Commit | Line | Data |
---|---|---|
60370d40 | 1 | ;;; unrmail.el --- convert Rmail files to mailbox files |
76550a57 | 2 | |
5eba27ea | 3 | ;;; Copyright (C) 1992, 2002 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 | ||
10 | ;; GNU Emacs is free software; you can redistribute it and/or modify | |
11 | ;; it 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 | ;; 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 | |
b578f267 EN |
21 | ;; along with GNU Emacs; see the file COPYING. If not, write to the |
22 | ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
23 | ;; Boston, MA 02111-1307, USA. | |
8548041d | 24 | |
60370d40 PJ |
25 | ;;; Commentary: |
26 | ||
76550a57 ER |
27 | ;;; Code: |
28 | ||
8548041d RS |
29 | (defvar command-line-args-left) ;Avoid 'free variable' warning |
30 | ||
31 | ;;;###autoload | |
32 | (defun batch-unrmail () | |
28925d74 | 33 | "Convert Rmail files to system inbox format. |
8548041d RS |
34 | Specify the input Rmail file names as command line arguments. |
35 | For each Rmail file, the corresponding output file name | |
36 | is made by adding `.mail' at the end. | |
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) | |
39 | (if (not noninteractive) | |
40 | (error "`batch-unrmail' is to be used only with -batch")) | |
41 | (let ((error nil)) | |
42 | (while command-line-args-left | |
43 | (or (unrmail (car command-line-args-left) | |
44 | (concat (car command-line-args-left) ".mail")) | |
45 | (setq error t)) | |
46 | (setq command-line-args-left (cdr command-line-args-left))) | |
47 | (message "Done") | |
48 | (kill-emacs (if error 1 0)))) | |
49 | ||
50 | ;;;###autoload | |
51 | (defun unrmail (file to-file) | |
28925d74 | 52 | "Convert Rmail file FILE to system inbox format file TO-FILE." |
4eb5bf46 | 53 | (interactive "fUnrmail (rmail file): \nFUnrmail into (new mailbox file): ") |
6740652e RS |
54 | (with-temp-buffer |
55 | ;; Read in the old Rmail file with no decoding. | |
56 | (let ((coding-system-for-read 'raw-text)) | |
57 | (insert-file-contents file)) | |
58 | ;; But make it multibyte. | |
59 | (set-buffer-multibyte t) | |
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. | |
111 | (while (search-forward "\^_\^l" nil t) | |
112 | (let ((beg (point)) | |
113 | (end (save-excursion | |
114 | (if (search-forward "\^_" nil t) | |
115 | (1- (point)) (point-max)))) | |
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)))) | |
5eba27ea RS |
135 | (search-forward ",,") |
136 | (unless (eolp) | |
137 | (setq keywords | |
138 | (buffer-substring (point) | |
139 | (progn (end-of-line) | |
140 | (1- (point))))) | |
141 | (setq keywords | |
142 | (replace-regexp-in-string ", " "," keywords))) | |
143 | ||
144 | (setq attrs | |
145 | (list | |
146 | (if (string-match ", answered," label-line) ?A ?-) | |
147 | (if (string-match ", deleted," label-line) ?D ?-) | |
148 | (if (string-match ", edited," label-line) ?E ?-) | |
149 | (if (string-match ", filed," label-line) ?F ?-) | |
150 | (if (string-match ", resent," label-line) ?R ?-) | |
151 | (if (string-match ", unseen," label-line) ?\ ?-) | |
152 | (if (string-match ", stored," label-line) ?S ?-))) | |
6740652e RS |
153 | |
154 | ;; Delete the special Babyl lines at the start, | |
155 | ;; and the ***EOOH*** line, and the reformatted header if any. | |
156 | (goto-char (point-min)) | |
157 | (if reformatted | |
158 | (progn | |
159 | (forward-line 2) | |
160 | ;; Delete Summary-Line headers. | |
161 | (let ((case-fold-search t)) | |
162 | (while (looking-at "Summary-Line:") | |
163 | (forward-line 1))) | |
164 | (delete-region (point-min) (point)) | |
165 | ;; Delete the old reformatted header. | |
166 | (re-search-forward "^[*][*][*] EOOH [*][*][*]\n") | |
167 | (forward-line -1) | |
168 | (let ((start (point))) | |
169 | (search-forward "\n\n") | |
170 | (delete-region start (point)))) | |
171 | ;; Not reformatted. Delete the special | |
172 | ;; lines before the real header. | |
173 | (re-search-forward "^[*][*][*] EOOH [*][*][*]\n") | |
174 | (delete-region (point-min) (point))) | |
175 | ||
176 | ;; Some operations on the message header itself. | |
5eba27ea | 177 | (goto-char (point-min)) |
6740652e RS |
178 | (save-restriction |
179 | (narrow-to-region | |
180 | (point-min) | |
181 | (save-excursion (search-forward "\n\n" nil 'move) (point))) | |
182 | ||
183 | ;; Fetch or construct what we should use in the `From ' line. | |
184 | (setq mail-from | |
185 | (or (mail-fetch-field "Mail-From") | |
186 | (concat "From " | |
187 | (mail-strip-quoted-names (or (mail-fetch-field "from") | |
188 | (mail-fetch-field "really-from") | |
189 | (mail-fetch-field "sender") | |
190 | "unknown")) | |
191 | " " (current-time-string)))) | |
192 | ||
193 | ;; If the message specifies a coding system, use it. | |
194 | (let ((maybe-coding (mail-fetch-field "X-Coding-System"))) | |
195 | (if maybe-coding | |
196 | (setq coding (intern maybe-coding)))) | |
197 | ||
198 | ;; Delete the Mail-From: header field if any. | |
199 | (when (re-search-forward "^Mail-from:" nil t) | |
200 | (beginning-of-line) | |
201 | (delete-region (point) | |
202 | (progn (forward-line 1) (point))))) | |
203 | ||
204 | (goto-char (point-min)) | |
205 | ;; Insert the `From ' line. | |
5eba27ea | 206 | (insert mail-from "\n") |
6740652e | 207 | ;; Record the keywords and attributes in our special way. |
5eba27ea RS |
208 | (insert "X-BABYL-V6-ATTRIBUTES: " (apply 'string attrs) "\n") |
209 | (when keywords | |
210 | (insert "X-BABYL-V6-KEYWORDS: " keywords "\n")) | |
211 | (goto-char (point-min)) | |
212 | ;; ``Quote'' "\nFrom " as "\n>From " | |
213 | ;; (note that this isn't really quoting, as there is no requirement | |
214 | ;; that "\n[>]+From " be quoted in the same transparent way.) | |
215 | (let ((case-fold-search nil)) | |
216 | (while (search-forward "\nFrom " nil t) | |
217 | (forward-char -5) | |
218 | (insert ?>))) | |
6740652e | 219 | ;; Write it to the output file. |
5eba27ea | 220 | (write-region (point-min) (point-max) to-file t |
6740652e RS |
221 | 'nomsg)))) |
222 | (kill-buffer temp-buffer)) | |
4eb5bf46 | 223 | (message "Writing messages to %s...done" to-file))) |
76550a57 | 224 | |
896546cd RS |
225 | (provide 'unrmail) |
226 | ||
76550a57 | 227 | ;;; unrmail.el ends here |
5eba27ea | 228 | |
ab5796a9 | 229 | ;;; arch-tag: 14c6290d-60b2-456f-8909-5c2387de6acb |