51 |
(defun unrmail (file to-file) |
(defun unrmail (file to-file) |
52 |
"Convert Rmail file FILE to system inbox format file TO-FILE." |
"Convert Rmail file FILE to system inbox format file TO-FILE." |
53 |
(interactive "fUnrmail (rmail file): \nFUnrmail into (new mailbox file): ") |
(interactive "fUnrmail (rmail file): \nFUnrmail into (new mailbox file): ") |
54 |
(let ((message-count 1) |
(with-temp-buffer |
55 |
;; Prevent rmail from making, or switching to, a summary buffer. |
;; Read in the old Rmail file with no decoding. |
56 |
(rmail-display-summary nil) |
(let ((coding-system-for-read 'raw-text)) |
57 |
(rmail-delete-after-output nil) |
(insert-file-contents file)) |
58 |
(temp-buffer (get-buffer-create " unrmail"))) |
;; But make it multibyte. |
59 |
(rmail file) |
(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 |
|
|
99 |
;; Default the directory of TO-FILE based on where FILE is. |
;; Default the directory of TO-FILE based on where FILE is. |
100 |
(setq to-file (expand-file-name to-file default-directory)) |
(setq to-file (expand-file-name to-file default-directory)) |
101 |
(condition-case () |
(condition-case () |
102 |
(delete-file to-file) |
(delete-file to-file) |
103 |
(file-error nil)) |
(file-error nil)) |
104 |
(message "Writing messages to %s..." to-file) |
(message "Writing messages to %s..." to-file) |
105 |
(save-restriction |
(goto-char (point-min)) |
106 |
(widen) |
|
107 |
(while (<= message-count rmail-total-messages) |
(let ((temp-buffer (get-buffer-create " unrmail")) |
108 |
(let ((beg (rmail-msgbeg message-count)) |
(from-buffer (current-buffer))) |
109 |
(end (rmail-msgbeg (1+ message-count))) |
|
110 |
(from-buffer (current-buffer)) |
;; Process the messages one by one. |
111 |
(coding (or rmail-file-coding-system 'raw-text)) |
(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) |
117 |
label-line attrs keywords |
label-line attrs keywords |
118 |
header-beginning mail-from) |
mail-from reformatted) |
|
(save-excursion |
|
|
(goto-char (rmail-msgbeg message-count)) |
|
|
(setq header-beginning (point)) |
|
|
(search-forward "\n*** EOOH ***\n") |
|
|
(forward-line -1) |
|
|
(search-forward "\n\n") |
|
|
(save-restriction |
|
|
(narrow-to-region header-beginning (point)) |
|
|
(setq mail-from |
|
|
(or (mail-fetch-field "Mail-From") |
|
|
(concat "From " |
|
|
(mail-strip-quoted-names (or (mail-fetch-field "from") |
|
|
(mail-fetch-field "really-from") |
|
|
(mail-fetch-field "sender") |
|
|
"unknown")) |
|
|
" " (current-time-string)))))) |
|
119 |
(with-current-buffer temp-buffer |
(with-current-buffer temp-buffer |
120 |
(setq buffer-undo-list t) |
(setq buffer-undo-list t) |
121 |
(erase-buffer) |
(erase-buffer) |
123 |
(insert-buffer-substring from-buffer beg end) |
(insert-buffer-substring from-buffer beg end) |
124 |
(goto-char (point-min)) |
(goto-char (point-min)) |
125 |
(forward-line 1) |
(forward-line 1) |
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. |
131 |
(setq label-line |
(setq label-line |
132 |
(buffer-substring (point) |
(buffer-substring (point) |
133 |
(progn (forward-line 1) |
(save-excursion (forward-line 1) |
134 |
(point)))) |
(point)))) |
|
(forward-line -1) |
|
135 |
(search-forward ",,") |
(search-forward ",,") |
136 |
(unless (eolp) |
(unless (eolp) |
137 |
(setq keywords |
(setq keywords |
150 |
(if (string-match ", resent," label-line) ?R ?-) |
(if (string-match ", resent," label-line) ?R ?-) |
151 |
(if (string-match ", unseen," label-line) ?\ ?-) |
(if (string-match ", unseen," label-line) ?\ ?-) |
152 |
(if (string-match ", stored," label-line) ?S ?-))) |
(if (string-match ", stored," label-line) ?S ?-))) |
153 |
(unrmail-unprune) |
|
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. |
177 |
|
(goto-char (point-min)) |
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)) |
(goto-char (point-min)) |
205 |
|
;; Insert the `From ' line. |
206 |
(insert mail-from "\n") |
(insert mail-from "\n") |
207 |
|
;; Record the keywords and attributes in our special way. |
208 |
(insert "X-BABYL-V6-ATTRIBUTES: " (apply 'string attrs) "\n") |
(insert "X-BABYL-V6-ATTRIBUTES: " (apply 'string attrs) "\n") |
209 |
(when keywords |
(when keywords |
210 |
(insert "X-BABYL-V6-KEYWORDS: " keywords "\n")) |
(insert "X-BABYL-V6-KEYWORDS: " keywords "\n")) |
216 |
(while (search-forward "\nFrom " nil t) |
(while (search-forward "\nFrom " nil t) |
217 |
(forward-char -5) |
(forward-char -5) |
218 |
(insert ?>))) |
(insert ?>))) |
219 |
|
;; Write it to the output file. |
220 |
(write-region (point-min) (point-max) to-file t |
(write-region (point-min) (point-max) to-file t |
221 |
'nomsg))) |
'nomsg)))) |
222 |
(setq message-count (1+ message-count)))) |
(kill-buffer temp-buffer)) |
223 |
(message "Writing messages to %s...done" to-file))) |
(message "Writing messages to %s...done" to-file))) |
224 |
|
|
|
(defun unrmail-unprune () |
|
|
(let* ((pruned |
|
|
(save-excursion |
|
|
(goto-char (point-min)) |
|
|
(forward-line 1) |
|
|
(= (following-char) ?1)))) |
|
|
(if pruned |
|
|
(progn |
|
|
(goto-char (point-min)) |
|
|
(forward-line 2) |
|
|
;; Delete Summary-Line headers. |
|
|
(let ((case-fold-search t)) |
|
|
(while (looking-at "Summary-Line:") |
|
|
(forward-line 1))) |
|
|
(delete-region (point-min) (point)) |
|
|
;; Delete the old reformatted header. |
|
|
(re-search-forward "^[*][*][*] EOOH [*][*][*]\n") |
|
|
(forward-line -1) |
|
|
(let ((start (point))) |
|
|
(search-forward "\n\n") |
|
|
(delete-region start (point)))) |
|
|
;; Delete everything up to the real header. |
|
|
(goto-char (point-min)) |
|
|
(re-search-forward "^[*][*][*] EOOH [*][*][*]\n") |
|
|
(delete-region (point-min) (point))) |
|
|
(goto-char (point-min)) |
|
|
(when (re-search-forward "^Mail-from:") |
|
|
(beginning-of-line) |
|
|
(delete-region (point) |
|
|
(progn (forward-line 1) (point)))))) |
|
|
|
|
|
|
|
225 |
(provide 'unrmail) |
(provide 'unrmail) |
226 |
|
|
227 |
;;; unrmail.el ends here |
;;; unrmail.el ends here |