1 files changed, 154 insertions, 0 deletions

diff --git a/lisp/mail/rmailsort.el b/lisp/mail/rmailsort.el
new file mode 100644
index 00000000000..867cc363506
--- /dev/null
+++ b/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
+      )
+    ))