wl/wl-action.el

   1 ;;; wl-action.el --- Mark and actions in the Summary mode for Wanderlust.
   2
   3 ;; Copyright (C) 2003 Yuuichi Teranishi <teranisi@gohome.org>
   4
   5 ;; Author: Yuuichi Teranishi <teranisi@gohome.org>
   6 ;; Keywords: mail, net news
   7
   8 ;; This file is part of Wanderlust (Yet Another Message Interface on Emacsen).
   9
  10 ;; This program is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14 ;;
  15 ;; This program is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19 ;;
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24 ;;
  25
  26 ;;; Commentary:
  27 ;;
  28
  29 ;;; Code:
  30 ;;
  31
  32 (require 'wl-summary)
  33
  34 (eval-when-compile
  35   (defalias-maybe 'wl-summary-target-mark 'ignore)
  36   (defalias-maybe 'wl-summary-target-mark-region 'ignore))
  37
  38 (defsubst wl-summary-action-mark (action)
  39   (nth 0 action))
  40 (defsubst wl-summary-action-symbol (action)
  41   (nth 1 action))
  42 (defsubst wl-summary-action-argument-function (action)
  43   (nth 2 action))
  44 (defsubst wl-summary-action-set-function (action)
  45   (nth 3 action))
  46 (defsubst wl-summary-action-exec-function (action)
  47   (nth 4 action))
  48 (defsubst wl-summary-action-face (action)
  49   (nth 5 action))
  50 (defsubst wl-summary-action-docstring (action)
  51   (concat (nth 6 action)
  52           "\nThis function is defined by `wl-summary-define-mark-action'."))
  53
  54 ;; Set mark
  55 (defun wl-summary-set-mark (&optional set-mark number interactive data)
  56   (interactive)
  57   "Set temporary mark SET-MARK on the message with NUMBER.
  58 NUMBER is the message number to set the mark on.
  59 INTERACTIVE is set as t if it have to run interactively.
  60 DATA is passed to the set-action function of the action as an argument.
  61 Return number if put mark succeed"
  62   (let* ((set-mark (or set-mark
  63                        (completing-read "Mark: " wl-summary-mark-action-list)))
  64          (current (wl-summary-message-number))
  65          (action (assoc set-mark wl-summary-mark-action-list))
  66          visible mark cur-mark)
  67     (when (zerop (elmo-folder-length wl-summary-buffer-elmo-folder))
  68       (error "Set mark failed"))
  69     (prog1
  70         (save-excursion
  71           ;; Put mark
  72           (if number
  73               ;; Jump to message if cursor is not on the message.
  74               (when (and (setq visible (wl-summary-message-visible-p number))
  75                          (not (eq number current)))
  76                 (wl-summary-jump-to-msg number))
  77             (setq visible t
  78                   number current))
  79           (setq cur-mark (nth 1 (wl-summary-registered-temp-mark number)))
  80           (unless number
  81             (error "No message"))
  82           (if (wl-summary-reserve-temp-mark-p cur-mark)
  83               (when interactive
  84                 (error "Already marked as `%s'" cur-mark))
  85             (when (and interactive
  86                        (null data)
  87                        (wl-summary-action-argument-function action))
  88               (setq data (funcall (wl-summary-action-argument-function action)
  89                                   (wl-summary-action-symbol action)
  90                                   number)))
  91             ;; Unset the current mark.
  92             (wl-summary-unset-mark number)
  93             ;; Set action.
  94             (funcall (wl-summary-action-set-function action)
  95                      number
  96                      (wl-summary-action-mark action)
  97                      data)
  98             (when visible
  99               (wl-summary-put-temp-mark set-mark)
 100               (when wl-summary-highlight
 101                 (wl-highlight-summary-current-line))
 102               (when data
 103                 (wl-summary-print-argument number data)))
 104             (set-buffer-modified-p nil)
 105             ;; Return value.
 106             number))
 107       ;; Move the cursor.
 108       (if (or interactive (interactive-p))
 109           (if (eq wl-summary-move-direction-downward nil)
 110               (wl-summary-prev)
 111             (wl-summary-next))))))
 112
 113 (defun wl-summary-register-target-mark (number mark data)
 114   (or (memq number wl-summary-buffer-target-mark-list)
 115       (setq wl-summary-buffer-target-mark-list
 116             (cons number wl-summary-buffer-target-mark-list))))
 117
 118 (defun wl-summary-unregister-target-mark (number)
 119   (setq wl-summary-buffer-target-mark-list
 120         (delq number wl-summary-buffer-target-mark-list)))
 121
 122 (defun wl-summary-have-target-mark-p (number)
 123   (memq number wl-summary-buffer-target-mark-list))
 124
 125 (defun wl-summary-target-mark-set-action (action)
 126   (unless (eq (wl-summary-action-symbol action) 'target-mark)
 127     (save-excursion
 128       (goto-char (point-min))
 129       (let ((numlist wl-summary-buffer-number-list)
 130             number mlist data)
 131         ;; use firstly marked message.
 132         (when (wl-summary-action-argument-function action)
 133           (while numlist
 134             (if (memq (car numlist) wl-summary-buffer-target-mark-list)
 135                 (setq number (car numlist)
 136                       numlist nil))
 137             (setq numlist (cdr numlist)))
 138           (wl-summary-jump-to-msg number)
 139           (setq data (funcall (wl-summary-action-argument-function action)
 140                               (wl-summary-action-symbol action) number)))
 141         (while (not (eobp))
 142           (when (string= (wl-summary-temp-mark) "*")
 143             (let (wl-summary-buffer-disp-msg)
 144               (when (setq number (wl-summary-message-number))
 145                 (wl-summary-set-mark (wl-summary-action-mark action)
 146                                      nil nil data)
 147                 (setq wl-summary-buffer-target-mark-list
 148                       (delq number wl-summary-buffer-target-mark-list)))))
 149           (forward-line 1))
 150         (setq mlist wl-summary-buffer-target-mark-list)
 151         (while mlist
 152           (wl-summary-register-temp-mark (car mlist)
 153                                          (wl-summary-action-mark action) data)
 154           (setq wl-summary-buffer-target-mark-list
 155                 (delq (car mlist) wl-summary-buffer-target-mark-list))
 156           (setq mlist (cdr mlist)))))))
 157
 158 ;; wl-summary-buffer-temp-mark-list specification
 159 ;; ((1 "D" nil)(2 "o" "+fuga")(3 "O" "+hoge"))
 160 (defun wl-summary-register-temp-mark (number mark mark-info)
 161   (let ((elem (assq number wl-summary-buffer-temp-mark-list)))
 162     (setq wl-summary-buffer-temp-mark-list
 163           (delq elem wl-summary-buffer-temp-mark-list)))
 164   (setq wl-summary-buffer-temp-mark-list
 165         (cons (list number mark mark-info) wl-summary-buffer-temp-mark-list)))
 166
 167 (defun wl-summary-unregister-temp-mark (number)
 168   (let ((elem (assq number wl-summary-buffer-temp-mark-list)))
 169     (setq wl-summary-buffer-temp-mark-list
 170           (delq elem wl-summary-buffer-temp-mark-list))))
 171
 172 (defun wl-summary-registered-temp-mark (number)
 173   (assq number wl-summary-buffer-temp-mark-list))
 174
 175 (defun wl-summary-collect-temp-mark (mark &optional begin end)
 176   (if (or begin end)
 177       (save-excursion
 178         (save-restriction
 179           (let (mark-list)
 180             (narrow-to-region (or begin (point-min))(or end (point-max)))
 181             (goto-char (point-min))
 182             ;; for thread...
 183             (if (eq wl-summary-buffer-view 'thread)
 184                 (let (number entity mark-info)
 185                   (while (not (eobp))
 186                     (setq number (wl-summary-message-number)
 187                           entity (wl-thread-get-entity number)
 188                           mark-info (wl-summary-registered-temp-mark number))
 189                     ;; toplevel message mark.
 190                     (when (string= (nth 1 mark-info) mark)
 191                       (setq mark-list (cons mark-info mark-list)))
 192                     ;; When thread is closed...children should also be checked.
 193                     (unless (wl-thread-entity-get-opened entity)
 194                       (dolist (msg (wl-thread-get-children-msgs number))
 195                         (setq mark-info (wl-summary-registered-temp-mark
 196                                          msg))
 197                         (when (string= (nth 1 mark-info) mark)
 198                           (setq mark-list (cons mark-info mark-list)))))
 199                     (forward-line 1)))
 200               (let (number mark-info)
 201                 (while (not (eobp))
 202                   (setq number (wl-summary-message-number)
 203                         mark-info (wl-summary-registered-temp-mark number))
 204                   (when (string= (nth 1 mark-info) mark)
 205                     (setq mark-list (cons mark-info mark-list)))
 206                   (forward-line 1))))
 207             mark-list)))
 208     (let (mark-list)
 209       (dolist (mark-info wl-summary-buffer-temp-mark-list)
 210         (when (string= (nth 1 mark-info) mark)
 211           (setq mark-list (cons mark-info mark-list))))
 212       mark-list)))
 213
 214 ;; Unset mark
 215 (defun wl-summary-unset-mark (&optional number interactive force)
 216   "Unset temporary mark of the message with NUMBER.
 217 NUMBER is the message number to unset the mark.
 218 If not specified, the message on the cursor position is treated.
 219 Optional INTERACTIVE is non-nil when it should be called interactively.
 220 If optional FORCE is non-nil, remove scored mark too.
 221 Return number if put mark succeed"
 222   (interactive)
 223   (save-excursion
 224     (beginning-of-line)
 225     (let ((buffer-read-only nil)
 226           visible mark action)
 227       (if number
 228           ;; Jump to message
 229           (when (and (setq visible (wl-summary-message-visible-p number))
 230                      (not (eq number (wl-summary-message-number))))
 231             (wl-summary-jump-to-msg number))
 232         (setq visible t
 233               number (wl-summary-message-number)))
 234       (setq mark (wl-summary-temp-mark))
 235       ;; Remove from temporal mark structure.
 236       (wl-summary-unregister-target-mark number)
 237       (wl-summary-unregister-temp-mark number)
 238       ;; Delete mark on buffer.
 239       (when visible
 240         (unless (string= mark " ")
 241           (wl-summary-put-temp-mark
 242            (or (unless force (wl-summary-get-score-mark number))
 243                " "))
 244           (setq action (assoc mark wl-summary-mark-action-list))
 245           (when wl-summary-highlight
 246             (wl-highlight-summary-current-line))
 247           (when (wl-summary-action-argument-function action)
 248             (wl-summary-remove-argument)))
 249         (set-buffer-modified-p nil))))
 250   ;; Move the cursor.
 251   ;;  (if (or interactive (interactive-p))
 252   ;;      (if (eq wl-summary-move-direction-downward nil)
 253   ;;      (wl-summary-prev)
 254   ;;    (wl-summary-next))))
 255   )
 256
 257 (defun wl-summary-make-destination-numbers-list (mark-list)
 258   (let (dest-numbers dest-number)
 259     (dolist (elem mark-list)
 260       (setq dest-number (assoc (nth 2 elem) dest-numbers))
 261       (if dest-number
 262           (unless (memq (car elem) (cdr dest-number))
 263             (nconc dest-number (list (car elem))))
 264         (setq dest-numbers (nconc dest-numbers
 265                                   (list
 266                                    (list (nth 2 elem)
 267                                          (car elem)))))))
 268     dest-numbers))
 269
 270 (defun wl-summary-move-mark-list-messages (mark-list folder-name message)
 271   (if (null mark-list)
 272       (message "No marks")
 273     (save-excursion
 274       (let ((start (point))
 275             (refiles (mapcar 'car mark-list))
 276             (refile-failures 0)
 277             refile-len
 278             dst-msgs                    ; loop counter
 279             result)
 280         ;; begin refile...
 281         (setq refile-len (length refiles))
 282         (goto-char start)               ; avoid moving cursor to
 283                                         ; the bottom line.
 284         (message message)
 285         (when (> refile-len elmo-display-progress-threshold)
 286           (elmo-progress-set 'elmo-folder-move-messages
 287                              refile-len message))
 288         (setq result nil)
 289         (condition-case nil
 290             (setq result (elmo-folder-move-messages
 291                           wl-summary-buffer-elmo-folder
 292                           refiles
 293                           (if (eq folder-name 'null)
 294                               'null
 295                             (wl-folder-get-elmo-folder folder-name))))
 296           (error nil))
 297         (when result            ; succeeded.
 298           ;; update buffer.
 299           (wl-summary-delete-messages-on-buffer refiles)
 300           ;; update wl-summary-buffer-temp-mark-list.
 301           (dolist (mark-info mark-list)
 302             (setq wl-summary-buffer-temp-mark-list
 303                   (delq mark-info wl-summary-buffer-temp-mark-list))))
 304         (elmo-progress-clear 'elmo-folder-move-messages)
 305         (message (concat message "done"))
 306         (wl-summary-set-message-modified)
 307         ;; Return the operation failed message numbers.
 308         (if result
 309             0
 310           (length refiles))))))
 311
 312 (defun wl-summary-get-refile-destination-subr (action number learn)
 313   (let* ((number (or number (wl-summary-message-number)))
 314          (msgid (and number
 315                      (elmo-message-field wl-summary-buffer-elmo-folder
 316                                          number 'message-id)))
 317          (entity (and number
 318                       (elmo-message-entity wl-summary-buffer-elmo-folder
 319                                            number)))
 320          folder cur-mark tmp-folder)
 321     (catch 'done
 322       (when (null entity)
 323         (message "Cannot decide destination.")
 324         (throw 'done nil))
 325       (when (null number)
 326         (message "No message.")
 327         (throw 'done nil))
 328       (setq folder (wl-summary-read-folder
 329                     (or (wl-refile-guess entity) wl-trash-folder)
 330                     (format "for %s " action)))
 331       ;; Cache folder hack by okada@opaopa.org
 332       (when (and (eq (elmo-folder-type-internal
 333                       (wl-folder-get-elmo-folder
 334                        (wl-folder-get-realname folder))) 'cache)
 335                  (not (string= folder
 336                                (setq tmp-folder
 337                                      (concat "'cache/"
 338                                              (elmo-cache-get-path-subr
 339                                               (elmo-msgid-to-cache msgid)))))))
 340         (setq folder tmp-folder)
 341         (message "Force refile to %s." folder))
 342       (if (string= folder (wl-summary-buffer-folder-name))
 343           (error "Same folder"))
 344       (if (or (not (elmo-folder-writable-p (wl-folder-get-elmo-folder folder)))
 345               (string= folder wl-queue-folder)
 346               (string= folder wl-draft-folder))
 347           (error "Don't set as target: %s" folder))
 348       ;; learn for refile.
 349       (when learn
 350         (wl-refile-learn entity folder))
 351       folder)))
 352
 353 ;;; Actions
 354 (defun wl-summary-define-mark-action ()
 355   (interactive)
 356   (dolist (action wl-summary-mark-action-list)
 357     (fset (intern (format "wl-summary-%s" (wl-summary-action-symbol action)))
 358           `(lambda (&optional number data)
 359              ,(wl-summary-action-docstring action)
 360              (interactive)
 361              (wl-summary-set-mark ,(wl-summary-action-mark action)
 362                                   number (interactive-p) data)))
 363     (fset (intern (format "wl-summary-%s-region"
 364                           (wl-summary-action-symbol action)))
 365           `(lambda (beg end)
 366              ,(wl-summary-action-docstring action)
 367              (interactive "r")
 368              (save-excursion
 369                (goto-char beg)
 370                (wl-summary-mark-region-subr
 371                 (quote ,(intern (format "wl-summary-%s"
 372                                         (wl-summary-action-symbol action))))
 373                 beg end
 374                 (if (quote ,(wl-summary-action-argument-function action))
 375                     (funcall (function
 376                               ,(wl-summary-action-argument-function action))
 377                              (quote ,(wl-summary-action-symbol action))
 378                              (wl-summary-message-number)))))))
 379     (fset (intern (format "wl-summary-target-mark-%s"
 380                           (wl-summary-action-symbol action)))
 381           `(lambda ()
 382              ,(wl-summary-action-docstring action)
 383              (interactive)
 384              (wl-summary-target-mark-set-action (quote ,action))))
 385     (fset (intern (format "wl-thread-%s"
 386                           (wl-summary-action-symbol action)))
 387           `(lambda (arg)
 388              ,(wl-summary-action-docstring action)
 389              (interactive "P")
 390              (wl-thread-call-region-func
 391               (quote ,(intern (format "wl-summary-%s-region"
 392                                       (wl-summary-action-symbol action))))
 393               arg)
 394              (if arg
 395                  (wl-summary-goto-top-of-current-thread))
 396              (if (not wl-summary-move-direction-downward)
 397                  (wl-summary-prev)
 398                (wl-thread-goto-bottom-of-sub-thread)
 399                (if wl-summary-buffer-disp-msg
 400                    (wl-summary-redisplay)))))))
 401
 402 (defun wl-summary-get-dispose-folder (folder)
 403   (if (string= folder wl-trash-folder)
 404       'null
 405     (let* ((type (or (wl-get-assoc-list-value wl-dispose-folder-alist folder)
 406                      'trash)))
 407       (cond ((stringp type)
 408              type)
 409             ((or (equal type 'remove) (equal type 'null))
 410              'null)
 411             (t;; (equal type 'trash)
 412              (let ((trash-folder (wl-folder-get-elmo-folder wl-trash-folder)))
 413                (unless (elmo-folder-exists-p trash-folder)
 414                  (if (y-or-n-p
 415                       (format "Trash Folder %s does not exist, create it? "
 416                               wl-trash-folder))
 417                      (elmo-folder-create trash-folder)
 418                    (error "Trash Folder is not created"))))
 419              wl-trash-folder)))))
 420
 421 ;; Dispose action.
 422 (defun wl-summary-exec-action-dispose (mark-list)
 423   (wl-summary-move-mark-list-messages mark-list
 424                                       (wl-summary-get-dispose-folder
 425                                        (wl-summary-buffer-folder-name))
 426                                       "Disposing messages..."))
 427
 428 ;; Delete action.
 429 (defun wl-summary-exec-action-delete (mark-list)
 430   (wl-summary-move-mark-list-messages mark-list
 431                                       'null
 432                                       "Deleting messages..."))
 433
 434 ;; Refile action
 435 (defun wl-summary-set-action-refile (number mark data)
 436   (let ((policy (wl-get-assoc-list-value wl-refile-policy-alist
 437                                          (wl-summary-buffer-folder-name)))
 438         (elem wl-summary-mark-action-list))
 439     (if (eq policy 'copy)
 440         (while elem
 441           (when (eq (wl-summary-action-symbol (car elem)) 'copy)
 442             (wl-summary-register-temp-mark number
 443                                            (wl-summary-action-mark (car elem))
 444                                            data)
 445             (setq elem nil))
 446           (setq elem (cdr elem)))
 447       (wl-summary-register-temp-mark number mark data)
 448       (setq wl-summary-buffer-prev-refile-destination data))))
 449
 450 (defun wl-summary-get-refile-destination (action number)
 451   "Decide refile destination."
 452   (wl-summary-get-refile-destination-subr action number t))
 453
 454 (defun wl-summary-exec-action-refile (mark-list)
 455   (save-excursion
 456     (let ((start (point))
 457           (failures 0)
 458           (refile-len (length mark-list))
 459           dst-msgs ; loop counter
 460           result)
 461       ;; begin refile...
 462       (setq dst-msgs
 463             (wl-summary-make-destination-numbers-list mark-list))
 464       (goto-char start) ; avoid moving cursor to the bottom line.
 465       (when (> refile-len elmo-display-progress-threshold)
 466         (elmo-progress-set 'elmo-folder-move-messages
 467                            refile-len "Refiling messages..."))
 468       (while dst-msgs
 469         (setq result nil)
 470         (condition-case nil
 471             (setq result (elmo-folder-move-messages
 472                           wl-summary-buffer-elmo-folder
 473                           (cdr (car dst-msgs))
 474                           (wl-folder-get-elmo-folder (car (car dst-msgs)))))
 475           (error nil))
 476         (if result              ; succeeded.
 477             (progn
 478               ;; update buffer.
 479               (wl-summary-delete-messages-on-buffer (cdr (car dst-msgs)))
 480               (setq wl-summary-buffer-temp-mark-list
 481                     (wl-delete-associations
 482                      (cdr (car dst-msgs))
 483                      wl-summary-buffer-temp-mark-list)))
 484           (setq failures
 485                 (+ failures (length (cdr (car dst-msgs))))))
 486         (setq dst-msgs (cdr dst-msgs)))
 487       (elmo-progress-clear 'elmo-folder-move-messages)
 488       failures)))
 489
 490 ;; Copy action
 491 (defun wl-summary-get-copy-destination (action number)
 492   (wl-summary-get-refile-destination-subr action number nil))
 493
 494 (defun wl-summary-exec-action-copy (mark-list)
 495   (save-excursion
 496     (let ((start (point))
 497           (failures 0)
 498           (refile-len (length mark-list))
 499           dst-msgs ; loop counter
 500           result)
 501       ;; begin refile...
 502       (setq dst-msgs
 503             (wl-summary-make-destination-numbers-list mark-list))
 504       (goto-char start) ; avoid moving cursor to the bottom line.
 505       (when (> refile-len elmo-display-progress-threshold)
 506         (elmo-progress-set 'elmo-folder-move-messages
 507                            refile-len "Copying messages..."))
 508       (while dst-msgs
 509         (setq result nil)
 510         (condition-case nil
 511             (setq result (elmo-folder-move-messages
 512                           wl-summary-buffer-elmo-folder
 513                           (cdr (car dst-msgs))
 514                           (wl-folder-get-elmo-folder (car (car dst-msgs)))
 515                           'no-delete))
 516           (error nil))
 517         (if result              ; succeeded.
 518             (progn
 519               ;; update buffer.
 520               (wl-summary-delete-copy-marks-on-buffer (cdr (car dst-msgs)))
 521               (setq wl-summary-buffer-temp-mark-list
 522                     (wl-delete-associations
 523                      (cdr (car dst-msgs))
 524                      wl-summary-buffer-temp-mark-list)))
 525           (setq failures
 526                 (+ failures (length (cdr (car dst-msgs))))))
 527         (setq dst-msgs (cdr dst-msgs)))
 528       (elmo-progress-clear 'elmo-folder-move-messages)
 529       failures)))
 530
 531 ;; Prefetch.
 532 (defun wl-summary-exec-action-prefetch (mark-list)
 533   (save-excursion
 534     (let* ((count 0)
 535            (length (length mark-list))
 536            (mark-list-copy (copy-sequence mark-list))
 537            (pos (point))
 538            (failures 0))
 539       (dolist (mark-info mark-list-copy)
 540         (message "Prefetching...(%d/%d)"
 541                  (setq count (+ 1 count)) length)
 542         (if (wl-summary-prefetch-msg (car mark-info))
 543             (progn
 544               (wl-summary-unset-mark (car mark-info))
 545               (sit-for 0))
 546           (incf failures)))
 547       (message "Prefetching...done")
 548       0)))
 549
 550 ;; Resend.
 551 (defun wl-summary-get-resend-address (action number)
 552   "Decide resend address."
 553   (completing-read "Resend message to: " 'wl-complete-address))
 554
 555 (defun wl-summary-exec-action-resend (mark-list)
 556   (let ((failure 0))
 557     (dolist (mark-info mark-list)
 558       (if (condition-case nil
 559               (progn
 560                 (wl-summary-exec-action-resend-subr (car mark-info)
 561                                                     (nth 2 mark-info))
 562                 t)
 563             (error))
 564           (wl-summary-unmark (car mark-info))
 565         (incf failure)))
 566     failure))
 567
 568 (defun wl-summary-exec-action-resend-subr (number address)
 569   "Resend the message with NUMBER to ADDRESS."
 570   (message "Resending message to %s..." address)
 571   (let ((folder wl-summary-buffer-elmo-folder))
 572     (save-excursion
 573       ;; We first set up a normal mail buffer.
 574       (set-buffer (get-buffer-create " *wl-draft-resend*"))
 575       (buffer-disable-undo (current-buffer))
 576       (erase-buffer)
 577       (setq wl-sent-message-via nil)
 578       ;; Insert our usual headers.
 579       (wl-draft-insert-from-field)
 580       (wl-draft-insert-date-field)
 581       (insert "To: " address "\n")
 582       (goto-char (point-min))
 583       ;; Rename them all to "Resent-*".
 584       (while (re-search-forward "^[A-Za-z]" nil t)
 585         (forward-char -1)
 586         (insert "Resent-"))
 587       (widen)
 588       (forward-line)
 589       (delete-region (point) (point-max))
 590       (let ((beg (point)))
 591         ;; Insert the message to be resent.
 592         (insert
 593          (with-temp-buffer
 594            (elmo-message-fetch folder number
 595                                (elmo-make-fetch-strategy 'entire)
 596                                nil (current-buffer) 'unread)
 597            (buffer-string)))
 598         (goto-char (point-min))
 599         (search-forward "\n\n")
 600         (forward-char -1)
 601         (save-restriction
 602           (narrow-to-region beg (point))
 603           (wl-draft-delete-fields wl-ignored-resent-headers)
 604           (goto-char (point-max)))
 605         (insert mail-header-separator)
 606         ;; Rename all old ("Previous-")Resent headers.
 607         (while (re-search-backward "^\\(Previous-\\)*Resent-" beg t)
 608           (beginning-of-line)
 609           (insert "Previous-"))
 610         ;; Quote any "From " lines at the beginning.
 611         (goto-char beg)
 612         (when (looking-at "From ")
 613           (replace-match "X-From-Line: ")))
 614       ;; Send it.
 615       (wl-draft-dispatch-message)
 616       (kill-buffer (current-buffer)))
 617     (message "Resending message to %s...done" address)))
 618
 619 ;;;
 620 (defun wl-summary-remove-argument ()
 621   (save-excursion
 622     (let ((inhibit-read-only t)
 623           (buffer-read-only nil)
 624           (buf (current-buffer))
 625           sol eol rs re)
 626       (beginning-of-line)
 627       (setq sol (point))
 628       (search-forward "\r")
 629       (forward-char -1)
 630       (setq eol (point))
 631       (setq rs (next-single-property-change sol 'wl-summary-action-argument
 632                                             buf eol))
 633       (setq re (next-single-property-change rs 'wl-summary-action-argument
 634                                             buf eol))
 635       (put-text-property rs re 'wl-summary-action-argument nil)
 636       (put-text-property rs re 'invisible nil)
 637       (goto-char re)
 638       (delete-char (- eol re)))))
 639
 640 (defun wl-summary-collect-numbers-region (begin end)
 641   "Return a list of message number in the region specified by BEGIN and END."
 642   (save-excursion
 643     (save-restriction
 644       (let (numbers)
 645         (narrow-to-region (or begin (point-min))(or end (point-max)))
 646         (goto-char (point-min))
 647         ;; for thread...
 648         (if (eq wl-summary-buffer-view 'thread)
 649             (let (number entity mark-info)
 650               (while (not (eobp))
 651                 (setq numbers (cons (wl-summary-message-number) numbers)
 652                       entity (wl-thread-get-entity number))
 653                 ;; When thread is closed...children should also be checked.
 654                 (unless (wl-thread-entity-get-opened entity)
 655                   (dolist (msg (wl-thread-get-children-msgs number))
 656                     (setq numbers (cons msg numbers))))
 657                 (forward-line 1)))
 658           (let (number mark-info)
 659             (while (not (eobp))
 660               (setq numbers (cons (wl-summary-message-number) numbers))
 661               (forward-line 1))))
 662         numbers))))
 663
 664 (defun wl-summary-exec (&optional numbers)
 665   (interactive)
 666   (let ((failures 0)
 667         collected pair action modified)
 668     (dolist (action wl-summary-mark-action-list)
 669       (setq collected (cons (cons
 670                              (wl-summary-action-mark action)
 671                              nil) collected)))
 672     (dolist (mark-info wl-summary-buffer-temp-mark-list)
 673       (if numbers
 674           (when (memq (nth 0 mark-info) numbers)
 675             (setq pair (assoc (nth 1 mark-info) collected)))
 676         (setq pair (assoc (nth 1 mark-info) collected)))
 677       (setq pair (assoc (nth 1 mark-info) collected))
 678       (setcdr pair (cons mark-info (cdr pair))))
 679     ;; collected is a pair of
 680     ;; mark-string and a list of mark-info
 681     (dolist (pair collected)
 682       (setq action (assoc (car pair) wl-summary-mark-action-list))
 683       (when (and (cdr pair) (wl-summary-action-exec-function action))
 684         (setq modified t)
 685         (setq failures (+ failures (funcall
 686                                     (wl-summary-action-exec-function action)
 687                                     (cdr pair))))))
 688     (when modified
 689       (wl-summary-set-message-modified))
 690     (run-hooks 'wl-summary-exec-hook)
 691     ;; message buffer is not up-to-date
 692     (unless (and wl-message-buffer
 693                  (eq (wl-summary-message-number)
 694                      (with-current-buffer wl-message-buffer
 695                        wl-message-buffer-cur-number)))
 696       (wl-summary-toggle-disp-msg 'off)
 697       (setq wl-message-buffer nil))
 698     (set-buffer-modified-p nil)
 699     (when (> failures 0)
 700       (format "%d execution(s) were failed" failures))))
 701
 702 (defun wl-summary-exec-region (beg end)
 703   (interactive "r")
 704   (wl-summary-exec
 705    (wl-summary-collect-numbers-region beg end)))
 706
 707 (defun wl-summary-read-folder (default &optional purpose ignore-error
 708                                 no-create init)
 709   (let ((fld (completing-read
 710               (format "Folder name %s(%s): " (or purpose "")
 711                       default)
 712               'wl-folder-complete-folder
 713               nil nil (or init wl-default-spec)
 714               'wl-read-folder-hist)))
 715     (if (or (string= fld wl-default-spec)
 716             (string= fld ""))
 717         (setq fld default))
 718     (setq fld (elmo-string (wl-folder-get-realname fld)))
 719     (if (string-match "\n" fld)
 720         (error "Not supported folder name: %s" fld))
 721     (unless no-create
 722       (if ignore-error
 723           (condition-case nil
 724               (wl-folder-confirm-existence
 725                (wl-folder-get-elmo-folder
 726                 fld))
 727             (error))
 728         (wl-folder-confirm-existence (wl-folder-get-elmo-folder
 729                                       fld))))
 730     fld))
 731
 732 (defun wl-summary-print-argument (msg-num folder)
 733   "Print action argument on line."
 734   (when folder
 735     (wl-summary-remove-argument)
 736     (save-excursion
 737       (let ((inhibit-read-only t)
 738             (folder (copy-sequence folder))
 739             (buffer-read-only nil)
 740             len rs re c)
 741         (setq len (string-width folder))
 742         (if (< len 1) ()
 743           ;;(end-of-line)
 744           (beginning-of-line)
 745           (search-forward "\r")
 746           (forward-char -1)
 747           (setq re (point))
 748           (let ((width (cond (wl-summary-width
 749                               (1- wl-summary-width))
 750                              (wl-summary-print-argument-within-window
 751                               (1- (window-width)))))
 752                 (c (current-column))
 753                 (padding 0))
 754             (if (and width (> (+ c len) width))
 755                 (progn
 756                   (move-to-column width)
 757                   (setq c (current-column))
 758                   (while (> (+ c len) width)
 759                     (forward-char -1)
 760                     (setq c (current-column)))
 761                   (when (< (+ c len) width)
 762                     (setq folder (concat " " folder)))
 763                   (setq rs (point))
 764                   (put-text-property rs re 'invisible t))
 765               (when (and width
 766                          (> (setq padding (- width len c)) 0))
 767                 (setq folder (concat (make-string padding ?\ )
 768                                      folder)))
 769               (setq rs (1- re))))
 770           (put-text-property rs re 'wl-summary-action-argument t)
 771           (goto-char re)
 772           (wl-highlight-action-argument-string folder)
 773           (insert folder)
 774           (set-buffer-modified-p nil))))))
 775
 776 (defsubst wl-summary-reserve-temp-mark-p (mark)
 777   "Return t if temporal MARK should be reserved."
 778   (member mark wl-summary-reserve-mark-list))
 779
 780 (defun wl-summary-refile-prev-destination ()
 781   "Refile message to previously refiled destination."
 782   (interactive)
 783   (funcall (symbol-function 'wl-summary-refile)
 784            wl-summary-buffer-prev-refile-destination)
 785   (if (eq wl-summary-move-direction-downward nil)
 786       (wl-summary-prev)
 787     (wl-summary-next)))
 788
 789 (defsubst wl-summary-no-auto-refile-message-p (number)
 790   (member (elmo-message-mark wl-summary-buffer-elmo-folder number)
 791           wl-summary-auto-refile-skip-marks))
 792
 793 (defun wl-summary-auto-refile (&optional open-all)
 794   "Set refile mark automatically according to 'wl-refile-guess-by-rule'."
 795   (interactive "P")
 796   (message "Marking...")
 797   (save-excursion
 798     (if (and (eq wl-summary-buffer-view 'thread)
 799              open-all)
 800         (wl-thread-open-all))
 801     (let* ((spec (wl-summary-buffer-folder-name))
 802            checked-dsts
 803            (count 0)
 804            number dst thr-entity)
 805       (goto-line 1)
 806       (while (not (eobp))
 807         (setq number (wl-summary-message-number))
 808         (dolist (number (cons number
 809                               (and (eq wl-summary-buffer-view 'thread)
 810                                    ;; process invisible children.
 811                                    (not (wl-thread-entity-get-opened
 812                                          (setq thr-entity
 813                                                (wl-thread-get-entity number))))
 814                                    (wl-thread-entity-get-descendant
 815                                     thr-entity))))
 816           (when (and (not (wl-summary-no-auto-refile-message-p
 817                            number))
 818                      (setq dst
 819                            (wl-folder-get-realname
 820                             (wl-refile-guess-by-rule
 821                              (elmo-message-entity wl-summary-buffer-elmo-folder
 822                                                   number))))
 823                      (not (equal dst spec))
 824                      (let ((pair (assoc dst checked-dsts))
 825                            ret)
 826                        (if pair
 827                            (cdr pair)
 828                          (setq ret
 829                                (condition-case nil
 830                                    (progn
 831                                      (wl-folder-confirm-existence
 832                                       (wl-folder-get-elmo-folder dst))
 833                                      t)
 834                                  (error)))
 835                          (setq checked-dsts (cons (cons dst ret) checked-dsts))
 836                          ret)))
 837             (if (funcall (symbol-function 'wl-summary-refile) number dst)
 838                 (incf count))
 839             (message "Marking...%d message(s)." count)))
 840         (forward-line))
 841       (if (eq count 0)
 842           (message "No message was marked.")
 843         (message "Marked %d message(s)." count)))))
 844
 845 (defun wl-summary-unmark (&optional number)
 846   "Unmark marks (temporary, refile, copy, delete)of current line.
 847 If optional argument NUMBER is specified, unmark message specified by NUMBER."
 848   (interactive)
 849   (wl-summary-unset-mark number (interactive-p)))
 850
 851 (defun wl-summary-unmark-region (beg end)
 852   (interactive "r")
 853   (save-excursion
 854     (save-restriction
 855       (narrow-to-region beg end)
 856       (goto-char (point-min))
 857       (if (eq wl-summary-buffer-view 'thread)
 858           (progn
 859             (while (not (eobp))
 860               (let* ((number (wl-summary-message-number))
 861                      (entity (wl-thread-get-entity number)))
 862                 (if (wl-thread-entity-get-opened entity)
 863                     ;; opened...unmark line.
 864                     (wl-summary-unmark)
 865                   ;; closed
 866                   (wl-summary-delete-marks-on-buffer
 867                    (wl-thread-get-children-msgs number))))
 868               (forward-line 1)))
 869         (while (not (eobp))
 870           (wl-summary-unmark)
 871           (forward-line 1))))))
 872
 873 (defun wl-summary-mark-region-subr (function beg end data)
 874   (save-excursion
 875     (save-restriction
 876       (narrow-to-region beg end)
 877       (goto-char (point-min))
 878       (if (eq wl-summary-buffer-view 'thread)
 879           (progn
 880             (while (not (eobp))
 881               (let* ((number (wl-summary-message-number))
 882                      (entity (wl-thread-get-entity number))
 883                      (wl-summary-move-direction-downward t)
 884                      children)
 885                 (if (wl-thread-entity-get-opened entity)
 886                     ;; opened...delete line.
 887                     (funcall function nil data)
 888                   ;; closed
 889                   (setq children (wl-thread-get-children-msgs number))
 890                   (while children
 891                     (funcall function (pop children) data)))
 892                 (forward-line 1))))
 893         (while (not (eobp))
 894           (funcall function nil data)
 895           (forward-line 1))))))
 896
 897 (defun wl-summary-target-mark-all ()
 898   (interactive)
 899   (wl-summary-target-mark-region (point-min) (point-max))
 900   (setq wl-summary-buffer-target-mark-list
 901         (elmo-folder-list-messages wl-summary-buffer-elmo-folder
 902                                    nil 'in-msgdb)))
 903
 904 (defun wl-summary-delete-all-mark (mark)
 905   (goto-char (point-min))
 906   (while (not (eobp))
 907     (when (string= (wl-summary-temp-mark) mark)
 908       (wl-summary-unmark))
 909     (forward-line 1))
 910   (let (deleted)
 911     (dolist (mark-info wl-summary-buffer-temp-mark-list)
 912       (when (string= (nth 1 mark-info) mark)
 913         (setq deleted (cons mark-info deleted))))
 914     (dolist (delete deleted)
 915       (setq wl-summary-buffer-temp-mark-list
 916             (delq delete wl-summary-buffer-temp-mark-list)))))
 917
 918 (defun wl-summary-unmark-all ()
 919   "Unmark all according to what you input."
 920   (interactive)
 921   (let ((unmarks (string-to-char-list (read-from-minibuffer "Unmark: ")))
 922         cur-mark)
 923     (save-excursion
 924       (while unmarks
 925         (setq cur-mark (char-to-string (car unmarks)))
 926         (wl-summary-delete-all-mark cur-mark)
 927         (setq unmarks (cdr unmarks))))))
 928
 929 (defun wl-summary-target-mark-thread ()
 930   (interactive)
 931   (wl-thread-call-region-func 'wl-summary-target-mark-region t))
 932
 933 (require 'product)
 934 (product-provide (provide 'wl-action) (require 'wl-version))
 935
 936 ;;; wl-action.el ends here