/[emacs]/emacs/lisp/mail/unrmail.el
ViewVC logotype

Diff of /emacs/lisp/mail/unrmail.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.12 by pj, Mon Aug 6 09:45:50 2001 UTC revision 1.12.8.1 by miles, Fri Apr 4 06:20:27 2003 UTC
# Line 1  Line 1 
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
# Line 51  For example, invoke `emacs -batch -f bat Line 51  For example, invoke `emacs -batch -f bat
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    

Legend:
Removed from v.1.12  
changed lines
  Added in v.1.12.8.1

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26