1 |
;;; unrmail.el --- convert Rmail files to mailbox files |
;;; unrmail.el --- convert Rmail files to mailbox files |
2 |
|
|
3 |
;;; Copyright (C) 1992 Free Software Foundation, Inc. |
;;; Copyright (C) 1992, 2002 Free Software Foundation, Inc. |
4 |
|
|
5 |
;; Maintainer: FSF |
;; Maintainer: FSF |
6 |
;; Keywords: mail |
;; Keywords: mail |
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 0) |
(let ((message-count 1) |
55 |
;; Prevent rmail from making, or switching to, a summary buffer. |
;; Prevent rmail from making, or switching to, a summary buffer. |
56 |
(rmail-display-summary nil) |
(rmail-display-summary nil) |
57 |
(rmail-delete-after-output nil)) |
(rmail-delete-after-output nil) |
58 |
|
(temp-buffer (get-buffer-create " unrmail"))) |
59 |
(rmail file) |
(rmail file) |
60 |
;; Default the directory of TO-FILE based on where FILE is. |
;; Default the directory of TO-FILE based on where FILE is. |
61 |
(setq to-file (expand-file-name to-file default-directory)) |
(setq to-file (expand-file-name to-file default-directory)) |
62 |
|
(condition-case () |
63 |
|
(delete-file to-file) |
64 |
|
(file-error nil)) |
65 |
(message "Writing messages to %s..." to-file) |
(message "Writing messages to %s..." to-file) |
66 |
(while (< message-count rmail-total-messages) |
(save-restriction |
67 |
(rmail-show-message |
(widen) |
68 |
(setq message-count (1+ message-count))) |
(while (<= message-count rmail-total-messages) |
69 |
(rmail-toggle-header) |
(let ((beg (rmail-msgbeg message-count)) |
70 |
(rmail-output to-file 1 t)) |
(end (rmail-msgbeg (1+ message-count))) |
71 |
|
(from-buffer (current-buffer)) |
72 |
|
(coding (or rmail-file-coding-system 'raw-text)) |
73 |
|
label-line attrs keywords |
74 |
|
header-beginning mail-from) |
75 |
|
(save-excursion |
76 |
|
(goto-char (rmail-msgbeg message-count)) |
77 |
|
(setq header-beginning (point)) |
78 |
|
(search-forward "\n*** EOOH ***\n") |
79 |
|
(forward-line -1) |
80 |
|
(search-forward "\n\n") |
81 |
|
(save-restriction |
82 |
|
(narrow-to-region header-beginning (point)) |
83 |
|
(setq mail-from |
84 |
|
(or (mail-fetch-field "Mail-From") |
85 |
|
(concat "From " |
86 |
|
(mail-strip-quoted-names (or (mail-fetch-field "from") |
87 |
|
(mail-fetch-field "really-from") |
88 |
|
(mail-fetch-field "sender") |
89 |
|
"unknown")) |
90 |
|
" " (current-time-string)))))) |
91 |
|
(with-current-buffer temp-buffer |
92 |
|
(setq buffer-undo-list t) |
93 |
|
(erase-buffer) |
94 |
|
(setq buffer-file-coding-system coding) |
95 |
|
(insert-buffer-substring from-buffer beg end) |
96 |
|
(goto-char (point-min)) |
97 |
|
(forward-line 1) |
98 |
|
(setq label-line |
99 |
|
(buffer-substring (point) |
100 |
|
(progn (forward-line 1) |
101 |
|
(point)))) |
102 |
|
(forward-line -1) |
103 |
|
(search-forward ",,") |
104 |
|
(unless (eolp) |
105 |
|
(setq keywords |
106 |
|
(buffer-substring (point) |
107 |
|
(progn (end-of-line) |
108 |
|
(1- (point))))) |
109 |
|
(setq keywords |
110 |
|
(replace-regexp-in-string ", " "," keywords))) |
111 |
|
|
112 |
|
(setq attrs |
113 |
|
(list |
114 |
|
(if (string-match ", answered," label-line) ?A ?-) |
115 |
|
(if (string-match ", deleted," label-line) ?D ?-) |
116 |
|
(if (string-match ", edited," label-line) ?E ?-) |
117 |
|
(if (string-match ", filed," label-line) ?F ?-) |
118 |
|
(if (string-match ", resent," label-line) ?R ?-) |
119 |
|
(if (string-match ", unseen," label-line) ?\ ?-) |
120 |
|
(if (string-match ", stored," label-line) ?S ?-))) |
121 |
|
(unrmail-unprune) |
122 |
|
(goto-char (point-min)) |
123 |
|
(insert mail-from "\n") |
124 |
|
(insert "X-BABYL-V6-ATTRIBUTES: " (apply 'string attrs) "\n") |
125 |
|
(when keywords |
126 |
|
(insert "X-BABYL-V6-KEYWORDS: " keywords "\n")) |
127 |
|
(goto-char (point-min)) |
128 |
|
;; ``Quote'' "\nFrom " as "\n>From " |
129 |
|
;; (note that this isn't really quoting, as there is no requirement |
130 |
|
;; that "\n[>]+From " be quoted in the same transparent way.) |
131 |
|
(let ((case-fold-search nil)) |
132 |
|
(while (search-forward "\nFrom " nil t) |
133 |
|
(forward-char -5) |
134 |
|
(insert ?>))) |
135 |
|
(write-region (point-min) (point-max) to-file t |
136 |
|
'nomsg))) |
137 |
|
(setq message-count (1+ message-count)))) |
138 |
(message "Writing messages to %s...done" to-file))) |
(message "Writing messages to %s...done" to-file))) |
139 |
|
|
140 |
|
(defun unrmail-unprune () |
141 |
|
(let* ((pruned |
142 |
|
(save-excursion |
143 |
|
(goto-char (point-min)) |
144 |
|
(forward-line 1) |
145 |
|
(= (following-char) ?1)))) |
146 |
|
(if pruned |
147 |
|
(progn |
148 |
|
(goto-char (point-min)) |
149 |
|
(forward-line 2) |
150 |
|
;; Delete Summary-Line headers. |
151 |
|
(let ((case-fold-search t)) |
152 |
|
(while (looking-at "Summary-Line:") |
153 |
|
(forward-line 1))) |
154 |
|
(delete-region (point-min) (point)) |
155 |
|
;; Delete the old reformatted header. |
156 |
|
(re-search-forward "^[*][*][*] EOOH [*][*][*]\n") |
157 |
|
(forward-line -1) |
158 |
|
(let ((start (point))) |
159 |
|
(search-forward "\n\n") |
160 |
|
(delete-region start (point)))) |
161 |
|
;; Delete everything up to the real header. |
162 |
|
(goto-char (point-min)) |
163 |
|
(re-search-forward "^[*][*][*] EOOH [*][*][*]\n") |
164 |
|
(delete-region (point-min) (point))) |
165 |
|
(goto-char (point-min)) |
166 |
|
(when (re-search-forward "^Mail-from:") |
167 |
|
(beginning-of-line) |
168 |
|
(delete-region (point) |
169 |
|
(progn (forward-line 1) (point)))))) |
170 |
|
|
171 |
|
|
172 |
(provide 'unrmail) |
(provide 'unrmail) |
173 |
|
|
174 |
;;; unrmail.el ends here |
;;; unrmail.el ends here |
175 |
|
|