cgit.sxemacs.org Git - packages/blob - xemacs-packages/vm/lisp/vm-save.el

   1 ;;; vm-save.el --- Saving and piping messages under VM
   2 ;;
   3 ;; Copyright (C) 1989, 1990, 1993, 1994 Kyle E. Jones
   4 ;; Copyright (C) 2003-2006 Robert Widhopf-Fenk
   5 ;;
   6 ;; This program is free software; you can redistribute it and/or modify
   7 ;; it under the terms of the GNU General Public License as published by
   8 ;; the Free Software Foundation; either version 2 of the License, or
   9 ;; (at your option) any later version.
  10 ;;
  11 ;; This program is distributed in the hope that it will be useful,
  12 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;; GNU General Public License for more details.
  15 ;;
  16 ;; You should have received a copy of the GNU General Public License along
  17 ;; with this program; if not, write to the Free Software Foundation, Inc.,
  18 ;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  19
  20 ;; (match-data) returns the match data as MARKERS, often corrupting it in the
  21 ;; process due to buffer narrowing, and the fact that buffers are indexed from
  22 ;; 1 while strings are indexed from 0. :-(
  23
  24 ;;; Code:
  25
  26 ;;;###autoload
  27 (defun vm-match-data ()
  28   (let ((n (1- (/ (length (match-data)) 2)))
  29         (list nil))
  30     (while (>= n 0)
  31       (setq list (cons (match-beginning n)
  32                        (cons (match-end n) list))
  33             n (1- n)))
  34     list))
  35
  36 ;;;###autoload
  37 (defun vm-auto-select-folder (mp auto-folder-alist)
  38   (condition-case error-data
  39       (catch 'match
  40         (let (header alist tuple-list)
  41           (setq alist auto-folder-alist)
  42           (while alist
  43             (setq header (vm-get-header-contents (car mp) (car (car alist))
  44                                                  ", "))
  45             (if (null header)
  46                 ()
  47               (setq tuple-list (cdr (car alist)))
  48               (while tuple-list
  49                 (if (let ((case-fold-search vm-auto-folder-case-fold-search))
  50                       (string-match (car (car tuple-list)) header))
  51                     ;; Don't waste time eval'ing an atom.
  52                     (if (stringp (cdr (car tuple-list)))
  53                         (throw 'match (cdr (car tuple-list)))
  54                       (let* ((match-data (vm-match-data))
  55                              ;; allow this buffer to live forever
  56                              (buf (get-buffer-create " *vm-auto-folder*"))
  57                              (result))
  58                         ;; Set up a buffer that matches our cached
  59                         ;; match data.
  60                         (save-excursion
  61                           (set-buffer buf)
  62                           (if vm-fsfemacs-mule-p
  63                               (set-buffer-multibyte nil))
  64                           (widen)
  65                           (erase-buffer)
  66                           (insert header)
  67                           ;; It appears that get-buffer-create clobbers the
  68                           ;; match-data.
  69                           ;;
  70                           ;; The match data is off by one because we matched
  71                           ;; a string and Emacs indexes strings from 0 and
  72                           ;; buffers from 1.
  73                           ;;
  74                           ;; Also store-match-data only accepts MARKERS!!
  75                           ;; AUGHGHGH!!
  76                           (store-match-data
  77                            (mapcar
  78                             (function (lambda (n) (and n (vm-marker n))))
  79                             (mapcar
  80                              (function (lambda (n) (and n (1+ n))))
  81                              match-data)))
  82                           (setq result (eval (cdr (car tuple-list))))
  83                           (while (consp result)
  84                             (setq result (vm-auto-select-folder mp result)))
  85                           (if result
  86                               (throw 'match result))))))
  87                 (setq tuple-list (cdr tuple-list))))
  88             (setq alist (cdr alist)))
  89           nil ))
  90     (error (error "error processing vm-auto-folder-alist: %s"
  91                   (prin1-to-string error-data)))))
  92
  93 ;;;###autoload
  94 (defun vm-auto-archive-messages (&optional arg)
  95   "Save all unfiled messages that auto-match a folder via
  96 vm-auto-folder-alist to their appropriate folders.  Messages that
  97 are flagged for deletion are not saved.
  98
  99 Prefix arg means to ask user for confirmation before saving each message.
 100
 101 When invoked on marked messages (via vm-next-command-uses-marks),
 102 only marked messages are checked against vm-auto-folder-alist.
 103
 104 The saved messages are flagged as `filed'."
 105   (interactive "P")
 106   (vm-select-folder-buffer)
 107   (vm-check-for-killed-summary)
 108   (vm-error-if-folder-empty)
 109   (message "Archiving...")
 110   (let ((auto-folder)
 111         (archived 0))
 112     (unwind-protect
 113         ;; Need separate (let ...) so vm-message-pointer can
 114         ;; revert back in time for
 115         ;; (vm-update-summary-and-mode-line).
 116         ;; vm-last-save-folder is tucked away here since archives
 117         ;; shouldn't affect its value.
 118         (let ((vm-message-pointer
 119                (if (eq last-command 'vm-next-command-uses-marks)
 120                    (vm-select-marked-or-prefixed-messages 0)
 121                  vm-message-list))
 122               (done nil)
 123               stop-point
 124               (vm-last-save-folder vm-last-save-folder)
 125               (vm-move-after-deleting nil))
 126           ;; mark the place where we should stop.  otherwise if any
 127           ;; messages in this folder are archived to this folder
 128           ;; we would file messages into this folder forever.
 129           (setq stop-point (vm-last vm-message-pointer))
 130           (while (not done)
 131             (and (not (vm-filed-flag (car vm-message-pointer)))
 132                  ;; don't archive deleted messages
 133                  (not (vm-deleted-flag (car vm-message-pointer)))
 134                  (setq auto-folder (vm-auto-select-folder
 135                                     vm-message-pointer
 136                                     vm-auto-folder-alist))
 137                  ;; Don't let user archive into the same folder
 138                  ;; that they are visiting.
 139                  (not (eq (vm-get-file-buffer auto-folder)
 140                           (current-buffer)))
 141                  (or (null arg)
 142                      (y-or-n-p
 143                       (format "Save message %s in folder %s? "
 144                               (vm-number-of (car vm-message-pointer))
 145                               auto-folder)))
 146                  (let ((vm-delete-after-saving vm-delete-after-archiving)
 147                        (last-command 'vm-auto-archive-messages))
 148                    (vm-save-message auto-folder)
 149                    (vm-increment archived)
 150                    (message "%d archived, still working..." archived)))
 151             (setq done (eq vm-message-pointer stop-point)
 152                   vm-message-pointer (cdr vm-message-pointer))))
 153       ;; fix mode line
 154       (intern (buffer-name) vm-buffers-needing-display-update)
 155       (vm-update-summary-and-mode-line))
 156     (if (zerop archived)
 157         (message "No messages were archived")
 158       (message "%d message%s archived"
 159                archived (if (= 1 archived) "" "s")))))
 160
 161 ;;;---------------------------------------------------------------------------
 162 ;; The following defun seems a lot less efficient than it might be,
 163 ;; but I don't have a better sense of how to access the folder buffer
 164 ;; and read its local variables. [2006/10/31:rpg]
 165 ;;---------------------------------------------------------------------------
 166
 167 (defun vm-imap-folder-p ()
 168   "Is the current folder an IMAP folder?"
 169   (save-excursion
 170     (vm-select-folder-buffer)
 171     (eq vm-folder-access-method 'imap)))
 172
 173 ;;;---------------------------------------------------------------------------
 174 ;; New shell defun to handle both IMAP and local saving.
 175 ;;---------------------------------------------------------------------------
 176 ;;;###autoload
 177 (defun vm-save-message (folder &optional count)
 178   "Save the current message.  This may be done either by saving it
 179 to an IMAP folder or by saving it to a local filesystem folder.
 180 Which is done is controlled by the type of the current vm-folder
 181 buffer and the variable `vm-imap-save-to-server'."
 182   (interactive
 183    (if (and vm-imap-save-to-server
 184             (vm-imap-folder-p))
 185        ;; IMAP saving --- argument parsing taken from
 186        ;; vm-save-message-to-imap-folder
 187        (save-excursion
 188          (vm-session-initialization)
 189          (vm-check-for-killed-folder)
 190          (vm-select-folder-buffer-if-possible)
 191          (let ((this-command this-command)
 192                (last-command last-command))
 193            (list (vm-read-imap-folder-name "Save to IMAP folder: "
 194                                            vm-imap-server-list t)
 195                  (prefix-numeric-value current-prefix-arg))))
 196        ;; saving to local filesystem.  argument parsing taken from old
 197        ;; vm-save-message now vm-save-message-to-local-folder
 198        (list
 199         ;; protect value of last-command
 200         (let ((last-command last-command)
 201               (this-command this-command))
 202           (vm-follow-summary-cursor)
 203           (let ((default (save-excursion
 204                            (vm-select-folder-buffer)
 205                            (vm-check-for-killed-summary)
 206                            (vm-error-if-folder-empty)
 207                            (or (vm-auto-select-folder vm-message-pointer
 208                                                       vm-auto-folder-alist)
 209                                vm-last-save-folder)))
 210                 (dir (or vm-folder-directory default-directory)))
 211             (cond ((and default
 212                         (let ((default-directory dir))
 213                           (file-directory-p default)))
 214                    (vm-read-file-name "Save in folder: " dir nil nil default))
 215                   (default
 216                       (vm-read-file-name
 217                        (format "Save in folder: (default %s) " default)
 218                        dir default))
 219                   (t
 220                    (vm-read-file-name "Save in folder: " dir nil)))))
 221         (prefix-numeric-value current-prefix-arg))))
 222   (if (and vm-imap-save-to-server
 223            (vm-imap-folder-p))
 224       (vm-save-message-to-imap-folder folder count)
 225       (vm-save-message-to-local-folder folder count)))
 226
 227 ;;;###autoload
 228 (defun vm-save-message-to-local-folder (folder &optional count)
 229   "Save the current message to a mail folder.
 230 If the folder already exists, the message will be appended to it.
 231
 232 Prefix arg COUNT means save this message and the next COUNT-1
 233 messages.  A negative COUNT means save this message and the
 234 previous COUNT-1 messages.
 235
 236 When invoked on marked messages (via vm-next-command-uses-marks),
 237 all marked messages in the current folder are saved; other messages are
 238 ignored.
 239
 240 The saved messages are flagged as `filed'."
 241   (interactive
 242    (list
 243     ;; protect value of last-command
 244     (let ((last-command last-command)
 245           (this-command this-command))
 246       (vm-follow-summary-cursor)
 247       (let ((default (save-excursion
 248                        (vm-select-folder-buffer)
 249                        (vm-check-for-killed-summary)
 250                        (vm-error-if-folder-empty)
 251                        (or (vm-auto-select-folder vm-message-pointer
 252                                                   vm-auto-folder-alist)
 253                            vm-last-save-folder)))
 254             (dir (or vm-folder-directory default-directory)))
 255         (cond ((and default
 256                     (let ((default-directory dir))
 257                       (file-directory-p default)))
 258                (vm-read-file-name "Save in folder: " dir nil nil default))
 259               (default
 260                (vm-read-file-name
 261                 (format "Save in folder: (default %s) " default)
 262                 dir default))
 263               (t
 264                (vm-read-file-name "Save in folder: " dir nil)))))
 265     (prefix-numeric-value current-prefix-arg)))
 266   (let (auto-folder unexpanded-folder)
 267     (vm-select-folder-buffer)
 268     (vm-check-for-killed-summary)
 269     (vm-error-if-folder-empty)
 270     (setq unexpanded-folder folder
 271           auto-folder (vm-auto-select-folder vm-message-pointer
 272                                              vm-auto-folder-alist))
 273     (vm-display nil nil '(vm-save-message) '(vm-save-message))
 274     (or count (setq count 1))
 275     ;; Expand the filename, forcing relative paths to resolve
 276     ;; into the folder directory.
 277     (let ((default-directory
 278             (expand-file-name (or vm-folder-directory default-directory))))
 279       (setq folder (expand-file-name folder)))
 280     ;; Confirm new folders, if the user requested this.
 281     (if (and vm-confirm-new-folders
 282              (not (file-exists-p folder))
 283              (or (not vm-visit-when-saving) (not (vm-get-file-buffer folder)))
 284              (not (y-or-n-p (format "%s does not exist, save there anyway? "
 285                                     folder))))
 286         (error "Save aborted"))
 287     ;; Check and see if we are currently visiting the folder
 288     ;; that the user wants to save to.
 289     (if (and (not vm-visit-when-saving) (vm-get-file-buffer folder))
 290         (error "Folder %s is being visited, cannot save." folder))
 291     (let ((mlist (vm-select-marked-or-prefixed-messages count))
 292           (coding-system-for-write
 293            (if (file-exists-p folder)
 294                (vm-get-file-line-ending-coding-system folder)
 295              (vm-new-folder-line-ending-coding-system)))
 296           (oldmodebits (and (fboundp 'default-file-modes)
 297                             (default-file-modes)))
 298           (m nil) (count 0) folder-buffer target-type)
 299       (cond ((and mlist (eq vm-visit-when-saving t))
 300              (setq folder-buffer (or (vm-get-file-buffer folder)
 301                                      ;; avoid letter bombs
 302                                      (let ((inhibit-local-variables t)
 303                                            (enable-local-eval nil)
 304                                            (enable-local-variables nil))
 305                                        (find-file-noselect folder)))))
 306             ((and mlist vm-visit-when-saving)
 307              (setq folder-buffer (vm-get-file-buffer folder))))
 308       (if (and mlist vm-check-folder-types)
 309           (progn
 310             (setq target-type (or (vm-get-folder-type folder)
 311                                   vm-default-folder-type
 312                                   (and mlist
 313                                        (vm-message-type-of (car mlist)))))
 314             (if (eq target-type 'unknown)
 315                 (error "Folder %s's type is unrecognized" folder))))
 316       (unwind-protect
 317           (save-excursion
 318             (and oldmodebits (set-default-file-modes
 319                               vm-default-folder-permission-bits))
 320             ;; if target folder is empty or nonexistent we need to
 321             ;; write out the folder header first.
 322             (if mlist
 323                 (let ((attrs (file-attributes folder)))
 324                   (if (or (null attrs) (= 0 (nth 7 attrs)))
 325                       (if (null folder-buffer)
 326                           (vm-write-string folder
 327                                            (vm-folder-header target-type))
 328                         (vm-write-string folder-buffer
 329                                          (vm-folder-header target-type))))))
 330             (while mlist
 331               (setq m (vm-real-message-of (car mlist)))
 332               (set-buffer (vm-buffer-of m))
 333               (vm-save-restriction
 334                (widen)
 335                ;; have to stuff the attributes in all cases because
 336                ;; the deleted attribute may have been stuffed
 337                ;; previously and we don't want to save that attribute.
 338                ;; also we don't want to save out the cached summary entry.
 339                (vm-stuff-attributes m t)
 340                (if (null folder-buffer)
 341                    (if (or (null vm-check-folder-types)
 342                            (eq target-type (vm-message-type-of m)))
 343                        (write-region (vm-start-of m)
 344                                      (vm-end-of m)
 345                                      folder t 'quiet)
 346                      (if (null vm-convert-folder-types)
 347                          (if (not (vm-virtual-message-p (car mlist)))
 348                              (error "Folder type mismatch: %s, %s"
 349                                     (vm-message-type-of m) target-type)
 350                            (error "Message %s type mismatches folder %s"
 351                                   (vm-number-of (car mlist))
 352                                   folder
 353                                   (vm-message-type-of m)
 354                                   target-type))
 355                        (vm-write-string
 356                         folder
 357                         (vm-leading-message-separator target-type m t))
 358                        (if (eq target-type 'From_-with-Content-Length)
 359                            (vm-write-string
 360                             folder
 361                             (concat vm-content-length-header " "
 362                                     (vm-su-byte-count m) "\n")))
 363                        (write-region (vm-headers-of m)
 364                                      (vm-text-end-of m)
 365                                      folder t 'quiet)
 366                        (vm-write-string
 367                         folder
 368                         (vm-trailing-message-separator target-type))))
 369                  (save-excursion
 370                    (set-buffer folder-buffer)
 371                    ;; if the buffer is a live VM folder
 372                    ;; honor vm-folder-read-only.
 373                    (if vm-folder-read-only
 374                        (signal 'folder-read-only (list (current-buffer))))
 375                    (let ((buffer-read-only nil))
 376                      (vm-save-restriction
 377                       (widen)
 378                       (save-excursion
 379                         (goto-char (point-max))
 380                         (if (or (null vm-check-folder-types)
 381                                 (eq target-type (vm-message-type-of m)))
 382                             (insert-buffer-substring
 383                              (vm-buffer-of m)
 384                              (vm-start-of m) (vm-end-of m))
 385                           (if (null vm-convert-folder-types)
 386                               (if (not (vm-virtual-message-p (car mlist)))
 387                                   (error "Folder type mismatch: %s, %s"
 388                                          (vm-message-type-of m) target-type)
 389                                 (error "Message %s type mismatches folder %s"
 390                                        (vm-number-of (car mlist))
 391                                        folder
 392                                        (vm-message-type-of m)
 393                                        target-type))
 394                             (vm-write-string
 395                              (current-buffer)
 396                              (vm-leading-message-separator target-type m t))
 397                             (if (eq target-type 'From_-with-Content-Length)
 398                                 (vm-write-string
 399                                  (current-buffer)
 400                                  (concat vm-content-length-header " "
 401                                          (vm-su-byte-count m) "\n")))
 402                             (insert-buffer-substring (vm-buffer-of m)
 403                                                      (vm-headers-of m)
 404                                                      (vm-text-end-of m))
 405                             (vm-write-string
 406                              (current-buffer)
 407                              (vm-trailing-message-separator target-type)))))
 408                       ;; vars should exist and be local
 409                       ;; but they may have strange values,
 410                       ;; so check the major-mode.
 411                       (cond ((eq major-mode 'vm-mode)
 412                              (vm-increment vm-messages-not-on-disk)
 413                              (vm-clear-modification-flag-undos)))))))
 414                (if (null (vm-filed-flag m))
 415                    (vm-set-filed-flag m t))
 416                (vm-increment count)
 417                (vm-modify-folder-totals folder 'saved 1 m)
 418                (vm-update-summary-and-mode-line)
 419                (setq mlist (cdr mlist)))))
 420         (and oldmodebits (set-default-file-modes oldmodebits)))
 421       (if m
 422           (if folder-buffer
 423               (progn
 424                 (save-excursion
 425                   (set-buffer folder-buffer)
 426                   (if (eq major-mode 'vm-mode)
 427                       (progn
 428                         (vm-check-for-killed-summary)
 429                         (vm-assimilate-new-messages)
 430                         (if (null vm-message-pointer)
 431                             (progn (setq vm-message-pointer vm-message-list
 432                                          vm-need-summary-pointer-update t)
 433                                    (intern (buffer-name)
 434                                            vm-buffers-needing-display-update)
 435                                    (vm-preview-current-message))
 436                           (vm-update-summary-and-mode-line)))))
 437                 (message "%d message%s saved to buffer %s"
 438                          count
 439                          (if (/= 1 count) "s" "")
 440                          (buffer-name folder-buffer)))
 441             (message "%d message%s saved to %s"
 442                      count (if (/= 1 count) "s" "") folder))))
 443     (if (or (null vm-last-save-folder)
 444             (not (equal unexpanded-folder auto-folder)))
 445         (setq vm-last-save-folder unexpanded-folder))
 446     (if (and vm-delete-after-saving (not vm-folder-read-only))
 447         (vm-delete-message count))
 448     folder ))
 449
 450 ;;;###autoload
 451 (defun vm-save-message-sans-headers (file &optional count)
 452   "Save the current message to a file, without its header section.
 453 If the file already exists, the message body will be appended to it.
 454 Prefix arg COUNT means save the next COUNT message bodiess.  A
 455 negative COUNT means save the previous COUNT bodies.
 456
 457 When invoked on marked messages (via vm-next-command-uses-marks),
 458 only the next COUNT marked messages are saved; other intervening
 459 messages are ignored.
 460
 461 The saved messages are flagged as `written'.
 462
 463 This command should NOT be used to save message to mail folders; use
 464 vm-save-message instead (normally bound to `s')."
 465   (interactive
 466    ;; protect value of last-command
 467    (let ((last-command last-command)
 468          (this-command this-command))
 469      (vm-follow-summary-cursor)
 470      (vm-select-folder-buffer)
 471      (list
 472       (vm-read-file-name
 473        (if vm-last-written-file
 474            (format "Write text to file: (default %s) "
 475                    vm-last-written-file)
 476          "Write text to file: ")
 477        nil vm-last-written-file nil)
 478       (prefix-numeric-value current-prefix-arg))))
 479   (vm-select-folder-buffer)
 480   (vm-check-for-killed-summary)
 481   (vm-error-if-folder-empty)
 482   (vm-display nil nil '(vm-save-message-sans-headers)
 483               '(vm-save-message-sans-headers))
 484   (or count (setq count 1))
 485   (setq file (expand-file-name file))
 486   ;; Check and see if we are currently visiting the file
 487   ;; that the user wants to save to.
 488   (if (and (not vm-visit-when-saving) (vm-get-file-buffer file))
 489       (error "File %s is being visited, cannot save." file))
 490   (let ((mlist (vm-select-marked-or-prefixed-messages count))
 491         (oldmodebits (and (fboundp 'default-file-modes)
 492                           (default-file-modes)))
 493         (coding-system-for-write
 494          (vm-get-file-line-ending-coding-system file))
 495         (m nil) file-buffer)
 496     (cond ((and mlist (eq vm-visit-when-saving t))
 497            (setq file-buffer (or (vm-get-file-buffer file)
 498                                  (find-file-noselect file))))
 499           ((and mlist vm-visit-when-saving)
 500            (setq file-buffer (vm-get-file-buffer file))))
 501     (if (and (not (memq (vm-get-folder-type file) '(nil unknown)))
 502              (not (y-or-n-p "This file looks like a mail folder, append to it anyway? ")))
 503         (error "Aborted"))
 504     (unwind-protect
 505         (save-excursion
 506           (and oldmodebits (set-default-file-modes
 507                             vm-default-folder-permission-bits))
 508           (while mlist
 509             (setq m (vm-real-message-of (car mlist)))
 510             (set-buffer (vm-buffer-of m))
 511             (vm-save-restriction
 512              (widen)
 513              (if (null file-buffer)
 514                  (write-region (vm-text-of m)
 515                                (vm-text-end-of m)
 516                                file t 'quiet)
 517                (let ((start (vm-text-of m))
 518                      (end (vm-text-end-of m)))
 519                  (save-excursion
 520                    (set-buffer file-buffer)
 521                    (save-excursion
 522                      (let (buffer-read-only)
 523                        (vm-save-restriction
 524                         (widen)
 525                         (save-excursion
 526                           (goto-char (point-max))
 527                           (insert-buffer-substring
 528                            (vm-buffer-of m)
 529                            start end))))))))
 530              (if (null (vm-written-flag m))
 531                  (vm-set-written-flag m t))
 532              (vm-update-summary-and-mode-line)
 533              (setq mlist (cdr mlist)))))
 534       (and oldmodebits (set-default-file-modes oldmodebits)))
 535     (if m
 536         (if file-buffer
 537             (message "Message%s written to buffer %s" (if (/= 1 count) "s" "")
 538                      (buffer-name file-buffer))
 539           (message "Message%s written to %s" (if (/= 1 count) "s" "") file)))
 540     (setq vm-last-written-file file)))
 541
 542 (defun vm-switch-to-command-output-buffer (command buffer discard-output)
 543   "Eventually switch to the output buffer of the command."
 544   (let ((output-bytes (save-excursion (set-buffer buffer) (buffer-size))))
 545     (if (zerop output-bytes)
 546         (message "Command '%s' produced no output." command)
 547       (if discard-output
 548           (message "Command '%s' produced %d bytes of output."
 549                    command output-bytes)
 550         (display-buffer buffer)))))
 551
 552 (defun vm-pipe-message-part (m arg)
 553   "Return (START END) bounds for piping to external command, based on ARG."
 554   (cond ((equal prefix-arg '(4))
 555          (list (vm-text-of m) (vm-text-end-of m)))
 556         ((equal prefix-arg '(16))
 557          (list (vm-headers-of m) (vm-text-of m)))
 558         ((equal prefix-arg '(64))
 559          (list (vm-vheaders-of m) (vm-text-end-of m)))
 560         (t
 561          (list (vm-headers-of m) (vm-text-end-of m)))))
 562
 563 ;;;###autoload
 564 (defun vm-pipe-message-to-command (command &optional prefix-arg discard-output)
 565   "Runs a shell command with contents from the current message as input.
 566 By default, the entire message is used.
 567 With one \\[universal-argument] the text portion of the message is used.
 568 With two \\[universal-argument]'s the header portion of the message is used.
 569 With three \\[universal-argument]'s the visible header portion of the message
 570 plus the text portion is used.
 571
 572 When invoked on marked messages (via vm-next-command-uses-marks),
 573 each marked message is successively piped to the shell command,
 574 one message per command invocation.
 575
 576 Output, if any, is displayed.  The message is not altered."
 577   (interactive
 578    ;; protect value of last-command
 579    (let ((last-command last-command)
 580          (this-command this-command))
 581      (vm-follow-summary-cursor)
 582      (vm-select-folder-buffer)
 583      (list (read-string "Pipe to command: " vm-last-pipe-command)
 584            current-prefix-arg)))
 585   (vm-select-folder-buffer)
 586   (vm-check-for-killed-summary)
 587   (vm-error-if-folder-empty)
 588   (setq vm-last-pipe-command command)
 589   (let ((buffer (get-buffer-create "*Shell Command Output*"))
 590         m
 591         (pop-up-windows (and pop-up-windows (eq vm-mutable-windows t)))
 592         ;; prefix arg doesn't have "normal" meaning here, so only call
 593         ;; vm-select-marked-or-prefixed-messages if we're using marks.
 594         (mlist (if (eq last-command 'vm-next-command-uses-marks)
 595                    (vm-select-marked-or-prefixed-messages 0)
 596                  (list (car vm-message-pointer)))))
 597     (save-excursion
 598       (set-buffer buffer)
 599       (erase-buffer))
 600     (while mlist
 601       (setq m (vm-real-message-of (car mlist)))
 602       (set-buffer (vm-buffer-of m))
 603       (save-restriction
 604         (widen)
 605         (let ((pop-up-windows (and pop-up-windows (eq vm-mutable-windows t)))
 606               ;; call-process-region calls write-region.
 607               ;; don't let it do CR -> LF translation.
 608               (selective-display nil)
 609               (region (vm-pipe-message-part m prefix-arg)))
 610           (call-process-region (nth 0 region) (nth 1 region)
 611                                (or shell-file-name "sh")
 612                                nil buffer nil shell-command-switch command)))
 613       (setq mlist (cdr mlist)))
 614     (vm-display nil nil '(vm-pipe-message-to-command)
 615                 '(vm-pipe-message-to-command))
 616     (vm-switch-to-command-output-buffer command buffer discard-output)
 617     buffer))
 618
 619 (defun vm-pipe-message-to-command-to-string (command &optional prefix-arg)
 620   "Run a shell command with contents from the current message as input.
 621 This function is like `vm-pipe-message-to-command', but will not display the
 622 output of the command, but return it as a string."
 623   (save-excursion
 624     (set-buffer (vm-pipe-message-to-command command prefix-arg t))
 625     (buffer-substring-no-properties (point-min) (point-max))))
 626
 627 ;;;###autoload
 628 (defun vm-pipe-message-to-command-discard-output (command &optional prefix-arg)
 629   "Run a shell command with contents from the current message as input.
 630 This function is like `vm-pipe-message-to-command', but will not display the
 631 output of the command."
 632   (interactive
 633    ;; protect value of last-command
 634    (let ((last-command last-command)
 635          (this-command this-command))
 636      (vm-follow-summary-cursor)
 637      (vm-select-folder-buffer)
 638      (list (read-string "Pipe to command: " vm-last-pipe-command)
 639            current-prefix-arg)))
 640   (vm-pipe-message-to-command command prefix-arg t))
 641
 642 (defun vm-pipe-command-exit-handler (process discard-output
 643                                              &optional exit-handler)
 644   "Switch to output buffer of PROCESS if DISCARD-OUTPUT non-nil.
 645 If non-nil call EXIT-HANDLER with the two arguments COMMAND and OUTPUT-BUFFER."
 646   (let ((exit-code (process-exit-status process))
 647         (buffer (process-buffer process))
 648         (command (process-command process)))
 649   (if (not (zerop exit-code))
 650       (message "Command '%s' exit code is %d." command exit-code))
 651   (vm-display nil nil '(vm-pipe-message-to-command)
 652               '(vm-pipe-message-to-command))
 653   (vm-switch-to-command-output-buffer command buffer discard-output)
 654   (if exit-handler
 655       (funcall exit-handler command buffer))))
 656
 657 (defvar vm-pipe-messages-to-command-start ""
 658   "*Inserted by `vm-pipe-messages-to-command' before a message.")
 659
 660 (defvar vm-pipe-messages-to-command-end "\n"
 661   "*Inserted by `vm-pipe-messages-to-command' after a message.")
 662
 663 ;;;###autoload
 664 (defun vm-pipe-messages-to-command (command &optional prefix-arg
 665                                             discard-output no-wait)
 666   "Run a shell command with contents from messages as input.
 667
 668 Similar to `vm-pipe-message-to-command', but it will call process
 669 just once and pipe all messages to it.  For bulk operations this
 670 is much faster than calling the command on each message.  This is
 671 more like saving to a pipe.
 672
 673 Before a message it will insert `vm-pipe-messages-to-command-start'
 674 and after a message `vm-pipe-messages-to-command-end'.
 675
 676 Output, if any, is displayed unless DISCARD-OUTPUT is t.
 677
 678 If NO-WAIT is t, then do not wait for process to finish, if it is
 679 a function then call it with the COMMAND and OUTPUT-BUFFER as
 680 arguments after the command finished."
 681   (interactive
 682    ;; protect value of last-command
 683    (let ((last-command last-command)
 684          (this-command this-command))
 685      (vm-follow-summary-cursor)
 686      (vm-select-folder-buffer)
 687      (list (read-string "Pipe to command: " vm-last-pipe-command)
 688            current-prefix-arg)))
 689   (vm-select-folder-buffer)
 690   (vm-check-for-killed-summary)
 691   (vm-error-if-folder-empty)
 692   (setq vm-last-pipe-command command)
 693   (let ((buffer (get-buffer-create "*Shell Command Output*"))
 694         (pop-up-windows (and pop-up-windows (eq vm-mutable-windows t)))
 695         ;; prefix arg doesn't have "normal" meaning here, so only call
 696         ;; vm-select-marked-or-prefixed-messages if we're using marks.
 697         (mlist (if (eq last-command 'vm-next-command-uses-marks)
 698                    (vm-select-marked-or-prefixed-messages 0)
 699                  (list (car vm-message-pointer))))
 700         m process)
 701     (save-excursion
 702       (set-buffer buffer)
 703       (erase-buffer))
 704     (setq process (start-process command buffer
 705                                  (or shell-file-name "sh")
 706                                  shell-command-switch command))
 707     (set-process-sentinel
 708      process
 709      `(lambda (process status)
 710         (setq status (process-status process))
 711         (if (eq 'exit status)
 712             (if ,no-wait
 713                 (vm-pipe-command-exit-handler
 714                  process ,command ,discard-output
 715                  (if (and ,no-wait (functionp ,no-wait))
 716                      no-wait)))
 717           (message "Command '%s' changed state to %s."
 718                    ,command status))))
 719     (while mlist
 720       (setq m (vm-real-message-of (car mlist)))
 721       (set-buffer (vm-buffer-of m))
 722       (process-send-string process vm-pipe-messages-to-command-start)
 723       (save-restriction
 724         (widen)
 725         (let ((region (vm-pipe-message-part m prefix-arg)))
 726           (process-send-region process (nth 0 region) (nth 1 region))))
 727       (process-send-string process vm-pipe-messages-to-command-end)
 728       (setq mlist (cdr mlist)))
 729
 730     (process-send-eof process)
 731
 732     (when (not no-wait)
 733       (while (and (eq 'run (process-status process)))
 734         (accept-process-output process)
 735         (sit-for 0))
 736       (vm-pipe-command-exit-handler process command discard-output))
 737     buffer))
 738
 739 (defun vm-pipe-messages-to-command-to-string (command &optional prefix-arg)
 740   "Runs a shell command with contents from the current message as input.
 741 This function is like `vm-pipe-messages-to-command', but will not display the
 742 output of the command, but return it as a string."
 743   (interactive
 744    ;; protect value of last-command
 745    (let ((last-command last-command)
 746          (this-command this-command))
 747      (vm-follow-summary-cursor)
 748      (vm-select-folder-buffer)
 749      (list (read-string "Pipe to command: " vm-last-pipe-command)
 750            current-prefix-arg)))
 751   (save-excursion
 752     (set-buffer (vm-pipe-messages-to-command command prefix-arg t))
 753     (buffer-substring-no-properties (point-min) (point-max))))
 754
 755 ;;;###autoload
 756 (defun vm-pipe-messages-to-command-discard-output (command &optional prefix-arg)
 757   "Runs a shell command with contents from the current message as input.
 758 This function is like `vm-pipe-messages-to-command', but will not display the
 759 output of the command."
 760   (interactive
 761    ;; protect value of last-command
 762    (let ((last-command last-command)
 763          (this-command this-command))
 764      (vm-follow-summary-cursor)
 765      (vm-select-folder-buffer)
 766      (list (read-string "Pipe to command: " vm-last-pipe-command)
 767            current-prefix-arg)))
 768   (vm-pipe-messages-to-command command prefix-arg t))
 769
 770 ;;;###autoload
 771 (defun vm-print-message (&optional count)
 772   "Print the current message
 773 Prefix arg N means print the current message and the next N - 1 messages.
 774 Prefix arg -N means print the current message and the previous N - 1 messages.
 775
 776 The variable `vm-print-command' controls what command is run to
 777 print the message, and `vm-print-command-switches' is a list of switches
 778 to pass to the command.
 779
 780 When invoked on marked messages (via vm-next-command-uses-marks),
 781 each marked message is printed, one message per vm-print-command invocation.
 782
 783 Output, if any, is displayed.  The message is not altered."
 784   (interactive "p")
 785   (vm-follow-summary-cursor)
 786   (vm-select-folder-buffer)
 787   (vm-check-for-killed-summary)
 788   (vm-error-if-folder-empty)
 789   (or count (setq count 1))
 790   (let* ((buffer (get-buffer-create "*Shell Command Output*"))
 791          (need-tempfile (string-match ".*-.*-\\(win95\\|nt\\)"
 792                                       system-configuration))
 793          (tempfile (if need-tempfile (vm-make-tempfile-name)))
 794          (command (mapconcat (function identity)
 795                              (nconc (list vm-print-command)
 796                                     (copy-sequence vm-print-command-switches)
 797                                     (if need-tempfile
 798                                         (list tempfile)))
 799                              " "))
 800          (m nil)
 801          (pop-up-windows (and pop-up-windows (eq vm-mutable-windows t)))
 802          (mlist (vm-select-marked-or-prefixed-messages count)))
 803     (save-excursion
 804       (set-buffer buffer)
 805       (erase-buffer))
 806     (while mlist
 807       (setq m (vm-real-message-of (car mlist)))
 808       (set-buffer (vm-buffer-of m))
 809       (if (and vm-display-using-mime (vectorp (vm-mm-layout m)))
 810           (let ((work-buffer nil))
 811             (unwind-protect
 812                 (progn
 813                   (setq work-buffer (vm-make-work-buffer))
 814                   (set-buffer work-buffer)
 815                   (vm-insert-region-from-buffer
 816                    (vm-buffer-of m) (vm-vheaders-of m) (vm-text-of m))
 817                   (vm-decode-mime-encoded-words)
 818                   (goto-char (point-max))
 819                   (let ((vm-auto-displayed-mime-content-types
 820                          '("text" "multipart"))
 821                         (vm-mime-internal-content-types
 822                          '("text" "multipart"))
 823                         (vm-mime-external-content-types-alist nil))
 824                     (vm-decode-mime-layout (vm-mm-layout m)))
 825                   (let ((pop-up-windows (and pop-up-windows
 826                                              (eq vm-mutable-windows t)))
 827                         ;; call-process-region calls write-region.
 828                         ;; don't let it do CR -> LF translation.
 829                         (selective-display nil))
 830                     (if need-tempfile
 831                         (write-region (point-min) (point-max)
 832                                       tempfile nil 0))
 833                     (call-process-region (point-min) (point-max)
 834                                          (or shell-file-name "sh")
 835                                          nil buffer nil
 836                                          shell-command-switch command)
 837                     (if need-tempfile
 838                         (vm-error-free-call 'delete-file tempfile))))
 839               (and work-buffer (kill-buffer work-buffer))))
 840         (save-restriction
 841           (widen)
 842           (narrow-to-region (vm-vheaders-of m) (vm-text-end-of m))
 843           (let ((pop-up-windows (and pop-up-windows
 844                                      (eq vm-mutable-windows t)))
 845                 ;; call-process-region calls write-region.
 846                 ;; don't let it do CR -> LF translation.
 847                 (selective-display nil))
 848             (if need-tempfile
 849                 (write-region (point-min) (point-max)
 850                               tempfile nil 0))
 851             (call-process-region (point-min) (point-max)
 852                                  (or shell-file-name "sh")
 853                                  nil buffer nil
 854                                  shell-command-switch command)
 855             (if need-tempfile
 856                 (vm-error-free-call 'delete-file tempfile)))))
 857       (setq mlist (cdr mlist)))
 858     (vm-display nil nil '(vm-print-message) '(vm-print-message))
 859     (vm-switch-to-command-output-buffer command buffer nil)))
 860
 861 ;;;###autoload
 862 (defun vm-save-message-to-imap-folder (folder &optional count)
 863   "Save the current message to an IMAP folder.
 864 Prefix arg COUNT means save this message and the next COUNT-1
 865 messages.  A negative COUNT means save this message and the
 866 previous COUNT-1 messages.
 867
 868 When invoked on marked messages (via vm-next-command-uses-marks),
 869 all marked messages in the current folder are saved; other messages are
 870 ignored.
 871
 872 The saved messages are flagged as `filed'."
 873   (interactive
 874    (save-excursion
 875      (vm-session-initialization)
 876      (vm-check-for-killed-folder)
 877      (vm-select-folder-buffer-if-possible)
 878      (let ((this-command this-command)
 879            (last-command last-command))
 880        (list (vm-read-imap-folder-name "Save to IMAP folder: "
 881                                        vm-imap-server-list t)
 882              (prefix-numeric-value current-prefix-arg)))))
 883   (vm-select-folder-buffer)
 884   (vm-check-for-killed-summary)
 885   (vm-error-if-folder-empty)
 886   (vm-display nil nil '(vm-save-message-to-imap-folder)
 887               '(vm-save-message-to-imap-folder))
 888   (or count (setq count 1))
 889   (let ((mlist (vm-select-marked-or-prefixed-messages count))
 890         process m
 891         (mailbox (nth 3 (vm-imap-parse-spec-to-list folder)))
 892         (count 0))
 893     (unwind-protect
 894         (save-excursion
 895           (setq process (vm-imap-make-session folder))
 896           (set-buffer (process-buffer process))
 897           (while mlist
 898             (setq m (car mlist))
 899             (vm-imap-save-message process m mailbox)
 900             (when (null (vm-filed-flag m))
 901                 (vm-set-filed-flag m t))
 902             (vm-increment count)
 903             (vm-modify-folder-totals folder 'saved 1 m)
 904             (setq mlist (cdr mlist))))
 905       (and process (vm-imap-end-session process)))
 906     (vm-update-summary-and-mode-line)
 907     (message "%d message%s saved to %s"
 908              count (if (/= 1 count) "s" "")
 909              (vm-safe-imapdrop-string folder))
 910     (when (and vm-delete-after-saving (not vm-folder-read-only))
 911         (vm-delete-message count))
 912     folder ))
 913
 914 (provide 'vm-save)
 915
 916 ;;; vm-save.el ends here