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