Mercurial > emacs
annotate lisp/mail/rmailsort.el @ 1398:70d0cd4c5bff
mem_limits.h is now called mem-limits.h.
author | Roland McGrath <roland@gnu.org> |
---|---|
date | Mon, 12 Oct 1992 18:55:05 +0000 |
parents | 213978acbc1e |
children | f680a6fb6661 |
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." | |
119 (let ((buffer-read-only nil) | |
120 (sort-lists nil)) | |
121 (message "Finding sort keys...") | |
122 (widen) | |
123 (let ((msgnum 1)) | |
124 (while (>= rmail-total-messages msgnum) | |
125 (setq sort-lists | |
126 (cons (cons (funcall keyfunc msgnum) ;A sort key. | |
127 (buffer-substring | |
128 (rmail-msgbeg msgnum) (rmail-msgend msgnum))) | |
129 sort-lists)) | |
148
a099f0c77321
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
131
diff
changeset
|
130 (if (zerop (% msgnum 10)) |
a099f0c77321
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
131
diff
changeset
|
131 (message "Finding sort keys...%d" msgnum)) |
90 | 132 (setq msgnum (1+ msgnum)))) |
133 (or reverse (setq sort-lists (nreverse sort-lists))) | |
134 (setq sort-lists | |
135 (sort sort-lists | |
136 (function | |
137 (lambda (a b) | |
138 (string-lessp (car a) (car b)))))) | |
139 (if reverse (setq sort-lists (nreverse sort-lists))) | |
140 (message "Reordering buffer...") | |
141 (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
|
142 (let ((msgnum 1)) |
a099f0c77321
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
131
diff
changeset
|
143 (while sort-lists |
a099f0c77321
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
131
diff
changeset
|
144 (insert (cdr (car sort-lists))) |
a099f0c77321
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
131
diff
changeset
|
145 (if (zerop (% msgnum 10)) |
a099f0c77321
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
131
diff
changeset
|
146 (message "Reordering buffer...%d" msgnum)) |
a099f0c77321
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
131
diff
changeset
|
147 (setq sort-lists (cdr sort-lists)) |
a099f0c77321
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
131
diff
changeset
|
148 (setq msgnum (1+ msgnum)))) |
90 | 149 (rmail-set-message-counters) |
150 | 150 (rmail-show-message 1))) |
90 | 151 |
152 (defun rmail-fetch-field (msg field) | |
153 "Return the value of the header field FIELD of MSG. | |
154 Arguments are MSG and FIELD." | |
155 (let ((next (rmail-msgend msg))) | |
156 (save-restriction | |
157 (goto-char (rmail-msgbeg msg)) | |
158 (narrow-to-region (if (search-forward "\n*** EOOH ***\n" next t) | |
159 (point) | |
160 (forward-line 1) | |
161 (point)) | |
162 (progn (search-forward "\n\n" nil t) (point))) | |
163 (mail-fetch-field field)))) | |
164 | |
165 ;; Copy of the function gnus-comparable-date in gnus.el | |
166 | |
167 (defun rmail-sortable-date-string (date) | |
168 "Make sortable string by string-lessp from DATE." | |
169 (let ((month '(("JAN" . " 1")("FEB" . " 2")("MAR" . " 3") | |
170 ("APR" . " 4")("MAY" . " 5")("JUN" . " 6") | |
171 ("JUL" . " 7")("AUG" . " 8")("SEP" . " 9") | |
150 | 172 ("OCT" . "10")("NOV" . "11")("DEC" . "12") |
173 ("JANUARY" . " 1") ("FEBRUARY" . " 2") | |
174 ("MARCH" . " 3") ("APRIL" . " 4") | |
175 ("MAY" . " 5") ("JUNE" . " 6") | |
176 ("JULY" . " 7") ("AUGUST" . " 8") | |
177 ("SEPTEMBER" " 9") ("OCTOBER" . "10") | |
178 ("NOVEMBER" "11") ("DECEMBER" . "12"))) | |
90 | 179 (date (or date ""))) |
180 ;; Can understand the following styles: | |
181 ;; (1) 14 Apr 89 03:20:12 GMT | |
182 ;; (2) Fri, 17 Mar 89 4:01:33 GMT | |
183 (if (string-match | |
92 | 184 "\\([0-9]+\\) +\\([^ ,]+\\) +\\([0-9]+\\) +\\([0-9:]+\\)" date) |
90 | 185 (concat |
131 | 186 ;; Year |
187 (rmail-date-full-year | |
188 (substring date (match-beginning 3) (match-end 3))) | |
90 | 189 ;; Month |
190 (cdr | |
191 (assoc | |
192 (upcase (substring date (match-beginning 2) (match-end 2))) month)) | |
193 ;; Day | |
194 (format "%2d" (string-to-int | |
195 (substring date | |
196 (match-beginning 1) (match-end 1)))) | |
197 ;; Time | |
198 (substring date (match-beginning 4) (match-end 4))) | |
199 ;; Cannot understand DATE string. | |
148
a099f0c77321
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
131
diff
changeset
|
200 date))) |
131 | 201 |
202 (defun rmail-date-full-year (year-string) | |
203 (if (<= (length year-string) 2) | |
204 (concat "19" year-string) | |
205 year-string)) | |
584 | 206 |
207 (provide 'rmailsort) | |
658
7cbd4fcd8b0f
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
584
diff
changeset
|
208 |
7cbd4fcd8b0f
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
584
diff
changeset
|
209 ;;; rmailsort.el ends here |