|
0
|
1 ;;; Message encapsulation
|
|
70
|
2 ;;; Copyright (C) 1989, 1990, 1993, 1994 Kyle E. Jones
|
|
0
|
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:\\)")
|
|
70
|
119 (vm-reorder-message-headers nil keep-list discard-regexp)
|
|
0
|
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:\\)")
|
|
70
|
202 (vm-reorder-message-headers nil keep-list discard-regexp)
|
|
0
|
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")
|
|
70
|
229 (setq prologue-separator-regexp "^-[^ ].*\n"
|
|
|
230 separator-regexp "^-[^ ].*\n"))
|
|
|
231 (save-excursion
|
|
|
232 (vm-save-restriction
|
|
0
|
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))
|
|
70
|
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)
|
|
0
|
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."))))
|
|
70
|
368 (vm-unsaved-message "Bursting %s digest..." digest-type)
|
|
0
|
369 (cond
|
|
70
|
370 ((cond ((equal digest-type "rfc934")
|
|
0
|
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)
|
|
70
|
384 (vm-delete-message 1)))
|
|
|
385 (vm-assimilate-new-messages t)
|
|
0
|
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
|
|
76
|
396 vm-burst-rfc1153-digest)
|
|
0
|
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.
|
|
76
|
416 Returns either \"rfc934\" or \"rfc1153\"."
|
|
70
|
417 (save-excursion
|
|
|
418 (set-buffer (vm-buffer-of m))
|
|
0
|
419 (save-excursion
|
|
|
420 (save-restriction
|
|
|
421 (widen)
|
|
76
|
422 (goto-char (vm-text-of m))
|
|
|
423 (if (search-forward "\n----------------------------------------------------------------------\n" nil t)
|
|
|
424 "rfc1153"
|
|
|
425 "rfc934")))))
|
