Commit | Line | Data |
---|---|---|
60370d40 | 1 | ;;; unrmail.el --- convert Rmail files to mailbox files |
76550a57 | 2 | |
f2e3589a | 3 | ;; Copyright (C) 1992, 2001, 2002, 2003, 2004, 2005, |
2f043267 | 4 | ;; 2006, 2007, 2008 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 | (defvar command-line-args-left) ;Avoid 'free variable' warning |
29 | ||
30 | ;;;###autoload | |
31 | (defun batch-unrmail () | |
28925d74 | 32 | "Convert Rmail files to system inbox format. |
8548041d RS |
33 | Specify the input Rmail file names as command line arguments. |
34 | For each Rmail file, the corresponding output file name | |
35 | is made by adding `.mail' at the end. | |
36 | For example, invoke `emacs -batch -f batch-unrmail RMAIL'." | |
37 | ;; command-line-args-left is what is left of the command line (from startup.el) | |
38 | (if (not noninteractive) | |
39 | (error "`batch-unrmail' is to be used only with -batch")) | |
40 | (let ((error nil)) | |
41 | (while command-line-args-left | |
42 | (or (unrmail (car command-line-args-left) | |
43 | (concat (car command-line-args-left) ".mail")) | |
44 | (setq error t)) | |
45 | (setq command-line-args-left (cdr command-line-args-left))) | |
46 | (message "Done") | |
47 | (kill-emacs (if error 1 0)))) | |
48 | ||
2b54af74 DN |
49 | (declare-function mail-strip-quoted-names "mail-utils" (address)) |
50 | ||
8548041d RS |
51 | ;;;###autoload |
52 | (defun unrmail (file to-file) | |
28925d74 | 53 | "Convert Rmail file FILE to system inbox format file TO-FILE." |
4eb5bf46 | 54 | (interactive "fUnrmail (rmail file): \nFUnrmail into (new mailbox file): ") |
6740652e RS |
55 | (with-temp-buffer |
56 | ;; Read in the old Rmail file with no decoding. | |
57 | (let ((coding-system-for-read 'raw-text)) | |
58 | (insert-file-contents file)) | |
59 | ;; But make it multibyte. | |
60 | (set-buffer-multibyte t) | |
61 | ||
62 | (if (not (looking-at "BABYL OPTIONS")) | |
63 | (error "This file is not in Babyl format")) | |
64 | ||
65 | ;; Decode the file contents just as Rmail did. | |
66 | (let ((modifiedp (buffer-modified-p)) | |
67 | (coding-system rmail-file-coding-system) | |
68 | from to) | |
69 | (goto-char (point-min)) | |
70 | (search-forward "\n\^_" nil t) ; Skip BABYL header. | |
71 | (setq from (point)) | |
72 | (goto-char (point-max)) | |
73 | (search-backward "\n\^_" from 'mv) | |
74 | (setq to (point)) | |
75 | (unless (and coding-system | |
76 | (coding-system-p coding-system)) | |
77 | (setq coding-system | |
78 | ;; Emacs 21.1 and later writes RMAIL files in emacs-mule, but | |
79 | ;; earlier versions did that with the current buffer's encoding. | |
80 | ;; So we want to favor detection of emacs-mule (whose normal | |
81 | ;; priority is quite low), but still allow detection of other | |
82 | ;; encodings if emacs-mule won't fit. The call to | |
83 | ;; detect-coding-with-priority below achieves that. | |
84 | (car (detect-coding-with-priority | |
85 | from to | |
86 | '((coding-category-emacs-mule . emacs-mule)))))) | |
87 | (unless (memq coding-system | |
88 | '(undecided undecided-unix)) | |
89 | (set-buffer-modified-p t) ; avoid locking when decoding | |
90 | (let ((buffer-undo-list t)) | |
91 | (decode-coding-region from to coding-system)) | |
92 | (setq coding-system last-coding-system-used)) | |
93 | ||
94 | (setq buffer-file-coding-system nil) | |
95 | ||
96 | ;; We currently don't use this value, but maybe we should. | |
97 | (setq save-buffer-coding-system | |
98 | (or coding-system 'undecided))) | |
99 | ||
a538e583 KH |
100 | ;; Default the directory of TO-FILE based on where FILE is. |
101 | (setq to-file (expand-file-name to-file default-directory)) | |
5eba27ea RS |
102 | (condition-case () |
103 | (delete-file to-file) | |
104 | (file-error nil)) | |
4eb5bf46 | 105 | (message "Writing messages to %s..." to-file) |
6740652e RS |
106 | (goto-char (point-min)) |
107 | ||
108 | (let ((temp-buffer (get-buffer-create " unrmail")) | |
109 | (from-buffer (current-buffer))) | |
110 | ||
111 | ;; Process the messages one by one. | |
112 | (while (search-forward "\^_\^l" nil t) | |
113 | (let ((beg (point)) | |
114 | (end (save-excursion | |
115 | (if (search-forward "\^_" nil t) | |
116 | (1- (point)) (point-max)))) | |
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)))) | |
5eba27ea RS |
136 | (search-forward ",,") |
137 | (unless (eolp) | |
138 | (setq keywords | |
139 | (buffer-substring (point) | |
140 | (progn (end-of-line) | |
141 | (1- (point))))) | |
142 | (setq keywords | |
143 | (replace-regexp-in-string ", " "," keywords))) | |
144 | ||
145 | (setq attrs | |
146 | (list | |
147 | (if (string-match ", answered," label-line) ?A ?-) | |
148 | (if (string-match ", deleted," label-line) ?D ?-) | |
149 | (if (string-match ", edited," label-line) ?E ?-) | |
150 | (if (string-match ", filed," label-line) ?F ?-) | |
151 | (if (string-match ", resent," label-line) ?R ?-) | |
152 | (if (string-match ", unseen," label-line) ?\ ?-) | |
153 | (if (string-match ", stored," label-line) ?S ?-))) | |
6740652e RS |
154 | |
155 | ;; Delete the special Babyl lines at the start, | |
156 | ;; and the ***EOOH*** line, and the reformatted header if any. | |
157 | (goto-char (point-min)) | |
158 | (if reformatted | |
159 | (progn | |
160 | (forward-line 2) | |
161 | ;; Delete Summary-Line headers. | |
162 | (let ((case-fold-search t)) | |
163 | (while (looking-at "Summary-Line:") | |
164 | (forward-line 1))) | |
165 | (delete-region (point-min) (point)) | |
166 | ;; Delete the old reformatted header. | |
167 | (re-search-forward "^[*][*][*] EOOH [*][*][*]\n") | |
168 | (forward-line -1) | |
169 | (let ((start (point))) | |
170 | (search-forward "\n\n") | |
171 | (delete-region start (point)))) | |
172 | ;; Not reformatted. Delete the special | |
173 | ;; lines before the real header. | |
174 | (re-search-forward "^[*][*][*] EOOH [*][*][*]\n") | |
175 | (delete-region (point-min) (point))) | |
176 | ||
177 | ;; Some operations on the message header itself. | |
5eba27ea | 178 | (goto-char (point-min)) |
6740652e RS |
179 | (save-restriction |
180 | (narrow-to-region | |
181 | (point-min) | |
182 | (save-excursion (search-forward "\n\n" nil 'move) (point))) | |
183 | ||
184 | ;; Fetch or construct what we should use in the `From ' line. | |
185 | (setq mail-from | |
186 | (or (mail-fetch-field "Mail-From") | |
187 | (concat "From " | |
188 | (mail-strip-quoted-names (or (mail-fetch-field "from") | |
189 | (mail-fetch-field "really-from") | |
190 | (mail-fetch-field "sender") | |
191 | "unknown")) | |
192 | " " (current-time-string)))) | |
193 | ||
194 | ;; If the message specifies a coding system, use it. | |
195 | (let ((maybe-coding (mail-fetch-field "X-Coding-System"))) | |
196 | (if maybe-coding | |
197 | (setq coding (intern maybe-coding)))) | |
198 | ||
199 | ;; Delete the Mail-From: header field if any. | |
200 | (when (re-search-forward "^Mail-from:" nil t) | |
201 | (beginning-of-line) | |
202 | (delete-region (point) | |
203 | (progn (forward-line 1) (point))))) | |
204 | ||
205 | (goto-char (point-min)) | |
206 | ;; Insert the `From ' line. | |
5eba27ea | 207 | (insert mail-from "\n") |
6740652e | 208 | ;; Record the keywords and attributes in our special way. |
5eba27ea RS |
209 | (insert "X-BABYL-V6-ATTRIBUTES: " (apply 'string attrs) "\n") |
210 | (when keywords | |
211 | (insert "X-BABYL-V6-KEYWORDS: " keywords "\n")) | |
212 | (goto-char (point-min)) | |
213 | ;; ``Quote'' "\nFrom " as "\n>From " | |
214 | ;; (note that this isn't really quoting, as there is no requirement | |
215 | ;; that "\n[>]+From " be quoted in the same transparent way.) | |
216 | (let ((case-fold-search nil)) | |
217 | (while (search-forward "\nFrom " nil t) | |
218 | (forward-char -5) | |
219 | (insert ?>))) | |
6740652e | 220 | ;; Write it to the output file. |
5eba27ea | 221 | (write-region (point-min) (point-max) to-file t |
6740652e RS |
222 | 'nomsg)))) |
223 | (kill-buffer temp-buffer)) | |
4eb5bf46 | 224 | (message "Writing messages to %s...done" to-file))) |
76550a57 | 225 | |
896546cd RS |
226 | (provide 'unrmail) |
227 | ||
76550a57 | 228 | ;;; unrmail.el ends here |
5eba27ea | 229 | |
cbee283d | 230 | ;; arch-tag: 14c6290d-60b2-456f-8909-5c2387de6acb |