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