lisp/mh-e/mh-limit.el

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