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