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