Mercurial > emacs

comparison lisp/mail/rmailsort.el @ 3133:2c1553d7aad1

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
New version from Umeda. Needs detailed entry.
author Richard M. Stallman <rms@gnu.org>
date Wed, 26 May 1993 20:28:11 +0000
parents 3b0a06fc7c4b
children fab096be7274
comparison
equal deleted inserted replaced
3132:e32cef1a19b7 3133:2c1553d7aad1
1 ;;; rmailsort.el --- Rmail: sort messages. 1 ;;; rmailsort.el --- Rmail: sort messages.
2 2
3 ;; Copyright (C) 1990 Free Software Foundation, Inc. 3 ;; Copyright (C) 1990, 1993 Free Software Foundation, Inc.
4 4
5 ;; Author: Masanobu UMEDA <umerin@mse.kyutech.ac.jp>
6 ;; Version: $Header: rmailsort.el,v 1.6 93/05/26 22:24:42 umerin Exp $
5 ;; Keywords: mail 7 ;; Keywords: mail
6 8
7 ;; This file is part of GNU Emacs. 9 ;; This file is part of GNU Emacs.
8 10
9 ;; GNU Emacs is free software; you can redistribute it and/or modify 11 ;; GNU Emacs is free software; you can redistribute it and/or modify
18 20
19 ;; You should have received a copy of the GNU General Public License 21 ;; You should have received a copy of the GNU General Public License
20 ;; along with GNU Emacs; see the file COPYING. If not, write to 22 ;; along with GNU Emacs; see the file COPYING. If not, write to
21 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. 23 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
22 24
25 ;;; Commentary:
26
27 ;; LCD Archive Entry:
28 ;; rmailsort|Masanobu UMEDA|umerin@mse.kyutech.ac.jp|
29 ;; Rmail: sort messages.|
30 ;; $Date: 93/05/26 22:24:42 $|$Revision: 1.6 $|~/misc/rmailsort.el.Z|
31
23 ;;; Code: 32 ;;; Code:
24 33
25 (require 'rmail) 34 (require 'rmail)
26 (require 'sort) 35 (require 'sort)
27 36
37 (autoload 'timezone-make-date-sortable "timezone")
38
28 ;; GNUS compatible key bindings. 39 ;; GNUS compatible key bindings.
40
29 (define-key rmail-mode-map "\C-c\C-s\C-d" 'rmail-sort-by-date) 41 (define-key rmail-mode-map "\C-c\C-s\C-d" 'rmail-sort-by-date)
30 (define-key rmail-mode-map "\C-c\C-s\C-s" 'rmail-sort-by-subject) 42 (define-key rmail-mode-map "\C-c\C-s\C-s" 'rmail-sort-by-subject)
31 (define-key rmail-mode-map "\C-c\C-s\C-a" 'rmail-sort-by-author) 43 (define-key rmail-mode-map "\C-c\C-s\C-a" 'rmail-sort-by-author)
32 (define-key rmail-mode-map "\C-c\C-s\C-r" 'rmail-sort-by-recipient) 44 (define-key rmail-mode-map "\C-c\C-s\C-r" 'rmail-sort-by-recipient)
33 (define-key rmail-mode-map "\C-c\C-s\C-c" 'rmail-sort-by-correspondent) 45 (define-key rmail-mode-map "\C-c\C-s\C-c" 'rmail-sort-by-correspondent)
34 (define-key rmail-mode-map "\C-c\C-s\C-l" 'rmail-sort-by-size-lines) 46 (define-key rmail-mode-map "\C-c\C-s\C-l" 'rmail-sort-by-lines)
47
48 ;; Key binding may not be installed unless Rmail Summary mode is loaded.
49 (if (boundp 'rmail-summary-mode-map)
50 (progn
51 (define-key rmail-summary-mode-map
52 "\C-c\C-s\C-d" 'rmail-summary-sort-by-date)
53 (define-key rmail-summary-mode-map
54 "\C-c\C-s\C-s" 'rmail-summary-sort-by-subject)
55 (define-key rmail-summary-mode-map
56 "\C-c\C-s\C-a" 'rmail-summary-sort-by-author)
57 (define-key rmail-summary-mode-map
58 "\C-c\C-s\C-r" 'rmail-summary-sort-by-recipient)
59 (define-key rmail-summary-mode-map
60 "\C-c\C-s\C-c" 'rmail-summary-sort-by-correspondent)
61 (define-key rmail-summary-mode-map
62 "\C-c\C-s\C-l" 'rmail-summary-sort-by-lines)
63 ))
64
65
66 ;; Sorting messages in Rmail buffer
35 67
36 (defun rmail-sort-by-date (reverse) 68 (defun rmail-sort-by-date (reverse)
37 "Sort messages of current Rmail file by date. 69 "Sort messages of current Rmail file by date.
38 If prefix argument REVERSE is non-nil, sort them in reverse order." 70 If prefix argument REVERSE is non-nil, sort them in reverse order."
39 (interactive "P") 71 (interactive "P")
40 (rmail-sort-messages reverse 72 (rmail-sort-messages reverse
41 (function 73 (function
42 (lambda (msg) 74 (lambda (msg)
43 (rmail-sortable-date-string 75 (rmail-make-date-sortable
44 (rmail-fetch-field msg "Date")))))) 76 (rmail-fetch-field msg "Date"))))))
45 77
46 (defun rmail-sort-by-subject (reverse) 78 (defun rmail-sort-by-subject (reverse)
47 "Sort messages of current Rmail file by subject. 79 "Sort messages of current Rmail file by subject.
48 If prefix argument REVERSE is non-nil, sort them in reverse order." 80 If prefix argument REVERSE is non-nil, sort them in reverse order."
61 If prefix argument REVERSE is non-nil, sort them in reverse order." 93 If prefix argument REVERSE is non-nil, sort them in reverse order."
62 (interactive "P") 94 (interactive "P")
63 (rmail-sort-messages reverse 95 (rmail-sort-messages reverse
64 (function 96 (function
65 (lambda (msg) 97 (lambda (msg)
66 (mail-strip-quoted-names 98 (downcase ;Canonical name
67 (or (rmail-fetch-field msg "From") 99 (mail-strip-quoted-names
68 (rmail-fetch-field msg "Sender") "")))))) 100 (or (rmail-fetch-field msg "From")
101 (rmail-fetch-field msg "Sender") "")))))))
69 102
70 (defun rmail-sort-by-recipient (reverse) 103 (defun rmail-sort-by-recipient (reverse)
71 "Sort messages of current Rmail file by recipient. 104 "Sort messages of current Rmail file by recipient.
72 If prefix argument REVERSE is non-nil, sort them in reverse order." 105 If prefix argument REVERSE is non-nil, sort them in reverse order."
73 (interactive "P") 106 (interactive "P")
74 (rmail-sort-messages reverse 107 (rmail-sort-messages reverse
75 (function 108 (function
76 (lambda (msg) 109 (lambda (msg)
77 (mail-strip-quoted-names 110 (downcase ;Canonical name
78 (or (rmail-fetch-field msg "To") 111 (mail-strip-quoted-names
79 (rmail-fetch-field msg "Apparently-To") "") 112 (or (rmail-fetch-field msg "To")
80 ))))) 113 (rmail-fetch-field msg "Apparently-To") "")
114 ))))))
81 115
82 (defun rmail-sort-by-correspondent (reverse) 116 (defun rmail-sort-by-correspondent (reverse)
83 "Sort messages of current Rmail file by other correspondent. 117 "Sort messages of current Rmail file by other correspondent.
84 If prefix argument REVERSE is non-nil, sort them in reverse order." 118 If prefix argument REVERSE is non-nil, sort them in reverse order."
85 (interactive "P") 119 (interactive "P")
90 msg 124 msg
91 '("From" "Sender" "To" "Apparently-To")))))) 125 '("From" "Sender" "To" "Apparently-To"))))))
92 126
93 (defun rmail-select-correspondent (msg fields) 127 (defun rmail-select-correspondent (msg fields)
94 (let ((ans "")) 128 (let ((ans ""))
95 (while (and fields (string= ans "")) 129 (while (and fields (string= ans ""))
96 (setq ans 130 (setq ans
97 (rmail-dont-reply-to 131 (rmail-dont-reply-to
98 (mail-strip-quoted-names 132 (mail-strip-quoted-names
99 (or (rmail-fetch-field msg (car fields)) "")))) 133 (or (rmail-fetch-field msg (car fields)) ""))))
100 (setq fields (cdr fields))) 134 (setq fields (cdr fields)))
101 ans)) 135 ans))
102 136
103 (defun rmail-sort-by-size-lines (reverse) 137 (defun rmail-sort-by-lines (reverse)
104 "Sort messages of current Rmail file by message size. 138 "Sort messages of current Rmail file by lines of the message.
105 If prefix argument REVERSE is non-nil, sort them in reverse order." 139 If prefix argument REVERSE is non-nil, sort them in reverse order."
106 (interactive "P") 140 (interactive "P")
107 (rmail-sort-messages reverse 141 (rmail-sort-messages reverse
108 (function 142 (function
109 (lambda (msg) 143 (lambda (msg)
110 (format "%9d" 144 (count-lines (rmail-msgbeg msgnum)
111 (count-lines (rmail-msgbeg msgnum) 145 (rmail-msgend msgnum))))))
112 (rmail-msgend msgnum)))))))
113 146
114 147 ;; Sorting messages in Rmail Summary buffer.
115 (defun rmail-sort-messages (reverse keyfunc) 148
149 (defun rmail-summary-sort-by-date (reverse)
150 "Sort messages of current Rmail summary by date.
151 If prefix argument REVERSE is non-nil, sort them in reverse order."
152 (interactive "P")
153 (rmail-sort-from-summary (function rmail-sort-by-date) reverse))
154
155 (defun rmail-summary-sort-by-subject (reverse)
156 "Sort messages of current Rmail summary by subject.
157 If prefix argument REVERSE is non-nil, sort them in reverse order."
158 (interactive "P")
159 (rmail-sort-from-summary (function rmail-sort-by-subject) reverse))
160
161 (defun rmail-summary-sort-by-author (reverse)
162 "Sort messages of current Rmail summary by author.
163 If prefix argument REVERSE is non-nil, sort them in reverse order."
164 (interactive "P")
165 (rmail-sort-from-summary (function rmail-sort-by-author) reverse))
166
167 (defun rmail-summary-sort-by-recipient (reverse)
168 "Sort messages of current Rmail summary by recipient.
169 If prefix argument REVERSE is non-nil, sort them in reverse order."
170 (interactive "P")
171 (rmail-sort-from-summary (function rmail-sort-by-recipient) reverse))
172
173 (defun rmail-summary-sort-by-correspondent (reverse)
174 "Sort messages of current Rmail summary by other correspondent.
175 If prefix argument REVERSE is non-nil, sort them in reverse order."
176 (interactive "P")
177 (rmail-sort-from-summary (function rmail-sort-by-correspondent) reverse))
178
179 (defun rmail-summary-sort-by-lines (reverse)
180 "Sort messages of current Rmail summary by lines of the message.
181 If prefix argument REVERSE is non-nil, sort them in reverse order."
182 (interactive "P")
183 (rmail-sort-from-summary (function rmail-sort-by-lines) reverse))
184
185
186 ;; Basic functions
187
188 (defun rmail-sort-messages (reverse keyfun)
116 "Sort messages of current Rmail file. 189 "Sort messages of current Rmail file.
117 1st argument REVERSE is non-nil, sort them in reverse order. 190 If 1st argument REVERSE is non-nil, sort them in reverse order.
118 2nd argument KEYFUNC is called with message number, and should return a key." 191 2nd argument KEYFUN is called with a message number, and should return a key."
119 (or (eq major-mode 'rmail-mode)
120 (error "Current buffer not in Rmail mode"))
121 (let ((buffer-read-only nil) 192 (let ((buffer-read-only nil)
193 (predicate nil) ;< or string-lessp
122 (sort-lists nil)) 194 (sort-lists nil))
123 (message "Finding sort keys...") 195 (message "Finding sort keys...")
124 (widen) 196 (widen)
125 (let ((msgnum 1)) 197 (let ((msgnum 1))
126 (while (>= rmail-total-messages msgnum) 198 (while (>= rmail-total-messages msgnum)
127 (setq sort-lists 199 (setq sort-lists
128 (cons (cons (funcall keyfunc msgnum) ;A sort key. 200 (cons (list (funcall keyfun msgnum) ;Make sorting key
129 (buffer-substring 201 (eq rmail-current-message msgnum) ;True if current
130 (rmail-msgbeg msgnum) (rmail-msgend msgnum))) 202 (aref rmail-message-vector msgnum)
203 (aref rmail-message-vector (1+ msgnum)))
131 sort-lists)) 204 sort-lists))
132 (if (zerop (% msgnum 10)) 205 (if (zerop (% msgnum 10))
133 (message "Finding sort keys...%d" msgnum)) 206 (message "Finding sort keys...%d" msgnum))
134 (setq msgnum (1+ msgnum)))) 207 (setq msgnum (1+ msgnum))))
135 (or reverse (setq sort-lists (nreverse sort-lists))) 208 (or reverse (setq sort-lists (nreverse sort-lists)))
209 ;; Decide predicate: < or string-lessp
210 (if (numberp (car (car sort-lists))) ;Is a key numeric?
211 (setq predicate (function <))
212 (setq predicate (function string-lessp)))
136 (setq sort-lists 213 (setq sort-lists
137 (sort sort-lists 214 (sort sort-lists
138 (function 215 (function
139 (lambda (a b) 216 (lambda (a b)
140 (string-lessp (car a) (car b)))))) 217 (funcall predicate (car a) (car b))))))
141 (if reverse (setq sort-lists (nreverse sort-lists))) 218 (if reverse (setq sort-lists (nreverse sort-lists)))
142 (message "Reordering buffer...") 219 ;; Now we enter critical region. So, keyboard quit is disabled.
143 (delete-region (rmail-msgbeg 1) (rmail-msgend rmail-total-messages)) 220 (message "Reordering messages...")
144 (let ((msgnum 1)) 221 (let ((inhibit-quit t) ;Inhibit quit
222 (current-message nil)
223 (msgnum 1)
224 (msginfo nil))
225 ;; There's little hope that we can easily undo after that.
226 (buffer-flush-undo (current-buffer))
227 (goto-char (rmail-msgbeg 1))
228 ;; To force update of all markers.
229 (insert-before-markers ?Z)
230 (backward-char 1)
231 ;; Now reorder messages.
145 (while sort-lists 232 (while sort-lists
146 (insert (cdr (car sort-lists))) 233 (setq msginfo (car sort-lists))
234 ;; Swap two messages.
235 (insert-buffer-substring
236 (current-buffer) (nth 2 msginfo) (nth 3 msginfo))
237 (delete-region (nth 2 msginfo) (nth 3 msginfo))
238 ;; Is current message?
239 (if (nth 1 msginfo)
240 (setq current-message msgnum))
241 (setq sort-lists (cdr sort-lists))
147 (if (zerop (% msgnum 10)) 242 (if (zerop (% msgnum 10))
148 (message "Reordering buffer...%d" msgnum)) 243 (message "Reordering messages...%d" msgnum))
149 (setq sort-lists (cdr sort-lists)) 244 (setq msgnum (1+ msgnum)))
150 (setq msgnum (1+ msgnum)))) 245 ;; Delete the garbage inserted before.
151 (rmail-set-message-counters) 246 (delete-char 1)
152 (rmail-show-message 1))) 247 (setq quit-flag nil)
248 (buffer-enable-undo)
249 (rmail-set-message-counters)
250 (rmail-show-message current-message))
251 ))
252
253 (defun rmail-sort-from-summary (sortfun reverse)
254 "Sort Rmail messages from Summary buffer and update it after sorting."
255 (pop-to-buffer rmail-buffer)
256 (funcall sortfun reverse)
257 (rmail-summary))
153 258
154 (defun rmail-fetch-field (msg field) 259 (defun rmail-fetch-field (msg field)
155 "Return the value of the header field FIELD of MSG. 260 "Return the value of the header FIELD of MSG.
156 Arguments are MSG and FIELD." 261 Arguments are MSG and FIELD."
157 (let ((next (rmail-msgend msg))) 262 (save-restriction
158 (save-restriction 263 (widen)
264 (let ((next (rmail-msgend msg)))
159 (goto-char (rmail-msgbeg msg)) 265 (goto-char (rmail-msgbeg msg))
160 (narrow-to-region (if (search-forward "\n*** EOOH ***\n" next t) 266 (narrow-to-region (if (search-forward "\n*** EOOH ***\n" next t)
161 (point) 267 (point)
162 (forward-line 1) 268 (forward-line 1)
163 (point)) 269 (point))
164 (progn (search-forward "\n\n" nil t) (point))) 270 (progn (search-forward "\n\n" nil t) (point)))
165 (mail-fetch-field field)))) 271 (mail-fetch-field field))))
166 272
167 ;; Copy of the function gnus-comparable-date in gnus.el 273 (defun rmail-make-date-sortable (date)
168 274 "Make DATE sortable using the function string-lessp."
169 (defun rmail-sortable-date-string (date) 275 ;; Assume the default time zone is GMT.
170 "Make sortable string by string-lessp from DATE." 276 (timezone-make-date-sortable date "GMT" "GMT"))
171 (let ((month '(("JAN" . " 1")("FEB" . " 2")("MAR" . " 3") 277
172 ("APR" . " 4")("MAY" . " 5")("JUN" . " 6") 278 ;; Copy of the function gnus-comparable-date in gnus.el version 3.13
173 ("JUL" . " 7")("AUG" . " 8")("SEP" . " 9") 279 ;
174 ("OCT" . "10")("NOV" . "11")("DEC" . "12") 280 ;(defun rmail-make-date-sortable (date)
175 ("JANUARY" . " 1") ("FEBRUARY" . " 2") 281 ; "Make sortable string by string-lessp from DATE."
176 ("MARCH" . " 3") ("APRIL" . " 4") 282 ; (let ((month '(("JAN" . " 1")("FEB" . " 2")("MAR" . " 3")
177 ("MAY" . " 5") ("JUNE" . " 6") 283 ; ("APR" . " 4")("MAY" . " 5")("JUN" . " 6")
178 ("JULY" . " 7") ("AUGUST" . " 8") 284 ; ("JUL" . " 7")("AUG" . " 8")("SEP" . " 9")
179 ("SEPTEMBER" " 9") ("OCTOBER" . "10") 285 ; ("OCT" . "10")("NOV" . "11")("DEC" . "12")))
180 ("NOVEMBER" "11") ("DECEMBER" . "12"))) 286 ; (date (or date "")))
181 (date (or date ""))) 287 ; ;; Can understand the following styles:
182 ;; Can understand the following styles: 288 ; ;; (1) 14 Apr 89 03:20:12 GMT
183 ;; (1) 14 Apr 89 03:20:12 GMT 289 ; ;; (2) Fri, 17 Mar 89 4:01:33 GMT
184 ;; (2) Fri, 17 Mar 89 4:01:33 GMT 290 ; (if (string-match
185 (if (string-match 291 ; "\\([0-9]+\\) \\([^ ,]+\\) \\([0-9]+\\) \\([0-9:]+\\)" date)
186 "\\([0-9]+\\) +\\([^ ,]+\\) +\\([0-9]+\\) +\\([0-9:]+\\)" date) 292 ; (concat
187 (concat 293 ; ;; Year
188 ;; Year 294 ; (substring date (match-beginning 3) (match-end 3))
189 (rmail-date-full-year 295 ; ;; Month
190 (substring date (match-beginning 3) (match-end 3))) 296 ; (cdr
191 ;; Month 297 ; (assoc
192 (cdr 298 ; (upcase (substring date (match-beginning 2) (match-end 2))) month))
193 (assoc 299 ; ;; Day
194 (upcase (substring date (match-beginning 2) (match-end 2))) month)) 300 ; (format "%2d" (string-to-int
195 ;; Day 301 ; (substring date
196 (format "%2d" (string-to-int 302 ; (match-beginning 1) (match-end 1))))
197 (substring date 303 ; ;; Time
198 (match-beginning 1) (match-end 1)))) 304 ; (substring date (match-beginning 4) (match-end 4)))
199 ;; Time 305 ; ;; Cannot understand DATE string.
200 (substring date (match-beginning 4) (match-end 4))) 306 ; date
201 307 ; )
202 ;; Handles this format Fri May 10 21:51:55 1991 308 ; ))
203 (if (string-match
204 " \\([a-z][a-z][a-z]\\) +\\([0-9]+\\) \\([0-9:]+\\) \\([0-9]+\\)" date)
205 (concat
206 ;; Year
207 (rmail-date-full-year
208 (substring date (match-beginning 4) (match-end 4)))
209 ;; Month
210 (cdr
211 (assoc
212 (upcase (substring date (match-beginning 1) (match-end 1))) month))
213 ;; Day
214 (format "%2d" (string-to-int
215 (substring date
216 (match-beginning 2) (match-end 2))))
217 ;; Time
218 (substring date (match-beginning 3) (match-end 3)))
219
220 ;; Cannot understand DATE string.
221 date))))
222
223 (defun rmail-date-full-year (year-string)
224 (if (<= (length year-string) 2)
225 (concat "19" year-string)
226 year-string))
227 309
228 (provide 'rmailsort) 310 (provide 'rmailsort)
229 311
230 ;;; rmailsort.el ends here 312 ;;; rmailsort.el ends here