/[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.13.2.1 by pmr, Sat Feb 15 17:16:29 2003 UTC revision 1.13.2.2 by rms, Sun Oct 3 01:20:20 2004 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, 2002 Free Software Foundation, Inc.  ;;; Copyright (C) 1992, 2002, 2004 Free Software Foundation, Inc.
4    
5  ;; Maintainer: FSF  ;; Maintainer: FSF
6  ;; Keywords: mail  ;; Keywords: mail
# Line 29  Line 29 
29  (defvar command-line-args-left) ;Avoid 'free variable' warning  (defvar command-line-args-left) ;Avoid 'free variable' warning
30    
31  ;;;###autoload  ;;;###autoload
32  (defun batch-unrmail ()  (defun batch-convert-babyl ()
33    "Convert Rmail files to system inbox format.    "Convert Babyl files (old Rmail file) to system inbox format.
34  Specify the input Rmail file names as command line arguments.  Specify the input Babyl file names as command line arguments.
35  For each Rmail file, the corresponding output file name  For each Babyl file, the corresponding output file name
36  is made by adding `.mail' at the end.  is made by adding `.mail' at the end.
37  For example, invoke `emacs -batch -f batch-unrmail RMAIL'."  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)    ;; command-line-args-left is what is left of the command line (from startup.el)
# Line 48  For example, invoke `emacs -batch -f bat Line 48  For example, invoke `emacs -batch -f bat
48      (kill-emacs (if error 1 0))))      (kill-emacs (if error 1 0))))
49    
50  ;;;###autoload  ;;;###autoload
51  (defun unrmail (file to-file)  (defalias 'batch-unrmail 'batch-convert-babyl)
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): ")    (interactive "fUnrmail (rmail file): \nFUnrmail into (new mailbox file): ")
57    (let ((message-count 1)    (with-temp-buffer
58          ;; Prevent rmail from making, or switching to, a summary buffer.      (decode-babyl-file file)
59          (rmail-display-summary nil)      ;; Write it to the output file.
60          (rmail-delete-after-output nil)      ;; Since the file may contain messages of different encodings
61          (temp-buffer (get-buffer-create " unrmail")))      ;; at the tail (non-BYBYL part), we can't decode them at once
62  ;    (rmail file)      ;; on reading.  So, at first, we read the file without text
63      ;; Default the directory of TO-FILE based on where FILE is.      ;; code conversion, then decode the messages one by one by
64      (setq to-file (expand-file-name to-file default-directory))      ;; rmail-decode-babyl-format or
65      (condition-case ()      ;; rmail-convert-to-babyl-format.
66          (delete-file to-file)      (let ((coding-system-for-write 'raw-text))
67        (file-error nil))        (write-region (point-min) (point-max) to-file nil
68      (message "Writing messages to %s..." to-file)                      'nomsg))))
69      (if (save-restriction  
70            (save-excursion  ;;;###autoload
71              (widen)  (defalias 'unrmail 'convert-babyl-file)
72              (goto-char (point-min))  
73              (not (looking-at "BABYL OPTIONS"))))  ;;;###autoload
74          (write-region (point-min) (point-max) to-file t 'nomsg)  (defun decode-babyl-file (file)
75        (save-restriction    "Convert Babyl file FILE to system inbox format in current buffer."
76          (widen)    (interactive "fUnrmail (rmail file): ")
77          (while (<= message-count rmail-total-messages)    ;; Read in the Babyl file with no decoding.
78            (let ((beg (rmail-msgbeg message-count))    (let ((thisbuf (current-buffer)))
79                  (end (rmail-msgbeg (1+ message-count)))      (with-temp-buffer
80                  (from-buffer (current-buffer))        (let ((coding-system-for-read 'raw-text))
81                  (coding (or rmail-file-coding-system 'raw-text))          (insert-file-contents file))
82                  label-line attrs keywords        ;; But make it multibyte.
83                  header-beginning mail-from)        (set-buffer-multibyte t)
84              (save-excursion  
85                (goto-char (rmail-msgbeg message-count))        (if (not (looking-at "BABYL OPTIONS"))
86                (setq header-beginning (point))            (error "File %s not in Babyl format"))
87                (search-forward "\n*** EOOH ***\n")  
88                (forward-line -1)        (decode-babyl thisbuf))))
89                (search-forward "\n\n")  
90                (save-restriction  ;;;###autoload
91                  (narrow-to-region header-beginning (point))  (defun decode-babyl (outbuf)
92                  (setq mail-from    "Convert Babyl data in current bufer to inbox format and store in OUTBUF."
93                        (or (mail-fetch-field "Mail-From")    ;; Decode the file contents just as Rmail did.
94                            (concat "From "    (let ((modifiedp (buffer-modified-p))
95                                    (mail-strip-quoted-names (or (mail-fetch-field "from")          (coding-system rmail-file-coding-system)
96                                                                 (mail-fetch-field "really-from")          from to)
                                                                (mail-fetch-field "sender")  
                                                                "unknown"))  
                                   " " (current-time-string))))))  
             (with-current-buffer temp-buffer  
               (setq buffer-undo-list t)  
               (erase-buffer)  
               (setq buffer-file-coding-system coding)  
               (insert-buffer-substring from-buffer beg end)  
               (goto-char (point-min))  
               (forward-line 1)  
               (setq label-line  
                     (buffer-substring (point)  
                                       (progn (forward-line 1)  
                                              (point))))  
               (forward-line -1)  
               (search-forward ",,")  
               (unless (eolp)  
                 (setq keywords  
                       (buffer-substring (point)  
                                         (progn (end-of-line)  
                                                (1- (point)))))  
                 (setq keywords  
                       (replace-regexp-in-string ", " "," keywords)))  
   
               (setq attrs  
                     (list  
                      (if (string-match ", answered," label-line) ?A ?-)  
                      (if (string-match ", deleted," label-line) ?D ?-)  
                      (if (string-match ", edited," label-line) ?E ?-)  
                      (if (string-match ", filed," label-line) ?F ?-)  
                      (if (string-match ", resent," label-line) ?R ?-)  
                      (if (string-match ", unseen," label-line) ?\  ?-)  
                      (if (string-match ", stored," label-line) ?S ?-)))  
               (unrmail-unprune)  
               (goto-char (point-min))  
               (insert mail-from "\n")  
               (insert "X-BABYL-V6-ATTRIBUTES: " (apply 'string attrs) "\n")  
               (when keywords  
                 (insert "X-BABYL-V6-KEYWORDS: " keywords "\n"))  
               (goto-char (point-min))  
               ;; ``Quote'' "\nFrom " as "\n>From "  
               ;;  (note that this isn't really quoting, as there is no requirement  
               ;;   that "\n[>]+From " be quoted in the same transparent way.)  
               (let ((case-fold-search nil))  
                 (while (search-forward "\nFrom " nil t)  
                   (forward-char -5)  
                   (insert ?>)))  
               (write-region (point-min) (point-max) to-file t  
                             'nomsg)))  
           (setq message-count (1+ message-count)))))  
     (message "Writing messages to %s...done" to-file)))  
   
 (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)))  
97      (goto-char (point-min))      (goto-char (point-min))
98      (when (re-search-forward "^Mail-from:")      (search-forward "\n\^_" nil t)      ; Skip BABYL header.
99        (beginning-of-line)      (setq from (point))
100        (delete-region (point)      (goto-char (point-max))
101                       (progn (forward-line 1) (point))))))      (search-backward "\n\^_" from 'mv)
102        (setq to (point))
103        (unless (and coding-system
104                     (coding-system-p coding-system))
105          (setq coding-system
106                ;; Emacs 21.1 and later writes RMAIL files in emacs-mule, but
107                ;; earlier versions did that with the current buffer's encoding.
108                ;; So we want to favor detection of emacs-mule (whose normal
109                ;; priority is quite low), but still allow detection of other
110                ;; encodings if emacs-mule won't fit.  The call to
111                ;; detect-coding-with-priority below achieves that.
112                (car (detect-coding-with-priority
113                      from to
114                      '((coding-category-emacs-mule . emacs-mule))))))
115        (unless (memq coding-system
116                      '(undecided undecided-unix))
117          (set-buffer-modified-p t) ; avoid locking when decoding
118          (let ((buffer-undo-list t))
119            (decode-coding-region from to coding-system))
120          (setq coding-system last-coding-system-used))
121    
122        (setq buffer-file-coding-system nil)
123    
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)
162                                        (progn (end-of-line)
163                                               (1- (point)))))
164                (setq keywords
165                      (replace-regexp-in-string ", " "," keywords)))
166    
167              (setq attrs
168                    (list
169                     (if (string-match ", answered," label-line) ?A ?-)
170                     (if (string-match ", deleted," label-line) ?D ?-)
171                     (if (string-match ", edited," label-line) ?E ?-)
172                     (if (string-match ", filed," label-line) ?F ?-)
173                     (if (string-match ", resent," label-line) ?R ?-)
174                     (if (string-match ", unseen," label-line) ?\  ?-)
175                     (if (string-match ", stored," label-line) ?S ?-)))
176    
177              ;; Delete the special Babyl lines at the start,
178              ;; and the ***EOOH*** line, and the reformatted header if any.
179              (goto-char (point-min))
180              (if reformatted
181                  (progn
182                    (forward-line 2)
183                    ;; Delete Summary-Line headers.
184                    (let ((case-fold-search t))
185                      (while (looking-at "Summary-Line:")
186                        (forward-line 1)))
187                    (delete-region (point-min) (point))
188                    ;; Delete the old reformatted header.
189                    (re-search-forward "^[*][*][*] EOOH [*][*][*]\n")
190                    (forward-line -1)
191                    (let ((start (point)))
192                      (search-forward "\n\n")
193                      (delete-region start (point))))
194                ;; Not reformatted.  Delete the special
195                ;; lines before the real header.
196                (re-search-forward "^[*][*][*] EOOH [*][*][*]\n")
197                (delete-region (point-min) (point)))
198    
199              ;; Some operations on the message header itself.
200              (goto-char (point-min))
201              (save-restriction
202                (narrow-to-region
203                 (point-min)
204                 (save-excursion (search-forward "\n\n" nil 'move) (point)))
205    
206                ;; Fetch or construct what we should use in the `From ' line.
207                (setq mail-from
208                      (or (mail-fetch-field "Mail-From")
209                          (concat "From "
210                                  (mail-strip-quoted-names (or (mail-fetch-field "from")
211                                                               (mail-fetch-field "really-from")
212                                                               (mail-fetch-field "sender")
213                                                               "unknown"))
214                                  " " (current-time-string))))
215    
216                ;; If the message specifies a coding system, use it.
217                (let ((maybe-coding (mail-fetch-field "X-Coding-System")))
218                  (if maybe-coding
219                      (setq coding (intern maybe-coding))))
220    
221                ;; Delete the Mail-From: header field if any.
222                (when (re-search-forward "^Mail-from:" nil t)
223                  (beginning-of-line)
224                  (delete-region (point)
225                                 (progn (forward-line 1) (point)))))
226    
227              (goto-char (point-min))
228              ;; Insert the `From ' line.
229              (insert mail-from "\n")
230              ;; Record the keywords and attributes in our special way.
231              (insert "X-BABYL-V6-ATTRIBUTES: " (apply 'string attrs) "\n")
232              (when keywords
233                (insert "X-BABYL-V6-KEYWORDS: " keywords "\n"))
234              (goto-char (point-min))
235              ;; ``Quote'' "\nFrom " as "\n>From "
236              ;;  (note that this isn't really quoting, as there is no requirement
237              ;;   that "\n[>]+From " be quoted in the same transparent way.)
238              (let ((case-fold-search nil))
239                (while (search-forward "\nFrom " nil t)
240                  (forward-char -5)
241                  (insert ?>)))
242              ;; Write it to the original buffer.
243              (append-to-buffer thisbuf (point-min) (point-max)))))
244        (kill-buffer temp-buffer)))
245    
246  (provide 'unrmail)  (provide 'unrmail)
247    
248  ;;; unrmail.el ends here  ;;; unrmail.el ends here
249    
250    ;;; arch-tag: 14c6290d-60b2-456f-8909-5c2387de6acb

Legend:
Removed from v.1.13.2.1  
changed lines
  Added in v.1.13.2.2

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