lisp/mh-e/mh-limit.el

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