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