X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/51693c8c83c3ae56cdd9011c7536012681d07df7..d33e73c1eb79ebf599a896a4e05ec9cc28f470b2:/lisp/mail/rmailsort.el diff --git a/lisp/mail/rmailsort.el b/lisp/mail/rmailsort.el index c9fa8057ee..3194358451 100644 --- a/lisp/mail/rmailsort.el +++ b/lisp/mail/rmailsort.el @@ -1,36 +1,42 @@ -;;; Rmail: sort messages. -;; Copyright (C) 1990 Masanobu UMEDA -;; umerin@tc.Nagasaki.GO.JP? +;;; rmailsort.el --- Rmail: sort messages + +;; Copyright (C) 1990, 1993, 1994, 2001 Free Software Foundation, Inc. + +;; Author: Masanobu UMEDA +;; Maintainer: FSF +;; Keywords: mail ;; This file is part of GNU Emacs. +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + ;; 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. +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; Code: -(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) -(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) +;; For rmail-select-summary +(require 'rmail) + +(autoload 'timezone-make-date-sortable "timezone") +;; Sorting messages in Rmail buffer + +;;;###autoload (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." @@ -38,9 +44,10 @@ 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")))))) +;;;###autoload (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." @@ -51,9 +58,11 @@ If prefix argument REVERSE is non-nil, sort them in reverse order." (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)))))) + (if (string-match "^\\(re:[ \t]*\\)*" key) + (substring key (match-end 0)) + key)))))) +;;;###autoload (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." @@ -61,10 +70,12 @@ 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") ""))))))) +;;;###autoload (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." @@ -72,11 +83,13 @@ 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") "") + )))))) +;;;###autoload (defun rmail-sort-by-correspondent (reverse) "Sort messages of current Rmail file by other correspondent. If prefix argument REVERSE is non-nil, sort them in reverse order." @@ -90,68 +103,134 @@ 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)) + +;;;###autoload +(defun rmail-sort-by-lines (reverse) + "Sort messages of current Rmail file by number of lines. 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 msg) + (rmail-msgend msg)))))) + +;;;###autoload +(defun rmail-sort-by-labels (reverse labels) + "Sort messages of current Rmail file by labels. +If prefix argument REVERSE is non-nil, sort them in reverse order. +KEYWORDS is a comma-separated list of labels." + (interactive "P\nsSort by labels: ") + (or (string-match "[^ \t]" labels) + (error "No labels specified")) + (setq labels (concat (substring labels (match-beginning 0)) ",")) + (let (labelvec) + (while (string-match "[ \t]*,[ \t]*" labels) + (setq labelvec (cons + (concat ", ?\\(" + (substring labels 0 (match-beginning 0)) + "\\),") + labelvec)) + (setq labels (substring labels (match-end 0)))) + (setq labelvec (apply 'vector (nreverse labelvec))) + (rmail-sort-messages reverse + (function + (lambda (msg) + (let ((n 0)) + (while (and (< n (length labelvec)) + (not (rmail-message-labels-p + msg (aref labelvec n)))) + (setq n (1+ n))) + n)))))) +;; Basic functions -(defun rmail-sort-messages (reverse keyfunc) +(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." - (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)) - (if (zerop (% msgnum 10)) - (message "Finding sort keys...%d" msgnum)) - (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)) - (let ((msgnum 1)) - (while sort-lists - (insert (cdr (car sort-lists))) - (if (zerop (% msgnum 10)) - (message "Reordering buffer...%d" msgnum)) - (setq sort-lists (cdr sort-lists)) - (setq msgnum (1+ msgnum)))) - (rmail-set-message-counters) - (rmail-show-message))) +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." + (save-current-buffer + ;; If we are in a summary buffer, operate on the Rmail buffer. + (if (eq major-mode 'rmail-summary-mode) + (set-buffer rmail-buffer)) + (let ((buffer-read-only nil) + (point-offset (- (point) (point-min))) + (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 (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) + (funcall predicate (car a) (car b)))))) + (if reverse (setq sort-lists (nreverse sort-lists))) + ;; 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-disable-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 + (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)) + (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) + (goto-char (+ point-offset (point-min))) + (if (rmail-summary-exists) + (rmail-select-summary + (rmail-update-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) @@ -160,38 +239,12 @@ 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"))) - (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))) - ;; 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")) + +(provide 'rmailsort) + +;;; arch-tag: 0d90896b-0c35-46ac-b240-38be5ada2360 +;;; rmailsort.el ends here