New version from Umeda. Needs detailed entry.

1 files changed, 186 insertions, 104 deletions

diff --git a/lisp/mail/rmailsort.el b/lisp/mail/rmailsort.el
index 182da0613ef..a1c2e91a87e 100644
--- a/lisp/mail/rmailsort.el
+++ b/lisp/mail/rmailsort.el
@@ -1,7 +1,9 @@
 ;;; rmailsort.el --- Rmail: sort messages.
 
-;; Copyright (C) 1990 Free Software Foundation, Inc.
+;; Copyright (C) 1990, 1993 Free Software Foundation, Inc.
 
+;; Author: Masanobu UMEDA <umerin@mse.kyutech.ac.jp>
+;; Version: $Header: rmailsort.el,v 1.6 93/05/26 22:24:42 umerin Exp $
 ;; Keywords: mail
 
 ;; This file is part of GNU Emacs.
@@ -20,18 +22,48 @@
 ;; along with GNU Emacs; see the file COPYING.  If not, write to
 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
 
+;;; Commentary:
+
+;; LCD Archive Entry:
+;; rmailsort|Masanobu UMEDA|umerin@mse.kyutech.ac.jp|
+;; Rmail: sort messages.|
+;; $Date: 93/05/26 22:24:42 $|$Revision: 1.6 $|~/misc/rmailsort.el.Z|
+
 ;;; Code:
 
 (require 'rmail)
 (require 'sort)
 
+(autoload 'timezone-make-date-sortable "timezone")
+
 ;; GNUS compatible key bindings.
+
 (define-key rmail-mode-map "\C-c\C-s\C-d" 'rmail-sort-by-date)
 (define-key rmail-mode-map "\C-c\C-s\C-s" 'rmail-sort-by-subject)
 (define-key rmail-mode-map "\C-c\C-s\C-a" 'rmail-sort-by-author)
 (define-key rmail-mode-map "\C-c\C-s\C-r" 'rmail-sort-by-recipient)
 (define-key rmail-mode-map "\C-c\C-s\C-c" 'rmail-sort-by-correspondent)
-(define-key rmail-mode-map "\C-c\C-s\C-l" 'rmail-sort-by-size-lines)
+(define-key rmail-mode-map "\C-c\C-s\C-l" 'rmail-sort-by-lines)
+
+;; Key binding may not be installed unless Rmail Summary mode is loaded.
+(if (boundp 'rmail-summary-mode-map)
+    (progn
+      (define-key rmail-summary-mode-map
+	"\C-c\C-s\C-d" 'rmail-summary-sort-by-date)
+      (define-key rmail-summary-mode-map
+	"\C-c\C-s\C-s" 'rmail-summary-sort-by-subject)
+      (define-key rmail-summary-mode-map
+	"\C-c\C-s\C-a" 'rmail-summary-sort-by-author)
+      (define-key rmail-summary-mode-map
+	"\C-c\C-s\C-r" 'rmail-summary-sort-by-recipient)
+      (define-key rmail-summary-mode-map
+	"\C-c\C-s\C-c" 'rmail-summary-sort-by-correspondent)
+      (define-key rmail-summary-mode-map
+	"\C-c\C-s\C-l" 'rmail-summary-sort-by-lines)
+      ))
+
+
+;; Sorting messages in Rmail buffer
 
 (defun rmail-sort-by-date (reverse)
   "Sort messages of current Rmail file by date.
@@ -40,7 +72,7 @@ If prefix argument REVERSE is non-nil, sort them in reverse order."
   (rmail-sort-messages reverse
 		       (function
 			(lambda (msg)
-			  (rmail-sortable-date-string
+			  (rmail-make-date-sortable
 			   (rmail-fetch-field msg "Date"))))))
 
 (defun rmail-sort-by-subject (reverse)
@@ -63,9 +95,10 @@ If prefix argument REVERSE is non-nil, sort them in reverse order."
   (rmail-sort-messages reverse
 		       (function
 			(lambda (msg)
-			  (mail-strip-quoted-names
-			   (or (rmail-fetch-field msg "From")
-			       (rmail-fetch-field msg "Sender") ""))))))
+			  (downcase	;Canonical name
+			   (mail-strip-quoted-names
+			    (or (rmail-fetch-field msg "From")
+				(rmail-fetch-field msg "Sender") "")))))))
 
 (defun rmail-sort-by-recipient (reverse)
   "Sort messages of current Rmail file by recipient.
@@ -74,10 +107,11 @@ If prefix argument REVERSE is non-nil, sort them in reverse order."
   (rmail-sort-messages reverse
 		       (function
 			(lambda (msg)
-			  (mail-strip-quoted-names
-			   (or (rmail-fetch-field msg "To")
-			       (rmail-fetch-field msg "Apparently-To") "")
-			   )))))
+			  (downcase	;Canonical name
+			   (mail-strip-quoted-names
+			    (or (rmail-fetch-field msg "To")
+				(rmail-fetch-field msg "Apparently-To") "")
+			    ))))))
 
 (defun rmail-sort-by-correspondent (reverse)
   "Sort messages of current Rmail file by other correspondent.
@@ -92,70 +126,142 @@ If prefix argument REVERSE is non-nil, sort them in reverse order."
 
 (defun rmail-select-correspondent (msg fields)
   (let ((ans ""))
-   (while (and fields (string= ans ""))
-     (setq ans
-	   (rmail-dont-reply-to
-	    (mail-strip-quoted-names
-	     (or (rmail-fetch-field msg (car fields)) ""))))
-     (setq fields (cdr fields)))
-   ans))
-
-(defun rmail-sort-by-size-lines (reverse)
-  "Sort messages of current Rmail file by message size.
+    (while (and fields (string= ans ""))
+      (setq ans
+	    (rmail-dont-reply-to
+	     (mail-strip-quoted-names
+	      (or (rmail-fetch-field msg (car fields)) ""))))
+      (setq fields (cdr fields)))
+    ans))
+
+(defun rmail-sort-by-lines (reverse)
+  "Sort messages of current Rmail file by lines of the message.
 If prefix argument REVERSE is non-nil, sort them in reverse order."
   (interactive "P")
   (rmail-sort-messages reverse
 		       (function
 			(lambda (msg)
-			  (format "%9d"
-				  (count-lines (rmail-msgbeg msgnum)
-					       (rmail-msgend msgnum)))))))
+			  (count-lines (rmail-msgbeg msgnum)
+				       (rmail-msgend msgnum))))))
 
+;; Sorting messages in Rmail Summary buffer.
+
+(defun rmail-summary-sort-by-date (reverse)
+  "Sort messages of current Rmail summary by date.
+If prefix argument REVERSE is non-nil, sort them in reverse order."
+  (interactive "P")
+  (rmail-sort-from-summary (function rmail-sort-by-date) reverse))
+
+(defun rmail-summary-sort-by-subject (reverse)
+  "Sort messages of current Rmail summary by subject.
+If prefix argument REVERSE is non-nil, sort them in reverse order."
+  (interactive "P")
+  (rmail-sort-from-summary (function rmail-sort-by-subject) reverse))
 
-(defun rmail-sort-messages (reverse keyfunc)
+(defun rmail-summary-sort-by-author (reverse)
+  "Sort messages of current Rmail summary by author.
+If prefix argument REVERSE is non-nil, sort them in reverse order."
+  (interactive "P")
+  (rmail-sort-from-summary (function rmail-sort-by-author) reverse))
+
+(defun rmail-summary-sort-by-recipient (reverse)
+  "Sort messages of current Rmail summary by recipient.
+If prefix argument REVERSE is non-nil, sort them in reverse order."
+  (interactive "P")
+  (rmail-sort-from-summary (function rmail-sort-by-recipient) reverse))
+
+(defun rmail-summary-sort-by-correspondent (reverse)
+  "Sort messages of current Rmail summary by other correspondent.
+If prefix argument REVERSE is non-nil, sort them in reverse order."
+  (interactive "P")
+  (rmail-sort-from-summary (function rmail-sort-by-correspondent) reverse))
+
+(defun rmail-summary-sort-by-lines (reverse)
+  "Sort messages of current Rmail summary by lines of the message.
+If prefix argument REVERSE is non-nil, sort them in reverse order."
+  (interactive "P")
+  (rmail-sort-from-summary (function rmail-sort-by-lines) reverse))
+
+
+;; Basic functions
+
+(defun rmail-sort-messages (reverse keyfun)
   "Sort messages of current Rmail file.
-1st argument REVERSE is non-nil, sort them in reverse order.
-2nd argument KEYFUNC is called with message number, and should return a key."
- (or (eq major-mode 'rmail-mode)
-     (error "Current buffer not in Rmail mode"))
+If 1st argument REVERSE is non-nil, sort them in reverse order.
+2nd argument KEYFUN is called with a message number, and should return a key."
   (let ((buffer-read-only nil)
+	(predicate nil)			;< or string-lessp
 	(sort-lists nil))
     (message "Finding sort keys...")
     (widen)
     (let ((msgnum 1))
       (while (>= rmail-total-messages msgnum)
 	(setq sort-lists
-	      (cons (cons (funcall keyfunc msgnum) ;A sort key.
-			  (buffer-substring
-			   (rmail-msgbeg msgnum) (rmail-msgend msgnum)))
+	      (cons (list (funcall keyfun msgnum) ;Make sorting key
+			  (eq rmail-current-message msgnum) ;True if current
+			  (aref rmail-message-vector msgnum)
+			  (aref rmail-message-vector (1+ msgnum)))
 		    sort-lists))
 	(if (zerop (% msgnum 10))
 	    (message "Finding sort keys...%d" msgnum))
 	(setq msgnum (1+ msgnum))))
     (or reverse (setq sort-lists (nreverse sort-lists)))
+    ;; Decide predicate: < or string-lessp
+    (if (numberp (car (car sort-lists))) ;Is a key numeric?
+	(setq predicate (function <))
+      (setq predicate (function string-lessp)))
     (setq sort-lists
 	  (sort sort-lists
 		(function
 		 (lambda (a b)
-		   (string-lessp (car a) (car b))))))
+		   (funcall predicate (car a) (car b))))))
     (if reverse (setq sort-lists (nreverse sort-lists)))
-    (message "Reordering buffer...")
-    (delete-region (rmail-msgbeg 1) (rmail-msgend rmail-total-messages))
-    (let ((msgnum 1))
+    ;; Now we enter critical region.  So, keyboard quit is disabled.
+    (message "Reordering messages...")
+    (let ((inhibit-quit t)		;Inhibit quit
+	  (current-message nil)
+	  (msgnum 1)
+	  (msginfo nil))
+      ;; There's little hope that we can easily undo after that.
+      (buffer-flush-undo (current-buffer))
+      (goto-char (rmail-msgbeg 1))
+      ;; To force update of all markers.
+      (insert-before-markers ?Z)
+      (backward-char 1)
+      ;; Now reorder messages.
       (while sort-lists
-	(insert (cdr (car sort-lists)))
-	(if (zerop (% msgnum 10))
-	    (message "Reordering buffer...%d" msgnum))
+	(setq msginfo (car sort-lists))
+	;; Swap two messages.
+	(insert-buffer-substring
+	 (current-buffer) (nth 2 msginfo) (nth 3 msginfo))
+	(delete-region  (nth 2 msginfo) (nth 3 msginfo))
+	;; Is current message?
+	(if (nth 1 msginfo)
+	    (setq current-message msgnum))
 	(setq sort-lists (cdr sort-lists))
-	(setq msgnum (1+ msgnum))))
-    (rmail-set-message-counters)
-    (rmail-show-message 1)))
+	(if (zerop (% msgnum 10))
+	    (message "Reordering messages...%d" msgnum))
+	(setq msgnum (1+ msgnum)))
+      ;; Delete the garbage inserted before.
+      (delete-char 1)
+      (setq quit-flag nil)
+      (buffer-enable-undo)
+      (rmail-set-message-counters)
+      (rmail-show-message current-message))
+    ))
+
+(defun rmail-sort-from-summary (sortfun reverse)
+  "Sort Rmail messages from Summary buffer and update it after sorting."
+  (pop-to-buffer rmail-buffer)
+  (funcall sortfun reverse)
+  (rmail-summary))
 
 (defun rmail-fetch-field (msg field)
-  "Return the value of the header field FIELD of MSG.
+  "Return the value of the header FIELD of MSG.
 Arguments are MSG and FIELD."
-  (let ((next (rmail-msgend msg)))
-    (save-restriction
+  (save-restriction
+    (widen)
+    (let ((next (rmail-msgend msg)))
       (goto-char (rmail-msgbeg msg))
       (narrow-to-region (if (search-forward "\n*** EOOH ***\n" next t)
 			    (point)
@@ -164,66 +270,42 @@ Arguments are MSG and FIELD."
 			(progn (search-forward "\n\n" nil t) (point)))
       (mail-fetch-field field))))
 
-;; Copy of the function gnus-comparable-date in gnus.el
-
-(defun rmail-sortable-date-string (date)
-  "Make sortable string by string-lessp from DATE."
-  (let ((month '(("JAN" . " 1")("FEB" . " 2")("MAR" . " 3")
-		 ("APR" . " 4")("MAY" . " 5")("JUN" . " 6")
-		 ("JUL" . " 7")("AUG" . " 8")("SEP" . " 9")
-		 ("OCT" . "10")("NOV" . "11")("DEC" . "12")
-		 ("JANUARY" . " 1") ("FEBRUARY" . " 2")
-		 ("MARCH" . " 3")   ("APRIL" . " 4")
-		 ("MAY" . " 5")     ("JUNE" . " 6")
-		 ("JULY" . " 7")    ("AUGUST" . " 8")
-		 ("SEPTEMBER" " 9") ("OCTOBER" . "10")
-		 ("NOVEMBER" "11")  ("DECEMBER" . "12")))
-	(date (or date "")))
-    ;; Can understand the following styles:
-    ;; (1) 14 Apr 89 03:20:12 GMT
-    ;; (2) Fri, 17 Mar 89 4:01:33 GMT
-    (if (string-match
-	 "\\([0-9]+\\) +\\([^ ,]+\\) +\\([0-9]+\\) +\\([0-9:]+\\)" date)
-	(concat
-	 ;; Year
-	 (rmail-date-full-year
-	  (substring date (match-beginning 3) (match-end 3)))
-	 ;; Month
-	 (cdr
-	  (assoc
-	   (upcase (substring date (match-beginning 2) (match-end 2))) month))
-	 ;; Day
-	 (format "%2d" (string-to-int
-			(substring date
-				   (match-beginning 1) (match-end 1))))
-	 ;; Time
-	 (substring date (match-beginning 4) (match-end 4)))
-
-      ;; Handles this format Fri May 10 21:51:55 1991
-      (if (string-match
-         " \\([a-z][a-z][a-z]\\) +\\([0-9]+\\) \\([0-9:]+\\) \\([0-9]+\\)" date)
-	  (concat
-	   ;; Year
-	   (rmail-date-full-year 
-	    (substring date (match-beginning 4) (match-end 4)))
-	   ;; Month
-	   (cdr
-	    (assoc
-	     (upcase (substring date (match-beginning 1) (match-end 1))) month))
-	   ;; Day
-	   (format "%2d" (string-to-int
-			  (substring date
-				     (match-beginning 2) (match-end 2))))
-	   ;; Time
-	   (substring date (match-beginning 3) (match-end 3)))
-
-      ;; Cannot understand DATE string.
-      date))))
-
-(defun rmail-date-full-year (year-string)
-  (if (<= (length year-string) 2)
-      (concat "19" year-string)
-    year-string))
+(defun rmail-make-date-sortable (date)
+  "Make DATE sortable using the function string-lessp."
+  ;; Assume the default time zone is GMT.
+  (timezone-make-date-sortable date "GMT" "GMT"))
+
+;; Copy of the function gnus-comparable-date in gnus.el version 3.13
+;
+;(defun rmail-make-date-sortable (date)
+;  "Make sortable string by string-lessp from DATE."
+;  (let ((month '(("JAN" . " 1")("FEB" . " 2")("MAR" . " 3")
+;		 ("APR" . " 4")("MAY" . " 5")("JUN" . " 6")
+;		 ("JUL" . " 7")("AUG" . " 8")("SEP" . " 9")
+;		 ("OCT" . "10")("NOV" . "11")("DEC" . "12")))
+;	(date (or date "")))
+;    ;; Can understand the following styles:
+;    ;; (1) 14 Apr 89 03:20:12 GMT
+;    ;; (2) Fri, 17 Mar 89 4:01:33 GMT
+;    (if (string-match
+;	 "\\([0-9]+\\) \\([^ ,]+\\) \\([0-9]+\\) \\([0-9:]+\\)" date)
+;	(concat
+;	 ;; Year
+;	 (substring date (match-beginning 3) (match-end 3))
+;	 ;; Month
+;	 (cdr
+;	  (assoc
+;	   (upcase (substring date (match-beginning 2) (match-end 2))) month))
+;	 ;; Day
+;	 (format "%2d" (string-to-int
+;			(substring date
+;				   (match-beginning 1) (match-end 1))))
+;	 ;; Time
+;	 (substring date (match-beginning 4) (match-end 4)))
+;      ;; Cannot understand DATE string.
+;      date
+;      )
+;    ))
 
 (provide 'rmailsort)