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