Mercurial > hg > xemacs-beta

comparison lisp/rmail/undigest.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 0293115a14e9
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
1 ;;; undigest.el --- digest-cracking support for the RMAIL mail reader
2
3 ;; Copyright (C) 1985, 1986, 1994 Free Software Foundation, Inc.
4
5 ;; Maintainer: FSF
6 ;; Keywords: mail
7
8 ;; This file is part of XEmacs.
9
10 ;; XEmacs is free software; you can redistribute it and/or modify it
11 ;; under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation; either version 2, or (at your option)
13 ;; any later version.
14
15 ;; XEmacs is distributed in the hope that it will be useful, but
16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
18 ;; General Public License for more details.
19
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with XEmacs; see the file COPYING. If not, write to the Free
22 ;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
23
24 ;;; Synched up with: FSF 19.30.
25
26 ;;; Commentary:
27
28 ;; See Internet RFC 934
29
30 ;;; Code:
31
32 (require 'rmail)
33
34 (defun undigestify-rmail-message ()
35 "Break up a digest message into its constituent messages.
36 Leaves original message, deleted, before the undigestified messages."
37 (interactive)
38 (widen)
39 (let ((buffer-read-only nil)
40 (msg-string (buffer-substring (rmail-msgbeg rmail-current-message)
41 (rmail-msgend rmail-current-message))))
42 (goto-char (rmail-msgend rmail-current-message))
43 (narrow-to-region (point) (point))
44 (insert msg-string)
45 (narrow-to-region (point-min) (1- (point-max))))
46 (let ((error t)
47 (buffer-read-only nil))
48 (unwind-protect
49 (progn
50 (save-restriction
51 (goto-char (point-min))
52 (delete-region (point-min)
53 (progn (search-forward "\n*** EOOH ***\n")
54 (point)))
55 (insert "\^_\^L\n0, unseen,,\n*** EOOH ***\n")
56 (narrow-to-region (point)
57 (point-max))
58 (let* ((fill-prefix "")
59 (case-fold-search t)
60 start
61 (digest-name
62 (mail-strip-quoted-names
63 (or (save-restriction
64 (search-forward "\n\n")
65 (setq start (point))
66 (narrow-to-region (point-min) (point))
67 (goto-char (point-max))
68 (or (mail-fetch-field "Reply-To")
69 (mail-fetch-field "To")
70 (mail-fetch-field "Apparently-To")
71 (mail-fetch-field "From")))
72 (error "Message is not a digest--bad header")))))
73 (save-excursion
74 (goto-char (point-max))
75 (skip-chars-backward " \t\n")
76 (let (found)
77 ;; compensate for broken un*x digestifiers. Sigh Sigh.
78 (while (and (> (point) start) (not found))
79 (forward-line -1)
80 (if (looking-at (concat "End of.*Digest.*\n"
81 (regexp-quote "*********") "*"
82 "\\(\n------*\\)*"))
83 (setq found t)))
84 (if (not found)
85 (error "Message is not a digest--no end line"))))
86 (re-search-forward (concat "^" (make-string 55 ?-) "-*\n*"))
87 (replace-match "\^_\^L\n0, unseen,,\n*** EOOH ***\n")
88 (save-restriction
89 (narrow-to-region (point)
90 (progn (search-forward "\n\n")
91 (point)))
92 (if (mail-fetch-field "To") nil
93 (goto-char (point-min))
94 (insert "To: " digest-name "\n")))
95 (while (re-search-forward
96 (concat "\n\n" (make-string 27 ?-) "-*\n*")
97 nil t)
98 (replace-match "\n\n\^_\^L\n0, unseen,,\n*** EOOH ***\n")
99 (save-restriction
100 (if (looking-at "End ")
101 (insert "To: " digest-name "\n\n")
102 (narrow-to-region (point)
103 (progn (search-forward "\n\n"
104 nil 'move)
105 (point))))
106 (if (mail-fetch-field "To")
107 nil
108 (goto-char (point-min))
109 (insert "To: " digest-name "\n")))
110 ;; Digestifiers may insert `- ' on lines that start with `-'.
111 ;; Undo that.
112 (save-excursion
113 (goto-char (point-min))
114 (if (re-search-forward
115 "\n\n----------------------------*\n*"
116 nil t)
117 (let ((end (point-marker)))
118 (goto-char (point-min))
119 (while (re-search-forward "^- " end t)
120 (delete-char -2)))))
121 )))
122 (setq error nil)
123 (message "Message successfully undigestified")
124 (let ((n rmail-current-message))
125 (rmail-forget-messages)
126 (rmail-show-message n)
127 (rmail-delete-forward)
128 (if (rmail-summary-exists)
129 (rmail-select-summary
130 (rmail-update-summary)))))
131 (cond (error
132 (narrow-to-region (point-min) (1+ (point-max)))
133 (delete-region (point-min) (point-max))
134 (rmail-show-message rmail-current-message))))))
135
136 ;;; undigest.el ends here