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