Mercurial > hg > xemacs-beta

comparison lisp/vm/vm-digest.el @ 2:ac2d302a0011 r19-15b2

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-15b2
author cvs
date Mon, 13 Aug 2007 08:46:35 +0200
parents 376386a54a3c
children 49a24b4fd526
comparison
equal deleted inserted replaced
1:c0c6a60d29db 2:ac2d302a0011
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
212 294
213 (defun vm-rfc1153-or-rfc934-burst-message (m rfc1153) 295 (defun vm-rfc1153-or-rfc934-burst-message (m rfc1153)
214 "Burst messages from the digest message M. 296 "Burst messages from the digest message M.
215 M should be a message struct for a real message. 297 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 298 If RFC1153 is non-nil, assume the digest is of the form specified by
369 (cond 451 (cond
370 ((cond ((equal digest-type "rfc934") 452 ((cond ((equal digest-type "rfc934")
371 (vm-rfc934-burst-message m)) 453 (vm-rfc934-burst-message m))
372 ((equal digest-type "rfc1153") 454 ((equal digest-type "rfc1153")
373 (vm-rfc1153-burst-message m)) 455 (vm-rfc1153-burst-message m))
456 ((equal digest-type "rfc1521")
457 (error "Don't yet know how to burst MIME digests."))
374 (t (error "Unknown digest type: %s" digest-type))) 458 (t (error "Unknown digest type: %s" digest-type)))
375 (message "Bursting %s digest... done" digest-type) 459 (message "Bursting %s digest... done" digest-type)
376 (vm-clear-modification-flag-undos) 460 (vm-clear-modification-flag-undos)
377 (vm-set-buffer-modified-p t) 461 (vm-set-buffer-modified-p t)
378 (vm-increment vm-modification-counter) 462 (vm-increment vm-modification-counter)
391 ;; message, alter the new message count and confuse 475 ;; message, alter the new message count and confuse
392 ;; themselves. 476 ;; themselves.
393 (setq totals-blurb (vm-emit-totals-blurb)) 477 (setq totals-blurb (vm-emit-totals-blurb))
394 (vm-display nil nil '(vm-burst-digest 478 (vm-display nil nil '(vm-burst-digest
395 vm-burst-rfc934-digest 479 vm-burst-rfc934-digest
396 vm-burst-rfc1153-digest) 480 vm-burst-rfc1153-digest
481 vm-burst-rfc1521-digest)
397 (list this-command)) 482 (list this-command))
398 (if (vm-thoughtfully-select-message) 483 (if (vm-thoughtfully-select-message)
399 (vm-preview-current-message) 484 (vm-preview-current-message)
400 (vm-update-summary-and-mode-line)) 485 (vm-update-summary-and-mode-line))
401 (message totals-blurb))) 486 (message totals-blurb)))
408 (defun vm-burst-rfc1153-digest () 493 (defun vm-burst-rfc1153-digest ()
409 "Burst an RFC 1153 style digest" 494 "Burst an RFC 1153 style digest"
410 (interactive) 495 (interactive)
411 (vm-burst-digest "rfc1153")) 496 (vm-burst-digest "rfc1153"))
412 497
498 (defun vm-burst-rfc1521-digest ()
499 "Burst an RFC 1521 (MIME) style digest"
500 (interactive)
501 (vm-burst-digest "rfc1521"))
502
413 (defun vm-guess-digest-type (m) 503 (defun vm-guess-digest-type (m)
414 "Guess the digest type of the message M. 504 "Guess the digest type of the message M.
415 M should be the message struct of a real message. 505 M should be the message struct of a real message.
416 Returns either \"rfc934\" or \"rfc1153\"." 506 Returns either \"rfc934\", \"rfc1153\", or \"rfc1521\"."
417 (save-excursion 507 (save-excursion
418 (set-buffer (vm-buffer-of m)) 508 (set-buffer (vm-buffer-of m))
419 (save-excursion 509 (save-excursion
420 (save-restriction 510 (save-restriction
421 (widen) 511 (widen)
422 (goto-char (vm-text-of m)) 512 (goto-char (vm-headers-of m))
423 (if (search-forward "\n----------------------------------------------------------------------\n" nil t) 513 (if (let ((case-fold-search t))
424 "rfc1153" 514 (re-search-forward "^MIME-Version:" nil t))
425 "rfc934"))))) 515 "rfc1521"
516 (goto-char (vm-text-of m))
517 (if (search-forward "\n----------------------------------------------------------------------\n" nil t)
518 "rfc1153"
519 "rfc934"))))))