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