1 ;;; mh-limit.el --- MH-E display limits
3 ;; Copyright (C) 2001, 2002, 2003, 2006 Free Software Foundation, Inc.
5 ;; Author: Peter S. Galbraith <psg@debian.org>
6 ;; Maintainer: Bill Wohler <wohler@newt.com>
10 ;; This file is part of GNU Emacs.
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)
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.
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.
29 ;; "Poor man's threading" by psg.
39 (autoload 'message-fetch-field
"message")
43 ;;; MH-Folder Commands
48 (defun mh-delete-subject ()
49 "Delete messages with same subject\\<mh-folder-mode-map>.
51 To delete messages faster, you can use this command to delete all
52 the messages with the same subject as the current message. This
53 command puts these messages in a sequence named \"subject\". You
54 can undo this action by using \\[mh-undo] with a prefix argument
55 and then specifying the \"subject\" sequence."
57 (let ((count (mh-subject-to-sequence nil
)))
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
)))))
69 (defun mh-delete-subject-or-thread ()
70 "Delete messages with same subject or thread\\<mh-folder-mode-map>.
72 To delete messages faster, you can use this command to delete all
73 the messages with the same subject as the current message. This
74 command puts these messages in a sequence named \"subject\". You
75 can undo this action by using \\[mh-undo] with a prefix argument
76 and then specifying the \"subject\" sequence.
78 However, if the buffer is displaying a threaded view of the
79 folder then this command behaves like \\[mh-thread-delete]."
81 (if (memq 'unthread mh-view-ops
)
86 (defun mh-narrow-to-cc (&optional pick-expr
)
87 "Limit to messages with the same \"Cc:\" field.
88 With a prefix argument, edit PICK-EXPR.
90 Use \\<mh-folder-mode-map>\\[mh-widen] to undo this command."
92 (list (mh-edit-pick-expr (mh-current-message-header-field 'cc
))))
93 (mh-narrow-to-header-field 'cc pick-expr
))
96 (defun mh-narrow-to-from (&optional pick-expr
)
97 "Limit to messages with the same \"From:\" field.
98 With a prefix argument, edit PICK-EXPR.
100 Use \\<mh-folder-mode-map>\\[mh-widen] to undo this command."
102 (list (mh-edit-pick-expr (mh-current-message-header-field 'from
))))
103 (mh-narrow-to-header-field 'from pick-expr
))
106 (defun mh-narrow-to-range (range)
109 Check the documentation of `mh-interactive-range' to see how
110 RANGE is read in interactive use.
112 Use \\<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
))
119 (defun mh-narrow-to-subject (&optional pick-expr
)
120 "Limit to messages with same subject.
121 With a prefix argument, edit PICK-EXPR.
123 Use \\<mh-folder-mode-map>\\[mh-widen] to undo this command."
125 (list (mh-edit-pick-expr (mh-current-message-header-field 'subject
))))
126 (mh-narrow-to-header-field 'subject pick-expr
))
129 (defun mh-narrow-to-to (&optional pick-expr
)
130 "Limit to messages with the same \"To:\" field.
131 With a prefix argument, edit PICK-EXPR.
133 Use \\<mh-folder-mode-map>\\[mh-widen] to undo this command."
135 (list (mh-edit-pick-expr (mh-current-message-header-field 'to
))))
136 (mh-narrow-to-header-field 'to pick-expr
))
142 (defun mh-subject-to-sequence (all)
143 "Put all following messages with same subject in sequence 'subject.
144 If arg ALL is t, move to beginning of folder buffer to collect all
146 If arg ALL is nil, collect only messages fron current one on forward.
148 Return number of messages put in the sequence:
150 nil -> there was no subject line.
152 0 -> there were no later messages with the same
153 subject (sequence not made)
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
)))
160 (defun mh-subject-to-sequence-threaded (all)
161 "Put all messages with the same subject in the 'subject sequence.
163 This function works when the folder is threaded. In this
164 situation the subject could get truncated and so the normal
165 matching doesn't work.
167 The parameter ALL is non-nil then all the messages in the buffer
168 are considered, otherwise only the messages after the current one
169 are taken into account."
170 (let* ((cur (mh-get-msg-num nil
))
171 (subject (mh-thread-find-msg-subject cur
))
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
)
179 (setq msgs
(sort msgs
#'mh-lessp
))
182 (when (assoc 'subject mh-seq-list
)
183 (mh-delete-seq 'subject
))
184 (mh-add-msgs-to-seq msgs
'subject
)
187 (defvar mh-limit-max-subject-size
41
188 "Maximum size of the subject part.
189 It would be desirable to avoid hard-coding this.")
191 (defun mh-subject-to-sequence-unthreaded (all)
192 "Put all following messages with same subject in sequence 'subject.
194 This function only works with an unthreaded folder. If arg ALL is
195 t, move to beginning of folder buffer to collect all messages. If
196 arg ALL is nil, collect only messages fron current one on
199 Return number of messages put in the sequence:
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"))
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")
214 (let ((subject (mh-match-string-no-properties 3))
216 (if (> (length subject
) mh-limit-max-subject-size
)
217 (setq subject
(substring subject
0 mh-limit-max-subject-size
)))
220 (goto-char (point-min)))
221 (while (re-search-forward mh-scan-subject-regexp nil t
)
222 (let ((this-subject (mh-match-string-no-properties 3)))
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
))))))
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
)))
237 (mh-add-msgs-to-seq (car sorted-list
) 'subject nil
)
238 (setq sorted-list
(cdr sorted-list
)))
243 (defun mh-edit-pick-expr (default)
244 "With prefix arg edit a pick expression.
245 If 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: "
252 (defun mh-pick-args-list (s)
253 "Form list by grouping elements in string S suitable for pick arguments.
254 For 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
)
260 (setq current-arg
(car full-list
))
261 (if (null (string-match "^-" current-arg
))
263 (if (null collection
)
265 (format "%s %s" collection current-arg
)))
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
)))
272 (setq arg-list
(append arg-list
(list collection
))))
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
)))
279 (let ((folder mh-current-folder
))
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
))
287 (field-option (format "-%s" header-field
))
288 (patterns (loop for x in
(split-string field
"[ ]*,[ ]*")
290 collect
(if (string-match "<\\(.*@.*\\)>" x
)
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
))))))))
299 (defun mh-narrow-to-header-field (header-field pick-expr
)
300 "Limit to messages whose HEADER-FIELD match PICK-EXPR.
301 The 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)))))
307 (apply #'mh-exec-cmd-output
"pick" nil folder
308 (append original
(list "-list") pick-expr
))
309 (goto-char (point-min))
311 (let ((num (ignore-errors
313 (buffer-substring (point) (mh-line-end-position))))))
314 (when num
(push num 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
))))
325 ;; indent-tabs-mode: nil
326 ;; sentence-end-double-space: nil
329 ;; arch-tag: b0d24378-1234-4c42-aa3f-7abad25b40a1
330 ;;; mh-limit.el ends here