1;;; mh-limit.el --- MH-E display limits
2
3;; Copyright (C) 2001, 2002, 2003, 2006, 2007 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
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
93          (mh-quote-pick-expr (mh-current-message-header-field 'cc)))))
94  (mh-narrow-to-header-field 'cc pick-expr))
95
96;;;###mh-autoload
97(defun mh-narrow-to-from (&optional pick-expr)
98  "Limit to messages with the same \"From:\" field.
99With a prefix argument, edit PICK-EXPR.
100
101Use \\<mh-folder-mode-map>\\[mh-widen] to undo this command."
102  (interactive
103   (list (mh-edit-pick-expr
104          (mh-quote-pick-expr (mh-current-message-header-field 'from)))))
105  (mh-narrow-to-header-field 'from pick-expr))
106
107;;;###mh-autoload
108(defun mh-narrow-to-range (range)
109  "Limit to RANGE.
110
111Check the documentation of `mh-interactive-range' to see how
112RANGE is read in interactive use.
113
114Use \\<mh-folder-mode-map>\\[mh-widen] to undo this command."
115  (interactive (list (mh-interactive-range "Narrow to")))
116  (when (assoc 'range mh-seq-list) (mh-delete-seq 'range))
117  (mh-add-msgs-to-seq (mh-range-to-msg-list range) 'range)
118  (mh-narrow-to-seq 'range))
119
120;;;###mh-autoload
121(defun mh-narrow-to-subject (&optional pick-expr)
122  "Limit to messages with same subject.
123With a prefix argument, edit PICK-EXPR.
124The string Re: is removed from the search.
125
126Use \\<mh-folder-mode-map>\\[mh-widen] to undo this command."
127  (interactive
128   (list (mh-edit-pick-expr
129          (mh-quote-pick-expr (mh-current-message-header-field 'subject)))))
130  (setq pick-expr
131        (let ((case-fold-search t))
132          (loop for s in pick-expr
133                collect (mh-replace-regexp-in-string "re: *" "" s))))
134  (mh-narrow-to-header-field 'subject pick-expr))
135
136;;;###mh-autoload
137(defun mh-narrow-to-to (&optional pick-expr)
138  "Limit to messages with the same \"To:\" field.
139With a prefix argument, edit PICK-EXPR.
140
141Use \\<mh-folder-mode-map>\\[mh-widen] to undo this command."
142  (interactive
143   (list (mh-edit-pick-expr
144          (mh-quote-pick-expr (mh-current-message-header-field 'to)))))
145  (mh-narrow-to-header-field 'to pick-expr))
146
147
148
149;;; Support Routines
150
151(defun mh-subject-to-sequence (all)
152  "Put all following messages with same subject in sequence 'subject.
153If arg ALL is t, move to beginning of folder buffer to collect all
154messages.
155If arg ALL is nil, collect only messages fron current one on forward.
156
157Return number of messages put in the sequence:
158
159 nil -> there was no subject line.
160
161 0   -> there were no later messages with the same
162        subject (sequence not made)
163
164 >1  -> the total number of messages including current one."
165  (if (memq 'unthread mh-view-ops)
166      (mh-subject-to-sequence-threaded all)
167    (mh-subject-to-sequence-unthreaded all)))
168
169(defun mh-subject-to-sequence-threaded (all)
170  "Put all messages with the same subject in the 'subject sequence.
171
172This function works when the folder is threaded. In this
173situation the subject could get truncated and so the normal
174matching doesn't work.
175
176The parameter ALL is non-nil then all the messages in the buffer
177are considered, otherwise only the messages after the current one
178are taken into account."
179  (let* ((cur (mh-get-msg-num nil))
180         (subject (mh-thread-find-msg-subject cur))
181         region msgs)
182    (if (null subject)
183        (and (message "No subject line") nil)
184      (setq region (cons (if all (point-min) (point)) (point-max)))
185      (mh-iterate-on-range msg region
186        (when (eq (mh-thread-find-msg-subject msg) subject)
187          (push msg msgs)))
188      (setq msgs (sort msgs #'mh-lessp))
189      (if (null msgs)
190          0
191        (when (assoc 'subject mh-seq-list)
192          (mh-delete-seq 'subject))
193        (mh-add-msgs-to-seq msgs 'subject)
194        (length msgs)))))
195
196(defvar mh-limit-max-subject-size 41
197  "Maximum size of the subject part.
198It would be desirable to avoid hard-coding this.")
199
200(defun mh-subject-to-sequence-unthreaded (all)
201  "Put all following messages with same subject in sequence 'subject.
202
203This function only works with an unthreaded folder. If arg ALL is
204t, move to beginning of folder buffer to collect all messages. If
205arg ALL is nil, collect only messages fron current one on
206forward.
207
208Return number of messages put in the sequence:
209
210 nil -> there was no subject line.
211 0   -> there were no later messages with the same
212        subject (sequence not made)
213 >1  -> the total number of messages including current one."
214  (if (not (eq major-mode 'mh-folder-mode))
215      (error "Not in a folder buffer"))
216  (save-excursion
217    (beginning-of-line)
218    (if (or (not (looking-at mh-scan-subject-regexp))
219            (not (match-string 3))
220            (string-equal "" (match-string 3)))
221        (progn (message "No subject line")
222               nil)
223      (let ((subject (mh-match-string-no-properties 3))
224            (list))
225        (if (> (length subject) mh-limit-max-subject-size)
226            (setq subject (substring subject 0 mh-limit-max-subject-size)))
227        (save-excursion
228          (if all
229              (goto-char (point-min)))
230          (while (re-search-forward mh-scan-subject-regexp nil t)
231            (let ((this-subject (mh-match-string-no-properties 3)))
232              (if (> (length this-subject) mh-limit-max-subject-size)
233                  (setq this-subject (substring this-subject
234                                                0 mh-limit-max-subject-size)))
235              (if (string-equal this-subject subject)
236                  (setq list (cons (mh-get-msg-num t) list))))))
237        (cond
238         (list
239          ;; If we created a new sequence, add the initial message to it too.
240          (if (not (member (mh-get-msg-num t) list))
241              (setq list (cons (mh-get-msg-num t) list)))
242          (if (assoc 'subject mh-seq-list) (mh-delete-seq 'subject))
243          ;; sort the result into a sequence
244          (let ((sorted-list (sort (copy-sequence list) 'mh-lessp)))
245            (while sorted-list
246              (mh-add-msgs-to-seq (car sorted-list) 'subject nil)
247              (setq sorted-list (cdr sorted-list)))
248            (safe-length list)))
249         (t
250          0))))))
251
252(defun mh-edit-pick-expr (default)
253  "With prefix arg edit a pick expression.
254If no prefix arg is given, then return DEFAULT."
255  (let ((default-string (loop for x in default concat (format " %s" x))))
256    (if (or current-prefix-arg (equal default-string ""))
257        (mh-pick-args-list (read-string "Pick expression: "
258                                        default-string))
259      default)))
260
261(defun mh-pick-args-list (s)
262  "Form list by grouping elements in string S suitable for pick arguments.
263For example, the string \"-subject a b c -from Joe User
264<user@domain.com>\" is converted to (\"-subject\" \"a b c\"
265\"-from\" \"Joe User <user@domain.com>\""
266  (let ((full-list (split-string s))
267        current-arg collection arg-list)
268    (while full-list
269      (setq current-arg (car full-list))
270      (if (null (string-match "^-" current-arg))
271          (setq collection
272                (if (null collection)
273                    current-arg
274                  (format "%s %s" collection current-arg)))
275        (when collection
276          (setq arg-list (append arg-list (list collection)))
277          (setq collection nil))
278        (setq arg-list (append arg-list (list current-arg))))
279      (setq full-list (cdr full-list)))
280    (when collection
281      (setq arg-list (append arg-list (list collection))))
282    arg-list))
283
284(defun mh-current-message-header-field (header-field)
285  "Return a pick regexp to match HEADER-FIELD of the message at point."
286  (let ((num (mh-get-msg-num nil)))
287    (when num
288      (let ((folder mh-current-folder))
289        (with-temp-buffer
290          (insert-file-contents-literally (mh-msg-filename num folder))
291          (goto-char (point-min))
292          (when (search-forward "\n\n" nil t)
293            (narrow-to-region (point-min) (point)))
294          (let* ((field (or (message-fetch-field (format "%s" header-field))
295                            ""))
296                 (field-option (format "-%s" header-field))
297                 (patterns (loop for x in (split-string  field "[ ]*,[ ]*")
298                                 unless (equal x "")
299                                 collect (if (string-match "<\\(.*@.*\\)>" x)
300                                             (match-string 1 x)
301                                           x))))
302            (when patterns
303              (loop with accum = `(,field-option ,(car patterns))
304                    for e in (cdr patterns)
305                    do (setq accum `(,field-option ,e "-or" ,@accum))
306                    finally return accum))))))))
307
308(defun mh-narrow-to-header-field (header-field pick-expr)
309  "Limit to messages whose HEADER-FIELD match PICK-EXPR.
310The MH command pick is used to do the match."
311  (let ((folder mh-current-folder)
312        (original (mh-coalesce-msg-list
313                   (mh-range-to-msg-list (cons (point-min) (point-max)))))
314        (msg-list ()))
315    (with-temp-buffer
316      (apply #'mh-exec-cmd-output "pick" nil folder
317             (append original (list "-list") pick-expr))
318      (goto-char (point-min))
319      (while (not (eobp))
320        (let ((num (ignore-errors
321                     (string-to-number
322                      (buffer-substring (point) (mh-line-end-position))))))
323          (when num (push num msg-list))
324          (forward-line))))
325    (if (null msg-list)
326        (message "No matches")
327      (when (assoc 'header mh-seq-list) (mh-delete-seq 'header))
328      (mh-add-msgs-to-seq msg-list 'header)
329      (mh-narrow-to-seq 'header))))
330
331(provide 'mh-limit)
332
333;; Local Variables:
334;; indent-tabs-mode: nil
335;; sentence-end-double-space: nil
336;; End:
337
338;; arch-tag: b0d24378-1234-4c42-aa3f-7abad25b40a1
339;;; mh-limit.el ends here
340