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             (when (and (eq wl-summary-buffer-view 'thread)
 106                        interactive)
 107               (wl-thread-open-close 'force-open))
 108             ;; Return value.
 109             number))
 110       ;; Move the cursor.
 111       (if (or interactive (interactive-p))
 112           (if (eq wl-summary-move-direction-downward nil)
 113               (wl-summary-prev)
 114             (wl-summary-next))))))
 115
 116 (defun wl-summary-register-target-mark (number mark data)
 117   (or (memq number wl-summary-buffer-target-mark-list)
 118       (setq wl-summary-buffer-target-mark-list
 119             (cons number wl-summary-buffer-target-mark-list))))
 120
 121 (defun wl-summary-unregister-target-mark (number)
 122   (setq wl-summary-buffer-target-mark-list
 123         (delq number wl-summary-buffer-target-mark-list)))
 124
 125 (defun wl-summary-have-target-mark-p (number)
 126   (memq number wl-summary-buffer-target-mark-list))
 127
 128 (defun wl-summary-target-mark-set-action (action)
 129   (unless (eq (wl-summary-action-symbol action) 'target-mark)
 130     (unless wl-summary-buffer-target-mark-list (error "no target"))
 131     (save-excursion
 132       (goto-char (point-min))
 133       (let ((numlist wl-summary-buffer-number-list)
 134             number mlist data)
 135         ;; use firstly marked message.
 136         (when (wl-summary-action-argument-function action)
 137           (while numlist
 138             (if (memq (car numlist) wl-summary-buffer-target-mark-list)
 139                 (setq number (car numlist)
 140                       numlist nil))
 141             (setq numlist (cdr numlist)))
 142           (wl-summary-jump-to-msg number)
 143           (setq data (funcall (wl-summary-action-argument-function action)
 144                               (wl-summary-action-symbol action) number)))
 145         (while (not (eobp))
 146           (when (string= (wl-summary-temp-mark) "*")
 147             (let (wl-summary-buffer-disp-msg)
 148               (when (setq number (wl-summary-message-number))
 149                 (wl-summary-set-mark (wl-summary-action-mark action)
 150                                      nil nil data)
 151                 (setq wl-summary-buffer-target-mark-list
 152                       (delq number wl-summary-buffer-target-mark-list)))))
 153           (forward-line 1))
 154         (setq mlist wl-summary-buffer-target-mark-list)
 155         (while mlist
 156           (wl-summary-register-temp-mark (car mlist)
 157                                          (wl-summary-action-mark action) data)
 158           (setq wl-summary-buffer-target-mark-list
 159                 (delq (car mlist) wl-summary-buffer-target-mark-list))
 160           (setq mlist (cdr mlist)))))))
 161
 162 ;; wl-summary-buffer-temp-mark-list specification
 163 ;; ((1 "D" nil)(2 "o" "+fuga")(3 "O" "+hoge"))
 164 (defun wl-summary-register-temp-mark (number mark mark-info)
 165   (let ((elem (assq number wl-summary-buffer-temp-mark-list)))
 166     (setq wl-summary-buffer-temp-mark-list
 167           (delq elem wl-summary-buffer-temp-mark-list)))
 168   (setq wl-summary-buffer-temp-mark-list
 169         (cons (list number mark mark-info) wl-summary-buffer-temp-mark-list)))
 170
 171 (defun wl-summary-unregister-temp-mark (number)
 172   (let ((elem (assq number wl-summary-buffer-temp-mark-list)))
 173     (setq wl-summary-buffer-temp-mark-list
 174           (delq elem wl-summary-buffer-temp-mark-list))))
 175
 176 (defun wl-summary-registered-temp-mark (number)
 177   (and wl-summary-buffer-temp-mark-list
 178        (assq number wl-summary-buffer-temp-mark-list)))
 179
 180 (defun wl-summary-collect-temp-mark (mark &optional begin end)
 181   (if (or begin end)
 182       (save-excursion
 183         (save-restriction
 184           (let (mark-list)
 185             (narrow-to-region (or begin (point-min))(or end (point-max)))
 186             (goto-char (point-min))
 187             ;; for thread...
 188             (if (eq wl-summary-buffer-view 'thread)
 189                 (let (number entity mark-info)
 190                   (while (not (eobp))
 191                     (setq number (wl-summary-message-number)
 192                           entity (wl-thread-get-entity number)
 193                           mark-info (wl-summary-registered-temp-mark number))
 194                     ;; toplevel message mark.
 195                     (when (string= (nth 1 mark-info) mark)
 196                       (setq mark-list (cons mark-info mark-list)))
 197                     ;; When thread is closed...children should also be checked.
 198                     (unless (wl-thread-entity-get-opened entity)
 199                       (dolist (msg (wl-thread-get-children-msgs number))
 200                         (setq mark-info (wl-summary-registered-temp-mark
 201                                          msg))
 202                         (when (string= (nth 1 mark-info) mark)
 203                           (setq mark-list (cons mark-info mark-list)))))
 204                     (forward-line 1)))
 205               (let (number mark-info)
 206                 (while (not (eobp))
 207                   (setq number (wl-summary-message-number)
 208                         mark-info (wl-summary-registered-temp-mark number))
 209                   (when (string= (nth 1 mark-info) mark)
 210                     (setq mark-list (cons mark-info mark-list)))
 211                   (forward-line 1))))
 212             mark-list)))
 213     (let (mark-list)
 214       (dolist (mark-info wl-summary-buffer-temp-mark-list)
 215         (when (string= (nth 1 mark-info) mark)
 216           (setq mark-list (cons mark-info mark-list))))
 217       mark-list)))
 218
 219 ;; Unset mark
 220 (defun wl-summary-unset-mark (&optional number interactive force)
 221   "Unset temporary mark of the message with NUMBER.
 222 NUMBER is the message number to unset the mark.
 223 If not specified, the message on the cursor position is treated.
 224 Optional INTERACTIVE is non-nil when it should be called interactively.
 225 If optional FORCE is non-nil, remove scored mark too.
 226 Return number if put mark succeed"
 227   (interactive)
 228   (save-excursion
 229     (beginning-of-line)
 230     (let ((buffer-read-only nil)
 231           visible mark action)
 232       (if number
 233           ;; Jump to message
 234           (when (and (setq visible (wl-summary-message-visible-p number))
 235                      (not (eq number (wl-summary-message-number))))
 236             (wl-summary-jump-to-msg number))
 237         (setq visible t
 238               number (wl-summary-message-number)))
 239       (setq mark (wl-summary-temp-mark))
 240       ;; Remove from temporal mark structure.
 241       (wl-summary-unregister-target-mark number)
 242       (wl-summary-unregister-temp-mark number)
 243       ;; Delete mark on buffer.
 244       (when visible
 245         (unless (string= mark " ")
 246           (wl-summary-put-temp-mark
 247            (or (unless force (wl-summary-get-score-mark number))
 248                " "))
 249           (setq action (assoc mark wl-summary-mark-action-list))
 250           (when wl-summary-highlight
 251             (wl-highlight-summary-current-line))
 252           (when (wl-summary-action-argument-function action)
 253             (wl-summary-remove-argument)))
 254         (set-buffer-modified-p nil))))
 255   ;; Move the cursor.
 256   ;;  (if (or interactive (interactive-p))
 257   ;;      (if (eq wl-summary-move-direction-downward nil)
 258   ;;      (wl-summary-prev)
 259   ;;    (wl-summary-next))))
 260   )
 261
 262 (defun wl-summary-make-destination-numbers-list (mark-list)
 263   (let (dest-numbers dest-number)
 264     (dolist (elem mark-list)
 265       (setq dest-number (assoc (nth 2 elem) dest-numbers))
 266       (if dest-number
 267           (unless (memq (car elem) (cdr dest-number))
 268             (nconc dest-number (list (car elem))))
 269         (setq dest-numbers (nconc dest-numbers
 270                                   (list
 271                                    (list (nth 2 elem)
 272                                          (car elem)))))))
 273     dest-numbers))
 274
 275 (defun wl-summary-move-mark-list-messages (mark-list folder-name message)
 276   (if (null mark-list)
 277       (message "No marks")
 278     (save-excursion
 279       (let ((start (point))
 280             (refiles (mapcar 'car mark-list))
 281             (refile-failures 0)
 282             refile-len
 283             dst-msgs                    ; loop counter
 284             result)
 285         ;; begin refile...
 286         (setq refile-len (length refiles))
 287         (goto-char start)               ; avoid moving cursor to
 288                                         ; the bottom line.
 289         (message message)
 290         (when (> refile-len elmo-display-progress-threshold)
 291           (elmo-progress-set 'elmo-folder-move-messages
 292                              refile-len message))
 293         (setq result nil)
 294         (condition-case nil
 295             (setq result (elmo-folder-move-messages
 296                           wl-summary-buffer-elmo-folder
 297                           refiles
 298                           (if (eq folder-name 'null)
 299                               'null
 300                             (wl-folder-get-elmo-folder folder-name))))
 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   (when (null data)
 442     (error "Destination folder is empty"))
 443   (wl-summary-register-temp-mark number mark data)
 444   (setq wl-summary-buffer-prev-refile-destination data))
 445
 446 (defun wl-summary-get-refile-destination (action number)
 447   "Decide refile destination."
 448   (wl-summary-get-refile-destination-subr action number t))
 449
 450 (defun wl-summary-exec-action-refile (mark-list)
 451   (save-excursion
 452     (let ((start (point))
 453           (failures 0)
 454           (refile-len (length mark-list))
 455           dst-msgs)
 456       ;; begin refile...
 457       (setq dst-msgs (wl-summary-make-destination-numbers-list mark-list))
 458       (goto-char start) ; avoid moving cursor to the bottom line.
 459       (when (> refile-len elmo-display-progress-threshold)
 460         (elmo-progress-set 'elmo-folder-move-messages
 461                            refile-len "Refiling messages..."))
 462       (dolist (pair dst-msgs)
 463         (if (condition-case nil
 464                 (elmo-folder-move-messages
 465                  wl-summary-buffer-elmo-folder
 466                  (cdr pair)
 467                  (wl-folder-get-elmo-folder (car pair)))
 468               (error nil))
 469             (progn
 470               ;; update buffer.
 471               (wl-summary-delete-messages-on-buffer (cdr pair))
 472               (setq wl-summary-buffer-temp-mark-list
 473                     (wl-delete-associations
 474                      (cdr pair)
 475                      wl-summary-buffer-temp-mark-list)))
 476           (setq failures (+ failures (length (cdr pair))))))
 477       (elmo-progress-clear 'elmo-folder-move-messages)
 478       (if (<= failures 0)
 479           (message "Refiling messages...done"))
 480       failures)))
 481
 482 ;; Copy action
 483 (defun wl-summary-get-copy-destination (action number)
 484   (wl-summary-get-refile-destination-subr action number nil))
 485
 486 (defun wl-summary-exec-action-copy (mark-list)
 487   (save-excursion
 488     (let ((start (point))
 489           (failures 0)
 490           (refile-len (length mark-list))
 491           dst-msgs)
 492       ;; begin refile...
 493       (setq dst-msgs
 494             (wl-summary-make-destination-numbers-list mark-list))
 495       (goto-char start) ; avoid moving cursor to the bottom line.
 496       (when (> refile-len elmo-display-progress-threshold)
 497         (elmo-progress-set 'elmo-folder-move-messages
 498                            refile-len "Copying messages..."))
 499       (dolist (pair dst-msgs)
 500         (if (condition-case nil
 501                 (elmo-folder-move-messages
 502                  wl-summary-buffer-elmo-folder
 503                  (cdr pair)
 504                  (wl-folder-get-elmo-folder (car pair))
 505                  'no-delete)
 506               (error nil))
 507             (progn
 508               ;; update buffer.
 509               (wl-summary-delete-copy-marks-on-buffer (cdr pair))
 510               (setq wl-summary-buffer-temp-mark-list
 511                     (wl-delete-associations
 512                      (cdr pair)
 513                      wl-summary-buffer-temp-mark-list)))
 514           (setq failures (+ failures (length (cdr pair))))))
 515       (elmo-progress-clear 'elmo-folder-move-messages)
 516       (if (<= failures 0)
 517           (message "Copying messages...done"))
 518       failures)))
 519
 520 ;; Prefetch.
 521 (defun wl-summary-exec-action-prefetch (mark-list)
 522   (save-excursion
 523     (let* ((count 0)
 524            (length (length mark-list))
 525            (mark-list-copy (copy-sequence mark-list))
 526            (pos (point))
 527            (failures 0))
 528       (dolist (mark-info mark-list-copy)
 529         (message "Prefetching...(%d/%d)"
 530                  (setq count (+ 1 count)) length)
 531         (if (wl-summary-prefetch-msg (car mark-info))
 532             (progn
 533               (wl-summary-unset-mark (car mark-info))
 534               (sit-for 0))
 535           (incf failures)))
 536       (message "Prefetching...done")
 537       0)))
 538
 539 ;; Resend.
 540 (defun wl-summary-get-resend-address (action number)
 541   "Decide resend address."
 542   (wl-address-read-from-minibuffer "Resend message to: "))
 543
 544 (defun wl-summary-exec-action-resend (mark-list)
 545   (let ((failure 0))
 546     (dolist (mark-info mark-list)
 547       (if (condition-case nil
 548               (progn
 549                 (wl-summary-exec-action-resend-subr (car mark-info)
 550                                                     (nth 2 mark-info))
 551                 t)
 552             (error))
 553           (wl-summary-unmark (car mark-info))
 554         (incf failure)))
 555     failure))
 556
 557 (defun wl-summary-exec-action-resend-subr (number address)
 558   "Resend the message with NUMBER to ADDRESS."
 559   (message "Resending message to %s..." address)
 560   (let ((folder wl-summary-buffer-elmo-folder))
 561     (save-excursion
 562       ;; We first set up a normal mail buffer.
 563       (set-buffer (get-buffer-create " *wl-draft-resend*"))
 564       (set-buffer-multibyte nil)
 565       (erase-buffer)
 566       (setq wl-sent-message-via nil)
 567       ;; Insert our usual headers.
 568       (wl-draft-insert-from-field)
 569       (wl-draft-insert-date-field)
 570       (insert "To: " address "\n")
 571       (goto-char (point-min))
 572       ;; Rename them all to "Resent-*".
 573       (while (re-search-forward "^[A-Za-z]" nil t)
 574         (forward-char -1)
 575         (insert "Resent-"))
 576       (widen)
 577       (forward-line)
 578       (delete-region (point) (point-max))
 579       (let ((beg (point)))
 580         ;; Insert the message to be resent.
 581         (insert
 582          ;; elmo-message-fetch is erase current buffer before fetch message
 583          (elmo-message-fetch-string folder number
 584                                     (if wl-summary-resend-use-cache
 585                                         (elmo-make-fetch-strategy
 586                                          'entire 'maybe nil
 587                                          (elmo-file-cache-get-path
 588                                           (elmo-message-field
 589                                            folder number 'message-id)))
 590                                       (elmo-make-fetch-strategy 'entire))
 591                                     'unread))
 592         (goto-char (point-min))
 593         (search-forward "\n\n")
 594         (forward-char -1)
 595         (save-restriction
 596           (narrow-to-region beg (point))
 597           (wl-draft-delete-fields wl-ignored-resent-headers)
 598           (goto-char (point-max)))
 599         (insert mail-header-separator)
 600         ;; Rename all old ("Previous-")Resent headers.
 601         (while (re-search-backward "^\\(Previous-\\)*Resent-" beg t)
 602           (beginning-of-line)
 603           (insert "Previous-"))
 604         ;; Quote any "From " lines at the beginning.
 605         (goto-char beg)
 606         (when (looking-at "From ")
 607           (replace-match "X-From-Line: ")))
 608       (run-hooks 'wl-summary-resend-hook)
 609       ;; Send it.
 610       (wl-draft-dispatch-message)
 611       (kill-buffer (current-buffer)))
 612     (message "Resending message to %s...done" address)))
 613
 614 ;;;
 615 (defun wl-summary-remove-argument ()
 616   (save-excursion
 617     (let ((inhibit-read-only t)
 618           (buffer-read-only nil)
 619           (buf (current-buffer))
 620           sol eol rs re)
 621       (beginning-of-line)
 622       (setq sol (point))
 623       (search-forward "\r")
 624       (forward-char -1)
 625       (setq eol (point))
 626       (setq rs (next-single-property-change sol 'wl-summary-action-argument
 627                                             buf eol))
 628       (setq re (next-single-property-change rs 'wl-summary-action-argument
 629                                             buf eol))
 630       (put-text-property rs re 'wl-summary-action-argument nil)
 631       (put-text-property rs re 'invisible nil)
 632       (goto-char re)
 633       (delete-char (- eol re)))))
 634
 635 (defun wl-summary-collect-numbers-region (begin end)
 636   "Return a list of message number in the region specified by BEGIN and END."
 637   (save-excursion
 638     (save-restriction
 639       (let (numbers)
 640         (wl-summary-narrow-to-region (or begin (point-min))(or end (point-max)))
 641         (goto-char (point-min))
 642         ;; for thread...
 643         (if (eq wl-summary-buffer-view 'thread)
 644             (let (number entity)
 645               (while (not (eobp))
 646                 (setq numbers (cons (wl-summary-message-number) numbers)
 647                       entity (wl-thread-get-entity number))
 648                 ;; When thread is closed...children should also be checked.
 649                 (unless (wl-thread-entity-get-opened entity)
 650                   (dolist (msg (wl-thread-get-children-msgs number))
 651                     (setq numbers (cons msg numbers))))
 652                 (forward-line 1)))
 653           (let (number)
 654             (while (not (eobp))
 655               (setq numbers (cons (wl-summary-message-number) numbers))
 656               (forward-line 1))))
 657         (nreverse (delq nil numbers))))))
 658
 659 (defun wl-summary-exec (&optional numbers)
 660   (interactive)
 661   (let ((failures 0)
 662         collected pair action modified)
 663     (dolist (action wl-summary-mark-action-list)
 664       (setq collected (cons (cons
 665                              (wl-summary-action-mark action)
 666                              nil) collected)))
 667     (dolist (mark-info wl-summary-buffer-temp-mark-list)
 668       (setq pair
 669             (when (or (null numbers)
 670                       (memq (nth 0 mark-info) numbers))
 671               (assoc (nth 1 mark-info) collected)))
 672       (if pair
 673           (setcdr pair (cons mark-info (cdr pair)))))
 674     ;; collected is a pair of
 675     ;; mark-string and a list of mark-info
 676     (dolist (pair collected)
 677       (when (cdr pair)
 678         (setq action (assoc (car pair) wl-summary-mark-action-list))
 679         (when (wl-summary-action-exec-function action)
 680           (setq modified t)
 681           (setq failures (+ failures (funcall
 682                                       (wl-summary-action-exec-function action)
 683                                       (cdr pair)))))))
 684     (when modified
 685       (wl-summary-set-message-modified))
 686     (run-hooks 'wl-summary-exec-hook)
 687     ;; message buffer is not up-to-date
 688     (unless (and wl-message-buffer
 689                  (eq (wl-summary-message-number)
 690                      (with-current-buffer wl-message-buffer
 691                        wl-message-buffer-cur-number)))
 692       (wl-summary-toggle-disp-msg 'off)
 693       (setq wl-message-buffer nil))
 694     (set-buffer-modified-p nil)
 695     (when (> failures 0)
 696       (message "%d execution(s) were failed" failures))))
 697
 698 (defun wl-summary-exec-region (beg end)
 699   (interactive "r")
 700   (wl-summary-exec
 701    (wl-summary-collect-numbers-region beg end)))
 702
 703 (defun wl-summary-read-folder (default &optional purpose ignore-error
 704                                 no-create init)
 705   (let ((fld (completing-read
 706               (format "Folder name %s(%s): " (or purpose "")
 707                       default)
 708               'wl-folder-complete-folder
 709               nil nil (or init wl-default-spec)
 710               'wl-read-folder-history)))
 711     (if (or (string= fld wl-default-spec)
 712             (string= fld ""))
 713         (setq fld default))
 714     (setq fld (elmo-string (wl-folder-get-realname fld)))
 715     (if (string-match "\n" fld)
 716         (error "Not supported folder name: %s" fld))
 717     (unless no-create
 718       (if ignore-error
 719           (condition-case nil
 720               (wl-folder-confirm-existence
 721                (wl-folder-get-elmo-folder
 722                 fld))
 723             (error))
 724         (wl-folder-confirm-existence (wl-folder-get-elmo-folder
 725                                       fld))))
 726     fld))
 727
 728 (defun wl-summary-print-argument (msg-num data)
 729   "Print action argument on line."
 730   (when data
 731     (wl-summary-remove-argument)
 732     (save-excursion
 733       (let ((inhibit-read-only t)
 734             (data (copy-sequence data))
 735             (buffer-read-only nil)
 736             len rs re c)
 737         (setq len (string-width data))
 738         (if (< len 1) ()
 739           ;;(end-of-line)
 740           (beginning-of-line)
 741           (search-forward "\r")
 742           (forward-char -1)
 743           (setq re (point))
 744           (let ((width (cond (wl-summary-width
 745                               (1- wl-summary-width))
 746                              (wl-summary-print-argument-within-window
 747                               (1- (window-width)))))
 748                 (c (current-column))
 749                 (padding 0))
 750             (if (and width
 751                      (> (+ c len) width))
 752                 (progn
 753                   (move-to-column width)
 754                   (setq c (current-column))
 755                   (while (> (+ c len) width)
 756                     (forward-char -1)
 757                     (setq c (current-column)))
 758                   (when (< (+ c len) width)
 759                     (setq data (concat " " data)))
 760                   (setq rs (point))
 761                   (put-text-property rs re 'invisible t))
 762               (when (and width
 763                          (> (setq padding (- width len c)) 0))
 764                 (setq data (concat (make-string padding ?\ ) data)))
 765               (setq rs (1- re))))
 766           (put-text-property rs re 'wl-summary-action-argument t)
 767           (goto-char re)
 768           (wl-highlight-action-argument-string data)
 769           (insert data)
 770           (set-buffer-modified-p nil))))))
 771
 772 (defsubst wl-summary-reserve-temp-mark-p (mark)
 773   "Return t if temporal MARK should be reserved."
 774   (member mark wl-summary-reserve-mark-list))
 775
 776 ;; Refile prev destination
 777 (defun wl-summary-refile-prev-destination ()
 778   "Refile message to previously refiled destination."
 779   (interactive)
 780   (funcall (symbol-function 'wl-summary-refile)
 781            (wl-summary-message-number)
 782            wl-summary-buffer-prev-refile-destination)
 783   (if (and (interactive-p)
 784            (eq wl-summary-move-direction-downward nil))
 785       (wl-summary-prev)
 786     (wl-summary-next)))
 787
 788 (defun wl-summary-refile-prev-destination-region (beg end)
 789   "Refile messages in the region to previously refiled destination."
 790   (interactive "r")
 791   (wl-summary-mark-region-subr 'wl-summary-refile
 792                                beg end
 793                                wl-summary-buffer-prev-refile-destination))
 794
 795 (defun wl-thread-refile-prev-destination (arg)
 796   "Refile messages in the thread to previously refiled destination."
 797   (interactive "P")
 798   (wl-thread-call-region-func
 799    'wl-summary-refile-prev-destination-region
 800    arg))
 801
 802 (defun wl-summary-target-mark-refile-prev-destination ()
 803   "Refile messages with target mark to previously refiled destination."
 804   (interactive)
 805   (let ((elem wl-summary-mark-action-list)
 806         action)
 807     (while elem
 808       (when (eq (wl-summary-action-symbol (car elem)) 'refile)
 809         (setq action (car elem))
 810         (setq elem nil))
 811       (setq elem (cdr elem)))
 812     (wl-summary-target-mark-set-action
 813      (list
 814       (car action)
 815       'refile-prev-destination
 816       (lambda (&rest args) wl-summary-buffer-prev-refile-destination)
 817       (nth 2 action)
 818       (nth 3 action)
 819       (nth 4 action)
 820       (nth 6 action)))))
 821
 822 (defsubst wl-summary-no-auto-refile-message-p (number)
 823   (member (wl-summary-message-mark wl-summary-buffer-elmo-folder number)
 824           wl-summary-auto-refile-skip-marks))
 825
 826 (defvar wl-auto-refile-guess-functions
 827   '(wl-refile-guess-by-rule)
 828   "*List of functions which is used for guessing refile destination folder.")
 829
 830 (defun wl-summary-auto-refile (&optional open-all)
 831   "Set refile mark automatically according to 'wl-refile-guess-by-rule'."
 832   (interactive "P")
 833   (message "Marking...")
 834   (save-excursion
 835     (if (and (eq wl-summary-buffer-view 'thread)
 836              open-all)
 837         (wl-thread-open-all))
 838     (let* ((spec (wl-summary-buffer-folder-name))
 839            checked-dsts
 840            (count 0)
 841            number dst thr-entity)
 842       (goto-line 1)
 843       (while (not (eobp))
 844         (setq number (wl-summary-message-number))
 845         (dolist (number (cons number
 846                               (and (eq wl-summary-buffer-view 'thread)
 847                                    ;; process invisible children.
 848                                    (not (wl-thread-entity-get-opened
 849                                          (setq thr-entity
 850                                                (wl-thread-get-entity number))))
 851                                    (wl-thread-entity-get-descendant
 852                                     thr-entity))))
 853           (when (and (not (wl-summary-no-auto-refile-message-p number))
 854                      (not (wl-summary-reserve-temp-mark-p
 855                            (nth 1 (wl-summary-registered-temp-mark number))))
 856                      (setq dst
 857                            (wl-folder-get-realname
 858                             (wl-refile-guess
 859                              (elmo-message-entity wl-summary-buffer-elmo-folder
 860                                                   number)
 861                              wl-auto-refile-guess-functions)))
 862                      (not (equal dst spec))
 863                      (let ((pair (assoc dst checked-dsts))
 864                            ret)
 865                        (if pair
 866                            (cdr pair)
 867                          (setq ret
 868                                (condition-case nil
 869                                    (progn
 870                                      (wl-folder-confirm-existence
 871                                       (wl-folder-get-elmo-folder dst))
 872                                      t)
 873                                  (error)))
 874                          (setq checked-dsts (cons (cons dst ret) checked-dsts))
 875                          ret)))
 876             (if (funcall (symbol-function 'wl-summary-refile) number dst)
 877                 (incf count))
 878             (message "Marking...%d message(s)." count)))
 879         (forward-line))
 880       (if (eq count 0)
 881           (message "No message was marked.")
 882         (message "Marked %d message(s)." count)))))
 883
 884 (defun wl-summary-unmark (&optional number)
 885   "Unmark marks (temporary, refile, copy, delete)of current line.
 886 If optional argument NUMBER is specified, unmark message specified by NUMBER."
 887   (interactive)
 888   (wl-summary-unset-mark number (interactive-p)))
 889
 890 (defun wl-summary-unmark-region (beg end)
 891   (interactive "r")
 892   (save-excursion
 893     (save-restriction
 894       (wl-summary-narrow-to-region beg end)
 895       (goto-char (point-min))
 896       (if (eq wl-summary-buffer-view 'thread)
 897           (progn
 898             (while (not (eobp))
 899               (let* ((number (wl-summary-message-number))
 900                      (entity (wl-thread-get-entity number)))
 901                 (if (wl-thread-entity-get-opened entity)
 902                     ;; opened...unmark line.
 903                     (wl-summary-unmark)
 904                   ;; closed
 905                   (wl-summary-delete-marks-on-buffer
 906                    (wl-thread-get-children-msgs number))))
 907               (forward-line 1)))
 908         (while (not (eobp))
 909           (wl-summary-unmark)
 910           (forward-line 1))))))
 911
 912 (defun wl-summary-mark-region-subr (function beg end data)
 913   (save-excursion
 914     (save-restriction
 915       (wl-summary-narrow-to-region beg end)
 916       (goto-char (point-min))
 917       (if (eq wl-summary-buffer-view 'thread)
 918           (progn
 919             (while (not (eobp))
 920               (let* ((number (wl-summary-message-number))
 921                      (entity (wl-thread-get-entity number))
 922                      (wl-summary-move-direction-downward t)
 923                      children)
 924                 (if (wl-thread-entity-get-opened entity)
 925                     ;; opened...delete line.
 926                     (funcall function nil data)
 927                   ;; closed
 928                   (setq children (wl-thread-get-children-msgs number))
 929                   (while children
 930                     (funcall function (pop children) data)))
 931                 (forward-line 1))))
 932         (while (not (eobp))
 933           (funcall function nil data)
 934           (forward-line 1))))))
 935
 936 (defun wl-summary-target-mark-all ()
 937   (interactive)
 938   (wl-summary-target-mark-region (point-min) (point-max)))
 939
 940 (defun wl-summary-delete-all-mark (mark)
 941   (goto-char (point-min))
 942   (while (not (eobp))
 943     (when (string= (wl-summary-temp-mark) mark)
 944       (wl-summary-unmark))
 945     (forward-line 1))
 946   (if (string= mark "*")
 947       (setq wl-summary-buffer-target-mark-list nil)
 948     (let (deleted)
 949       (dolist (mark-info wl-summary-buffer-temp-mark-list)
 950         (when (string= (nth 1 mark-info) mark)
 951           (setq deleted (cons mark-info deleted))))
 952       (dolist (delete deleted)
 953         (setq wl-summary-buffer-temp-mark-list
 954               (delq delete wl-summary-buffer-temp-mark-list))))))
 955
 956 (defun wl-summary-unmark-all ()
 957   "Unmark all according to what you input."
 958   (interactive)
 959   (let ((unmarks (string-to-char-list (read-from-minibuffer "Unmark: ")))
 960         cur-mark)
 961     (save-excursion
 962       (while unmarks
 963         (setq cur-mark (char-to-string (car unmarks)))
 964         (wl-summary-delete-all-mark cur-mark)
 965         (setq unmarks (cdr unmarks))))))
 966
 967 (defun wl-summary-target-mark-thread ()
 968   (interactive)
 969   (wl-thread-call-region-func 'wl-summary-target-mark-region t))
 970
 971 (require 'product)
 972 (product-provide (provide 'wl-action) (require 'wl-version))
 973
 974 ;;; wl-action.el ends here