Mercurial > emacs

comparison lisp/mail/unrmail.el @ 88155:d7ddb3e565de

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
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