Mercurial > hg > xemacs-beta

comparison lisp/vm/vm-save.el @ 70:131b0175ea99 r20-0b30

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-0b30
author cvs
date Mon, 13 Aug 2007 09:02:59 +0200
parents 05472e90ae02
children 0d2f883870bc
comparison
equal deleted inserted replaced
69:804d1389bcd6 70:131b0175ea99
33 (condition-case error-data 33 (condition-case error-data
34 (catch 'match 34 (catch 'match
35 (let (header alist tuple-list) 35 (let (header alist tuple-list)
36 (setq alist auto-folder-alist) 36 (setq alist auto-folder-alist)
37 (while alist 37 (while alist
38 (setq header (vm-get-header-contents (car mp) (car (car alist)) 38 (setq header (vm-get-header-contents (car mp) (car (car alist))))
39 ", "))
40 (if (null header) 39 (if (null header)
41 () 40 ()
42 (setq tuple-list (cdr (car alist))) 41 (setq tuple-list (cdr (car alist)))
43 (while tuple-list 42 (while tuple-list
44 (if (let ((case-fold-search vm-auto-folder-case-fold-search)) 43 (if (let ((case-fold-search vm-auto-folder-case-fold-search))
96 The saved messages are flagged as `filed'." 95 The saved messages are flagged as `filed'."
97 (interactive "P") 96 (interactive "P")
98 (vm-select-folder-buffer) 97 (vm-select-folder-buffer)
99 (vm-check-for-killed-summary) 98 (vm-check-for-killed-summary)
100 (vm-error-if-folder-empty) 99 (vm-error-if-folder-empty)
101 (message "Archiving...") 100 (vm-unsaved-message "Archiving...")
102 (let ((auto-folder) 101 (let ((auto-folder)
103 (archived 0)) 102 (archived 0))
104 (unwind-protect 103 (unwind-protect
105 ;; Need separate (let ...) so vm-message-pointer can 104 ;; Need separate (let ...) so vm-message-pointer can
106 ;; revert back in time for 105 ;; revert back in time for
130 (y-or-n-p 129 (y-or-n-p
131 (format "Save message %s in folder %s? " 130 (format "Save message %s in folder %s? "
132 (vm-number-of (car vm-message-pointer)) 131 (vm-number-of (car vm-message-pointer))
133 auto-folder))) 132 auto-folder)))
134 (let ((vm-delete-after-saving vm-delete-after-archiving)) 133 (let ((vm-delete-after-saving vm-delete-after-archiving))
135 (vm-save-message auto-folder) 134 (if (not (string-equal auto-folder "/dev/null"))
135 (vm-save-message auto-folder))
136 (vm-increment archived) 136 (vm-increment archived)
137 (message "%d archived, still working..." archived))) 137 (vm-unsaved-message "%d archived, still working..."
138 archived)))
138 (setq done (eq vm-message-pointer stop-point) 139 (setq done (eq vm-message-pointer stop-point)
139 vm-message-pointer (cdr vm-message-pointer)))) 140 vm-message-pointer (cdr vm-message-pointer))))
140 ;; fix mode line 141 ;; fix mode line
141 (intern (buffer-name) vm-buffers-needing-display-update) 142 (intern (buffer-name) vm-buffers-needing-display-update)
142 (vm-update-summary-and-mode-line)) 143 (vm-update-summary-and-mode-line))
143 (if (zerop archived) 144 (if (zerop archived)
144 (message "No messages were archived") 145 (message "No messages archived")
145 (message "%d message%s archived" 146 (message "%d message%s archived"
146 archived (if (= 1 archived) "" "s"))))) 147 archived (if (= 1 archived) "" "s")))))
147 148
148 (defun vm-save-message (folder &optional count) 149 (defun vm-save-message (folder &optional count)
149 "Save the current message to a mail folder. 150 "Save the current message to a mail folder.
430 (buffer-name file-buffer)) 431 (buffer-name file-buffer))
431 (message "Message%s written to %s" (if (/= 1 count) "s" "") file))) 432 (message "Message%s written to %s" (if (/= 1 count) "s" "") file)))
432 (setq vm-last-written-file file))) 433 (setq vm-last-written-file file)))
433 434
434 (defun vm-pipe-message-to-command (command prefix-arg) 435 (defun vm-pipe-message-to-command (command prefix-arg)
435 "Runs a shell command with some or all of the contents of the 436 "Run shell command with the some or all of the current message as input.
436 current message as input. 437 By default the entire message is used.
437 By default, the entire message is used.
438 With one \\[universal-argument] the text portion of the message is used. 438 With one \\[universal-argument] the text portion of the message is used.
439 With two \\[universal-argument]'s the header portion of the message is used. 439 With two \\[universal-argument]'s the header portion of the message is used.
440 With three \\[universal-argument]'s the visible header portion of the message 440 With three \\[universal-argument]'s the visible header portion of the message
441 plus the text portion is used. 441 plus the text portion is used.
442 442
484 (narrow-to-region (vm-vheaders-of m) (vm-text-end-of m))) 484 (narrow-to-region (vm-vheaders-of m) (vm-text-end-of m)))
485 (t (narrow-to-region (point) (vm-text-end-of m)))) 485 (t (narrow-to-region (point) (vm-text-end-of m))))
486 (let ((pop-up-windows (and pop-up-windows (eq vm-mutable-windows t)))) 486 (let ((pop-up-windows (and pop-up-windows (eq vm-mutable-windows t))))
487 (call-process-region (point-min) (point-max) 487 (call-process-region (point-min) (point-max)
488 (or shell-file-name "sh") 488 (or shell-file-name "sh")
489 nil buffer nil shell-command-switch command))) 489 nil buffer nil "-c" command)))
490 (setq mlist (cdr mlist))) 490 (setq mlist (cdr mlist)))
491 (set-buffer buffer) 491 (set-buffer buffer)
492 (if (not (zerop (buffer-size))) 492 (if (not (zerop (buffer-size)))
493 (vm-display buffer t '(vm-pipe-message-to-command) 493 (vm-display buffer t '(vm-pipe-message-to-command)
494 '(vm-pipe-message-to-command)) 494 '(vm-pipe-message-to-command))
495 (vm-display nil nil '(vm-pipe-message-to-command) 495 (vm-display nil nil '(vm-pipe-message-to-command)
496 '(vm-pipe-message-to-command))))) 496 '(vm-pipe-message-to-command)))))
497 497
498 (defun vm-print-message (&optional count) 498 (defun vm-print-message ()
499 "Print the current message 499 "Print the current message."
500 Prefix arg N means print the current message and the next N - 1 messages. 500 (interactive)
501 Prefix arg -N means print the current message and the previous N - 1 messages. 501 (vm-pipe-message-to-command
502 502 (mapconcat (function identity)
503 The variable `vm-print-command' controls what command is run to 503 (nconc (list vm-print-command) vm-print-command-switches)
504 print the message, and `vm-print-command-switches' is a list of switches 504 " ")
505 to pass to the command. 505 '(64)))
506 506
507 When invoked on marked messages (via vm-next-command-uses-marks),
508 each marked message is printed, one message per vm-print-command invocation.
509
510 Output, if any, is displayed. The message is not altered."
511 (interactive "p")
512 (vm-follow-summary-cursor)
513 (vm-select-folder-buffer)
514 (vm-check-for-killed-summary)
515 (vm-error-if-folder-empty)
516 (or count (setq count 1))
517 (let ((buffer (get-buffer-create "*Shell Command Output*"))
518 (command (mapconcat (function identity)
519 (nconc (list vm-print-command)
520 vm-print-command-switches)
521 " "))
522 (m nil)
523 (pop-up-windows (and pop-up-windows (eq vm-mutable-windows t)))
524 (mlist (vm-select-marked-or-prefixed-messages count)))
525 (set-buffer buffer)
526 (erase-buffer)
527 (while mlist
528 (setq m (vm-real-message-of (car mlist)))
529 (set-buffer (vm-buffer-of m))
530 (if (and vm-display-using-mime (vectorp (vm-mm-layout m)))
531 (let ((work-buffer nil))
532 (unwind-protect
533 (progn
534 (setq work-buffer (generate-new-buffer "*vm-work*"))
535 (set-buffer work-buffer)
536 (vm-insert-region-from-buffer
537 (vm-buffer-of m) (vm-vheaders-of m) (vm-text-of m))
538 (vm-decode-mime-encoded-words)
539 (goto-char (point-max))
540 (let ((vm-auto-displayed-mime-content-types
541 '("text" "multipart"))
542 (vm-mime-internal-content-types
543 '("text" "multipart"))
544 (vm-mime-external-content-types-alist nil))
545 (vm-decode-mime-layout (vm-mm-layout m)))
546 (let ((pop-up-windows (and pop-up-windows
547 (eq vm-mutable-windows t))))
548 (call-process-region (point-min) (point-max)
549 (or shell-file-name "sh")
550 nil buffer nil
551 shell-command-switch command)))
552 (and work-buffer (kill-buffer work-buffer))))
553 (save-restriction
554 (widen)
555 (narrow-to-region (vm-vheaders-of m) (vm-text-end-of m))
556 (let ((pop-up-windows (and pop-up-windows
557 (eq vm-mutable-windows t))))
558 (call-process-region (point-min) (point-max)
559 (or shell-file-name "sh")
560 nil buffer nil
561 shell-command-switch command))))
562 (setq mlist (cdr mlist)))
563 (set-buffer buffer)
564 (if (not (zerop (buffer-size)))
565 (vm-display buffer t '(vm-pipe-message-to-command)
566 '(vm-pipe-message-to-command))
567 (vm-display nil nil '(vm-pipe-message-to-command)
568 '(vm-pipe-message-to-command)))))