lisp/mail/rmailsort.el

   1 ;;; rmailsort.el --- Rmail: sort messages
   2
   3 ;; Copyright (C) 1990, 1993, 1994, 2001, 2002, 2003, 2004, 2005, 2006,
   4 ;;   2007, 2008, 2009  Free Software Foundation, Inc.
   5
   6 ;; Author: Masanobu UMEDA <umerin@mse.kyutech.ac.jp>
   7 ;; Maintainer: FSF
   8 ;; Keywords: mail
   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 `rmail-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 `rmail-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             ;; NB despite the name, this lives in mail-utils.el.
 107             (rmail-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 ;; arch-tag: 665da245-f6a7-4115-ad8c-ba19216988d5
 254 ;;; rmailsort.el ends here