Mercurial > hg > xemacs-beta

comparison lisp/vm/vm-digest.el @ 10:49a24b4fd526 r19-15b6

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-15b6
author cvs
date Mon, 13 Aug 2007 08:47:52 +0200
parents ac2d302a0011
children 859a2309aef8
comparison
equal deleted inserted replaced
9:6f2bbbbbe05a 10:49a24b4fd526
207 (insert "---------------\n\nEnd of this Digest\n******************\n") 207 (insert "---------------\n\nEnd of this Digest\n******************\n")
208 (goto-char start) 208 (goto-char start)
209 (delete-region (point) (progn (forward-line 1) (point))) 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" ""))) 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))))) 211 (goto-char start)))))
212
213 (defun vm-rfc1521-encapsulate-messages (message-list keep-list discard-regexp)
214 "Encapsulate the messages in MESSAGE-LIST as per RFC 1521 (MIME).
215 The resulting digest is inserted at point in the current buffer.
216 MIME headers at point-max are added/updated.
217 Point is not moved.
218
219 MESSAGE-LIST should be a list of message structs (real or virtual).
220 These are the messages that will be encapsulated.
221 KEEP-LIST should be a list of regexps matching headers to keep.
222 DISCARD-REGEXP should be a regexp that matches headers to be discarded.
223 KEEP-LIST and DISCARD-REGEXP are used to order and trim the headers
224 to be forwarded. See the docs for vm-reorder-message-headers
225 to find out how KEEP-LIST and DISCARD-REGEXP are used."
226 (if message-list
227 (let ((target-buffer (current-buffer))
228 (mlist message-list)
229 (boundary (format "-----%07X%07X" (abs (random)) (abs (random))))
230 ; insertion-point
231 source-buffer m start)
232 (save-restriction
233 ;; narrow to a zero length region to avoid interacting
234 ;; with anything that might have already been inserted
235 ;; into the buffer.
236 (narrow-to-region (point) (point))
237 (setq start (point))
238 (while mlist
239 (insert "--" boundary "\nContent-Type: message/rfc822\n\n")
240 (setq m (vm-real-message-of (car mlist))
241 source-buffer (vm-buffer-of m))
242 (save-excursion
243 (set-buffer source-buffer)
244 (save-restriction
245 (widen)
246 (save-excursion
247 (set-buffer target-buffer)
248 (let ((beg (point)))
249 (insert-buffer-substring source-buffer (vm-headers-of m)
250 (vm-text-end-of m))
251 (goto-char beg)
252 (vm-reorder-message-headers nil nil
253 "\\(X-VM-\\|Status:\\)")
254 (vm-reorder-message-headers nil keep-list discard-regexp)
255 ))))
256 (goto-char (point-max))
257 (insert "\n")
258 (setq mlist (cdr mlist)))
259 (insert "--" boundary "--\n")
260
261 (goto-char start)
262 (insert "--" boundary "\nContent-Type: text/plain\n\n")
263 (insert (format
264 "This is an RFC 1521 (MIME) digest; %d message%s.\n\n\n\n\n"
265 (length message-list)
266 (if (cdr message-list) "s" "")))
267 ; (setq insertion-point (point-marker))
268 (goto-char start))
269
270 ;; outside of the save-restriction
271 (save-excursion
272 (let (end)
273 (goto-char (point-min))
274 (re-search-forward
275 (concat "^" (regexp-quote mail-header-separator) "$")
276 nil t)
277 (setq end (point))
278 (goto-char (point-min))
279 (cond
280 ((re-search-forward "^content-type:" end t)
281 (delete-region (point) (progn (forward-line 1) (point)))
282 (while (looking-at " \t")
283 (delete-region (point) (progn (forward-line 1) (point))))))
284 (goto-char end)
285 (insert "MIME-Version: 1.0\n"
286 "Content-Type: multipart/digest; boundary=\""
287 boundary "\"\n")
288 ))
289
290 ; (goto-char insertion-point)
291 ; (set-marker insertion-point nil)
292 )))
293
294 212
295 (defun vm-rfc1153-or-rfc934-burst-message (m rfc1153) 213 (defun vm-rfc1153-or-rfc934-burst-message (m rfc1153)
296 "Burst messages from the digest message M. 214 "Burst messages from the digest message M.
297 M should be a message struct for a real message. 215 M should be a message struct for a real message.
298 If RFC1153 is non-nil, assume the digest is of the form specified by 216 If RFC1153 is non-nil, assume the digest is of the form specified by
451 (cond 369 (cond
452 ((cond ((equal digest-type "rfc934") 370 ((cond ((equal digest-type "rfc934")
453 (vm-rfc934-burst-message m)) 371 (vm-rfc934-burst-message m))
454 ((equal digest-type "rfc1153") 372 ((equal digest-type "rfc1153")
455 (vm-rfc1153-burst-message m)) 373 (vm-rfc1153-burst-message m))
456 ((equal digest-type "rfc1521")
457 (error "Don't yet know how to burst MIME digests."))
458 (t (error "Unknown digest type: %s" digest-type))) 374 (t (error "Unknown digest type: %s" digest-type)))
459 (message "Bursting %s digest... done" digest-type) 375 (message "Bursting %s digest... done" digest-type)
460 (vm-clear-modification-flag-undos) 376 (vm-clear-modification-flag-undos)
461 (vm-set-buffer-modified-p t) 377 (vm-set-buffer-modified-p t)
462 (vm-increment vm-modification-counter) 378 (vm-increment vm-modification-counter)
475 ;; message, alter the new message count and confuse 391 ;; message, alter the new message count and confuse
476 ;; themselves. 392 ;; themselves.
477 (setq totals-blurb (vm-emit-totals-blurb)) 393 (setq totals-blurb (vm-emit-totals-blurb))
478 (vm-display nil nil '(vm-burst-digest 394 (vm-display nil nil '(vm-burst-digest
479 vm-burst-rfc934-digest 395 vm-burst-rfc934-digest
480 vm-burst-rfc1153-digest 396 vm-burst-rfc1153-digest)
481 vm-burst-rfc1521-digest)
482 (list this-command)) 397 (list this-command))
483 (if (vm-thoughtfully-select-message) 398 (if (vm-thoughtfully-select-message)
484 (vm-preview-current-message) 399 (vm-preview-current-message)
485 (vm-update-summary-and-mode-line)) 400 (vm-update-summary-and-mode-line))
486 (message totals-blurb))) 401 (message totals-blurb)))
493 (defun vm-burst-rfc1153-digest () 408 (defun vm-burst-rfc1153-digest ()
494 "Burst an RFC 1153 style digest" 409 "Burst an RFC 1153 style digest"
495 (interactive) 410 (interactive)
496 (vm-burst-digest "rfc1153")) 411 (vm-burst-digest "rfc1153"))
497 412
498 (defun vm-burst-rfc1521-digest ()
499 "Burst an RFC 1521 (MIME) style digest"
500 (interactive)
501 (vm-burst-digest "rfc1521"))
502
503 (defun vm-guess-digest-type (m) 413 (defun vm-guess-digest-type (m)
504 "Guess the digest type of the message M. 414 "Guess the digest type of the message M.
505 M should be the message struct of a real message. 415 M should be the message struct of a real message.
506 Returns either \"rfc934\", \"rfc1153\", or \"rfc1521\"." 416 Returns either \"rfc934\" or \"rfc1153\"."
507 (save-excursion 417 (save-excursion
508 (set-buffer (vm-buffer-of m)) 418 (set-buffer (vm-buffer-of m))
509 (save-excursion 419 (save-excursion
510 (save-restriction 420 (save-restriction
511 (widen) 421 (widen)
512 (goto-char (vm-headers-of m)) 422 (goto-char (vm-text-of m))
513 (if (let ((case-fold-search t)) 423 (if (search-forward "\n----------------------------------------------------------------------\n" nil t)
514 (re-search-forward "^MIME-Version:" nil t)) 424 "rfc1153"
515 "rfc1521" 425 "rfc934")))))
516 (goto-char (vm-text-of m))
517 (if (search-forward "\n----------------------------------------------------------------------\n" nil t)
518 "rfc1153"
519 "rfc934"))))))