(unrmail): Mostly rewritten. Parses the file

directly, without calling any functions in Rmail.
(unrmail-unprune): Function deleted.

1 files changed, 121 insertions, 68 deletions

diff --git a/lisp/mail/unrmail.el b/lisp/mail/unrmail.el
index 55f611b53ad..db6990d625b 100644
--- a/lisp/mail/unrmail.el
+++ b/lisp/mail/unrmail.el
@@ -51,43 +51,71 @@ For example, invoke `emacs -batch -f batch-unrmail RMAIL'."
 (defun unrmail (file to-file)
   "Convert Rmail file FILE to system inbox format file TO-FILE."
   (interactive "fUnrmail (rmail file): \nFUnrmail into (new mailbox file): ")
-  (let ((message-count 1)
-        ;; Prevent rmail from making, or switching to, a summary buffer.
-        (rmail-display-summary nil)
-        (rmail-delete-after-output nil)
-        (temp-buffer (get-buffer-create " unrmail")))
-    (rmail file)
+  (with-temp-buffer
+    ;; Read in the old Rmail file with no decoding.
+    (let ((coding-system-for-read 'raw-text))
+      (insert-file-contents file))
+    ;; But make it multibyte.
+    (set-buffer-multibyte t)
+
+    (if (not (looking-at "BABYL OPTIONS"))
+        (error "This file is not in Babyl format"))
+
+    ;; Decode the file contents just as Rmail did.
+    (let ((modifiedp (buffer-modified-p))
+          (coding-system rmail-file-coding-system)
+          from to)
+      (goto-char (point-min))
+      (search-forward "\n\^_" nil t)    ; Skip BABYL header.
+      (setq from (point))
+      (goto-char (point-max))
+      (search-backward "\n\^_" from 'mv)
+      (setq to (point))
+      (unless (and coding-system
+                   (coding-system-p coding-system))
+        (setq coding-system
+              ;; Emacs 21.1 and later writes RMAIL files in emacs-mule, but
+              ;; earlier versions did that with the current buffer's encoding.
+              ;; So we want to favor detection of emacs-mule (whose normal
+              ;; priority is quite low), but still allow detection of other
+              ;; encodings if emacs-mule won't fit.  The call to
+              ;; detect-coding-with-priority below achieves that.
+              (car (detect-coding-with-priority
+                    from to
+                    '((coding-category-emacs-mule . emacs-mule))))))
+      (unless (memq coding-system
+                    '(undecided undecided-unix))
+        (set-buffer-modified-p t)       ; avoid locking when decoding
+        (let ((buffer-undo-list t))
+          (decode-coding-region from to coding-system))
+        (setq coding-system last-coding-system-used))
+
+      (setq buffer-file-coding-system nil)
+
+      ;; We currently don't use this value, but maybe we should.
+      (setq save-buffer-coding-system
+            (or coding-system 'undecided)))
+
     ;; Default the directory of TO-FILE based on where FILE is.
     (setq to-file (expand-file-name to-file default-directory))
     (condition-case ()
         (delete-file to-file)
       (file-error nil))
     (message "Writing messages to %s..." to-file)
-    (save-restriction
-      (widen)
-      (while (<= message-count rmail-total-messages)
-        (let ((beg (rmail-msgbeg message-count))
-              (end (rmail-msgbeg (1+ message-count)))
-              (from-buffer (current-buffer))
-              (coding (or rmail-file-coding-system 'raw-text))
+    (goto-char (point-min))
+
+    (let ((temp-buffer (get-buffer-create " unrmail"))
+          (from-buffer (current-buffer)))
+
+      ;; Process the messages one by one.
+      (while (search-forward "\^_\^l" nil t)
+        (let ((beg (point))
+              (end (save-excursion
+                     (if (search-forward "\^_" nil t)
+                         (1- (point)) (point-max))))
+              (coding 'raw-text)
               label-line attrs keywords
-              header-beginning mail-from)
-          (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))))))
+              mail-from reformatted)
           (with-current-buffer temp-buffer
             (setq buffer-undo-list t)
             (erase-buffer)
@@ -95,11 +123,15 @@ For example, invoke `emacs -batch -f batch-unrmail RMAIL'."
             (insert-buffer-substring from-buffer beg end)
             (goto-char (point-min))
             (forward-line 1)
+            ;; Record whether the header is reformatted.
+            (setq reformatted (= (following-char) ?1))
+
+            ;; Collect the label line, then get the attributes
+            ;; and the keywords from it.
             (setq label-line
                   (buffer-substring (point)
-                                    (progn (forward-line 1)
-                                           (point))))
-            (forward-line -1)
+                                    (save-excursion (forward-line 1)
+                                                    (point))))
             (search-forward ",,")
             (unless (eolp)
               (setq keywords
@@ -118,9 +150,61 @@ For example, invoke `emacs -batch -f batch-unrmail RMAIL'."
                    (if (string-match ", resent," label-line) ?R ?-)
                    (if (string-match ", unseen," label-line) ?\  ?-)
                    (if (string-match ", stored," label-line) ?S ?-)))
-            (unrmail-unprune)
+
+            ;; Delete the special Babyl lines at the start,
+            ;; and the ***EOOH*** line, and the reformatted header if any.
+            (goto-char (point-min))
+            (if reformatted
+                (progn
+                  (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))))
+              ;; Not reformatted.  Delete the special
+              ;; lines before the real header.
+              (re-search-forward "^[*][*][*] EOOH [*][*][*]\n")
+              (delete-region (point-min) (point)))
+
+            ;; Some operations on the message header itself.
             (goto-char (point-min))
+            (save-restriction
+              (narrow-to-region 
+               (point-min)
+               (save-excursion (search-forward "\n\n" nil 'move) (point)))
+
+              ;; Fetch or construct what we should use in the `From ' line.
+              (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))))
+
+              ;; If the message specifies a coding system, use it.
+              (let ((maybe-coding (mail-fetch-field "X-Coding-System")))
+                (if maybe-coding
+                    (setq coding (intern maybe-coding))))
+
+              ;; Delete the Mail-From: header field if any.
+              (when (re-search-forward "^Mail-from:" nil t)
+                (beginning-of-line)
+                (delete-region (point)
+                               (progn (forward-line 1) (point)))))
+
+            (goto-char (point-min))
+            ;; Insert the `From ' line.
             (insert mail-from "\n")
+            ;; Record the keywords and attributes in our special way.
             (insert "X-BABYL-V6-ATTRIBUTES: " (apply 'string attrs) "\n")
             (when keywords
               (insert "X-BABYL-V6-KEYWORDS: " keywords "\n"))
@@ -132,43 +216,12 @@ For example, invoke `emacs -batch -f batch-unrmail RMAIL'."
               (while (search-forward "\nFrom " nil t)
                 (forward-char -5)
                 (insert ?>)))
+            ;; Write it to the output file.
             (write-region (point-min) (point-max) to-file t
-                          'nomsg)))
-        (setq message-count (1+ message-count))))
+                          'nomsg))))
+      (kill-buffer temp-buffer))
     (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)))
-    (goto-char (point-min))
-    (when (re-search-forward "^Mail-from:")
-      (beginning-of-line)
-      (delete-region (point)
-                     (progn (forward-line 1) (point))))))
-
-
 (provide 'unrmail)
 
 ;;; unrmail.el ends here