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