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