home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / gnu / lucid / lemacs-19.6 / lisp / vm / vm-folder.el < prev    next >
Encoding:
Text File  |  1992-10-22  |  53.7 KB  |  1,540 lines
  1. ;;; VM folder related functions
  2. ;;; Copyright (C) 1989, 1990, 1991 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. (defun vm-number-messages (&optional start-point end-point)
  19.   (let ((n 1) (message-list (or start-point vm-message-list)))
  20.     (if (and start-point (vm-reverse-link-of (car start-point)))
  21.     (setq n (1+ (string-to-int
  22.              (vm-number-of
  23.               (car
  24.                (vm-reverse-link-of
  25.             (car start-point))))))))
  26.     (while (not (eq message-list end-point))
  27.       (vm-set-number-of (car message-list) (int-to-string n))
  28.       (setq n (1+ n) message-list (cdr message-list)))
  29.     (or end-point (setq vm-ml-highest-message-number (int-to-string (1- n))))
  30.     (if vm-summary-buffer
  31.     (vm-copy-local-variables vm-summary-buffer
  32.                  'vm-ml-highest-message-number))))
  33.  
  34. (defun vm-do-needed-renumbering ()
  35.   (if vm-numbering-redo-start-point
  36.       (progn
  37.     (vm-number-messages (and (consp vm-numbering-redo-start-point)
  38.                  vm-numbering-redo-start-point)
  39.                 vm-numbering-redo-end-point)
  40.     (setq vm-numbering-redo-start-point nil
  41.           vm-numbering-redo-end-point nil))))
  42.  
  43. (defun vm-reverse-link-messages ()
  44.   (let ((mp vm-message-list) prev)
  45.     (while mp
  46.       (vm-set-reverse-link-of (car mp) prev)
  47.       (setq prev mp mp (cdr mp)))))
  48.  
  49. (defun vm-match-visible-header (alist)
  50.   (catch 'match
  51.     (while alist
  52.       (if (looking-at (car (car alist)))
  53.       (throw 'match (car alist)))
  54.       (setq alist (cdr alist)))
  55.     nil))
  56.  
  57. (defun vm-get-folder-type ()
  58.   (save-excursion
  59.     (save-restriction
  60.       (widen)
  61.       (goto-char (point-min))
  62.       (skip-chars-forward "\n")
  63.       (cond ((looking-at "From ") 'From_)
  64.         ((looking-at "\001\001\001\001\n") 'mmdf)
  65.         ((looking-at "^$") 'From_)))))
  66.  
  67. ;; Build a chain of message structures.
  68. ;; Find the start and end of each message and fill in the relevant
  69. ;; fields in the message structures.
  70.  
  71. (defun vm-build-message-list (&optional rebuild-markers)
  72.   ;; sanity check
  73.   (if rebuild-markers
  74.       (setq rebuild-markers vm-message-list))
  75.   (save-excursion
  76.     (vm-build-visible-header-alist)
  77.     (let (tail-cons message prev-message case-fold-search list marker
  78.       start-regexp sep-pattern trailer-length)
  79.       (if (eq vm-folder-type 'mmdf)
  80.       (setq start-regexp "^\001\001\001\001\n"
  81.         separator-string "\n\001\001\001\001\n\001\001\001\001"
  82.         trailer-length 6)
  83.     (setq start-regexp "^From "
  84.           separator-string "\n\nFrom "
  85.           trailer-length 2))
  86.       (if (and vm-message-list (not rebuild-markers))
  87.       (let ((mp vm-message-list)
  88.         (end (point-min)))
  89.         (while mp
  90.           (if (< end (vm-end-of (car mp)))
  91.           (setq end (vm-end-of (car mp))))
  92.           (setq mp (cdr mp)))
  93.         ;; move back past trailer so separator-string will match below
  94.         (goto-char (- end trailer-length))
  95.         (setq tail-cons (vm-last vm-message-list)))
  96.     (if rebuild-markers
  97.         (setq list vm-message-list))
  98.     (goto-char (point-min))
  99.     (re-search-forward start-regexp nil 0)
  100.     (goto-char (or (match-beginning 0) (point)))
  101.     (if (looking-at start-regexp)
  102.         (if rebuild-markers
  103.         (progn
  104.           (setq message (car list)
  105.             prev-message message
  106.             tail-cons list
  107.             list (cdr list))
  108.           (vm-set-start-of message (vm-marker (match-beginning 0)))
  109.           (vm-set-vheaders-of message nil)
  110.           (vm-set-text-of message nil))
  111.           (setq message (vm-make-message) prev-message message)
  112.           (vm-set-reverse-link-of message nil)
  113.           (vm-set-start-of message (vm-marker (match-beginning 0)))
  114.           (setq vm-message-list (list message)
  115.             tail-cons vm-message-list))))
  116.       (while (and (or (null rebuild-markers) list)
  117.           (search-forward separator-string nil t))
  118.     (setq marker (vm-marker (+ trailer-length (match-beginning 0)))
  119.           message (or (car list) (vm-make-message)))
  120.     (vm-set-start-of message marker)
  121.     (if prev-message
  122.         (vm-set-end-of prev-message marker))
  123.     (cond (list
  124.            (vm-set-vheaders-of message nil)
  125.            (vm-set-text-of message nil)
  126.            (setq tail-cons list
  127.              list (cdr list)
  128.              prev-message message))
  129.           (tail-cons
  130.            (setcdr tail-cons (list message))
  131.            (vm-set-reverse-link-of message tail-cons)
  132.            (setq tail-cons (cdr tail-cons)
  133.              prev-message message))
  134.           (t
  135.            (vm-set-reverse-link-of message nil)
  136.            (setq vm-message-list (list message)
  137.              tail-cons vm-message-list
  138.              prev-message message))))
  139.       (if prev-message
  140.       (vm-set-end-of prev-message (vm-marker (point-max))))
  141.       ;; If there are still some messages whose markers have not been
  142.       ;; fixed up there is a serious problem.
  143.       ;; The message list will need to be rebuilt from scratch.
  144.       ;; Force this to happen.
  145.       (and rebuild-markers list (setq vm-message-list nil)))))
  146.  
  147. (defun vm-build-visible-header-alist ()
  148.   (let ((header-alist (cons nil nil))
  149.     (vheaders vm-visible-headers)
  150.     list)
  151.     (setq list header-alist)
  152.     (while vheaders
  153.       (setcdr list (cons (cons (car vheaders) nil) nil))
  154.       (setq list (cdr list) vheaders (cdr vheaders)))
  155.     (setq vm-visible-header-alist (cdr header-alist))))
  156.  
  157. ;; Group the headers that the user wants to see at the end of the headers
  158. ;; section so we can narrow to them.  The vheaders field of the
  159. ;; message struct is set.  This function is called on demand whenever
  160. ;; a vheaders field is discovered to be nil for a particular message.
  161.  
  162. (defun vm-reorder-message-headers (message)
  163.   (save-excursion
  164.     ;; if there is a cached regexp that points to the ordered headers
  165.     ;; then use it and avoid a lot of work.
  166.     (if (and (vm-vheaders-regexp-of message)
  167.          (progn (goto-char (vm-start-of message))
  168.             (re-search-forward (vm-vheaders-regexp-of message)
  169.                        (vm-text-of message) t)))
  170.     (vm-set-vheaders-of message (vm-marker (match-beginning 0)))
  171.       ;; oh well, we gotta do it the hard way.
  172.       ;;
  173.       ;; vm-visible-header-alist is an assoc list version of
  174.       ;; vm-visible-headers.  When a matching header is found,
  175.       ;; the header is stuffed into its corresponding assoc cell
  176.       ;; and the header text is deleted from the buffer.  After all
  177.       ;; the visible headers have been collected, they are inserted
  178.       ;; into the buffer in a clump at the end of the header section.
  179.       (vm-save-restriction
  180.        (let ((header-alist vm-visible-header-alist)
  181.          list buffer-read-only match-end-0 extras
  182.          (inhibit-quit t)
  183.          ;; This prevents file locking from occuring.  Disabling
  184.          ;; locking can speed things noticably if the lock directory
  185.          ;; is on a slow device.  We don't need locking here because
  186.          ;; in a mail context reordering headers is harmless.
  187.          (buffer-file-name nil)
  188.          (old-buffer-modified-p (buffer-modified-p)))
  189.      (goto-char (vm-start-of message))
  190.      (forward-line)
  191.      (while (and (not (= (following-char) ?\n))
  192.              (looking-at vm-generic-header-regexp))
  193.        (setq match-end-0 (match-end 0)
  194.          list (vm-match-visible-header header-alist))
  195.        (if (and (null list)
  196.             (or (null vm-invisible-header-regexp)
  197.             (looking-at vm-invisible-header-regexp)))
  198.            (goto-char match-end-0)
  199.          (if list
  200.          (if (cdr list)
  201.              (setcdr list 
  202.                  (concat
  203.                   (cdr list)
  204.                   (buffer-substring (point) match-end-0)))
  205.            (setcdr list (buffer-substring (point) match-end-0)))
  206.            (setq extras
  207.              (cons (buffer-substring (point) match-end-0) extras)))
  208.          (delete-region (point) match-end-0)))
  209.      (vm-set-vheaders-of message (point-marker))
  210.      (save-excursion
  211.        ;; now dump out the visible headers
  212.        ;; the vm-visible-headers go first
  213.        (setq list header-alist)
  214.        (while list
  215.          (if (cdr (car list))
  216.          (progn
  217.            (insert (cdr (car list)))
  218.            (setcdr (car list) nil)))
  219.          (setq list (cdr list)))
  220.        ;; now the headers that were not explicitly ignored, if any.
  221.        (if extras
  222.            (progn
  223.          (setq extras (nreverse extras))
  224.          (while extras
  225.            (insert (car extras))
  226.            (setq extras (cdr extras)))))
  227.        (set-buffer-modified-p old-buffer-modified-p))
  228.      ;; cache a regular expression that can be used to find the start of
  229.      ;; the reordered header the next time this folder is visited.
  230.      (if (looking-at vm-generic-header-regexp)
  231.          (vm-set-vheaders-regexp-of
  232.           message
  233.           (concat "^" (buffer-substring (match-beginning 1) (match-end 1))
  234.               ":"))))))))
  235.  
  236. ;; Reads the message attributes and cached header information from the
  237. ;; header portion of the each message, if our X-VM- attributes header is
  238. ;; present.  If the header is not present, assume the message is new,
  239. ;; unless we are being compatible with Berkeley Mail in which case we
  240. ;; also check for a Status header.
  241. ;;
  242. ;; If a message already has attributes don't bother checking the
  243. ;; headers.
  244. ;;
  245. ;; This function also discovers and stores the position where the
  246. ;; message text begins.
  247. ;;
  248. ;; Totals are gathered for use by vm-emit-totals-blurb.
  249. ;;
  250. ;; Supports version 4 format of attribute storage, for backward compatibility.
  251.  
  252. (defun vm-read-attributes ()
  253.   (save-excursion
  254.     (let ((mp vm-message-list)
  255.       (vm-new-count 0)
  256.       (vm-unread-count 0)
  257.       (vm-total-count 0)
  258.       data)
  259.       (while mp
  260.     (vm-increment vm-total-count)
  261.     (if (vm-attributes-of (car mp))
  262.         ()
  263.       (goto-char (vm-start-of (car mp)))
  264.       ;; find start of text section and save it
  265.       (search-forward "\n\n" (vm-text-end-of (car mp)) 0)
  266.       (vm-set-text-of (car mp) (point-marker))
  267.       ;; now look for our header
  268.       (goto-char (vm-start-of (car mp)))
  269.       (cond
  270.        ((re-search-forward vm-attributes-header-regexp
  271.                    (vm-text-of (car mp)) t)
  272.         (goto-char (match-beginning 2))
  273.         (condition-case ()
  274.         (setq data (read (current-buffer)))
  275.           (error (setq data
  276.                (list
  277.                 (make-vector vm-attributes-vector-length nil)
  278.                 (make-vector vm-cache-vector-length nil)))
  279.              ;; In lieu of a valid attributes header
  280.              ;; assume the message is new.
  281.              (aset (car data) 0 t)))
  282.         ;; support version 4 format
  283.         (cond ((vectorp data)
  284.            (setq data (vm-convert-v4-attributes data)))
  285.           (t
  286.            ;; extend vectors if necessary to accomodate
  287.            ;; more caching and attributes without alienating
  288.            ;; other version 5 folders.
  289.            (cond ((< (length (car data))
  290.                  vm-attributes-vector-length)
  291.               (setcar data (vm-extend-vector
  292.                     (car data)
  293.                     vm-attributes-vector-length))))
  294.            (cond ((< (length (car (cdr data)))
  295.                  vm-cache-vector-length)
  296.               (setcar (cdr data)
  297.                   (vm-extend-vector
  298.                    (car (cdr data))
  299.                    vm-cache-vector-length))))))
  300.         (vm-set-attributes-of (car mp) (car data))
  301.         (vm-set-cache-of (car mp) (car (cdr data))))
  302.        ((and vm-berkeley-mail-compatibility
  303.          (re-search-forward vm-berkeley-mail-status-header-regexp
  304.                     (vm-text-of (car mp)) t))
  305.         (goto-char (match-beginning 1))
  306.         (vm-set-attributes-of
  307.          (car mp)
  308.          (make-vector vm-attributes-vector-length nil))
  309.         (vm-set-unread-flag (car mp) (not (looking-at ".*R.*")) t)
  310.         (vm-set-cache-of (car mp) (make-vector vm-cache-vector-length
  311.                            nil)))
  312.        (t
  313.         (vm-set-attributes-of
  314.          (car mp)
  315.          (make-vector vm-attributes-vector-length nil))
  316.         (vm-set-new-flag (car mp) t t)
  317.         (vm-set-cache-of (car mp) (make-vector vm-cache-vector-length
  318.                            nil)))))
  319.     (cond ((vm-deleted-flag (car mp))) ; don't count deleted messages
  320.           ((vm-new-flag (car mp))
  321.            (vm-increment vm-new-count))
  322.           ((vm-unread-flag (car mp))
  323.            (vm-increment vm-unread-count)))
  324.     (setq mp (cdr mp)))
  325.       (setq vm-totals (list vm-total-count vm-new-count vm-unread-count)))))
  326.  
  327. (defun vm-convert-v4-attributes (data)
  328.   (list (apply 'vector
  329.            (nconc (vm-vector-to-list data)
  330.               (make-list (- vm-attributes-vector-length
  331.                     (length data))
  332.                  nil)))
  333.     (make-vector vm-cache-vector-length nil)))
  334.  
  335. ;; Go to the message specified in a bookmark and eat the bookmark.
  336. ;; Returns non-nil if successful, nil otherwise.
  337. (defun vm-gobble-bookmark ()
  338.   (let ((old-buffer-modified-p (buffer-modified-p))
  339.     buffer-read-only n
  340.     ;; This prevents file locking from occuring.  Disabling
  341.     ;; locking can speed things noticably if the lock
  342.     ;; directory is on a slow device.  We don't need locking
  343.     ;; here because the user shouldn't care about VM removing
  344.     ;; its own status headers.
  345.     (buffer-file-name nil)
  346.     (inhibit-quit t))
  347.     (save-excursion
  348.       (vm-save-restriction
  349.        (let (lim)
  350.      (widen)
  351.      (goto-char (point-min))
  352.      (forward-line)
  353.      (search-forward "\n\n" nil t)
  354.      (setq lim (point))
  355.      (goto-char (point-min))
  356.      (forward-line)
  357.      (if (re-search-forward vm-bookmark-header-regexp lim t)
  358.          (progn
  359.            (setq n (string-to-int
  360.             (buffer-substring (match-beginning 1) (match-end 1))))
  361.            (delete-region (match-beginning 0) (match-end 0))))))
  362.     (set-buffer-modified-p old-buffer-modified-p)
  363.     (if (null n)
  364.     nil
  365.       (condition-case ()
  366.       (vm-goto-message n)
  367.     (error nil))
  368.       t ))))
  369.  
  370. (defun vm-check-header-variables ()
  371.   (save-excursion
  372.     (vm-save-restriction
  373.      (let (lim)
  374.        (widen)
  375.        (goto-char (point-min))
  376.        (forward-line)
  377.        (search-forward "\n\n" nil t)
  378.        (setq lim (point))
  379.        (goto-char (point-min))
  380.        (forward-line)
  381.        (if (re-search-forward vm-vheader-header-regexp lim t)
  382.        (let ((old-buffer-modified-p (buffer-modified-p))
  383.          ;; This prevents file locking from occuring.  Disabling
  384.          ;; locking can speed things noticably if the lock
  385.          ;; directory is on a slow device.  We don't need locking
  386.          ;; here because the user shouldn't care about VM removing
  387.          ;; its own status headers.
  388.          (buffer-file-name nil)
  389.          buffer-read-only vis invis got
  390.          (inhibit-quit t))
  391.          (goto-char (match-beginning 1))
  392.          (condition-case ()
  393.          (setq vis (read (current-buffer))
  394.                invis (read (current-buffer))
  395.                got t)
  396.            (error nil))
  397.          (delete-region (match-beginning 0) (match-end 0))
  398.          ;; if the variables don't match the values stored when this
  399.          ;; folder was saved, then we have to discard any cached
  400.          ;; vheader info so the user will see the right headers.
  401.          (and got (or (not (equal vis vm-visible-headers))
  402.               (not (equal invis vm-invisible-header-regexp)))
  403.           (let ((mp vm-message-list))
  404.             (message "Discarding visible header info...")
  405.             (while mp
  406.               (vm-set-vheaders-regexp-of (car mp) nil)
  407.               (vm-set-vheaders-of (car mp) nil)
  408.               (setq mp (cdr mp)))))
  409.          (set-buffer-modified-p old-buffer-modified-p)))))))
  410.  
  411. ;; Read and delete the header that gives the folder's desired
  412. ;; message order.
  413. (defun vm-gobble-message-order ()
  414.   (let ((old-buffer-modified-p (buffer-modified-p))
  415.     buffer-read-only lim v order
  416.     ;; This prevents file locking from occuring.  Disabling
  417.     ;; locking can speed things noticably if the lock
  418.     ;; directory is on a slow device.  We don't need locking
  419.     ;; here because the user shouldn't care about VM removing
  420.     ;; its own status headers.
  421.     (buffer-file-name nil)
  422.     (mp vm-message-list)
  423.     (list-length (length vm-message-list)) 
  424.     (inhibit-quit t))
  425.     (save-excursion
  426.       (vm-save-restriction
  427.        (widen)
  428.        (goto-char (point-min))
  429.        (forward-line)
  430.        (search-forward "\n\n" nil t)
  431.        (setq lim (point))
  432.        (goto-char (point-min))
  433.        (forward-line)
  434.        (if (re-search-forward vm-message-order-header-regexp lim t)
  435.        (progn
  436.          (message "Reordering messages...")
  437.          (goto-char (match-beginning 1))
  438.          (setq order (read (current-buffer))
  439.            v (make-vector (max list-length (length order)) nil))
  440.          (delete-region (match-beginning 0) (match-end 0))
  441.          (while (and order mp)
  442.            (aset v (1- (car order)) (car mp))
  443.            (setq order (cdr order) mp (cdr mp)))
  444.          (setq vm-message-list (delq nil (append v mp))
  445.            vm-message-order-changed t
  446.            vm-message-order-stuffed nil
  447.            vm-numbering-redo-start-point t
  448.            vm-message-pointer (memq (car vm-message-pointer)
  449.                         vm-message-list))
  450.          (vm-reverse-link-messages)))))
  451.     (set-buffer-modified-p old-buffer-modified-p)))
  452.  
  453. ;; Stuff the message attributes back into the message as headers.
  454. (defun vm-stuff-attributes (m &optional suppress-delete)
  455.   (save-excursion
  456.     (vm-save-restriction
  457.      (widen)
  458.      (let ((old-buffer-modified-p (buffer-modified-p))
  459.        attributes cache buffer-read-only
  460.        ;; This prevents file locking from occuring.  Disabling
  461.        ;; locking can speed things noticably if the lock
  462.        ;; directory is on a slow device.  We don't need locking
  463.        ;; here because the user shouldn't care about VM stuffing
  464.        ;; its own status headers.
  465.        (buffer-file-name nil)
  466.        (delflag (vm-deleted-flag m))
  467.        (inhibit-quit t))
  468.        (setq attributes (vm-attributes-of m)
  469.          cache (vm-cache-of m))
  470.        (and delflag suppress-delete
  471.         (vm-set-deleted-flag-in-vector attributes nil))
  472.        (goto-char (vm-start-of m))
  473.        (forward-line)
  474.        (if (re-search-forward vm-attributes-header-regexp
  475.                   (vm-text-of m) t)
  476.        (delete-region (match-beginning 0) (match-end 0)))
  477.        (insert-before-markers vm-attributes-header " ("
  478.                   (let ((print-escape-newlines t))
  479.                 (prin1-to-string attributes))
  480.                   "\n\t"
  481.                   (let ((print-escape-newlines t))
  482.                 (prin1-to-string cache))
  483.                   ")\n")
  484.        (vm-set-modflag-of m nil)
  485.        (cond (vm-berkeley-mail-compatibility
  486.           (goto-char (vm-start-of m))
  487.           (forward-line)
  488.           (if (re-search-forward vm-berkeley-mail-status-header-regexp
  489.                      (vm-text-of m) t)
  490.           (delete-region (match-beginning 0) (match-end 0)))
  491.           (cond ((not (vm-new-flag m))
  492.              (insert-before-markers
  493.               vm-berkeley-mail-status-header
  494.               (if (vm-unread-flag m) "" "R")
  495.               "O\n")))))
  496.        (and delflag suppress-delete
  497.         (vm-set-deleted-flag-in-vector attributes t))
  498.        (set-buffer-modified-p old-buffer-modified-p)))))
  499.  
  500. (defun vm-stuff-virtual-attributes (message)
  501.   (let ((virtual (eq message (vm-real-message-of message)))
  502.     (mirror (eq (vm-attributes-of message)
  503.             (vm-attributes-of (vm-real-message-of message)))))
  504.     (if (or (not virtual) (and virtual mirror))
  505.     (save-excursion
  506.       (set-buffer (marker-buffer (vm-start-of message)))
  507.       (vm-stuff-attributes message)))))
  508.  
  509. ;; Insert a bookmark into the first message in the folder.
  510. (defun vm-stuff-bookmark ()
  511.   (if vm-message-pointer
  512.       (save-excursion
  513.     (vm-save-restriction
  514.      (widen)
  515.      (let ((old-buffer-modified-p (buffer-modified-p))
  516.            ;; This prevents file locking from occuring.  Disabling
  517.            ;; locking can speed things noticably if the lock
  518.            ;; directory is on a slow device.  We don't need locking
  519.            ;; here because the user shouldn't care about VM stuffing
  520.            ;; its own status headers.
  521.            (buffer-file-name nil)
  522.            buffer-read-only lim
  523.            (inhibit-quit t))
  524.        (goto-char (point-min))
  525.        (forward-line)
  526.        (search-forward "\n\n" nil t)
  527.        (setq lim (point))
  528.        (goto-char (point-min))
  529.        (forward-line)
  530.        (if (re-search-forward vm-bookmark-header-regexp lim t)
  531.            (delete-region (match-beginning 0) (match-end 0)))
  532.        (insert-before-markers vm-bookmark-header " "
  533.                   (vm-number-of (car vm-message-pointer))
  534.                   "\n")
  535.        (set-buffer-modified-p old-buffer-modified-p))))))
  536.  
  537. ;; stuff the current values of the header variables for future messages.
  538. (defun vm-stuff-header-variables ()
  539.   (if vm-message-pointer
  540.       (save-excursion
  541.     (vm-save-restriction
  542.      (widen)
  543.      (let ((old-buffer-modified-p (buffer-modified-p))
  544.            (print-escape-newlines t)
  545.            buffer-read-only lim
  546.            ;; This prevents file locking from occuring.  Disabling
  547.            ;; locking can speed things noticably if the lock
  548.            ;; directory is on a slow device.  We don't need locking
  549.            ;; here because the user shouldn't care about VM stuffing
  550.            ;; its own status headers.
  551.            (buffer-file-name nil)
  552.            (inhibit-quit t))
  553.        (goto-char (point-min))
  554.        (forward-line)
  555.        (search-forward "\n\n" nil t)
  556.        (setq lim (point))
  557.        (goto-char (point-min))
  558.        (forward-line)
  559.        (if (re-search-forward vm-vheader-header-regexp lim t)
  560.            (delete-region (match-beginning 0) (match-end 0)))
  561.        (insert-before-markers vm-vheader-header " "
  562.                   (prin1-to-string vm-visible-headers) " "
  563.                   (prin1-to-string vm-invisible-header-regexp)
  564.                   "\n")
  565.        (set-buffer-modified-p old-buffer-modified-p))))))
  566.  
  567. ;; Insert a header into the first message of the folder that lists
  568. ;; the folder's message order.
  569. (defun vm-stuff-message-order ()
  570.   (if (cdr vm-message-list)
  571.       (save-excursion
  572.     (vm-save-restriction
  573.      (widen)
  574.      (let ((old-buffer-modified-p (buffer-modified-p))
  575.            ;; This prevents file locking from occuring.  Disabling
  576.            ;; locking can speed things noticably if the lock
  577.            ;; directory is on a slow device.  We don't need locking
  578.            ;; here because the user shouldn't care about VM stuffing
  579.            ;; its own status headers.
  580.            (buffer-file-name nil)
  581.            buffer-read-only lim n
  582.            (mp (copy-sequence vm-message-list))
  583.            (inhibit-quit t))
  584.        (setq mp
  585.          (sort mp
  586.                (function
  587.             (lambda (p q)
  588.               (< (vm-start-of p) (vm-start-of q))))))
  589.        (goto-char (point-min))
  590.        (forward-line)
  591.        (search-forward "\n\n" nil t)
  592.        (setq lim (point))
  593.        (goto-char (point-min))
  594.        (forward-line)
  595.        (if (re-search-forward vm-message-order-header-regexp lim t)
  596.            (delete-region (match-beginning 0) (match-end 0)))
  597.        (insert-before-markers vm-message-order-header "\n\t(")
  598.        (setq n 0)
  599.        (while mp
  600.          (insert-before-markers (vm-number-of (car mp)))
  601.          (setq n (1+ n) mp (cdr mp))
  602.          (and mp (insert-before-markers
  603.               (if (zerop (% n 15))
  604.               "\n\t "
  605.             " "))))
  606.        (insert-before-markers ")\n")
  607.        (setq vm-message-order-stuffed t)
  608.        (set-buffer-modified-p old-buffer-modified-p))))))
  609.  
  610. (defun vm-change-all-new-to-unread ()
  611.   (let ((mp vm-message-list))
  612.     (while mp
  613.       (if (vm-new-flag (car mp))
  614.       (progn
  615.         (vm-set-new-flag (car mp) nil)
  616.         (vm-set-unread-flag (car mp) t)))
  617.       (setq mp (cdr mp)))))
  618.  
  619. (defun vm-highlight-headers (message window)
  620.   (and vm-highlighted-header-regexp window
  621.        (<= (window-start window) (vm-text-of message))
  622.        (save-excursion
  623.      ;; As of v18.52, this call to save-window-excursion is needed!
  624.      ;; Somehow window point can get fouled in here, and drag the
  625.      ;; buffer point along with it.  This problem only manifests
  626.      ;; itself when operating VM from the summary buffer, subsequent
  627.      ;; to using vm-beginning-of-message or vm-end-of-message.
  628.      ;; After running a next or previous message command, point
  629.      ;; somehow ends up at the end of the message.
  630.      (save-window-excursion
  631.        (goto-char (window-start window))
  632.        (while (re-search-forward vm-highlighted-header-regexp
  633.                      (vm-text-of message) t)
  634.          (save-restriction
  635.            (goto-char (match-beginning 0))
  636.            (if (looking-at vm-generic-header-regexp)
  637.            (progn
  638.              (goto-char (match-beginning 2))
  639.              (narrow-to-region (point-min) (point))
  640.              (sit-for 0)
  641.              (setq inverse-video t)
  642.              (goto-char (point-min))
  643.              (widen)
  644.              (narrow-to-region (point) (match-end 2))
  645.              (sit-for 0)
  646.              (setq inverse-video nil)
  647.              (goto-char (match-end 0)))
  648.          (goto-char (match-end 0)))))))))
  649.  
  650. (defun vm-unread-message (&optional count)
  651.   "Set the `unread' attribute for the current message.  If the message is
  652. already new or unread, then it left unchanged.
  653.  
  654. Numeric prefix argument N mans to unread the current message plus the
  655. next N-1 messages.  A negative N means unread the current message and
  656. the previous N-1 messages.
  657.  
  658. When invoked on marked messages (via vm-next-command-uses-marks),
  659. all marked messages are affected, other messages are ignored."
  660.   (interactive "p")
  661.   (or count (setq count 1))
  662.   (vm-follow-summary-cursor)
  663.   (vm-select-folder-buffer)
  664.   (vm-check-for-killed-summary)
  665.   (vm-error-if-folder-empty)
  666.   (let ((mlist (vm-select-marked-or-prefixed-messages count)))
  667.     (while mlist
  668.       (if (and (not (vm-unread-flag (car mlist)))
  669.            (not (vm-new-flag (car mlist))))
  670.       (vm-set-unread-flag (car mlist) t))
  671.       (setq mlist (cdr mlist))))
  672.   (vm-update-summary-and-mode-line))
  673.  
  674. (defun vm-quit-no-change ()
  675.   "Exit VM without saving changes made to the folder."
  676.   (interactive)
  677.   (vm-quit t))
  678.  
  679. (defun vm-quit (&optional no-change)
  680.   "Quit VM, saving changes and expunging deleted messages."
  681.   (interactive)
  682.   (vm-select-folder-buffer)
  683.   (if (not (memq major-mode '(vm-mode vm-virtual-mode)))
  684.       (error "%s must be invoked from a VM buffer." this-command))
  685.   (vm-check-for-killed-summary)
  686.   (vm-error-if-referenced-virtually)
  687.   (if (eq major-mode 'vm-virtual-mode)
  688.       (vm-virtual-quit)
  689.     (cond
  690.      ((and no-change (buffer-modified-p)
  691.        (not (zerop vm-messages-not-on-disk))
  692.        ;; Folder may have been saved with C-x C-s and attributes may have
  693.        ;; been changed after that; in that case vm-messages-not-on-disk
  694.        ;; would not have been zeroed.  However, all modification flag
  695.        ;; undos are cleared if VM actually modifies the folder buffer
  696.        ;; (as opposed to the folder's attributes), so this can be used
  697.        ;; to verify that there are indeed unsaved messages.
  698.        (null (assq 'vm-set-buffer-modified-p vm-undo-record-list))
  699.        (not
  700.         (y-or-n-p
  701.          (format
  702.           "%d message%s have not been saved to disk, quit anyway? "
  703.           vm-messages-not-on-disk
  704.           (if (= 1 vm-messages-not-on-disk) "" "s")))))
  705.       (error "Aborted"))
  706.      ((and no-change (buffer-modified-p) vm-confirm-quit
  707.        (not (y-or-n-p "There are unsaved changes, quit anyway? ")))
  708.       (error "Aborted"))
  709.      ((and (eq vm-confirm-quit t)
  710.        (not (y-or-n-p "Do you really want to quit? ")))
  711.       (error "Aborted")))
  712.     (message "")
  713.     (let ((inhibit-quit t))
  714.       (if (not no-change)
  715.       (progn
  716.         ;; this could take a while, so give the user some feedback
  717.         (message "Quitting...")
  718.         (or vm-folder-read-only (vm-change-all-new-to-unread))
  719.         (if (not (buffer-modified-p))
  720.         (message ""))))
  721.       (if (and (buffer-modified-p) (not no-change))
  722.       (vm-save-folder t))
  723.       (let ((summary-buffer vm-summary-buffer)
  724.         (mail-buffer (current-buffer)))
  725.     (if summary-buffer
  726.         (progn
  727.           (if (eq vm-mutable-windows t)
  728.           (delete-windows-on vm-summary-buffer))
  729.           (kill-buffer summary-buffer)))
  730.     (set-buffer mail-buffer)
  731.     (set-buffer-modified-p nil)
  732.     (kill-buffer (current-buffer))))))
  733.  
  734. ;; in support of timer based checkpointing.
  735. (defun vm-checkpoint-prologue-hook ()
  736.   (if (eq vm-checkpoint-modification-counter vm-modification-counter)
  737.       nil
  738.     (let ((mp vm-message-list))
  739.       (while mp
  740.     (if (vm-modflag-of (car mp))
  741.         (vm-stuff-attributes (car mp)))
  742.     (setq mp (cdr mp))))
  743.     (setq vm-checkpoint-modification-counter
  744.       vm-modification-counter)
  745.     t ))
  746.  
  747. (defun vm-checkpoint-epilogue-hook ()
  748.   (set-file-modes buffer-auto-save-file-name 384))
  749.  
  750. ;; support for numeric vm-flush-interval
  751. (defun vm-flush-timer-function ()
  752.   (set-timer-restart current-timer vm-flush-interval)
  753.   ;; if no vm-mode buffers are found, we might as well shut down the
  754.   ;; flush timer.
  755.   (if (not (vm-flush-cached-data))
  756.       (set-timer-restart current-timer nil)))
  757.  
  758. ;; flush cached data in all vm-mode buffers.
  759. ;; returns non-nil if any vm-mode buffers were found.
  760. (defun vm-flush-cached-data ()
  761.   (save-excursion
  762.     (let ((buf-list (buffer-list)) found-one)
  763.       (while (and buf-list (not (input-pending-p)))
  764.     (set-buffer (car buf-list))
  765.     (cond ((eq major-mode 'vm-mode)
  766.            (setq found-one t)
  767.            (if (not (eq vm-modification-counter
  768.                 vm-flushed-modification-counter))
  769.            (let ((mp vm-message-list))
  770.              (while (and mp (not (input-pending-p)))
  771.                (if (vm-modflag-of (car mp))
  772.                (vm-stuff-attributes (car mp)))
  773.                (setq mp (cdr mp)))
  774.              (and (null mp)
  775.               (setq vm-flushed-modification-counter
  776.                 vm-modification-counter))))))
  777.     (setq buf-list (cdr buf-list)))
  778.       ;; we may not have checked them all so return non-nil so
  779.       ;; the flusher won't give up trying.
  780.       (or buf-list found-one) )))
  781.  
  782. ;; This allows C-x C-s to do the right thing for VM mail buffers.
  783. ;; Note that deleted messages are not expunged.
  784. (defun vm-write-file-hook ()
  785.   (if (and (eq major-mode 'vm-mode) (not vm-inhibit-write-file-hook))
  786.     ;; The vm-save-restriction isn't really necessary here, since
  787.     ;; the stuff routines clean up after themselves, but should remain
  788.     ;; as a safeguard against the time when other stuff is added here.
  789.     (vm-save-restriction
  790.      (let ((inhibit-quit t)
  791.        (mp vm-message-list)
  792.        (buffer-read-only))
  793.     (while mp
  794.       (if (vm-modflag-of (car mp))
  795.           (vm-stuff-attributes (car mp)))
  796.       (setq mp (cdr mp)))
  797.     (if vm-message-list
  798.         (progn
  799.           (vm-do-needed-renumbering)
  800.           (vm-stuff-bookmark)
  801.           (vm-stuff-header-variables)
  802.           (and vm-retain-message-order
  803.            vm-message-order-changed
  804.            (vm-stuff-message-order))))
  805.     ;; We can't be sure the write is going to succeed, so we can't set
  806.     ;; this variable to nil.  We can't leave it set to t either since
  807.     ;; the user will be confused, since she thought the folder was saved.
  808.     ;; The solution, set vm-buffer-modified-p to a value that indicates
  809.     ;; uncertainty.
  810.     (setq vm-buffer-modified-p "--??-")
  811.     (if vm-summary-buffer
  812.         (save-excursion
  813.           (set-buffer vm-summary-buffer)
  814.           (setq vm-buffer-modified-p "--??-")))
  815.     nil ))))
  816.  
  817. (defun vm-save-buffer (prefix)
  818.   (interactive "P")
  819.   (vm-select-folder-buffer)
  820.   (vm-error-if-virtual-folder)
  821.   (save-buffer prefix)
  822.   (setq vm-block-new-mail nil
  823.     vm-buffer-modified-p nil
  824.     vm-message-order-changed nil)
  825.   (vm-update-summary-and-mode-line))
  826.  
  827. (defun vm-write-file ()
  828.   (interactive)
  829.   (vm-select-folder-buffer)
  830.   (vm-error-if-virtual-folder)
  831.   (call-interactively 'write-file)
  832.   (setq vm-block-new-mail nil
  833.     vm-buffer-modified-p nil
  834.     vm-message-order-changed nil)
  835.   (vm-update-summary-and-mode-line))
  836.  
  837. (defun vm-save-folder (&optional quitting prefix)
  838.   "Save current folder to disk.
  839. Prefix args are handled the same for the command save-buffer."
  840.   (interactive (list nil current-prefix-arg))
  841.   (vm-select-folder-buffer)
  842.   (vm-sanity-check-modification-flag)
  843.   (vm-check-for-killed-summary)
  844.   (vm-error-if-virtual-folder)
  845.   (if (buffer-modified-p)
  846.       (let ((inhibit-quit t) mp)
  847.     (message "Expunging...")
  848.     ;; may get error if folder is emptied by the expunge.
  849.     (condition-case ()
  850.         (vm-expunge-folder quitting t)
  851.       (error nil))
  852.     ;; stuff the attributes of messages that need it.
  853.     (message "Stuffing attributes...")
  854.     (setq mp vm-message-list)
  855.     (while mp
  856.       (if (vm-modflag-of (car mp))
  857.           (vm-stuff-attributes (car mp)))
  858.       (setq mp (cdr mp)))
  859.     ;; stuff bookmark and header variable values
  860.     (if vm-message-list
  861.         (progn
  862.           (vm-do-needed-renumbering)
  863.           (vm-stuff-bookmark)
  864.           (vm-stuff-header-variables)
  865.           (and vm-retain-message-order
  866.            vm-message-order-changed
  867.            (vm-stuff-message-order))))
  868.     (message "Saving...")
  869.     (let ((vm-inhibit-write-file-hook t))
  870.       (save-buffer prefix))
  871.     (vm-set-buffer-modified-p nil t)
  872.     (setq vm-messages-not-on-disk 0)
  873.     (setq vm-block-new-mail nil)
  874.     (setq vm-message-order-changed nil)
  875.     (and (zerop (buffer-size)) vm-delete-empty-folders
  876.          (condition-case ()
  877.          (progn
  878.            (delete-file buffer-file-name)
  879.            (message "%s removed" buffer-file-name))
  880.            (error nil)))
  881.     (if (not quitting)
  882.         (if vm-message-pointer
  883.         (vm-update-summary-and-mode-line)
  884.           (vm-next-message))))
  885.     (message "No changes need to be saved")))
  886.  
  887. ;; detect if a recover-file is being performed
  888. ;; and handle things properly.
  889. (defun vm-handle-file-recovery ()
  890.   (if (and (buffer-modified-p)
  891.        (eq major-mode 'vm-mode)
  892.        vm-message-list
  893.        (= (vm-end-of (car vm-message-list)) 1))
  894.       (progn
  895.     (if (and vm-summary-buffer (bufferp vm-summary-buffer))
  896.         (kill-buffer vm-summary-buffer))
  897.     (setq vm-message-list nil
  898.           vm-message-pointer nil
  899.           vm-summary-buffer nil)
  900.     ;; We can't allow the user to get new mail until a real
  901.     ;; save is performed.  Until then the buffer and the disk
  902.     ;; don't match.
  903.     (setq vm-block-new-mail t)
  904.     (vm buffer-file-name))))
  905.  
  906. ;; detect if a revert-buffer is being performed
  907. ;; and handle things properly.
  908. (defun vm-handle-file-reversion ()
  909.   (if (and (not (buffer-modified-p))
  910.        (eq major-mode 'vm-mode)
  911.        vm-message-list
  912.        (= (vm-end-of (car vm-message-list)) 1))
  913.       (progn
  914.     (save-excursion
  915.       ;; save-excursion required to restore current buffer
  916.       ;; due to a bug in kill-buffer (really replace-buffer-in-windows)
  917.       (if (and vm-summary-buffer (bufferp vm-summary-buffer))
  918.           (kill-buffer vm-summary-buffer)))
  919.     (setq vm-summary-buffer nil)
  920.     (vm-build-message-list t)
  921.     (if (null vm-message-list)
  922.         (progn
  923.           (message "Partial revert failed; disk version of folder has too few messages...")
  924.           (sleep-for 3)
  925.           (message "Assuming file changed completely; rebuilding message list...")
  926.           (sleep-for 1)
  927.           (setq vm-message-pointer nil)
  928.           (vm buffer-file-name))
  929.       (vm-assimilate-new-messages)
  930.       (vm-preview-current-message)))))
  931.  
  932. (defun vm-visit-folder (folder &optional read-only)
  933.   "Visit a mail file.
  934. VM will parse and present its messages to you in the usual way.
  935.  
  936. First arg FOLDER specifies the mail file to visit.  When this
  937. command is called interactively the file name is read from the
  938. minibuffer.
  939.  
  940. Prefix arg or optional second arg READ-ONLY non-nil indicates
  941. that the folder should be considered read only.  No attribute
  942. changes, messages additions or deletions will be allowed in the
  943. visited folder."
  944.   (interactive
  945.    (save-excursion
  946.      (vm-session-initialization)
  947.      (vm-select-folder-buffer)
  948.      (let ((dir (if vm-folder-directory
  949.             (expand-file-name vm-folder-directory)
  950.           default-directory)))
  951.        (list (read-file-name
  952.           (format "Visit%s folder:%s "
  953.               (if current-prefix-arg " read only" "")
  954.               (if vm-last-save-folder
  955.               (format " (default %s)" vm-last-save-folder)
  956.             ""))
  957.           dir vm-last-save-folder t) current-prefix-arg))))
  958.   (vm-session-initialization)
  959.   (vm-select-folder-buffer)
  960.   (vm-check-for-killed-summary)
  961.   (vm folder read-only))
  962.  
  963. (defun vm-help ()
  964.   "Display VM command and variable information."
  965.   (interactive)
  966.   (if (and vm-mail-buffer (get-buffer-window vm-mail-buffer))
  967.       (set-buffer vm-mail-buffer))
  968.   (let ((pop-up-windows (and pop-up-windows (eq vm-mutable-windows t))))
  969.     (cond
  970.      ((eq last-command 'vm-help)
  971.       (describe-mode))
  972.      ((eq vm-system-state 'previewing)
  973.       (message "Type SPC to read message, n previews next message   (? gives more help)"))
  974.      ((memq vm-system-state '(showing reading))
  975.       (message "SPC and b scroll, (d)elete, (s)ave, (n)ext, (r)eply   (? gives more help)"))
  976.      (t (describe-mode)))))
  977.  
  978. (defun vm-move-mail (source destination)
  979.   (let ((status
  980.      (call-process vm-movemail-program nil nil nil
  981.                (expand-file-name source)
  982.                (expand-file-name destination))))
  983.     (if (not (= 0 status))
  984.     (error "vm: %s exited with code %s" vm-movemail-program status))
  985.     status))
  986.  
  987. (defun vm-gobble-crash-box ()
  988.   (save-excursion
  989.     (vm-save-restriction
  990.      (widen)
  991.      (let ((opoint-max (point-max)) crash-buf buffer-read-only
  992.        (old-buffer-modified-p (buffer-modified-p))
  993.            ;; crash box could contain a letter bomb...
  994.        ;; force user notification of file variables.
  995.        (inhibit-local-variables t)
  996.        (enable-local-variables nil))
  997.        (setq crash-buf (find-file-noselect vm-crash-box))
  998.        (goto-char (point-max))
  999.        (insert-buffer-substring crash-buf
  1000.                 1 (1+ (save-excursion
  1001.                     (set-buffer crash-buf)
  1002.                     (widen)
  1003.                     (buffer-size))))
  1004.        (write-region opoint-max (point-max) buffer-file-name t t)
  1005.        ;; make sure primary inbox is private.  384 = octal 600
  1006.        (condition-case () (set-file-modes buffer-file-name 384) (error nil))
  1007.        (set-buffer-modified-p old-buffer-modified-p)
  1008.        (kill-buffer crash-buf)
  1009.        (condition-case () (delete-file vm-crash-box)
  1010.      (error nil))))))
  1011.  
  1012. (defun vm-compatible-folder-p (file)
  1013.   (while (not (string= file (setq file (expand-file-name file)))))
  1014.   (let (buffer (type vm-folder-type))
  1015.     (if (zerop (buffer-size))
  1016.     t
  1017.       (if (null (setq buffer (get-file-buffer file)))
  1018.       (if (not (file-exists-p file))
  1019.           t
  1020.         (save-excursion
  1021.           (unwind-protect
  1022.           (progn
  1023.             (setq buffer (generate-new-buffer " *vm work*"))
  1024.             (call-process "sed" file buffer nil "-n" "1p")
  1025.             (save-excursion
  1026.               (set-buffer buffer)
  1027.               (or (zerop (buffer-size))
  1028.               (eq type (vm-get-folder-type)))))
  1029.         (and buffer (kill-buffer buffer)))))
  1030.     (save-excursion
  1031.       (set-buffer buffer)
  1032.       (or (zerop (buffer-size))
  1033.           (eq type (vm-get-folder-type))))))))
  1034.  
  1035. (defun vm-check-for-spooled-mail ()
  1036.   (let ((spool-files
  1037.      (append (or vm-spool-files
  1038.              (list (concat vm-spool-directory (user-login-name))))
  1039.          (list vm-crash-box)))
  1040.     (new-mail nil))
  1041.     (while spool-files
  1042.       (if (and (not (equal 0 (nth 7 (file-attributes (car spool-files)))))
  1043.            (file-readable-p (car spool-files))
  1044.            (vm-compatible-folder-p (car spool-files)))
  1045.       (setq spool-files nil
  1046.         new-mail t)
  1047.     (setq spool-files (cdr spool-files))))
  1048.     new-mail ))
  1049.  
  1050. (defun vm-get-spooled-mail ()
  1051.   (if vm-block-new-mail
  1052.       (error "Can't get new mail until you save this folder."))
  1053.   (let ((spool-files (or vm-spool-files
  1054.              (list (concat vm-spool-directory (user-login-name)))))
  1055.     (inhibit-quit t)
  1056.     (got-mail))
  1057.     (if (file-exists-p vm-crash-box)
  1058.     (progn
  1059.       (message "Recovering messages from crash box...")
  1060.       (vm-gobble-crash-box)
  1061.       (message "Recovering messages from crash box... done")
  1062.       (setq got-mail t)))
  1063.     (while spool-files
  1064.       (if (and (not (equal 0 (nth 7 (file-attributes (car spool-files)))))
  1065.            (file-readable-p (car spool-files))
  1066.            (vm-compatible-folder-p (car spool-files)))
  1067.       (progn
  1068.         (message "Getting new mail from %s..." (car spool-files))
  1069.         (vm-move-mail (car spool-files) vm-crash-box)
  1070.         (vm-gobble-crash-box)
  1071.         (message "Getting new mail from %s... done" (car spool-files))
  1072.         (setq got-mail t)))
  1073.       (setq spool-files (cdr spool-files)))
  1074.     got-mail ))
  1075.  
  1076. (defun vm-get-new-mail (&optional arg)
  1077.   "Move any new mail that has arrived in the system mailbox into the
  1078. primary inbox.  New mail is appended to the disk and buffer copies of
  1079. the primary inbox.
  1080.  
  1081. Prefix arg means to gather mail from a user specified folder, instead of
  1082. the usual spool file(s).  The file name will be read from the minibuffer.
  1083. Unlike when getting mail from a spool file, in this case the folder is left
  1084. undisturbed after its messages have been copied."
  1085.   (interactive "P")
  1086.   (vm-select-folder-buffer)
  1087.   (vm-check-for-killed-summary)
  1088.   (vm-error-if-virtual-folder)
  1089.   (vm-error-if-folder-read-only)
  1090.   (if (and (null arg) (not vm-primary-inbox-p)
  1091.        (vm-check-for-spooled-mail))
  1092.       (progn
  1093.     (switch-to-buffer (or (get-file-buffer vm-primary-inbox)
  1094.                   (find-file-noselect vm-primary-inbox)))
  1095.     (if (not (eq major-mode 'vm-mode))
  1096.         (vm-mode))))
  1097.   (if (null arg)
  1098.       (if (not (and (vm-get-spooled-mail) (vm-assimilate-new-messages)))
  1099.        (progn
  1100.          (message "No new mail.")
  1101.         ;; don't let this message stay up forever...
  1102.          (sit-for 4)
  1103.          (message ""))
  1104.     (vm-deferred-message (vm-emit-totals-blurb))
  1105.     (or (vm-thoughtfully-select-message)
  1106.         (vm-update-summary-and-mode-line)))
  1107.     (let (folder mcount buffer-read-only)
  1108.       (setq folder (read-file-name "Gather mail from folder: "
  1109.                    vm-folder-directory t))
  1110.       (if (not (vm-compatible-folder-p folder))
  1111.       (error "Folder %s is not the same format as this folder." folder))
  1112.       (save-excursion
  1113.     (vm-save-restriction
  1114.      (widen)
  1115.      (goto-char (point-max))
  1116.      (insert-file-contents folder)))
  1117.       (if (null vm-totals)
  1118.       (vm-read-attributes))
  1119.       (setq mcount (car vm-totals))
  1120.       (if (vm-assimilate-new-messages)
  1121.       (progn
  1122.         (vm-deferred-message (vm-emit-totals-blurb))
  1123.         (vm-update-summary-and-mode-line)
  1124.         ;; The gathered messages are actually still on disk
  1125.         ;; unless the user deletes the folder himself.
  1126.         ;; However, users may not understand what happened if
  1127.         ;; the messages go away after a "quit, no save".
  1128.         (setq vm-messages-not-on-disk
  1129.           (+ vm-messages-not-on-disk (- (car vm-totals) mcount))))
  1130.     (message "No messages gathered.")))))
  1131.  
  1132. (defun vm-emit-totals-blurb ()
  1133.   (save-excursion
  1134.     (vm-select-folder-buffer)
  1135.     (if (null vm-totals)
  1136.     (vm-read-attributes))
  1137.     (message "%d message%s, %d new, %d unread."
  1138.          (car vm-totals) (if (= (car vm-totals) 1) "" "s") 
  1139.          (car (cdr vm-totals))
  1140.          (car (cdr (cdr vm-totals))))))
  1141.  
  1142. ;; returns non-nil if there were any new messages
  1143. (defun vm-assimilate-new-messages ()
  1144.   (let ((tail-cons (vm-last vm-message-list))
  1145.     (new-messages-p (null vm-message-list)))
  1146.     (save-excursion
  1147.       (vm-save-restriction
  1148.        (widen)
  1149.        (vm-build-message-list)
  1150.        (vm-read-attributes)
  1151.        (setq new-messages-p (or new-messages-p (cdr tail-cons))
  1152.          vm-numbering-redo-start-point new-messages-p
  1153.          vm-summary-redo-start-point new-messages-p)
  1154.        (cond ((and vm-current-grouping new-messages-p)
  1155.           (condition-case data
  1156.           (vm-group-messages vm-current-grouping)
  1157.         ;; presumably an unsupported grouping
  1158.         (error (message (car (cdr data)))
  1159.                (sleep-for 2))))))
  1160.       (setq vm-need-summary-pointer-update t)
  1161.       new-messages-p )))
  1162.  
  1163. ;; return a list of all marked messages or the messages indicated by a
  1164. ;; prefix argument.
  1165. (defun vm-select-marked-or-prefixed-messages (prefix)
  1166.   (let (mlist)
  1167.     (if (eq last-command 'vm-next-command-uses-marks)
  1168.     (setq mlist (vm-marked-messages))
  1169.       (let* ((direction (if (< prefix 0) 'backward 'forward))
  1170.          (count (vm-abs prefix))
  1171.          (vm-message-pointer vm-message-pointer))
  1172.     (if (not (eq vm-circular-folders t))
  1173.         (vm-check-count prefix))
  1174.     (while (not (zerop count))
  1175.       (setq mlist (cons (car vm-message-pointer) mlist))
  1176.       (vm-decrement count)
  1177.       (if (not (zerop count))
  1178.           (vm-move-message-pointer direction))))
  1179.       (nreverse mlist))))
  1180.  
  1181. (defun vm-display-startup-message ()
  1182.   (if (sit-for 5)
  1183.       (let ((lines vm-startup-message-lines))
  1184.     (message "VM %s, Copyright (C) 1991 Kyle E. Jones; type ? for help"
  1185.          vm-version)
  1186.     (setq vm-startup-message-displayed t)
  1187.     (while (and (sit-for 4) lines)
  1188.       (message (substitute-command-keys (car lines)))
  1189.       (setq lines (cdr lines)))))
  1190.   (message ""))
  1191.  
  1192. (defun vm-load-rc (&optional interactive)
  1193.   (interactive "p")
  1194.   (if (or (not vm-rc-loaded) interactive)
  1195.       (load "~/.vm" (not interactive) (not interactive) t))
  1196.   (setq vm-rc-loaded t))
  1197.  
  1198. (defun vm-session-initialization ()
  1199.   ;; If this is the first time VM has been run in this Emacs session,
  1200.   ;; do some necessary preparations.
  1201.   (if (or (not (boundp 'vm-session-beginning)) vm-session-beginning)
  1202.       (progn
  1203.     (random t)
  1204.     (vm-load-rc)
  1205.     (if vm-window-configuration-file
  1206.         (if (condition-case () (progn (require 'screen) t))
  1207.         (vm-load-window-configurations vm-window-configuration-file)
  1208.           (message "can't support window configurations without the screen package... sorry.")
  1209.           (setq vm-window-configuration-file nil)
  1210.           (sleep-for 2)))
  1211.     (setq vm-session-beginning nil))))
  1212.  
  1213. (defun vm (&optional folder read-only)
  1214.   "Read mail under Emacs.
  1215. Optional first arg FOLDER specifies the folder to visit.  It defaults
  1216. to the value of vm-primary-inbox.  The folder buffer is put into VM
  1217. mode, a major mode for reading mail.
  1218.  
  1219. Prefix arg or optional second arg READ-ONLY non-nil indicates
  1220. that the folder should be considered read only.  No attribute
  1221. changes, messages additions or deletions will be allowed in the
  1222. visited folder.
  1223.  
  1224. Visiting the primary inbox causes any contents of the system mailbox to
  1225. be moved and appended to the resulting buffer.
  1226.  
  1227. All the messages can be read by repeatedly pressing SPC.  Use `n'ext and
  1228. `p'revious to move about in the folder.  Messages are marked for
  1229. deletion with `d', and saved to another folder with `s'.  Quitting VM
  1230. with `q' expunges deleted messages and saves the buffered folder to
  1231. disk.
  1232.  
  1233. See the documentation for vm-mode for more information."
  1234.   (interactive (list nil current-prefix-arg))
  1235.   (vm-session-initialization)
  1236.   ;; set inhibit-local-variables non-nil to protect
  1237.   ;; against letter bombs.
  1238.   (let ((inhibit-local-variables t)
  1239.     (enable-local-variables nil)
  1240.     (full-startup (not (bufferp folder)))
  1241.     mail-buffer already-existed)
  1242.     (setq mail-buffer
  1243.       (if (bufferp folder)
  1244.           (setq already-existed folder)
  1245.         (let ((file (or folder (expand-file-name vm-primary-inbox))))
  1246.           (if (file-directory-p file)
  1247.           ;; MH code perhaps... ?
  1248.           (error "%s is a directory" file)
  1249.         (or (setq already-existed (get-file-buffer file))
  1250.             (let ((default-directory
  1251.                 (or (and vm-folder-directory
  1252.                      (expand-file-name vm-folder-directory))
  1253.                 default-directory)))
  1254.               (find-file-noselect file)))))))
  1255.     (set-buffer mail-buffer)
  1256.     (setq vm-folder-read-only read-only)
  1257.     (vm-sanity-check-modification-flag)
  1258.     (vm-check-for-killed-summary)
  1259.     ;; If the buffer's not modified then we know that there can be no
  1260.     ;; messages in the folder that are not on disk.
  1261.     (or (buffer-modified-p) (setq vm-messages-not-on-disk 0))
  1262.     (let ((first-time (not (eq major-mode 'vm-mode)))
  1263.       (auto-save-newer (and buffer-file-name
  1264.                 (file-newer-than-file-p
  1265.                  (make-auto-save-file-name)
  1266.                  buffer-file-name)))
  1267.       (inhibit-quit t)
  1268.       blurb)
  1269.       ;; If this is not a VM mode buffer then some initialization
  1270.       ;; needs to be done 
  1271.       (if first-time
  1272.       (progn
  1273.         (buffer-flush-undo (current-buffer))
  1274.         (abbrev-mode 0)
  1275.         (auto-fill-mode 0)
  1276.         (vm-mode-internal)))
  1277.       (if (or (and vm-primary-inbox-p
  1278.            ;; We demand full-startup and first-time here
  1279.            ;; to make sure that vm-mode being in the
  1280.            ;; auto-mode-alist doesn't cause an auto
  1281.            ;; save file to be ignored.  Otherwise an auto
  1282.            ;; save file might be ignored on an "M-x vm"
  1283.            ;; if vm-mode were in in the auto-folder-alist.
  1284.            full-startup
  1285.            first-time
  1286.            (not vm-folder-read-only)
  1287.            (not auto-save-newer)
  1288.            (vm-get-spooled-mail))
  1289.           first-time
  1290.           ;; If the message list is empty, take a second look: the
  1291.           ;; buffer may have been encrypted the first time around.
  1292.           ;; This is a concession to users who use crypt.el and put
  1293.           ;; vm-mode into auto-mode-alist.
  1294.           (null vm-message-list))
  1295.       (save-excursion
  1296.         (save-window-excursion
  1297.           (save-restriction
  1298.         (delete-windows-on (current-buffer))
  1299.         (set-buffer mail-buffer)
  1300.         (and vm-summary-buffer (delete-windows-on vm-summary-buffer))
  1301.         (set-buffer mail-buffer)
  1302.         (vm-assimilate-new-messages)
  1303.         ;; Can't allow a folder-empty error here because execution
  1304.         ;; would abort before the code below.
  1305.         (if (null vm-message-list)
  1306.             (and full-startup (message "Folder is empty."))
  1307.           (if first-time
  1308.               (progn
  1309.             (vm-check-header-variables)
  1310.             (vm-gobble-message-order)
  1311.             (vm-gobble-bookmark)))
  1312.           (setq blurb (vm-emit-totals-blurb))
  1313.           (vm-thoughtfully-select-message))))))
  1314.       (and full-startup (not blurb)
  1315.        (setq blurb (vm-emit-totals-blurb)))
  1316.       (if (and full-startup vm-message-list vm-startup-with-summary)
  1317.       (progn
  1318.         (vm-summarize)
  1319.         (message blurb)))
  1320.       (if vm-mutable-windows
  1321.       (if (not (vm-set-window-configuration 'startup))
  1322.           (let ((pop-up-windows (and pop-up-windows
  1323.                      (eq vm-mutable-windows t))))
  1324.         (switch-to-buffer (current-buffer))
  1325.         (and vm-summary-buffer (display-buffer vm-summary-buffer))
  1326.         (if (and (eq vm-startup-with-summary t)
  1327.              (eq vm-mutable-windows t)
  1328.              vm-summary-buffer)
  1329.             (progn
  1330.               (select-window (get-buffer-window vm-summary-buffer))
  1331.               (delete-other-windows)))
  1332.         (if (eq vm-mutable-windows t)
  1333.             (vm-proportion-windows))))
  1334.     (switch-to-buffer (current-buffer)))
  1335.       (set-buffer mail-buffer)
  1336.       (vm-preview-current-message)
  1337.       (if (and (numberp vm-flush-interval)
  1338.            (condition-case data
  1339.            (progn (require 'timer) t)
  1340.          (error
  1341.           (message "can't support numeric vm-flush-interval without interval timers... sorry.")
  1342.           (sleep-for 2)
  1343.           nil ))
  1344.            (not (get-timer "vm-flush")))
  1345.       (start-timer "vm-flush" 'vm-flush-timer-function vm-flush-interval nil))
  1346.       (if (and (not already-existed) auto-save-newer)
  1347.       (progn
  1348.         (discard-input)
  1349.         (if vm-primary-inbox-p
  1350.         (message "Not checking for new mail... auto save file is newer; consider M-x recover-file")
  1351.           (message "Auto save file is newer; consider M-x recover-file"))
  1352.         (sit-for 3)))
  1353.       ;; Display copyright and copying info unless
  1354.       ;; user says no.
  1355.       (if (and full-startup
  1356.            (not (or vm-inhibit-startup-message vm-startup-message-displayed)))
  1357.       (progn
  1358.         (vm-display-startup-message)
  1359.         (if (not (input-pending-p))
  1360.         (message blurb)))))))
  1361.  
  1362. (defun vm-mode ()
  1363.   "Major mode for reading mail.
  1364.  
  1365. Commands:
  1366.    h - summarize folder contents
  1367.    j - discard cached information about the current message
  1368.  
  1369.    n - go to next message
  1370.    p - go to previous message
  1371.    N - like `n' but ignores skip-variable settings
  1372.    P - like `p' but ignores skip-variable settings
  1373.  M-n - go to next unread message
  1374.  M-p - go to previous unread message
  1375.  RET - go to numbered message (uses prefix arg or prompts in minibuffer)
  1376.  TAB - go to last message seen
  1377.  M-s - incremental search through the folder
  1378.  
  1379.    t - display hidden headers
  1380.  SPC - scroll forward a page (if at end of message, then display next message)
  1381.    b - scroll backward a page
  1382.    < - go to beginning of current message
  1383.    > - go to end of current message
  1384.  
  1385.    d - delete message, prefix arg deletes messages forward (flag as deleted)
  1386.  C-d - delete message, prefix arg deletes messages backward (flag as deleted)
  1387.    u - undelete
  1388.    k - flag for deletion all messages with same subject as the current message
  1389.  
  1390.    r - reply (only to the sender of the message)
  1391.    R - reply with included text for current message
  1392.  M-r - extract and resend bounced message
  1393.    f - followup (reply to all recipients of message)
  1394.    F - followup with included text from the current message
  1395.    z - forward the current message
  1396.    m - send a message
  1397.    B - resend the current message to another user.
  1398.    c - continue composing the most recent message you were composing
  1399.  
  1400.    @ - digestify and mail entire folder contents (the folder is not modified)
  1401.    * - burst a digest into individual messages, and append and assimilate these
  1402.        message into the current folder.
  1403.  
  1404.    G - group messages according to some criteria
  1405.  
  1406.    g - get any new mail that has arrived in the system mailbox
  1407.        (new mail is appended to the disk and buffer copies of the
  1408.        primary inbox.)
  1409.    v - visit another mail folder
  1410.    V - visit a virtual folder
  1411.  
  1412.    e - edit the current message
  1413.  
  1414.    s - save current message in a folder (appends if folder already exists)
  1415.    w - write current message to a file without its headers (appends if exists)
  1416.    S - save entire folder to disk, expunging deleted messages
  1417.    A - save unfiled messages to their vm-auto-folder-alist specified folders
  1418.    # - expunge deleted messages (without saving folder)
  1419.    q - quit VM, deleted messages are expunged, folder saved to disk
  1420.    x - exit VM with no change to the folder
  1421.  
  1422.  M N - use marks; the next vm command will affect only marked messages
  1423.        if it makes sense for the command to do so
  1424.  
  1425.        M M - mark the current message
  1426.        M U - unmark the current message
  1427.        M m - mark all messsages
  1428.        M u - unmark all messsages
  1429.        M ? - help for the mark commands
  1430.  
  1431.  W S - save the current window configuration to a name
  1432.  W D - delete a window configuration
  1433.  W W - apply a configuration
  1434.  W ? - help for the window configuration commands
  1435.  
  1436.  C-_ - undo, special undo that retracts the most recent
  1437.              changes in message attributes.  Expunges and saves
  1438.              cannot be undone.  C-x u is also bound to this
  1439.              command.
  1440.  
  1441.    L - reload your VM init file, ~/.vm
  1442.  
  1443.    ? - help
  1444.  
  1445.    ! - run a shell command
  1446.    | - run a shell command with the current message as input
  1447.  
  1448.  M-C - view conditions under which you may redistribute VM
  1449.  M-W - view the details of VM's lack of a warranty
  1450.  
  1451. Variables:
  1452.    vm-auto-center-summary
  1453.    vm-auto-folder-alist
  1454.    vm-auto-folder-case-fold-search
  1455.    vm-auto-next-message
  1456.    vm-berkeley-mail-compatibility
  1457.    vm-circular-folders
  1458.    vm-confirm-new-folders
  1459.    vm-confirm-quit
  1460.    vm-crash-box
  1461.    vm-delete-after-archiving
  1462.    vm-delete-after-bursting
  1463.    vm-delete-after-saving
  1464.    vm-delete-empty-folders
  1465.    vm-digest-center-preamble
  1466.    vm-digest-preamble-format
  1467.    vm-folder-directory
  1468.    vm-folder-read-only
  1469.    vm-follow-summary-cursor
  1470.    vm-forwarding-subject-format
  1471.    vm-gargle-uucp
  1472.    vm-group-by
  1473.    vm-highlighted-header-regexp
  1474.    vm-honor-page-delimiters
  1475.    vm-in-reply-to-format
  1476.    vm-included-text-attribution-format
  1477.    vm-included-text-prefix
  1478.    vm-inhibit-startup-message
  1479.    vm-invisible-header-regexp
  1480.    vm-keep-sent-messages
  1481.    vm-mail-header-from
  1482.    vm-mail-window-percentage
  1483.    vm-mode-hooks
  1484.    vm-move-after-deleting
  1485.    vm-move-after-undeleting
  1486.    vm-mutable-windows
  1487.    vm-preview-lines
  1488.    vm-preview-read-messages
  1489.    vm-primary-inbox
  1490.    vm-retain-message-order
  1491.    vm-reply-ignored-addresses
  1492.    vm-reply-subject-prefix
  1493.    vm-rfc934-forwarding
  1494.    vm-search-using-regexps
  1495.    vm-skip-deleted-messages
  1496.    vm-skip-read-messages
  1497.    vm-spool-files
  1498.    vm-startup-with-summary
  1499.    vm-strip-reply-headers
  1500.    vm-summary-format
  1501.    vm-virtual-folder-alist
  1502.    vm-virtual-mirror
  1503.    vm-visible-headers
  1504.    vm-visit-when-saving
  1505.    vm-window-configuration-file"
  1506.   (interactive)
  1507.   (vm (current-buffer)))
  1508.  
  1509. ;; this does the real major mode scutwork.
  1510. (defun vm-mode-internal ()
  1511.   (widen)
  1512.   (setq
  1513.    case-fold-search t
  1514.    checkpoint-direct-conversion-hooks '(vm-checkpoint-prologue-hook)
  1515.    checkpoint-epilogue-hooks '(vm-checkpoint-epilogue-hook)
  1516.    major-mode 'vm-mode
  1517.    mode-line-format vm-mode-line-format
  1518.    mode-name "VM"
  1519.    buffer-read-only t
  1520.    vm-message-list nil
  1521.    vm-message-pointer nil
  1522.    vm-current-grouping vm-group-by
  1523.    vm-folder-type (vm-get-folder-type)
  1524.    vm-primary-inbox-p (equal buffer-file-name
  1525.                  (expand-file-name vm-primary-inbox)))
  1526.   (use-local-map vm-mode-map)
  1527.   (run-hooks 'vm-mode-hooks))
  1528.  
  1529. (put 'vm-mode 'mode-class 'special)
  1530.  
  1531. (if (not (memq 'vm-write-file-hook write-file-hooks))
  1532.     (setq write-file-hooks
  1533.       (cons 'vm-write-file-hook write-file-hooks)))
  1534.  
  1535. (if (not (memq 'vm-handle-file-recovery find-file-hooks))
  1536.     (setq find-file-hooks
  1537.       (nconc find-file-hooks
  1538.          '(vm-handle-file-recovery
  1539.            vm-handle-file-reversion))))
  1540.