lisp/mail/rmailsort.el

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