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

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