code.delx.au - gnu-emacs/blob - lisp/mail/rmailsort.el

   1 ;;; rmailsort.el --- Rmail: sort messages
   2
   3 ;; Copyright (C) 1990, 1993-1994, 2001-2012  Free Software Foundation, Inc.
   4
   5 ;; Author: Masanobu UMEDA <umerin@mse.kyutech.ac.jp>
   6 ;; Maintainer: FSF
   7 ;; Keywords: mail
   8 ;; Package: rmail
   9
  10 ;; This file is part of GNU Emacs.
  11
  12 ;; GNU Emacs is free software: you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation, either version 3 of the License, or
  15 ;; (at your option) any later version.
  16
  17 ;; GNU Emacs is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  24
  25 ;;; Commentary:
  26
  27 ;; Functions for sorting messages in an Rmail buffer.
  28
  29 ;;; Code:
  30
  31 (require 'rmail)
  32
  33 ;;;###autoload
  34 (defun rmail-sort-by-date (reverse)
  35   "Sort messages of current Rmail buffer by \"Date\" header.
  36 If prefix argument REVERSE is non-nil, sorts in reverse order."
  37   (interactive "P")
  38   (rmail-sort-messages reverse
  39                        (lambda (msg)
  40                          (rmail-make-date-sortable
  41                           (rmail-get-header "Date" msg)))))
  42
  43 ;;;###autoload
  44 (defun rmail-sort-by-subject (reverse)
  45   "Sort messages of current Rmail buffer by \"Subject\" header.
  46 Ignores any \"Re: \" prefix.  If prefix argument REVERSE is
  47 non-nil, sorts in reverse order."
  48   ;; Note this is a case-sensitive sort.
  49   (interactive "P")
  50   (rmail-sort-messages reverse
  51                        (lambda (msg)
  52                          (let ((key (or (rmail-get-header "Subject" msg) ""))
  53                                (case-fold-search t))
  54                            ;; Remove `Re:'
  55                            (if (string-match "^\\(re:[ \t]*\\)*" key)
  56                                (substring key (match-end 0))
  57                              key)))))
  58
  59 ;;;###autoload
  60 (defun rmail-sort-by-author (reverse)
  61   "Sort messages of current Rmail buffer by author.
  62 This uses either the \"From\" or \"Sender\" header, downcased.
  63 If prefix argument REVERSE is non-nil, sorts in reverse order."
  64   (interactive "P")
  65   (rmail-sort-messages reverse
  66                        (lambda (msg)
  67                          (downcase      ; canonical name
  68                           (mail-strip-quoted-names
  69                            (or (rmail-get-header "From" msg)
  70                                (rmail-get-header "Sender" msg) ""))))))
  71
  72 ;;;###autoload
  73 (defun rmail-sort-by-recipient (reverse)
  74   "Sort messages of current Rmail buffer by recipient.
  75 This uses either the \"To\" or \"Apparently-To\" header, downcased.
  76 If prefix argument REVERSE is non-nil, sorts in reverse order."
  77   (interactive "P")
  78   (rmail-sort-messages reverse
  79                        (lambda (msg)
  80                          (downcase      ; canonical name
  81                           (mail-strip-quoted-names
  82                            (or (rmail-get-header "To" msg)
  83                                (rmail-get-header "Apparently-To" msg) ""))))))
  84
  85 ;;;###autoload
  86 (defun rmail-sort-by-correspondent (reverse)
  87   "Sort messages of current Rmail buffer by other correspondent.
  88 This uses either the \"From\", \"Sender\", \"To\", or
  89 \"Apparently-To\" header, downcased.  Uses the first header not
  90 excluded by `mail-dont-reply-to-names'.  If prefix argument
  91 REVERSE is non-nil, sorts in reverse order."
  92   (interactive "P")
  93   (rmail-sort-messages reverse
  94                        (lambda (msg)
  95                          (downcase
  96                           (rmail-select-correspondent
  97                            msg
  98                            '("From" "Sender" "To" "Apparently-To"))))))
  99
 100 (defun rmail-select-correspondent (msg fields)
 101   "Find the first header not excluded by `mail-dont-reply-to-names'.
 102 MSG is a message number.  FIELDS is a list of header names."
 103   (let ((ans ""))
 104     (while (and fields (string= ans ""))
 105       (setq ans
 106             (mail-dont-reply-to
 107              (mail-strip-quoted-names
 108               (or (rmail-get-header (car fields) msg) ""))))
 109       (setq fields (cdr fields)))
 110     ans))
 111
 112 ;;;###autoload
 113 (defun rmail-sort-by-lines (reverse)
 114   "Sort messages of current Rmail buffer by the number of lines.
 115 If prefix argument REVERSE is non-nil, sorts in reverse order."
 116   (interactive "P")
 117   (rmail-sort-messages reverse
 118                        (lambda (msg)
 119                          (count-lines (rmail-msgbeg msg)
 120                                       (rmail-msgend msg)))))
 121
 122 ;;;###autoload
 123 (defun rmail-sort-by-labels (reverse labels)
 124   "Sort messages of current Rmail buffer by labels.
 125 LABELS is a comma-separated list of labels.  The order of these
 126 labels specifies the order of messages: messages with the first
 127 label come first, messages with the second label come second, and
 128 so on.  Messages that have none of these labels come last.
 129 If prefix argument REVERSE is non-nil, sorts in reverse order."
 130   (interactive "P\nsSort by labels: ")
 131   (or (string-match "[^ \t]" labels)    ; need some non-whitespace
 132       (error "No labels specified"))
 133   ;; Remove leading whitespace, add trailing comma.
 134   (setq labels (concat (substring labels (match-beginning 0)) ","))
 135   (let (labelvec nmax)
 136     ;; Convert "l1,..." into "\\(, \\|\\`\\)l1\\(,\\|\\'\\)" "..." ...
 137     (while (string-match "[ \t]*,[ \t]*" labels)
 138       (setq labelvec (cons
 139                       (concat "\\(, \\|\\`\\)"
 140                               (substring labels 0 (match-beginning 0))
 141                               "\\(,\\|\\'\\)")
 142                       labelvec))
 143       (setq labels (substring labels (match-end 0))))
 144     (setq labelvec (apply 'vector (nreverse labelvec))
 145           nmax (length labelvec))
 146     (rmail-sort-messages reverse
 147                          ;; If no labels match, returns nmax; if they
 148                          ;; match the first specified in LABELS,
 149                          ;; returns 0; if they match the second, returns 1; etc.
 150                          ;; Hence sorts as described in the doc-string.
 151                          (lambda (msg)
 152                            (let ((n 0)
 153                                  (str (concat (rmail-get-attr-names msg)
 154                                               ", "
 155                                               (rmail-get-keywords msg))))
 156                              ;; No labels: can't match anything.
 157                              (if (string-equal ", " str)
 158                                  nmax
 159                                (while (and (< n nmax)
 160                                            (not (string-match (aref labelvec n)
 161                                                               str)))
 162                                  (setq n (1+ n)))
 163                                n))))))
 164 \f
 165 ;; Basic functions
 166 (declare-function rmail-update-summary "rmailsum" (&rest ignore))
 167
 168 (defun rmail-sort-messages (reverse keyfun)
 169   "Sort messages of current Rmail buffer.
 170 If REVERSE is non-nil, sorts in reverse order.  Calls the
 171 function KEYFUN with a message number (it should return a sort key).
 172 Numeric keys are sorted numerically, all others as strings."
 173   (with-current-buffer rmail-buffer
 174     (let ((return-to-point
 175            (if (rmail-buffers-swapped-p)
 176                (point)))
 177           (sort-lists nil))
 178       (rmail-swap-buffers-maybe)
 179       (message "Finding sort keys...")
 180       (widen)
 181       (let ((msgnum 1))
 182         (while (>= rmail-total-messages msgnum)
 183           (setq sort-lists
 184                 (cons (list (funcall keyfun msgnum) ;Make sorting key
 185                             (eq rmail-current-message msgnum) ;True if current
 186                             (aref rmail-message-vector msgnum)
 187                             (aref rmail-message-vector (1+ msgnum)))
 188                       sort-lists))
 189           (if (zerop (% msgnum 10))
 190               (message "Finding sort keys...%d" msgnum))
 191           (setq msgnum (1+ msgnum))))
 192       (or reverse (setq sort-lists (nreverse sort-lists)))
 193       (setq sort-lists
 194             (sort sort-lists
 195                   ;; Decide predicate: < or string-lessp
 196                   (if (numberp (car (car sort-lists))) ;Is a key numeric?
 197                       'car-less-than-car
 198                     (lambda (a b)
 199                       (string-lessp (car a) (car b))))))
 200       (if reverse (setq sort-lists (nreverse sort-lists)))
 201       ;; Now we enter critical region.  So, keyboard quit is disabled.
 202       (message "Reordering messages...")
 203       (let ((inhibit-quit t)            ;Inhibit quit
 204             (inhibit-read-only t)
 205             (current-message nil)
 206             (msgnum 1)
 207             (msginfo nil)
 208             (undo (not (eq buffer-undo-list t))))
 209         ;; There's little hope that we can easily undo after that.
 210         (buffer-disable-undo (current-buffer))
 211         (goto-char (rmail-msgbeg 1))
 212         ;; To force update of all markers,
 213         ;; keep the new copies separated from the remaining old messages.
 214         (insert-before-markers ?Z)
 215         (backward-char 1)
 216         ;; Now reorder messages.
 217         (dolist (msginfo sort-lists)
 218           ;; Swap two messages.
 219           (insert-buffer-substring
 220            (current-buffer) (nth 2 msginfo) (nth 3 msginfo))
 221           ;; The last message may not have \n\n after it.
 222           (rmail-ensure-blank-line)
 223           (delete-region (nth 2 msginfo) (nth 3 msginfo))
 224           ;; Is current message?
 225           (if (nth 1 msginfo)
 226               (setq current-message msgnum))
 227           (if (zerop (% msgnum 10))
 228               (message "Reordering messages...%d" msgnum))
 229           (setq msgnum (1+ msgnum)))
 230         ;; Delete the dummy separator Z inserted before.
 231         (delete-char 1)
 232         (setq quit-flag nil)
 233         ;; If undo was on before, re-enable it.  But note that it is
 234         ;; disabled in mbox Rmail, so this is kind of pointless.
 235         (if undo (buffer-enable-undo))
 236         (rmail-set-message-counters)
 237         (rmail-show-message-1 current-message)
 238         (if return-to-point
 239             (goto-char return-to-point))
 240         (if (rmail-summary-exists)
 241             (rmail-select-summary (rmail-update-summary)))))))
 242
 243 (autoload 'timezone-make-date-sortable "timezone")
 244
 245 (defun rmail-make-date-sortable (date)
 246   "Make DATE sortable using the function `string-lessp'."
 247   ;; Assume the default time zone is GMT.
 248   (timezone-make-date-sortable date "GMT" "GMT"))
 249
 250 (provide 'rmailsort)
 251
 252 ;; Local Variables:
 253 ;; generated-autoload-file: "rmail.el"
 254 ;; End:
 255
 256 ;;; rmailsort.el ends here