cgit.sxemacs.org Git - packages/blob - xemacs-packages/rmail/rmailsort.el

   1 ;;; rmailsort.el --- Rmail: sort messages.
   2
   3 ;; Copyright (C) 1990, 1993 Free Software Foundation, Inc.
   4
   5 ;; Author: Masanobu UMEDA <umerin@mse.kyutech.ac.jp>
   6 ;; Version: !Header: /home/fsf/rms/e19/lisp/RCS/rmailsort.el,v 1.16 1993/11/24 08:08:56 rms Exp !
   7 ;; Keywords: mail
   8
   9 ;; This file is part of XEmacs.
  10
  11 ;; XEmacs is free software; you can redistribute it and/or modify it
  12 ;; 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 ;; XEmacs is distributed in the hope that it will be useful, but
  17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  19 ;; General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with XEmacs; 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 (autoload 'timezone-make-date-sortable "timezone")
  31
  32 ;; Sorting messages in Rmail buffer
  33
  34 (defun rmail-sort-by-date (reverse)
  35   "Sort messages of current Rmail file by date.
  36 If prefix argument REVERSE is non-nil, sort them in reverse order."
  37   (interactive "P")
  38   (rmail-sort-messages reverse
  39                        (function
  40                         (lambda (msg)
  41                           (rmail-make-date-sortable
  42                            (rmail-fetch-field msg "Date"))))))
  43
  44 (defun rmail-sort-by-subject (reverse)
  45   "Sort messages of current Rmail file by subject.
  46 If prefix argument REVERSE is non-nil, sort them in reverse order."
  47   (interactive "P")
  48   (rmail-sort-messages reverse
  49                        (function
  50                         (lambda (msg)
  51                           (let ((key (or (rmail-fetch-field msg "Subject") ""))
  52                                 (case-fold-search t))
  53                             ;; Remove `Re:'
  54                             (if (string-match "^\\(re:[ \t]+\\)*" key)
  55                                 (substring key (match-end 0)) key))))))
  56
  57 (defun rmail-sort-by-author (reverse)
  58   "Sort messages of current Rmail file by author.
  59 If prefix argument REVERSE is non-nil, sort them in reverse order."
  60   (interactive "P")
  61   (rmail-sort-messages reverse
  62                        (function
  63                         (lambda (msg)
  64                           (downcase     ;Canonical name
  65                            (mail-strip-quoted-names
  66                             (or (rmail-fetch-field msg "From")
  67                                 (rmail-fetch-field msg "Sender") "")))))))
  68
  69 (defun rmail-sort-by-recipient (reverse)
  70   "Sort messages of current Rmail file by recipient.
  71 If prefix argument REVERSE is non-nil, sort them in reverse order."
  72   (interactive "P")
  73   (rmail-sort-messages reverse
  74                        (function
  75                         (lambda (msg)
  76                           (downcase     ;Canonical name
  77                            (mail-strip-quoted-names
  78                             (or (rmail-fetch-field msg "To")
  79                                 (rmail-fetch-field msg "Apparently-To") "")
  80                             ))))))
  81
  82 (defun rmail-sort-by-correspondent (reverse)
  83   "Sort messages of current Rmail file by other correspondent.
  84 If prefix argument REVERSE is non-nil, sort them in reverse order."
  85   (interactive "P")
  86   (rmail-sort-messages reverse
  87                        (function
  88                         (lambda (msg)
  89                           (rmail-select-correspondent
  90                            msg
  91                            '("From" "Sender" "To" "Apparently-To"))))))
  92
  93 (defun rmail-select-correspondent (msg fields)
  94   (let ((ans ""))
  95     (while (and fields (string= ans ""))
  96       (setq ans
  97             (rmail-dont-reply-to
  98              (mail-strip-quoted-names
  99               (or (rmail-fetch-field msg (car fields)) ""))))
 100       (setq fields (cdr fields)))
 101     ans))
 102
 103 (defun rmail-sort-by-lines (reverse)
 104   "Sort messages of current Rmail file by number of lines.
 105 If prefix argument REVERSE is non-nil, sort them in reverse order."
 106   (interactive "P")
 107   (rmail-sort-messages reverse
 108                        (function
 109                         (lambda (msg)
 110                           (count-lines (rmail-msgbeg msgnum)
 111                                        (rmail-msgend msgnum))))))
 112 \f
 113 ;; Basic functions
 114
 115 (defun rmail-sort-messages (reverse keyfun)
 116   "Sort messages of current Rmail file.
 117 If 1st argument REVERSE is non-nil, sort them in reverse order.
 118 2nd argument KEYFUN is called with a message number, and should return a key."
 119   (save-excursion
 120     ;; If we are in a summary buffer, operate on the Rmail buffer.
 121     (if (eq major-mode 'rmail-summary-mode)
 122         (set-buffer rmail-buffer))
 123     (let ((buffer-read-only nil)
 124           (predicate nil)                       ;< or string-lessp
 125           (sort-lists nil))
 126       (message "Finding sort keys...")
 127       (widen)
 128       (let ((msgnum 1))
 129         (while (>= rmail-total-messages msgnum)
 130           (setq sort-lists
 131                 (cons (list (funcall keyfun msgnum) ;Make sorting key
 132                             (eq rmail-current-message msgnum) ;True if current
 133                             (aref rmail-message-vector msgnum)
 134                             (aref rmail-message-vector (1+ msgnum)))
 135                       sort-lists))
 136           (if (zerop (% msgnum 10))
 137               (message "Finding sort keys...%d" msgnum))
 138           (setq msgnum (1+ msgnum))))
 139       (or reverse (setq sort-lists (nreverse sort-lists)))
 140       ;; Decide predicate: < or string-lessp
 141       (if (numberp (car (car sort-lists))) ;Is a key numeric?
 142           (setq predicate (function <))
 143         (setq predicate (function string-lessp)))
 144       (setq sort-lists
 145             (sort sort-lists
 146                   (function
 147                    (lambda (a b)
 148                      (funcall predicate (car a) (car b))))))
 149       (if reverse (setq sort-lists (nreverse sort-lists)))
 150       ;; Now we enter critical region.  So, keyboard quit is disabled.
 151       (message "Reordering messages...")
 152       (let ((inhibit-quit t)            ;Inhibit quit
 153             (current-message nil)
 154             (msgnum 1)
 155             (msginfo nil))
 156         ;; There's little hope that we can easily undo after that.
 157         (buffer-disable-undo (current-buffer))
 158         (goto-char (rmail-msgbeg 1))
 159         ;; To force update of all markers.
 160         (insert-before-markers ?Z)
 161         (backward-char 1)
 162         ;; Now reorder messages.
 163         (while sort-lists
 164           (setq msginfo (car sort-lists))
 165           ;; Swap two messages.
 166           (insert-buffer-substring
 167            (current-buffer) (nth 2 msginfo) (nth 3 msginfo))
 168           (delete-region  (nth 2 msginfo) (nth 3 msginfo))
 169           ;; Is current message?
 170           (if (nth 1 msginfo)
 171               (setq current-message msgnum))
 172           (setq sort-lists (cdr sort-lists))
 173           (if (zerop (% msgnum 10))
 174               (message "Reordering messages...%d" msgnum))
 175           (setq msgnum (1+ msgnum)))
 176         ;; Delete the garbage inserted before.
 177         (delete-char 1)
 178         (setq quit-flag nil)
 179         (buffer-enable-undo)
 180         (rmail-set-message-counters)
 181         (rmail-show-message current-message)))))
 182
 183 (defun rmail-fetch-field (msg field)
 184   "Return the value of the header FIELD of MSG.
 185 Arguments are MSG and FIELD."
 186   (save-restriction
 187     (widen)
 188     (let ((next (rmail-msgend msg)))
 189       (goto-char (rmail-msgbeg msg))
 190       (narrow-to-region (if (search-forward "\n*** EOOH ***\n" next t)
 191                             (point)
 192                           (forward-line 1)
 193                           (point))
 194                         (progn (search-forward "\n\n" nil t) (point)))
 195       (mail-fetch-field field))))
 196
 197 (defun rmail-make-date-sortable (date)
 198   "Make DATE sortable using the function string-lessp."
 199   ;; Assume the default time zone is GMT.
 200   (timezone-make-date-sortable date "GMT" "GMT"))
 201
 202 (provide 'rmailsort)
 203
 204 ;;; rmailsort.el ends here