Mercurial > hg > xemacs-beta

comparison lisp/vm/vm-folder.el @ 20:859a2309aef8 r19-15b93

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-15b93
author cvs
date Mon, 13 Aug 2007 08:50:05 +0200
parents 49a24b4fd526
children 4103f0995bd7
comparison
equal deleted inserted replaced
19:ac1f612d5250 20:859a2309aef8
1 ;;; VM folder related functions 1 ;;; VM folder related functions
2 ;;; Copyright (C) 1989, 1990, 1991, 1993, 1994, 1995, 1996 Kyle E. Jones 2 ;;; Copyright (C) 1989-1997 Kyle E. Jones
3 ;;; 3 ;;;
4 ;;; This program is free software; you can redistribute it and/or modify 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 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) 6 ;;; the Free Software Foundation; either version 1, or (at your option)
7 ;;; any later version. 7 ;;; any later version.
57 (t means start from the beginning of vm-message-list.) 57 (t means start from the beginning of vm-message-list.)
58 If START-POINT is closer to the head of vm-message-list than 58 If START-POINT is closer to the head of vm-message-list than
59 vm-numbering-redo-start-point or is equal to t, then 59 vm-numbering-redo-start-point or is equal to t, then
60 vm-numbering-redo-start-point is set to match it." 60 vm-numbering-redo-start-point is set to match it."
61 (intern (buffer-name) vm-buffers-needing-display-update) 61 (intern (buffer-name) vm-buffers-needing-display-update)
62 (if (and (consp start-point) (consp vm-numbering-redo-start-point) 62 (if (eq vm-numbering-redo-start-point t)
63 (not (eq vm-numbering-redo-start-point t))) 63 nil
64 (let ((mp vm-message-list)) 64 (if (and (consp start-point) (consp vm-numbering-redo-start-point))
65 (while (and mp (not (or (eq mp start-point) 65 (let ((mp vm-message-list))
66 (eq mp vm-numbering-redo-start-point)))) 66 (while (and mp (not (or (eq mp start-point)
67 (setq mp (cdr mp))) 67 (eq mp vm-numbering-redo-start-point))))
68 (if (null mp) 68 (setq mp (cdr mp)))
69 (error "Something is wrong in vm-set-numbering-redo-start-point")) 69 (if (null mp)
70 (if (eq mp start-point) 70 (error "Something is wrong in vm-set-numbering-redo-start-point"))
71 (setq vm-numbering-redo-start-point start-point))) 71 (if (eq mp start-point)
72 (setq vm-numbering-redo-start-point start-point))) 72 (setq vm-numbering-redo-start-point start-point)))
73 (setq vm-numbering-redo-start-point start-point))))
73 74
74 (defun vm-set-numbering-redo-end-point (end-point) 75 (defun vm-set-numbering-redo-end-point (end-point)
75 "Set vm-numbering-redo-end-point to END-POINT if appropriate. 76 "Set vm-numbering-redo-end-point to END-POINT if appropriate.
76 Also mark the current buffer as needing a display update. 77 Also mark the current buffer as needing a display update.
77 78
120 Also mark the current buffer as needing a display update. 121 Also mark the current buffer as needing a display update.
121 122
122 START-POINT should be a cons in vm-message-list or just t. 123 START-POINT should be a cons in vm-message-list or just t.
123 (t means start from the beginning of vm-message-list.) 124 (t means start from the beginning of vm-message-list.)
124 If START-POINT is closer to the head of vm-message-list than 125 If START-POINT is closer to the head of vm-message-list than
125 vm-numbering-redo-start-point or is equal to t, then 126 vm-summary-redo-start-point or is equal to t, then
126 vm-numbering-redo-start-point is set to match it." 127 vm-summary-redo-start-point is set to match it."
127 (intern (buffer-name) vm-buffers-needing-display-update) 128 (intern (buffer-name) vm-buffers-needing-display-update)
128 (if (and (consp start-point) (consp vm-summary-redo-start-point) 129 (if (eq vm-summary-redo-start-point t)
129 (not (eq vm-summary-redo-start-point t))) 130 nil
130 (let ((mp vm-message-list)) 131 (if (and (consp start-point) (consp vm-summary-redo-start-point))
131 (while (and mp (not (or (eq mp start-point) 132 (let ((mp vm-message-list))
132 (eq mp vm-summary-redo-start-point)))) 133 (while (and mp (not (or (eq mp start-point)
133 (setq mp (cdr mp))) 134 (eq mp vm-summary-redo-start-point))))
134 (if (null mp) 135 (setq mp (cdr mp)))
135 (error "Something is wrong in vm-set-summary-redo-start-point")) 136 (if (null mp)
136 (if (eq mp start-point) 137 (error "Something is wrong in vm-set-summary-redo-start-point"))
137 (setq vm-summary-redo-start-point start-point))) 138 (if (eq mp start-point)
138 (setq vm-summary-redo-start-point start-point))) 139 (setq vm-summary-redo-start-point start-point)))
140 (setq vm-summary-redo-start-point start-point))))
139 141
140 (defun vm-mark-for-summary-update (m &optional dont-kill-cache) 142 (defun vm-mark-for-summary-update (m &optional dont-kill-cache)
141 "Mark message M for a summary update. 143 "Mark message M for a summary update.
142 Also mark M's buffer as needing a display update. Any virtual 144 Also mark M's buffer as needing a display update. Any virtual
143 messages of M and their buffers are similarly marked for update. 145 messages of M and their buffers are similarly marked for update.
233 235
234 (defun vm-do-needed-mode-line-update () 236 (defun vm-do-needed-mode-line-update ()
235 "Do a modeline update for the current folder buffer. 237 "Do a modeline update for the current folder buffer.
236 This means setting up all the various vm-ml attribute variables 238 This means setting up all the various vm-ml attribute variables
237 in the folder buffer and copying necessary variables to the 239 in the folder buffer and copying necessary variables to the
238 folder buffer's summary buffer, and then forcing Emacs to update 240 folder buffer's summary and presentation buffers, and then
239 all modelines. 241 forcing Emacs to update all modelines.
240 242
241 Also if a virtual folder being updated has no messages, 243 If a virtual folder being updated has no messages, then
242 erase-buffer is called on its buffer." 244 erase-buffer is called on its buffer.
245
246 If any type of folder is empty, erase-buffer is called
247 on its presentation buffer, if any."
243 ;; XXX This last bit should probably should be moved to 248 ;; XXX This last bit should probably should be moved to
244 ;; XXX vm-expunge-folder. 249 ;; XXX vm-expunge-folder.
245 250
246 (if (null vm-message-pointer) 251 (if (null vm-message-pointer)
247 ;; erase the leftover message if the folder is really empty. 252 (progn
248 (if (eq major-mode 'vm-virtual-mode) 253 ;; erase the leftover message if the folder is really empty.
249 (let ((buffer-read-only nil) 254 (if (eq major-mode 'vm-virtual-mode)
250 (omodified (buffer-modified-p))) 255 (let ((buffer-read-only nil)
251 (unwind-protect 256 (omodified (buffer-modified-p)))
252 (erase-buffer) 257 (unwind-protect
253 (set-buffer-modified-p omodified)))) 258 (erase-buffer)
259 (set-buffer-modified-p omodified))))
260 (if vm-presentation-buffer
261 (let ((omodified (buffer-modified-p)))
262 (unwind-protect
263 (save-excursion
264 (set-buffer vm-presentation-buffer)
265 (let ((buffer-read-only nil))
266 (erase-buffer)))
267 (set-buffer-modified-p omodified)))))
254 ;; try to avoid calling vm-su-labels if possible so as to 268 ;; try to avoid calling vm-su-labels if possible so as to
255 ;; avoid loading vm-summary.el. 269 ;; avoid loading vm-summary.el.
256 (if (vm-labels-of (car vm-message-pointer)) 270 (if (vm-labels-of (car vm-message-pointer))
257 (setq vm-ml-labels (vm-su-labels (car vm-message-pointer))) 271 (setq vm-ml-labels (vm-su-labels (car vm-message-pointer)))
258 (setq vm-ml-labels nil)) 272 (setq vm-ml-labels nil))
293 'vm-ml-sort-keys 307 'vm-ml-sort-keys
294 'vm-ml-labels 308 'vm-ml-labels
295 'vm-message-list) 309 'vm-message-list)
296 (set-buffer vm-summary-buffer) 310 (set-buffer vm-summary-buffer)
297 (set-buffer-modified-p modified)))) 311 (set-buffer-modified-p modified))))
312 (if vm-presentation-buffer
313 (let ((modified (buffer-modified-p)))
314 (save-excursion
315 (vm-copy-local-variables vm-presentation-buffer
316 'vm-ml-message-new
317 'vm-ml-message-unread
318 'vm-ml-message-read
319 'vm-ml-message-edited
320 'vm-ml-message-replied
321 'vm-ml-message-forwarded
322 'vm-ml-message-filed
323 'vm-ml-message-written
324 'vm-ml-message-deleted
325 'vm-ml-message-marked
326 'vm-ml-message-number
327 'vm-ml-highest-message-number
328 'vm-folder-read-only
329 'vm-folder-type
330 'vm-virtual-folder-definition
331 'vm-virtual-mirror
332 'vm-ml-labels
333 'vm-message-list)
334 (set-buffer vm-presentation-buffer)
335 (set-buffer-modified-p modified))))
298 (vm-force-mode-line-update)) 336 (vm-force-mode-line-update))
299 337
300 (defun vm-update-summary-and-mode-line () 338 (defun vm-update-summary-and-mode-line ()
301 "Update summary and mode line for all VM folder and summary buffers. 339 "Update summary and mode line for all VM folder and summary buffers.
302 Really this updates all the visible status indicators. 340 Really this updates all the visible status indicators.
438 (defun vm-get-folder-type (&optional file start end) 476 (defun vm-get-folder-type (&optional file start end)
439 "Return a symbol indicating the folder type of the current buffer. 477 "Return a symbol indicating the folder type of the current buffer.
440 This function works by examining the beginning of a folder. 478 This function works by examining the beginning of a folder.
441 If optional arg FILE is present the type of FILE is returned instead. 479 If optional arg FILE is present the type of FILE is returned instead.
442 If optional second and third arg START and END are provided, 480 If optional second and third arg START and END are provided,
443 vm-get-folder-type will examine the the text between those buffer 481 vm-get-folder-type will examine the text between those buffer
444 positions. START and END default to 1 and (buffer-size) + 1. 482 positions. START and END default to 1 and (buffer-size) + 1.
445 483
446 Returns 484 Returns
447 nil if folder has no type (empty) 485 nil if folder has no type (empty)
448 unknown if the type is not known to VM 486 unknown if the type is not known to VM
937 (vm-set-vheaders-of message (vm-marker (match-beginning 0)))) 975 (vm-set-vheaders-of message (vm-marker (match-beginning 0))))
938 ;; oh well, we gotta do it the hard way. 976 ;; oh well, we gotta do it the hard way.
939 ;; 977 ;;
940 ;; header-alist will contain an assoc list version of 978 ;; header-alist will contain an assoc list version of
941 ;; keep-list. For messages associated with a folder 979 ;; keep-list. For messages associated with a folder
942 ;; buffer: when a matching header is found, the header 980 ;; buffer: when a matching header is found, the
943 ;; is stuffed into its corresponding assoc cell and the 981 ;; header's start and end positions are added to its
944 ;; header text is deleted from the buffer. After all 982 ;; corresponding assoc cell. The positions of unwanted
945 ;; the visible headers have been collected, they are 983 ;; headers are remember also so that they can be copied
946 ;; inserted into the buffer in a clump at the end of 984 ;; to the top of the message, to be out of sight after
947 ;; the header section. Unmatched headers are skipped over. 985 ;; narrowing. Once the positions have all been
986 ;; recorded a new copy of the headers is inserted in
987 ;; the proper order and the old headers are deleted.
948 ;; 988 ;;
949 ;; For free standing messages, unmatched headers are 989 ;; For free standing messages, unwanted headers are
950 ;; stripped from the message. 990 ;; stripped from the message, unremembered.
951 (vm-save-restriction 991 (vm-save-restriction
952 (let ((header-alist (vm-build-header-order-alist keep-list)) 992 (let ((header-alist (vm-build-header-order-alist keep-list))
953 (buffer-read-only nil) 993 (buffer-read-only nil)
954 (work-buffer nil) 994 (work-buffer nil)
955 (extras nil) 995 (extras nil)
959 ;; locking can speed things noticeably if the lock directory 999 ;; locking can speed things noticeably if the lock directory
960 ;; is on a slow device. We don't need locking here because 1000 ;; is on a slow device. We don't need locking here because
961 ;; in a mail context reordering headers is harmless. 1001 ;; in a mail context reordering headers is harmless.
962 (buffer-file-name nil) 1002 (buffer-file-name nil)
963 (case-fold-search t) 1003 (case-fold-search t)
1004 (unwanted-list nil)
1005 unwanted-tail
1006 new-header-start
1007 old-header-start
964 (old-buffer-modified-p (buffer-modified-p))) 1008 (old-buffer-modified-p (buffer-modified-p)))
965 (unwind-protect 1009 (unwind-protect
966 (progn 1010 (progn
967 (if message 1011 (if message
968 (progn 1012 (progn
985 (insert-buffer-substring 1029 (insert-buffer-substring
986 folder-buffer 1030 folder-buffer
987 (vm-headers-of message) 1031 (vm-headers-of message)
988 (vm-text-of message)) 1032 (vm-text-of message))
989 (goto-char (point-min)))) 1033 (goto-char (point-min))))
1034 (setq old-header-start (point))
990 (while (and (not (= (following-char) ?\n)) 1035 (while (and (not (= (following-char) ?\n))
991 (vm-match-header)) 1036 (vm-match-header))
992 (setq end-of-header (vm-matched-header-end) 1037 (setq end-of-header (vm-matched-header-end)
993 list (vm-match-ordered-header header-alist)) 1038 list (vm-match-ordered-header header-alist))
994 ;; don't display/keep this header if 1039 ;; don't display/keep this header if
996 ;; and discard-regexp is nil 1041 ;; and discard-regexp is nil
997 ;; or 1042 ;; or
998 ;; discard-regexp is matched 1043 ;; discard-regexp is matched
999 (if (or (and (null list) (null discard-regexp)) 1044 (if (or (and (null list) (null discard-regexp))
1000 (and discard-regexp (looking-at discard-regexp))) 1045 (and discard-regexp (looking-at discard-regexp)))
1001 ;; skip the unwanted header if doing 1046 ;; delete the unwanted header if not doing
1002 ;; work for a folder buffer, otherwise 1047 ;; work for a folder buffer, otherwise
1003 ;; discard the header. 1048 ;; remember the start and end of the
1004 (if message 1049 ;; unwanted header so we can copy it
1005 (goto-char end-of-header) 1050 ;; later.
1006 (delete-region (point) end-of-header)) 1051 (if (not message)
1052 (delete-region (point) end-of-header)
1053 (if (null unwanted-list)
1054 (setq unwanted-list
1055 (cons (point) (cons end-of-header nil))
1056 unwanted-tail unwanted-list)
1057 (if (= (point) (car (cdr unwanted-tail)))
1058 (setcar (cdr unwanted-tail)
1059 end-of-header)
1060 (setcdr (cdr unwanted-tail)
1061 (cons (point)
1062 (cons end-of-header nil)))
1063 (setq unwanted-tail (cdr (cdr unwanted-tail)))))
1064 (goto-char end-of-header))
1007 ;; got a match 1065 ;; got a match
1008 ;; stuff the header into the cdr of the 1066 ;; stuff the start and end of the header
1009 ;; returned alist element 1067 ;; into the cdr of the returned alist
1068 ;; element.
1010 (if list 1069 (if list
1011 (if (cdr list) 1070 ;; reverse point and end-of-header.
1012 (setcdr list 1071 ;; list will be nreversed later.
1013 (concat 1072 (setcdr list (cons end-of-header
1014 (cdr list) 1073 (cons (point)
1015 (buffer-substring (point) 1074 (cdr list))))
1016 end-of-header))) 1075 ;; reverse point and end-of-header.
1017 (setcdr list (buffer-substring (point) 1076 ;; list will be nreversed later.
1018 end-of-header)))
1019 (setq extras 1077 (setq extras
1020 (cons (buffer-substring (point) end-of-header) 1078 (cons end-of-header
1021 extras))) 1079 (cons (point) extras))))
1022 (delete-region (point) end-of-header))) 1080 (goto-char end-of-header)))
1081 (setq new-header-start (point))
1082 (while unwanted-list
1083 (insert-buffer-substring (current-buffer)
1084 (car unwanted-list)
1085 (car (cdr unwanted-list)))
1086 (setq unwanted-list (cdr (cdr unwanted-list))))
1023 ;; remember the offset of where the visible 1087 ;; remember the offset of where the visible
1024 ;; header start so we can initialize the 1088 ;; header start so we can initialize the
1025 ;; vm-vheaders-of field later. 1089 ;; vm-vheaders-of field later.
1026 (if message 1090 (if message
1027 (setq vheader-offset (1- (point)))) 1091 (setq vheader-offset (- (point) new-header-start)))
1028 ;; now dump out the headers we saved. 1092 (while header-alist
1029 ;; the keep-list headers go first. 1093 (setq list (nreverse (cdr (car header-alist))))
1030 (setq list header-alist) 1094 (while list
1031 (while list 1095 (insert-buffer-substring (current-buffer)
1032 (if (cdr (car list)) 1096 (car list)
1033 (progn 1097 (car (cdr list)))
1034 (insert (cdr (car list))) 1098 (setq list (cdr (cdr list))))
1035 (setcdr (car list) nil))) 1099 (setq header-alist (cdr header-alist)))
1036 (setq list (cdr list)))
1037 ;; now the headers that were not explicitly 1100 ;; now the headers that were not explicitly
1038 ;; undesirable, if any. 1101 ;; undesirable, if any.
1039 (if extras 1102 (setq extras (nreverse extras))
1040 (progn 1103 (while extras
1041 (setq extras (nreverse extras)) 1104 (insert-buffer-substring (current-buffer)
1042 (while extras 1105 (car extras)
1043 (insert (car extras)) 1106 (car (cdr extras)))
1044 (setq extras (cdr extras))))) 1107 (setq extras (cdr (cdr extras))))
1108 (delete-region old-header-start new-header-start)
1045 ;; update the folder buffer if we're supposed to. 1109 ;; update the folder buffer if we're supposed to.
1046 ;; lock out interrupts. 1110 ;; lock out interrupts.
1047 (if message 1111 (if message
1048 (let ((inhibit-quit t)) 1112 (let ((inhibit-quit t))
1049 (set-buffer (vm-buffer-of message)) 1113 (set-buffer (vm-buffer-of message))
1471 (widen) 1535 (widen)
1472 (let ((old-buffer-modified-p (buffer-modified-p)) 1536 (let ((old-buffer-modified-p (buffer-modified-p))
1473 attributes cache 1537 attributes cache
1474 (case-fold-search t) 1538 (case-fold-search t)
1475 (buffer-read-only nil) 1539 (buffer-read-only nil)
1476 ;; don't truncate the printing of large Lisp objects
1477 (print-length nil)
1478 opoint 1540 opoint
1479 ;; This prevents file locking from occuring. Disabling 1541 ;; This prevents file locking from occuring. Disabling
1480 ;; locking can speed things noticeably if the lock 1542 ;; locking can speed things noticeably if the lock
1481 ;; directory is on a slow device. We don't need locking 1543 ;; directory is on a slow device. We don't need locking
1482 ;; here because the user shouldn't care about VM stuffing 1544 ;; here because the user shouldn't care about VM stuffing
1531 "O\n") 1593 "O\n")
1532 (set-marker (vm-headers-of m) opoint))))) 1594 (set-marker (vm-headers-of m) opoint)))))
1533 (vm-set-modflag-of m nil)) 1595 (vm-set-modflag-of m nil))
1534 (set-buffer-modified-p old-buffer-modified-p)))))) 1596 (set-buffer-modified-p old-buffer-modified-p))))))
1535 1597
1598 (defun vm-stuff-folder-attributes (&optional abort-if-input-pending)
1599 (let ((newlist nil) mp)
1600 ;; stuff the attributes of messages that need it.
1601 ;; build a list of messages that need their attributes stuffed
1602 (setq mp vm-message-list)
1603 (while mp
1604 (if (vm-modflag-of (car mp))
1605 (setq newlist (cons (car mp) newlist)))
1606 (setq mp (cdr mp)))
1607 ;; now sort the list by physical order so that we
1608 ;; reduce the amount of gap motion induced by modifying
1609 ;; the buffer. what we want to avoid is updating
1610 ;; message 3, then 234, then 10, then 500, thus causing
1611 ;; large chunks of memory to be copied repeatedly as
1612 ;; the gap moves to accomodate the insertions.
1613 (let ((vm-key-functions '(vm-sort-compare-physical-order-r)))
1614 (setq mp (sort newlist 'vm-sort-compare-xxxxxx)))
1615 (while (and mp (or (not abort-if-input-pending) (not (input-pending-p))))
1616 (vm-stuff-attributes (car mp))
1617 (setq mp (cdr mp)))
1618 (if mp nil t)))
1619
1536 ;; we can be a bit lazy in this function since it's only called 1620 ;; we can be a bit lazy in this function since it's only called
1537 ;; from within vm-stuff-attributes. we don't worry about 1621 ;; from within vm-stuff-attributes. we don't worry about
1538 ;; restoring the modified flag, setting buffer-read-only, or 1622 ;; restoring the modified flag, setting buffer-read-only, or
1539 ;; about not moving point. 1623 ;; about not moving point.
1540 (defun vm-stuff-babyl-attributes (m for-other-folder) 1624 (defun vm-stuff-babyl-attributes (m for-other-folder)
1653 ;; just insert. This will cause the summary header 1737 ;; just insert. This will cause the summary header
1654 ;; to be visible if there are no non-visible headers, 1738 ;; to be visible if there are no non-visible headers,
1655 ;; oh well, no way around this. 1739 ;; oh well, no way around this.
1656 (insert vm-labels-header " " 1740 (insert vm-labels-header " "
1657 (let ((print-escape-newlines t) 1741 (let ((print-escape-newlines t)
1658 ;; don't truncate the printing of large Lisp objects
1659 (print-length nil)
1660 (list nil)) 1742 (list nil))
1661 (mapatoms (function 1743 (mapatoms (function
1662 (lambda (sym) 1744 (lambda (sym)
1663 (setq list (cons (symbol-name sym) list)))) 1745 (setq list (cons (symbol-name sym) list))))
1664 vm-label-obarray) 1746 vm-label-obarray)
1715 (save-excursion 1797 (save-excursion
1716 (vm-save-restriction 1798 (vm-save-restriction
1717 (widen) 1799 (widen)
1718 (let ((old-buffer-modified-p (buffer-modified-p)) 1800 (let ((old-buffer-modified-p (buffer-modified-p))
1719 (case-fold-search t) 1801 (case-fold-search t)
1720 ;; don't truncate the printing of large Lisp objects
1721 (print-length nil)
1722 ;; This prevents file locking from occuring. Disabling 1802 ;; This prevents file locking from occuring. Disabling
1723 ;; locking can speed things noticeably if the lock 1803 ;; locking can speed things noticeably if the lock
1724 ;; directory is on a slow device. We don't need locking 1804 ;; directory is on a slow device. We don't need locking
1725 ;; here because the user shouldn't care about VM stuffing 1805 ;; here because the user shouldn't care about VM stuffing
1726 ;; its own status headers. 1806 ;; its own status headers.
1763 (widen) 1843 (widen)
1764 (let ((old-buffer-modified-p (buffer-modified-p)) 1844 (let ((old-buffer-modified-p (buffer-modified-p))
1765 (case-fold-search t) 1845 (case-fold-search t)
1766 (print-escape-newlines t) 1846 (print-escape-newlines t)
1767 lim 1847 lim
1768 ;; don't truncate the printing of large Lisp objects
1769 (print-length nil)
1770 (buffer-read-only nil) 1848 (buffer-read-only nil)
1771 ;; This prevents file locking from occuring. Disabling 1849 ;; This prevents file locking from occuring. Disabling
1772 ;; locking can speed things noticeably if the lock 1850 ;; locking can speed things noticeably if the lock
1773 ;; directory is on a slow device. We don't need locking 1851 ;; directory is on a slow device. We don't need locking
1774 ;; here because the user shouldn't care about VM stuffing 1852 ;; here because the user shouldn't care about VM stuffing
1808 (save-excursion 1886 (save-excursion
1809 (vm-save-restriction 1887 (vm-save-restriction
1810 (widen) 1888 (widen)
1811 (let ((old-buffer-modified-p (buffer-modified-p)) 1889 (let ((old-buffer-modified-p (buffer-modified-p))
1812 (case-fold-search t) 1890 (case-fold-search t)
1813 ;; don't truncate the printing of large Lisp objects
1814 (print-length nil)
1815 ;; This prevents file locking from occuring. Disabling 1891 ;; This prevents file locking from occuring. Disabling
1816 ;; locking can speed things noticeably if the lock 1892 ;; locking can speed things noticeably if the lock
1817 ;; directory is on a slow device. We don't need locking 1893 ;; directory is on a slow device. We don't need locking
1818 ;; here because the user shouldn't care about VM stuffing 1894 ;; here because the user shouldn't care about VM stuffing
1819 ;; its own status headers. 1895 ;; its own status headers.
1935 (interactive) 2011 (interactive)
1936 (vm-select-folder-buffer) 2012 (vm-select-folder-buffer)
1937 (if (not (memq major-mode '(vm-mode vm-virtual-mode))) 2013 (if (not (memq major-mode '(vm-mode vm-virtual-mode)))
1938 (error "%s must be invoked from a VM buffer." this-command)) 2014 (error "%s must be invoked from a VM buffer." this-command))
1939 (vm-check-for-killed-summary) 2015 (vm-check-for-killed-summary)
1940 2016 (vm-check-for-killed-presentation)
1941 (run-hooks 'vm-quit-hook) 2017
2018 (save-excursion (run-hooks 'vm-quit-hook))
2019
2020 (vm-garbage-collect-message)
1942 2021
1943 (vm-display nil nil '(vm-quit-just-bury) 2022 (vm-display nil nil '(vm-quit-just-bury)
1944 '(vm-quit-just-bury quitting)) 2023 '(vm-quit-just-bury quitting))
1945 (if vm-summary-buffer 2024 (if vm-summary-buffer
1946 (vm-display vm-summary-buffer nil nil nil)) 2025 (vm-display vm-summary-buffer nil nil nil))
1947 (if vm-summary-buffer 2026 (if vm-summary-buffer
1948 (vm-bury-buffer vm-summary-buffer)) 2027 (vm-bury-buffer vm-summary-buffer))
2028 (if vm-presentation-buffer-handle
2029 (vm-display vm-presentation-buffer-handle nil nil nil))
2030 (if vm-presentation-buffer-handle
2031 (vm-bury-buffer vm-presentation-buffer-handle))
1949 (vm-display (current-buffer) nil nil nil) 2032 (vm-display (current-buffer) nil nil nil)
1950 (vm-bury-buffer (current-buffer))) 2033 (vm-bury-buffer (current-buffer)))
1951 2034
1952 (defun vm-quit-just-iconify () 2035 (defun vm-quit-just-iconify ()
1953 "Iconify the frame and bury the current VM folder and summary buffers. 2036 "Iconify the frame and bury the current VM folder and summary buffers.
1955 (interactive) 2038 (interactive)
1956 (vm-select-folder-buffer) 2039 (vm-select-folder-buffer)
1957 (if (not (memq major-mode '(vm-mode vm-virtual-mode))) 2040 (if (not (memq major-mode '(vm-mode vm-virtual-mode)))
1958 (error "%s must be invoked from a VM buffer." this-command)) 2041 (error "%s must be invoked from a VM buffer." this-command))
1959 (vm-check-for-killed-summary) 2042 (vm-check-for-killed-summary)
1960 2043 (vm-check-for-killed-presentation)
1961 (run-hooks 'vm-quit-hook) 2044
2045 (save-excursion (run-hooks 'vm-quit-hook))
2046
2047 (vm-garbage-collect-message)
1962 2048
1963 (vm-display nil nil '(vm-quit-just-iconify) 2049 (vm-display nil nil '(vm-quit-just-iconify)
1964 '(vm-quit-just-iconify quitting)) 2050 '(vm-quit-just-iconify quitting))
1965 (vm-bury-buffer (current-buffer)) 2051 (let ((summary-buffer vm-summary-buffer)
1966 (if vm-summary-buffer 2052 (pres-buffer vm-presentation-buffer-handle))
1967 (vm-bury-buffer vm-summary-buffer)) 2053 (vm-bury-buffer (current-buffer))
1968 (vm-iconify-frame)) 2054 (if summary-buffer
2055 (vm-bury-buffer summary-buffer))
2056 (if pres-buffer
2057 (vm-bury-buffer pres-buffer))
2058 (vm-iconify-frame)))
1969 2059
1970 (defun vm-quit-no-change () 2060 (defun vm-quit-no-change ()
1971 "Quit visiting the current folder without saving changes made to the folder." 2061 "Quit visiting the current folder without saving changes made to the folder."
1972 (interactive) 2062 (interactive)
1973 (vm-quit t)) 2063 (vm-quit t))
1977 (interactive) 2067 (interactive)
1978 (vm-select-folder-buffer) 2068 (vm-select-folder-buffer)
1979 (if (not (memq major-mode '(vm-mode vm-virtual-mode))) 2069 (if (not (memq major-mode '(vm-mode vm-virtual-mode)))
1980 (error "%s must be invoked from a VM buffer." this-command)) 2070 (error "%s must be invoked from a VM buffer." this-command))
1981 (vm-check-for-killed-summary) 2071 (vm-check-for-killed-summary)
2072 (vm-check-for-killed-presentation)
1982 (vm-display nil nil '(vm-quit vm-quit-no-change) 2073 (vm-display nil nil '(vm-quit vm-quit-no-change)
1983 (list this-command 'quitting)) 2074 (list this-command 'quitting))
1984 (let ((virtual (eq major-mode 'vm-virtual-mode))) 2075 (let ((virtual (eq major-mode 'vm-virtual-mode)))
1985 (cond 2076 (cond
1986 ((and (not virtual) no-change (buffer-modified-p) 2077 ((and (not virtual) no-change (buffer-modified-p)
2078 (or buffer-file-name buffer-offer-save)
1987 (not (zerop vm-messages-not-on-disk)) 2079 (not (zerop vm-messages-not-on-disk))
1988 ;; Folder may have been saved with C-x C-s and attributes may have 2080 ;; Folder may have been saved with C-x C-s and attributes may have
1989 ;; been changed after that; in that case vm-messages-not-on-disk 2081 ;; been changed after that; in that case vm-messages-not-on-disk
1990 ;; would not have been zeroed. However, all modification flag 2082 ;; would not have been zeroed. However, all modification flag
1991 ;; undos are cleared if VM actually modifies the folder buffer 2083 ;; undos are cleared if VM actually modifies the folder buffer
1998 "%d message%s have not been saved to disk, quit anyway? " 2090 "%d message%s have not been saved to disk, quit anyway? "
1999 vm-messages-not-on-disk 2091 vm-messages-not-on-disk
2000 (if (= 1 vm-messages-not-on-disk) "" "s"))))) 2092 (if (= 1 vm-messages-not-on-disk) "" "s")))))
2001 (error "Aborted")) 2093 (error "Aborted"))
2002 ((and (not virtual) 2094 ((and (not virtual)
2003 no-change (buffer-modified-p) vm-confirm-quit 2095 no-change
2096 (or buffer-file-name buffer-offer-save)
2097 (buffer-modified-p)
2098 vm-confirm-quit
2004 (not (y-or-n-p "There are unsaved changes, quit anyway? "))) 2099 (not (y-or-n-p "There are unsaved changes, quit anyway? ")))
2005 (error "Aborted")) 2100 (error "Aborted"))
2006 ((and (eq vm-confirm-quit t) 2101 ((and (eq vm-confirm-quit t)
2007 (not (y-or-n-p "Do you really want to quit? "))) 2102 (not (y-or-n-p "Do you really want to quit? ")))
2008 (error "Aborted"))) 2103 (error "Aborted")))
2009 2104
2010 (run-hooks 'vm-quit-hook) 2105 (save-excursion (run-hooks 'vm-quit-hook))
2106
2107 (vm-garbage-collect-message)
2108 (vm-garbage-collect-folder)
2011 2109
2012 (vm-virtual-quit) 2110 (vm-virtual-quit)
2013 (if (and (not no-change) (not virtual)) 2111 (if (and (not no-change) (not virtual))
2014 (progn 2112 (progn
2015 ;; this could take a while, so give the user some feedback 2113 ;; this could take a while, so give the user some feedback
2016 (vm-unsaved-message "Quitting...") 2114 (vm-unsaved-message "Quitting...")
2017 (or vm-folder-read-only (eq major-mode 'vm-virtual-mode) 2115 (or vm-folder-read-only (eq major-mode 'vm-virtual-mode)
2018 (vm-change-all-new-to-unread)))) 2116 (vm-change-all-new-to-unread))))
2019 (if (and (buffer-modified-p) (not no-change) (not virtual)) 2117 (if (and (buffer-modified-p)
2118 (or buffer-file-name buffer-offer-save)
2119 (not no-change)
2120 (not virtual))
2020 (vm-save-folder)) 2121 (vm-save-folder))
2021 (vm-unsaved-message "") 2122 (vm-unsaved-message "")
2022 (let ((summary-buffer vm-summary-buffer) 2123 (let ((summary-buffer vm-summary-buffer)
2124 (pres-buffer vm-presentation-buffer-handle)
2023 (mail-buffer (current-buffer))) 2125 (mail-buffer (current-buffer)))
2024 (if summary-buffer 2126 (if summary-buffer
2025 (progn 2127 (progn
2026 (vm-display vm-summary-buffer nil nil nil) 2128 (vm-display summary-buffer nil nil nil)
2027 (kill-buffer summary-buffer))) 2129 (kill-buffer summary-buffer)))
2130 (if pres-buffer
2131 (progn
2132 (vm-display pres-buffer nil nil nil)
2133 (kill-buffer pres-buffer)))
2028 (set-buffer mail-buffer) 2134 (set-buffer mail-buffer)
2029 (vm-display mail-buffer nil nil nil) 2135 (vm-display mail-buffer nil nil nil)
2030 ;; vm-display is not supposed to change the current buffer. 2136 ;; vm-display is not supposed to change the current buffer.
2031 ;; still better to be safe here. 2137 ;; still it's better to be safe here.
2032 (set-buffer mail-buffer) 2138 (set-buffer mail-buffer)
2033 (set-buffer-modified-p nil) 2139 (set-buffer-modified-p nil)
2034 (kill-buffer (current-buffer))) 2140 (kill-buffer (current-buffer)))
2035 (vm-update-summary-and-mode-line))) 2141 (vm-update-summary-and-mode-line)))
2036 2142
2037 (defun vm-start-itimers-if-needed () 2143 (defun vm-start-itimers-if-needed ()
2038 (if (or (natnump vm-flush-interval) 2144 (cond ((and (not (natnump vm-flush-interval))
2039 (natnump vm-auto-get-new-mail)) 2145 (not (natnump vm-auto-get-new-mail))))
2040 (progn 2146 ((condition-case data
2041 (if (null 2147 (progn (require 'itimer) t)
2042 (condition-case data 2148 (error nil))
2043 (progn (require 'itimer) t) 2149 (and (natnump vm-flush-interval) (not (get-itimer "vm-flush"))
2044 (error nil))) 2150 (start-itimer "vm-flush" 'vm-flush-itimer-function
2045 (setq vm-flush-interval t 2151 vm-flush-interval nil))
2046 vm-auto-get-new-mail t) 2152 (and (natnump vm-auto-get-new-mail) (not (get-itimer "vm-get-mail"))
2047 (and (natnump vm-flush-interval) (not (get-itimer "vm-flush")) 2153 (start-itimer "vm-get-mail" 'vm-get-mail-itimer-function
2048 (start-itimer "vm-flush" 'vm-flush-itimer-function 2154 vm-auto-get-new-mail nil)))
2049 vm-flush-interval nil)) 2155 ((condition-case data
2050 (and (natnump vm-auto-get-new-mail) (not (get-itimer "vm-get-mail")) 2156 (progn (require 'timer) t)
2051 (start-itimer "vm-get-mail" 'vm-get-mail-itimer-function 2157 (error nil))
2052 vm-auto-get-new-mail nil)))))) 2158 (let (timer)
2159 (and (natnump vm-flush-interval)
2160 (setq timer (run-at-time vm-flush-interval vm-flush-interval
2161 'vm-flush-itimer-function nil))
2162 (timer-set-function timer 'vm-flush-itimer-function
2163 (list timer)))
2164 (and (natnump vm-auto-get-new-mail)
2165 (setq timer (run-at-time vm-auto-get-new-mail
2166 vm-auto-get-new-mail
2167 'vm-get-mail-itimer-function nil))
2168 (timer-set-function timer 'vm-get-mail-itimer-function
2169 (list timer)))))
2170 (t
2171 (setq vm-flush-interval t
2172 vm-auto-get-new-mail t))))
2053 2173
2054 ;; support for numeric vm-auto-get-new-mail 2174 ;; support for numeric vm-auto-get-new-mail
2055 (defun vm-get-mail-itimer-function () 2175 ;; if timer argument is present, this means we're using the Emacs
2176 ;; 'timer package rather than the 'itimer package.
2177 (defun vm-get-mail-itimer-function (&optional timer)
2056 (if (integerp vm-auto-get-new-mail) 2178 (if (integerp vm-auto-get-new-mail)
2057 (set-itimer-restart current-itimer vm-auto-get-new-mail)) 2179 (if timer
2180 (timer-set-time timer (current-time) vm-auto-get-new-mail)
2181 (set-itimer-restart current-itimer vm-auto-get-new-mail)))
2058 (let ((b-list (buffer-list))) 2182 (let ((b-list (buffer-list)))
2059 (while (and (not (input-pending-p)) b-list) 2183 (while (and (not (input-pending-p)) b-list)
2060 (save-excursion 2184 (save-excursion
2061 (set-buffer (car b-list)) 2185 (set-buffer (car b-list))
2062 (if (and (eq major-mode 'vm-mode) 2186 (if (and (eq major-mode 'vm-mode)
2077 (vm-preview-current-message) 2201 (vm-preview-current-message)
2078 (vm-update-summary-and-mode-line))))) 2202 (vm-update-summary-and-mode-line)))))
2079 (setq b-list (cdr b-list))))) 2203 (setq b-list (cdr b-list)))))
2080 2204
2081 ;; support for numeric vm-flush-interval 2205 ;; support for numeric vm-flush-interval
2082 (defun vm-flush-itimer-function () 2206 ;; if timer argument is present, this means we're using the Emacs
2207 ;; 'timer package rather than the 'itimer package.
2208 (defun vm-flush-itimer-function (&optional timer)
2083 (if (integerp vm-flush-interval) 2209 (if (integerp vm-flush-interval)
2084 (set-itimer-restart current-itimer vm-flush-interval)) 2210 (if timer
2211 (timer-set-time timer (current-time) vm-flush-interval)
2212 (set-itimer-restart current-itimer vm-flush-interval)))
2085 ;; if no vm-mode buffers are found, we might as well shut down the 2213 ;; if no vm-mode buffers are found, we might as well shut down the
2086 ;; flush itimer. 2214 ;; flush itimer.
2087 (if (not (vm-flush-cached-data)) 2215 (if (not (vm-flush-cached-data))
2088 (set-itimer-restart current-itimer nil))) 2216 (if timer
2217 (cancel-timer timer)
2218 (set-itimer-restart current-itimer nil))))
2089 2219
2090 ;; flush cached data in all vm-mode buffers. 2220 ;; flush cached data in all vm-mode buffers.
2091 ;; returns non-nil if any vm-mode buffers were found. 2221 ;; returns non-nil if any vm-mode buffers were found.
2092 (defun vm-flush-cached-data () 2222 (defun vm-flush-cached-data ()
2093 (save-excursion 2223 (save-excursion
2097 (set-buffer (car buf-list)) 2227 (set-buffer (car buf-list))
2098 (cond ((and (eq major-mode 'vm-mode) vm-message-list) 2228 (cond ((and (eq major-mode 'vm-mode) vm-message-list)
2099 (setq found-one t) 2229 (setq found-one t)
2100 (if (not (eq vm-modification-counter 2230 (if (not (eq vm-modification-counter
2101 vm-flushed-modification-counter)) 2231 vm-flushed-modification-counter))
2102 (let ((mp vm-message-list)) 2232 (progn
2103 (vm-stuff-summary) 2233 (vm-stuff-summary)
2104 (vm-stuff-labels) 2234 (vm-stuff-labels)
2105 (and vm-message-order-changed 2235 (and vm-message-order-changed
2106 (vm-stuff-message-order)) 2236 (vm-stuff-message-order))
2107 (while (and mp (not (input-pending-p))) 2237 (and (vm-stuff-folder-attributes t)
2108 (if (vm-modflag-of (car mp))
2109 (vm-stuff-attributes (car mp)))
2110 (setq mp (cdr mp)))
2111 (and (null mp)
2112 (setq vm-flushed-modification-counter 2238 (setq vm-flushed-modification-counter
2113 vm-modification-counter)))))) 2239 vm-modification-counter))))))
2114 (setq buf-list (cdr buf-list))) 2240 (setq buf-list (cdr buf-list)))
2115 ;; if we haven't checked them all return non-nil so 2241 ;; if we haven't checked them all return non-nil so
2116 ;; the flusher won't give up trying. 2242 ;; the flusher won't give up trying.
2122 (if (and (eq major-mode 'vm-mode) (not vm-inhibit-write-file-hook)) 2248 (if (and (eq major-mode 'vm-mode) (not vm-inhibit-write-file-hook))
2123 ;; The vm-save-restriction isn't really necessary here, since 2249 ;; The vm-save-restriction isn't really necessary here, since
2124 ;; the stuff routines clean up after themselves, but should remain 2250 ;; the stuff routines clean up after themselves, but should remain
2125 ;; as a safeguard against the time when other stuff is added here. 2251 ;; as a safeguard against the time when other stuff is added here.
2126 (vm-save-restriction 2252 (vm-save-restriction
2127 (let ((mp vm-message-list) 2253 (let ((buffer-read-only))
2128 (buffer-read-only)) 2254 (vm-stuff-folder-attributes nil)
2129 (while mp 2255 (if vm-message-list
2130 (if (vm-modflag-of (car mp)) 2256 (progn
2131 (vm-stuff-attributes (car mp))) 2257 ;; get summary cache up-to-date
2132 (setq mp (cdr mp))) 2258 (vm-update-summary-and-mode-line)
2133 (if vm-message-list 2259 (vm-stuff-bookmark)
2134 (progn 2260 (vm-stuff-header-variables)
2135 ;; get summary cache up-to-date 2261 (vm-stuff-labels)
2136 (vm-update-summary-and-mode-line) 2262 (vm-stuff-summary)
2137 (vm-stuff-bookmark) 2263 (and vm-message-order-changed
2138 (vm-stuff-header-variables) 2264 (vm-stuff-message-order))))
2139 (vm-stuff-labels) 2265 nil ))))
2140 (vm-stuff-summary)
2141 (and vm-message-order-changed
2142 (vm-stuff-message-order))))
2143 nil ))))
2144 2266
2145 (defun vm-save-buffer (prefix) 2267 (defun vm-save-buffer (prefix)
2146 (interactive "P") 2268 (interactive "P")
2147 (vm-select-folder-buffer) 2269 (vm-select-folder-buffer)
2148 (vm-error-if-virtual-folder) 2270 (vm-error-if-virtual-folder)
2175 (vm-check-for-killed-summary) 2297 (vm-check-for-killed-summary)
2176 (vm-display nil nil '(vm-save-folder) '(vm-save-folder)) 2298 (vm-display nil nil '(vm-save-folder) '(vm-save-folder))
2177 (if (eq major-mode 'vm-virtual-mode) 2299 (if (eq major-mode 'vm-virtual-mode)
2178 (vm-virtual-save-folder prefix) 2300 (vm-virtual-save-folder prefix)
2179 (if (buffer-modified-p) 2301 (if (buffer-modified-p)
2180 (let (mp) 2302 (let (mp (newlist nil))
2181 ;; stuff the attributes of messages that need it. 2303 ;; stuff the attributes of messages that need it.
2182 (vm-unsaved-message "Stuffing attributes...") 2304 (vm-unsaved-message "Stuffing attributes...")
2183 (setq mp vm-message-list) 2305 (vm-stuff-folder-attributes nil)
2184 (while mp
2185 (if (vm-modflag-of (car mp))
2186 (vm-stuff-attributes (car mp)))
2187 (setq mp (cdr mp)))
2188 ;; stuff bookmark and header variable values 2306 ;; stuff bookmark and header variable values
2189 (if vm-message-list 2307 (if vm-message-list
2190 (progn 2308 (progn
2191 ;; get summary cache up-to-date 2309 ;; get summary cache up-to-date
2192 (vm-update-summary-and-mode-line) 2310 (vm-update-summary-and-mode-line)
2433 (let ((triples nil) 2551 (let ((triples nil)
2434 ;; since we could accept-process-output here (POP code), 2552 ;; since we could accept-process-output here (POP code),
2435 ;; a timer process might try to start retrieving mail 2553 ;; a timer process might try to start retrieving mail
2436 ;; before we finish. block these attempts. 2554 ;; before we finish. block these attempts.
2437 (vm-block-new-mail t) 2555 (vm-block-new-mail t)
2556 (fallback-triples nil)
2438 crash in maildrop popdrop 2557 crash in maildrop popdrop
2439 (got-mail nil)) 2558 (got-mail nil))
2559 (cond ((and buffer-file-name
2560 (consp vm-spool-file-suffixes)
2561 (stringp vm-crash-box-suffix))
2562 (setq fallback-triples
2563 (mapcar (function
2564 (lambda (suffix)
2565 (list buffer-file-name
2566 (concat buffer-file-name suffix)
2567 (concat buffer-file-name
2568 vm-crash-box-suffix))))
2569 vm-spool-file-suffixes))))
2570 (cond ((and buffer-file-name
2571 vm-make-spool-file-name vm-make-crash-box-name)
2572 (setq fallback-triples
2573 (ncons fallback-triples
2574 (list (list buffer-file-name
2575 (save-excursion
2576 (funcall vm-make-spool-file-name
2577 buffer-file-name))
2578 (save-excursion
2579 (funcall vm-make-crash-box-name
2580 buffer-file-name))))))))
2440 (cond ((null (vm-spool-files)) 2581 (cond ((null (vm-spool-files))
2441 (setq triples (list 2582 (setq triples (list
2442 (list vm-primary-inbox 2583 (list vm-primary-inbox
2443 (concat vm-spool-directory (user-login-name)) 2584 (concat vm-spool-directory (user-login-name))
2444 vm-crash-box)))) 2585 vm-crash-box))))
2447 (mapcar (function 2588 (mapcar (function
2448 (lambda (s) (list vm-primary-inbox s vm-crash-box))) 2589 (lambda (s) (list vm-primary-inbox s vm-crash-box)))
2449 (vm-spool-files)))) 2590 (vm-spool-files))))
2450 ((consp (car (vm-spool-files))) 2591 ((consp (car (vm-spool-files)))
2451 (setq triples (vm-spool-files)))) 2592 (setq triples (vm-spool-files))))
2593 (setq triples (append triples fallback-triples))
2452 (while triples 2594 (while triples
2453 (setq in (expand-file-name (nth 0 (car triples)) vm-folder-directory) 2595 (setq in (expand-file-name (nth 0 (car triples)) vm-folder-directory)
2454 maildrop (nth 1 (car triples)) 2596 maildrop (nth 1 (car triples))
2455 crash (nth 2 (car triples))) 2597 crash (nth 2 (car triples)))
2456 (if (eq (current-buffer) (vm-get-file-buffer in)) 2598 (if (eq (current-buffer) (vm-get-file-buffer in))
2571 (- (length vm-message-list) 2713 (- (length vm-message-list)
2572 mcount)))) 2714 mcount))))
2573 (message "No messages gathered.")))))) 2715 (message "No messages gathered."))))))
2574 2716
2575 ;; returns non-nil if there were any new messages 2717 ;; returns non-nil if there were any new messages
2576 (defun vm-assimilate-new-messages (&optional dont-read-attributes gobble-order) 2718 (defun vm-assimilate-new-messages (&optional
2719 dont-read-attributes
2720 gobble-order
2721 labels)
2577 (let ((tail-cons (vm-last vm-message-list)) 2722 (let ((tail-cons (vm-last vm-message-list))
2578 b-list new-messages) 2723 b-list new-messages)
2579 (save-excursion 2724 (save-excursion
2580 (vm-save-restriction 2725 (vm-save-restriction
2581 (widen) 2726 (widen)
2604 ;; it. Also something the user does when 2749 ;; it. Also something the user does when
2605 ;; vm-arrived-message-hook is run might affect it. 2750 ;; vm-arrived-message-hook is run might affect it.
2606 ;; vm-assimilate-new-messages returns this value so it must 2751 ;; vm-assimilate-new-messages returns this value so it must
2607 ;; not be mangled. 2752 ;; not be mangled.
2608 (setq new-messages (copy-sequence new-messages)) 2753 (setq new-messages (copy-sequence new-messages))
2754 ;; add the labels
2755 (if (and labels vm-burst-digest-messages-inherit-labels)
2756 (let ((mp new-messages))
2757 (while mp
2758 (vm-set-labels-of (car mp) (copy-sequence labels))
2759 (setq mp (cdr mp)))))
2609 (if vm-summary-show-threads 2760 (if vm-summary-show-threads
2610 (progn 2761 (progn
2611 ;; get numbering and summary of new messages done now 2762 ;; get numbering and summary of new messages done now
2612 ;; so that the sort code only has to worry about the 2763 ;; so that the sort code only has to worry about the
2613 ;; changes it needs to make. 2764 ;; changes it needs to make.
2686 (nreverse mlist)))) 2837 (nreverse mlist))))
2687 2838
2688 (defun vm-display-startup-message () 2839 (defun vm-display-startup-message ()
2689 (if (sit-for 5) 2840 (if (sit-for 5)
2690 (let ((lines vm-startup-message-lines)) 2841 (let ((lines vm-startup-message-lines))
2691 (message "VM %s, Copyright (C) 1996 Kyle E. Jones; type ? for help" 2842 (message "VM %s, Copyright (C) 1997 Kyle E. Jones; type ? for help"
2692 vm-version) 2843 vm-version)
2693 (setq vm-startup-message-displayed t) 2844 (setq vm-startup-message-displayed t)
2694 (while (and (sit-for 4) lines) 2845 (while (and (sit-for 4) lines)
2695 (message (substitute-command-keys (car lines))) 2846 (message (substitute-command-keys (car lines)))
2696 (setq lines (cdr lines))))) 2847 (setq lines (cdr lines)))))
2700 (interactive "p") 2851 (interactive "p")
2701 (if (or (not vm-init-file-loaded) interactive) 2852 (if (or (not vm-init-file-loaded) interactive)
2702 (progn 2853 (progn
2703 (and vm-init-file 2854 (and vm-init-file
2704 (load vm-init-file (not interactive) (not interactive) t)) 2855 (load vm-init-file (not interactive) (not interactive) t))
2705 (and vm-options-file (load vm-options-file t t t)))) 2856 (and vm-preferences-file (load vm-preferences-file t t t))))
2706 (setq vm-init-file-loaded t) 2857 (setq vm-init-file-loaded t)
2707 (vm-display nil nil '(vm-load-init-file) '(vm-load-init-file))) 2858 (vm-display nil nil '(vm-load-init-file) '(vm-load-init-file)))
2708 2859
2709 (defun vm-session-initialization () 2860 (defun vm-session-initialization ()
2710 ;; If this is the first time VM has been run in this Emacs session, 2861 ;; If this is the first time VM has been run in this Emacs session,
2742 (setq 2893 (setq
2743 major-mode 'vm-mode 2894 major-mode 'vm-mode
2744 mode-line-format vm-mode-line-format 2895 mode-line-format vm-mode-line-format
2745 mode-name "VM" 2896 mode-name "VM"
2746 ;; must come after the setting of major-mode 2897 ;; must come after the setting of major-mode
2747 mode-popup-menu (and vm-use-menus 2898 mode-popup-menu (and vm-use-menus vm-popup-menu-on-mouse-3
2748 (vm-menu-support-possible-p) 2899 (vm-menu-support-possible-p)
2749 (vm-menu-mode-menu)) 2900 (vm-menu-mode-menu))
2750 buffer-read-only t 2901 buffer-read-only t
2902 ;; If the user quits a vm-mode buffer, the default action is
2903 ;; to kill the buffer. Make a note that we should offer to
2904 ;; save this buffer even if it has no file associated with it.
2905 ;; We have no idea of the value of the data in the buffer
2906 ;; before it was put into vm-mode.
2907 buffer-offer-save t
2751 require-final-newline nil 2908 require-final-newline nil
2752 vm-thread-obarray nil 2909 vm-thread-obarray nil
2753 vm-thread-subject-obarray nil 2910 vm-thread-subject-obarray nil
2754 vm-label-obarray (make-vector 29 0) 2911 vm-label-obarray (make-vector 29 0)
2755 vm-last-message-pointer nil 2912 vm-last-message-pointer nil
2765 vm-virtual-buffers (vm-link-to-virtual-buffers) 2922 vm-virtual-buffers (vm-link-to-virtual-buffers)
2766 vm-folder-type (vm-get-folder-type)) 2923 vm-folder-type (vm-get-folder-type))
2767 (use-local-map vm-mode-map) 2924 (use-local-map vm-mode-map)
2768 (and (vm-menu-support-possible-p) 2925 (and (vm-menu-support-possible-p)
2769 (vm-menu-install-menus)) 2926 (vm-menu-install-menus))
2927 (add-hook 'kill-buffer-hook 'vm-garbage-collect-folder)
2928 (add-hook 'kill-buffer-hook 'vm-garbage-collect-message)
2929 ;; avoid the XEmacs file dialog box.
2930 (defvar should-use-dialog-box)
2931 (make-local-variable 'should-use-dialog-box)
2932 (setq should-use-dialog-box nil)
2933 ;; mail folders are precious. protect them by default.
2934 (make-local-variable 'file-precious-flag)
2935 (setq file-precious-flag t)
2770 (run-hooks 'vm-mode-hook) 2936 (run-hooks 'vm-mode-hook)
2771 ;; compatibility 2937 ;; compatibility
2772 (run-hooks 'vm-mode-hooks)) 2938 (run-hooks 'vm-mode-hooks))
2773 2939
2774 (defun vm-link-to-virtual-buffers () 2940 (defun vm-link-to-virtual-buffers ()
2879 ;; message separator strings may have leaked into view 3045 ;; message separator strings may have leaked into view
2880 (if (> (point-max) (vm-text-end-of (car vm-message-pointer))) 3046 (if (> (point-max) (vm-text-end-of (car vm-message-pointer)))
2881 (narrow-to-region (point-min) (vm-text-end-of (car vm-message-pointer)))) 3047 (narrow-to-region (point-min) (vm-text-end-of (car vm-message-pointer))))
2882 (vm-display nil nil '(vm-change-folder-type) '(vm-change-folder-type))) 3048 (vm-display nil nil '(vm-change-folder-type) '(vm-change-folder-type)))
2883 3049
3050 (defun vm-garbage-collect-folder ()
3051 (save-excursion
3052 (while vm-folder-garbage-alist
3053 (condition-case nil
3054 (funcall (cdr (car vm-folder-garbage-alist))
3055 (car (car vm-folder-garbage-alist)))
3056 (error nil))
3057 (setq vm-folder-garbage-alist (cdr vm-folder-garbage-alist)))))
3058
3059 (defun vm-garbage-collect-message ()
3060 (save-excursion
3061 (while vm-message-garbage-alist
3062 (condition-case nil
3063 (funcall (cdr (car vm-message-garbage-alist))
3064 (car (car vm-message-garbage-alist)))
3065 (error nil))
3066 (setq vm-message-garbage-alist (cdr vm-message-garbage-alist)))))
3067
2884 (if (not (memq 'vm-write-file-hook write-file-hooks)) 3068 (if (not (memq 'vm-write-file-hook write-file-hooks))
2885 (setq write-file-hooks 3069 (setq write-file-hooks
2886 (cons 'vm-write-file-hook write-file-hooks))) 3070 (cons 'vm-write-file-hook write-file-hooks)))
2887 3071
2888 (if (not (memq 'vm-handle-file-recovery find-file-hooks)) 3072 (if (not (memq 'vm-handle-file-recovery find-file-hooks))