Mercurial > emacs
annotate lisp/mail/rmailsort.el @ 814:38b2499cb3e9
*** empty log message ***
author | Eric S. Raymond <esr@snark.thyrsus.com> |
---|---|
date | Fri, 17 Jul 1992 20:24:00 +0000 |
parents | 4f28bd14272c |
children | 213978acbc1e |
rev | line source |
---|---|
658
7cbd4fcd8b0f
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
584
diff
changeset
|
1 ;;; rmailsort.el --- Rmail: sort messages. |
7cbd4fcd8b0f
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
584
diff
changeset
|
2 |
807
4f28bd14272c
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
767
diff
changeset
|
3 ;; Maintainer: FSF |
4f28bd14272c
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
767
diff
changeset
|
4 ;; Last-Modified: 16 Mar 1992 |
814
38b2499cb3e9
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
807
diff
changeset
|
5 ;; Keywords: mail |
807
4f28bd14272c
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
767
diff
changeset
|
6 |
767
02bfc9709961
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
658
diff
changeset
|
7 ;; Copyright (C) 1990 Free Software Foundation, Inc. |
02bfc9709961
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
658
diff
changeset
|
8 ;; This file is part of GNU Emacs. |
90 | 9 |
767
02bfc9709961
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
658
diff
changeset
|
10 ;; GNU Emacs is free software; you can redistribute it and/or modify |
02bfc9709961
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
658
diff
changeset
|
11 ;; it under the terms of the GNU General Public License as published by |
807
4f28bd14272c
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
767
diff
changeset
|
12 ;; the Free Software Foundation; either version 2, or (at your option) |
767
02bfc9709961
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
658
diff
changeset
|
13 ;; any later version. |
90 | 14 |
15 ;; GNU Emacs is distributed in the hope that it will be useful, | |
767
02bfc9709961
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
658
diff
changeset
|
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
02bfc9709961
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
658
diff
changeset
|
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
02bfc9709961
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
658
diff
changeset
|
18 ;; GNU General Public License for more details. |
90 | 19 |
767
02bfc9709961
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
658
diff
changeset
|
20 ;; You should have received a copy of the GNU General Public License |
02bfc9709961
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
658
diff
changeset
|
21 ;; along with GNU Emacs; see the file COPYING. If not, write to |
02bfc9709961
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
658
diff
changeset
|
22 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |
02bfc9709961
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
658
diff
changeset
|
23 |
807
4f28bd14272c
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
767
diff
changeset
|
24 ;;; Code: |
90 | 25 |
26 (require 'rmail) | |
27 (require 'sort) | |
28 | |
29 ;; GNUS compatible key bindings. | |
30 (define-key rmail-mode-map "\C-c\C-s\C-d" 'rmail-sort-by-date) | |
31 (define-key rmail-mode-map "\C-c\C-s\C-s" 'rmail-sort-by-subject) | |
32 (define-key rmail-mode-map "\C-c\C-s\C-a" 'rmail-sort-by-author) | |
33 (define-key rmail-mode-map "\C-c\C-s\C-r" 'rmail-sort-by-recipient) | |
131 | 34 (define-key rmail-mode-map "\C-c\C-s\C-c" 'rmail-sort-by-correspondent) |
148
a099f0c77321
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
131
diff
changeset
|
35 (define-key rmail-mode-map "\C-c\C-s\C-l" 'rmail-sort-by-size-lines) |
90 | 36 |
37 (defun rmail-sort-by-date (reverse) | |
38 "Sort messages of current Rmail file by date. | |
39 If prefix argument REVERSE is non-nil, sort them in reverse order." | |
40 (interactive "P") | |
41 (rmail-sort-messages reverse | |
42 (function | |
43 (lambda (msg) | |
44 (rmail-sortable-date-string | |
45 (rmail-fetch-field msg "Date")))))) | |
46 | |
47 (defun rmail-sort-by-subject (reverse) | |
48 "Sort messages of current Rmail file by subject. | |
49 If prefix argument REVERSE is non-nil, sort them in reverse order." | |
50 (interactive "P") | |
51 (rmail-sort-messages reverse | |
52 (function | |
53 (lambda (msg) | |
54 (let ((key (or (rmail-fetch-field msg "Subject") "")) | |
55 (case-fold-search t)) | |
56 ;; Remove `Re:' | |
57 (if (string-match "^\\(re:[ \t]+\\)*" key) | |
58 (substring key (match-end 0)) key)))))) | |
59 | |
60 (defun rmail-sort-by-author (reverse) | |
61 "Sort messages of current Rmail file by author. | |
62 If prefix argument REVERSE is non-nil, sort them in reverse order." | |
63 (interactive "P") | |
64 (rmail-sort-messages reverse | |
65 (function | |
66 (lambda (msg) | |
67 (mail-strip-quoted-names | |
68 (or (rmail-fetch-field msg "From") | |
69 (rmail-fetch-field msg "Sender") "")))))) | |
70 | |
71 (defun rmail-sort-by-recipient (reverse) | |
72 "Sort messages of current Rmail file by recipient. | |
73 If prefix argument REVERSE is non-nil, sort them in reverse order." | |
74 (interactive "P") | |
75 (rmail-sort-messages reverse | |
76 (function | |
77 (lambda (msg) | |
78 (mail-strip-quoted-names | |
79 (or (rmail-fetch-field msg "To") | |
80 (rmail-fetch-field msg "Apparently-To") "") | |
81 ))))) | |
82 | |
131 | 83 (defun rmail-sort-by-correspondent (reverse) |
84 "Sort messages of current Rmail file by other correspondent. | |
85 If prefix argument REVERSE is non-nil, sort them in reverse order." | |
86 (interactive "P") | |
87 (rmail-sort-messages reverse | |
88 (function | |
89 (lambda (msg) | |
90 (rmail-select-correspondent | |
91 msg | |
92 '("From" "Sender" "To" "Apparently-To")))))) | |
93 | |
94 (defun rmail-select-correspondent (msg fields) | |
95 (let ((ans "")) | |
96 (while (and fields (string= ans "")) | |
97 (setq ans | |
98 (rmail-dont-reply-to | |
99 (mail-strip-quoted-names | |
100 (or (rmail-fetch-field msg (car fields)) "")))) | |
101 (setq fields (cdr fields))) | |
102 ans)) | |
148
a099f0c77321
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
131
diff
changeset
|
103 |
a099f0c77321
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
131
diff
changeset
|
104 (defun rmail-sort-by-size-lines (reverse) |
a099f0c77321
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
131
diff
changeset
|
105 "Sort messages of current Rmail file by message size. |
a099f0c77321
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
131
diff
changeset
|
106 If prefix argument REVERSE is non-nil, sort them in reverse order." |
a099f0c77321
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
131
diff
changeset
|
107 (interactive "P") |
a099f0c77321
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
131
diff
changeset
|
108 (rmail-sort-messages reverse |
a099f0c77321
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
131
diff
changeset
|
109 (function |
a099f0c77321
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
131
diff
changeset
|
110 (lambda (msg) |
a099f0c77321
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
131
diff
changeset
|
111 (format "%9d" |
a099f0c77321
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
131
diff
changeset
|
112 (count-lines (rmail-msgbeg msgnum) |
a099f0c77321
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
131
diff
changeset
|
113 (rmail-msgend msgnum))))))) |
90 | 114 |
115 | |
116 (defun rmail-sort-messages (reverse keyfunc) | |
117 "Sort messages of current Rmail file. | |
118 1st argument REVERSE is non-nil, sort them in reverse order. | |
119 2nd argument KEYFUNC is called with message number, and should return a key." | |
120 (let ((buffer-read-only nil) | |
121 (sort-lists nil)) | |
122 (message "Finding sort keys...") | |
123 (widen) | |
124 (let ((msgnum 1)) | |
125 (while (>= rmail-total-messages msgnum) | |
126 (setq sort-lists | |
127 (cons (cons (funcall keyfunc msgnum) ;A sort key. | |
128 (buffer-substring | |
129 (rmail-msgbeg msgnum) (rmail-msgend msgnum))) | |
130 sort-lists)) | |
148
a099f0c77321
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
131
diff
changeset
|
131 (if (zerop (% msgnum 10)) |
a099f0c77321
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
131
diff
changeset
|
132 (message "Finding sort keys...%d" msgnum)) |
90 | 133 (setq msgnum (1+ msgnum)))) |
134 (or reverse (setq sort-lists (nreverse sort-lists))) | |
135 (setq sort-lists | |
136 (sort sort-lists | |
137 (function | |
138 (lambda (a b) | |
139 (string-lessp (car a) (car b)))))) | |
140 (if reverse (setq sort-lists (nreverse sort-lists))) | |
141 (message "Reordering buffer...") | |
142 (delete-region (rmail-msgbeg 1) (rmail-msgend rmail-total-messages)) | |
148
a099f0c77321
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
131
diff
changeset
|
143 (let ((msgnum 1)) |
a099f0c77321
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
131
diff
changeset
|
144 (while sort-lists |
a099f0c77321
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
131
diff
changeset
|
145 (insert (cdr (car sort-lists))) |
a099f0c77321
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
131
diff
changeset
|
146 (if (zerop (% msgnum 10)) |
a099f0c77321
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
131
diff
changeset
|
147 (message "Reordering buffer...%d" msgnum)) |
a099f0c77321
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
131
diff
changeset
|
148 (setq sort-lists (cdr sort-lists)) |
a099f0c77321
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
131
diff
changeset
|
149 (setq msgnum (1+ msgnum)))) |
90 | 150 (rmail-set-message-counters) |
150 | 151 (rmail-show-message 1))) |
90 | 152 |
153 (defun rmail-fetch-field (msg field) | |
154 "Return the value of the header field FIELD of MSG. | |
155 Arguments are MSG and FIELD." | |
156 (let ((next (rmail-msgend msg))) | |
157 (save-restriction | |
158 (goto-char (rmail-msgbeg msg)) | |
159 (narrow-to-region (if (search-forward "\n*** EOOH ***\n" next t) | |
160 (point) | |
161 (forward-line 1) | |
162 (point)) | |
163 (progn (search-forward "\n\n" nil t) (point))) | |
164 (mail-fetch-field field)))) | |
165 | |
166 ;; Copy of the function gnus-comparable-date in gnus.el | |
167 | |
168 (defun rmail-sortable-date-string (date) | |
169 "Make sortable string by string-lessp from DATE." | |
170 (let ((month '(("JAN" . " 1")("FEB" . " 2")("MAR" . " 3") | |
171 ("APR" . " 4")("MAY" . " 5")("JUN" . " 6") | |
172 ("JUL" . " 7")("AUG" . " 8")("SEP" . " 9") | |
150 | 173 ("OCT" . "10")("NOV" . "11")("DEC" . "12") |
174 ("JANUARY" . " 1") ("FEBRUARY" . " 2") | |
175 ("MARCH" . " 3") ("APRIL" . " 4") | |
176 ("MAY" . " 5") ("JUNE" . " 6") | |
177 ("JULY" . " 7") ("AUGUST" . " 8") | |
178 ("SEPTEMBER" " 9") ("OCTOBER" . "10") | |
179 ("NOVEMBER" "11") ("DECEMBER" . "12"))) | |
90 | 180 (date (or date ""))) |
181 ;; Can understand the following styles: | |
182 ;; (1) 14 Apr 89 03:20:12 GMT | |
183 ;; (2) Fri, 17 Mar 89 4:01:33 GMT | |
184 (if (string-match | |
92 | 185 "\\([0-9]+\\) +\\([^ ,]+\\) +\\([0-9]+\\) +\\([0-9:]+\\)" date) |
90 | 186 (concat |
131 | 187 ;; Year |
188 (rmail-date-full-year | |
189 (substring date (match-beginning 3) (match-end 3))) | |
90 | 190 ;; Month |
191 (cdr | |
192 (assoc | |
193 (upcase (substring date (match-beginning 2) (match-end 2))) month)) | |
194 ;; Day | |
195 (format "%2d" (string-to-int | |
196 (substring date | |
197 (match-beginning 1) (match-end 1)))) | |
198 ;; Time | |
199 (substring date (match-beginning 4) (match-end 4))) | |
200 ;; Cannot understand DATE string. | |
148
a099f0c77321
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
131
diff
changeset
|
201 date))) |
131 | 202 |
203 (defun rmail-date-full-year (year-string) | |
204 (if (<= (length year-string) 2) | |
205 (concat "19" year-string) | |
206 year-string)) | |
584 | 207 |
208 (provide 'rmailsort) | |
658
7cbd4fcd8b0f
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
584
diff
changeset
|
209 |
7cbd4fcd8b0f
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
584
diff
changeset
|
210 ;;; rmailsort.el ends here |