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