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           (setq visible (or
  73                          ;; not-interactive and visible
  74                          (and number (wl-summary-jump-to-msg number))
  75                          ;; interactive
  76                          (and (null number) current))
  77                 number (or number current)
  78                 cur-mark (nth 1 (wl-summary-registered-temp-mark number)))
  79           (unless number
  80             (error "No message"))
  81           (if (wl-summary-reserve-temp-mark-p cur-mark)
  82               (when interactive
  83                 (error "Already marked as `%s'" cur-mark))
  84             (when (and interactive
  85                        (null data)
  86                        (wl-summary-action-argument-function action))
  87               (setq data (funcall (wl-summary-action-argument-function action)
  88                                   (wl-summary-action-symbol action)
  89                                   number)))
  90             (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* ((count 0)
 545            (length (length mark-list))
 546            (mark-list-copy (copy-sequence mark-list))
 547            (pos (point))
 548            (failures 0))
 549       (dolist (mark-info mark-list-copy)
 550         (message "Prefetching...(%d/%d)"
 551                  (setq count (+ 1 count)) length)
 552         (if (wl-summary-prefetch-msg (car mark-info))
 553             (progn
 554               (wl-summary-unset-mark (car mark-info))
 555               (sit-for 0))
 556           (incf failures)))
 557       (message "Prefetching...done")
 558       0)))
 559
 560 ;; Resend.
 561 (defun wl-summary-get-resend-address (action number)
 562   "Decide resend address."
 563   (completing-read "Resend message to: " 'wl-complete-address))
 564
 565 (defun wl-summary-exec-action-resend (mark-list)
 566   (let ((failure 0))
 567     (dolist (mark-info mark-list)
 568       (if (condition-case nil
 569               (progn
 570                 (wl-summary-exec-action-resend-subr (car mark-info)
 571                                                     (nth 2 mark-info))
 572                 t)
 573             (error))
 574           (wl-summary-unmark (car mark-info))
 575         (incf failure)))
 576     failure))
 577
 578 (defun wl-summary-exec-action-resend-subr (number address)
 579   "Resend the message with NUMBER to ADDRESS."
 580   (message "Resending message to %s..." address)
 581   (let ((folder wl-summary-buffer-elmo-folder))
 582     (save-excursion
 583       ;; We first set up a normal mail buffer.
 584       (set-buffer (get-buffer-create " *wl-draft-resend*"))
 585       (buffer-disable-undo (current-buffer))
 586       (erase-buffer)
 587       (setq wl-sent-message-via nil)
 588       ;; Insert our usual headers.
 589       (wl-draft-insert-from-field)
 590       (wl-draft-insert-date-field)
 591       (insert "To: " address "\n")
 592       (goto-char (point-min))
 593       ;; Rename them all to "Resent-*".
 594       (while (re-search-forward "^[A-Za-z]" nil t)
 595         (forward-char -1)
 596         (insert "Resent-"))
 597       (widen)
 598       (forward-line)
 599       (delete-region (point) (point-max))
 600       (let ((beg (point)))
 601         ;; Insert the message to be resent.
 602         (insert
 603          (with-temp-buffer
 604            (elmo-message-fetch folder number
 605                                (elmo-make-fetch-strategy 'entire)
 606                                nil (current-buffer) 'unread)
 607            (buffer-string)))
 608         (goto-char (point-min))
 609         (search-forward "\n\n")
 610         (forward-char -1)
 611         (save-restriction
 612           (narrow-to-region beg (point))
 613           (wl-draft-delete-fields wl-ignored-resent-headers)
 614           (goto-char (point-max)))
 615         (insert mail-header-separator)
 616         ;; Rename all old ("Previous-")Resent headers.
 617         (while (re-search-backward "^\\(Previous-\\)*Resent-" beg t)
 618           (beginning-of-line)
 619           (insert "Previous-"))
 620         ;; Quote any "From " lines at the beginning.
 621         (goto-char beg)
 622         (when (looking-at "From ")
 623           (replace-match "X-From-Line: ")))
 624       ;; Send it.
 625       (wl-draft-dispatch-message)
 626       (kill-buffer (current-buffer)))
 627     (message "Resending message to %s...done" address)))
 628
 629 ;;;
 630 (defun wl-summary-remove-argument ()
 631   (save-excursion
 632     (let ((inhibit-read-only t)
 633           (buffer-read-only nil)
 634           (buf (current-buffer))
 635           sol eol rs re)
 636       (beginning-of-line)
 637       (setq sol (point))
 638       (search-forward "\r")
 639       (forward-char -1)
 640       (setq eol (point))
 641       (setq rs (next-single-property-change sol 'wl-summary-action-argument
 642                                             buf eol))
 643       (setq re (next-single-property-change rs 'wl-summary-action-argument
 644                                             buf eol))
 645       (put-text-property rs re 'wl-summary-action-argument nil)
 646       (put-text-property rs re 'invisible nil)
 647       (goto-char re)
 648       (delete-char (- eol re)))))
 649
 650 (defun wl-summary-collect-numbers-region (begin end)
 651   "Return a list of message number in the region specified by BEGIN and END."
 652   (save-excursion
 653     (save-restriction
 654       (let (numbers)
 655         (narrow-to-region (or begin (point-min))(or end (point-max)))
 656         (goto-char (point-min))
 657         ;; for thread...
 658         (if (eq wl-summary-buffer-view 'thread)
 659             (let (number entity mark-info)
 660               (while (not (eobp))
 661                 (setq numbers (cons (wl-summary-message-number) numbers)
 662                       entity (wl-thread-get-entity number))
 663                 ;; When thread is closed...children should also be checked.
 664                 (unless (wl-thread-entity-get-opened entity)
 665                   (dolist (msg (wl-thread-get-children-msgs number))
 666                     (setq numbers (cons msg numbers))))
 667                 (forward-line 1)))
 668           (let (number mark-info)
 669             (while (not (eobp))
 670               (setq numbers (cons (wl-summary-message-number) numbers))
 671               (forward-line 1))))
 672         numbers))))
 673
 674 (defun wl-summary-exec (&optional numbers)
 675   (interactive)
 676   (let ((failures 0)
 677         collected pair action modified)
 678     (dolist (action wl-summary-mark-action-list)
 679       (setq collected (cons (cons
 680                              (wl-summary-action-mark action)
 681                              nil) collected)))
 682     (dolist (mark-info wl-summary-buffer-temp-mark-list)
 683       (if numbers
 684           (when (memq (nth 0 mark-info) numbers)
 685             (setq pair (assoc (nth 1 mark-info) collected)))
 686         (setq pair (assoc (nth 1 mark-info) collected)))
 687       (setq pair (assoc (nth 1 mark-info) collected))
 688       (setcdr pair (cons mark-info (cdr pair))))
 689     ;; collected is a pair of
 690     ;; mark-string and a list of mark-info
 691     (dolist (pair collected)
 692       (setq action (assoc (car pair) wl-summary-mark-action-list))
 693       (when (and (cdr pair) (wl-summary-action-exec-function action))
 694         (setq modified t)
 695         (setq failures (+ failures (funcall
 696                                     (wl-summary-action-exec-function action)
 697                                     (cdr pair))))))
 698     (when modified
 699       (wl-summary-set-message-modified))
 700     (run-hooks 'wl-summary-exec-hook)
 701     ;; message buffer is not up-to-date
 702     (unless (and wl-message-buffer
 703                  (eq (wl-summary-message-number)
 704                      (with-current-buffer wl-message-buffer
 705                        wl-message-buffer-cur-number)))
 706       (wl-summary-toggle-disp-msg 'off)
 707       (setq wl-message-buffer nil))
 708     (set-buffer-modified-p nil)
 709     (when (> failures 0)
 710       (format "%d execution(s) were failed" failures))))
 711
 712 (defun wl-summary-exec-region (beg end)
 713   (interactive "r")
 714   (wl-summary-exec
 715    (wl-summary-collect-numbers-region beg end)))
 716
 717 (defun wl-summary-read-folder (default &optional purpose ignore-error
 718                                 no-create init)
 719   (let ((fld (completing-read
 720               (format "Folder name %s(%s): " (or purpose "")
 721                       default)
 722               'wl-folder-complete-folder
 723               nil nil (or init wl-default-spec)
 724               'wl-read-folder-hist)))
 725     (if (or (string= fld wl-default-spec)
 726             (string= fld ""))
 727         (setq fld default))
 728     (setq fld (elmo-string (wl-folder-get-realname fld)))
 729     (if (string-match "\n" fld)
 730         (error "Not supported folder name: %s" fld))
 731     (unless no-create
 732       (if ignore-error
 733           (condition-case nil
 734               (wl-folder-confirm-existence
 735                (wl-folder-get-elmo-folder
 736                 fld))
 737             (error))
 738         (wl-folder-confirm-existence (wl-folder-get-elmo-folder
 739                                       fld))))
 740     fld))
 741
 742 (defun wl-summary-print-argument (msg-num folder)
 743   "Print action argument on line."
 744   (when folder
 745     (wl-summary-remove-argument)
 746     (save-excursion
 747       (let ((inhibit-read-only t)
 748             (folder (copy-sequence folder))
 749             (buffer-read-only nil)
 750             len rs re c)
 751         (setq len (string-width folder))
 752         (if (< len 1) ()
 753           ;;(end-of-line)
 754           (beginning-of-line)
 755           (search-forward "\r")
 756           (forward-char -1)
 757           (setq re (point))
 758           (setq c 0)
 759           (while (< c len)
 760             (forward-char -1)
 761             (setq c (+ c (char-width (following-char)))))
 762           (and (> c len) (setq folder (concat " " folder)))
 763           (setq rs (point))
 764           (when wl-summary-width
 765             (put-text-property rs re 'invisible t))
 766           (put-text-property rs re 'wl-summary-action-argument t)
 767           (goto-char re)
 768           (wl-highlight-action-argument-string folder)
 769           (insert folder)
 770           (set-buffer-modified-p nil))))))
 771
 772 (defsubst wl-summary-reserve-temp-mark-p (mark)
 773   "Return t if temporal MARK should be reserved."
 774   (member mark wl-summary-reserve-mark-list))
 775
 776 (defun wl-summary-refile-prev-destination ()
 777   "Refile message to previously refiled destination."
 778   (interactive)
 779   (funcall (symbol-function 'wl-summary-refile)
 780            wl-summary-buffer-prev-refile-destination
 781            (wl-summary-message-number))
 782   (if (eq wl-summary-move-direction-downward nil)
 783       (wl-summary-prev)
 784     (wl-summary-next)))
 785
 786 (defsubst wl-summary-no-auto-refile-message-p (msg)
 787   (member (elmo-msgdb-get-mark (wl-summary-buffer-msgdb) msg)
 788           wl-summary-auto-refile-skip-marks))
 789
 790 (defun wl-summary-auto-refile (&optional open-all)
 791   "Set refile mark automatically according to 'wl-refile-guess-by-rule'."
 792   (interactive "P")
 793   (message "Marking...")
 794   (save-excursion
 795     (if (and (eq wl-summary-buffer-view 'thread)
 796              open-all)
 797         (wl-thread-open-all))
 798     (let* ((spec (wl-summary-buffer-folder-name))
 799            checked-dsts
 800            (count 0)
 801            number dst thr-entity)
 802       (goto-line 1)
 803       (while (not (eobp))
 804         (setq number (wl-summary-message-number))
 805         (dolist (number (cons number
 806                               (and (eq wl-summary-buffer-view 'thread)
 807                                    ;; process invisible children.
 808                                    (not (wl-thread-entity-get-opened
 809                                          (setq thr-entity
 810                                                (wl-thread-get-entity number))))
 811                                    (wl-thread-entity-get-descendant
 812                                     thr-entity))))
 813           (when (and (not (wl-summary-no-auto-refile-message-p
 814                            number))
 815                      (setq dst
 816                            (wl-folder-get-realname
 817                             (wl-refile-guess-by-rule
 818                              (elmo-msgdb-overview-get-entity
 819                               number (wl-summary-buffer-msgdb)))))
 820                      (not (equal dst spec))
 821                      (let ((pair (assoc dst checked-dsts))
 822                            ret)
 823                        (if pair
 824                            (cdr pair)
 825                          (setq ret
 826                                (condition-case nil
 827                                    (progn
 828                                      (wl-folder-confirm-existence
 829                                       (wl-folder-get-elmo-folder dst))
 830                                      t)
 831                                  (error)))
 832                          (setq checked-dsts (cons (cons dst ret) checked-dsts))
 833                          ret)))
 834             (if (funcall (symbol-function 'wl-summary-refile) number dst)
 835                 (incf count))
 836             (message "Marking...%d message(s)." count)))
 837         (forward-line))
 838       (if (eq count 0)
 839           (message "No message was marked.")
 840         (message "Marked %d message(s)." count)))))
 841
 842 (defun wl-summary-unmark (&optional number)
 843   "Unmark marks (temporary, refile, copy, delete)of current line.
 844 If optional argument NUMBER is specified, unmark message specified by NUMBER."
 845   (interactive)
 846   (wl-summary-unset-mark number (interactive-p)))
 847
 848 (defun wl-summary-unmark-region (beg end)
 849   (interactive "r")
 850   (save-excursion
 851     (save-restriction
 852       (narrow-to-region beg end)
 853       (goto-char (point-min))
 854       (if (eq wl-summary-buffer-view 'thread)
 855           (progn
 856             (while (not (eobp))
 857               (let* ((number (wl-summary-message-number))
 858                      (entity (wl-thread-get-entity number)))
 859                 (if (wl-thread-entity-get-opened entity)
 860                     ;; opened...unmark line.
 861                     (wl-summary-unmark)
 862                   ;; closed
 863                   (wl-summary-delete-marks-on-buffer
 864                    (wl-thread-get-children-msgs number))))
 865               (forward-line 1)))
 866         (while (not (eobp))
 867           (wl-summary-unmark)
 868           (forward-line 1))))))
 869
 870 (defun wl-summary-mark-region-subr (function beg end data)
 871   (save-excursion
 872     (save-restriction
 873       (narrow-to-region beg end)
 874       (goto-char (point-min))
 875       (if (eq wl-summary-buffer-view 'thread)
 876           (progn
 877             (while (not (eobp))
 878               (let* ((number (wl-summary-message-number))
 879                      (entity (wl-thread-get-entity number))
 880                      (wl-summary-move-direction-downward t)
 881                      children)
 882                 (if (wl-thread-entity-get-opened entity)
 883                     ;; opened...delete line.
 884                     (funcall function number data)
 885                   ;; closed
 886                   (setq children (wl-thread-get-children-msgs number))
 887                   (while children
 888                     (funcall function (pop children) data)))
 889                 (forward-line 1))))
 890         (while (not (eobp))
 891           (funcall function (wl-summary-message-number) data)
 892           (forward-line 1))))))
 893
 894 (defun wl-summary-target-mark-all ()
 895   (interactive)
 896   (wl-summary-target-mark-region (point-min) (point-max))
 897   (setq wl-summary-buffer-target-mark-list
 898         (elmo-folder-list-messages wl-summary-buffer-elmo-folder
 899                                    nil 'in-msgdb)))
 900
 901 (defun wl-summary-delete-all-mark (mark)
 902   (goto-char (point-min))
 903   (while (not (eobp))
 904     (when (string= (wl-summary-temp-mark) mark)
 905       (wl-summary-unmark))
 906     (forward-line 1))
 907   (let (deleted)
 908     (dolist (mark-info wl-summary-buffer-temp-mark-list)
 909       (when (string= (nth 1 mark-info) mark)
 910         (setq deleted (cons mark-info deleted))))
 911     (dolist (delete deleted)
 912       (setq wl-summary-buffer-temp-mark-list
 913             (delq delete wl-summary-buffer-temp-mark-list)))))
 914
 915 (defun wl-summary-unmark-all ()
 916   "Unmark all according to what you input."
 917   (interactive)
 918   (let ((unmarks (string-to-char-list (read-from-minibuffer "Unmark: ")))
 919         cur-mark)
 920     (save-excursion
 921       (while unmarks
 922         (setq cur-mark (char-to-string (car unmarks)))
 923         (wl-summary-delete-all-mark cur-mark)
 924         (setq unmarks (cdr unmarks))))))
 925
 926 (defun wl-summary-target-mark-thread ()
 927   (interactive)
 928   (wl-thread-call-region-func 'wl-summary-target-mark-region t))
 929
 930 (require 'product)
 931 (product-provide (provide 'wl-action) (require 'wl-version))
 932
 933 ;;; wl-action.el ends here