lisp/mail/rmailsort.el

   1 ;;; rmailsort.el --- Rmail: sort messages
   2
   3 ;; Copyright (C) 1990, 1993, 1994, 2001 Free Software Foundation, Inc.
   4
   5 ;; Author: Masanobu UMEDA <umerin@mse.kyutech.ac.jp>
   6 ;; Maintainer: FSF
   7 ;; Keywords: mail
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, USA.
  25
  26 ;;; Commentary:
  27
  28 ;;; Code:
  29
  30 (require 'sort)
  31
  32 ;; For rmail-select-summary
  33 (require 'rmail)
  34
  35 (autoload 'timezone-make-date-sortable "timezone")
  36
  37 ;; Sorting messages in Rmail buffer
  38
  39 ;;;###autoload
  40 (defun rmail-sort-by-date (reverse)
  41   "Sort messages of current Rmail file by date.
  42 If prefix argument REVERSE is non-nil, sort them in reverse order."
  43   (interactive "P")
  44   (rmail-sort-messages reverse
  45                        (function
  46                         (lambda (msg)
  47                           (rmail-make-date-sortable
  48                            (rmail-fetch-field msg "Date"))))))
  49
  50 ;;;###autoload
  51 (defun rmail-sort-by-subject (reverse)
  52   "Sort messages of current Rmail file by subject.
  53 If prefix argument REVERSE is non-nil, sort them in reverse order."
  54   (interactive "P")
  55   (rmail-sort-messages reverse
  56                        (function
  57                         (lambda (msg)
  58                           (let ((key (or (rmail-fetch-field msg "Subject") ""))
  59                                 (case-fold-search t))
  60                             ;; Remove `Re:'
  61                             (if (string-match "^\\(re:[ \t]*\\)*" key)
  62                                 (substring key (match-end 0))
  63                               key))))))
  64
  65 ;;;###autoload
  66 (defun rmail-sort-by-author (reverse)
  67   "Sort messages of current Rmail file by author.
  68 If prefix argument REVERSE is non-nil, sort them in reverse order."
  69   (interactive "P")
  70   (rmail-sort-messages reverse
  71                        (function
  72                         (lambda (msg)
  73                           (downcase     ;Canonical name
  74                            (mail-strip-quoted-names
  75                             (or (rmail-fetch-field msg "From")
  76                                 (rmail-fetch-field msg "Sender") "")))))))
  77
  78 ;;;###autoload
  79 (defun rmail-sort-by-recipient (reverse)
  80   "Sort messages of current Rmail file by recipient.
  81 If prefix argument REVERSE is non-nil, sort them in reverse order."
  82   (interactive "P")
  83   (rmail-sort-messages reverse
  84                        (function
  85                         (lambda (msg)
  86                           (downcase     ;Canonical name
  87                            (mail-strip-quoted-names
  88                             (or (rmail-fetch-field msg "To")
  89                                 (rmail-fetch-field msg "Apparently-To") "")
  90                             ))))))
  91
  92 ;;;###autoload
  93 (defun rmail-sort-by-correspondent (reverse)
  94   "Sort messages of current Rmail file by other correspondent.
  95 If prefix argument REVERSE is non-nil, sort them in reverse order."
  96   (interactive "P")
  97   (rmail-sort-messages reverse
  98                        (function
  99                         (lambda (msg)
 100                           (rmail-select-correspondent
 101                            msg
 102                            '("From" "Sender" "To" "Apparently-To"))))))
 103
 104 (defun rmail-select-correspondent (msg fields)
 105   (let ((ans ""))
 106     (while (and fields (string= ans ""))
 107       (setq ans
 108             (rmail-dont-reply-to
 109              (mail-strip-quoted-names
 110               (or (rmail-fetch-field msg (car fields)) ""))))
 111       (setq fields (cdr fields)))
 112     ans))
 113
 114 ;;;###autoload
 115 (defun rmail-sort-by-lines (reverse)
 116   "Sort messages of current Rmail file by number of lines.
 117 If prefix argument REVERSE is non-nil, sort them in reverse order."
 118   (interactive "P")
 119   (rmail-sort-messages reverse
 120                        (function
 121                         (lambda (msg)
 122                           (count-lines (rmail-msgbeg msg)
 123                                        (rmail-msgend msg))))))
 124
 125 ;;;###autoload
 126 (defun rmail-sort-by-labels (reverse labels)
 127   "Sort messages of current Rmail file by labels.
 128 If prefix argument REVERSE is non-nil, sort them in reverse order.
 129 KEYWORDS is a comma-separated list of labels."
 130   (interactive "P\nsSort by labels: ")
 131   (or (string-match "[^ \t]" labels)
 132       (error "No labels specified"))
 133   (setq labels (concat (substring labels (match-beginning 0)) ","))
 134   (let (labelvec)
 135     (while (string-match "[ \t]*,[ \t]*" labels)
 136       (setq labelvec (cons
 137                       (concat ", ?\\("
 138                               (substring labels 0 (match-beginning 0))
 139                               "\\),")
 140                       labelvec))
 141       (setq labels (substring labels (match-end 0))))
 142     (setq labelvec (apply 'vector (nreverse labelvec)))
 143     (rmail-sort-messages reverse
 144                          (function
 145                           (lambda (msg)
 146                             (let ((n 0))
 147                               (while (and (< n (length labelvec))
 148                                           (not (rmail-message-labels-p
 149                                                 msg (aref labelvec n))))
 150                                 (setq n (1+ n)))
 151                               n))))))
 152 \f
 153 ;; Basic functions
 154
 155 (defun rmail-sort-messages (reverse keyfun)
 156   "Sort messages of current Rmail file.
 157 If 1st argument REVERSE is non-nil, sort them in reverse order.
 158 2nd argument KEYFUN is called with a message number, and should return a key."
 159   (save-current-buffer
 160     ;; If we are in a summary buffer, operate on the Rmail buffer.
 161     (if (eq major-mode 'rmail-summary-mode)
 162         (set-buffer rmail-buffer))
 163     (let ((buffer-read-only nil)
 164           (point-offset (- (point) (point-min)))
 165           (predicate nil)                       ;< or string-lessp
 166           (sort-lists nil))
 167       (message "Finding sort keys...")
 168       (widen)
 169       (let ((msgnum 1))
 170         (while (>= rmail-total-messages msgnum)
 171           (setq sort-lists
 172                 (cons (list (funcall keyfun msgnum) ;Make sorting key
 173                             (eq rmail-current-message msgnum) ;True if current
 174                             (aref rmail-message-vector msgnum)
 175                             (aref rmail-message-vector (1+ msgnum)))
 176                       sort-lists))
 177           (if (zerop (% msgnum 10))
 178               (message "Finding sort keys...%d" msgnum))
 179           (setq msgnum (1+ msgnum))))
 180       (or reverse (setq sort-lists (nreverse sort-lists)))
 181       ;; Decide predicate: < or string-lessp
 182       (if (numberp (car (car sort-lists))) ;Is a key numeric?
 183           (setq predicate (function <))
 184         (setq predicate (function string-lessp)))
 185       (setq sort-lists
 186             (sort sort-lists
 187                   (function
 188                    (lambda (a b)
 189                      (funcall predicate (car a) (car b))))))
 190       (if reverse (setq sort-lists (nreverse sort-lists)))
 191       ;; Now we enter critical region.  So, keyboard quit is disabled.
 192       (message "Reordering messages...")
 193       (let ((inhibit-quit t)            ;Inhibit quit
 194             (current-message nil)
 195             (msgnum 1)
 196             (msginfo nil))
 197         ;; There's little hope that we can easily undo after that.
 198         (buffer-disable-undo (current-buffer))
 199         (goto-char (rmail-msgbeg 1))
 200         ;; To force update of all markers.
 201         (insert-before-markers ?Z)
 202         (backward-char 1)
 203         ;; Now reorder messages.
 204         (while sort-lists
 205           (setq msginfo (car sort-lists))
 206           ;; Swap two messages.
 207           (insert-buffer-substring
 208            (current-buffer) (nth 2 msginfo) (nth 3 msginfo))
 209           (delete-region  (nth 2 msginfo) (nth 3 msginfo))
 210           ;; Is current message?
 211           (if (nth 1 msginfo)
 212               (setq current-message msgnum))
 213           (setq sort-lists (cdr sort-lists))
 214           (if (zerop (% msgnum 10))
 215               (message "Reordering messages...%d" msgnum))
 216           (setq msgnum (1+ msgnum)))
 217         ;; Delete the garbage inserted before.
 218         (delete-char 1)
 219         (setq quit-flag nil)
 220         (buffer-enable-undo)
 221         (rmail-set-message-counters)
 222         (rmail-show-message current-message)
 223         (goto-char (+ point-offset (point-min)))
 224         (if (rmail-summary-exists)
 225             (rmail-select-summary
 226              (rmail-update-summary)))))))
 227
 228 (defun rmail-fetch-field (msg field)
 229   "Return the value of the header FIELD of MSG.
 230 Arguments are MSG and FIELD."
 231   (save-restriction
 232     (widen)
 233     (let ((next (rmail-msgend msg)))
 234       (goto-char (rmail-msgbeg msg))
 235       (narrow-to-region (if (search-forward "\n*** EOOH ***\n" next t)
 236                             (point)
 237                           (forward-line 1)
 238                           (point))
 239                         (progn (search-forward "\n\n" nil t) (point)))
 240       (mail-fetch-field field))))
 241
 242 (defun rmail-make-date-sortable (date)
 243   "Make DATE sortable using the function string-lessp."
 244   ;; Assume the default time zone is GMT.
 245   (timezone-make-date-sortable date "GMT" "GMT"))
 246
 247 (provide 'rmailsort)
 248
 249 ;;; rmailsort.el ends here