(Named Features): Fix typo.
[bpt/emacs.git] / lisp / mh-e / mh-limit.el
CommitLineData
dda00b2c
BW
1;;; mh-limit.el --- MH-E display limits
2
3;; Copyright (C) 2001, 2002, 2003, 2006 Free Software Foundation, Inc.
4
5;; Author: Peter S. Galbraith <psg@debian.org>
6;; Maintainer: Bill Wohler <wohler@newt.com>
7;; Keywords: mail
8;; See: mh-e.el
9
10;; This file is part of GNU Emacs.
11
12;; GNU Emacs is free software; you can redistribute it and/or modify
13;; it under the terms of the GNU General Public License as published by
14;; the Free Software Foundation; either version 2, or (at your option)
15;; any later version.
16
17;; GNU Emacs is distributed in the hope that it will be useful,
18;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20;; GNU General Public License for more details.
21
22;; You should have received a copy of the GNU General Public License
23;; along with GNU Emacs; see the file COPYING. If not, write to the
24;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
25;; Boston, MA 02110-1301, USA.
26
27;;; Commentary:
28
29;; "Poor man's threading" by psg.
30
31;;; Change Log:
32
33;;; Code:
34
35(require 'mh-e)
36(mh-require-cl)
37(require 'mh-scan)
38
39(autoload 'message-fetch-field "message")
40
41\f
42
43;;; MH-Folder Commands
44
45;; Alphabetical.
46
47;;;###mh-autoload
48(defun mh-delete-subject ()
49 "Delete messages with same subject\\<mh-folder-mode-map>.
50
51To delete messages faster, you can use this command to delete all
52the messages with the same subject as the current message. This
53command puts these messages in a sequence named \"subject\". You
54can undo this action by using \\[mh-undo] with a prefix argument
55and then specifying the \"subject\" sequence."
56 (interactive)
57 (let ((count (mh-subject-to-sequence nil)))
58 (cond
59 ((not count) ; No subject line, delete msg anyway
60 (mh-delete-msg (mh-get-msg-num t)))
61 ((= 0 count) ; No other msgs, delete msg anyway.
62 (message "No other messages with same Subject following this one")
63 (mh-delete-msg (mh-get-msg-num t)))
64 (t ; We have a subject sequence.
65 (message "Marked %d messages for deletion" count)
66 (mh-delete-msg 'subject)))))
67
68;;;###mh-autoload
69(defun mh-delete-subject-or-thread ()
70 "Delete messages with same subject or thread\\<mh-folder-mode-map>.
71
72To delete messages faster, you can use this command to delete all
73the messages with the same subject as the current message. This
74command puts these messages in a sequence named \"subject\". You
75can undo this action by using \\[mh-undo] with a prefix argument
76and then specifying the \"subject\" sequence.
77
78However, if the buffer is displaying a threaded view of the
79folder then this command behaves like \\[mh-thread-delete]."
80 (interactive)
81 (if (memq 'unthread mh-view-ops)
82 (mh-thread-delete)
83 (mh-delete-subject)))
84
85;;;###mh-autoload
86(defun mh-narrow-to-cc (&optional pick-expr)
87 "Limit to messages with the same \"Cc:\" field.
88With a prefix argument, edit PICK-EXPR.
89
90Use \\<mh-folder-mode-map>\\[mh-widen] to undo this command."
91 (interactive
92 (list (mh-edit-pick-expr (mh-current-message-header-field 'cc))))
93 (mh-narrow-to-header-field 'cc pick-expr))
94
95;;;###mh-autoload
96(defun mh-narrow-to-from (&optional pick-expr)
97 "Limit to messages with the same \"From:\" field.
98With a prefix argument, edit PICK-EXPR.
99
100Use \\<mh-folder-mode-map>\\[mh-widen] to undo this command."
101 (interactive
102 (list (mh-edit-pick-expr (mh-current-message-header-field 'from))))
103 (mh-narrow-to-header-field 'from pick-expr))
104
105;;;###mh-autoload
106(defun mh-narrow-to-range (range)
107 "Limit to RANGE.
108
109Check the documentation of `mh-interactive-range' to see how
110RANGE is read in interactive use.
111
112Use \\<mh-folder-mode-map>\\[mh-widen] to undo this command."
113 (interactive (list (mh-interactive-range "Narrow to")))
114 (when (assoc 'range mh-seq-list) (mh-delete-seq 'range))
115 (mh-add-msgs-to-seq (mh-range-to-msg-list range) 'range)
116 (mh-narrow-to-seq 'range))
117
118;;;###mh-autoload
119(defun mh-narrow-to-subject (&optional pick-expr)
120 "Limit to messages with same subject.
121With a prefix argument, edit PICK-EXPR.
122
123Use \\<mh-folder-mode-map>\\[mh-widen] to undo this command."
124 (interactive
125 (list (mh-edit-pick-expr (mh-current-message-header-field 'subject))))
126 (mh-narrow-to-header-field 'subject pick-expr))
127
128;;;###mh-autoload
129(defun mh-narrow-to-to (&optional pick-expr)
130 "Limit to messages with the same \"To:\" field.
131With a prefix argument, edit PICK-EXPR.
132
133Use \\<mh-folder-mode-map>\\[mh-widen] to undo this command."
134 (interactive
135 (list (mh-edit-pick-expr (mh-current-message-header-field 'to))))
136 (mh-narrow-to-header-field 'to pick-expr))
137
138\f
139
140;;; Support Routines
141
142(defun mh-subject-to-sequence (all)
143 "Put all following messages with same subject in sequence 'subject.
144If arg ALL is t, move to beginning of folder buffer to collect all
145messages.
146If arg ALL is nil, collect only messages fron current one on forward.
147
148Return number of messages put in the sequence:
149
150 nil -> there was no subject line.
151
152 0 -> there were no later messages with the same
153 subject (sequence not made)
154
155 >1 -> the total number of messages including current one."
156 (if (memq 'unthread mh-view-ops)
157 (mh-subject-to-sequence-threaded all)
158 (mh-subject-to-sequence-unthreaded all)))
159
160(defun mh-subject-to-sequence-threaded (all)
161 "Put all messages with the same subject in the 'subject sequence.
162
163This function works when the folder is threaded. In this
164situation the subject could get truncated and so the normal
165matching doesn't work.
166
167The parameter ALL is non-nil then all the messages in the buffer
168are considered, otherwise only the messages after the current one
169are taken into account."
170 (let* ((cur (mh-get-msg-num nil))
171 (subject (mh-thread-find-msg-subject cur))
172 region msgs)
173 (if (null subject)
174 (and (message "No subject line") nil)
175 (setq region (cons (if all (point-min) (point)) (point-max)))
176 (mh-iterate-on-range msg region
177 (when (eq (mh-thread-find-msg-subject msg) subject)
178 (push msg msgs)))
179 (setq msgs (sort msgs #'mh-lessp))
180 (if (null msgs)
181 0
182 (when (assoc 'subject mh-seq-list)
183 (mh-delete-seq 'subject))
184 (mh-add-msgs-to-seq msgs 'subject)
185 (length msgs)))))
186
187(defvar mh-limit-max-subject-size 41
188 "Maximum size of the subject part.
189It would be desirable to avoid hard-coding this.")
190
191(defun mh-subject-to-sequence-unthreaded (all)
192 "Put all following messages with same subject in sequence 'subject.
193
194This function only works with an unthreaded folder. If arg ALL is
195t, move to beginning of folder buffer to collect all messages. If
196arg ALL is nil, collect only messages fron current one on
197forward.
198
199Return number of messages put in the sequence:
200
201 nil -> there was no subject line.
202 0 -> there were no later messages with the same
203 subject (sequence not made)
204 >1 -> the total number of messages including current one."
205 (if (not (eq major-mode 'mh-folder-mode))
206 (error "Not in a folder buffer"))
207 (save-excursion
208 (beginning-of-line)
209 (if (or (not (looking-at mh-scan-subject-regexp))
210 (not (match-string 3))
211 (string-equal "" (match-string 3)))
212 (progn (message "No subject line")
213 nil)
d5dc8c56 214 (let ((subject (mh-match-string-no-properties 3))
dda00b2c
BW
215 (list))
216 (if (> (length subject) mh-limit-max-subject-size)
217 (setq subject (substring subject 0 mh-limit-max-subject-size)))
218 (save-excursion
219 (if all
220 (goto-char (point-min)))
221 (while (re-search-forward mh-scan-subject-regexp nil t)
d5dc8c56 222 (let ((this-subject (mh-match-string-no-properties 3)))
dda00b2c
BW
223 (if (> (length this-subject) mh-limit-max-subject-size)
224 (setq this-subject (substring this-subject
225 0 mh-limit-max-subject-size)))
226 (if (string-equal this-subject subject)
227 (setq list (cons (mh-get-msg-num t) list))))))
228 (cond
229 (list
230 ;; If we created a new sequence, add the initial message to it too.
231 (if (not (member (mh-get-msg-num t) list))
232 (setq list (cons (mh-get-msg-num t) list)))
233 (if (assoc 'subject mh-seq-list) (mh-delete-seq 'subject))
234 ;; sort the result into a sequence
235 (let ((sorted-list (sort (copy-sequence list) 'mh-lessp)))
236 (while sorted-list
237 (mh-add-msgs-to-seq (car sorted-list) 'subject nil)
238 (setq sorted-list (cdr sorted-list)))
239 (safe-length list)))
240 (t
241 0))))))
242
243(defun mh-edit-pick-expr (default)
244 "With prefix arg edit a pick expression.
245If no prefix arg is given, then return DEFAULT."
246 (let ((default-string (loop for x in default concat (format " %s" x))))
247 (if (or current-prefix-arg (equal default-string ""))
248 (mh-pick-args-list (read-string "Pick expression: "
249 default-string))
250 default)))
251
252(defun mh-pick-args-list (s)
253 "Form list by grouping elements in string S suitable for pick arguments.
254For example, the string \"-subject a b c -from Joe User
255<user@domain.com>\" is converted to (\"-subject\" \"a b c\"
256\"-from\" \"Joe User <user@domain.com>\""
257 (let ((full-list (split-string s))
258 current-arg collection arg-list)
259 (while full-list
260 (setq current-arg (car full-list))
261 (if (null (string-match "^-" current-arg))
262 (setq collection
263 (if (null collection)
264 current-arg
265 (format "%s %s" collection current-arg)))
266 (when collection
267 (setq arg-list (append arg-list (list collection)))
268 (setq collection nil))
269 (setq arg-list (append arg-list (list current-arg))))
270 (setq full-list (cdr full-list)))
271 (when collection
272 (setq arg-list (append arg-list (list collection))))
273 arg-list))
274
275(defun mh-current-message-header-field (header-field)
276 "Return a pick regexp to match HEADER-FIELD of the message at point."
277 (let ((num (mh-get-msg-num nil)))
278 (when num
279 (let ((folder mh-current-folder))
280 (with-temp-buffer
281 (insert-file-contents-literally (mh-msg-filename num folder))
282 (goto-char (point-min))
283 (when (search-forward "\n\n" nil t)
284 (narrow-to-region (point-min) (point)))
285 (let* ((field (or (message-fetch-field (format "%s" header-field))
286 ""))
287 (field-option (format "-%s" header-field))
288 (patterns (loop for x in (split-string field "[ ]*,[ ]*")
289 unless (equal x "")
290 collect (if (string-match "<\\(.*@.*\\)>" x)
291 (match-string 1 x)
292 x))))
293 (when patterns
294 (loop with accum = `(,field-option ,(car patterns))
295 for e in (cdr patterns)
296 do (setq accum `(,field-option ,e "-or" ,@accum))
297 finally return accum))))))))
298
299(defun mh-narrow-to-header-field (header-field pick-expr)
300 "Limit to messages whose HEADER-FIELD match PICK-EXPR.
301The MH command pick is used to do the match."
302 (let ((folder mh-current-folder)
303 (original (mh-coalesce-msg-list
304 (mh-range-to-msg-list (cons (point-min) (point-max)))))
305 (msg-list ()))
306 (with-temp-buffer
307 (apply #'mh-exec-cmd-output "pick" nil folder
308 (append original (list "-list") pick-expr))
309 (goto-char (point-min))
310 (while (not (eobp))
311 (let ((num (ignore-errors
312 (string-to-number
d5dc8c56 313 (buffer-substring (point) (mh-line-end-position))))))
dda00b2c
BW
314 (when num (push num msg-list))
315 (forward-line))))
316 (if (null msg-list)
317 (message "No matches")
318 (when (assoc 'header mh-seq-list) (mh-delete-seq 'header))
319 (mh-add-msgs-to-seq msg-list 'header)
320 (mh-narrow-to-seq 'header))))
321
322(provide 'mh-limit)
323
324;; Local Variables:
325;; indent-tabs-mode: nil
326;; sentence-end-double-space: nil
327;; End:
328
a1ab640d 329;; arch-tag: b0d24378-1234-4c42-aa3f-7abad25b40a1
dda00b2c 330;;; mh-limit.el ends here