Mercurial > emacs

changeset 55497:85aa052b7bf2

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
(unrmail): Mostly rewritten. Parses the file directly, without calling any functions in Rmail. (unrmail-unprune): Function deleted.
author Richard M. Stallman <rms@gnu.org>
date Mon, 10 May 2004 16:24:26 +0000
parents 7463d23ad340
children 2b06def87ce0
files lisp/mail/unrmail.el
diffstat 1 files changed, 121 insertions(+), 68 deletions(-) [+]
line wrap: on
line diff
--- a/lisp/mail/unrmail.el	Mon May 10 15:54:52 2004 +0000
+++ b/lisp/mail/unrmail.el	Mon May 10 16:24:26 2004 +0000
@@ -51,43 +51,71 @@
 (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 @@
 	    (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 @@
 		   (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 @@
 	      (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