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