changeset 47631:433ae412d00f

(unrmail): Do the work directly, without actually selecting the messages in the from file. (unrmail-unprune): New subroutine.

--- a/lisp/mail/unrmail.el	Thu Sep 26 22:00:22 2002 +0000
+++ b/lisp/mail/unrmail.el	Thu Sep 26 22:02:23 2002 +0000
@@ -1,6 +1,6 @@
 ;;; unrmail.el --- convert Rmail files to mailbox files
 
-;;; Copyright (C) 1992 Free Software Foundation, Inc.
+;;; Copyright (C) 1992, 2002 Free Software Foundation, Inc.
 
 ;; Maintainer: FSF
 ;; Keywords: mail
@@ -51,21 +51,125 @@
 (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 0)
+  (let ((message-count 1)
 	;; Prevent rmail from making, or switching to, a summary buffer.
 	(rmail-display-summary nil)
-	(rmail-delete-after-output nil))
+	(rmail-delete-after-output nil)
+	(temp-buffer (get-buffer-create " unrmail")))
     (rmail file)
     ;; 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)
-    (while (< message-count rmail-total-messages)
-      (rmail-show-message
-       (setq message-count (1+ message-count)))
-      (rmail-toggle-header)
-      (rmail-output to-file 1 t))
+    (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))
+	      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))))))
+	  (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)))
+    (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
+