1 ;;; rmailsort.el --- Rmail: sort messages.
3 ;; Copyright (C) 1990, 1993 Free Software Foundation, Inc.
5 ;; Author: Masanobu UMEDA <umerin@mse.kyutech.ac.jp>
6 ;; Version: $Header: /gd/gnu/emacs/19.0/lisp/RCS/rmailsort.el,v 1.20 1994/03/30 02:24:05 kwzh Exp kwzh $
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
23 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
29 (autoload 'timezone-make-date-sortable
"timezone")
31 ;; Sorting messages in Rmail buffer
33 (defun rmail-sort-by-date (reverse)
34 "Sort messages of current Rmail file by date.
35 If prefix argument REVERSE is non-nil, sort them in reverse order."
37 (rmail-sort-messages reverse
40 (rmail-make-date-sortable
41 (rmail-fetch-field msg
"Date"))))))
43 (defun rmail-sort-by-subject (reverse)
44 "Sort messages of current Rmail file by subject.
45 If prefix argument REVERSE is non-nil, sort them in reverse order."
47 (rmail-sort-messages reverse
50 (let ((key (or (rmail-fetch-field msg
"Subject") ""))
53 (if (string-match "^\\(re:[ \t]*\\)*" key
)
54 (substring key
(match-end 0))
57 (defun rmail-sort-by-author (reverse)
58 "Sort messages of current Rmail file by author.
59 If prefix argument REVERSE is non-nil, sort them in reverse order."
61 (rmail-sort-messages reverse
64 (downcase ;Canonical name
65 (mail-strip-quoted-names
66 (or (rmail-fetch-field msg
"From")
67 (rmail-fetch-field msg
"Sender") "")))))))
69 (defun rmail-sort-by-recipient (reverse)
70 "Sort messages of current Rmail file by recipient.
71 If prefix argument REVERSE is non-nil, sort them in reverse order."
73 (rmail-sort-messages reverse
76 (downcase ;Canonical name
77 (mail-strip-quoted-names
78 (or (rmail-fetch-field msg
"To")
79 (rmail-fetch-field msg
"Apparently-To") "")
82 (defun rmail-sort-by-correspondent (reverse)
83 "Sort messages of current Rmail file by other correspondent.
84 If prefix argument REVERSE is non-nil, sort them in reverse order."
86 (rmail-sort-messages reverse
89 (rmail-select-correspondent
91 '("From" "Sender" "To" "Apparently-To"))))))
93 (defun rmail-select-correspondent (msg fields
)
95 (while (and fields
(string= ans
""))
98 (mail-strip-quoted-names
99 (or (rmail-fetch-field msg
(car fields
)) ""))))
100 (setq fields
(cdr fields
)))
103 (defun rmail-sort-by-lines (reverse)
104 "Sort messages of current Rmail file by number of lines.
105 If prefix argument REVERSE is non-nil, sort them in reverse order."
107 (rmail-sort-messages reverse
110 (count-lines (rmail-msgbeg msg
)
111 (rmail-msgend msg
))))))
113 (defun rmail-sort-by-keywords (reverse labels
)
114 "Sort messages of current Rmail file by labels.
115 If prefix argument REVERSE is non-nil, sort them in reverse order.
116 KEYWORDS is a comma-separated list of labels."
117 (interactive "P\nsSort by labels: ")
118 (or (string-match "[^ \t]" labels
)
119 (error "No labels specified"))
120 (setq labels
(concat (substring labels
(match-beginning 0)) ","))
122 (while (string-match "[ \t]*,[ \t]*" labels
)
125 (substring labels
0 (match-beginning 0))
128 (setq labels
(substring labels
(match-end 0))))
129 (setq labelvec
(apply 'vector
(nreverse labelvec
)))
130 (rmail-sort-messages reverse
134 (while (and (< n
(length labelvec
))
135 (not (rmail-message-labels-p
136 msg
(aref labelvec n
))))
142 (defun rmail-sort-messages (reverse keyfun
)
143 "Sort messages of current Rmail file.
144 If 1st argument REVERSE is non-nil, sort them in reverse order.
145 2nd argument KEYFUN is called with a message number, and should return a key."
147 ;; If we are in a summary buffer, operate on the Rmail buffer.
148 (if (eq major-mode
'rmail-summary-mode
)
149 (set-buffer rmail-buffer
))
150 (let ((buffer-read-only nil
)
151 (predicate nil
) ;< or string-lessp
153 (message "Finding sort keys...")
156 (while (>= rmail-total-messages msgnum
)
158 (cons (list (funcall keyfun msgnum
) ;Make sorting key
159 (eq rmail-current-message msgnum
) ;True if current
160 (aref rmail-message-vector msgnum
)
161 (aref rmail-message-vector
(1+ msgnum
)))
163 (if (zerop (% msgnum
10))
164 (message "Finding sort keys...%d" msgnum
))
165 (setq msgnum
(1+ msgnum
))))
166 (or reverse
(setq sort-lists
(nreverse sort-lists
)))
167 ;; Decide predicate: < or string-lessp
168 (if (numberp (car (car sort-lists
))) ;Is a key numeric?
169 (setq predicate
(function <))
170 (setq predicate
(function string-lessp
)))
175 (funcall predicate
(car a
) (car b
))))))
176 (if reverse
(setq sort-lists
(nreverse sort-lists
)))
177 ;; Now we enter critical region. So, keyboard quit is disabled.
178 (message "Reordering messages...")
179 (let ((inhibit-quit t
) ;Inhibit quit
180 (current-message nil
)
183 ;; There's little hope that we can easily undo after that.
184 (buffer-disable-undo (current-buffer))
185 (goto-char (rmail-msgbeg 1))
186 ;; To force update of all markers.
187 (insert-before-markers ?Z
)
189 ;; Now reorder messages.
191 (setq msginfo
(car sort-lists
))
192 ;; Swap two messages.
193 (insert-buffer-substring
194 (current-buffer) (nth 2 msginfo
) (nth 3 msginfo
))
195 (delete-region (nth 2 msginfo
) (nth 3 msginfo
))
196 ;; Is current message?
198 (setq current-message msgnum
))
199 (setq sort-lists
(cdr sort-lists
))
200 (if (zerop (% msgnum
10))
201 (message "Reordering messages...%d" msgnum
))
202 (setq msgnum
(1+ msgnum
)))
203 ;; Delete the garbage inserted before.
207 (rmail-set-message-counters)
208 (rmail-show-message current-message
)
209 (if (rmail-summary-exists)
210 (rmail-select-summary
211 (rmail-update-summary)))))))
213 (defun rmail-fetch-field (msg field
)
214 "Return the value of the header FIELD of MSG.
215 Arguments are MSG and FIELD."
218 (let ((next (rmail-msgend msg
)))
219 (goto-char (rmail-msgbeg msg
))
220 (narrow-to-region (if (search-forward "\n*** EOOH ***\n" next t
)
224 (progn (search-forward "\n\n" nil t
) (point)))
225 (mail-fetch-field field
))))
227 (defun rmail-make-date-sortable (date)
228 "Make DATE sortable using the function string-lessp."
229 ;; Assume the default time zone is GMT.
230 (timezone-make-date-sortable date
"GMT" "GMT"))
234 ;;; rmailsort.el ends here