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