Initial revision

lisp/mail/rmailsort.el

@@ -0,0 +1,154 @@
+;;; Rmail: sort messages.
+;; Copyright (C) 1990 Masanobu UMEDA
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY.  No author or distributor
+;; accepts responsibility to anyone for the consequences of using it
+;; or for whether it serves any particular purpose or works at all,
+;; unless he says so in writing.  Refer to the GNU Emacs General Public
+;; License for full details.
+
+;; Everyone is granted permission to copy, modify and redistribute
+;; GNU Emacs, but only under the conditions described in the
+;; GNU Emacs General Public License.   A copy of this license is
+;; supposed to have been given to you along with GNU Emacs so you
+;; can know your rights and responsibilities.  It should be in a
+;; file named COPYING.  Among other things, the copyright notice
+;; and this notice must be preserved on all copies.
+
+(provide 'rmailsort)
+(require 'rmail)
+(require 'sort)
+
+;; 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)
+
+(defun rmail-sort-by-date (reverse)
+  "Sort messages of current Rmail file by date.
+If prefix argument REVERSE is non-nil, sort them in reverse order."
+  (interactive "P")
+  (rmail-sort-messages reverse
+		       (function
+			(lambda (msg)
+			  (rmail-sortable-date-string
+			   (rmail-fetch-field msg "Date"))))))
+
+(defun rmail-sort-by-subject (reverse)
+  "Sort messages of current Rmail file by subject.
+If prefix argument REVERSE is non-nil, sort them in reverse order."
+  (interactive "P")
+  (rmail-sort-messages reverse
+		       (function
+			(lambda (msg)
+			  (let ((key (or (rmail-fetch-field msg "Subject") ""))
+				(case-fold-search t))
+			    ;; Remove `Re:'
+			    (if (string-match "^\\(re:[ \t]+\\)*" key)
+				(substring key (match-end 0)) key))))))
+
+(defun rmail-sort-by-author (reverse)
+  "Sort messages of current Rmail file by author.
+If prefix argument REVERSE is non-nil, sort them in reverse order."
+  (interactive "P")
+  (rmail-sort-messages reverse
+		       (function
+			(lambda (msg)
+			  (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.
+If prefix argument REVERSE is non-nil, sort them in reverse order."
+  (interactive "P")
+  (rmail-sort-messages reverse
+		       (function
+			(lambda (msg)
+			  (mail-strip-quoted-names
+			   (or (rmail-fetch-field msg "To")
+			       (rmail-fetch-field msg "Apparently-To") "")
+			   )))))
+
+
+
+(defun rmail-sort-messages (reverse keyfunc)
+  "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."
+  (let ((buffer-read-only nil)
+	(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)))
+		    sort-lists))
+	(setq msgnum (1+ msgnum))))
+    (or reverse (setq sort-lists (nreverse sort-lists)))
+    (setq sort-lists
+	  (sort sort-lists
+		(function
+		 (lambda (a b)
+		   (string-lessp (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))
+    (while sort-lists
+      (insert (cdr (car sort-lists)))
+      (setq sort-lists (cdr sort-lists)))
+    (rmail-set-message-counters)
+    (rmail-show-message)
+    ))
+
+(defun rmail-fetch-field (msg field)
+  "Return the value of the header field FIELD of MSG.
+Arguments are MSG and FIELD."
+  (let ((next (rmail-msgend msg)))
+    (save-restriction
+      (goto-char (rmail-msgbeg msg))
+      (narrow-to-region (if (search-forward "\n*** EOOH ***\n" next t)
+			    (point)
+			  (forward-line 1)
+			  (point))
+			(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")))
+	(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
+      )
+    ))