1 ;;; rmailsort.el --- Rmail: sort messages.
3 ;; Copyright (C) 1990, 1993, 1994 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.
30 ;; For rmail-select-summary
33 (autoload 'timezone-make-date-sortable "timezone")
35 ;; Sorting messages in Rmail buffer
38 (defun rmail-sort-by-date (reverse)
39 "Sort messages of current Rmail file by date.
40 If prefix argument REVERSE is non-nil, sort them in reverse order."
42 (rmail-sort-messages reverse
45 (rmail-make-date-sortable
46 (rmail-fetch-field msg "Date"))))))
49 (defun rmail-sort-by-subject (reverse)
50 "Sort messages of current Rmail file by subject.
51 If prefix argument REVERSE is non-nil, sort them in reverse order."
53 (rmail-sort-messages reverse
56 (let ((key (or (rmail-fetch-field msg "Subject") ""))
59 (if (string-match "^\\(re:[ \t]*\\)*" key)
60 (substring key (match-end 0))
64 (defun rmail-sort-by-author (reverse)
65 "Sort messages of current Rmail file by author.
66 If prefix argument REVERSE is non-nil, sort them in reverse order."
68 (rmail-sort-messages reverse
71 (downcase ;Canonical name
72 (mail-strip-quoted-names
73 (or (rmail-fetch-field msg "From")
74 (rmail-fetch-field msg "Sender") "")))))))
77 (defun rmail-sort-by-recipient (reverse)
78 "Sort messages of current Rmail file by recipient.
79 If prefix argument REVERSE is non-nil, sort them in reverse order."
81 (rmail-sort-messages reverse
84 (downcase ;Canonical name
85 (mail-strip-quoted-names
86 (or (rmail-fetch-field msg "To")
87 (rmail-fetch-field msg "Apparently-To") "")
91 (defun rmail-sort-by-correspondent (reverse)
92 "Sort messages of current Rmail file by other correspondent.
93 If prefix argument REVERSE is non-nil, sort them in reverse order."
95 (rmail-sort-messages reverse
98 (rmail-select-correspondent
100 '("From" "Sender" "To" "Apparently-To"))))))
102 (defun rmail-select-correspondent (msg fields)
104 (while (and fields (string= ans ""))
107 (mail-strip-quoted-names
108 (or (rmail-fetch-field msg (car fields)) ""))))
109 (setq fields (cdr fields)))
113 (defun rmail-sort-by-lines (reverse)
114 "Sort messages of current Rmail file by number of lines.
115 If prefix argument REVERSE is non-nil, sort them in reverse order."
117 (rmail-sort-messages reverse
120 (count-lines (rmail-msgbeg msg)
121 (rmail-msgend msg))))))
124 (defun rmail-sort-by-keywords (reverse labels)
125 "Sort messages of current Rmail file by labels.
126 If prefix argument REVERSE is non-nil, sort them in reverse order.
127 KEYWORDS is a comma-separated list of labels."
128 (interactive "P\nsSort by labels: ")
129 (or (string-match "[^ \t]" labels)
130 (error "No labels specified"))
131 (setq labels (concat (substring labels (match-beginning 0)) ","))
133 (while (string-match "[ \t]*,[ \t]*" labels)
136 (substring labels 0 (match-beginning 0))
139 (setq labels (substring labels (match-end 0))))
140 (setq labelvec (apply 'vector (nreverse labelvec)))
141 (rmail-sort-messages reverse
145 (while (and (< n (length labelvec))
146 (not (rmail-message-labels-p
147 msg (aref labelvec n))))
153 (defun rmail-sort-messages (reverse keyfun)
154 "Sort messages of current Rmail file.
155 If 1st argument REVERSE is non-nil, sort them in reverse order.
156 2nd argument KEYFUN is called with a message number, and should return a key."
158 ;; If we are in a summary buffer, operate on the Rmail buffer.
159 (if (eq major-mode 'rmail-summary-mode)
160 (set-buffer rmail-buffer))
161 (let ((buffer-read-only nil)
162 (point-offset (- (point) (point-min)))
163 (predicate nil) ;< or string-lessp
165 (message "Finding sort keys...")
168 (while (>= rmail-total-messages msgnum)
170 (cons (list (funcall keyfun msgnum) ;Make sorting key
171 (eq rmail-current-message msgnum) ;True if current
172 (aref rmail-message-vector msgnum)
173 (aref rmail-message-vector (1+ msgnum)))
175 (if (zerop (% msgnum 10))
176 (message "Finding sort keys...%d" msgnum))
177 (setq msgnum (1+ msgnum))))
178 (or reverse (setq sort-lists (nreverse sort-lists)))
179 ;; Decide predicate: < or string-lessp
180 (if (numberp (car (car sort-lists))) ;Is a key numeric?
181 (setq predicate (function <))
182 (setq predicate (function string-lessp)))
187 (funcall predicate (car a) (car b))))))
188 (if reverse (setq sort-lists (nreverse sort-lists)))
189 ;; Now we enter critical region. So, keyboard quit is disabled.
190 (message "Reordering messages...")
191 (let ((inhibit-quit t) ;Inhibit quit
192 (current-message nil)
195 ;; There's little hope that we can easily undo after that.
196 (buffer-disable-undo (current-buffer))
197 (goto-char (rmail-msgbeg 1))
198 ;; To force update of all markers.
199 (insert-before-markers ?Z)
201 ;; Now reorder messages.
203 (setq msginfo (car sort-lists))
204 ;; Swap two messages.
205 (insert-buffer-substring
206 (current-buffer) (nth 2 msginfo) (nth 3 msginfo))
207 (delete-region (nth 2 msginfo) (nth 3 msginfo))
208 ;; Is current message?
210 (setq current-message msgnum))
211 (setq sort-lists (cdr sort-lists))
212 (if (zerop (% msgnum 10))
213 (message "Reordering messages...%d" msgnum))
214 (setq msgnum (1+ msgnum)))
215 ;; Delete the garbage inserted before.
219 (rmail-set-message-counters)
220 (rmail-show-message current-message)
221 (goto-char (+ point-offset (point-min)))
222 (if (rmail-summary-exists)
223 (rmail-select-summary
224 (rmail-update-summary)))))))
226 (defun rmail-fetch-field (msg field)
227 "Return the value of the header FIELD of MSG.
228 Arguments are MSG and FIELD."
231 (let ((next (rmail-msgend msg)))
232 (goto-char (rmail-msgbeg msg))
233 (narrow-to-region (if (search-forward "\n*** EOOH ***\n" next t)
237 (progn (search-forward "\n\n" nil t) (point)))
238 (mail-fetch-field field))))
240 (defun rmail-make-date-sortable (date)
241 "Make DATE sortable using the function string-lessp."
242 ;; Assume the default time zone is GMT.
243 (timezone-make-date-sortable date "GMT" "GMT"))
247 ;;; rmailsort.el ends here