lisp/mh-e/mh-limit.el

   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 3, 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 \f
  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
  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."
  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
  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.
  77
  78 However, if the buffer is displaying a threaded view of the
  79 folder 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.
  88 With a prefix argument, edit PICK-EXPR.
  89
  90 Use \\<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.
  99 With a prefix argument, edit PICK-EXPR.
 100
 101 Use \\<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
 111 Check the documentation of `mh-interactive-range' to see how
 112 RANGE is read in interactive use.
 113
 114 Use \\<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.
 123 With a prefix argument, edit PICK-EXPR.
 124 The string Re: is removed from the search.
 125
 126 Use \\<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.
 139 With a prefix argument, edit PICK-EXPR.
 140
 141 Use \\<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 \f
 148
 149 ;;; Support Routines
 150
 151 (defun mh-subject-to-sequence (all)
 152   "Put all following messages with same subject in sequence 'subject.
 153 If arg ALL is t, move to beginning of folder buffer to collect all
 154 messages.
 155 If arg ALL is nil, collect only messages fron current one on forward.
 156
 157 Return 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
 172 This function works when the folder is threaded. In this
 173 situation the subject could get truncated and so the normal
 174 matching doesn't work.
 175
 176 The parameter ALL is non-nil then all the messages in the buffer
 177 are considered, otherwise only the messages after the current one
 178 are 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.
 198 It 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
 203 This function only works with an unthreaded folder. If arg ALL is
 204 t, move to beginning of folder buffer to collect all messages. If
 205 arg ALL is nil, collect only messages fron current one on
 206 forward.
 207
 208 Return 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.
 254 If 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.
 263 For 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.
 310 The 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