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