Commit | Line | Data |
---|---|---|
537ab246 BG |
1 | ;;; rmailsort.el --- Rmail: sort messages |
2 | ||
ba318903 | 3 | ;; Copyright (C) 1990, 1993-1994, 2001-2014 Free Software Foundation, |
ab422c4d | 4 | ;; Inc. |
537ab246 BG |
5 | |
6 | ;; Author: Masanobu UMEDA <umerin@mse.kyutech.ac.jp> | |
34dc21db | 7 | ;; Maintainer: emacs-devel@gnu.org |
537ab246 | 8 | ;; Keywords: mail |
bd78fa1d | 9 | ;; Package: rmail |
537ab246 BG |
10 | |
11 | ;; This file is part of GNU Emacs. | |
12 | ||
13 | ;; GNU Emacs is free software: you can redistribute it and/or modify | |
14 | ;; it under the terms of the GNU General Public License as published by | |
15 | ;; the Free Software Foundation, either version 3 of the License, or | |
16 | ;; (at your option) any later version. | |
17 | ||
18 | ;; GNU Emacs is distributed in the hope that it will be useful, | |
19 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
20 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
21 | ;; GNU General Public License for more details. | |
22 | ||
23 | ;; You should have received a copy of the GNU General Public License | |
24 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. | |
25 | ||
26 | ;;; Commentary: | |
27 | ||
65ad1920 GM |
28 | ;; Functions for sorting messages in an Rmail buffer. |
29 | ||
537ab246 BG |
30 | ;;; Code: |
31 | ||
efb656fd | 32 | (require 'rmail) |
537ab246 | 33 | |
537ab246 BG |
34 | ;;;###autoload |
35 | (defun rmail-sort-by-date (reverse) | |
65ad1920 GM |
36 | "Sort messages of current Rmail buffer by \"Date\" header. |
37 | If prefix argument REVERSE is non-nil, sorts in reverse order." | |
537ab246 BG |
38 | (interactive "P") |
39 | (rmail-sort-messages reverse | |
65ad1920 GM |
40 | (lambda (msg) |
41 | (rmail-make-date-sortable | |
42 | (rmail-get-header "Date" msg))))) | |
537ab246 BG |
43 | |
44 | ;;;###autoload | |
45 | (defun rmail-sort-by-subject (reverse) | |
65ad1920 GM |
46 | "Sort messages of current Rmail buffer by \"Subject\" header. |
47 | Ignores any \"Re: \" prefix. If prefix argument REVERSE is | |
48 | non-nil, sorts in reverse order." | |
49 | ;; Note this is a case-sensitive sort. | |
537ab246 BG |
50 | (interactive "P") |
51 | (rmail-sort-messages reverse | |
65ad1920 GM |
52 | (lambda (msg) |
53 | (let ((key (or (rmail-get-header "Subject" msg) "")) | |
54 | (case-fold-search t)) | |
55 | ;; Remove `Re:' | |
56 | (if (string-match "^\\(re:[ \t]*\\)*" key) | |
57 | (substring key (match-end 0)) | |
58 | key))))) | |
537ab246 BG |
59 | |
60 | ;;;###autoload | |
61 | (defun rmail-sort-by-author (reverse) | |
65ad1920 GM |
62 | "Sort messages of current Rmail buffer by author. |
63 | This uses either the \"From\" or \"Sender\" header, downcased. | |
64 | If prefix argument REVERSE is non-nil, sorts in reverse order." | |
537ab246 BG |
65 | (interactive "P") |
66 | (rmail-sort-messages reverse | |
65ad1920 GM |
67 | (lambda (msg) |
68 | (downcase ; canonical name | |
69 | (mail-strip-quoted-names | |
70 | (or (rmail-get-header "From" msg) | |
71 | (rmail-get-header "Sender" msg) "")))))) | |
537ab246 BG |
72 | |
73 | ;;;###autoload | |
74 | (defun rmail-sort-by-recipient (reverse) | |
65ad1920 GM |
75 | "Sort messages of current Rmail buffer by recipient. |
76 | This uses either the \"To\" or \"Apparently-To\" header, downcased. | |
77 | If prefix argument REVERSE is non-nil, sorts in reverse order." | |
537ab246 BG |
78 | (interactive "P") |
79 | (rmail-sort-messages reverse | |
65ad1920 GM |
80 | (lambda (msg) |
81 | (downcase ; canonical name | |
82 | (mail-strip-quoted-names | |
83 | (or (rmail-get-header "To" msg) | |
84 | (rmail-get-header "Apparently-To" msg) "")))))) | |
537ab246 BG |
85 | |
86 | ;;;###autoload | |
87 | (defun rmail-sort-by-correspondent (reverse) | |
65ad1920 GM |
88 | "Sort messages of current Rmail buffer by other correspondent. |
89 | This uses either the \"From\", \"Sender\", \"To\", or | |
90 | \"Apparently-To\" header, downcased. Uses the first header not | |
38a71655 | 91 | excluded by `mail-dont-reply-to-names'. If prefix argument |
65ad1920 | 92 | REVERSE is non-nil, sorts in reverse order." |
537ab246 BG |
93 | (interactive "P") |
94 | (rmail-sort-messages reverse | |
65ad1920 GM |
95 | (lambda (msg) |
96 | (downcase | |
537ab246 BG |
97 | (rmail-select-correspondent |
98 | msg | |
99 | '("From" "Sender" "To" "Apparently-To")))))) | |
100 | ||
101 | (defun rmail-select-correspondent (msg fields) | |
38a71655 | 102 | "Find the first header not excluded by `mail-dont-reply-to-names'. |
65ad1920 | 103 | MSG is a message number. FIELDS is a list of header names." |
537ab246 BG |
104 | (let ((ans "")) |
105 | (while (and fields (string= ans "")) | |
106 | (setq ans | |
38a71655 | 107 | (mail-dont-reply-to |
537ab246 BG |
108 | (mail-strip-quoted-names |
109 | (or (rmail-get-header (car fields) msg) "")))) | |
110 | (setq fields (cdr fields))) | |
111 | ans)) | |
112 | ||
113 | ;;;###autoload | |
114 | (defun rmail-sort-by-lines (reverse) | |
65ad1920 GM |
115 | "Sort messages of current Rmail buffer by the number of lines. |
116 | If prefix argument REVERSE is non-nil, sorts in reverse order." | |
537ab246 BG |
117 | (interactive "P") |
118 | (rmail-sort-messages reverse | |
65ad1920 GM |
119 | (lambda (msg) |
120 | (count-lines (rmail-msgbeg msg) | |
121 | (rmail-msgend msg))))) | |
537ab246 BG |
122 | |
123 | ;;;###autoload | |
124 | (defun rmail-sort-by-labels (reverse labels) | |
65ad1920 GM |
125 | "Sort messages of current Rmail buffer by labels. |
126 | LABELS is a comma-separated list of labels. The order of these | |
127 | labels specifies the order of messages: messages with the first | |
128 | label come first, messages with the second label come second, and | |
129 | so on. Messages that have none of these labels come last. | |
130 | If prefix argument REVERSE is non-nil, sorts in reverse order." | |
537ab246 | 131 | (interactive "P\nsSort by labels: ") |
65ad1920 | 132 | (or (string-match "[^ \t]" labels) ; need some non-whitespace |
537ab246 | 133 | (error "No labels specified")) |
65ad1920 | 134 | ;; Remove leading whitespace, add trailing comma. |
537ab246 | 135 | (setq labels (concat (substring labels (match-beginning 0)) ",")) |
65ad1920 GM |
136 | (let (labelvec nmax) |
137 | ;; Convert "l1,..." into "\\(, \\|\\`\\)l1\\(,\\|\\'\\)" "..." ... | |
537ab246 BG |
138 | (while (string-match "[ \t]*,[ \t]*" labels) |
139 | (setq labelvec (cons | |
65ad1920 | 140 | (concat "\\(, \\|\\`\\)" |
537ab246 | 141 | (substring labels 0 (match-beginning 0)) |
65ad1920 | 142 | "\\(,\\|\\'\\)") |
537ab246 BG |
143 | labelvec)) |
144 | (setq labels (substring labels (match-end 0)))) | |
65ad1920 GM |
145 | (setq labelvec (apply 'vector (nreverse labelvec)) |
146 | nmax (length labelvec)) | |
537ab246 | 147 | (rmail-sort-messages reverse |
65ad1920 GM |
148 | ;; If no labels match, returns nmax; if they |
149 | ;; match the first specified in LABELS, | |
150 | ;; returns 0; if they match the second, returns 1; etc. | |
151 | ;; Hence sorts as described in the doc-string. | |
152 | (lambda (msg) | |
153 | (let ((n 0) | |
154 | (str (concat (rmail-get-attr-names msg) | |
155 | ", " | |
156 | (rmail-get-keywords msg)))) | |
157 | ;; No labels: can't match anything. | |
158 | (if (string-equal ", " str) | |
159 | nmax | |
160 | (while (and (< n nmax) | |
161 | (not (string-match (aref labelvec n) | |
162 | str))) | |
163 | (setq n (1+ n))) | |
164 | n)))))) | |
537ab246 BG |
165 | \f |
166 | ;; Basic functions | |
efb656fd | 167 | (declare-function rmail-update-summary "rmailsum" (&rest ignore)) |
537ab246 BG |
168 | |
169 | (defun rmail-sort-messages (reverse keyfun) | |
65ad1920 GM |
170 | "Sort messages of current Rmail buffer. |
171 | If REVERSE is non-nil, sorts in reverse order. Calls the | |
172 | function KEYFUN with a message number (it should return a sort key). | |
173 | Numeric keys are sorted numerically, all others as strings." | |
537ab246 BG |
174 | (with-current-buffer rmail-buffer |
175 | (let ((return-to-point | |
176 | (if (rmail-buffers-swapped-p) | |
177 | (point))) | |
537ab246 BG |
178 | (sort-lists nil)) |
179 | (rmail-swap-buffers-maybe) | |
180 | (message "Finding sort keys...") | |
181 | (widen) | |
182 | (let ((msgnum 1)) | |
183 | (while (>= rmail-total-messages msgnum) | |
184 | (setq sort-lists | |
185 | (cons (list (funcall keyfun msgnum) ;Make sorting key | |
186 | (eq rmail-current-message msgnum) ;True if current | |
187 | (aref rmail-message-vector msgnum) | |
188 | (aref rmail-message-vector (1+ msgnum))) | |
189 | sort-lists)) | |
190 | (if (zerop (% msgnum 10)) | |
191 | (message "Finding sort keys...%d" msgnum)) | |
192 | (setq msgnum (1+ msgnum)))) | |
193 | (or reverse (setq sort-lists (nreverse sort-lists))) | |
537ab246 BG |
194 | (setq sort-lists |
195 | (sort sort-lists | |
73d7bcb9 SM |
196 | ;; Decide predicate: < or string-lessp |
197 | (if (numberp (car (car sort-lists))) ;Is a key numeric? | |
198 | 'car-less-than-car | |
65ad1920 GM |
199 | (lambda (a b) |
200 | (string-lessp (car a) (car b)))))) | |
537ab246 BG |
201 | (if reverse (setq sort-lists (nreverse sort-lists))) |
202 | ;; Now we enter critical region. So, keyboard quit is disabled. | |
203 | (message "Reordering messages...") | |
204 | (let ((inhibit-quit t) ;Inhibit quit | |
205 | (inhibit-read-only t) | |
206 | (current-message nil) | |
207 | (msgnum 1) | |
65ad1920 GM |
208 | (msginfo nil) |
209 | (undo (not (eq buffer-undo-list t)))) | |
537ab246 BG |
210 | ;; There's little hope that we can easily undo after that. |
211 | (buffer-disable-undo (current-buffer)) | |
212 | (goto-char (rmail-msgbeg 1)) | |
213 | ;; To force update of all markers, | |
214 | ;; keep the new copies separated from the remaining old messages. | |
215 | (insert-before-markers ?Z) | |
216 | (backward-char 1) | |
217 | ;; Now reorder messages. | |
218 | (dolist (msginfo sort-lists) | |
219 | ;; Swap two messages. | |
220 | (insert-buffer-substring | |
221 | (current-buffer) (nth 2 msginfo) (nth 3 msginfo)) | |
222 | ;; The last message may not have \n\n after it. | |
137ea8af | 223 | (rmail-ensure-blank-line) |
537ab246 BG |
224 | (delete-region (nth 2 msginfo) (nth 3 msginfo)) |
225 | ;; Is current message? | |
226 | (if (nth 1 msginfo) | |
227 | (setq current-message msgnum)) | |
228 | (if (zerop (% msgnum 10)) | |
229 | (message "Reordering messages...%d" msgnum)) | |
230 | (setq msgnum (1+ msgnum))) | |
231 | ;; Delete the dummy separator Z inserted before. | |
232 | (delete-char 1) | |
233 | (setq quit-flag nil) | |
65ad1920 GM |
234 | ;; If undo was on before, re-enable it. But note that it is |
235 | ;; disabled in mbox Rmail, so this is kind of pointless. | |
236 | (if undo (buffer-enable-undo)) | |
537ab246 | 237 | (rmail-set-message-counters) |
a1a29341 | 238 | (rmail-show-message-1 current-message) |
537ab246 BG |
239 | (if return-to-point |
240 | (goto-char return-to-point)) | |
241 | (if (rmail-summary-exists) | |
242 | (rmail-select-summary (rmail-update-summary))))))) | |
243 | ||
efb656fd GM |
244 | (autoload 'timezone-make-date-sortable "timezone") |
245 | ||
537ab246 | 246 | (defun rmail-make-date-sortable (date) |
65ad1920 | 247 | "Make DATE sortable using the function `string-lessp'." |
537ab246 BG |
248 | ;; Assume the default time zone is GMT. |
249 | (timezone-make-date-sortable date "GMT" "GMT")) | |
250 | ||
251 | (provide 'rmailsort) | |
252 | ||
35426db4 GM |
253 | ;; Local Variables: |
254 | ;; generated-autoload-file: "rmail.el" | |
255 | ;; End: | |
256 | ||
537ab246 | 257 | ;;; rmailsort.el ends here |