Mercurial > emacs
comparison lisp/mail/unrmail.el @ 88155:d7ddb3e565de
sync with trunk
author | Henrik Enberg <henrik.enberg@telia.com> |
---|---|
date | Mon, 16 Jan 2006 00:03:54 +0000 |
parents | ef41980f1588 |
children | 6e97bfe9f7f0 |
comparison
equal
deleted
inserted
replaced
88154:8ce476d3ba36 | 88155:d7ddb3e565de |
---|---|
1 ;;; unrmail.el --- convert Rmail files to mailbox files | 1 ;;; unrmail.el --- convert Rmail files to mailbox files |
2 | 2 |
3 ;;; Copyright (C) 1992, 2002, 2004 Free Software Foundation, Inc. | 3 ;;; Copyright (C) 1992, 2002, 2003, 2004, 2005 Free Software Foundation, Inc. |
4 | 4 |
5 ;; Maintainer: FSF | 5 ;; Maintainer: FSF |
6 ;; Keywords: mail | 6 ;; Keywords: mail |
7 | 7 |
8 ;; This file is part of GNU Emacs. | 8 ;; This file is part of GNU Emacs. |
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | 17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
18 ;; GNU General Public License for more details. | 18 ;; GNU General Public License for more details. |
19 | 19 |
20 ;; You should have received a copy of the GNU General Public License | 20 ;; You should have received a copy of the GNU General Public License |
21 ;; along with GNU Emacs; see the file COPYING. If not, write to the | 21 ;; along with GNU Emacs; see the file COPYING. If not, write to the |
22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, | 22 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, |
23 ;; Boston, MA 02111-1307, USA. | 23 ;; Boston, MA 02110-1301, USA. |
24 | 24 |
25 ;;; Commentary: | 25 ;;; Commentary: |
26 | 26 |
27 ;;; Code: | 27 ;;; Code: |
28 | 28 |
29 (defvar command-line-args-left) ;Avoid 'free variable' warning | 29 (defvar command-line-args-left) ;Avoid 'free variable' warning |
30 | 30 |
31 ;;;###autoload | 31 ;;;###autoload |
32 (defun batch-convert-babyl () | 32 (defun batch-unrmail () |
33 "Convert Babyl files (old Rmail file) to system inbox format. | 33 "Convert Rmail files to system inbox format. |
34 Specify the input Babyl file names as command line arguments. | 34 Specify the input Rmail file names as command line arguments. |
35 For each Babyl file, the corresponding output file name | 35 For each Rmail file, the corresponding output file name |
36 is made by adding `.mail' at the end. | 36 is made by adding `.mail' at the end. |
37 For example, invoke `emacs -batch -f batch-unrmail RMAIL'." | 37 For example, invoke `emacs -batch -f batch-unrmail RMAIL'." |
38 ;; command-line-args-left is what is left of the command line (from startup.el) | 38 ;; command-line-args-left is what is left of the command line (from startup.el) |
39 (if (not noninteractive) | 39 (if (not noninteractive) |
40 (error "`batch-unrmail' is to be used only with -batch")) | 40 (error "`batch-unrmail' is to be used only with -batch")) |
46 (setq command-line-args-left (cdr command-line-args-left))) | 46 (setq command-line-args-left (cdr command-line-args-left))) |
47 (message "Done") | 47 (message "Done") |
48 (kill-emacs (if error 1 0)))) | 48 (kill-emacs (if error 1 0)))) |
49 | 49 |
50 ;;;###autoload | 50 ;;;###autoload |
51 (defalias 'batch-unrmail 'batch-convert-babyl) | 51 (defun unrmail (file to-file) |
52 | 52 "Convert Rmail file FILE to system inbox format file TO-FILE." |
53 ;;;###autoload | |
54 (defun convert-babyl-file (file to-file) | |
55 "Convert Babyl (old Rmail) file FILE to system inbox format file TO-FILE." | |
56 (interactive "fUnrmail (rmail file): \nFUnrmail into (new mailbox file): ") | 53 (interactive "fUnrmail (rmail file): \nFUnrmail into (new mailbox file): ") |
57 (with-temp-buffer | 54 (with-temp-buffer |
58 (decode-babyl-file file) | 55 ;; Read in the old Rmail file with no decoding. |
59 ;; Write it to the output file. | 56 (let ((coding-system-for-read 'raw-text)) |
60 ;; Since the file may contain messages of different encodings | 57 (insert-file-contents file)) |
61 ;; at the tail (non-BYBYL part), we can't decode them at once | 58 ;; But make it multibyte. |
62 ;; on reading. So, at first, we read the file without text | 59 (set-buffer-multibyte t) |
63 ;; code conversion, then decode the messages one by one by | 60 |
64 ;; rmail-decode-babyl-format or | 61 (if (not (looking-at "BABYL OPTIONS")) |
65 ;; rmail-convert-to-babyl-format. | 62 (error "This file is not in Babyl format")) |
66 (let ((coding-system-for-write 'raw-text)) | 63 |
67 (write-region (point-min) (point-max) to-file nil | 64 ;; Decode the file contents just as Rmail did. |
68 'nomsg)))) | 65 (let ((modifiedp (buffer-modified-p)) |
69 | 66 (coding-system rmail-file-coding-system) |
70 ;;;###autoload | 67 from to) |
71 (defalias 'unrmail 'convert-babyl-file) | 68 (goto-char (point-min)) |
72 | 69 (search-forward "\n\^_" nil t) ; Skip BABYL header. |
73 ;;;###autoload | 70 (setq from (point)) |
74 (defun decode-babyl-file (file) | 71 (goto-char (point-max)) |
75 "Convert Babyl file FILE to system inbox format in current buffer." | 72 (search-backward "\n\^_" from 'mv) |
76 (interactive "fUnrmail (rmail file): ") | 73 (setq to (point)) |
77 ;; Read in the Babyl file with no decoding. | 74 (unless (and coding-system |
78 (let ((thisbuf (current-buffer))) | 75 (coding-system-p coding-system)) |
79 (with-temp-buffer | 76 (setq coding-system |
80 (let ((coding-system-for-read 'raw-text)) | 77 ;; Emacs 21.1 and later writes RMAIL files in emacs-mule, but |
81 (insert-file-contents file)) | 78 ;; earlier versions did that with the current buffer's encoding. |
82 ;; But make it multibyte. | 79 ;; So we want to favor detection of emacs-mule (whose normal |
83 (set-buffer-multibyte t) | 80 ;; priority is quite low), but still allow detection of other |
84 | 81 ;; encodings if emacs-mule won't fit. The call to |
85 (if (not (looking-at "BABYL OPTIONS")) | 82 ;; detect-coding-with-priority below achieves that. |
86 (error "File %s not in Babyl format")) | 83 (car (detect-coding-with-priority |
87 | 84 from to |
88 (decode-babyl thisbuf)))) | 85 '((coding-category-emacs-mule . emacs-mule)))))) |
89 | 86 (unless (memq coding-system |
90 ;;;###autoload | 87 '(undecided undecided-unix)) |
91 (defun decode-babyl (outbuf) | 88 (set-buffer-modified-p t) ; avoid locking when decoding |
92 "Convert Babyl data in current bufer to inbox format and store in OUTBUF." | 89 (let ((buffer-undo-list t)) |
93 ;; Decode the file contents just as Rmail did. | 90 (decode-coding-region from to coding-system)) |
94 (let ((modifiedp (buffer-modified-p)) | 91 (setq coding-system last-coding-system-used)) |
95 (coding-system rmail-file-coding-system) | 92 |
96 from to) | 93 (setq buffer-file-coding-system nil) |
94 | |
95 ;; We currently don't use this value, but maybe we should. | |
96 (setq save-buffer-coding-system | |
97 (or coding-system 'undecided))) | |
98 | |
99 ;; Default the directory of TO-FILE based on where FILE is. | |
100 (setq to-file (expand-file-name to-file default-directory)) | |
101 (condition-case () | |
102 (delete-file to-file) | |
103 (file-error nil)) | |
104 (message "Writing messages to %s..." to-file) | |
97 (goto-char (point-min)) | 105 (goto-char (point-min)) |
98 (search-forward "\n\^_" nil t) ; Skip BABYL header. | 106 |
99 (setq from (point)) | 107 (let ((temp-buffer (get-buffer-create " unrmail")) |
100 (goto-char (point-max)) | 108 (from-buffer (current-buffer))) |
101 (search-backward "\n\^_" from 'mv) | 109 |
102 (setq to (point)) | 110 ;; Process the messages one by one. |
103 (unless (and coding-system | 111 (while (search-forward "\^_\^l" nil t) |
104 (coding-system-p coding-system)) | 112 (let ((beg (point)) |
105 (setq coding-system | 113 (end (save-excursion |
106 ;; Emacs 21.1 and later writes RMAIL files in emacs-mule, but | 114 (if (search-forward "\^_" nil t) |
107 ;; earlier versions did that with the current buffer's encoding. | 115 (1- (point)) (point-max)))) |
108 ;; So we want to favor detection of emacs-mule (whose normal | 116 (coding 'raw-text) |
109 ;; priority is quite low), but still allow detection of other | 117 label-line attrs keywords |
110 ;; encodings if emacs-mule won't fit. The call to | 118 mail-from reformatted) |
111 ;; detect-coding-with-priority below achieves that. | 119 (with-current-buffer temp-buffer |
112 (car (detect-coding-with-priority | 120 (setq buffer-undo-list t) |
113 from to | 121 (erase-buffer) |
114 '((coding-category-emacs-mule . emacs-mule)))))) | 122 (setq buffer-file-coding-system coding) |
115 (unless (memq coding-system | 123 (insert-buffer-substring from-buffer beg end) |
116 '(undecided undecided-unix)) | 124 (goto-char (point-min)) |
117 (set-buffer-modified-p t) ; avoid locking when decoding | 125 (forward-line 1) |
118 (let ((buffer-undo-list t)) | 126 ;; Record whether the header is reformatted. |
119 (decode-coding-region from to coding-system)) | 127 (setq reformatted (= (following-char) ?1)) |
120 (setq coding-system last-coding-system-used)) | 128 |
121 | 129 ;; Collect the label line, then get the attributes |
122 (setq buffer-file-coding-system nil) | 130 ;; and the keywords from it. |
123 | 131 (setq label-line |
124 ;; We currently don't use this value, but maybe we should. | |
125 (setq save-buffer-coding-system | |
126 (or coding-system 'undecided))) | |
127 | |
128 (goto-char (point-min)) | |
129 | |
130 (let ((temp-buffer (get-buffer-create " unrmail")) | |
131 (from-buffer (current-buffer))) | |
132 | |
133 ;; Process the messages one by one. | |
134 (while (search-forward "\^_\^l" nil t) | |
135 (let ((beg (point)) | |
136 (end (save-excursion | |
137 (if (search-forward "\^_" nil t) | |
138 (1- (point)) (point-max)))) | |
139 (coding 'raw-text) | |
140 label-line attrs keywords | |
141 mail-from reformatted) | |
142 (with-current-buffer temp-buffer | |
143 (setq buffer-undo-list t) | |
144 (erase-buffer) | |
145 (setq buffer-file-coding-system coding) | |
146 (insert-buffer-substring from-buffer beg end) | |
147 (goto-char (point-min)) | |
148 (forward-line 1) | |
149 ;; Record whether the header is reformatted. | |
150 (setq reformatted (= (following-char) ?1)) | |
151 | |
152 ;; Collect the label line, then get the attributes | |
153 ;; and the keywords from it. | |
154 (setq label-line | |
155 (buffer-substring (point) | |
156 (save-excursion (forward-line 1) | |
157 (point)))) | |
158 (search-forward ",,") | |
159 (unless (eolp) | |
160 (setq keywords | |
161 (buffer-substring (point) | 132 (buffer-substring (point) |
162 (progn (end-of-line) | 133 (save-excursion (forward-line 1) |
163 (1- (point))))) | 134 (point)))) |
164 (setq keywords | 135 (search-forward ",,") |
165 (replace-regexp-in-string ", " "," keywords))) | 136 (unless (eolp) |
166 | 137 (setq keywords |
167 (setq attrs | 138 (buffer-substring (point) |
168 (list | 139 (progn (end-of-line) |
169 (if (string-match ", answered," label-line) ?A ?-) | 140 (1- (point))))) |
170 (if (string-match ", deleted," label-line) ?D ?-) | 141 (setq keywords |
171 (if (string-match ", edited," label-line) ?E ?-) | 142 (replace-regexp-in-string ", " "," keywords))) |
172 (if (string-match ", filed," label-line) ?F ?-) | 143 |
173 (if (string-match ", resent," label-line) ?R ?-) | 144 (setq attrs |
174 (if (string-match ", unseen," label-line) ?\ ?-) | 145 (list |
175 (if (string-match ", stored," label-line) ?S ?-))) | 146 (if (string-match ", answered," label-line) ?A ?-) |
176 | 147 (if (string-match ", deleted," label-line) ?D ?-) |
177 ;; Delete the special Babyl lines at the start, | 148 (if (string-match ", edited," label-line) ?E ?-) |
178 ;; and the ***EOOH*** line, and the reformatted header if any. | 149 (if (string-match ", filed," label-line) ?F ?-) |
179 (goto-char (point-min)) | 150 (if (string-match ", resent," label-line) ?R ?-) |
180 (if reformatted | 151 (if (string-match ", unseen," label-line) ?\ ?-) |
181 (progn | 152 (if (string-match ", stored," label-line) ?S ?-))) |
182 (forward-line 2) | 153 |
183 ;; Delete Summary-Line headers. | 154 ;; Delete the special Babyl lines at the start, |
184 (let ((case-fold-search t)) | 155 ;; and the ***EOOH*** line, and the reformatted header if any. |
185 (while (looking-at "Summary-Line:") | 156 (goto-char (point-min)) |
186 (forward-line 1))) | 157 (if reformatted |
187 (delete-region (point-min) (point)) | 158 (progn |
188 ;; Delete the old reformatted header. | 159 (forward-line 2) |
189 (re-search-forward "^[*][*][*] EOOH [*][*][*]\n") | 160 ;; Delete Summary-Line headers. |
190 (forward-line -1) | 161 (let ((case-fold-search t)) |
191 (let ((start (point))) | 162 (while (looking-at "Summary-Line:") |
192 (search-forward "\n\n") | 163 (forward-line 1))) |
193 (delete-region start (point)))) | 164 (delete-region (point-min) (point)) |
194 ;; Not reformatted. Delete the special | 165 ;; Delete the old reformatted header. |
195 ;; lines before the real header. | 166 (re-search-forward "^[*][*][*] EOOH [*][*][*]\n") |
196 (re-search-forward "^[*][*][*] EOOH [*][*][*]\n") | 167 (forward-line -1) |
197 (delete-region (point-min) (point))) | 168 (let ((start (point))) |
198 | 169 (search-forward "\n\n") |
199 ;; Some operations on the message header itself. | 170 (delete-region start (point)))) |
200 (goto-char (point-min)) | 171 ;; Not reformatted. Delete the special |
201 (save-restriction | 172 ;; lines before the real header. |
202 (narrow-to-region | 173 (re-search-forward "^[*][*][*] EOOH [*][*][*]\n") |
203 (point-min) | 174 (delete-region (point-min) (point))) |
204 (save-excursion (search-forward "\n\n" nil 'move) (point))) | 175 |
205 | 176 ;; Some operations on the message header itself. |
206 ;; Fetch or construct what we should use in the `From ' line. | 177 (goto-char (point-min)) |
207 (setq mail-from | 178 (save-restriction |
208 (or (mail-fetch-field "Mail-From") | 179 (narrow-to-region |
209 (concat "From " | 180 (point-min) |
210 (mail-strip-quoted-names (or (mail-fetch-field "from") | 181 (save-excursion (search-forward "\n\n" nil 'move) (point))) |
211 (mail-fetch-field "really-from") | 182 |
212 (mail-fetch-field "sender") | 183 ;; Fetch or construct what we should use in the `From ' line. |
213 "unknown")) | 184 (setq mail-from |
214 " " (current-time-string)))) | 185 (or (mail-fetch-field "Mail-From") |
215 | 186 (concat "From " |
216 ;; If the message specifies a coding system, use it. | 187 (mail-strip-quoted-names (or (mail-fetch-field "from") |
217 (let ((maybe-coding (mail-fetch-field "X-Coding-System"))) | 188 (mail-fetch-field "really-from") |
218 (if maybe-coding | 189 (mail-fetch-field "sender") |
219 (setq coding (intern maybe-coding)))) | 190 "unknown")) |
220 | 191 " " (current-time-string)))) |
221 ;; Delete the Mail-From: header field if any. | 192 |
222 (when (re-search-forward "^Mail-from:" nil t) | 193 ;; If the message specifies a coding system, use it. |
223 (beginning-of-line) | 194 (let ((maybe-coding (mail-fetch-field "X-Coding-System"))) |
224 (delete-region (point) | 195 (if maybe-coding |
225 (progn (forward-line 1) (point))))) | 196 (setq coding (intern maybe-coding)))) |
226 | 197 |
227 (goto-char (point-min)) | 198 ;; Delete the Mail-From: header field if any. |
228 ;; Insert the `From ' line. | 199 (when (re-search-forward "^Mail-from:" nil t) |
229 (insert mail-from "\n") | 200 (beginning-of-line) |
230 ;; Record the keywords and attributes in our special way. | 201 (delete-region (point) |
231 (insert "X-BABYL-V6-ATTRIBUTES: " (apply 'string attrs) "\n") | 202 (progn (forward-line 1) (point))))) |
232 (when keywords | 203 |
233 (insert "X-BABYL-V6-KEYWORDS: " keywords "\n")) | 204 (goto-char (point-min)) |
234 (goto-char (point-min)) | 205 ;; Insert the `From ' line. |
235 ;; ``Quote'' "\nFrom " as "\n>From " | 206 (insert mail-from "\n") |
236 ;; (note that this isn't really quoting, as there is no requirement | 207 ;; Record the keywords and attributes in our special way. |
237 ;; that "\n[>]+From " be quoted in the same transparent way.) | 208 (insert "X-BABYL-V6-ATTRIBUTES: " (apply 'string attrs) "\n") |
238 (let ((case-fold-search nil)) | 209 (when keywords |
239 (while (search-forward "\nFrom " nil t) | 210 (insert "X-BABYL-V6-KEYWORDS: " keywords "\n")) |
240 (forward-char -5) | 211 (goto-char (point-min)) |
241 (insert ?>))) | 212 ;; ``Quote'' "\nFrom " as "\n>From " |
242 ;; Write it to the original buffer. | 213 ;; (note that this isn't really quoting, as there is no requirement |
243 (append-to-buffer thisbuf (point-min) (point-max))))) | 214 ;; that "\n[>]+From " be quoted in the same transparent way.) |
244 (kill-buffer temp-buffer))) | 215 (let ((case-fold-search nil)) |
216 (while (search-forward "\nFrom " nil t) | |
217 (forward-char -5) | |
218 (insert ?>))) | |
219 ;; Write it to the output file. | |
220 (write-region (point-min) (point-max) to-file t | |
221 'nomsg)))) | |
222 (kill-buffer temp-buffer)) | |
223 (message "Writing messages to %s...done" to-file))) | |
245 | 224 |
246 (provide 'unrmail) | 225 (provide 'unrmail) |
247 | 226 |
248 ;;; unrmail.el ends here | 227 ;;; unrmail.el ends here |
249 | 228 |