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                           (wl-summary-buffer-msgdb)
 297                           (not (null (cdr dst-msgs)))
 298                           nil ; no-delete
 299                           nil ; same-number
 300                           t))
 301           (error nil))
 302         (when result            ; succeeded.
 303           ;; update buffer.
 304           (wl-summary-delete-messages-on-buffer refiles)
 305           ;; update wl-summary-buffer-temp-mark-list.
 306           (dolist (mark-info mark-list)
 307             (setq wl-summary-buffer-temp-mark-list
 308                   (delq mark-info wl-summary-buffer-temp-mark-list))))
 309         (elmo-progress-clear 'elmo-folder-move-messages)
 310         (message (concat message "done"))
 311         (wl-summary-set-message-modified)
 312         ;; Return the operation failed message numbers.
 313         (if result
 314             0
 315           (length refiles))))))
 316
 317 (defun wl-summary-get-refile-destination-subr (action number learn)
 318   (let* ((number (or number (wl-summary-message-number)))
 319          (msgid (and number
 320                      (elmo-message-field wl-summary-buffer-elmo-folder
 321                                          number 'message-id)))
 322          (entity (and number
 323                       (elmo-message-entity wl-summary-buffer-elmo-folder
 324                                            number)))
 325          folder cur-mark tmp-folder)
 326     (catch 'done
 327       (when (null entity)
 328         (message "Cannot decide destination.")
 329         (throw 'done nil))
 330       (when (null number)
 331         (message "No message.")
 332         (throw 'done nil))
 333       (setq folder (wl-summary-read-folder
 334                     (or (wl-refile-guess entity) wl-trash-folder)
 335                     (format "for %s " action)))
 336       ;; Cache folder hack by okada@opaopa.org
 337       (when (and (eq (elmo-folder-type-internal
 338                       (wl-folder-get-elmo-folder
 339                        (wl-folder-get-realname folder))) 'cache)
 340                  (not (string= folder
 341                                (setq tmp-folder
 342                                      (concat "'cache/"
 343                                              (elmo-cache-get-path-subr
 344                                               (elmo-msgid-to-cache msgid)))))))
 345         (setq folder tmp-folder)
 346         (message "Force refile to %s." folder))
 347       (if (string= folder (wl-summary-buffer-folder-name))
 348           (error "Same folder"))
 349       (if (or (not (elmo-folder-writable-p (wl-folder-get-elmo-folder folder)))
 350               (string= folder wl-queue-folder)
 351               (string= folder wl-draft-folder))
 352           (error "Don't set as target: %s" folder))
 353       ;; learn for refile.
 354       (when learn
 355         (wl-refile-learn entity folder))
 356       folder)))
 357
 358 ;;; Actions
 359 (defun wl-summary-define-mark-action ()
 360   (interactive)
 361   (dolist (action wl-summary-mark-action-list)
 362     (fset (intern (format "wl-summary-%s" (wl-summary-action-symbol action)))
 363           `(lambda (&optional number data)
 364              ,(wl-summary-action-docstring action)
 365              (interactive)
 366              (wl-summary-set-mark ,(wl-summary-action-mark action)
 367                                   number (interactive-p) data)))
 368     (fset (intern (format "wl-summary-%s-region"
 369                           (wl-summary-action-symbol action)))
 370           `(lambda (beg end)
 371              ,(wl-summary-action-docstring action)
 372              (interactive "r")
 373              (save-excursion
 374                (goto-char beg)
 375                (wl-summary-mark-region-subr
 376                 (quote ,(intern (format "wl-summary-%s"
 377                                         (wl-summary-action-symbol action))))
 378                 beg end
 379                 (if (quote ,(wl-summary-action-argument-function action))
 380                     (funcall (function
 381                               ,(wl-summary-action-argument-function action))
 382                              (quote ,(wl-summary-action-symbol action))
 383                              (wl-summary-message-number)))))))
 384     (fset (intern (format "wl-summary-target-mark-%s"
 385                           (wl-summary-action-symbol action)))
 386           `(lambda ()
 387              ,(wl-summary-action-docstring action)
 388              (interactive)
 389              (wl-summary-target-mark-set-action (quote ,action))))
 390     (fset (intern (format "wl-thread-%s"
 391                           (wl-summary-action-symbol action)))
 392           `(lambda (arg)
 393              ,(wl-summary-action-docstring action)
 394              (interactive "P")
 395              (wl-thread-call-region-func
 396               (quote ,(intern (format "wl-summary-%s-region"
 397                                       (wl-summary-action-symbol action))))
 398               arg)
 399              (if arg
 400                  (wl-summary-goto-top-of-current-thread))
 401              (if (not wl-summary-move-direction-downward)
 402                  (wl-summary-prev)
 403                (wl-thread-goto-bottom-of-sub-thread)
 404                (if wl-summary-buffer-disp-msg
 405                    (wl-summary-redisplay)))))))
 406
 407 (defun wl-summary-get-dispose-folder (folder)
 408   (if (string= folder wl-trash-folder)
 409       'null
 410     (let* ((type (or (wl-get-assoc-list-value wl-dispose-folder-alist folder)
 411                      'trash)))
 412       (cond ((stringp type)
 413              type)
 414             ((or (equal type 'remove) (equal type 'null))
 415              'null)
 416             (t;; (equal type 'trash)
 417              (let ((trash-folder (wl-folder-get-elmo-folder wl-trash-folder)))
 418                (unless (elmo-folder-exists-p trash-folder)
 419                  (if (y-or-n-p
 420                       (format "Trash Folder %s does not exist, create it? "
 421                               wl-trash-folder))
 422                      (elmo-folder-create trash-folder)
 423                    (error "Trash Folder is not created"))))
 424              wl-trash-folder)))))
 425
 426 ;; Dispose action.
 427 (defun wl-summary-exec-action-dispose (mark-list)
 428   (wl-summary-move-mark-list-messages mark-list
 429                                       (wl-summary-get-dispose-folder
 430                                        (wl-summary-buffer-folder-name))
 431                                       "Disposing messages..."))
 432
 433 ;; Delete action.
 434 (defun wl-summary-exec-action-delete (mark-list)
 435   (wl-summary-move-mark-list-messages mark-list
 436                                       'null
 437                                       "Deleting messages..."))
 438
 439 ;; Refile action
 440 (defun wl-summary-set-action-refile (number mark data)
 441   (let ((policy (wl-get-assoc-list-value wl-refile-policy-alist
 442                                          (wl-summary-buffer-folder-name)))
 443         (elem wl-summary-mark-action-list))
 444     (if (eq policy 'copy)
 445         (while elem
 446           (when (eq (wl-summary-action-symbol (car elem)) 'copy)
 447             (wl-summary-register-temp-mark number
 448                                            (wl-summary-action-mark (car elem))
 449                                            data)
 450             (setq elem nil))
 451           (setq elem (cdr elem)))
 452       (wl-summary-register-temp-mark number mark data)
 453       (setq wl-summary-buffer-prev-refile-destination data))))
 454
 455 (defun wl-summary-get-refile-destination (action number)
 456   "Decide refile destination."
 457   (wl-summary-get-refile-destination-subr action number t))
 458
 459 (defun wl-summary-exec-action-refile (mark-list)
 460   (save-excursion
 461     (let ((start (point))
 462           (failures 0)
 463           (refile-len (length mark-list))
 464           dst-msgs ; loop counter
 465           result)
 466       ;; begin refile...
 467       (setq dst-msgs
 468             (wl-summary-make-destination-numbers-list mark-list))
 469       (goto-char start) ; avoid moving cursor to the bottom line.
 470       (when (> refile-len elmo-display-progress-threshold)
 471         (elmo-progress-set 'elmo-folder-move-messages
 472                            refile-len "Refiling messages..."))
 473       (while dst-msgs
 474         (setq result nil)
 475         (condition-case nil
 476             (setq result (elmo-folder-move-messages
 477                           wl-summary-buffer-elmo-folder
 478                           (cdr (car dst-msgs))
 479                           (wl-folder-get-elmo-folder
 480                            (car (car dst-msgs)))
 481                           (wl-summary-buffer-msgdb)
 482                           (not (null (cdr dst-msgs)))
 483                           nil ; no-delete
 484                           nil ; same-number
 485                           t))
 486           (error nil))
 487         (if result              ; succeeded.
 488             (progn
 489               ;; update buffer.
 490               (wl-summary-delete-messages-on-buffer (cdr (car dst-msgs)))
 491               (setq wl-summary-buffer-temp-mark-list
 492                     (wl-delete-associations
 493                      (cdr (car dst-msgs))
 494                      wl-summary-buffer-temp-mark-list)))
 495           (setq failures
 496                 (+ failures (length (cdr (car dst-msgs))))))
 497         (setq dst-msgs (cdr dst-msgs)))
 498       (elmo-progress-clear 'elmo-folder-move-messages)
 499       failures)))
 500
 501 ;; Copy action
 502 (defun wl-summary-get-copy-destination (action number)
 503   (wl-summary-get-refile-destination-subr action number nil))
 504
 505 (defun wl-summary-exec-action-copy (mark-list)
 506   (save-excursion
 507     (let ((start (point))
 508           (failures 0)
 509           (refile-len (length mark-list))
 510           dst-msgs ; loop counter
 511           result)
 512       ;; begin refile...
 513       (setq dst-msgs
 514             (wl-summary-make-destination-numbers-list mark-list))
 515       (goto-char start) ; avoid moving cursor to the bottom line.
 516       (when (> refile-len elmo-display-progress-threshold)
 517         (elmo-progress-set 'elmo-folder-move-messages
 518                            refile-len "Copying messages..."))
 519       (while dst-msgs
 520         (setq result nil)
 521         (condition-case nil
 522             (setq result (elmo-folder-move-messages
 523                             wl-summary-buffer-elmo-folder
 524                             (cdr (car dst-msgs))
 525                             (wl-folder-get-elmo-folder
 526                              (car (car dst-msgs)))
 527                             (wl-summary-buffer-msgdb)
 528                             (not (null (cdr dst-msgs)))
 529                             t ; t is no-delete (copy)
 530                             nil ; same-number
 531                             t))
 532           (error nil))
 533         (if result              ; succeeded.
 534             (progn
 535               ;; update buffer.
 536               (wl-summary-delete-copy-marks-on-buffer (cdr (car dst-msgs)))
 537               (setq wl-summary-buffer-temp-mark-list
 538                     (wl-delete-associations
 539                      (cdr (car dst-msgs))
 540                      wl-summary-buffer-temp-mark-list)))
 541           (setq failures
 542                 (+ failures (length (cdr (car dst-msgs))))))
 543         (setq dst-msgs (cdr dst-msgs)))
 544       (elmo-progress-clear 'elmo-folder-move-messages)
 545       failures)))
 546
 547 ;; Prefetch.
 548 (defun wl-summary-exec-action-prefetch (mark-list)
 549   (save-excursion
 550     (let* ((count 0)
 551            (length (length mark-list))
 552            (mark-list-copy (copy-sequence mark-list))
 553            (pos (point))
 554            (failures 0))
 555       (dolist (mark-info mark-list-copy)
 556         (message "Prefetching...(%d/%d)"
 557                  (setq count (+ 1 count)) length)
 558         (if (wl-summary-prefetch-msg (car mark-info))
 559             (progn
 560               (wl-summary-unset-mark (car mark-info))
 561               (sit-for 0))
 562           (incf failures)))
 563       (message "Prefetching...done")
 564       0)))
 565
 566 ;; Resend.
 567 (defun wl-summary-get-resend-address (action number)
 568   "Decide resend address."
 569   (completing-read "Resend message to: " 'wl-complete-address))
 570
 571 (defun wl-summary-exec-action-resend (mark-list)
 572   (let ((failure 0))
 573     (dolist (mark-info mark-list)
 574       (if (condition-case nil
 575               (progn
 576                 (wl-summary-exec-action-resend-subr (car mark-info)
 577                                                     (nth 2 mark-info))
 578                 t)
 579             (error))
 580           (wl-summary-unmark (car mark-info))
 581         (incf failure)))
 582     failure))
 583
 584 (defun wl-summary-exec-action-resend-subr (number address)
 585   "Resend the message with NUMBER to ADDRESS."
 586   (message "Resending message to %s..." address)
 587   (let ((folder wl-summary-buffer-elmo-folder))
 588     (save-excursion
 589       ;; We first set up a normal mail buffer.
 590       (set-buffer (get-buffer-create " *wl-draft-resend*"))
 591       (buffer-disable-undo (current-buffer))
 592       (erase-buffer)
 593       (setq wl-sent-message-via nil)
 594       ;; Insert our usual headers.
 595       (wl-draft-insert-from-field)
 596       (wl-draft-insert-date-field)
 597       (insert "To: " address "\n")
 598       (goto-char (point-min))
 599       ;; Rename them all to "Resent-*".
 600       (while (re-search-forward "^[A-Za-z]" nil t)
 601         (forward-char -1)
 602         (insert "Resent-"))
 603       (widen)
 604       (forward-line)
 605       (delete-region (point) (point-max))
 606       (let ((beg (point)))
 607         ;; Insert the message to be resent.
 608         (insert
 609          (with-temp-buffer
 610            (elmo-message-fetch folder number
 611                                (elmo-make-fetch-strategy 'entire)
 612                                nil (current-buffer) 'unread)
 613            (buffer-string)))
 614         (goto-char (point-min))
 615         (search-forward "\n\n")
 616         (forward-char -1)
 617         (save-restriction
 618           (narrow-to-region beg (point))
 619           (wl-draft-delete-fields wl-ignored-resent-headers)
 620           (goto-char (point-max)))
 621         (insert mail-header-separator)
 622         ;; Rename all old ("Previous-")Resent headers.
 623         (while (re-search-backward "^\\(Previous-\\)*Resent-" beg t)
 624           (beginning-of-line)
 625           (insert "Previous-"))
 626         ;; Quote any "From " lines at the beginning.
 627         (goto-char beg)
 628         (when (looking-at "From ")
 629           (replace-match "X-From-Line: ")))
 630       ;; Send it.
 631       (wl-draft-dispatch-message)
 632       (kill-buffer (current-buffer)))
 633     (message "Resending message to %s...done" address)))
 634
 635 ;;;
 636 (defun wl-summary-remove-argument ()
 637   (save-excursion
 638     (let ((inhibit-read-only t)
 639           (buffer-read-only nil)
 640           (buf (current-buffer))
 641           sol eol rs re)
 642       (beginning-of-line)
 643       (setq sol (point))
 644       (search-forward "\r")
 645       (forward-char -1)
 646       (setq eol (point))
 647       (setq rs (next-single-property-change sol 'wl-summary-action-argument
 648                                             buf eol))
 649       (setq re (next-single-property-change rs 'wl-summary-action-argument
 650                                             buf eol))
 651       (put-text-property rs re 'wl-summary-action-argument nil)
 652       (put-text-property rs re 'invisible nil)
 653       (goto-char re)
 654       (delete-char (- eol re)))))
 655
 656 (defun wl-summary-collect-numbers-region (begin end)
 657   "Return a list of message number in the region specified by BEGIN and END."
 658   (save-excursion
 659     (save-restriction
 660       (let (numbers)
 661         (narrow-to-region (or begin (point-min))(or end (point-max)))
 662         (goto-char (point-min))
 663         ;; for thread...
 664         (if (eq wl-summary-buffer-view 'thread)
 665             (let (number entity mark-info)
 666               (while (not (eobp))
 667                 (setq numbers (cons (wl-summary-message-number) numbers)
 668                       entity (wl-thread-get-entity number))
 669                 ;; When thread is closed...children should also be checked.
 670                 (unless (wl-thread-entity-get-opened entity)
 671                   (dolist (msg (wl-thread-get-children-msgs number))
 672                     (setq numbers (cons msg numbers))))
 673                 (forward-line 1)))
 674           (let (number mark-info)
 675             (while (not (eobp))
 676               (setq numbers (cons (wl-summary-message-number) numbers))
 677               (forward-line 1))))
 678         numbers))))
 679
 680 (defun wl-summary-exec (&optional numbers)
 681   (interactive)
 682   (let ((failures 0)
 683         collected pair action modified)
 684     (dolist (action wl-summary-mark-action-list)
 685       (setq collected (cons (cons
 686                              (wl-summary-action-mark action)
 687                              nil) collected)))
 688     (dolist (mark-info wl-summary-buffer-temp-mark-list)
 689       (if numbers
 690           (when (memq (nth 0 mark-info) numbers)
 691             (setq pair (assoc (nth 1 mark-info) collected)))
 692         (setq pair (assoc (nth 1 mark-info) collected)))
 693       (setq pair (assoc (nth 1 mark-info) collected))
 694       (setcdr pair (cons mark-info (cdr pair))))
 695     ;; collected is a pair of
 696     ;; mark-string and a list of mark-info
 697     (dolist (pair collected)
 698       (setq action (assoc (car pair) wl-summary-mark-action-list))
 699       (when (and (cdr pair) (wl-summary-action-exec-function action))
 700         (setq modified t)
 701         (setq failures (+ failures (funcall
 702                                     (wl-summary-action-exec-function action)
 703                                     (cdr pair))))))
 704     (when modified
 705       (wl-summary-set-message-modified))
 706     (run-hooks 'wl-summary-exec-hook)
 707     ;; message buffer is not up-to-date
 708     (unless (and wl-message-buffer
 709                  (eq (wl-summary-message-number)
 710                      (with-current-buffer wl-message-buffer
 711                        wl-message-buffer-cur-number)))
 712       (wl-summary-toggle-disp-msg 'off)
 713       (setq wl-message-buffer nil))
 714     (set-buffer-modified-p nil)
 715     (when (> failures 0)
 716       (format "%d execution(s) were failed" failures))))
 717
 718 (defun wl-summary-exec-region (beg end)
 719   (interactive "r")
 720   (wl-summary-exec
 721    (wl-summary-collect-numbers-region beg end)))
 722
 723 (defun wl-summary-read-folder (default &optional purpose ignore-error
 724                                 no-create init)
 725   (let ((fld (completing-read
 726               (format "Folder name %s(%s): " (or purpose "")
 727                       default)
 728               'wl-folder-complete-folder
 729               nil nil (or init wl-default-spec)
 730               'wl-read-folder-hist)))
 731     (if (or (string= fld wl-default-spec)
 732             (string= fld ""))
 733         (setq fld default))
 734     (setq fld (elmo-string (wl-folder-get-realname fld)))
 735     (if (string-match "\n" fld)
 736         (error "Not supported folder name: %s" fld))
 737     (unless no-create
 738       (if ignore-error
 739           (condition-case nil
 740               (wl-folder-confirm-existence
 741                (wl-folder-get-elmo-folder
 742                 fld))
 743             (error))
 744         (wl-folder-confirm-existence (wl-folder-get-elmo-folder
 745                                       fld))))
 746     fld))
 747
 748 (defun wl-summary-print-argument (msg-num folder)
 749   "Print action argument on line."
 750   (when folder
 751     (wl-summary-remove-argument)
 752     (save-excursion
 753       (let ((inhibit-read-only t)
 754             (folder (copy-sequence folder))
 755             (buffer-read-only nil)
 756             len rs re c)
 757         (setq len (string-width folder))
 758         (if (< len 1) ()
 759           ;;(end-of-line)
 760           (beginning-of-line)
 761           (search-forward "\r")
 762           (forward-char -1)
 763           (setq re (point))
 764           (let ((width (cond (wl-summary-width
 765                               (1- wl-summary-width))
 766                              (wl-summary-print-argument-within-window
 767                               (1- (window-width)))))
 768                 (c (current-column))
 769                 (padding 0))
 770             (if (and width (> (+ c len) width))
 771                 (progn
 772                   (move-to-column width)
 773                   (setq c (current-column))
 774                   (while (> (+ c len) width)
 775                     (forward-char -1)
 776                     (setq c (current-column)))
 777                   (when (< (+ c len) width)
 778                     (setq folder (concat " " folder)))
 779                   (setq rs (point))
 780                   (put-text-property rs re 'invisible t))
 781               (when (and width
 782                          (> (setq padding (- width len c)) 0))
 783                 (setq folder (concat (make-string padding ?\ )
 784                                      folder)))
 785               (setq rs (1- re))))
 786           (put-text-property rs re 'wl-summary-action-argument t)
 787           (goto-char re)
 788           (wl-highlight-action-argument-string folder)
 789           (insert folder)
 790           (set-buffer-modified-p nil))))))
 791
 792 (defsubst wl-summary-reserve-temp-mark-p (mark)
 793   "Return t if temporal MARK should be reserved."
 794   (member mark wl-summary-reserve-mark-list))
 795
 796 (defun wl-summary-refile-prev-destination ()
 797   "Refile message to previously refiled destination."
 798   (interactive)
 799   (funcall (symbol-function 'wl-summary-refile)
 800            wl-summary-buffer-prev-refile-destination)
 801   (if (eq wl-summary-move-direction-downward nil)
 802       (wl-summary-prev)
 803     (wl-summary-next)))
 804
 805 (defsubst wl-summary-no-auto-refile-message-p (msg)
 806   (member (elmo-msgdb-get-mark (wl-summary-buffer-msgdb) msg)
 807           wl-summary-auto-refile-skip-marks))
 808
 809 (defun wl-summary-auto-refile (&optional open-all)
 810   "Set refile mark automatically according to 'wl-refile-guess-by-rule'."
 811   (interactive "P")
 812   (message "Marking...")
 813   (save-excursion
 814     (if (and (eq wl-summary-buffer-view 'thread)
 815              open-all)
 816         (wl-thread-open-all))
 817     (let* ((spec (wl-summary-buffer-folder-name))
 818            checked-dsts
 819            (count 0)
 820            number dst thr-entity)
 821       (goto-line 1)
 822       (while (not (eobp))
 823         (setq number (wl-summary-message-number))
 824         (dolist (number (cons number
 825                               (and (eq wl-summary-buffer-view 'thread)
 826                                    ;; process invisible children.
 827                                    (not (wl-thread-entity-get-opened
 828                                          (setq thr-entity
 829                                                (wl-thread-get-entity number))))
 830                                    (wl-thread-entity-get-descendant
 831                                     thr-entity))))
 832           (when (and (not (wl-summary-no-auto-refile-message-p
 833                            number))
 834                      (setq dst
 835                            (wl-folder-get-realname
 836                             (wl-refile-guess-by-rule
 837                              (elmo-msgdb-overview-get-entity
 838                               number (wl-summary-buffer-msgdb)))))
 839                      (not (equal dst spec))
 840                      (let ((pair (assoc dst checked-dsts))
 841                            ret)
 842                        (if pair
 843                            (cdr pair)
 844                          (setq ret
 845                                (condition-case nil
 846                                    (progn
 847                                      (wl-folder-confirm-existence
 848                                       (wl-folder-get-elmo-folder dst))
 849                                      t)
 850                                  (error)))
 851                          (setq checked-dsts (cons (cons dst ret) checked-dsts))
 852                          ret)))
 853             (if (funcall (symbol-function 'wl-summary-refile) number dst)
 854                 (incf count))
 855             (message "Marking...%d message(s)." count)))
 856         (forward-line))
 857       (if (eq count 0)
 858           (message "No message was marked.")
 859         (message "Marked %d message(s)." count)))))
 860
 861 (defun wl-summary-unmark (&optional number)
 862   "Unmark marks (temporary, refile, copy, delete)of current line.
 863 If optional argument NUMBER is specified, unmark message specified by NUMBER."
 864   (interactive)
 865   (wl-summary-unset-mark number (interactive-p)))
 866
 867 (defun wl-summary-unmark-region (beg end)
 868   (interactive "r")
 869   (save-excursion
 870     (save-restriction
 871       (narrow-to-region beg end)
 872       (goto-char (point-min))
 873       (if (eq wl-summary-buffer-view 'thread)
 874           (progn
 875             (while (not (eobp))
 876               (let* ((number (wl-summary-message-number))
 877                      (entity (wl-thread-get-entity number)))
 878                 (if (wl-thread-entity-get-opened entity)
 879                     ;; opened...unmark line.
 880                     (wl-summary-unmark)
 881                   ;; closed
 882                   (wl-summary-delete-marks-on-buffer
 883                    (wl-thread-get-children-msgs number))))
 884               (forward-line 1)))
 885         (while (not (eobp))
 886           (wl-summary-unmark)
 887           (forward-line 1))))))
 888
 889 (defun wl-summary-mark-region-subr (function beg end data)
 890   (save-excursion
 891     (save-restriction
 892       (narrow-to-region beg end)
 893       (goto-char (point-min))
 894       (if (eq wl-summary-buffer-view 'thread)
 895           (progn
 896             (while (not (eobp))
 897               (let* ((number (wl-summary-message-number))
 898                      (entity (wl-thread-get-entity number))
 899                      (wl-summary-move-direction-downward t)
 900                      children)
 901                 (if (wl-thread-entity-get-opened entity)
 902                     ;; opened...delete line.
 903                     (funcall function nil data)
 904                   ;; closed
 905                   (setq children (wl-thread-get-children-msgs number))
 906                   (while children
 907                     (funcall function (pop children) data)))
 908                 (forward-line 1))))
 909         (while (not (eobp))
 910           (funcall function nil data)
 911           (forward-line 1))))))
 912
 913 (defun wl-summary-target-mark-all ()
 914   (interactive)
 915   (wl-summary-target-mark-region (point-min) (point-max))
 916   (setq wl-summary-buffer-target-mark-list
 917         (elmo-folder-list-messages wl-summary-buffer-elmo-folder
 918                                    nil 'in-msgdb)))
 919
 920 (defun wl-summary-delete-all-mark (mark)
 921   (goto-char (point-min))
 922   (while (not (eobp))
 923     (when (string= (wl-summary-temp-mark) mark)
 924       (wl-summary-unmark))
 925     (forward-line 1))
 926   (let (deleted)
 927     (dolist (mark-info wl-summary-buffer-temp-mark-list)
 928       (when (string= (nth 1 mark-info) mark)
 929         (setq deleted (cons mark-info deleted))))
 930     (dolist (delete deleted)
 931       (setq wl-summary-buffer-temp-mark-list
 932             (delq delete wl-summary-buffer-temp-mark-list)))))
 933
 934 (defun wl-summary-unmark-all ()
 935   "Unmark all according to what you input."
 936   (interactive)
 937   (let ((unmarks (string-to-char-list (read-from-minibuffer "Unmark: ")))
 938         cur-mark)
 939     (save-excursion
 940       (while unmarks
 941         (setq cur-mark (char-to-string (car unmarks)))
 942         (wl-summary-delete-all-mark cur-mark)
 943         (setq unmarks (cdr unmarks))))))
 944
 945 (defun wl-summary-target-mark-thread ()
 946   (interactive)
 947   (wl-thread-call-region-func 'wl-summary-target-mark-region t))
 948
 949 (require 'product)
 950 (product-provide (provide 'wl-action) (require 'wl-version))
 951
 952 ;;; wl-action.el ends here