Commit | Line | Data |
---|---|---|
d654dddf | 1 | ;;; unrmail.el --- convert Rmail Babyl files to mailbox files |
76550a57 | 2 | |
d654dddf | 3 | ;; Copyright (C) 1992, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, |
5df4f04c | 4 | ;; 2009, 2010, 2011 Free Software Foundation, Inc. |
8548041d | 5 | |
070c251e | 6 | ;; Maintainer: FSF |
e9571d2a ER |
7 | ;; Keywords: mail |
8 | ||
8548041d RS |
9 | ;; This file is part of GNU Emacs. |
10 | ||
b1fc2b50 | 11 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
8548041d | 12 | ;; it under the terms of the GNU General Public License as published by |
b1fc2b50 GM |
13 | ;; the Free Software Foundation, either version 3 of the License, or |
14 | ;; (at your option) any later version. | |
8548041d RS |
15 | |
16 | ;; GNU Emacs is distributed in the hope that it will be useful, | |
17 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
18 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
19 | ;; GNU General Public License for more details. | |
20 | ||
21 | ;; You should have received a copy of the GNU General Public License | |
b1fc2b50 | 22 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
8548041d | 23 | |
60370d40 PJ |
24 | ;;; Commentary: |
25 | ||
76550a57 ER |
26 | ;;; Code: |
27 | ||
8548041d RS |
28 | ;;;###autoload |
29 | (defun batch-unrmail () | |
d654dddf GM |
30 | "Convert old-style Rmail Babyl files to system inbox format. |
31 | Specify the input Rmail Babyl file names as command line arguments. | |
8548041d RS |
32 | For each Rmail file, the corresponding output file name |
33 | is made by adding `.mail' at the end. | |
34 | For example, invoke `emacs -batch -f batch-unrmail RMAIL'." | |
8548041d RS |
35 | (if (not noninteractive) |
36 | (error "`batch-unrmail' is to be used only with -batch")) | |
37 | (let ((error nil)) | |
38 | (while command-line-args-left | |
39 | (or (unrmail (car command-line-args-left) | |
40 | (concat (car command-line-args-left) ".mail")) | |
41 | (setq error t)) | |
42 | (setq command-line-args-left (cdr command-line-args-left))) | |
43 | (message "Done") | |
44 | (kill-emacs (if error 1 0)))) | |
45 | ||
7b692c10 | 46 | (declare-function mail-mbox-from "mail-utils" ()) |
3a1eda7c | 47 | (defvar rmime-magic-string) ; in rmime.el, if you have it |
2b54af74 | 48 | |
8548041d RS |
49 | ;;;###autoload |
50 | (defun unrmail (file to-file) | |
d654dddf GM |
51 | "Convert old-style Rmail Babyl file FILE to system inbox format file TO-FILE." |
52 | (interactive "fUnrmail (babyl file): \nFUnrmail into (new mailbox file): ") | |
6740652e RS |
53 | (with-temp-buffer |
54 | ;; Read in the old Rmail file with no decoding. | |
55 | (let ((coding-system-for-read 'raw-text)) | |
56 | (insert-file-contents file)) | |
57 | ;; But make it multibyte. | |
58 | (set-buffer-multibyte t) | |
de456f3b | 59 | (setq buffer-file-coding-system 'raw-text-unix) |
6740652e RS |
60 | |
61 | (if (not (looking-at "BABYL OPTIONS")) | |
62 | (error "This file is not in Babyl format")) | |
63 | ||
64 | ;; Decode the file contents just as Rmail did. | |
65 | (let ((modifiedp (buffer-modified-p)) | |
66 | (coding-system rmail-file-coding-system) | |
67 | from to) | |
68 | (goto-char (point-min)) | |
69 | (search-forward "\n\^_" nil t) ; Skip BABYL header. | |
70 | (setq from (point)) | |
71 | (goto-char (point-max)) | |
72 | (search-backward "\n\^_" from 'mv) | |
73 | (setq to (point)) | |
74 | (unless (and coding-system | |
75 | (coding-system-p coding-system)) | |
76 | (setq coding-system | |
77 | ;; Emacs 21.1 and later writes RMAIL files in emacs-mule, but | |
78 | ;; earlier versions did that with the current buffer's encoding. | |
79 | ;; So we want to favor detection of emacs-mule (whose normal | |
80 | ;; priority is quite low), but still allow detection of other | |
81 | ;; encodings if emacs-mule won't fit. The call to | |
82 | ;; detect-coding-with-priority below achieves that. | |
83 | (car (detect-coding-with-priority | |
84 | from to | |
85 | '((coding-category-emacs-mule . emacs-mule)))))) | |
86 | (unless (memq coding-system | |
87 | '(undecided undecided-unix)) | |
88 | (set-buffer-modified-p t) ; avoid locking when decoding | |
89 | (let ((buffer-undo-list t)) | |
90 | (decode-coding-region from to coding-system)) | |
91 | (setq coding-system last-coding-system-used)) | |
92 | ||
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 | ||
a538e583 KH |
99 | ;; Default the directory of TO-FILE based on where FILE is. |
100 | (setq to-file (expand-file-name to-file default-directory)) | |
5eba27ea RS |
101 | (condition-case () |
102 | (delete-file to-file) | |
103 | (file-error nil)) | |
4eb5bf46 | 104 | (message "Writing messages to %s..." to-file) |
6740652e RS |
105 | (goto-char (point-min)) |
106 | ||
107 | (let ((temp-buffer (get-buffer-create " unrmail")) | |
108 | (from-buffer (current-buffer))) | |
109 | ||
110 | ;; Process the messages one by one. | |
4925ab0b | 111 | (while (re-search-forward "^\^_\^l" nil t) |
6740652e RS |
112 | (let ((beg (point)) |
113 | (end (save-excursion | |
4925ab0b GM |
114 | (if (re-search-forward "^\^_\\(\^l\\|\\'\\)" nil t) |
115 | (match-beginning 0) | |
116 | (point-max)))) | |
6740652e | 117 | (coding 'raw-text) |
5eba27ea | 118 | label-line attrs keywords |
6740652e | 119 | mail-from reformatted) |
5eba27ea RS |
120 | (with-current-buffer temp-buffer |
121 | (setq buffer-undo-list t) | |
122 | (erase-buffer) | |
123 | (setq buffer-file-coding-system coding) | |
124 | (insert-buffer-substring from-buffer beg end) | |
125 | (goto-char (point-min)) | |
126 | (forward-line 1) | |
6740652e RS |
127 | ;; Record whether the header is reformatted. |
128 | (setq reformatted (= (following-char) ?1)) | |
129 | ||
130 | ;; Collect the label line, then get the attributes | |
131 | ;; and the keywords from it. | |
5eba27ea RS |
132 | (setq label-line |
133 | (buffer-substring (point) | |
6740652e RS |
134 | (save-excursion (forward-line 1) |
135 | (point)))) | |
56ba4401 | 136 | (re-search-forward ",, ?") |
5eba27ea RS |
137 | (unless (eolp) |
138 | (setq keywords | |
139 | (buffer-substring (point) | |
140 | (progn (end-of-line) | |
141 | (1- (point))))) | |
56ba4401 GM |
142 | ;; Mbox rmail needs the spaces. Bug#2303. |
143 | ;;; (setq keywords | |
144 | ;;; (replace-regexp-in-string ", " "," keywords)) | |
145 | ) | |
5eba27ea RS |
146 | |
147 | (setq attrs | |
148 | (list | |
149 | (if (string-match ", answered," label-line) ?A ?-) | |
150 | (if (string-match ", deleted," label-line) ?D ?-) | |
151 | (if (string-match ", edited," label-line) ?E ?-) | |
152 | (if (string-match ", filed," label-line) ?F ?-) | |
a880e5b9 EZ |
153 | (if (string-match ", retried," label-line) ?R ?-) |
154 | (if (string-match ", forwarded," label-line) ?S ?-) | |
155 | (if (string-match ", unseen," label-line) ?U ?-) | |
156 | (if (string-match ", resent," label-line) ?r ?-))) | |
6740652e RS |
157 | |
158 | ;; Delete the special Babyl lines at the start, | |
159 | ;; and the ***EOOH*** line, and the reformatted header if any. | |
160 | (goto-char (point-min)) | |
161 | (if reformatted | |
162 | (progn | |
163 | (forward-line 2) | |
164 | ;; Delete Summary-Line headers. | |
165 | (let ((case-fold-search t)) | |
166 | (while (looking-at "Summary-Line:") | |
167 | (forward-line 1))) | |
168 | (delete-region (point-min) (point)) | |
169 | ;; Delete the old reformatted header. | |
170 | (re-search-forward "^[*][*][*] EOOH [*][*][*]\n") | |
171 | (forward-line -1) | |
172 | (let ((start (point))) | |
173 | (search-forward "\n\n") | |
174 | (delete-region start (point)))) | |
175 | ;; Not reformatted. Delete the special | |
176 | ;; lines before the real header. | |
177 | (re-search-forward "^[*][*][*] EOOH [*][*][*]\n") | |
178 | (delete-region (point-min) (point))) | |
179 | ||
4925ab0b GM |
180 | ;; Handle rmime formatting. |
181 | (when (require 'rmime nil t) | |
182 | (let ((start (point))) | |
183 | (while (search-forward rmime-magic-string nil t)) | |
184 | (delete-region start (point)))) | |
185 | ||
6740652e | 186 | ;; Some operations on the message header itself. |
5eba27ea | 187 | (goto-char (point-min)) |
6740652e | 188 | (save-restriction |
d654dddf | 189 | (narrow-to-region |
6740652e RS |
190 | (point-min) |
191 | (save-excursion (search-forward "\n\n" nil 'move) (point))) | |
192 | ||
193 | ;; Fetch or construct what we should use in the `From ' line. | |
71d8a140 EZ |
194 | (setq mail-from (or (let ((from (mail-fetch-field "Mail-From"))) |
195 | ;; mail-mbox-from (below) returns a | |
196 | ;; string that ends in a newline, but | |
197 | ;; but mail-fetch-field does not, so | |
198 | ;; we append a newline here. | |
199 | (if from | |
200 | (format "%s\n" from))) | |
7b692c10 | 201 | (mail-mbox-from))) |
6740652e RS |
202 | |
203 | ;; If the message specifies a coding system, use it. | |
204 | (let ((maybe-coding (mail-fetch-field "X-Coding-System"))) | |
205 | (if maybe-coding | |
de456f3b EZ |
206 | (setq coding |
207 | ;; Force Unix EOLs. | |
208 | (coding-system-change-eol-conversion | |
209 | (intern maybe-coding) 0)) | |
210 | ;; If there's no X-Coding-System header, assume the | |
211 | ;; message was never decoded. | |
212 | (setq coding 'raw-text-unix))) | |
6740652e RS |
213 | |
214 | ;; Delete the Mail-From: header field if any. | |
215 | (when (re-search-forward "^Mail-from:" nil t) | |
216 | (beginning-of-line) | |
217 | (delete-region (point) | |
218 | (progn (forward-line 1) (point))))) | |
219 | ||
220 | (goto-char (point-min)) | |
221 | ;; Insert the `From ' line. | |
71d8a140 | 222 | (insert mail-from) |
6740652e | 223 | ;; Record the keywords and attributes in our special way. |
77f33383 | 224 | (insert "X-RMAIL-ATTRIBUTES: " (apply 'string attrs) "\n") |
5eba27ea | 225 | (when keywords |
77f33383 | 226 | (insert "X-RMAIL-KEYWORDS: " keywords "\n")) |
5eba27ea RS |
227 | (goto-char (point-min)) |
228 | ;; ``Quote'' "\nFrom " as "\n>From " | |
229 | ;; (note that this isn't really quoting, as there is no requirement | |
230 | ;; that "\n[>]+From " be quoted in the same transparent way.) | |
231 | (let ((case-fold-search nil)) | |
232 | (while (search-forward "\nFrom " nil t) | |
233 | (forward-char -5) | |
234 | (insert ?>))) | |
88d03607 CY |
235 | ;; Make sure the message ends with two newlines |
236 | (goto-char (point-max)) | |
237 | (unless (looking-back "\n\n") | |
238 | (insert "\n")) | |
de456f3b EZ |
239 | ;; Write it to the output file, suitably encoded. |
240 | (let ((coding-system-for-write coding)) | |
241 | (write-region (point-min) (point-max) to-file t | |
242 | 'nomsg))))) | |
6740652e | 243 | (kill-buffer temp-buffer)) |
4eb5bf46 | 244 | (message "Writing messages to %s...done" to-file))) |
76550a57 | 245 | |
896546cd RS |
246 | (provide 'unrmail) |
247 | ||
cbee283d | 248 | ;; arch-tag: 14c6290d-60b2-456f-8909-5c2387de6acb |
d654dddf | 249 | ;;; unrmail.el ends here |