home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / vm / vm-save.el < prev    next >
Encoding:
Text File  |  1995-07-28  |  18.1 KB  |  507 lines
  1. ;;; Saving and piping messages under VM
  2. ;;; Copyright (C) 1989, 1990, 1993, 1994 Kyle E. Jones
  3. ;;;
  4. ;;; This program is free software; you can redistribute it and/or modify
  5. ;;; it under the terms of the GNU General Public License as published by
  6. ;;; the Free Software Foundation; either version 1, or (at your option)
  7. ;;; any later version.
  8. ;;;
  9. ;;; This program is distributed in the hope that it will be useful,
  10. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12. ;;; GNU General Public License for more details.
  13. ;;;
  14. ;;; You should have received a copy of the GNU General Public License
  15. ;;; along with this program; if not, write to the Free Software
  16. ;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  17.  
  18. (provide 'vm-save)
  19.  
  20. ;; (match-data) returns the match data as MARKERS, often corrupting
  21. ;; it in the process due to buffer narrowing, and the fact that buffers are
  22. ;; indexed from 1 while strings are indexed from 0. :-(
  23. (defun vm-match-data ()
  24.   (let ((index '(9 8 7 6 5 4 3 2 1 0))
  25.         (list))
  26.     (while index
  27.       (setq list (cons (match-beginning (car index))
  28.                (cons (match-end (car index)) list))
  29.         index (cdr index)))
  30.     list ))
  31.  
  32. (defun vm-auto-select-folder (mp auto-folder-alist)
  33.   (condition-case error-data
  34.       (catch 'match
  35.     (let (header alist tuple-list)
  36.       (setq alist auto-folder-alist)
  37.       (while alist
  38.         (setq header (vm-get-header-contents (car mp) (car (car alist))))
  39.         (if (null header)
  40.         ()
  41.           (setq tuple-list (cdr (car alist)))
  42.           (while tuple-list
  43.         (if (let ((case-fold-search vm-auto-folder-case-fold-search))
  44.               (string-match (car (car tuple-list)) header))
  45.             ;; Don't waste time eval'ing an atom.
  46.             (if (atom (cdr (car tuple-list)))
  47.             (throw 'match (cdr (car tuple-list)))
  48.               (let* ((match-data (vm-match-data))
  49.                  ;; allow this buffer to live forever
  50.                  (buf (get-buffer-create " *vm-auto-folder*"))
  51.                  (result))
  52.             ;; Set up a buffer that matches our cached
  53.             ;; match data.
  54.             (save-excursion
  55.               (set-buffer buf)
  56.               (widen)
  57.               (erase-buffer)
  58.               (insert header)
  59.               ;; It appears that get-buffer-create clobbers the
  60.               ;; match-data.
  61.               ;;
  62.               ;; The match data is off by one because we matched
  63.               ;; a string and Emacs indexes strings from 0 and
  64.               ;; buffers from 1.
  65.               ;;
  66.               ;; Also store-match-data only accepts MARKERS!!
  67.               ;; AUGHGHGH!!
  68.               (store-match-data
  69.                (mapcar
  70.                 (function (lambda (n) (and n (vm-marker n))))
  71.                 (mapcar
  72.                  (function (lambda (n) (and n (1+ n))))
  73.                  match-data)))
  74.               (setq result (eval (cdr (car tuple-list))))
  75.               (while (consp result)
  76.                 (setq result (vm-auto-select-folder mp result)))
  77.               (if result
  78.                   (throw 'match result))))))
  79.         (setq tuple-list (cdr tuple-list))))
  80.         (setq alist (cdr alist)))
  81.       nil ))
  82.     (error (error "error processing vm-auto-folder-alist: %s"
  83.           (prin1-to-string error-data)))))
  84.  
  85. (defun vm-auto-archive-messages (&optional arg)
  86.   "Save all unfiled messages that auto-match a folder via
  87. vm-auto-folder-alist to their appropriate folders.  Messages that
  88. are flagged for deletion are not saved.
  89.  
  90. Prefix arg means to ask user for confirmation before saving each message.
  91.  
  92. When invoked on marked messages (via vm-next-command-uses-marks),
  93. only marked messages are checked against vm-auto-folder-alist.
  94.  
  95. The saved messages are flagged as `filed'."
  96.   (interactive "P")
  97.   (vm-select-folder-buffer)
  98.   (vm-check-for-killed-summary)
  99.   (vm-error-if-folder-empty)
  100.   (vm-unsaved-message "Archiving...")
  101.   (let ((auto-folder)
  102.     (archived 0))
  103.     (unwind-protect
  104.     ;; Need separate (let ...) so vm-message-pointer can
  105.     ;; revert back in time for
  106.     ;; (vm-update-summary-and-mode-line).
  107.     ;; vm-last-save-folder is tucked away here since archives
  108.     ;; shouldn't affect its value.
  109.     (let ((vm-message-pointer
  110.            (if (eq last-command 'vm-next-command-uses-marks)
  111.            (vm-select-marked-or-prefixed-messages 0)
  112.          vm-message-list))
  113.           (done nil)
  114.           stop-point
  115.           (vm-last-save-folder vm-last-save-folder)
  116.           (vm-move-after-deleting nil))
  117.       ;; mark the place where we should stop.  otherwise if any
  118.       ;; messages in this folder are archived to this folder
  119.       ;; we would file messages into this folder forever.
  120.       (setq stop-point (vm-last vm-message-pointer))
  121.       (while (not done)
  122.         (and (not (vm-filed-flag (car vm-message-pointer)))
  123.          ;; don't archive deleted messages
  124.          (not (vm-deleted-flag (car vm-message-pointer)))
  125.          (setq auto-folder (vm-auto-select-folder
  126.                     vm-message-pointer
  127.                     vm-auto-folder-alist))
  128.          (or (null arg)
  129.              (y-or-n-p
  130.               (format "Save message %s in folder %s? "
  131.                   (vm-number-of (car vm-message-pointer))
  132.                   auto-folder)))
  133.          (let ((vm-delete-after-saving vm-delete-after-archiving))
  134.            (if (not (string-equal auto-folder "/dev/null"))
  135.                (vm-save-message auto-folder))
  136.            (vm-increment archived)
  137.            (vm-unsaved-message "%d archived, still working..."
  138.                        archived)))
  139.         (setq done (eq vm-message-pointer stop-point)
  140.           vm-message-pointer (cdr vm-message-pointer))))
  141.       ;; fix mode line
  142.       (intern (buffer-name) vm-buffers-needing-display-update)
  143.       (vm-update-summary-and-mode-line))
  144.     (if (zerop archived)
  145.     (message "No messages archived")
  146.       (message "%d message%s archived"
  147.            archived (if (= 1 archived) "" "s")))))
  148.  
  149. (defun vm-save-message (folder &optional count)
  150.   "Save the current message to a mail folder.
  151. If the folder already exists, the message will be appended to it.
  152.  
  153. Prefix arg COUNT means save this message and the next COUNT-1
  154. messages.  A negative COUNT means save this message and the
  155. previous COUNT-1 messages.
  156.  
  157. When invoked on marked messages (via vm-next-command-uses-marks),
  158. all marked messages in the current folder are saved; other messages are
  159. ignored.
  160.  
  161. The saved messages are flagged as `filed'."
  162.   (interactive
  163.    (list
  164.     ;; protect value of last-command
  165.     (let ((last-command last-command)
  166.       (this-command this-command))
  167.       (vm-follow-summary-cursor)
  168.       (let ((default (save-excursion
  169.                (vm-select-folder-buffer)
  170.                (vm-check-for-killed-summary)
  171.                (vm-error-if-folder-empty)
  172.                (or (vm-auto-select-folder vm-message-pointer
  173.                           vm-auto-folder-alist)
  174.                vm-last-save-folder)))
  175.         (dir (or vm-folder-directory default-directory)))
  176.     (cond ((and default
  177.             (let ((default-directory dir))
  178.               (file-directory-p default)))
  179.            (vm-read-file-name "Save in folder: " dir nil nil default))
  180.           (default
  181.            (vm-read-file-name
  182.         (format "Save in folder: (default %s) " default)
  183.         dir default))
  184.           (t
  185.            (vm-read-file-name "Save in folder: " dir nil)))))
  186.     (prefix-numeric-value current-prefix-arg)))
  187.   (let (unexpanded-folder)
  188.     (setq unexpanded-folder folder)
  189.     (vm-select-folder-buffer)
  190.     (vm-check-for-killed-summary)
  191.     (vm-error-if-folder-empty)
  192.     (vm-display nil nil '(vm-save-message) '(vm-save-message))
  193.     (or count (setq count 1))
  194.     ;; Expand the filename, forcing relative paths to resolve
  195.     ;; into the folder directory.
  196.     (let ((default-directory
  197.         (expand-file-name (or vm-folder-directory default-directory))))
  198.       (setq folder (expand-file-name folder)))
  199.     ;; Confirm new folders, if the user requested this.
  200.     (if (and vm-confirm-new-folders (interactive-p)
  201.          (not (file-exists-p folder))
  202.          (or (not vm-visit-when-saving) (not (vm-get-file-buffer folder)))
  203.          (not (y-or-n-p (format "%s does not exist, save there anyway? "
  204.                     folder))))
  205.     (error "Save aborted"))
  206.     ;; Check and see if we are currently visiting the folder
  207.     ;; that the user wants to save to.
  208.     (if (and (not vm-visit-when-saving) (vm-get-file-buffer folder))
  209.     (error "Folder %s is being visited, cannot save." folder))
  210.     (let ((mlist (vm-select-marked-or-prefixed-messages count))
  211.       (m nil) (count 0) folder-buffer target-type)
  212.       (cond ((and mlist (eq vm-visit-when-saving t))
  213.          (setq folder-buffer (or (vm-get-file-buffer folder)
  214.                      ;; avoid letter bombs
  215.                      (let ((inhibit-local-variables t)
  216.                        (enable-local-variables nil))
  217.                        (find-file-noselect folder)))))
  218.         ((and mlist vm-visit-when-saving)
  219.          (setq folder-buffer (vm-get-file-buffer folder))))
  220.       (if (and mlist vm-check-folder-types)
  221.       (progn
  222.         (setq target-type (or (vm-get-folder-type folder)
  223.                   vm-default-folder-type
  224.                   (and mlist
  225.                        (vm-message-type-of (car mlist)))))
  226.         (if (eq target-type 'unknown)
  227.         (error "Folder %s's type is unrecognized" folder))))
  228.       ;; if target folder is empty or nonexistent we need to
  229.       ;; write out the folder header first.
  230.       (if mlist
  231.       (let ((attrs (file-attributes folder)))
  232.         (if (or (null attrs) (= 0 (nth 7 attrs)))
  233.         (if (null folder-buffer)
  234.             (vm-write-string folder (vm-folder-header target-type))
  235.           (vm-write-string folder-buffer
  236.                    (vm-folder-header target-type))))))
  237.       (save-excursion
  238.     (while mlist
  239.       (setq m (vm-real-message-of (car mlist)))
  240.       (set-buffer (vm-buffer-of m))
  241.       (vm-save-restriction
  242.        (widen)
  243.        ;; have to stuff the attributes in all cases because
  244.        ;; the deleted attribute may have been stuffed
  245.        ;; previously and we don't want to save that attribute.
  246.        ;; also we don't want to save out the cached summary entry.
  247.        (vm-stuff-attributes m t)
  248.        (if (null folder-buffer)
  249.            (if (or (null vm-check-folder-types)
  250.                (eq target-type (vm-message-type-of m)))
  251.            (write-region (vm-start-of m)
  252.                  (vm-end-of m)
  253.                  folder t 'quiet)
  254.          (if (null vm-convert-folder-types)
  255.              (if (not (vm-virtual-message-p (car mlist)))
  256.              (error "Folder type mismatch: %s, %s"
  257.                 (vm-message-type-of m) target-type)
  258.                (error "Message %s type mismatches folder %s"
  259.                   (vm-number-of (car mlist))
  260.                   folder
  261.                   (vm-message-type-of m)
  262.                   target-type))
  263.            (vm-write-string
  264.             folder
  265.             (vm-leading-message-separator target-type m t))
  266.            (if (eq target-type 'From_-with-Content-Length)
  267.                (vm-write-string
  268.             folder
  269.             (concat vm-content-length-header " "
  270.                 (vm-su-byte-count m) "\n")))
  271.            (write-region (vm-headers-of m)
  272.                  (vm-text-end-of m)
  273.                  folder t 'quiet)
  274.            (vm-write-string
  275.             folder
  276.             (vm-trailing-message-separator target-type))))
  277.          (save-excursion
  278.            (set-buffer folder-buffer)
  279.            ;; if the buffer is a live VM folder
  280.            ;; honor vm-folder-read-only.
  281.            (if vm-folder-read-only
  282.            (signal 'folder-read-only (list (current-buffer))))
  283.            (let ((buffer-read-only nil))
  284.          (vm-save-restriction
  285.           (widen)
  286.           (save-excursion
  287.             (goto-char (point-max))
  288.             (if (or (null vm-check-folder-types)
  289.                 (eq target-type (vm-message-type-of m)))
  290.             (insert-buffer-substring
  291.              (vm-buffer-of m)
  292.              (vm-start-of m) (vm-end-of m))
  293.               (if (null vm-convert-folder-types)
  294.               (if (not (vm-virtual-message-p (car mlist)))
  295.                   (error "Folder type mismatch: %s, %s"
  296.                      (vm-message-type-of m) target-type)
  297.                 (error "Message %s type mismatches folder %s"
  298.                    (vm-number-of (car mlist))
  299.                    folder
  300.                    (vm-message-type-of m)
  301.                    target-type))
  302.             (vm-write-string
  303.              (current-buffer)
  304.              (vm-leading-message-separator target-type m t))
  305.             (if (eq target-type 'From_-with-Content-Length)
  306.                 (vm-write-string
  307.                  (current-buffer)
  308.                  (concat vm-content-length-header " "
  309.                      (vm-su-byte-count m) "\n")))
  310.             (insert-buffer-substring (vm-buffer-of m)
  311.                          (vm-headers-of m)
  312.                          (vm-text-end-of m))
  313.             (vm-write-string
  314.              (current-buffer)
  315.              (vm-trailing-message-separator target-type)))))
  316.           ;; vars should exist and be local
  317.           ;; but they may have strange values,
  318.           ;; so check the major-mode.
  319.           (cond ((eq major-mode 'vm-mode)
  320.              (vm-increment vm-messages-not-on-disk)
  321.              (vm-clear-modification-flag-undos)))))))
  322.        (if (null (vm-filed-flag m))
  323.            (vm-set-filed-flag m t))
  324.        (vm-increment count)
  325.        (vm-update-summary-and-mode-line)
  326.        (setq mlist (cdr mlist)))))
  327.       (if m
  328.       (if folder-buffer
  329.           (progn
  330.         (save-excursion
  331.           (set-buffer folder-buffer)
  332.           (if (eq major-mode 'vm-mode)
  333.               (progn
  334.             (vm-check-for-killed-summary)
  335.             (vm-assimilate-new-messages)
  336.             (if (null vm-message-pointer)
  337.                 (progn (setq vm-message-pointer vm-message-list
  338.                      vm-need-summary-pointer-update t)
  339.                    (intern (buffer-name)
  340.                        vm-buffers-needing-display-update)
  341.                    (vm-preview-current-message))
  342.               (vm-update-summary-and-mode-line)))))
  343.         (if (interactive-p)
  344.             (message "%d message%s saved to buffer %s"
  345.                  count
  346.                  (if (/= 1 count) "s" "")
  347.                  (buffer-name folder-buffer))))
  348.         (if (interactive-p)
  349.         (message "%d message%s saved to %s"
  350.              count (if (/= 1 count) "s" "") folder)))))
  351.     (setq vm-last-save-folder unexpanded-folder)
  352.     (if vm-delete-after-saving
  353.     (vm-delete-message count))))
  354.  
  355. (defun vm-save-message-sans-headers (file &optional count)
  356.   "Save the current message to a file, without its header section.
  357. If the file already exists, the message will be appended to it.
  358. Prefix arg COUNT means save the next COUNT messages.  A negative COUNT means
  359. save the previous COUNT.
  360.  
  361. When invoked on marked messages (via vm-next-command-uses-marks),
  362. all marked messages in the current folder are saved; other messages are
  363. ignored.
  364.  
  365. The saved messages are flagged as `written'.
  366.  
  367. This command should NOT be used to save message to mail folders; use
  368. vm-save-message instead (normally bound to `s')."
  369.   (interactive
  370.    ;; protect value of last-command
  371.    (let ((last-command last-command)
  372.      (this-command this-command))
  373.      (vm-follow-summary-cursor)
  374.      (vm-select-folder-buffer)
  375.      (list
  376.       (vm-read-file-name
  377.        (if vm-last-written-file
  378.        (format "Write text to file: (default %s) "
  379.            vm-last-written-file)
  380.      "Write text to file: ")
  381.        nil vm-last-written-file nil)
  382.       (prefix-numeric-value current-prefix-arg))))
  383.   (vm-select-folder-buffer)
  384.   (vm-check-for-killed-summary)
  385.   (vm-error-if-folder-empty)
  386.   (vm-display nil nil '(vm-save-message-sans-headers)
  387.           '(vm-save-message-sans-headers))
  388.   (or count (setq count 1))
  389.   (setq file (expand-file-name file))
  390.   ;; Check and see if we are currently visiting the file
  391.   ;; that the user wants to save to.
  392.   (if (and (not vm-visit-when-saving) (vm-get-file-buffer file))
  393.       (error "File %s is being visited, cannot save." file))
  394.   (let ((mlist (vm-select-marked-or-prefixed-messages count))
  395.     (m nil) file-buffer)
  396.     (cond ((and mlist (eq vm-visit-when-saving t))
  397.        (setq file-buffer (or (vm-get-file-buffer file)
  398.                  (find-file-noselect file))))
  399.       ((and mlist vm-visit-when-saving)
  400.        (setq file-buffer (vm-get-file-buffer file))))
  401.     (save-excursion
  402.       (while mlist
  403.     (setq m (vm-real-message-of (car mlist)))
  404.     (set-buffer (vm-buffer-of m))
  405.     (vm-save-restriction
  406.      (widen)
  407.      (if (null file-buffer)
  408.          (write-region (vm-text-of m)
  409.                (vm-text-end-of m)
  410.                file t 'quiet)
  411.        (let ((start (vm-text-of m))
  412.          (end (vm-text-end-of m)))
  413.          (save-excursion
  414.            (set-buffer file-buffer)
  415.            (save-excursion
  416.          (let (buffer-read-only)
  417.            (vm-save-restriction
  418.             (widen)
  419.             (save-excursion
  420.               (goto-char (point-max))
  421.               (insert-buffer-substring
  422.                (vm-buffer-of m)
  423.                start end))))))))
  424.     (if (null (vm-written-flag m))
  425.         (vm-set-written-flag m t))
  426.     (vm-update-summary-and-mode-line)
  427.     (setq mlist (cdr mlist)))))
  428.     (if m
  429.     (if file-buffer
  430.         (message "Message%s written to buffer %s" (if (/= 1 count) "s" "")
  431.              (buffer-name file-buffer))
  432.       (message "Message%s written to %s" (if (/= 1 count) "s" "") file)))
  433.     (setq vm-last-written-file file)))
  434.  
  435. (defun vm-pipe-message-to-command (command prefix-arg)
  436.   "Run shell command with the some or all of the current message as input.
  437. By default the entire 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.
  440. With three \\[universal-argument]'s the visible header portion of the message
  441.   plus the text portion is used.
  442.  
  443. When invoked on marked messages (via vm-next-command-uses-marks),
  444. each marked message is successively piped to the shell command,
  445. one message per command invocation.
  446.  
  447. Output, if any, is displayed.  The message is not altered."
  448.   (interactive
  449.    ;; protect value of last-command
  450.    (let ((last-command last-command)
  451.      (this-command this-command))
  452.      (vm-follow-summary-cursor)
  453.      (vm-select-folder-buffer)
  454.      (list (read-string "Pipe to command: " vm-last-pipe-command)
  455.        current-prefix-arg)))
  456.   (vm-select-folder-buffer)
  457.   (vm-check-for-killed-summary)
  458.   (vm-error-if-folder-empty)
  459.   (setq vm-last-pipe-command command)
  460.   (let ((buffer (get-buffer-create "*Shell Command Output*"))
  461.     m
  462.     (pop-up-windows (and pop-up-windows (eq vm-mutable-windows t)))
  463.     ;; prefix arg doesn't have "normal" meaning here, so only call
  464.     ;; vm-select-marked-or-prefixed-messages if we're using marks.
  465.     (mlist (if (eq last-command 'vm-next-command-uses-marks)
  466.            (vm-select-marked-or-prefixed-messages 0)
  467.          (list (car vm-message-pointer)))))
  468.     (set-buffer buffer)
  469.     (erase-buffer)
  470.     (while mlist
  471.       (setq m (vm-real-message-of (car mlist)))
  472.       (set-buffer (vm-buffer-of m))
  473.       (save-restriction
  474.     (widen)
  475.     (goto-char (vm-headers-of m))
  476.     (cond ((equal prefix-arg nil)
  477.            (narrow-to-region (point) (vm-text-end-of m)))
  478.           ((equal prefix-arg '(4))
  479.            (narrow-to-region (vm-text-of m)
  480.                  (vm-text-end-of m)))
  481.           ((equal prefix-arg '(16))
  482.            (narrow-to-region (point) (vm-text-of m)))
  483.           ((equal prefix-arg '(64))
  484.            (narrow-to-region (vm-vheaders-of m) (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))))
  487.       (call-process-region (point-min) (point-max)
  488.                    (or shell-file-name "sh")
  489.                    nil buffer nil "-c" command)))
  490.       (setq mlist (cdr mlist)))
  491.      (set-buffer buffer)
  492.      (if (not (zerop (buffer-size)))
  493.      (vm-display buffer t '(vm-pipe-message-to-command)
  494.              '(vm-pipe-message-to-command))
  495.        (vm-display nil nil '(vm-pipe-message-to-command)
  496.            '(vm-pipe-message-to-command)))))
  497.  
  498. (defun vm-print-message ()
  499.   "Print the current message."
  500.   (interactive)
  501.   (vm-pipe-message-to-command
  502.    (mapconcat (function identity)
  503.           (nconc (list vm-print-command) vm-print-command-switches)
  504.           " ")
  505.    '(64)))
  506.  
  507.