lisp/mail/pmailsort.el

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