1 ;;; rmailsort.el --- Rmail: sort messages
3 ;; Copyright (C) 1990, 1993, 1994, 2001 Free Software Foundation, Inc.
5 ;; Author: Masanobu UMEDA <umerin@mse.kyutech.ac.jp>
9 ;; This file is part of GNU Emacs.
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)
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.
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.
32 ;; For rmail-select-summary
35 (autoload 'timezone-make-date-sortable "timezone")
37 ;; Sorting messages in Rmail buffer
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."
44 (rmail-sort-messages reverse
47 (rmail-make-date-sortable
48 (rmail-fetch-field msg "Date"))))))
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."
55 (rmail-sort-messages reverse
58 (let ((key (or (rmail-fetch-field msg "Subject") ""))
61 (if (string-match "^\\(re:[ \t]*\\)*" key)
62 (substring key (match-end 0))
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."
70 (rmail-sort-messages reverse
73 (downcase ;Canonical name
74 (mail-strip-quoted-names
75 (or (rmail-fetch-field msg "From")
76 (rmail-fetch-field msg "Sender") "")))))))
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."
83 (rmail-sort-messages reverse
86 (downcase ;Canonical name
87 (mail-strip-quoted-names
88 (or (rmail-fetch-field msg "To")
89 (rmail-fetch-field msg "Apparently-To") "")
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."
97 (rmail-sort-messages reverse
100 (rmail-select-correspondent
102 '("From" "Sender" "To" "Apparently-To"))))))
104 (defun rmail-select-correspondent (msg fields)
106 (while (and fields (string= ans ""))
109 (mail-strip-quoted-names
110 (or (rmail-fetch-field msg (car fields)) ""))))
111 (setq fields (cdr fields)))
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."
119 (rmail-sort-messages reverse
122 (count-lines (rmail-msgbeg msg)
123 (rmail-msgend msg))))))
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)) ","))
135 (while (string-match "[ \t]*,[ \t]*" labels)
138 (substring labels 0 (match-beginning 0))
141 (setq labels (substring labels (match-end 0))))
142 (setq labelvec (apply 'vector (nreverse labelvec)))
143 (rmail-sort-messages reverse
147 (while (and (< n (length labelvec))
148 (not (rmail-message-labels-p
149 msg (aref labelvec n))))
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."
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
167 (message "Finding sort keys...")
170 (while (>= rmail-total-messages msgnum)
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)))
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)))
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)
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)
203 ;; Now reorder messages.
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?
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.
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)))))))
228 (defun rmail-fetch-field (msg field)
229 "Return the value of the header FIELD of MSG.
230 Arguments are MSG and FIELD."
233 (let ((next (rmail-msgend msg)))
234 (goto-char (rmail-msgbeg msg))
235 (narrow-to-region (if (search-forward "\n*** EOOH ***\n" next t)
239 (progn (search-forward "\n\n" nil t) (point)))
240 (mail-fetch-field field))))
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"))
249 ;;; rmailsort.el ends here