Mercurial > hg > xemacs-beta

comparison lisp/vm/vm-digest.el @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children ac2d302a0011
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
1 ;;; Message encapsulation
2 ;;; Copyright (C) 1989, 1990, 1993, 1994 Kyle E. Jones
3 ;;;
4 ;;; This program is free software; you can redistribute it and/or modify
5 ;;; it under the terms of the GNU General Public License as published by
6 ;;; the Free Software Foundation; either version 1, or (at your option)
7 ;;; any later version.
8 ;;;
9 ;;; This program is distributed in the hope that it will be useful,
10 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12 ;;; GNU General Public License for more details.
13 ;;;
14 ;;; You should have received a copy of the GNU General Public License
15 ;;; along with this program; if not, write to the Free Software
16 ;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
17
18 (provide 'vm-digest)
19
20 (defun vm-no-frills-encapsulate-message (m keep-list discard-regexp)
21 "Encapsulate a message M for forwarding, simply.
22 No message encapsulation standard is used. The message is
23 inserted at point in the current buffer, surrounded by two dashed
24 start/end separator lines. Point is not moved.
25
26 M should be a message struct for a real message, not a virtual message.
27 This is the message that will be encapsulated.
28 KEEP-LIST should be a list of regexps matching headers to keep.
29 DISCARD-REGEXP should be a regexp that matches headers to be discarded.
30 KEEP-LIST and DISCARD-REGEXP are used to order and trim the headers
31 to be forwarded. See the docs for vm-reorder-message-headers
32 to find out how KEEP-LIST and DISCARD-REGEXP are used."
33 (let ((target-buffer (current-buffer))
34 source-buffer)
35 (save-restriction
36 ;; narrow to a zero length region to avoid interacting
37 ;; with anything that might have already been inserted
38 ;; into the buffer.
39 (narrow-to-region (point) (point))
40 (insert "------- start of forwarded message -------\n")
41 (setq source-buffer (vm-buffer-of m))
42 (save-excursion
43 (set-buffer source-buffer)
44 (save-restriction
45 (widen)
46 (save-excursion
47 (set-buffer target-buffer)
48 (let ((beg (point)))
49 (insert-buffer-substring source-buffer (vm-headers-of m)
50 (vm-text-end-of m))
51 (goto-char beg)
52 (vm-reorder-message-headers nil nil "\\(X-VM-\\|Status:\\)")
53 (vm-reorder-message-headers nil keep-list discard-regexp)))))
54 (goto-char (point-max))
55 (insert "------- end of forwarded message -------\n"))))
56
57 (defun vm-rfc934-char-stuff-region (start end)
58 "Quote RFC 934 message separators between START and END.
59 START and END are buffer positions in the current buffer.
60 Lines beginning with `-' in the region have `- ' prepended to them."
61 (setq end (vm-marker end))
62 (save-excursion
63 (goto-char start)
64 (while (and (< (point) end) (re-search-forward "^-" end t))
65 (replace-match "- -" t t)))
66 (set-marker end nil))
67
68 (defun vm-rfc934-char-unstuff-region (start end)
69 "Unquote lines in between START and END as per RFC 934.
70 START and END are buffer positions in the current buffer.
71 Lines beginning with `- ' in the region have that string stripped
72 from them."
73 (setq end (vm-marker end))
74 (save-excursion
75 (goto-char start)
76 (while (and (< (point) end) (re-search-forward "^- " end t))
77 (replace-match "" t t)
78 (forward-char)))
79 (set-marker end nil))
80
81 (defun vm-rfc934-encapsulate-messages (message-list keep-list discard-regexp)
82 "Encapsulate the messages in MESSAGE-LIST as per RFC 934.
83 The resulting digest is inserted at point in the current buffer.
84 Point is not moved.
85
86 MESSAGE-LIST should be a list of message structs (real or virtual).
87 These are the messages that will be encapsulated.
88 KEEP-LIST should be a list of regexps matching headers to keep.
89 DISCARD-REGEXP should be a regexp that matches headers to be discarded.
90 KEEP-LIST and DISCARD-REGEXP are used to order and trim the headers
91 to be forwarded. See the docs for vm-reorder-message-headers
92 to find out how KEEP-LIST and DISCARD-REGEXP are used."
93 (if message-list
94 (let ((target-buffer (current-buffer))
95 (mlist message-list)
96 source-buffer m start n)
97 (save-restriction
98 ;; narrow to a zero length region to avoid interacting
99 ;; with anything that might have already been inserted
100 ;; into the buffer.
101 (narrow-to-region (point) (point))
102 (setq start (point))
103 (while mlist
104 (insert "---------------\n")
105 (setq m (vm-real-message-of (car mlist))
106 source-buffer (vm-buffer-of m))
107 (save-excursion
108 (set-buffer source-buffer)
109 (save-restriction
110 (widen)
111 (save-excursion
112 (set-buffer target-buffer)
113 (let ((beg (point)))
114 (insert-buffer-substring source-buffer (vm-headers-of m)
115 (vm-text-end-of m))
116 (goto-char beg)
117 (vm-reorder-message-headers nil nil
118 "\\(X-VM-\\|Status:\\)")
119 (vm-reorder-message-headers nil keep-list discard-regexp)
120 (vm-rfc934-char-stuff-region beg (point-max))))))
121 (goto-char (point-max))
122 (insert "---------------")
123 (setq mlist (cdr mlist)))
124 (delete-region (point) (progn (beginning-of-line) (point)))
125 (insert "------- end -------\n")
126 (goto-char start)
127 (delete-region (point) (progn (forward-line 1) (point)))
128 (setq n (length message-list))
129 (insert (format "------- start of %s%s(RFC 934 encapsulation) -------\n"
130 (if (cdr message-list)
131 "digest "
132 "forwarded message ")
133 (if (cdr message-list)
134 (format "(%d messages) " n)
135 "")))
136 (goto-char start)))))
137
138 (defun vm-rfc1153-char-stuff-region (start end)
139 "Quote RFC 1153 message separators between START and END.
140 START and END are buffer positions in the current buffer.
141 Lines consisting only of 30 hyphens have the first hyphen
142 converted to a space."
143 (setq end (vm-marker end))
144 (save-excursion
145 (goto-char start)
146 (while (and (< (point) end)
147 (re-search-forward "^------------------------------$" end t))
148 (replace-match " -----------------------------" t t)))
149 (set-marker end nil))
150
151 (defun vm-rfc1153-char-unstuff-region (start end)
152 "Unquote lines in between START and END as per RFC 1153.
153 START and END are buffer positions in the current buffer.
154 Lines consisting only of a space following by 29 hyphens have the space
155 converted to a hyphen."
156 (setq end (vm-marker end))
157 (save-excursion
158 (goto-char start)
159 (while (and (< (point) end)
160 (re-search-forward "^ -----------------------------$" end t))
161 (replace-match "------------------------------" t t)))
162 (set-marker end nil))
163
164 (defun vm-rfc1153-encapsulate-messages (message-list keep-list discard-regexp)
165 "Encapsulate the messages in MESSAGE-LIST as per RFC 1153.
166 The resulting digest is inserted at point in the current buffer.
167 Point is not moved.
168
169 MESSAGE-LIST should be a list of message structs (real or virtual).
170 These are the messages that will be encapsulated.
171 KEEP-LIST should be a list of regexps matching headers to keep.
172 DISCARD-REGEXP should be a regexp that matches headers to be discarded.
173 KEEP-LIST and DISCARD-REGEXP are used to order and trim the headers
174 to be forwarded. See the docs for vm-reorder-message-headers
175 to find out how KEEP-LIST and DISCARD-REGEXP are used."
176 (if message-list
177 (let ((target-buffer (current-buffer))
178 (mlist message-list)
179 source-buffer m start)
180 (save-restriction
181 ;; narrow to a zero length region to avoid interacting
182 ;; with anything that might have already been inserted
183 ;; into the buffer.
184 (narrow-to-region (point) (point))
185 (setq start (point))
186 (while mlist
187 (insert "---------------\n\n")
188 (setq m (vm-real-message-of (car mlist))
189 source-buffer (vm-buffer-of m))
190 (save-excursion
191 (set-buffer source-buffer)
192 (save-restriction
193 (widen)
194 (save-excursion
195 (set-buffer target-buffer)
196 (let ((beg (point)))
197 (insert-buffer-substring source-buffer (vm-headers-of m)
198 (vm-text-end-of m))
199 (goto-char beg)
200 (vm-reorder-message-headers nil nil
201 "\\(X-VM-\\|Status:\\)")
202 (vm-reorder-message-headers nil keep-list discard-regexp)
203 (vm-rfc1153-char-stuff-region beg (point-max))))))
204 (goto-char (point-max))
205 (insert "\n---------------")
206 (setq mlist (cdr mlist)))
207 (insert "---------------\n\nEnd of this Digest\n******************\n")
208 (goto-char start)
209 (delete-region (point) (progn (forward-line 1) (point)))
210 (insert (format "This is an RFC 1153 digest.\n(%d message%s)\n----------------------------------------------------------------------\n" (length message-list) (if (cdr message-list) "s" "")))
211 (goto-char start)))))
212
213 (defun vm-rfc1153-or-rfc934-burst-message (m rfc1153)
214 "Burst messages from the digest message M.
215 M should be a message struct for a real message.
216 If RFC1153 is non-nil, assume the digest is of the form specified by
217 RFC 1153. Otherwise assume RFC 934 digests."
218 (let ((work-buffer nil)
219 (match t)
220 (prev-sep nil)
221 (ident-header nil)
222 after-prev-sep prologue-separator-regexp separator-regexp
223 (folder-type vm-folder-type))
224 (if vm-digest-identifier-header-format
225 (setq ident-header (vm-sprintf 'vm-digest-identifier-header-format m)))
226 (if rfc1153
227 (setq prologue-separator-regexp "^----------------------------------------------------------------------\n"
228 separator-regexp "^------------------------------\n")
229 (setq prologue-separator-regexp "^-[^ ].*\n"
230 separator-regexp "^-[^ ].*\n"))
231 (save-excursion
232 (vm-save-restriction
233 (widen)
234 (unwind-protect
235 (catch 'done
236 (setq work-buffer (generate-new-buffer "*vm-work*"))
237 (set-buffer work-buffer)
238 (insert-buffer-substring (vm-buffer-of m)
239 (vm-text-of m)
240 (vm-text-end-of m))
241 (goto-char (point-min))
242 (if (not (re-search-forward prologue-separator-regexp nil t))
243 (throw 'done nil))
244 ;; think of this as a do-while loop.
245 (while match
246 (cond ((null prev-sep)
247 ;; from (point-min) to end of match
248 ;; is the digest prologue, devour it and
249 ;; carry on.
250 (delete-region (point-min) (match-end 0)))
251 (t
252 ;; munge previous messages message separators
253 (let ((md (match-data)))
254 (unwind-protect
255 (vm-munge-message-separators
256 folder-type
257 after-prev-sep
258 (match-beginning 0))
259 (store-match-data md)))
260 ;; eat preceding newlines
261 (while (= (preceding-char) ?\n)
262 (delete-char -1))
263 ;; put one back
264 (insert ?\n)))
265 ;; insert a trailing message separator
266 ;; delete the digest separator
267 ;; insert the leading separator
268 (if prev-sep
269 (progn
270 (delete-region (match-beginning 0) (match-end 0))
271 (insert (vm-trailing-message-separator folder-type))))
272 (setq prev-sep (point))
273 (insert (vm-leading-message-separator folder-type))
274 (setq after-prev-sep (point))
275 ;; eat trailing newlines
276 (while (= (following-char) ?\n)
277 (delete-char 1))
278 (insert ident-header)
279 ;; try to match message separator and repeat.
280 (setq match (re-search-forward separator-regexp nil t)))
281 ;; from the last separator to eof is the digest epilogue.
282 ;; discard it.
283 (delete-region (or prev-sep (point-min)) (point-max))
284 ;; Undo the quoting of the embedded message
285 ;; separators. This must be done before header
286 ;; conversions, else the Content-Length offsets might be
287 ;; rendered invalid by buffer size changes.
288 (if rfc1153
289 (vm-rfc1153-char-unstuff-region (point-min) (point-max))
290 (vm-rfc934-char-unstuff-region (point-min) (point-max)))
291 ;; do header conversions.
292 (let ((vm-folder-type folder-type))
293 (goto-char (point-min))
294 (while (vm-find-leading-message-separator)
295 (vm-skip-past-leading-message-separator)
296 (vm-convert-folder-type-headers folder-type folder-type)
297 (vm-find-trailing-message-separator)
298 (vm-skip-past-trailing-message-separator)))
299 ;; now insert the messages into the folder buffer
300 (cond ((not (zerop (buffer-size)))
301 (set-buffer (vm-buffer-of m))
302 (let ((old-buffer-modified-p (buffer-modified-p))
303 (buffer-read-only nil)
304 (inhibit-quit t))
305 (goto-char (point-max))
306 (insert-buffer-substring work-buffer)
307 (set-buffer-modified-p old-buffer-modified-p)
308 ;; return non-nil so caller knows we found some messages
309 t ))
310 ;; return nil so the caller knows we didn't find anything
311 (t nil)))
312 (and work-buffer (kill-buffer work-buffer)))))))
313
314 (defun vm-rfc934-burst-message (m)
315 "Burst messages from the RFC 934 digest message M.
316 M should be a message struct for a real message."
317 (vm-rfc1153-or-rfc934-burst-message m nil))
318
319 (defun vm-rfc1153-burst-message (m)
320 "Burst messages from the RFC 1153 digest message M.
321 M should be a message struct for a real message."
322 (vm-rfc1153-or-rfc934-burst-message m t))
323
324 (defun vm-burst-digest (&optional digest-type)
325 "Burst the current message (a digest) into its individual messages.
326 The digest's messages are assimilated into the folder as new mail
327 would be.
328
329 Optional argument DIGEST-TYPE is a string that tells VM what kind
330 of digest the current message is. If it is not given the value
331 defaults to the value of vm-digest-burst-type. When called
332 interactively DIGEST-TYPE will be read from the minibuffer.
333
334 If invoked on marked messages (via vm-next-command-uses-marks),
335 all marked messages will be burst."
336 (interactive
337 (list
338 (let ((type nil)
339 (this-command this-command)
340 (last-command last-command))
341 (setq type (completing-read (format "Digest type: (default %s) "
342 vm-digest-burst-type)
343 (append vm-digest-type-alist
344 (list '("guess")))
345 'identity nil))
346 (if (string= type "")
347 vm-digest-burst-type
348 type ))))
349 (or digest-type (setq digest-type vm-digest-burst-type))
350 (vm-follow-summary-cursor)
351 (vm-select-folder-buffer)
352 (vm-check-for-killed-summary)
353 (vm-error-if-folder-empty)
354 (let ((start-buffer (current-buffer)) m totals-blurb
355 (mlist (vm-select-marked-or-prefixed-messages 1)))
356 (while mlist
357 (if (vm-virtual-message-p (car mlist))
358 (progn
359 (setq m (vm-real-message-of (car mlist)))
360 (set-buffer (vm-buffer-of m)))
361 (setq m (car mlist)))
362 (vm-error-if-folder-read-only)
363 (if (equal digest-type "guess")
364 (progn
365 (setq digest-type (vm-guess-digest-type m))
366 (if (null digest-type)
367 (error "Couldn't guess digest type."))))
368 (vm-unsaved-message "Bursting %s digest..." digest-type)
369 (cond
370 ((cond ((equal digest-type "rfc934")
371 (vm-rfc934-burst-message m))
372 ((equal digest-type "rfc1153")
373 (vm-rfc1153-burst-message m))
374 (t (error "Unknown digest type: %s" digest-type)))
375 (message "Bursting %s digest... done" digest-type)
376 (vm-clear-modification-flag-undos)
377 (vm-set-buffer-modified-p t)
378 (vm-increment vm-modification-counter)
379 (and vm-delete-after-bursting
380 ;; if start folder was virtual, we're now in the wrong
381 ;; buffer. switch back.
382 (save-excursion
383 (set-buffer start-buffer)
384 (vm-delete-message 1)))
385 (vm-assimilate-new-messages t)
386 ;; do this now so if we error later in another iteration
387 ;; of the loop the summary and mode line will be correct.
388 (vm-update-summary-and-mode-line)))
389 (setq mlist (cdr mlist)))
390 ;; collect this data NOW, before the non-previewers read a
391 ;; message, alter the new message count and confuse
392 ;; themselves.
393 (setq totals-blurb (vm-emit-totals-blurb))
394 (vm-display nil nil '(vm-burst-digest
395 vm-burst-rfc934-digest
396 vm-burst-rfc1153-digest)
397 (list this-command))
398 (if (vm-thoughtfully-select-message)
399 (vm-preview-current-message)
400 (vm-update-summary-and-mode-line))
401 (message totals-blurb)))
402
403 (defun vm-burst-rfc934-digest ()
404 "Burst an RFC 934 style digest"
405 (interactive)
406 (vm-burst-digest "rfc934"))
407
408 (defun vm-burst-rfc1153-digest ()
409 "Burst an RFC 1153 style digest"
410 (interactive)
411 (vm-burst-digest "rfc1153"))
412
413 (defun vm-guess-digest-type (m)
414 "Guess the digest type of the message M.
415 M should be the message struct of a real message.
416 Returns either \"rfc934\" or \"rfc1153\"."
417 (save-excursion
418 (set-buffer (vm-buffer-of m))
419 (save-excursion
420 (save-restriction
421 (widen)
422 (goto-char (vm-text-of m))
423 (if (search-forward "\n----------------------------------------------------------------------\n" nil t)
424 "rfc1153"
425 "rfc934")))))