cgit.sxemacs.org Git - packages/blob - xemacs-packages/vm/lisp/vm-mark.el

   1 ;;; vm-mark.el ---  Commands for handling messages marks
   2 ;;
   3 ;; Copyright (C) 1990, 1993, 1994 Kyle E. Jones
   4 ;; Copyright (C) 2003-2006 Robert Widhopf-Fenk
   5 ;;
   6 ;; This program is free software; you can redistribute it and/or modify
   7 ;; it under the terms of the GNU General Public License as published by
   8 ;; the Free Software Foundation; either version 2 of the License, or
   9 ;; (at your option) any later version.
  10 ;;
  11 ;; This program is distributed in the hope that it will be useful,
  12 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;; GNU General Public License for more details.
  15 ;;
  16 ;; You should have received a copy of the GNU General Public License along
  17 ;; with this program; if not, write to the Free Software Foundation, Inc.,
  18 ;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  19
  20 ;;; Code:
  21
  22 ;;;###autoload
  23 (defun vm-clear-all-marks ()
  24   "Removes all message marks in the current folder."
  25   (interactive)
  26   (vm-select-folder-buffer)
  27   (vm-check-for-killed-summary)
  28   (vm-error-if-folder-empty)
  29   (message "Clearing all marks...")
  30   (let ((mp vm-message-list))
  31     (while mp
  32       (if (vm-mark-of (car mp))
  33           (progn
  34             (vm-set-mark-of (car mp) nil)
  35             (vm-mark-for-summary-update (car mp) t)))
  36       (setq mp (cdr mp))))
  37   (vm-display nil nil '(vm-clear-all-marks)
  38               '(vm-clear-all-marks marking-message))
  39   (vm-update-summary-and-mode-line)
  40   (message "Clearing all marks... done"))
  41
  42 ;;;###autoload
  43 (defun vm-toggle-all-marks ()
  44   "Toggles all message marks in the current folder.
  45 Messages that are unmarked will become marked and messages that are
  46 marked will become unmarked."
  47   (interactive)
  48   (vm-select-folder-buffer)
  49   (vm-check-for-killed-summary)
  50   (vm-error-if-folder-empty)
  51   (message "Toggling all marks...")
  52   (let ((mp vm-message-list))
  53     (while mp
  54       (vm-set-mark-of (car mp) (not (vm-mark-of (car mp))))
  55       (vm-mark-for-summary-update (car mp) t)
  56       (setq mp (cdr mp))))
  57   (vm-display nil nil '(vm-toggle-all-marks)
  58               '(vm-toggle-all-marks marking-message))
  59   (vm-update-summary-and-mode-line)
  60   (message "Toggling all marks... done"))
  61
  62 ;;;###autoload
  63 (defun vm-mark-all-messages ()
  64   "Mark all messages in the current folder."
  65   (interactive)
  66   (vm-select-folder-buffer)
  67   (vm-check-for-killed-summary)
  68   (vm-error-if-folder-empty)
  69   (message "Marking all messages...")
  70   (let ((mp vm-message-list))
  71     (while mp
  72       (vm-set-mark-of (car mp) t)
  73       (vm-mark-for-summary-update (car mp) t)
  74       (setq mp (cdr mp))))
  75   (vm-display nil nil '(vm-mark-all-messages)
  76               '(vm-mark-all-messages marking-message))
  77   (vm-update-summary-and-mode-line)
  78   (message "Marking all messages... done"))
  79
  80 ;;;###autoload
  81 (defun vm-mark-message (count)
  82   "Mark the current message.
  83 Numeric prefix argument N means mark the current message and the next
  84 N-1 messages.  A negative N means mark the current message and the
  85 previous N-1 messages."
  86   (interactive "p")
  87   (if (interactive-p)
  88       (vm-follow-summary-cursor))
  89   (vm-select-folder-buffer)
  90   (vm-check-for-killed-summary)
  91   (vm-error-if-folder-empty)
  92   (let ((direction (if (< count 0) 'backward 'forward))
  93         (count (vm-abs count))
  94         (oldmp vm-message-pointer)
  95         (vm-message-pointer vm-message-pointer))
  96     (while (not (zerop count))
  97       (if (not (vm-mark-of (car vm-message-pointer)))
  98           (progn
  99             (vm-set-mark-of (car vm-message-pointer) t)
 100             (vm-mark-for-summary-update (car vm-message-pointer) t)))
 101       (vm-decrement count)
 102       (if (not (zerop count))
 103           (vm-move-message-pointer direction))))
 104   (vm-display nil nil '(vm-mark-message)
 105               '(vm-mark-message marking-message))
 106   (vm-update-summary-and-mode-line))
 107
 108 ;;;###autoload
 109 (defun vm-unmark-message (count)
 110   "Remove the mark from the current message.
 111 Numeric prefix argument N means unmark the current message and the next
 112 N-1 messages.  A negative N means unmark the current message and the
 113 previous N-1 messages."
 114   (interactive "p")
 115   (if (interactive-p)
 116       (vm-follow-summary-cursor))
 117   (vm-select-folder-buffer)
 118   (vm-check-for-killed-summary)
 119   (vm-error-if-folder-empty)
 120   (let ((mlist (vm-select-marked-or-prefixed-messages count)))
 121     (while mlist
 122       (if (vm-mark-of (car mlist))
 123           (progn
 124             (vm-set-mark-of (car mlist) nil)
 125             (vm-mark-for-summary-update (car mlist) t)))
 126       (setq mlist (cdr mlist))))
 127   (vm-display nil nil '(vm-unmark-message)
 128               '(vm-unmark-message marking-message))
 129   (vm-update-summary-and-mode-line))
 130
 131 ;;;###autoload
 132 (defun vm-mark-summary-region ()
 133   "Mark all messages with summary lines contained in the region."
 134   (interactive)
 135   (vm-select-folder-buffer)
 136   (vm-check-for-killed-summary)
 137   (vm-error-if-folder-empty)
 138   (if (null vm-summary-buffer)
 139       (error "No summary."))
 140   (set-buffer vm-summary-buffer)
 141   (if (not (mark))
 142       (error "The region is not active now"))
 143   (vm-mark-or-unmark-summary-region t)
 144   (vm-display nil nil '(vm-mark-summary-region)
 145               '(vm-mark-summary-region marking-message))
 146   (vm-update-summary-and-mode-line))
 147
 148 ;;;###autoload
 149 (defun vm-unmark-summary-region ()
 150   "Remove marks from messages with summary lines contained in the region."
 151   (interactive)
 152   (vm-select-folder-buffer)
 153   (vm-check-for-killed-summary)
 154   (vm-error-if-folder-empty)
 155   (if (null vm-summary-buffer)
 156       (error "No summary."))
 157   (set-buffer vm-summary-buffer)
 158   (if (not (mark))
 159       (error "The region is not active now"))
 160   (vm-mark-or-unmark-summary-region nil)
 161   (vm-display nil nil '(vm-unmark-summary-region)
 162               '(vm-unmark-summary-region marking-message))
 163   (vm-update-summary-and-mode-line))
 164
 165 (defun vm-mark-or-unmark-summary-region (markit)
 166   ;; The folder buffers copy of vm-message-list has already been
 167   ;; propagated to the summary buffer.
 168   (let ((mp vm-message-list)
 169         (beg (point))
 170         (end (mark))
 171         tmp m)
 172     (if (> beg end)
 173         (setq tmp beg beg end end tmp))
 174     (while mp
 175       (setq m (car mp))
 176       (if (not (eq (not markit) (not (vm-mark-of m))))
 177           (if (or (and (>  (vm-su-end-of m) beg)
 178                        (<  (vm-su-end-of m) end))
 179                   (and (>= (vm-su-start-of m) beg)
 180                        (<  (vm-su-start-of m) end))
 181                   (and (>= beg (vm-su-start-of m))
 182                        (<  beg (vm-su-end-of m))))
 183               (progn
 184                 (vm-set-mark-of m markit)
 185                 (vm-mark-for-summary-update m t))))
 186       (setq mp (cdr mp)))))
 187
 188 (defun vm-mark-or-unmark-messages-with-selector (val selector arg)
 189   (let ((mlist vm-message-list)
 190         (virtual (eq major-mode 'vm-virtual-mode))
 191         (arglist (if arg (list arg) nil))
 192         (count 0))
 193     (setq selector (intern (concat "vm-vs-" (symbol-name selector))))
 194     (while mlist
 195       (if (if virtual
 196               (save-excursion
 197                 (set-buffer
 198                  (vm-buffer-of
 199                   (vm-real-message-of
 200                    (car mlist))))
 201                 (apply selector (vm-real-message-of (car mlist)) arglist))
 202             (apply selector (car mlist) arglist))
 203           (progn
 204             (vm-set-mark-of (car mlist) val)
 205             (vm-mark-for-summary-update (car mlist) t)
 206             (vm-increment count)))
 207       (setq mlist (cdr mlist)))
 208     (vm-display nil nil
 209                 '(vm-mark-matching-messages vm-unmark-matching-messages)
 210                 (list this-command 'marking-message))
 211     (vm-update-summary-and-mode-line)
 212     (message "%s message%s %smarked"
 213              (if (> count 0) count "No")
 214              (if (= 1 count) "" "s")
 215              (if val "" "un"))))
 216
 217 ;;;###autoload
 218 (defun vm-mark-matching-messages (selector &optional arg)
 219   "Mark messages matching some criterion.
 220 You can use any of the virtual folder selectors, except for the
 221 `and', `or' and `not' selectors.  See the documentation for the
 222 variable vm-virtual-folder-alist for more information."
 223   (interactive
 224    (let ((last-command last-command)
 225          (this-command this-command))
 226      (vm-select-folder-buffer)
 227      (vm-read-virtual-selector "Mark messages: ")))
 228   (vm-select-folder-buffer)
 229   (vm-check-for-killed-summary)
 230   (vm-error-if-folder-empty)
 231   (vm-mark-or-unmark-messages-with-selector t selector arg))
 232
 233 ;;;###autoload
 234 (defun vm-unmark-matching-messages (selector &optional arg)
 235   "Unmark messages matching some criterion.
 236 You can use any of the virtual folder selectors, except for the
 237 `and', `or' and `not' selectors.  See the documentation for the
 238 variable vm-virtual-folder-alist for more information."
 239   (interactive
 240    (let ((last-command last-command)
 241          (this-command this-command))
 242      (vm-select-folder-buffer)
 243      (vm-read-virtual-selector "Unmark messages: ")))
 244   (vm-select-folder-buffer)
 245   (vm-check-for-killed-summary)
 246   (vm-error-if-folder-empty)
 247   (vm-mark-or-unmark-messages-with-selector nil selector arg))
 248
 249 ;;;###autoload
 250 (defun vm-mark-thread-subtree ()
 251   "Mark all messages in the thread tree rooted at the current message."
 252   (interactive)
 253   (vm-follow-summary-cursor)
 254   (vm-select-folder-buffer)
 255   (vm-check-for-killed-summary)
 256   (vm-error-if-folder-empty)
 257   (vm-mark-or-unmark-thread-subtree t))
 258
 259 ;;;###autoload
 260 (defun vm-unmark-thread-subtree ()
 261   "Unmark all messages in the thread tree rooted at the current message."
 262   (interactive)
 263   (vm-follow-summary-cursor)
 264   (vm-select-folder-buffer)
 265   (vm-check-for-killed-summary)
 266   (vm-error-if-folder-empty)
 267   (vm-mark-or-unmark-thread-subtree nil))
 268
 269 (defun vm-mark-or-unmark-thread-subtree (mark)
 270   (vm-build-threads-if-unbuilt)
 271   (let ((list (list (car vm-message-pointer)))
 272         (loop-obarray (make-vector 29 0))
 273         subject-sym id-sym)
 274     (while list
 275       (if (not (eq (vm-mark-of (car list)) mark))
 276           (progn
 277             (vm-set-mark-of (car list) mark)
 278             (vm-mark-for-summary-update (car list))))
 279       (setq id-sym (car (vm-last (vm-th-thread-list (car list)))))
 280       (if (null (intern-soft (symbol-name id-sym) loop-obarray))
 281           (progn
 282             (intern (symbol-name id-sym) loop-obarray)
 283             (nconc list (copy-sequence (get id-sym 'children)))
 284             (setq subject-sym (intern (vm-so-sortable-subject (car list))
 285                                       vm-thread-subject-obarray))
 286             (if (and (boundp subject-sym)
 287                      (eq id-sym (aref (symbol-value subject-sym) 0)))
 288                 (nconc list (copy-sequence
 289                              (aref (symbol-value subject-sym) 2))))))
 290       (setq list (cdr list))))
 291   (vm-display nil nil
 292               '(vm-mark-thread-subtree vm-unmark-thread-subtree)
 293               (list this-command 'marking-message))
 294   (vm-update-summary-and-mode-line))
 295
 296 ;;;###autoload
 297 (defun vm-mark-messages-same-subject ()
 298   "Mark all messages with the same subject as the current message."
 299   (interactive)
 300   (vm-follow-summary-cursor)
 301   (vm-select-folder-buffer)
 302   (vm-check-for-killed-summary)
 303   (vm-error-if-folder-empty)
 304   (vm-mark-or-unmark-messages-same-subject t))
 305
 306 ;;;###autoload
 307 (defun vm-unmark-messages-same-subject ()
 308   "Unmark all messages with the same subject as the current message."
 309   (interactive)
 310   (vm-follow-summary-cursor)
 311   (vm-select-folder-buffer)
 312   (vm-check-for-killed-summary)
 313   (vm-error-if-folder-empty)
 314   (vm-mark-or-unmark-messages-same-subject nil))
 315
 316 (defun vm-mark-or-unmark-messages-same-subject (mark)
 317   (let ((mp vm-message-list)
 318         (mark-count 0)
 319         (subject (vm-so-sortable-subject (car vm-message-pointer))))
 320     (while mp
 321       (if (and (not (eq (vm-mark-of (car mp)) mark))
 322                (string-equal subject (vm-so-sortable-subject (car mp))))
 323           (progn
 324             (vm-set-mark-of (car mp) mark)
 325             (vm-increment mark-count)
 326             (vm-mark-for-summary-update (car mp) t)))
 327       (setq mp (cdr mp)))
 328     (if (zerop mark-count)
 329         (message "No messages %smarked" (if mark "" "un"))
 330       (message "%d message%s %smarked"
 331                mark-count
 332                (if (= 1 mark-count) "" "s")
 333                (if mark "" "un"))))
 334   (vm-display nil nil
 335               '(vm-mark-messages-same-subject
 336                 vm-unmark-messages-same-subject)
 337               (list this-command 'marking-message))
 338   (vm-update-summary-and-mode-line))
 339
 340 ;;;###autoload
 341 (defun vm-mark-messages-same-author ()
 342   "Mark all messages with the same author as the current message."
 343   (interactive)
 344   (vm-follow-summary-cursor)
 345   (vm-select-folder-buffer)
 346   (vm-check-for-killed-summary)
 347   (vm-error-if-folder-empty)
 348   (vm-mark-or-unmark-messages-same-author t))
 349
 350 ;;;###autoload
 351 (defun vm-unmark-messages-same-author ()
 352   "Unmark all messages with the same author as the current message."
 353   (interactive)
 354   (vm-follow-summary-cursor)
 355   (vm-select-folder-buffer)
 356   (vm-check-for-killed-summary)
 357   (vm-error-if-folder-empty)
 358   (vm-mark-or-unmark-messages-same-author nil))
 359
 360 (defun vm-mark-or-unmark-messages-same-author (mark)
 361   (let ((mp vm-message-list)
 362         (mark-count 0)
 363         (author (vm-su-from (car vm-message-pointer))))
 364     (while mp
 365       (if (and (not (eq (vm-mark-of (car mp)) mark))
 366                (vm-string-equal-ignore-case author (vm-su-from (car mp))))
 367           (progn
 368             (vm-set-mark-of (car mp) mark)
 369             (vm-increment mark-count)
 370             (vm-mark-for-summary-update (car mp) t)))
 371       (setq mp (cdr mp)))
 372     (if (zerop mark-count)
 373         (message "No messages %smarked" (if mark "" "un"))
 374       (message "%d message%s %smarked"
 375                mark-count
 376                (if (= 1 mark-count) "" "s")
 377                (if mark "" "un"))))
 378   (vm-display nil nil
 379               '(vm-mark-messages-same-author
 380                 vm-unmark-messages-same-author)
 381               (list this-command 'marking-message))
 382   (vm-update-summary-and-mode-line))
 383
 384 (defun vm-mark-or-unmark-messages-with-virtual-folder (val name)
 385   (let* ((vfolder (assoc name vm-virtual-folder-alist))
 386          vm-virtual-folder-definition m mlist clauses
 387          (count 0))
 388     (or vfolder (error "No such virtual folder, %s" name))
 389     (setq vfolder (vm-copy vfolder))
 390     (setq clauses (cdr vfolder))
 391     (while clauses
 392       (setcar (car clauses) (list (list 'get-buffer (buffer-name))))
 393       (setq clauses (cdr clauses)))
 394     (setq vm-virtual-folder-definition vfolder)
 395     (setq mlist (vm-build-virtual-message-list vm-message-list t))
 396     (if (null vm-real-buffers)
 397         (while mlist
 398           (setq m (vm-real-message-of (car mlist)))
 399           (vm-set-mark-of m val)
 400           (vm-mark-for-summary-update m t)
 401           (vm-increment count)
 402           (setq mlist (cdr mlist)))
 403       (let ((curbuf (current-buffer)) vmlist)
 404         (while mlist
 405           (setq m (vm-real-message-of (car mlist))
 406                 vmlist (vm-virtual-messages-of m))
 407           (while vmlist
 408             (cond ((eq curbuf (vm-buffer-of (car vmlist)))
 409                    (vm-set-mark-of (car vmlist) val)
 410                    (vm-mark-for-summary-update (car vmlist) t)
 411                    (vm-increment count)
 412                    (setq vmlist nil))
 413                   (t (setq vmlist (cdr vmlist)))))
 414           (setq mlist (cdr mlist)))))
 415     (vm-display nil nil
 416                 '(vm-mark-matching-messages-with-virtual-folder
 417                   vm-unmark-matching-messages-with-virtual-folder)
 418                 (list this-command 'marking-message))
 419     (vm-update-summary-and-mode-line)
 420     (message "%s message%s %smarked"
 421              (if (> count 0) count "No")
 422              (if (= 1 count) "" "s")
 423              (if val "" "un"))))
 424
 425 ;;;###autoload
 426 (defun vm-mark-matching-messages-with-virtual-folder (name)
 427   "Mark messages that are matched by the selectors of virtual folder NAME."
 428   (interactive
 429    (let ((last-command last-command)
 430          (this-command this-command))
 431      (list
 432       (completing-read
 433        "Mark messages matching this virtual folder's selectors: "
 434        vm-virtual-folder-alist nil t))))
 435   (vm-select-folder-buffer)
 436   (vm-check-for-killed-summary)
 437   (vm-error-if-folder-empty)
 438   (vm-mark-or-unmark-messages-with-virtual-folder t name))
 439
 440 ;;;###autoload
 441 (defun vm-unmark-matching-messages-with-virtual-folder (name)
 442   "Unmark messages that are matched by the selectors of virtual folder NAME."
 443   (interactive
 444    (let ((last-command last-command)
 445          (this-command this-command))
 446      (list
 447       (completing-read
 448        "Unmark message matching this virtual folder's selectors: "
 449        vm-virtual-folder-alist nil t))))
 450   (vm-select-folder-buffer)
 451   (vm-check-for-killed-summary)
 452   (vm-error-if-folder-empty)
 453   (vm-mark-or-unmark-messages-with-virtual-folder nil name))
 454
 455 ;;;###autoload
 456 (defun vm-next-command-uses-marks ()
 457   "Does nothing except insure that the next VM command will operate only
 458 on the marked messages in the current folder.  This only works for
 459 commands bound to key, menu or button press events.  M-x vm-command will
 460 not work."
 461   (interactive)
 462   (setq this-command 'vm-next-command-uses-marks)
 463   (message "Next command uses marks...")
 464   (vm-display nil nil '(vm-next-command-uses-marks)
 465               '(vm-next-command-uses-marks)))
 466
 467 ;;;###autoload
 468 (defun vm-marked-messages ()
 469   (let (list (mp vm-message-list))
 470     (while mp
 471       (if (vm-mark-of (car mp))
 472           (setq list (cons (car mp) list)))
 473       (setq mp (cdr mp)))
 474     (nreverse list)))
 475
 476 ;;;###autoload
 477 (defun vm-mark-help ()
 478   (interactive)
 479   (vm-display nil nil '(vm-mark-help) '(vm-mark-help))
 480   (message "MM = mark, MU = unmark, Mm = mark all, Mu = unmark all, MN = use marks, ..."))
 481
 482 (provide 'vm-mark)
 483
 484 ;;; vm-mark.el ends here