|
0
|
1 ;;; VM folder related functions
|
|
70
|
2 ;;; Copyright (C) 1989, 1990, 1991, 1993, 1994, 1995, 1996 Kyle E. Jones
|
|
0
|
3 ;;;
|
|
|
4 ;;; This program is free software; you can redistribute it and/or modify
|
|
|
5 ;;; it under the terms of the GNU General Public License as published by
|
|
|
6 ;;; the Free Software Foundation; either version 1, or (at your option)
|
|
|
7 ;;; any later version.
|
|
|
8 ;;;
|
|
|
9 ;;; This program is distributed in the hope that it will be useful,
|
|
|
10 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
11 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
|
12 ;;; GNU General Public License for more details.
|
|
|
13 ;;;
|
|
|
14 ;;; You should have received a copy of the GNU General Public License
|
|
|
15 ;;; along with this program; if not, write to the Free Software
|
|
|
16 ;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
|
|
|
17
|
|
|
18 (provide 'vm-folder)
|
|
|
19
|
|
|
20 (defun vm-number-messages (&optional start-point end-point)
|
|
|
21 "Set the number-of and padded-number-of slots of messages
|
|
|
22 in vm-message-list.
|
|
|
23
|
|
|
24 If non-nil, START-POINT should point to a cons cell in
|
|
|
25 vm-message-list and the numbering will begin there, else the
|
|
|
26 numbering will begin at the head of vm-message-list. If
|
|
|
27 START-POINT is non-nil the reverse-link-of slot of the message in
|
|
|
28 the cons must be valid and the message pointed to (if any) must
|
|
|
29 have a non-nil number-of slot, because it is used to determine
|
|
|
30 what the starting message number should be.
|
|
|
31
|
|
|
32 If non-nil, END-POINT should point to a cons cell in
|
|
|
33 vm-message-list and the numbering will end with the message just
|
|
|
34 before this cell. A nil value means numbering will be done until
|
|
|
35 the end of vm-message-list is reached."
|
|
|
36 (let ((n 1) (message-list (or start-point vm-message-list)))
|
|
|
37 (if (and start-point (vm-reverse-link-of (car start-point)))
|
|
|
38 (setq n (1+ (string-to-int
|
|
|
39 (vm-number-of
|
|
|
40 (car
|
|
|
41 (vm-reverse-link-of
|
|
|
42 (car start-point))))))))
|
|
|
43 (while (not (eq message-list end-point))
|
|
|
44 (vm-set-number-of (car message-list) (int-to-string n))
|
|
|
45 (vm-set-padded-number-of (car message-list) (format "%3d" n))
|
|
|
46 (setq n (1+ n) message-list (cdr message-list)))
|
|
|
47 (or end-point (setq vm-ml-highest-message-number (int-to-string (1- n))))
|
|
|
48 (if vm-summary-buffer
|
|
|
49 (vm-copy-local-variables vm-summary-buffer
|
|
|
50 'vm-ml-highest-message-number))))
|
|
|
51
|
|
|
52 (defun vm-set-numbering-redo-start-point (start-point)
|
|
|
53 "Set vm-numbering-redo-start-point to START-POINT if appropriate.
|
|
|
54 Also mark the current buffer as needing a display update.
|
|
|
55
|
|
|
56 START-POINT should be a cons in vm-message-list or just t.
|
|
|
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
|
|
|
59 vm-numbering-redo-start-point or is equal to t, then
|
|
|
60 vm-numbering-redo-start-point is set to match it."
|
|
|
61 (intern (buffer-name) vm-buffers-needing-display-update)
|
|
70
|
62 (if (and (consp start-point) (consp vm-numbering-redo-start-point)
|
|
|
63 (not (eq vm-numbering-redo-start-point t)))
|
|
|
64 (let ((mp vm-message-list))
|
|
|
65 (while (and mp (not (or (eq mp start-point)
|
|
|
66 (eq mp vm-numbering-redo-start-point))))
|
|
|
67 (setq mp (cdr mp)))
|
|
|
68 (if (null mp)
|
|
|
69 (error "Something is wrong in vm-set-numbering-redo-start-point"))
|
|
|
70 (if (eq mp start-point)
|
|
|
71 (setq vm-numbering-redo-start-point start-point)))
|
|
|
72 (setq vm-numbering-redo-start-point start-point)))
|
|
0
|
73
|
|
|
74 (defun vm-set-numbering-redo-end-point (end-point)
|
|
|
75 "Set vm-numbering-redo-end-point to END-POINT if appropriate.
|
|
|
76 Also mark the current buffer as needing a display update.
|
|
|
77
|
|
|
78 END-POINT should be a cons in vm-message-list or just t.
|
|
|
79 (t means number all the way to the end of vm-message-list.)
|
|
|
80 If END-POINT is closer to the end of vm-message-list or is equal
|
|
|
81 to t, then vm-numbering-redo-start-point is set to match it.
|
|
|
82 The number-of slot is used to determine proximity to the end of
|
|
|
83 vm-message-list, so this slot must be valid in END-POINT's message
|
|
|
84 and the message in the cons pointed to by vm-numbering-redo-end-point."
|
|
|
85 (intern (buffer-name) vm-buffers-needing-display-update)
|
|
|
86 (cond ((eq end-point t)
|
|
|
87 (setq vm-numbering-redo-end-point t))
|
|
|
88 ((and (consp end-point)
|
|
|
89 (> (string-to-int
|
|
|
90 (vm-number-of
|
|
|
91 (car end-point)))
|
|
|
92 (string-to-int
|
|
|
93 (vm-number-of
|
|
|
94 (car vm-numbering-redo-end-point)))))
|
|
|
95 (setq vm-numbering-redo-end-point end-point))
|
|
|
96 ((null end-point)
|
|
|
97 (setq vm-numbering-redo-end-point end-point))))
|
|
|
98
|
|
|
99 (defun vm-do-needed-renumbering ()
|
|
|
100 "Number messages in vm-message-list as specified by
|
|
|
101 vm-numbering-redo-start-point and vm-numbering-redo-end-point.
|
|
|
102
|
|
|
103 vm-numbering-redo-start-point = t means start at the head
|
|
|
104 of vm-message-list.
|
|
|
105 vm-numbering-redo-end-point = t means number all the way to the
|
|
|
106 end of vm-message-list.
|
|
|
107
|
|
|
108 Otherwise the variables' values should be conses in vm-message-list
|
|
|
109 or nil."
|
|
|
110 (if vm-numbering-redo-start-point
|
|
|
111 (progn
|
|
|
112 (vm-number-messages (and (consp vm-numbering-redo-start-point)
|
|
|
113 vm-numbering-redo-start-point)
|
|
|
114 vm-numbering-redo-end-point)
|
|
|
115 (setq vm-numbering-redo-start-point nil
|
|
|
116 vm-numbering-redo-end-point nil))))
|
|
|
117
|
|
|
118 (defun vm-set-summary-redo-start-point (start-point)
|
|
|
119 "Set vm-summary-redo-start-point to START-POINT if appropriate.
|
|
|
120 Also mark the current buffer as needing a display update.
|
|
|
121
|
|
|
122 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 If START-POINT is closer to the head of vm-message-list than
|
|
70
|
125 vm-numbering-redo-start-point or is equal to t, then
|
|
|
126 vm-numbering-redo-start-point is set to match it."
|
|
0
|
127 (intern (buffer-name) vm-buffers-needing-display-update)
|
|
70
|
128 (if (and (consp start-point) (consp vm-summary-redo-start-point)
|
|
|
129 (not (eq vm-summary-redo-start-point t)))
|
|
|
130 (let ((mp vm-message-list))
|
|
|
131 (while (and mp (not (or (eq mp start-point)
|
|
|
132 (eq mp vm-summary-redo-start-point))))
|
|
|
133 (setq mp (cdr mp)))
|
|
|
134 (if (null mp)
|
|
|
135 (error "Something is wrong in vm-set-summary-redo-start-point"))
|
|
|
136 (if (eq mp start-point)
|
|
|
137 (setq vm-summary-redo-start-point start-point)))
|
|
|
138 (setq vm-summary-redo-start-point start-point)))
|
|
0
|
139
|
|
|
140 (defun vm-mark-for-summary-update (m &optional dont-kill-cache)
|
|
|
141 "Mark message M for a summary update.
|
|
|
142 Also mark M's buffer as needing a display update. Any virtual
|
|
|
143 messages of M and their buffers are similarly marked for update.
|
|
|
144 If M is a virtual message and virtual mirroring is in effect for
|
|
|
145 M (i.e. attribute-of eq attributes-of M's real message), M's real
|
|
|
146 message and its buffer are scheduled for an update.
|
|
|
147
|
|
|
148 Optional arg DONT-KILL-CACHE non-nil means don't invalidate the
|
|
|
149 summary-of slot for any messages marked for update. This is
|
|
|
150 meant to be used by functions that update message information
|
|
|
151 that is not cached in the summary-of slot, e.g. message numbers
|
|
|
152 and thread indentation."
|
|
|
153 (cond ((eq m (vm-real-message-of m))
|
|
|
154 ;; this is a real message.
|
|
|
155 ;; its summary and modeline need to be updated.
|
|
|
156 (if (not dont-kill-cache)
|
|
|
157 ;; toss the cache. this also tosses the cache of any
|
|
|
158 ;; virtual messages mirroring this message. the summary
|
|
|
159 ;; entry cache must be cleared when an attribute of a
|
|
|
160 ;; message that could appear in the summary has changed.
|
|
|
161 (vm-set-summary-of m nil))
|
|
|
162 (if (vm-su-start-of m)
|
|
|
163 (setq vm-messages-needing-summary-update
|
|
|
164 (cons m vm-messages-needing-summary-update)))
|
|
|
165 (intern (buffer-name (vm-buffer-of m))
|
|
|
166 vm-buffers-needing-display-update)
|
|
|
167 ;; find the virtual messages of this real message that
|
|
|
168 ;; need a summary update.
|
|
|
169 (let ((m-list (vm-virtual-messages-of m)))
|
|
|
170 (while m-list
|
|
|
171 (if (eq (vm-attributes-of m) (vm-attributes-of (car m-list)))
|
|
|
172 (progn
|
|
|
173 (and (vm-su-start-of (car m-list))
|
|
|
174 (setq vm-messages-needing-summary-update
|
|
|
175 (cons (car m-list)
|
|
|
176 vm-messages-needing-summary-update)))
|
|
|
177 (intern (buffer-name (vm-buffer-of (car m-list)))
|
|
|
178 vm-buffers-needing-display-update)))
|
|
|
179 (setq m-list (cdr m-list)))))
|
|
|
180 (t
|
|
|
181 ;; this is a virtual message.
|
|
|
182 ;;
|
|
|
183 ;; if this message has virtual messages then we need to
|
|
|
184 ;; schedule updates for all the virtual messages that
|
|
|
185 ;; share a cache with this message and we need to
|
|
|
186 ;; schedule an update for the underlying real message
|
|
|
187 ;; since we are mirroring it.
|
|
|
188 ;;
|
|
|
189 ;; if there are no virtual messages, then this virtual
|
|
|
190 ;; message is not mirroring its real message so we need
|
|
|
191 ;; only take care of this one message.
|
|
|
192 (if (vm-virtual-messages-of m)
|
|
|
193 (let ((m-list (vm-virtual-messages-of m)))
|
|
|
194 ;; schedule updates for all the virtual message who share
|
|
|
195 ;; the same cache as this message.
|
|
|
196 (while m-list
|
|
|
197 (if (eq (vm-attributes-of m) (vm-attributes-of (car m-list)))
|
|
|
198 (progn
|
|
|
199 (and (vm-su-start-of (car m-list))
|
|
|
200 (setq vm-messages-needing-summary-update
|
|
|
201 (cons (car m-list)
|
|
|
202 vm-messages-needing-summary-update)))
|
|
|
203 (intern (buffer-name (vm-buffer-of (car m-list)))
|
|
|
204 vm-buffers-needing-display-update)))
|
|
|
205 (setq m-list (cdr m-list)))
|
|
|
206 ;; now take care of the real message
|
|
|
207 (if (not dont-kill-cache)
|
|
|
208 ;; toss the cache. this also tosses the cache of
|
|
|
209 ;; any virtual messages sharing the same cache as
|
|
|
210 ;; this message.
|
|
|
211 (vm-set-summary-of m nil))
|
|
|
212 (and (vm-su-start-of (vm-real-message-of m))
|
|
|
213 (setq vm-messages-needing-summary-update
|
|
|
214 (cons (vm-real-message-of m)
|
|
|
215 vm-messages-needing-summary-update)))
|
|
|
216 (intern (buffer-name (vm-buffer-of (vm-real-message-of m)))
|
|
|
217 vm-buffers-needing-display-update))
|
|
|
218 (if (not dont-kill-cache)
|
|
|
219 (vm-set-virtual-summary-of m nil))
|
|
|
220 (and (vm-su-start-of m)
|
|
|
221 (setq vm-messages-needing-summary-update
|
|
|
222 (cons m vm-messages-needing-summary-update)))
|
|
|
223 (intern (buffer-name (vm-buffer-of m))
|
|
|
224 vm-buffers-needing-display-update)))))
|
|
|
225
|
|
|
226 (defun vm-force-mode-line-update ()
|
|
|
227 "Force a mode line update in all frames."
|
|
|
228 (if (fboundp 'force-mode-line-update)
|
|
|
229 (force-mode-line-update t)
|
|
|
230 (save-excursion
|
|
|
231 (set-buffer (other-buffer))
|
|
|
232 (set-buffer-modified-p (buffer-modified-p)))))
|
|
|
233
|
|
|
234 (defun vm-do-needed-mode-line-update ()
|
|
|
235 "Do a modeline update for the current folder buffer.
|
|
|
236 This means setting up all the various vm-ml attribute variables
|
|
|
237 in the folder buffer and copying necessary variables to the
|
|
70
|
238 folder buffer's summary buffer, and then forcing Emacs to update
|
|
|
239 all modelines.
|
|
0
|
240
|
|
70
|
241 Also if a virtual folder being updated has no messages,
|
|
|
242 erase-buffer is called on its buffer."
|
|
0
|
243 ;; XXX This last bit should probably should be moved to
|
|
|
244 ;; XXX vm-expunge-folder.
|
|
|
245
|
|
|
246 (if (null vm-message-pointer)
|
|
70
|
247 ;; erase the leftover message if the folder is really empty.
|
|
|
248 (if (eq major-mode 'vm-virtual-mode)
|
|
|
249 (let ((buffer-read-only nil)
|
|
|
250 (omodified (buffer-modified-p)))
|
|
|
251 (unwind-protect
|
|
|
252 (erase-buffer)
|
|
|
253 (set-buffer-modified-p omodified))))
|
|
0
|
254 ;; try to avoid calling vm-su-labels if possible so as to
|
|
|
255 ;; avoid loading vm-summary.el.
|
|
|
256 (if (vm-labels-of (car vm-message-pointer))
|
|
|
257 (setq vm-ml-labels (vm-su-labels (car vm-message-pointer)))
|
|
|
258 (setq vm-ml-labels nil))
|
|
|
259 (setq vm-ml-message-number (vm-number-of (car vm-message-pointer)))
|
|
|
260 (setq vm-ml-message-new (vm-new-flag (car vm-message-pointer)))
|
|
|
261 (setq vm-ml-message-unread (vm-unread-flag (car vm-message-pointer)))
|
|
|
262 (setq vm-ml-message-read
|
|
|
263 (and (not (vm-new-flag (car vm-message-pointer)))
|
|
|
264 (not (vm-unread-flag (car vm-message-pointer)))))
|
|
|
265 (setq vm-ml-message-edited (vm-edited-flag (car vm-message-pointer)))
|
|
|
266 (setq vm-ml-message-filed (vm-filed-flag (car vm-message-pointer)))
|
|
|
267 (setq vm-ml-message-written (vm-written-flag (car vm-message-pointer)))
|
|
|
268 (setq vm-ml-message-replied (vm-replied-flag (car vm-message-pointer)))
|
|
|
269 (setq vm-ml-message-forwarded (vm-forwarded-flag (car vm-message-pointer)))
|
|
|
270 (setq vm-ml-message-redistributed (vm-redistributed-flag (car vm-message-pointer)))
|
|
|
271 (setq vm-ml-message-deleted (vm-deleted-flag (car vm-message-pointer)))
|
|
|
272 (setq vm-ml-message-marked (vm-mark-of (car vm-message-pointer))))
|
|
|
273 (if vm-summary-buffer
|
|
|
274 (let ((modified (buffer-modified-p)))
|
|
|
275 (save-excursion
|
|
|
276 (vm-copy-local-variables vm-summary-buffer
|
|
|
277 'vm-ml-message-new
|
|
|
278 'vm-ml-message-unread
|
|
|
279 'vm-ml-message-read
|
|
|
280 'vm-ml-message-edited
|
|
|
281 'vm-ml-message-replied
|
|
|
282 'vm-ml-message-forwarded
|
|
|
283 'vm-ml-message-filed
|
|
|
284 'vm-ml-message-written
|
|
|
285 'vm-ml-message-deleted
|
|
|
286 'vm-ml-message-marked
|
|
|
287 'vm-ml-message-number
|
|
|
288 'vm-ml-highest-message-number
|
|
|
289 'vm-folder-read-only
|
|
|
290 'vm-folder-type
|
|
|
291 'vm-virtual-folder-definition
|
|
|
292 'vm-virtual-mirror
|
|
|
293 'vm-ml-sort-keys
|
|
|
294 'vm-ml-labels
|
|
|
295 'vm-message-list)
|
|
|
296 (set-buffer vm-summary-buffer)
|
|
|
297 (set-buffer-modified-p modified))))
|
|
|
298 (vm-force-mode-line-update))
|
|
|
299
|
|
|
300 (defun vm-update-summary-and-mode-line ()
|
|
|
301 "Update summary and mode line for all VM folder and summary buffers.
|
|
|
302 Really this updates all the visible status indicators.
|
|
|
303
|
|
|
304 Message lists are renumbered.
|
|
|
305 Summary entries are wiped and regenerated.
|
|
|
306 Mode lines are updated.
|
|
|
307 Toolbars are updated."
|
|
|
308 (save-excursion
|
|
|
309 (mapatoms (function
|
|
|
310 (lambda (b)
|
|
|
311 (setq b (get-buffer (symbol-name b)))
|
|
|
312 (if b
|
|
|
313 (progn
|
|
|
314 (set-buffer b)
|
|
|
315 (vm-check-for-killed-summary)
|
|
|
316 (and vm-use-toolbar
|
|
|
317 (vm-toolbar-support-possible-p)
|
|
|
318 (vm-toolbar-update-toolbar))
|
|
|
319 (vm-do-needed-renumbering)
|
|
|
320 (if vm-summary-buffer
|
|
|
321 (vm-do-needed-summary-rebuild))
|
|
|
322 (vm-do-needed-mode-line-update)))))
|
|
|
323 vm-buffers-needing-display-update)
|
|
|
324 (fillarray vm-buffers-needing-display-update 0))
|
|
|
325 (if vm-messages-needing-summary-update
|
|
|
326 (progn
|
|
|
327 (mapcar (function vm-update-message-summary)
|
|
|
328 vm-messages-needing-summary-update)
|
|
|
329 (setq vm-messages-needing-summary-update nil)))
|
|
|
330 (vm-force-mode-line-update))
|
|
|
331
|
|
|
332 (defun vm-reverse-link-messages ()
|
|
|
333 "Set reverse links for all messages in vm-message-list."
|
|
|
334 (let ((mp vm-message-list)
|
|
|
335 (prev nil))
|
|
|
336 (while mp
|
|
|
337 (vm-set-reverse-link-of (car mp) prev)
|
|
|
338 (setq prev mp mp (cdr mp)))))
|
|
|
339
|
|
|
340 (defun vm-match-ordered-header (alist)
|
|
|
341 "Try to match a header in ALIST and return the matching cell.
|
|
|
342 This is used by header ordering code.
|
|
|
343
|
|
|
344 ALIST looks like this ((\"From\") (\"To\")). This function returns
|
|
|
345 the alist element whose car matches the header starting at point.
|
|
|
346 The header ordering code uses the cdr of the element
|
|
|
347 returned to hold headers to be output later."
|
|
|
348 (let ((case-fold-search t))
|
|
|
349 (catch 'match
|
|
|
350 (while alist
|
|
|
351 (if (looking-at (car (car alist)))
|
|
|
352 (throw 'match (car alist)))
|
|
|
353 (setq alist (cdr alist)))
|
|
|
354 nil)))
|
|
|
355
|
|
|
356 (defun vm-match-header (&optional header-name)
|
|
|
357 "Match a header and save some state information about the matched header.
|
|
|
358 Optional first arg HEADER-NAME means match the header only
|
|
|
359 if it matches HEADER-NAME. HEADER-NAME should be a string
|
|
|
360 containing a header name. The string should end with a colon if just
|
|
|
361 that name should be matched. A string that does not end in a colon
|
|
|
362 will match all headers that begin with that string.
|
|
|
363
|
|
|
364 State information is stored in vm-matched-header-vector bound to a vector
|
|
|
365 of this form.
|
|
|
366
|
|
|
367 [ header-start header-end
|
|
|
368 header-name-start header-name-end
|
|
|
369 header-contents-start header-contents-end ]
|
|
|
370
|
|
|
371 Elements are integers.
|
|
|
372 There are functions to access and use this info."
|
|
|
373 (let ((case-fold-search t)
|
|
|
374 (header-name-regexp "\\([^ \t\n:]+\\):"))
|
|
|
375 (if (if header-name
|
|
|
376 (and (looking-at header-name) (looking-at header-name-regexp))
|
|
|
377 (looking-at header-name-regexp))
|
|
|
378 (save-excursion
|
|
|
379 (aset vm-matched-header-vector 0 (point))
|
|
|
380 (aset vm-matched-header-vector 2 (point))
|
|
|
381 (aset vm-matched-header-vector 3 (match-end 1))
|
|
|
382 (goto-char (match-end 0))
|
|
|
383 ;; skip leading whitespace
|
|
|
384 (skip-chars-forward " \t")
|
|
|
385 (aset vm-matched-header-vector 4 (point))
|
|
|
386 (forward-line 1)
|
|
|
387 (while (looking-at "[ \t]")
|
|
|
388 (forward-line 1))
|
|
|
389 (aset vm-matched-header-vector 1 (point))
|
|
|
390 ;; drop the trailing newline
|
|
|
391 (aset vm-matched-header-vector 5 (1- (point)))))))
|
|
|
392
|
|
|
393 (defun vm-matched-header ()
|
|
|
394 "Returns the header last matched by vm-match-header.
|
|
|
395 Trailing newline is included."
|
|
|
396 (vm-buffer-substring-no-properties (aref vm-matched-header-vector 0)
|
|
|
397 (aref vm-matched-header-vector 1)))
|
|
|
398
|
|
|
399 (defun vm-matched-header-name ()
|
|
|
400 "Returns the name of the header last matched by vm-match-header."
|
|
|
401 (vm-buffer-substring-no-properties (aref vm-matched-header-vector 2)
|
|
|
402 (aref vm-matched-header-vector 3)))
|
|
|
403
|
|
|
404 (defun vm-matched-header-contents ()
|
|
|
405 "Returns the contents of the header last matched by vm-match-header.
|
|
|
406 Trailing newline is not included."
|
|
|
407 (vm-buffer-substring-no-properties (aref vm-matched-header-vector 4)
|
|
|
408 (aref vm-matched-header-vector 5)))
|
|
|
409
|
|
|
410 (defun vm-matched-header-start ()
|
|
|
411 "Returns the start position of the header last matched by vm-match-header."
|
|
|
412 (aref vm-matched-header-vector 0))
|
|
|
413
|
|
|
414 (defun vm-matched-header-end ()
|
|
|
415 "Returns the end position of the header last matched by vm-match-header."
|
|
|
416 (aref vm-matched-header-vector 1))
|
|
|
417
|
|
|
418 (defun vm-matched-header-name-start ()
|
|
|
419 "Returns the start position of the name of the header last matched
|
|
|
420 by vm-match-header."
|
|
|
421 (aref vm-matched-header-vector 2))
|
|
|
422
|
|
|
423 (defun vm-matched-header-name-end ()
|
|
|
424 "Returns the end position of the name of the header last matched
|
|
|
425 by vm-match-header."
|
|
|
426 (aref vm-matched-header-vector 3))
|
|
|
427
|
|
|
428 (defun vm-matched-header-contents-start ()
|
|
|
429 "Returns the start position of the contents of the header last matched
|
|
|
430 by vm-match-header."
|
|
|
431 (aref vm-matched-header-vector 4))
|
|
|
432
|
|
|
433 (defun vm-matched-header-contents-end ()
|
|
|
434 "Returns the end position of the contents of the header last matched
|
|
|
435 by vm-match-header."
|
|
|
436 (aref vm-matched-header-vector 5))
|
|
|
437
|
|
|
438 (defun vm-get-folder-type (&optional file start end)
|
|
|
439 "Return a symbol indicating the folder type of the current buffer.
|
|
|
440 This function works by examining the beginning of a folder.
|
|
|
441 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,
|
|
76
|
443 vm-get-folder-type will examine the the text between those buffer
|
|
0
|
444 positions. START and END default to 1 and (buffer-size) + 1.
|
|
|
445
|
|
|
446 Returns
|
|
|
447 nil if folder has no type (empty)
|
|
|
448 unknown if the type is not known to VM
|
|
|
449 mmdf for MMDF folders
|
|
|
450 babyl for BABYL folders
|
|
|
451 From_ for UNIX From_ folders
|
|
|
452
|
|
|
453 If vm-trust-From_-with-Content-Length is non-nil,
|
|
|
454 From_-with-Content-Length is returned if the first message in the
|
|
|
455 folder has a Content-Length header and the folder otherwise looks
|
|
|
456 like a From_ folder."
|
|
|
457 (let ((temp-buffer nil)
|
|
|
458 b
|
|
|
459 (case-fold-search nil))
|
|
|
460 (unwind-protect
|
|
|
461 (save-excursion
|
|
|
462 (if file
|
|
|
463 (progn
|
|
|
464 (setq b (vm-get-file-buffer file))
|
|
|
465 (if b
|
|
|
466 (set-buffer b)
|
|
|
467 (setq temp-buffer (generate-new-buffer "*vm-work*"))
|
|
|
468 (set-buffer temp-buffer)
|
|
|
469 (if (file-readable-p file)
|
|
|
470 (condition-case nil
|
|
70
|
471 (insert-file-contents file nil 0 4096)
|
|
0
|
472 (wrong-number-of-arguments
|
|
|
473 (call-process "sed" file temp-buffer nil
|
|
|
474 "-n" "1,/^$/p")))))))
|
|
|
475 (save-excursion
|
|
|
476 (save-restriction
|
|
|
477 (or start (setq start 1))
|
|
|
478 (or end (setq end (1+ (buffer-size))))
|
|
|
479 (widen)
|
|
|
480 (narrow-to-region start end)
|
|
|
481 (goto-char (point-min))
|
|
|
482 (cond ((zerop (buffer-size)) nil)
|
|
|
483 ((looking-at "\n*From ")
|
|
|
484 (if (not vm-trust-From_-with-Content-Length)
|
|
|
485 'From_
|
|
|
486 (let ((case-fold-search t))
|
|
|
487 (re-search-forward vm-content-length-search-regexp
|
|
|
488 nil t))
|
|
|
489 (cond ((match-beginning 1)
|
|
|
490 'From_)
|
|
|
491 ((match-beginning 0)
|
|
|
492 'From_-with-Content-Length)
|
|
|
493 (t 'From_))))
|
|
|
494 ((looking-at "\001\001\001\001\n") 'mmdf)
|
|
|
495 ((looking-at "BABYL OPTIONS:") 'babyl)
|
|
|
496 (t 'unknown)))))
|
|
|
497 (and temp-buffer (kill-buffer temp-buffer)))))
|
|
|
498
|
|
|
499 (defun vm-convert-folder-type (old-type new-type)
|
|
|
500 "Convert buffer from OLD-TYPE to NEW-TYPE.
|
|
|
501 OLD-TYPE and NEW-TYPE should be symbols returned from vm-get-folder-type.
|
|
|
502 This should be called on non-live buffers like crash boxes.
|
|
|
503 This will confuse VM if called on a folder buffer in vm-mode."
|
|
|
504 (let ((vm-folder-type old-type)
|
|
|
505 (pos-list nil)
|
|
|
506 beg end)
|
|
|
507 (goto-char (point-min))
|
|
|
508 (vm-skip-past-folder-header)
|
|
|
509 (while (vm-find-leading-message-separator)
|
|
|
510 (setq pos-list (cons (point-marker) pos-list))
|
|
|
511 (vm-skip-past-leading-message-separator)
|
|
|
512 (setq pos-list (cons (point-marker) pos-list))
|
|
|
513 (vm-find-trailing-message-separator)
|
|
|
514 (setq pos-list (cons (point-marker) pos-list))
|
|
|
515 (vm-skip-past-trailing-message-separator)
|
|
|
516 (setq pos-list (cons (point-marker) pos-list)))
|
|
|
517 (setq pos-list (nreverse pos-list))
|
|
|
518 (goto-char (point-min))
|
|
|
519 (vm-convert-folder-header old-type new-type)
|
|
|
520 (while pos-list
|
|
|
521 (setq beg (car pos-list))
|
|
|
522 (goto-char (car pos-list))
|
|
|
523 (insert-before-markers (vm-leading-message-separator new-type))
|
|
|
524 (delete-region (car pos-list) (car (cdr pos-list)))
|
|
|
525 (vm-convert-folder-type-headers old-type new-type)
|
|
|
526 (setq pos-list (cdr (cdr pos-list)))
|
|
|
527 (setq end (marker-position (car pos-list)))
|
|
|
528 (goto-char (car pos-list))
|
|
|
529 (insert-before-markers (vm-trailing-message-separator new-type))
|
|
|
530 (delete-region (car pos-list) (car (cdr pos-list)))
|
|
|
531 (goto-char beg)
|
|
|
532 (vm-munge-message-separators new-type beg end)
|
|
|
533 (setq pos-list (cdr (cdr pos-list))))))
|
|
|
534
|
|
|
535 (defun vm-convert-folder-header (old-type new-type)
|
|
|
536 "Convert the folder header form OLD-TYPE to NEW-TYPE.
|
|
|
537 The folder header is the text at the beginning of a folder that
|
|
|
538 is a legal part of the folder but is not part of the first
|
|
|
539 message. This is for dealing with BABYL files."
|
|
|
540 (if (eq old-type 'babyl)
|
|
|
541 (save-excursion
|
|
|
542 (let ((beg (point))
|
|
|
543 (case-fold-search t))
|
|
|
544 (cond ((and (looking-at "BABYL OPTIONS:")
|
|
|
545 (search-forward "\037" nil t))
|
|
|
546 (delete-region beg (point)))))))
|
|
|
547 (if (eq new-type 'babyl)
|
|
|
548 ;; insert before markers so that message location markers
|
|
|
549 ;; for the first message get moved forward.
|
|
|
550 (insert-before-markers "BABYL OPTIONS:\nVersion: 5\n\037")))
|
|
|
551
|
|
|
552 (defun vm-skip-past-folder-header ()
|
|
|
553 "Move point past the folder header.
|
|
|
554 The folder header is the text at the beginning of a folder that
|
|
|
555 is a legal part of the folder but is not part of the first
|
|
|
556 message. This is for dealing with BABYL files."
|
|
|
557 (cond ((eq vm-folder-type 'babyl)
|
|
|
558 (search-forward "\037" nil 0))))
|
|
|
559
|
|
|
560 (defun vm-convert-folder-type-headers (old-type new-type)
|
|
|
561 "Convert headers in the message around point from OLD-TYPE to NEW-TYPE.
|
|
|
562 This means to add/delete Content-Length and any other
|
|
|
563 headers related to folder-type as needed for folder type
|
|
|
564 conversions. This function expects point to be at the beginning
|
|
|
565 of the header section of a message, and it only deals with that
|
|
|
566 message."
|
|
|
567 (let (length)
|
|
|
568 ;; get the length now before the content-length headers are
|
|
|
569 ;; removed.
|
|
|
570 (if (eq new-type 'From_-with-Content-Length)
|
|
|
571 (let (start)
|
|
|
572 (save-excursion
|
|
|
573 (save-excursion
|
|
|
574 (search-forward "\n\n" nil 0)
|
|
|
575 (setq start (point)))
|
|
|
576 (let ((vm-folder-type old-type))
|
|
|
577 (vm-find-trailing-message-separator))
|
|
|
578 (setq length (- (point) start)))))
|
|
|
579 ;; chop out content-length header if new format doesn't need
|
|
|
580 ;; it or if the new format computed his own copy.
|
|
|
581 (if (or (eq old-type 'From_-with-Content-Length)
|
|
|
582 (eq new-type 'From_-with-Content-Length))
|
|
|
583 (save-excursion
|
|
|
584 (while (and (let ((case-fold-search t))
|
|
|
585 (re-search-forward vm-content-length-search-regexp
|
|
|
586 nil t))
|
|
|
587 (null (match-beginning 1))
|
|
|
588 (progn (goto-char (match-beginning 0))
|
|
|
589 (vm-match-header vm-content-length-header)))
|
|
|
590 (delete-region (vm-matched-header-start)
|
|
|
591 (vm-matched-header-end)))))
|
|
|
592 ;; insert the content-length header if needed
|
|
|
593 (if (eq new-type 'From_-with-Content-Length)
|
|
|
594 (save-excursion
|
|
|
595 (insert vm-content-length-header " " (int-to-string length) "\n")))))
|
|
|
596
|
|
|
597 (defun vm-munge-message-separators (folder-type start end)
|
|
|
598 "Munge message separators of FOLDER-TYPE found between START and END.
|
|
|
599 This function is used to eliminate message separators for a particular
|
|
|
600 folder type that happen to occur in a message. \">\" is prepended to such
|
|
|
601 separators."
|
|
|
602 (save-excursion
|
|
|
603 (let ((vm-folder-type folder-type))
|
|
|
604 (cond ((memq folder-type '(From_ From_-with-Content-Length mmdf babyl))
|
|
|
605 (setq end (vm-marker end))
|
|
|
606 (goto-char start)
|
|
|
607 (while (and (vm-find-leading-message-separator)
|
|
|
608 (< (point) end))
|
|
|
609 (insert ">"))
|
|
|
610 (set-marker end nil))))))
|
|
|
611
|
|
|
612 (defun vm-compatible-folder-p (file)
|
|
|
613 "Return non-nil if FILE is a compatible folder with the current buffer.
|
|
|
614 The current folder must have vm-folder-type initialized.
|
|
|
615 FILE is compatible if
|
|
|
616 - it is empty
|
|
|
617 - the current folder is empty
|
|
|
618 - the two folder types are equal"
|
|
|
619 (let ((type (vm-get-folder-type file)))
|
|
|
620 (or (not (and vm-folder-type type))
|
|
|
621 (eq vm-folder-type type))))
|
|
|
622
|
|
|
623 (defun vm-leading-message-separator (&optional folder-type message
|
|
|
624 for-other-folder)
|
|
|
625 "Returns a leading message separator for the current folder.
|
|
|
626 Defaults to returning a separator for the current folder type.
|
|
|
627
|
|
|
628 Optional first arg FOLDER-TYPE means return a separator for that
|
|
|
629 folder type instead.
|
|
|
630
|
|
|
631 Optional second arg MESSAGE should be a message struct. This is used
|
|
|
632 generating BABYL separators, because they contain message attributes
|
|
|
633 and labels that must must be copied from the message.
|
|
|
634
|
|
|
635 Optional third arg FOR-OTHER-FOLDER non-nil means that this separator will
|
|
|
636 be used a `foreign' folder. This means that the `deleted'
|
|
|
637 attributes should not be copied for BABYL folders."
|
|
|
638 (let ((type (or folder-type vm-folder-type)))
|
|
|
639 (cond ((memq type '(From_ From_-with-Content-Length))
|
|
|
640 (concat "From VM " (current-time-string) "\n"))
|
|
|
641 ((eq type 'mmdf)
|
|
|
642 "\001\001\001\001\n")
|
|
|
643 ((eq type 'babyl)
|
|
|
644 (cond (message
|
|
|
645 (concat "\014\n0,"
|
|
|
646 (vm-babyl-attributes-string message for-other-folder)
|
|
|
647 ",\n*** EOOH ***\n"))
|
|
|
648 (t "\014\n0, recent, unseen,,\n*** EOOH ***\n"))))))
|
|
|
649
|
|
|
650 (defun vm-trailing-message-separator (&optional folder-type)
|
|
|
651 "Returns a leading message separator for the current folder.
|
|
|
652 Defaults to returning a separator for the current folder type.
|
|
|
653
|
|
|
654 Optional first arg FOLDER-TYPE means return a separator for that
|
|
|
655 folder type instead."
|
|
|
656 (let ((type (or folder-type vm-folder-type)))
|
|
|
657 (cond ((eq type 'From_) "\n")
|
|
|
658 ((eq type 'From_-with-Content-Length) "")
|
|
|
659 ((eq type 'mmdf) "\001\001\001\001\n")
|
|
|
660 ((eq type 'babyl) "\037"))))
|
|
|
661
|
|
|
662 (defun vm-folder-header (&optional folder-type label-obarray)
|
|
|
663 "Returns a folder header for the current folder.
|
|
|
664 Defaults to returning a folder header for the current folder type.
|
|
|
665
|
|
|
666 Optional first arg FOLDER-TYPE means return a folder header for that
|
|
|
667 folder type instead.
|
|
|
668
|
|
|
669 Optional second arg LABEL-OBARRAY should be an obarray of labels
|
|
|
670 that have been used in this folder. This is used for BABYL folders."
|
|
|
671 (let ((type (or folder-type vm-folder-type)))
|
|
|
672 (cond ((eq type 'babyl)
|
|
|
673 (let ((list nil))
|
|
|
674 (if label-obarray
|
|
|
675 (mapatoms (function
|
|
|
676 (lambda (sym)
|
|
|
677 (setq list (cons sym list))))
|
|
|
678 label-obarray))
|
|
|
679 (if list
|
|
|
680 (format "BABYL OPTIONS:\nVersion: 5\nLabels: %s\n\037"
|
|
|
681 (mapconcat (function symbol-name) list ", "))
|
|
|
682 "BABYL OPTIONS:\nVersion: 5\n\037")))
|
|
|
683 (t ""))))
|
|
|
684
|
|
|
685 (defun vm-find-leading-message-separator ()
|
|
|
686 "Find the next leading message separator in a folder.
|
|
|
687 Returns non-nil if the separator is found, nil otherwise."
|
|
|
688 (cond
|
|
|
689 ((eq vm-folder-type 'From_)
|
|
|
690 (let ((reg1 "^From ")
|
|
|
691 (reg2 "^>From ")
|
|
|
692 (case-fold-search nil))
|
|
|
693 (catch 'done
|
|
|
694 (while (re-search-forward reg1 nil 'no-error)
|
|
|
695 (goto-char (match-beginning 0))
|
|
|
696 ;; remove the requirement that there be two
|
|
|
697 ;; consecutive newlines (or the beginning of the
|
|
|
698 ;; buffer) before "From ". Hopefully this will not
|
|
|
699 ;; break more than it fixes. (18 August 1995)
|
|
|
700 (if ;; (and (or (< (point) 3)
|
|
|
701 ;; (equal (char-after (- (point) 2)) ?\n))
|
|
|
702 (save-excursion
|
|
|
703 (and (= 0 (forward-line 1))
|
|
|
704 (or (vm-match-header)
|
|
|
705 (looking-at reg2))))
|
|
|
706 ;; )
|
|
|
707 (throw 'done t)
|
|
|
708 (forward-char 1)))
|
|
|
709 nil )))
|
|
|
710 ((eq vm-folder-type 'From_-with-Content-Length)
|
|
|
711 (let ((reg1 "\\(^\\|\n+\\)From ")
|
|
|
712 (case-fold-search nil))
|
|
|
713 (if (re-search-forward reg1 nil 'no-error)
|
|
|
714 (progn (goto-char (match-end 1)) t)
|
|
|
715 nil )))
|
|
|
716 ((eq vm-folder-type 'mmdf)
|
|
|
717 (let ((reg1 "^\001\001\001\001")
|
|
|
718 (case-fold-search nil))
|
|
|
719 (if (re-search-forward reg1 nil 'no-error)
|
|
|
720 (progn
|
|
|
721 (goto-char (match-beginning 0))
|
|
|
722 t )
|
|
|
723 nil )))
|
|
|
724 ((eq vm-folder-type 'babyl)
|
|
|
725 (let ((reg1 "\014\n[01],")
|
|
|
726 (case-fold-search nil))
|
|
|
727 (catch 'done
|
|
|
728 (while (re-search-forward reg1 nil 'no-error)
|
|
|
729 (goto-char (match-beginning 0))
|
|
|
730 (if (and (not (bobp)) (= (preceding-char) ?\037))
|
|
|
731 (throw 'done t)
|
|
|
732 (forward-char 1)))
|
|
|
733 nil )))))
|
|
|
734
|
|
|
735 (defun vm-find-trailing-message-separator ()
|
|
|
736 "Find the next trailing message separator in a folder."
|
|
|
737 (cond
|
|
|
738 ((eq vm-folder-type 'From_)
|
|
|
739 (vm-find-leading-message-separator)
|
|
|
740 (forward-char -1))
|
|
|
741 ((eq vm-folder-type 'From_-with-Content-Length)
|
|
|
742 (let ((reg1 "^From ")
|
|
|
743 content-length
|
|
|
744 (start-point (point))
|
|
|
745 (case-fold-search nil))
|
|
|
746 (if (and (let ((case-fold-search t))
|
|
|
747 (re-search-forward vm-content-length-search-regexp nil t))
|
|
|
748 (null (match-beginning 1))
|
|
|
749 (progn (goto-char (match-beginning 0))
|
|
|
750 (vm-match-header vm-content-length-header)))
|
|
|
751 (progn
|
|
|
752 (setq content-length
|
|
|
753 (string-to-int (vm-matched-header-contents)))
|
|
|
754 ;; if search fails, we'll be at point-max
|
|
|
755 ;; if specified content-length is too long, go to point-max
|
|
|
756 (if (search-forward "\n\n" nil 0)
|
|
|
757 (if (>= (- (point-max) (point)) content-length)
|
|
|
758 (forward-char content-length)
|
|
|
759 (goto-char (point-max))))
|
|
|
760 ;; Some systems seem to add a trailing newline that's
|
|
|
761 ;; not counted in the Content-Length header. Allow
|
|
|
762 ;; any number of them to avoid trouble.
|
|
|
763 (skip-chars-forward "\n")))
|
|
|
764 (if (or (eobp) (looking-at reg1))
|
|
|
765 nil
|
|
|
766 (goto-char start-point)
|
|
|
767 (if (re-search-forward reg1 nil 0)
|
|
|
768 (forward-char -5)))))
|
|
|
769 ((eq vm-folder-type 'mmdf)
|
|
|
770 (vm-find-leading-message-separator))
|
|
|
771 ((eq vm-folder-type 'babyl)
|
|
|
772 (vm-find-leading-message-separator)
|
|
|
773 (forward-char -1))))
|
|
|
774
|
|
|
775 (defun vm-skip-past-leading-message-separator ()
|
|
|
776 "Move point past a leading message separator at point."
|
|
|
777 (cond
|
|
|
778 ((memq vm-folder-type '(From_ From_-with-Content-Length))
|
|
|
779 (let ((reg1 "^>From ")
|
|
|
780 (case-fold-search nil))
|
|
|
781 (forward-line 1)
|
|
|
782 (while (looking-at reg1)
|
|
|
783 (forward-line 1))))
|
|
|
784 ((eq vm-folder-type 'mmdf)
|
|
|
785 (forward-char 5)
|
|
|
786 ;; skip >From. Either SCO's MMDF implementation leaves this
|
|
|
787 ;; stuff in the message, or many sysadmins have screwed up
|
|
|
788 ;; their mail configuration. Either way I'm tired of getting
|
|
|
789 ;; bug reports about it.
|
|
|
790 (let ((reg1 "^>From ")
|
|
|
791 (case-fold-search nil))
|
|
|
792 (while (looking-at reg1)
|
|
|
793 (forward-line 1))))
|
|
|
794 ((eq vm-folder-type 'babyl)
|
|
|
795 (search-forward "\n*** EOOH ***\n" nil 0))))
|
|
|
796
|
|
|
797 (defun vm-skip-past-trailing-message-separator ()
|
|
|
798 "Move point past a trailing message separator at point."
|
|
|
799 (cond
|
|
|
800 ((eq vm-folder-type 'From_)
|
|
|
801 (forward-char 1))
|
|
|
802 ((eq vm-folder-type 'From_-with-Content-Length))
|
|
|
803 ((eq vm-folder-type 'mmdf)
|
|
|
804 (forward-char 5))
|
|
|
805 ((eq vm-folder-type 'babyl)
|
|
|
806 (forward-char 1))))
|
|
|
807
|
|
|
808 (defun vm-build-message-list ()
|
|
|
809 "Build a chain of message structures, stored them in vm-message-list.
|
|
|
810 Finds the start and end of each message and fills in the relevant
|
|
|
811 fields in the message structures.
|
|
|
812
|
|
|
813 Also finds the beginning of the header section and the end of the
|
|
|
814 text section and fills in these fields in the message structures.
|
|
|
815
|
|
|
816 vm-text-of and vm-vheaders-of field don't get filled until they
|
|
|
817 are needed.
|
|
|
818
|
|
|
819 If vm-message-list already contained messages, the end of the last
|
|
|
820 known message is found and then the parsing of new messages begins
|
|
|
821 there and the message are appended to vm-message-list.
|
|
|
822
|
|
|
823 vm-folder-type is initialized here."
|
|
|
824 (setq vm-folder-type (vm-get-folder-type))
|
|
|
825 (save-excursion
|
|
|
826 (let ((tail-cons nil)
|
|
|
827 (n 0)
|
|
|
828 ;; Just for yucks, make the update interval vary.
|
|
|
829 (modulus (+ (% (vm-abs (random)) 11) 25))
|
|
|
830 message last-end)
|
|
|
831 (if vm-message-list
|
|
|
832 ;; there are already messages, therefore we're supposed
|
|
|
833 ;; to add to this list.
|
|
|
834 (let ((mp vm-message-list)
|
|
|
835 (end (point-min)))
|
|
|
836 ;; first we have to find physical end of the folder
|
|
|
837 ;; prior to the new messages that just came in.
|
|
|
838 (while mp
|
|
|
839 (if (< end (vm-end-of (car mp)))
|
|
|
840 (setq end (vm-end-of (car mp))))
|
|
|
841 (if (not (consp (cdr mp)))
|
|
|
842 (setq tail-cons mp))
|
|
|
843 (setq mp (cdr mp)))
|
|
|
844 (goto-char end))
|
|
|
845 ;; there are no messages so we're building the whole list.
|
|
|
846 ;; start from the beginning of the folder.
|
|
|
847 (goto-char (point-min))
|
|
|
848 ;; whine about newlines at the beginning of the folder.
|
|
|
849 ;; technically I think this is corruption, but there are
|
|
|
850 ;; too many busted mail-do-fcc's installed out there to
|
|
|
851 ;; do more than whine.
|
|
|
852 (if (and (memq vm-folder-type '(From_ From_-with-Content-Length))
|
|
|
853 (= (following-char) ?\n))
|
|
|
854 (progn
|
|
|
855 (message "Warning: newline found at beginning of folder, %s"
|
|
|
856 (or buffer-file-name (buffer-name)))
|
|
|
857 (sleep-for 2)))
|
|
|
858 (vm-skip-past-folder-header))
|
|
|
859 (setq last-end (point))
|
|
|
860 ;; parse the messages, set the markers that specify where
|
|
|
861 ;; things are.
|
|
|
862 (while (vm-find-leading-message-separator)
|
|
|
863 (setq message (vm-make-message))
|
|
|
864 (vm-set-message-type-of message vm-folder-type)
|
|
|
865 (vm-set-start-of message (vm-marker (point)))
|
|
|
866 (vm-skip-past-leading-message-separator)
|
|
|
867 (vm-set-headers-of message (vm-marker (point)))
|
|
|
868 (vm-find-trailing-message-separator)
|
|
|
869 (vm-set-text-end-of message (vm-marker (point)))
|
|
|
870 (vm-skip-past-trailing-message-separator)
|
|
|
871 (setq last-end (point))
|
|
|
872 (vm-set-end-of message (vm-marker (point)))
|
|
|
873 (vm-set-reverse-link-of message tail-cons)
|
|
|
874 (if (null tail-cons)
|
|
|
875 (setq vm-message-list (list message)
|
|
|
876 tail-cons vm-message-list)
|
|
|
877 (setcdr tail-cons (list message))
|
|
|
878 (setq tail-cons (cdr tail-cons)))
|
|
|
879 (vm-increment n)
|
|
|
880 (if (zerop (% n modulus))
|
|
70
|
881 (vm-unsaved-message "Parsing messages... %d" n)))
|
|
0
|
882 (if (>= n modulus)
|
|
70
|
883 (vm-unsaved-message "Parsing messages... done"))
|
|
0
|
884 (if (and (not (= last-end (point-max)))
|
|
|
885 (not (eq vm-folder-type 'unknown)))
|
|
|
886 (progn
|
|
|
887 (message "Warning: garbage found at end of folder, %s"
|
|
|
888 (or buffer-file-name (buffer-name)))
|
|
|
889 (sleep-for 2))))))
|
|
|
890
|
|
|
891 (defun vm-build-header-order-alist (vheaders)
|
|
|
892 (let ((order-alist (cons nil nil))
|
|
|
893 list)
|
|
|
894 (setq list order-alist)
|
|
|
895 (while vheaders
|
|
|
896 (setcdr list (cons (cons (car vheaders) nil) nil))
|
|
|
897 (setq list (cdr list) vheaders (cdr vheaders)))
|
|
|
898 (cdr order-alist)))
|
|
|
899
|
|
|
900 ;; Reorder the headers in a message.
|
|
|
901 ;;
|
|
|
902 ;; If a message struct is passed into this function, then we're
|
|
|
903 ;; operating on a message in a folder buffer. Headers are
|
|
|
904 ;; grouped so that the headers that the user wants to see are at
|
|
|
905 ;; the end of the headers section so we can narrow to them. This
|
|
|
906 ;; is done according to the preferences specified in
|
|
|
907 ;; vm-visible-header and vm-invisible-header-regexp. The
|
|
|
908 ;; vheaders field of the message struct is also set. This
|
|
|
909 ;; function is called on demand whenever a vheaders field is
|
|
|
910 ;; discovered to be nil for a particular message.
|
|
|
911 ;;
|
|
|
912 ;; If the message argument is nil, then we are operating on a
|
|
|
913 ;; freestanding message that is not part of a folder buffer. The
|
|
|
914 ;; keep-list and discard-regexp parameters are used in this case.
|
|
|
915 ;; Headers not matched by the keep list or matched by the discard
|
|
|
916 ;; list are stripped from the message. The remaining headers
|
|
|
917 ;; are ordered according to the order of the keep list.
|
|
|
918
|
|
|
919 (defun vm-reorder-message-headers (message keep-list discard-regexp)
|
|
|
920 (save-excursion
|
|
|
921 (if message
|
|
|
922 (progn
|
|
|
923 (set-buffer (vm-buffer-of message))
|
|
|
924 (setq keep-list vm-visible-headers
|
|
|
925 discard-regexp vm-invisible-header-regexp)))
|
|
|
926 (save-excursion
|
|
|
927 (save-restriction
|
|
|
928 (widen)
|
|
|
929 ;; if there is a cached regexp that points to the already
|
|
|
930 ;; ordered headers then use it and avoid a lot of work.
|
|
|
931 (if (and message (vm-vheaders-regexp-of message))
|
|
|
932 (save-excursion
|
|
|
933 (goto-char (vm-headers-of message))
|
|
|
934 (let ((case-fold-search t))
|
|
|
935 (re-search-forward (vm-vheaders-regexp-of message)
|
|
|
936 (vm-text-of message) t))
|
|
|
937 (vm-set-vheaders-of message (vm-marker (match-beginning 0))))
|
|
|
938 ;; oh well, we gotta do it the hard way.
|
|
|
939 ;;
|
|
|
940 ;; header-alist will contain an assoc list version of
|
|
|
941 ;; keep-list. For messages associated with a folder
|
|
70
|
942 ;; buffer: when a matching header is found, the header
|
|
|
943 ;; is stuffed into its corresponding assoc cell and the
|
|
|
944 ;; header text is deleted from the buffer. After all
|
|
|
945 ;; the visible headers have been collected, they are
|
|
|
946 ;; inserted into the buffer in a clump at the end of
|
|
|
947 ;; the header section. Unmatched headers are skipped over.
|
|
0
|
948 ;;
|
|
70
|
949 ;; For free standing messages, unmatched headers are
|
|
|
950 ;; stripped from the message.
|
|
0
|
951 (vm-save-restriction
|
|
|
952 (let ((header-alist (vm-build-header-order-alist keep-list))
|
|
|
953 (buffer-read-only nil)
|
|
|
954 (work-buffer nil)
|
|
|
955 (extras nil)
|
|
|
956 list end-of-header vheader-offset
|
|
|
957 (folder-buffer (current-buffer))
|
|
|
958 ;; This prevents file locking from occuring. Disabling
|
|
|
959 ;; locking can speed things noticeably if the lock directory
|
|
|
960 ;; is on a slow device. We don't need locking here because
|
|
|
961 ;; in a mail context reordering headers is harmless.
|
|
|
962 (buffer-file-name nil)
|
|
|
963 (case-fold-search t)
|
|
|
964 (old-buffer-modified-p (buffer-modified-p)))
|
|
|
965 (unwind-protect
|
|
|
966 (progn
|
|
|
967 (if message
|
|
|
968 (progn
|
|
|
969 ;; for babyl folders, keep an untouched
|
|
|
970 ;; copy of the headers between the
|
|
|
971 ;; attributes line and the *** EOOH ***
|
|
|
972 ;; line.
|
|
|
973 (if (and (eq vm-folder-type 'babyl)
|
|
|
974 (null (vm-babyl-frob-flag-of message)))
|
|
|
975 (progn
|
|
|
976 (goto-char (vm-start-of message))
|
|
|
977 (forward-line 2)
|
|
|
978 (vm-set-babyl-frob-flag-of message t)
|
|
|
979 (insert-buffer-substring
|
|
|
980 (current-buffer)
|
|
|
981 (vm-headers-of message)
|
|
|
982 (1- (vm-text-of message)))))
|
|
|
983 (setq work-buffer (generate-new-buffer "*vm-work*"))
|
|
|
984 (set-buffer work-buffer)
|
|
|
985 (insert-buffer-substring
|
|
|
986 folder-buffer
|
|
|
987 (vm-headers-of message)
|
|
|
988 (vm-text-of message))
|
|
|
989 (goto-char (point-min))))
|
|
70
|
990 (while (and (not (= (following-char) ?\n))
|
|
|
991 (vm-match-header))
|
|
0
|
992 (setq end-of-header (vm-matched-header-end)
|
|
|
993 list (vm-match-ordered-header header-alist))
|
|
|
994 ;; don't display/keep this header if
|
|
|
995 ;; keep-list not matched
|
|
|
996 ;; and discard-regexp is nil
|
|
|
997 ;; or
|
|
|
998 ;; discard-regexp is matched
|
|
|
999 (if (or (and (null list) (null discard-regexp))
|
|
|
1000 (and discard-regexp (looking-at discard-regexp)))
|
|
70
|
1001 ;; skip the unwanted header if doing
|
|
0
|
1002 ;; work for a folder buffer, otherwise
|
|
70
|
1003 ;; discard the header.
|
|
|
1004 (if message
|
|
|
1005 (goto-char end-of-header)
|
|
|
1006 (delete-region (point) end-of-header))
|
|
0
|
1007 ;; got a match
|
|
70
|
1008 ;; stuff the header into the cdr of the
|
|
|
1009 ;; returned alist element
|
|
0
|
1010 (if list
|
|
70
|
1011 (if (cdr list)
|
|
|
1012 (setcdr list
|
|
|
1013 (concat
|
|
|
1014 (cdr list)
|
|
|
1015 (buffer-substring (point)
|
|
|
1016 end-of-header)))
|
|
|
1017 (setcdr list (buffer-substring (point)
|
|
|
1018 end-of-header)))
|
|
0
|
1019 (setq extras
|
|
70
|
1020 (cons (buffer-substring (point) end-of-header)
|
|
|
1021 extras)))
|
|
|
1022 (delete-region (point) end-of-header)))
|
|
0
|
1023 ;; remember the offset of where the visible
|
|
|
1024 ;; header start so we can initialize the
|
|
|
1025 ;; vm-vheaders-of field later.
|
|
|
1026 (if message
|
|
70
|
1027 (setq vheader-offset (1- (point))))
|
|
|
1028 ;; now dump out the headers we saved.
|
|
|
1029 ;; the keep-list headers go first.
|
|
|
1030 (setq list header-alist)
|
|
|
1031 (while list
|
|
|
1032 (if (cdr (car list))
|
|
|
1033 (progn
|
|
|
1034 (insert (cdr (car list)))
|
|
|
1035 (setcdr (car list) nil)))
|
|
|
1036 (setq list (cdr list)))
|
|
0
|
1037 ;; now the headers that were not explicitly
|
|
|
1038 ;; undesirable, if any.
|
|
70
|
1039 (if extras
|
|
|
1040 (progn
|
|
|
1041 (setq extras (nreverse extras))
|
|
|
1042 (while extras
|
|
|
1043 (insert (car extras))
|
|
|
1044 (setq extras (cdr extras)))))
|
|
0
|
1045 ;; update the folder buffer if we're supposed to.
|
|
|
1046 ;; lock out interrupts.
|
|
|
1047 (if message
|
|
|
1048 (let ((inhibit-quit t))
|
|
|
1049 (set-buffer (vm-buffer-of message))
|
|
|
1050 (goto-char (vm-headers-of message))
|
|
|
1051 (insert-buffer-substring work-buffer)
|
|
|
1052 (delete-region (point) (vm-text-of message))
|
|
|
1053 (set-buffer-modified-p old-buffer-modified-p))))
|
|
|
1054 (and work-buffer (kill-buffer work-buffer)))
|
|
|
1055 (if message
|
|
|
1056 (progn
|
|
|
1057 (vm-set-vheaders-of message
|
|
|
1058 (vm-marker (+ (vm-headers-of message)
|
|
|
1059 vheader-offset)))
|
|
|
1060 ;; cache a regular expression that can be used to
|
|
|
1061 ;; find the start of the reordered header the next
|
|
|
1062 ;; time this folder is visited.
|
|
|
1063 (goto-char (vm-vheaders-of message))
|
|
|
1064 (if (vm-match-header)
|
|
|
1065 (vm-set-vheaders-regexp-of
|
|
|
1066 message
|
|
|
1067 (concat "^" (vm-matched-header-name) ":"))))))))))))
|
|
|
1068
|
|
|
1069 ;; Reads the message attributes and cached header information from the
|
|
|
1070 ;; header portion of the each message, if our X-VM- attributes header is
|
|
|
1071 ;; present. If the header is not present, assume the message is new,
|
|
|
1072 ;; unless we are being compatible with Berkeley Mail in which case we
|
|
|
1073 ;; also check for a Status header.
|
|
|
1074 ;;
|
|
|
1075 ;; If a message already has attributes don't bother checking the
|
|
|
1076 ;; headers.
|
|
|
1077 ;;
|
|
|
1078 ;; This function also discovers and stores the position where the
|
|
|
1079 ;; message text begins.
|
|
|
1080 ;;
|
|
|
1081 ;; Totals are gathered for use by vm-emit-totals-blurb.
|
|
|
1082 ;;
|
|
|
1083 ;; Supports version 4 format of attribute storage, for backward compatibility.
|
|
|
1084
|
|
|
1085 (defun vm-read-attributes (message-list)
|
|
|
1086 (save-excursion
|
|
|
1087 (let ((mp (or message-list vm-message-list))
|
|
|
1088 (vm-new-count 0)
|
|
|
1089 (vm-unread-count 0)
|
|
|
1090 (vm-deleted-count 0)
|
|
|
1091 (vm-total-count 0)
|
|
|
1092 (modulus (+ (% (vm-abs (random)) 11) 25))
|
|
|
1093 (case-fold-search t)
|
|
70
|
1094 data)
|
|
0
|
1095 (while mp
|
|
|
1096 (vm-increment vm-total-count)
|
|
|
1097 (if (vm-attributes-of (car mp))
|
|
|
1098 ()
|
|
|
1099 (goto-char (vm-headers-of (car mp)))
|
|
|
1100 ;; find start of text section and save it
|
|
|
1101 (search-forward "\n\n" (vm-text-end-of (car mp)) 0)
|
|
|
1102 (vm-set-text-of (car mp) (point-marker))
|
|
|
1103 ;; now look for our header
|
|
|
1104 (goto-char (vm-headers-of (car mp)))
|
|
|
1105 (cond
|
|
|
1106 ((re-search-forward vm-attributes-header-regexp
|
|
|
1107 (vm-text-of (car mp)) t)
|
|
|
1108 (goto-char (match-beginning 2))
|
|
|
1109 (condition-case ()
|
|
70
|
1110 (setq data (read (current-buffer)))
|
|
|
1111 (error (setq data
|
|
|
1112 (list
|
|
|
1113 (make-vector vm-attributes-vector-length nil)
|
|
|
1114 (make-vector vm-cache-vector-length nil)
|
|
|
1115 nil))
|
|
|
1116 ;; In lieu of a valid attributes header
|
|
|
1117 ;; assume the message is new. avoid
|
|
|
1118 ;; vm-set-new-flag because it asks for a
|
|
|
1119 ;; summary update.
|
|
|
1120 (vm-set-new-flag-in-vector (car data) t)))
|
|
0
|
1121 ;; support version 4 format
|
|
|
1122 (cond ((vectorp data)
|
|
|
1123 (setq data (vm-convert-v4-attributes data))
|
|
|
1124 ;; tink the message modflag so that if the
|
|
|
1125 ;; user saves we get rid of the old v4
|
|
|
1126 ;; attributes header. otherwise we could be
|
|
|
1127 ;; dealing with these things for all eternity.
|
|
|
1128 (vm-set-modflag-of (car mp) t))
|
|
|
1129 (t
|
|
|
1130 ;; extend vectors if necessary to accomodate
|
|
|
1131 ;; more caching and attributes without alienating
|
|
|
1132 ;; other version 5 folders.
|
|
|
1133 (cond ((< (length (car data))
|
|
|
1134 vm-attributes-vector-length)
|
|
|
1135 ;; tink the message modflag so that if
|
|
|
1136 ;; the user saves we get rid of the old
|
|
|
1137 ;; short vector. otherwise we could be
|
|
|
1138 ;; dealing with these things for all
|
|
|
1139 ;; eternity.
|
|
|
1140 (vm-set-modflag-of (car mp) t)
|
|
|
1141 (setcar data (vm-extend-vector
|
|
|
1142 (car data)
|
|
|
1143 vm-attributes-vector-length))))
|
|
|
1144 (cond ((< (length (car (cdr data)))
|
|
|
1145 vm-cache-vector-length)
|
|
|
1146 ;; tink the message modflag so that if
|
|
|
1147 ;; the user saves we get rid of the old
|
|
|
1148 ;; short vector. otherwise we could be
|
|
|
1149 ;; dealing with these things for all
|
|
|
1150 ;; eternity.
|
|
|
1151 (vm-set-modflag-of (car mp) t)
|
|
|
1152 (setcar (cdr data)
|
|
|
1153 (vm-extend-vector
|
|
|
1154 (car (cdr data))
|
|
|
1155 vm-cache-vector-length))))))
|
|
|
1156 (vm-set-labels-of (car mp) (nth 2 data))
|
|
|
1157 (vm-set-cache-of (car mp) (car (cdr data)))
|
|
|
1158 (vm-set-attributes-of (car mp) (car data)))
|
|
|
1159 ((and vm-berkeley-mail-compatibility
|
|
|
1160 (re-search-forward vm-berkeley-mail-status-header-regexp
|
|
|
1161 (vm-text-of (car mp)) t))
|
|
|
1162 (vm-set-cache-of (car mp) (make-vector vm-cache-vector-length
|
|
|
1163 nil))
|
|
|
1164 (goto-char (match-beginning 1))
|
|
|
1165 (vm-set-attributes-of
|
|
|
1166 (car mp)
|
|
|
1167 (make-vector vm-attributes-vector-length nil))
|
|
|
1168 (vm-set-unread-flag (car mp) (not (looking-at ".*R.*")) t))
|
|
|
1169 (t
|
|
|
1170 (vm-set-cache-of (car mp) (make-vector vm-cache-vector-length
|
|
|
1171 nil))
|
|
|
1172 (vm-set-attributes-of
|
|
|
1173 (car mp)
|
|
|
1174 (make-vector vm-attributes-vector-length nil))
|
|
|
1175 ;; In lieu of a valid attributes header
|
|
|
1176 ;; assume the message is new. avoid
|
|
|
1177 ;; vm-set-new-flag because it asks for a
|
|
|
1178 ;; summary update.
|
|
|
1179 (vm-set-new-flag-of (car mp) t)))
|
|
|
1180 ;; let babyl attributes override the normal VM
|
|
|
1181 ;; attributes header.
|
|
|
1182 (cond ((eq vm-folder-type 'babyl)
|
|
|
1183 (vm-read-babyl-attributes (car mp)))))
|
|
|
1184 (cond ((vm-deleted-flag (car mp))
|
|
|
1185 (vm-increment vm-deleted-count))
|
|
|
1186 ((vm-new-flag (car mp))
|
|
|
1187 (vm-increment vm-new-count))
|
|
|
1188 ((vm-unread-flag (car mp))
|
|
|
1189 (vm-increment vm-unread-count)))
|
|
|
1190 (if (zerop (% vm-total-count modulus))
|
|
70
|
1191 (vm-unsaved-message "Reading attributes... %d" vm-total-count))
|
|
0
|
1192 (setq mp (cdr mp)))
|
|
|
1193 (if (>= vm-total-count modulus)
|
|
70
|
1194 (vm-unsaved-message "Reading attributes... done"))
|
|
0
|
1195 (if (null message-list)
|
|
|
1196 (setq vm-totals (list vm-modification-counter
|
|
|
1197 vm-total-count
|
|
|
1198 vm-new-count
|
|
|
1199 vm-unread-count
|
|
|
1200 vm-deleted-count))))))
|
|
|
1201
|
|
|
1202 (defun vm-read-babyl-attributes (message)
|
|
|
1203 (let ((case-fold-search t)
|
|
|
1204 (labels nil)
|
|
|
1205 (vect (make-vector vm-attributes-vector-length nil)))
|
|
|
1206 (vm-set-attributes-of message vect)
|
|
|
1207 (save-excursion
|
|
|
1208 (goto-char (vm-start-of message))
|
|
|
1209 ;; skip past ^L\n
|
|
|
1210 (forward-char 2)
|
|
|
1211 (vm-set-babyl-frob-flag-of message (if (= (following-char) ?1) t nil))
|
|
|
1212 ;; skip past 0,
|
|
|
1213 (forward-char 2)
|
|
|
1214 ;; loop, noting attributes as we go.
|
|
|
1215 (while (and (not (eobp)) (not (looking-at ",")))
|
|
|
1216 (cond ((looking-at " unseen,")
|
|
|
1217 (vm-set-unread-flag-of message t))
|
|
|
1218 ((looking-at " recent,")
|
|
|
1219 (vm-set-new-flag-of message t))
|
|
|
1220 ((looking-at " deleted,")
|
|
|
1221 (vm-set-deleted-flag-of message t))
|
|
|
1222 ((looking-at " answered,")
|
|
|
1223 (vm-set-replied-flag-of message t))
|
|
|
1224 ((looking-at " forwarded,")
|
|
|
1225 (vm-set-forwarded-flag-of message t))
|
|
|
1226 ((looking-at " filed,")
|
|
|
1227 (vm-set-filed-flag-of message t))
|
|
|
1228 ((looking-at " redistributed,")
|
|
|
1229 (vm-set-redistributed-flag-of message t))
|
|
|
1230 ;; only VM knows about these, as far as I know.
|
|
|
1231 ((looking-at " edited,")
|
|
|
1232 (vm-set-forwarded-flag-of message t))
|
|
|
1233 ((looking-at " written,")
|
|
|
1234 (vm-set-forwarded-flag-of message t)))
|
|
|
1235 (skip-chars-forward "^,")
|
|
|
1236 (and (not (eobp)) (forward-char 1)))
|
|
|
1237 (and (not (eobp)) (forward-char 1))
|
|
|
1238 (while (looking-at " \\([^\000-\040,\177-\377]+\\),")
|
|
|
1239 (setq labels (cons (vm-buffer-substring-no-properties
|
|
|
1240 (match-beginning 1)
|
|
|
1241 (match-end 1))
|
|
|
1242 labels))
|
|
|
1243 (goto-char (match-end 0)))
|
|
|
1244 (vm-set-labels-of message labels))))
|
|
|
1245
|
|
|
1246 (defun vm-set-default-attributes (message-list)
|
|
|
1247 (let ((mp (or message-list vm-message-list)) attr cache)
|
|
|
1248 (while mp
|
|
|
1249 (setq attr (make-vector vm-attributes-vector-length nil)
|
|
|
1250 cache (make-vector vm-cache-vector-length nil))
|
|
|
1251 (vm-set-cache-of (car mp) cache)
|
|
|
1252 (vm-set-attributes-of (car mp) attr)
|
|
|
1253 ;; make message be new by default, but avoid vm-set-new-flag
|
|
|
1254 ;; because it asks for a summary update for the message.
|
|
|
1255 (vm-set-new-flag-of (car mp) t)
|
|
|
1256 ;; since this function is usually called in lieu of reading
|
|
|
1257 ;; attributes from the buffer, the attributes may be
|
|
|
1258 ;; untrustworthy. tink the message modflag to force the
|
|
|
1259 ;; new attributes out if the user saves.
|
|
|
1260 (vm-set-modflag-of (car mp) t)
|
|
|
1261 (setq mp (cdr mp)))))
|
|
|
1262
|
|
|
1263 (defun vm-emit-totals-blurb ()
|
|
|
1264 (save-excursion
|
|
|
1265 (vm-select-folder-buffer)
|
|
|
1266 (if (not (equal (nth 0 vm-totals) vm-modification-counter))
|
|
|
1267 (let ((mp vm-message-list)
|
|
|
1268 (vm-new-count 0)
|
|
|
1269 (vm-unread-count 0)
|
|
|
1270 (vm-deleted-count 0)
|
|
|
1271 (vm-total-count 0))
|
|
|
1272 (while mp
|
|
|
1273 (vm-increment vm-total-count)
|
|
|
1274 (cond ((vm-deleted-flag (car mp))
|
|
|
1275 (vm-increment vm-deleted-count))
|
|
|
1276 ((vm-new-flag (car mp))
|
|
|
1277 (vm-increment vm-new-count))
|
|
|
1278 ((vm-unread-flag (car mp))
|
|
|
1279 (vm-increment vm-unread-count)))
|
|
|
1280 (setq mp (cdr mp)))
|
|
|
1281 (setq vm-totals (list vm-modification-counter
|
|
|
1282 vm-total-count
|
|
|
1283 vm-new-count
|
|
|
1284 vm-unread-count
|
|
|
1285 vm-deleted-count))))
|
|
|
1286 (if (equal (nth 1 vm-totals) 0)
|
|
|
1287 (message "No messages.")
|
|
|
1288 (message "%d message%s, %d new, %d unread, %d deleted"
|
|
|
1289 (nth 1 vm-totals) (if (= (nth 1 vm-totals) 1) "" "s")
|
|
|
1290 (nth 2 vm-totals)
|
|
|
1291 (nth 3 vm-totals)
|
|
|
1292 (nth 4 vm-totals)))))
|
|
|
1293
|
|
|
1294 (defun vm-convert-v4-attributes (data)
|
|
|
1295 (list (apply 'vector
|
|
|
1296 (nconc (vm-vector-to-list data)
|
|
|
1297 (make-list (- vm-attributes-vector-length
|
|
|
1298 (length data))
|
|
|
1299 nil)))
|
|
|
1300 (make-vector vm-cache-vector-length nil)))
|
|
|
1301
|
|
|
1302 (defun vm-gobble-labels ()
|
|
|
1303 (let ((case-fold-search t)
|
|
|
1304 lim)
|
|
|
1305 (save-excursion
|
|
|
1306 (vm-save-restriction
|
|
|
1307 (widen)
|
|
|
1308 (if (eq vm-folder-type 'babyl)
|
|
|
1309 (progn
|
|
|
1310 (goto-char (point-min))
|
|
|
1311 (vm-skip-past-folder-header)
|
|
|
1312 (setq lim (point))
|
|
|
1313 (goto-char (point-min))
|
|
|
1314 (if (re-search-forward "^Labels:" lim t)
|
|
|
1315 (let (string list)
|
|
|
1316 (setq string (buffer-substring
|
|
|
1317 (point)
|
|
|
1318 (progn (end-of-line) (point)))
|
|
|
1319 list (vm-parse string
|
|
|
1320 "[\000-\040,\177-\377]*\\([^\000-\040,\177-\377]+\\)[\000-\040,\177-\377]*"))
|
|
|
1321 (mapcar (function
|
|
|
1322 (lambda (s)
|
|
|
1323 (intern (downcase s) vm-label-obarray)))
|
|
|
1324 list))))
|
|
|
1325 (goto-char (point-min))
|
|
|
1326 (vm-skip-past-folder-header)
|
|
|
1327 (vm-skip-past-leading-message-separator)
|
|
|
1328 (search-forward "\n\n" nil t)
|
|
|
1329 (setq lim (point))
|
|
|
1330 (goto-char (point-min))
|
|
|
1331 (vm-skip-past-folder-header)
|
|
|
1332 (vm-skip-past-leading-message-separator)
|
|
|
1333 (if (re-search-forward vm-labels-header-regexp lim t)
|
|
70
|
1334 (let (list)
|
|
|
1335 (setq list (read (current-buffer)))
|
|
0
|
1336 (mapcar (function
|
|
|
1337 (lambda (s)
|
|
|
1338 (intern s vm-label-obarray)))
|
|
|
1339 list))))))
|
|
|
1340 t ))
|
|
|
1341
|
|
|
1342 ;; Go to the message specified in a bookmark and eat the bookmark.
|
|
|
1343 ;; Returns non-nil if successful, nil otherwise.
|
|
|
1344 (defun vm-gobble-bookmark ()
|
|
|
1345 (let ((case-fold-search t)
|
|
70
|
1346 n lim)
|
|
0
|
1347 (save-excursion
|
|
|
1348 (vm-save-restriction
|
|
|
1349 (widen)
|
|
|
1350 (goto-char (point-min))
|
|
|
1351 (vm-skip-past-folder-header)
|
|
|
1352 (vm-skip-past-leading-message-separator)
|
|
|
1353 (search-forward "\n\n" nil t)
|
|
|
1354 (setq lim (point))
|
|
|
1355 (goto-char (point-min))
|
|
|
1356 (vm-skip-past-folder-header)
|
|
|
1357 (vm-skip-past-leading-message-separator)
|
|
|
1358 (if (re-search-forward vm-bookmark-header-regexp lim t)
|
|
70
|
1359 (setq n (read (current-buffer))))))
|
|
0
|
1360 (if n
|
|
|
1361 (vm-record-and-change-message-pointer
|
|
|
1362 vm-message-pointer
|
|
|
1363 (nthcdr (1- n) vm-message-list)))
|
|
|
1364 t ))
|
|
|
1365
|
|
|
1366 (defun vm-gobble-visible-header-variables ()
|
|
|
1367 (save-excursion
|
|
|
1368 (vm-save-restriction
|
|
|
1369 (let ((case-fold-search t)
|
|
|
1370 lim)
|
|
|
1371 (widen)
|
|
|
1372 (goto-char (point-min))
|
|
|
1373 (vm-skip-past-folder-header)
|
|
|
1374 (vm-skip-past-leading-message-separator)
|
|
|
1375 (search-forward "\n\n" nil t)
|
|
|
1376 (setq lim (point))
|
|
|
1377 (goto-char (point-min))
|
|
|
1378 (vm-skip-past-folder-header)
|
|
|
1379 (vm-skip-past-leading-message-separator)
|
|
|
1380 (if (re-search-forward vm-vheader-header-regexp lim t)
|
|
|
1381 (let (vis invis (got nil))
|
|
|
1382 (condition-case ()
|
|
|
1383 (setq vis (read (current-buffer))
|
|
|
1384 invis (read (current-buffer))
|
|
|
1385 got t)
|
|
|
1386 (error nil))
|
|
|
1387 ;; if the variables don't match the values stored when this
|
|
|
1388 ;; folder was saved, then we have to discard any cached
|
|
|
1389 ;; vheader info so the user will see the right headers.
|
|
|
1390 (and got (or (not (equal vis vm-visible-headers))
|
|
|
1391 (not (equal invis vm-invisible-header-regexp)))
|
|
|
1392 (let ((mp vm-message-list))
|
|
70
|
1393 (vm-unsaved-message "Discarding visible header info...")
|
|
0
|
1394 (while mp
|
|
|
1395 (vm-set-vheaders-regexp-of (car mp) nil)
|
|
|
1396 (vm-set-vheaders-of (car mp) nil)
|
|
|
1397 (setq mp (cdr mp)))))))))))
|
|
|
1398
|
|
|
1399 ;; Read and delete the header that gives the folder's desired
|
|
|
1400 ;; message order.
|
|
|
1401 (defun vm-gobble-message-order ()
|
|
|
1402 (let ((case-fold-search t)
|
|
|
1403 lim v order
|
|
|
1404 (mp vm-message-list)
|
|
|
1405 list-length)
|
|
|
1406 (save-excursion
|
|
|
1407 (save-restriction
|
|
|
1408 (widen)
|
|
|
1409 (goto-char (point-min))
|
|
|
1410 (vm-skip-past-folder-header)
|
|
|
1411 (vm-skip-past-leading-message-separator)
|
|
|
1412 (search-forward "\n\n" nil t)
|
|
|
1413 (setq lim (point))
|
|
|
1414 (goto-char (point-min))
|
|
|
1415 (vm-skip-past-folder-header)
|
|
|
1416 (vm-skip-past-leading-message-separator)
|
|
|
1417 (if (re-search-forward vm-message-order-header-regexp lim t)
|
|
70
|
1418 (progn
|
|
|
1419 (vm-unsaved-message "Reordering messages...")
|
|
|
1420 (setq order (read (current-buffer))
|
|
|
1421 list-length (length vm-message-list)
|
|
0
|
1422 v (make-vector (max list-length (length order)) nil))
|
|
|
1423 (while (and order mp)
|
|
70
|
1424 (aset v (1- (car order)) (car mp))
|
|
0
|
1425 (setq order (cdr order) mp (cdr mp)))
|
|
|
1426 ;; lock out interrupts while the message list is in
|
|
|
1427 ;; an inconsistent state.
|
|
|
1428 (let ((inhibit-quit t))
|
|
|
1429 (setq vm-message-list (delq nil (append v mp))
|
|
|
1430 vm-message-order-changed nil
|
|
|
1431 vm-message-order-header-present t
|
|
|
1432 vm-message-pointer (memq (car vm-message-pointer)
|
|
|
1433 vm-message-list))
|
|
|
1434 (vm-set-numbering-redo-start-point t)
|
|
|
1435 (vm-reverse-link-messages))
|
|
70
|
1436 (vm-unsaved-message "Reordering messages... done")))))))
|
|
0
|
1437
|
|
|
1438 ;; Read the header that gives the folder's cached summary format
|
|
|
1439 ;; If the current summary format is different, then the cached
|
|
|
1440 ;; summary lines are discarded.
|
|
|
1441 (defun vm-gobble-summary ()
|
|
|
1442 (let ((case-fold-search t)
|
|
|
1443 summary lim
|
|
|
1444 (mp vm-message-list))
|
|
|
1445 (save-excursion
|
|
|
1446 (vm-save-restriction
|
|
|
1447 (widen)
|
|
|
1448 (goto-char (point-min))
|
|
|
1449 (vm-skip-past-folder-header)
|
|
|
1450 (vm-skip-past-leading-message-separator)
|
|
|
1451 (search-forward "\n\n" nil t)
|
|
|
1452 (setq lim (point))
|
|
|
1453 (goto-char (point-min))
|
|
|
1454 (vm-skip-past-folder-header)
|
|
|
1455 (vm-skip-past-leading-message-separator)
|
|
|
1456 (if (re-search-forward vm-summary-header-regexp lim t)
|
|
70
|
1457 (progn
|
|
|
1458 (setq summary (read (current-buffer)))
|
|
0
|
1459 (if (not (equal summary vm-summary-format))
|
|
|
1460 (while mp
|
|
|
1461 (vm-set-summary-of (car mp) nil)
|
|
|
1462 ;; force restuffing of cache to clear old
|
|
|
1463 ;; summary entry cache.
|
|
|
1464 (vm-set-modflag-of (car mp) t)
|
|
|
1465 (setq mp (cdr mp))))))))))
|
|
|
1466
|
|
|
1467 ;; Stuff the message attributes back into the message as headers.
|
|
|
1468 (defun vm-stuff-attributes (m &optional for-other-folder)
|
|
|
1469 (save-excursion
|
|
|
1470 (vm-save-restriction
|
|
|
1471 (widen)
|
|
|
1472 (let ((old-buffer-modified-p (buffer-modified-p))
|
|
|
1473 attributes cache
|
|
|
1474 (case-fold-search t)
|
|
|
1475 (buffer-read-only nil)
|
|
76
|
1476 ;; don't truncate the printing of large Lisp objects
|
|
|
1477 (print-length nil)
|
|
0
|
1478 opoint
|
|
|
1479 ;; This prevents file locking from occuring. Disabling
|
|
|
1480 ;; locking can speed things noticeably if the lock
|
|
|
1481 ;; directory is on a slow device. We don't need locking
|
|
|
1482 ;; here because the user shouldn't care about VM stuffing
|
|
|
1483 ;; its own status headers.
|
|
|
1484 (buffer-file-name nil)
|
|
|
1485 (delflag (vm-deleted-flag m)))
|
|
|
1486 (unwind-protect
|
|
|
1487 (progn
|
|
|
1488 ;; don't put this folder's summary entry into another folder.
|
|
|
1489 (if for-other-folder
|
|
|
1490 (vm-set-summary-of m nil)
|
|
|
1491 (if (vm-su-start-of m)
|
|
|
1492 ;; fill the summary cache if it's not done already.
|
|
|
1493 (vm-su-summary m)))
|
|
|
1494 (setq attributes (vm-attributes-of m)
|
|
|
1495 cache (vm-cache-of m))
|
|
|
1496 (and delflag for-other-folder
|
|
|
1497 (vm-set-deleted-flag-in-vector
|
|
|
1498 (setq attributes (copy-sequence attributes)) nil))
|
|
|
1499 (if (eq vm-folder-type 'babyl)
|
|
|
1500 (vm-stuff-babyl-attributes m for-other-folder))
|
|
|
1501 (goto-char (vm-headers-of m))
|
|
|
1502 (while (re-search-forward vm-attributes-header-regexp
|
|
|
1503 (vm-text-of m) t)
|
|
|
1504 (delete-region (match-beginning 0) (match-end 0)))
|
|
|
1505 (goto-char (vm-headers-of m))
|
|
|
1506 (setq opoint (point))
|
|
|
1507 (insert-before-markers
|
|
|
1508 vm-attributes-header " ("
|
|
|
1509 (let ((print-escape-newlines t))
|
|
|
1510 (prin1-to-string attributes))
|
|
|
1511 "\n\t"
|
|
|
1512 (let ((print-escape-newlines t))
|
|
|
1513 (prin1-to-string cache))
|
|
|
1514 "\n\t"
|
|
|
1515 (let ((print-escape-newlines t))
|
|
|
1516 (prin1-to-string (vm-labels-of m)))
|
|
|
1517 ")\n")
|
|
|
1518 (set-marker (vm-headers-of m) opoint)
|
|
|
1519 (cond ((and (eq vm-folder-type 'From_)
|
|
|
1520 vm-berkeley-mail-compatibility)
|
|
|
1521 (goto-char (vm-headers-of m))
|
|
|
1522 (while (re-search-forward
|
|
|
1523 vm-berkeley-mail-status-header-regexp
|
|
|
1524 (vm-text-of m) t)
|
|
|
1525 (delete-region (match-beginning 0) (match-end 0)))
|
|
|
1526 (goto-char (vm-headers-of m))
|
|
|
1527 (cond ((not (vm-new-flag m))
|
|
|
1528 (insert-before-markers
|
|
|
1529 vm-berkeley-mail-status-header
|
|
|
1530 (if (vm-unread-flag m) "" "R")
|
|
|
1531 "O\n")
|
|
|
1532 (set-marker (vm-headers-of m) opoint)))))
|
|
|
1533 (vm-set-modflag-of m nil))
|
|
|
1534 (set-buffer-modified-p old-buffer-modified-p))))))
|
|
|
1535
|
|
|
1536 ;; 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
|
|
|
1538 ;; restoring the modified flag, setting buffer-read-only, or
|
|
|
1539 ;; about not moving point.
|
|
|
1540 (defun vm-stuff-babyl-attributes (m for-other-folder)
|
|
|
1541 (goto-char (vm-start-of m))
|
|
|
1542 (forward-char 2)
|
|
|
1543 (if (vm-babyl-frob-flag-of m)
|
|
|
1544 (insert "1")
|
|
|
1545 (insert "0"))
|
|
|
1546 (delete-char 1)
|
|
|
1547 (forward-char 1)
|
|
|
1548 (if (looking-at "\\( [^\000-\040,\177-\377]+,\\)+")
|
|
|
1549 (delete-region (match-beginning 0) (match-end 0)))
|
|
|
1550 (if (vm-new-flag m)
|
|
|
1551 (insert " recent, unseen,")
|
|
|
1552 (if (vm-unread-flag m)
|
|
|
1553 (insert " unseen,")))
|
|
|
1554 (if (and (not for-other-folder) (vm-deleted-flag m))
|
|
|
1555 (insert " deleted,"))
|
|
|
1556 (if (vm-replied-flag m)
|
|
|
1557 (insert " answered,"))
|
|
|
1558 (if (vm-forwarded-flag m)
|
|
|
1559 (insert " forwarded,"))
|
|
|
1560 (if (vm-redistributed-flag m)
|
|
|
1561 (insert " redistributed,"))
|
|
|
1562 (if (vm-filed-flag m)
|
|
|
1563 (insert " filed,"))
|
|
|
1564 (if (vm-edited-flag m)
|
|
|
1565 (insert " edited,"))
|
|
|
1566 (if (vm-written-flag m)
|
|
|
1567 (insert " written,"))
|
|
|
1568 (forward-char 1)
|
|
|
1569 (if (looking-at "\\( [^\000-\040,\177-\377]+,\\)+")
|
|
|
1570 (delete-region (match-beginning 0) (match-end 0)))
|
|
|
1571 (mapcar (function (lambda (label) (insert " " label ",")))
|
|
|
1572 (vm-labels-of m)))
|
|
|
1573
|
|
|
1574 (defun vm-babyl-attributes-string (m for-other-folder)
|
|
|
1575 (concat
|
|
|
1576 (if (vm-new-flag m)
|
|
|
1577 " recent, unseen,"
|
|
|
1578 (if (vm-unread-flag m)
|
|
|
1579 " unseen,"))
|
|
|
1580 (if (and (not for-other-folder) (vm-deleted-flag m))
|
|
|
1581 " deleted,")
|
|
|
1582 (if (vm-replied-flag m)
|
|
|
1583 " answered,")
|
|
|
1584 (if (vm-forwarded-flag m)
|
|
|
1585 " forwarded,")
|
|
|
1586 (if (vm-redistributed-flag m)
|
|
|
1587 " redistributed,")
|
|
|
1588 (if (vm-filed-flag m)
|
|
|
1589 " filed,")
|
|
|
1590 (if (vm-edited-flag m)
|
|
|
1591 " edited,")
|
|
|
1592 (if (vm-written-flag m)
|
|
|
1593 " written,")))
|
|
|
1594
|
|
|
1595 (defun vm-babyl-labels-string (m)
|
|
|
1596 (let ((list nil)
|
|
|
1597 (labels (vm-labels-of m)))
|
|
|
1598 (while labels
|
|
|
1599 (setq list (cons "," (cons (car labels) (cons " " list)))
|
|
|
1600 labels (cdr labels)))
|
|
|
1601 (apply 'concat (nreverse list))))
|
|
|
1602
|
|
|
1603 (defun vm-stuff-virtual-attributes (message)
|
|
|
1604 (let ((virtual (vm-virtual-message-p message)))
|
|
|
1605 (if (or (not virtual) (and virtual (vm-virtual-messages-of message)))
|
|
|
1606 (save-excursion
|
|
|
1607 (set-buffer
|
|
|
1608 (vm-buffer-of
|
|
|
1609 (vm-real-message-of message)))
|
|
|
1610 (vm-stuff-attributes (vm-real-message-of message))))))
|
|
|
1611
|
|
|
1612 (defun vm-stuff-labels ()
|
|
|
1613 (if vm-message-pointer
|
|
|
1614 (save-excursion
|
|
|
1615 (vm-save-restriction
|
|
|
1616 (widen)
|
|
|
1617 (let ((old-buffer-modified-p (buffer-modified-p))
|
|
|
1618 (case-fold-search t)
|
|
|
1619 ;; This prevents file locking from occuring. Disabling
|
|
|
1620 ;; locking can speed things noticeably if the lock
|
|
|
1621 ;; directory is on a slow device. We don't need locking
|
|
|
1622 ;; here because the user shouldn't care about VM stuffing
|
|
|
1623 ;; its own status headers.
|
|
|
1624 (buffer-file-name nil)
|
|
|
1625 (buffer-read-only nil)
|
|
|
1626 lim)
|
|
|
1627 (if (eq vm-folder-type 'babyl)
|
|
|
1628 (progn
|
|
|
1629 (goto-char (point-min))
|
|
|
1630 (vm-skip-past-folder-header)
|
|
|
1631 (delete-region (point) (point-min))
|
|
|
1632 (insert-before-markers (vm-folder-header vm-folder-type
|
|
|
1633 vm-label-obarray))))
|
|
|
1634 (goto-char (point-min))
|
|
|
1635 (vm-skip-past-folder-header)
|
|
|
1636 (vm-find-leading-message-separator)
|
|
|
1637 (vm-skip-past-leading-message-separator)
|
|
|
1638 (search-forward "\n\n" nil t)
|
|
|
1639 (setq lim (point))
|
|
|
1640 (goto-char (point-min))
|
|
|
1641 (vm-skip-past-folder-header)
|
|
|
1642 (vm-find-leading-message-separator)
|
|
|
1643 (vm-skip-past-leading-message-separator)
|
|
|
1644 (while (re-search-forward vm-labels-header-regexp lim t)
|
|
|
1645 (progn (goto-char (match-beginning 0))
|
|
|
1646 (if (vm-match-header vm-labels-header)
|
|
|
1647 (delete-region (vm-matched-header-start)
|
|
|
1648 (vm-matched-header-end)))))
|
|
|
1649 ;; To insert or to insert-before-markers, that is the question.
|
|
|
1650 ;;
|
|
|
1651 ;; If we insert-before-markers we push a header behind
|
|
|
1652 ;; vm-headers-of, which is clearly undesirable. So we
|
|
|
1653 ;; just insert. This will cause the summary header
|
|
|
1654 ;; to be visible if there are no non-visible headers,
|
|
|
1655 ;; oh well, no way around this.
|
|
|
1656 (insert vm-labels-header " "
|
|
|
1657 (let ((print-escape-newlines t)
|
|
76
|
1658 ;; don't truncate the printing of large Lisp objects
|
|
|
1659 (print-length nil)
|
|
0
|
1660 (list nil))
|
|
|
1661 (mapatoms (function
|
|
|
1662 (lambda (sym)
|
|
|
1663 (setq list (cons (symbol-name sym) list))))
|
|
|
1664 vm-label-obarray)
|
|
|
1665 (prin1-to-string list))
|
|
|
1666 "\n")
|
|
|
1667 (set-buffer-modified-p old-buffer-modified-p))))))
|
|
|
1668
|
|
|
1669 ;; Insert a bookmark into the first message in the folder.
|
|
|
1670 (defun vm-stuff-bookmark ()
|
|
|
1671 (if vm-message-pointer
|
|
|
1672 (save-excursion
|
|
|
1673 (vm-save-restriction
|
|
|
1674 (widen)
|
|
|
1675 (let ((old-buffer-modified-p (buffer-modified-p))
|
|
|
1676 (case-fold-search t)
|
|
|
1677 ;; This prevents file locking from occuring. Disabling
|
|
|
1678 ;; locking can speed things noticeably if the lock
|
|
|
1679 ;; directory is on a slow device. We don't need locking
|
|
|
1680 ;; here because the user shouldn't care about VM stuffing
|
|
|
1681 ;; its own status headers.
|
|
|
1682 (buffer-file-name nil)
|
|
|
1683 (buffer-read-only nil)
|
|
|
1684 lim)
|
|
|
1685 (goto-char (point-min))
|
|
|
1686 (vm-skip-past-folder-header)
|
|
|
1687 (vm-find-leading-message-separator)
|
|
|
1688 (vm-skip-past-leading-message-separator)
|
|
|
1689 (search-forward "\n\n" nil t)
|
|
|
1690 (setq lim (point))
|
|
|
1691 (goto-char (point-min))
|
|
|
1692 (vm-skip-past-folder-header)
|
|
|
1693 (vm-find-leading-message-separator)
|
|
|
1694 (vm-skip-past-leading-message-separator)
|
|
|
1695 (if (re-search-forward vm-bookmark-header-regexp lim t)
|
|
|
1696 (progn (goto-char (match-beginning 0))
|
|
|
1697 (if (vm-match-header vm-bookmark-header)
|
|
|
1698 (delete-region (vm-matched-header-start)
|
|
|
1699 (vm-matched-header-end)))))
|
|
|
1700 ;; To insert or to insert-before-markers, that is the question.
|
|
|
1701 ;;
|
|
|
1702 ;; If we insert-before-markers we push a header behind
|
|
|
1703 ;; vm-headers-of, which is clearly undesirable. So we
|
|
|
1704 ;; just insert. This will cause the bookmark header
|
|
|
1705 ;; to be visible if there are no non-visible headers,
|
|
|
1706 ;; oh well, no way around this.
|
|
|
1707 (insert vm-bookmark-header " "
|
|
|
1708 (vm-number-of (car vm-message-pointer))
|
|
|
1709 "\n")
|
|
|
1710 (set-buffer-modified-p old-buffer-modified-p))))))
|
|
|
1711
|
|
|
1712 ;; Insert the summary format variable header into the first message.
|
|
|
1713 (defun vm-stuff-summary ()
|
|
|
1714 (if vm-message-pointer
|
|
|
1715 (save-excursion
|
|
|
1716 (vm-save-restriction
|
|
|
1717 (widen)
|
|
|
1718 (let ((old-buffer-modified-p (buffer-modified-p))
|
|
|
1719 (case-fold-search t)
|
|
76
|
1720 ;; don't truncate the printing of large Lisp objects
|
|
|
1721 (print-length nil)
|
|
0
|
1722 ;; This prevents file locking from occuring. Disabling
|
|
|
1723 ;; locking can speed things noticeably if the lock
|
|
|
1724 ;; directory is on a slow device. We don't need locking
|
|
|
1725 ;; here because the user shouldn't care about VM stuffing
|
|
|
1726 ;; its own status headers.
|
|
|
1727 (buffer-file-name nil)
|
|
|
1728 (buffer-read-only nil)
|
|
|
1729 lim)
|
|
|
1730 (goto-char (point-min))
|
|
|
1731 (vm-skip-past-folder-header)
|
|
|
1732 (vm-find-leading-message-separator)
|
|
|
1733 (vm-skip-past-leading-message-separator)
|
|
|
1734 (search-forward "\n\n" nil t)
|
|
|
1735 (setq lim (point))
|
|
|
1736 (goto-char (point-min))
|
|
|
1737 (vm-skip-past-folder-header)
|
|
|
1738 (vm-find-leading-message-separator)
|
|
|
1739 (vm-skip-past-leading-message-separator)
|
|
|
1740 (while (re-search-forward vm-summary-header-regexp lim t)
|
|
|
1741 (progn (goto-char (match-beginning 0))
|
|
|
1742 (if (vm-match-header vm-summary-header)
|
|
|
1743 (delete-region (vm-matched-header-start)
|
|
|
1744 (vm-matched-header-end)))))
|
|
|
1745 ;; To insert or to insert-before-markers, that is the question.
|
|
|
1746 ;;
|
|
|
1747 ;; If we insert-before-markers we push a header behind
|
|
|
1748 ;; vm-headers-of, which is clearly undesirable. So we
|
|
|
1749 ;; just insert. This will cause the summary header
|
|
|
1750 ;; to be visible if there are no non-visible headers,
|
|
|
1751 ;; oh well, no way around this.
|
|
|
1752 (insert vm-summary-header " "
|
|
|
1753 (let ((print-escape-newlines t))
|
|
|
1754 (prin1-to-string vm-summary-format))
|
|
|
1755 "\n")
|
|
|
1756 (set-buffer-modified-p old-buffer-modified-p))))))
|
|
|
1757
|
|
|
1758 ;; stuff the current values of the header variables for future messages.
|
|
|
1759 (defun vm-stuff-header-variables ()
|
|
|
1760 (if vm-message-pointer
|
|
|
1761 (save-excursion
|
|
|
1762 (vm-save-restriction
|
|
|
1763 (widen)
|
|
|
1764 (let ((old-buffer-modified-p (buffer-modified-p))
|
|
|
1765 (case-fold-search t)
|
|
|
1766 (print-escape-newlines t)
|
|
|
1767 lim
|
|
76
|
1768 ;; don't truncate the printing of large Lisp objects
|
|
|
1769 (print-length nil)
|
|
0
|
1770 (buffer-read-only nil)
|
|
|
1771 ;; This prevents file locking from occuring. Disabling
|
|
|
1772 ;; locking can speed things noticeably if the lock
|
|
|
1773 ;; directory is on a slow device. We don't need locking
|
|
|
1774 ;; here because the user shouldn't care about VM stuffing
|
|
|
1775 ;; its own status headers.
|
|
|
1776 (buffer-file-name nil))
|
|
|
1777 (goto-char (point-min))
|
|
|
1778 (vm-skip-past-folder-header)
|
|
|
1779 (vm-find-leading-message-separator)
|
|
|
1780 (vm-skip-past-leading-message-separator)
|
|
|
1781 (search-forward "\n\n" nil t)
|
|
|
1782 (setq lim (point))
|
|
|
1783 (goto-char (point-min))
|
|
|
1784 (vm-skip-past-folder-header)
|
|
|
1785 (vm-find-leading-message-separator)
|
|
|
1786 (vm-skip-past-leading-message-separator)
|
|
|
1787 (while (re-search-forward vm-vheader-header-regexp lim t)
|
|
|
1788 (progn (goto-char (match-beginning 0))
|
|
|
1789 (if (vm-match-header vm-vheader-header)
|
|
|
1790 (delete-region (vm-matched-header-start)
|
|
|
1791 (vm-matched-header-end)))))
|
|
|
1792 ;; To insert or to insert-before-markers, that is the question.
|
|
|
1793 ;;
|
|
|
1794 ;; If we insert-before-markers we push a header behind
|
|
|
1795 ;; vm-headers-of, which is clearly undesirable. So we
|
|
|
1796 ;; just insert. This header will be visible if there
|
|
|
1797 ;; are no non-visible headers, oh well, no way around this.
|
|
|
1798 (insert vm-vheader-header " "
|
|
|
1799 (prin1-to-string vm-visible-headers) " "
|
|
|
1800 (prin1-to-string vm-invisible-header-regexp)
|
|
|
1801 "\n")
|
|
|
1802 (set-buffer-modified-p old-buffer-modified-p))))))
|
|
|
1803
|
|
|
1804 ;; Insert a header into the first message of the folder that lists
|
|
|
1805 ;; the folder's message order.
|
|
|
1806 (defun vm-stuff-message-order ()
|
|
|
1807 (if (cdr vm-message-list)
|
|
|
1808 (save-excursion
|
|
|
1809 (vm-save-restriction
|
|
|
1810 (widen)
|
|
|
1811 (let ((old-buffer-modified-p (buffer-modified-p))
|
|
|
1812 (case-fold-search t)
|
|
76
|
1813 ;; don't truncate the printing of large Lisp objects
|
|
|
1814 (print-length nil)
|
|
0
|
1815 ;; This prevents file locking from occuring. Disabling
|
|
|
1816 ;; locking can speed things noticeably if the lock
|
|
|
1817 ;; directory is on a slow device. We don't need locking
|
|
|
1818 ;; here because the user shouldn't care about VM stuffing
|
|
|
1819 ;; its own status headers.
|
|
|
1820 (buffer-file-name nil)
|
|
|
1821 lim n
|
|
|
1822 (buffer-read-only nil)
|
|
|
1823 (mp (copy-sequence vm-message-list)))
|
|
|
1824 (setq mp
|
|
|
1825 (sort mp
|
|
|
1826 (function
|
|
|
1827 (lambda (p q)
|
|
|
1828 (< (vm-start-of p) (vm-start-of q))))))
|
|
|
1829 (goto-char (point-min))
|
|
|
1830 (vm-skip-past-folder-header)
|
|
|
1831 (vm-find-leading-message-separator)
|
|
|
1832 (vm-skip-past-leading-message-separator)
|
|
|
1833 (search-forward "\n\n" nil t)
|
|
|
1834 (setq lim (point))
|
|
|
1835 (goto-char (point-min))
|
|
|
1836 (vm-skip-past-folder-header)
|
|
|
1837 (vm-find-leading-message-separator)
|
|
|
1838 (vm-skip-past-leading-message-separator)
|
|
|
1839 (while (re-search-forward vm-message-order-header-regexp lim t)
|
|
|
1840 (progn (goto-char (match-beginning 0))
|
|
|
1841 (if (vm-match-header vm-message-order-header)
|
|
|
1842 (delete-region (vm-matched-header-start)
|
|
|
1843 (vm-matched-header-end)))))
|
|
|
1844 ;; To insert or to insert-before-markers, that is the question.
|
|
|
1845 ;;
|
|
|
1846 ;; If we insert-before-markers we push a header behind
|
|
|
1847 ;; vm-headers-of, which is clearly undesirable. So we
|
|
|
1848 ;; just insert. This header will be visible if there
|
|
|
1849 ;; are no non-visible headers, oh well, no way around this.
|
|
|
1850 (insert vm-message-order-header "\n\t(")
|
|
|
1851 (setq n 0)
|
|
|
1852 (while mp
|
|
|
1853 (insert (vm-number-of (car mp)))
|
|
|
1854 (setq n (1+ n) mp (cdr mp))
|
|
|
1855 (and mp (insert
|
|
|
1856 (if (zerop (% n 15))
|
|
|
1857 "\n\t "
|
|
|
1858 " "))))
|
|
|
1859 (insert ")\n")
|
|
|
1860 (setq vm-message-order-changed nil
|
|
|
1861 vm-message-order-header-present t)
|
|
|
1862 (set-buffer-modified-p old-buffer-modified-p))))))
|
|
|
1863
|
|
|
1864 ;; Remove the message order header.
|
|
|
1865 (defun vm-remove-message-order ()
|
|
|
1866 (if (cdr vm-message-list)
|
|
|
1867 (save-excursion
|
|
|
1868 (vm-save-restriction
|
|
|
1869 (widen)
|
|
|
1870 (let ((old-buffer-modified-p (buffer-modified-p))
|
|
|
1871 (case-fold-search t)
|
|
|
1872 lim
|
|
|
1873 ;; This prevents file locking from occuring. Disabling
|
|
|
1874 ;; locking can speed things noticeably if the lock
|
|
|
1875 ;; directory is on a slow device. We don't need locking
|
|
|
1876 ;; here because the user shouldn't care about VM stuffing
|
|
|
1877 ;; its own status headers.
|
|
|
1878 (buffer-file-name nil)
|
|
|
1879 (buffer-read-only nil))
|
|
|
1880 (goto-char (point-min))
|
|
|
1881 (vm-skip-past-folder-header)
|
|
|
1882 (vm-skip-past-leading-message-separator)
|
|
|
1883 (search-forward "\n\n" nil t)
|
|
|
1884 (setq lim (point))
|
|
|
1885 (goto-char (point-min))
|
|
|
1886 (vm-skip-past-folder-header)
|
|
|
1887 (vm-skip-past-leading-message-separator)
|
|
|
1888 (while (re-search-forward vm-message-order-header-regexp lim t)
|
|
|
1889 (progn (goto-char (match-beginning 0))
|
|
|
1890 (if (vm-match-header vm-message-order-header)
|
|
|
1891 (delete-region (vm-matched-header-start)
|
|
|
1892 (vm-matched-header-end)))))
|
|
|
1893 (setq vm-message-order-header-present nil)
|
|
|
1894 (set-buffer-modified-p old-buffer-modified-p))))))
|
|
|
1895
|
|
|
1896 (defun vm-change-all-new-to-unread ()
|
|
|
1897 (let ((mp vm-message-list))
|
|
|
1898 (while mp
|
|
|
1899 (if (vm-new-flag (car mp))
|
|
|
1900 (progn
|
|
|
1901 (vm-set-new-flag (car mp) nil)
|
|
|
1902 (vm-set-unread-flag (car mp) t)))
|
|
|
1903 (setq mp (cdr mp)))))
|
|
|
1904
|
|
|
1905 (defun vm-unread-message (&optional count)
|
|
|
1906 "Set the `unread' attribute for the current message. If the message is
|
|
|
1907 already new or unread, then it is left unchanged.
|
|
|
1908
|
|
|
1909 Numeric prefix argument N means to unread the current message plus the
|
|
|
1910 next N-1 messages. A negative N means unread the current message and
|
|
|
1911 the previous N-1 messages.
|
|
|
1912
|
|
|
1913 When invoked on marked messages (via vm-next-command-uses-marks),
|
|
|
1914 all marked messages are affected, other messages are ignored."
|
|
|
1915 (interactive "p")
|
|
|
1916 (or count (setq count 1))
|
|
|
1917 (vm-follow-summary-cursor)
|
|
|
1918 (vm-select-folder-buffer)
|
|
|
1919 (vm-check-for-killed-summary)
|
|
|
1920 (vm-error-if-folder-empty)
|
|
|
1921 (let ((mlist (vm-select-marked-or-prefixed-messages count)))
|
|
|
1922 (while mlist
|
|
|
1923 (if (and (not (vm-unread-flag (car mlist)))
|
|
|
1924 (not (vm-new-flag (car mlist))))
|
|
|
1925 (vm-set-unread-flag (car mlist) t))
|
|
|
1926 (setq mlist (cdr mlist))))
|
|
|
1927 (vm-display nil nil '(vm-unread-message) '(vm-unread-message))
|
|
|
1928 (vm-update-summary-and-mode-line))
|
|
|
1929
|
|
|
1930 (defun vm-quit-just-bury ()
|
|
|
1931 "Bury the current VM folder and summary buffers.
|
|
|
1932 The folder is not altered and Emacs is still visiting it. You
|
|
|
1933 can switch back to it with switch-to-buffer or by using the
|
|
|
1934 Buffer Menu."
|
|
|
1935 (interactive)
|
|
|
1936 (vm-select-folder-buffer)
|
|
|
1937 (if (not (memq major-mode '(vm-mode vm-virtual-mode)))
|
|
|
1938 (error "%s must be invoked from a VM buffer." this-command))
|
|
|
1939 (vm-check-for-killed-summary)
|
|
|
1940
|
|
70
|
1941 (run-hooks 'vm-quit-hook)
|
|
0
|
1942
|
|
|
1943 (vm-display nil nil '(vm-quit-just-bury)
|
|
|
1944 '(vm-quit-just-bury quitting))
|
|
|
1945 (if vm-summary-buffer
|
|
|
1946 (vm-display vm-summary-buffer nil nil nil))
|
|
|
1947 (if vm-summary-buffer
|
|
|
1948 (vm-bury-buffer vm-summary-buffer))
|
|
|
1949 (vm-display (current-buffer) nil nil nil)
|
|
|
1950 (vm-bury-buffer (current-buffer)))
|
|
|
1951
|
|
|
1952 (defun vm-quit-just-iconify ()
|
|
|
1953 "Iconify the frame and bury the current VM folder and summary buffers.
|
|
|
1954 The folder is not altered and Emacs is still visiting it."
|
|
|
1955 (interactive)
|
|
|
1956 (vm-select-folder-buffer)
|
|
|
1957 (if (not (memq major-mode '(vm-mode vm-virtual-mode)))
|
|
|
1958 (error "%s must be invoked from a VM buffer." this-command))
|
|
|
1959 (vm-check-for-killed-summary)
|
|
|
1960
|
|
70
|
1961 (run-hooks 'vm-quit-hook)
|
|
0
|
1962
|
|
|
1963 (vm-display nil nil '(vm-quit-just-iconify)
|
|
|
1964 '(vm-quit-just-iconify quitting))
|
|
70
|
1965 (vm-bury-buffer (current-buffer))
|
|
|
1966 (if vm-summary-buffer
|
|
|
1967 (vm-bury-buffer vm-summary-buffer))
|
|
|
1968 (vm-iconify-frame))
|
|
0
|
1969
|
|
|
1970 (defun vm-quit-no-change ()
|
|
76
|
1971 "Quit visiting the current folder without saving changes made to the folder."
|
|
0
|
1972 (interactive)
|
|
|
1973 (vm-quit t))
|
|
|
1974
|
|
|
1975 (defun vm-quit (&optional no-change)
|
|
76
|
1976 "Quit visiting the current folder, saving changes. Deleted messages are not expunged."
|
|
0
|
1977 (interactive)
|
|
|
1978 (vm-select-folder-buffer)
|
|
|
1979 (if (not (memq major-mode '(vm-mode vm-virtual-mode)))
|
|
|
1980 (error "%s must be invoked from a VM buffer." this-command))
|
|
|
1981 (vm-check-for-killed-summary)
|
|
|
1982 (vm-display nil nil '(vm-quit vm-quit-no-change)
|
|
|
1983 (list this-command 'quitting))
|
|
|
1984 (let ((virtual (eq major-mode 'vm-virtual-mode)))
|
|
|
1985 (cond
|
|
|
1986 ((and (not virtual) no-change (buffer-modified-p)
|
|
|
1987 (not (zerop vm-messages-not-on-disk))
|
|
|
1988 ;; 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
|
|
|
1990 ;; would not have been zeroed. However, all modification flag
|
|
|
1991 ;; undos are cleared if VM actually modifies the folder buffer
|
|
|
1992 ;; (as opposed to the folder's attributes), so this can be used
|
|
|
1993 ;; to verify that there are indeed unsaved messages.
|
|
|
1994 (null (assq 'vm-set-buffer-modified-p vm-undo-record-list))
|
|
|
1995 (not
|
|
|
1996 (y-or-n-p
|
|
|
1997 (format
|
|
|
1998 "%d message%s have not been saved to disk, quit anyway? "
|
|
|
1999 vm-messages-not-on-disk
|
|
|
2000 (if (= 1 vm-messages-not-on-disk) "" "s")))))
|
|
|
2001 (error "Aborted"))
|
|
|
2002 ((and (not virtual)
|
|
70
|
2003 no-change (buffer-modified-p) vm-confirm-quit
|
|
0
|
2004 (not (y-or-n-p "There are unsaved changes, quit anyway? ")))
|
|
|
2005 (error "Aborted"))
|
|
|
2006 ((and (eq vm-confirm-quit t)
|
|
|
2007 (not (y-or-n-p "Do you really want to quit? ")))
|
|
|
2008 (error "Aborted")))
|
|
|
2009
|
|
70
|
2010 (run-hooks 'vm-quit-hook)
|
|
0
|
2011
|
|
|
2012 (vm-virtual-quit)
|
|
|
2013 (if (and (not no-change) (not virtual))
|
|
|
2014 (progn
|
|
|
2015 ;; this could take a while, so give the user some feedback
|
|
70
|
2016 (vm-unsaved-message "Quitting...")
|
|
0
|
2017 (or vm-folder-read-only (eq major-mode 'vm-virtual-mode)
|
|
|
2018 (vm-change-all-new-to-unread))))
|
|
70
|
2019 (if (and (buffer-modified-p) (not no-change) (not virtual))
|
|
0
|
2020 (vm-save-folder))
|
|
70
|
2021 (vm-unsaved-message "")
|
|
0
|
2022 (let ((summary-buffer vm-summary-buffer)
|
|
|
2023 (mail-buffer (current-buffer)))
|
|
|
2024 (if summary-buffer
|
|
|
2025 (progn
|
|
70
|
2026 (vm-display vm-summary-buffer nil nil nil)
|
|
0
|
2027 (kill-buffer summary-buffer)))
|
|
|
2028 (set-buffer mail-buffer)
|
|
|
2029 (vm-display mail-buffer nil nil nil)
|
|
|
2030 ;; vm-display is not supposed to change the current buffer.
|
|
70
|
2031 ;; still better to be safe here.
|
|
0
|
2032 (set-buffer mail-buffer)
|
|
|
2033 (set-buffer-modified-p nil)
|
|
|
2034 (kill-buffer (current-buffer)))
|
|
|
2035 (vm-update-summary-and-mode-line)))
|
|
|
2036
|
|
|
2037 (defun vm-start-itimers-if-needed ()
|
|
70
|
2038 (if (or (natnump vm-flush-interval)
|
|
|
2039 (natnump vm-auto-get-new-mail))
|
|
|
2040 (progn
|
|
|
2041 (if (null
|
|
|
2042 (condition-case data
|
|
|
2043 (progn (require 'itimer) t)
|
|
|
2044 (error nil)))
|
|
|
2045 (setq vm-flush-interval t
|
|
|
2046 vm-auto-get-new-mail t)
|
|
|
2047 (and (natnump vm-flush-interval) (not (get-itimer "vm-flush"))
|
|
|
2048 (start-itimer "vm-flush" 'vm-flush-itimer-function
|
|
|
2049 vm-flush-interval nil))
|
|
|
2050 (and (natnump vm-auto-get-new-mail) (not (get-itimer "vm-get-mail"))
|
|
|
2051 (start-itimer "vm-get-mail" 'vm-get-mail-itimer-function
|
|
|
2052 vm-auto-get-new-mail nil))))))
|
|
0
|
2053
|
|
70
|
2054 ;; support for numeric vm-auto-get-new-mail
|
|
|
2055 (defun vm-get-mail-itimer-function ()
|
|
|
2056 (if (integerp vm-auto-get-new-mail)
|
|
|
2057 (set-itimer-restart current-itimer vm-auto-get-new-mail))
|
|
|
2058 (let ((b-list (buffer-list)))
|
|
24
|
2059 (while (and (not (input-pending-p)) b-list)
|
|
|
2060 (save-excursion
|
|
|
2061 (set-buffer (car b-list))
|
|
|
2062 (if (and (eq major-mode 'vm-mode)
|
|
0
|
2063 (not (and (not (buffer-modified-p))
|
|
|
2064 buffer-file-name
|
|
|
2065 (file-newer-than-file-p
|
|
|
2066 (make-auto-save-file-name)
|
|
|
2067 buffer-file-name)))
|
|
|
2068 (not vm-block-new-mail)
|
|
|
2069 (not vm-folder-read-only)
|
|
70
|
2070 (vm-get-spooled-mail)
|
|
0
|
2071 (vm-assimilate-new-messages t))
|
|
|
2072 (progn
|
|
|
2073 ;; don't move the message pointer unless the folder
|
|
|
2074 ;; was empty.
|
|
|
2075 (if (and (null vm-message-pointer)
|
|
|
2076 (vm-thoughtfully-select-message))
|
|
|
2077 (vm-preview-current-message)
|
|
|
2078 (vm-update-summary-and-mode-line)))))
|
|
70
|
2079 (setq b-list (cdr b-list)))))
|
|
0
|
2080
|
|
|
2081 ;; support for numeric vm-flush-interval
|
|
70
|
2082 (defun vm-flush-itimer-function ()
|
|
0
|
2083 (if (integerp vm-flush-interval)
|
|
70
|
2084 (set-itimer-restart current-itimer vm-flush-interval))
|
|
0
|
2085 ;; if no vm-mode buffers are found, we might as well shut down the
|
|
|
2086 ;; flush itimer.
|
|
|
2087 (if (not (vm-flush-cached-data))
|
|
70
|
2088 (set-itimer-restart current-itimer nil)))
|
|
0
|
2089
|
|
|
2090 ;; flush cached data in all vm-mode buffers.
|
|
|
2091 ;; returns non-nil if any vm-mode buffers were found.
|
|
|
2092 (defun vm-flush-cached-data ()
|
|
|
2093 (save-excursion
|
|
|
2094 (let ((buf-list (buffer-list))
|
|
|
2095 (found-one nil))
|
|
|
2096 (while (and buf-list (not (input-pending-p)))
|
|
|
2097 (set-buffer (car buf-list))
|
|
|
2098 (cond ((and (eq major-mode 'vm-mode) vm-message-list)
|
|
|
2099 (setq found-one t)
|
|
|
2100 (if (not (eq vm-modification-counter
|
|
|
2101 vm-flushed-modification-counter))
|
|
70
|
2102 (let ((mp vm-message-list))
|
|
0
|
2103 (vm-stuff-summary)
|
|
|
2104 (vm-stuff-labels)
|
|
|
2105 (and vm-message-order-changed
|
|
|
2106 (vm-stuff-message-order))
|
|
70
|
2107 (while (and mp (not (input-pending-p)))
|
|
|
2108 (if (vm-modflag-of (car mp))
|
|
|
2109 (vm-stuff-attributes (car mp)))
|
|
|
2110 (setq mp (cdr mp)))
|
|
|
2111 (and (null mp)
|
|
0
|
2112 (setq vm-flushed-modification-counter
|
|
|
2113 vm-modification-counter))))))
|
|
|
2114 (setq buf-list (cdr buf-list)))
|
|
|
2115 ;; if we haven't checked them all return non-nil so
|
|
|
2116 ;; the flusher won't give up trying.
|
|
|
2117 (or buf-list found-one) )))
|
|
|
2118
|
|
|
2119 ;; This allows C-x C-s to do the right thing for VM mail buffers.
|
|
|
2120 ;; Note that deleted messages are not expunged.
|
|
|
2121 (defun vm-write-file-hook ()
|
|
|
2122 (if (and (eq major-mode 'vm-mode) (not vm-inhibit-write-file-hook))
|
|
|
2123 ;; The vm-save-restriction isn't really necessary here, since
|
|
|
2124 ;; the stuff routines clean up after themselves, but should remain
|
|
|
2125 ;; as a safeguard against the time when other stuff is added here.
|
|
|
2126 (vm-save-restriction
|
|
70
|
2127 (let ((mp vm-message-list)
|
|
|
2128 (buffer-read-only))
|
|
|
2129 (while mp
|
|
|
2130 (if (vm-modflag-of (car mp))
|
|
|
2131 (vm-stuff-attributes (car mp)))
|
|
|
2132 (setq mp (cdr mp)))
|
|
|
2133 (if vm-message-list
|
|
|
2134 (progn
|
|
|
2135 ;; get summary cache up-to-date
|
|
|
2136 (vm-update-summary-and-mode-line)
|
|
|
2137 (vm-stuff-bookmark)
|
|
|
2138 (vm-stuff-header-variables)
|
|
|
2139 (vm-stuff-labels)
|
|
|
2140 (vm-stuff-summary)
|
|
|
2141 (and vm-message-order-changed
|
|
|
2142 (vm-stuff-message-order))))
|
|
|
2143 nil ))))
|
|
0
|
2144
|
|
|
2145 (defun vm-save-buffer (prefix)
|
|
|
2146 (interactive "P")
|
|
|
2147 (vm-select-folder-buffer)
|
|
|
2148 (vm-error-if-virtual-folder)
|
|
|
2149 (save-buffer prefix)
|
|
|
2150 (intern (buffer-name) vm-buffers-needing-display-update)
|
|
|
2151 (setq vm-block-new-mail nil)
|
|
|
2152 (vm-display nil nil '(vm-save-buffer) '(vm-save-buffer))
|
|
|
2153 (vm-update-summary-and-mode-line))
|
|
|
2154
|
|
|
2155 (defun vm-write-file ()
|
|
|
2156 (interactive)
|
|
|
2157 (vm-select-folder-buffer)
|
|
|
2158 (vm-error-if-virtual-folder)
|
|
|
2159 (call-interactively 'write-file)
|
|
|
2160 (intern (buffer-name) vm-buffers-needing-display-update)
|
|
|
2161 (setq vm-block-new-mail nil)
|
|
|
2162 (vm-display nil nil '(vm-write-file) '(vm-write-file))
|
|
|
2163 (vm-update-summary-and-mode-line))
|
|
|
2164
|
|
|
2165 (defun vm-save-folder (&optional prefix)
|
|
|
2166 "Save current folder to disk.
|
|
|
2167 Deleted messages are not expunged.
|
|
|
2168 Prefix arg is handled the same as for the command save-buffer.
|
|
|
2169
|
|
|
2170 When applied to a virtual folder, this command runs itself on
|
|
|
2171 each of the underlying real folders associated with the virtual
|
|
|
2172 folder."
|
|
|
2173 (interactive (list current-prefix-arg))
|
|
|
2174 (vm-select-folder-buffer)
|
|
|
2175 (vm-check-for-killed-summary)
|
|
|
2176 (vm-display nil nil '(vm-save-folder) '(vm-save-folder))
|
|
|
2177 (if (eq major-mode 'vm-virtual-mode)
|
|
|
2178 (vm-virtual-save-folder prefix)
|
|
|
2179 (if (buffer-modified-p)
|
|
70
|
2180 (let (mp)
|
|
0
|
2181 ;; stuff the attributes of messages that need it.
|
|
70
|
2182 (vm-unsaved-message "Stuffing attributes...")
|
|
|
2183 (setq mp vm-message-list)
|
|
|
2184 (while mp
|
|
|
2185 (if (vm-modflag-of (car mp))
|
|
|
2186 (vm-stuff-attributes (car mp)))
|
|
|
2187 (setq mp (cdr mp)))
|
|
0
|
2188 ;; stuff bookmark and header variable values
|
|
|
2189 (if vm-message-list
|
|
|
2190 (progn
|
|
|
2191 ;; get summary cache up-to-date
|
|
|
2192 (vm-update-summary-and-mode-line)
|
|
|
2193 (vm-stuff-bookmark)
|
|
|
2194 (vm-stuff-header-variables)
|
|
|
2195 (vm-stuff-labels)
|
|
|
2196 (vm-stuff-summary)
|
|
|
2197 (and vm-message-order-changed
|
|
|
2198 (vm-stuff-message-order))))
|
|
70
|
2199 (vm-unsaved-message "Saving...")
|
|
0
|
2200 (let ((vm-inhibit-write-file-hook t))
|
|
|
2201 (save-buffer prefix))
|
|
|
2202 (vm-set-buffer-modified-p nil)
|
|
|
2203 (vm-clear-modification-flag-undos)
|
|
|
2204 (setq vm-messages-not-on-disk 0)
|
|
|
2205 (setq vm-block-new-mail nil)
|
|
|
2206 (and (zerop (buffer-size))
|
|
|
2207 vm-delete-empty-folders
|
|
|
2208 buffer-file-name
|
|
|
2209 (or (eq vm-delete-empty-folders t)
|
|
|
2210 (y-or-n-p (format "%s is empty, remove it? "
|
|
|
2211 (or buffer-file-name (buffer-name)))))
|
|
|
2212 (condition-case ()
|
|
|
2213 (progn
|
|
|
2214 (delete-file buffer-file-name)
|
|
|
2215 (message "%s removed" buffer-file-name))
|
|
|
2216 ;; no can do, oh well.
|
|
|
2217 (error nil)))
|
|
|
2218 (vm-update-summary-and-mode-line))
|
|
|
2219 (message "No changes need to be saved"))))
|
|
|
2220
|
|
|
2221 (defun vm-save-and-expunge-folder (&optional prefix)
|
|
|
2222 "Expunge folder, then save it to disk.
|
|
|
2223 Prefix arg is handled the same as for the command save-buffer.
|
|
|
2224 Expunge won't be done if folder is read-only.
|
|
|
2225
|
|
|
2226 When applied to a virtual folder, this command works as if you had
|
|
|
2227 run vm-expunge-folder followed by vm-save-folder."
|
|
|
2228 (interactive (list current-prefix-arg))
|
|
|
2229 (vm-select-folder-buffer)
|
|
|
2230 (vm-check-for-killed-summary)
|
|
|
2231 (vm-display nil nil '(vm-save-and-expunge-folder)
|
|
|
2232 '(vm-save-and-expunge-folder))
|
|
|
2233 (if (not vm-folder-read-only)
|
|
|
2234 (progn
|
|
70
|
2235 (vm-unsaved-message "Expunging...")
|
|
0
|
2236 (vm-expunge-folder t)))
|
|
|
2237 (vm-save-folder prefix))
|
|
|
2238
|
|
|
2239 (defun vm-handle-file-recovery-or-reversion (recovery)
|
|
|
2240 (if (and vm-summary-buffer (buffer-name vm-summary-buffer))
|
|
|
2241 (kill-buffer vm-summary-buffer))
|
|
|
2242 (vm-virtual-quit)
|
|
|
2243 ;; reset major mode, this will cause vm to start from scratch.
|
|
|
2244 (setq major-mode 'fundamental-mode)
|
|
|
2245 ;; If this is a recovery, we can't allow the user to get new
|
|
|
2246 ;; mail until a real save is performed. Until then the buffer
|
|
|
2247 ;; and the disk don't match.
|
|
|
2248 (if recovery
|
|
|
2249 (setq vm-block-new-mail t))
|
|
|
2250 (vm buffer-file-name))
|
|
|
2251
|
|
|
2252 ;; detect if a recover-file is being performed
|
|
|
2253 ;; and handle things properly.
|
|
|
2254 (defun vm-handle-file-recovery ()
|
|
|
2255 (if (and (buffer-modified-p)
|
|
|
2256 (eq major-mode 'vm-mode)
|
|
|
2257 vm-message-list
|
|
|
2258 (= (vm-end-of (car vm-message-list)) 1))
|
|
|
2259 (vm-handle-file-recovery-or-reversion t)))
|
|
|
2260
|
|
|
2261 ;; detect if a revert-buffer is being performed
|
|
|
2262 ;; and handle things properly.
|
|
|
2263 (defun vm-handle-file-reversion ()
|
|
|
2264 (if (and (not (buffer-modified-p))
|
|
|
2265 (eq major-mode 'vm-mode)
|
|
|
2266 vm-message-list
|
|
|
2267 (= (vm-end-of (car vm-message-list)) 1))
|
|
|
2268 (vm-handle-file-recovery-or-reversion nil)))
|
|
|
2269
|
|
|
2270 ;; FSF v19.23 revert-buffer doesn't mash all the markers together
|
|
|
2271 ;; like v18 and prior v19 versions, so the check in
|
|
|
2272 ;; vm-handle-file-reversion doesn't work. However v19.23 has a
|
|
|
2273 ;; hook we can use, after-revert-hook.
|
|
|
2274 (defun vm-after-revert-buffer-hook ()
|
|
|
2275 (if (eq major-mode 'vm-mode)
|
|
|
2276 (vm-handle-file-recovery-or-reversion nil)))
|
|
|
2277
|
|
|
2278 (defun vm-help ()
|
|
|
2279 "Display help for various VM activities."
|
|
|
2280 (interactive)
|
|
|
2281 (if (eq major-mode 'vm-summary-mode)
|
|
|
2282 (vm-select-folder-buffer))
|
|
|
2283 (let ((pop-up-windows (and pop-up-windows (eq vm-mutable-windows t)))
|
|
70
|
2284 (pop-up-frames vm-mutable-frames))
|
|
0
|
2285 (cond
|
|
|
2286 ((eq last-command 'vm-help)
|
|
|
2287 (describe-function major-mode))
|
|
|
2288 ((eq vm-system-state 'previewing)
|
|
|
2289 (message "Type SPC to read message, n previews next message (? gives more help)"))
|
|
|
2290 ((memq vm-system-state '(showing reading))
|
|
|
2291 (message "SPC and b scroll, (d)elete, (s)ave, (n)ext, (r)eply (? gives more help)"))
|
|
|
2292 ((eq vm-system-state 'editing)
|
|
|
2293 (message
|
|
|
2294 (substitute-command-keys
|
|
|
2295 "Type \\[vm-edit-message-end] to end edit, \\[vm-edit-message-abort] to abort with no change.")))
|
|
|
2296 ((eq major-mode 'mail-mode)
|
|
|
2297 (message
|
|
|
2298 (substitute-command-keys
|
|
70
|
2299 "Type \\[vm-mail-send-and-exit] to send message, \\[kill-buffer] to discard this message")))
|
|
0
|
2300 (t (describe-mode)))))
|
|
|
2301
|
|
|
2302 (defun vm-spool-move-mail (source destination)
|
|
|
2303 (let ((handler (and (fboundp 'find-file-name-handler)
|
|
|
2304 (condition-case ()
|
|
|
2305 (find-file-name-handler source 'vm-spool-move-mail)
|
|
|
2306 (wrong-number-of-arguments
|
|
|
2307 (find-file-name-handler source)))))
|
|
|
2308 status error-buffer)
|
|
|
2309 (if handler
|
|
|
2310 (funcall handler 'vm-spool-move-mail source destination)
|
|
|
2311 (setq error-buffer
|
|
|
2312 (get-buffer-create
|
|
|
2313 (format "*output of %s %s %s*"
|
|
|
2314 vm-movemail-program source destination)))
|
|
|
2315 (save-excursion
|
|
|
2316 (set-buffer error-buffer)
|
|
|
2317 (erase-buffer))
|
|
|
2318 (setq status
|
|
|
2319 (call-process vm-movemail-program nil error-buffer t
|
|
|
2320 source destination))
|
|
|
2321 (save-excursion
|
|
|
2322 (set-buffer error-buffer)
|
|
|
2323 (if (and (numberp status) (not (= 0 status)))
|
|
|
2324 (insert (format "\n%s exited with code %s\n"
|
|
|
2325 vm-movemail-program status)))
|
|
|
2326 (if (> (buffer-size) 0)
|
|
|
2327 (progn
|
|
|
2328 (vm-display-buffer error-buffer)
|
|
|
2329 (if (and (numberp status) (not (= 0 status)))
|
|
|
2330 (error "Failed getting new mail from %s" source)
|
|
|
2331 (message "Warning: unexpected output from %s"
|
|
|
2332 vm-movemail-program)
|
|
|
2333 (sleep-for 2)))
|
|
|
2334 ;; nag, nag, nag.
|
|
|
2335 (kill-buffer error-buffer))
|
|
|
2336 t ))))
|
|
|
2337
|
|
|
2338 (defun vm-gobble-crash-box (crash-box)
|
|
|
2339 (save-excursion
|
|
|
2340 (vm-save-restriction
|
|
|
2341 (widen)
|
|
|
2342 (let ((opoint-max (point-max)) crash-buf
|
|
|
2343 (buffer-read-only nil)
|
|
|
2344 (inbox-buffer-file buffer-file-name)
|
|
|
2345 (inbox-folder-type vm-folder-type)
|
|
|
2346 (inbox-empty (zerop (buffer-size)))
|
|
|
2347 got-mail crash-folder-type
|
|
|
2348 (old-buffer-modified-p (buffer-modified-p)))
|
|
|
2349 (setq crash-buf
|
|
|
2350 ;; crash box could contain a letter bomb...
|
|
|
2351 ;; force user notification of file variables for v18 Emacses
|
|
|
2352 ;; enable-local-variables == nil disables them for newer Emacses
|
|
|
2353 (let ((inhibit-local-variables t)
|
|
70
|
2354 (enable-local-variables nil))
|
|
0
|
2355 (find-file-noselect crash-box)))
|
|
|
2356 (save-excursion
|
|
|
2357 (set-buffer crash-buf)
|
|
|
2358 (setq crash-folder-type (vm-get-folder-type))
|
|
|
2359 (if (and crash-folder-type vm-check-folder-types)
|
|
|
2360 (cond ((eq crash-folder-type 'unknown)
|
|
|
2361 (error "crash box %s's type is unrecognized" crash-box))
|
|
|
2362 ((eq inbox-folder-type 'unknown)
|
|
|
2363 (error "inbox %s's type is unrecognized"
|
|
|
2364 inbox-buffer-file))
|
|
|
2365 ((null inbox-folder-type)
|
|
|
2366 (if vm-default-folder-type
|
|
|
2367 (if (not (eq vm-default-folder-type
|
|
|
2368 crash-folder-type))
|
|
|
2369 (if vm-convert-folder-types
|
|
|
2370 (progn
|
|
|
2371 (vm-convert-folder-type
|
|
|
2372 crash-folder-type
|
|
|
2373 vm-default-folder-type)
|
|
|
2374 ;; so that kill-buffer won't ask a
|
|
|
2375 ;; question later...
|
|
|
2376 (set-buffer-modified-p nil))
|
|
|
2377 (error "crash box %s mismatches vm-default-folder-type: %s, %s"
|
|
|
2378 crash-box crash-folder-type
|
|
|
2379 vm-default-folder-type)))))
|
|
|
2380 ((not (eq inbox-folder-type crash-folder-type))
|
|
|
2381 (if vm-convert-folder-types
|
|
|
2382 (progn
|
|
|
2383 (vm-convert-folder-type crash-folder-type
|
|
|
2384 inbox-folder-type)
|
|
|
2385 ;; so that kill-buffer won't ask a
|
|
|
2386 ;; question later...
|
|
|
2387 (set-buffer-modified-p nil))
|
|
|
2388 (error "crash box %s mismatches %s's folder type: %s, %s"
|
|
|
2389 crash-box inbox-buffer-file
|
|
|
2390 crash-folder-type inbox-folder-type)))))
|
|
|
2391 ;; toss the folder header if the inbox is not empty
|
|
|
2392 (goto-char (point-min))
|
|
|
2393 (if (not inbox-empty)
|
|
|
2394 (progn
|
|
|
2395 (vm-convert-folder-header (or inbox-folder-type
|
|
|
2396 vm-default-folder-type)
|
|
|
2397 nil)
|
|
|
2398 (set-buffer-modified-p nil))))
|
|
|
2399 (goto-char (point-max))
|
|
|
2400 (insert-buffer-substring crash-buf
|
|
|
2401 1 (1+ (save-excursion
|
|
|
2402 (set-buffer crash-buf)
|
|
|
2403 (widen)
|
|
|
2404 (buffer-size))))
|
|
70
|
2405 (write-region opoint-max (point-max) buffer-file-name t t)
|
|
|
2406 (vm-increment vm-modification-counter)
|
|
0
|
2407 (setq got-mail (/= opoint-max (point-max)))
|
|
70
|
2408 (set-buffer-modified-p old-buffer-modified-p)
|
|
42
|
2409 (kill-buffer crash-buf)
|
|
|
2410 (if (not (stringp vm-keep-crash-boxes))
|
|
|
2411 (vm-error-free-call 'delete-file crash-box)
|
|
70
|
2412 (rename-file crash-box
|
|
|
2413 (concat (expand-file-name vm-keep-crash-boxes)
|
|
|
2414 (if (not
|
|
|
2415 (= (aref vm-keep-crash-boxes
|
|
|
2416 (1- (length vm-keep-crash-boxes)))
|
|
|
2417 ?/))
|
|
|
2418 "/"
|
|
|
2419 "")
|
|
|
2420 "Z"
|
|
|
2421 (substring
|
|
|
2422 (timezone-make-date-sortable
|
|
|
2423 (current-time-string))
|
|
|
2424 4)))
|
|
|
2425 ;; guarantee that each new saved crashbox will have a
|
|
|
2426 ;; different name, assuming time doesn't reverse.
|
|
|
2427 (sleep-for 1))
|
|
0
|
2428 got-mail ))))
|
|
|
2429
|
|
70
|
2430 (defun vm-get-spooled-mail ()
|
|
|
2431 (if vm-block-new-mail
|
|
|
2432 (error "Can't get new mail until you save this folder."))
|
|
|
2433 (let ((triples nil)
|
|
|
2434 ;; since we could accept-process-output here (POP code),
|
|
|
2435 ;; a timer process might try to start retrieving mail
|
|
|
2436 ;; before we finish. block these attempts.
|
|
|
2437 (vm-block-new-mail t)
|
|
|
2438 crash in maildrop popdrop
|
|
|
2439 (got-mail nil))
|
|
0
|
2440 (cond ((null (vm-spool-files))
|
|
|
2441 (setq triples (list
|
|
|
2442 (list vm-primary-inbox
|
|
|
2443 (concat vm-spool-directory (user-login-name))
|
|
|
2444 vm-crash-box))))
|
|
|
2445 ((stringp (car (vm-spool-files)))
|
|
|
2446 (setq triples
|
|
|
2447 (mapcar (function
|
|
|
2448 (lambda (s) (list vm-primary-inbox s vm-crash-box)))
|
|
|
2449 (vm-spool-files))))
|
|
|
2450 ((consp (car (vm-spool-files)))
|
|
|
2451 (setq triples (vm-spool-files))))
|
|
70
|
2452 (while triples
|
|
|
2453 (setq in (expand-file-name (nth 0 (car triples)) vm-folder-directory)
|
|
|
2454 maildrop (nth 1 (car triples))
|
|
|
2455 crash (nth 2 (car triples)))
|
|
|
2456 (if (eq (current-buffer) (vm-get-file-buffer in))
|
|
|
2457 (progn
|
|
|
2458 (if (file-exists-p crash)
|
|
|
2459 (progn
|
|
|
2460 (message "Recovering messages from %s..." crash)
|
|
|
2461 (setq got-mail (or (vm-gobble-crash-box crash) got-mail))
|
|
|
2462 (message "Recovering messages from %s... done" crash)))
|
|
|
2463 (setq popdrop (and vm-recognize-pop-maildrops
|
|
|
2464 (string-match vm-recognize-pop-maildrops
|
|
|
2465 maildrop)
|
|
|
2466 ;; maildrop with password clipped
|
|
|
2467 (vm-safe-popdrop-string maildrop)))
|
|
|
2468 (if (or popdrop
|
|
|
2469 (and (not (equal 0 (nth 7 (file-attributes maildrop))))
|
|
|
2470 (file-readable-p maildrop)))
|
|
|
2471 (progn
|
|
|
2472 (setq crash (expand-file-name crash vm-folder-directory))
|
|
|
2473 (if (not popdrop)
|
|
|
2474 (setq maildrop (expand-file-name maildrop)))
|
|
|
2475 (if (if popdrop
|
|
|
2476 (vm-pop-move-mail maildrop crash)
|
|
|
2477 (vm-spool-move-mail maildrop crash))
|
|
|
2478 (if (vm-gobble-crash-box crash)
|
|
|
2479 (progn
|
|
|
2480 (setq got-mail t)
|
|
|
2481 (message "Got mail from %s."
|
|
|
2482 (or popdrop maildrop)))))))))
|
|
|
2483 (setq triples (cdr triples)))
|
|
|
2484 (if got-mail
|
|
|
2485 (run-hooks 'vm-retrieved-spooled-mail-hook))
|
|
|
2486 got-mail ))
|
|
0
|
2487
|
|
|
2488 (defun vm-safe-popdrop-string (drop)
|
|
|
2489 (or (and (string-match "^\\([^:]+\\):[^:]+:[^:]+:\\([^:]+\\):[^:]+" drop)
|
|
|
2490 (concat (substring drop (match-beginning 2) (match-end 2))
|
|
|
2491 "@"
|
|
|
2492 (substring drop (match-beginning 1) (match-end 1))))
|
|
|
2493 "???"))
|
|
|
2494
|
|
|
2495 (defun vm-get-new-mail (&optional arg)
|
|
|
2496 "Move any new mail that has arrived in any of the spool files for the
|
|
|
2497 current folder into the folder. New mail is appended to the disk
|
|
|
2498 and buffer copies of the folder.
|
|
|
2499
|
|
|
2500 Prefix arg means to gather mail from a user specified folder, instead of
|
|
|
2501 the usual spool files. The file name will be read from the minibuffer.
|
|
|
2502 Unlike when getting mail from a spool file, the source file is left
|
|
|
2503 undisturbed after its messages have been copied.
|
|
|
2504
|
|
|
2505 When applied to a virtual folder, this command runs itself on
|
|
|
2506 each of the underlying real folders associated with this virtual folder.
|
|
|
2507 A prefix argument has no effect; mail is always gathered from the
|
|
|
2508 spool files."
|
|
|
2509 (interactive "P")
|
|
|
2510 (vm-select-folder-buffer)
|
|
|
2511 (vm-check-for-killed-summary)
|
|
|
2512 (vm-error-if-folder-read-only)
|
|
|
2513 (cond ((eq major-mode 'vm-virtual-mode)
|
|
|
2514 (vm-virtual-get-new-mail))
|
|
|
2515 ((null arg)
|
|
|
2516 (if (not (eq major-mode 'vm-mode))
|
|
|
2517 (vm-mode))
|
|
|
2518 (if (consp (car (vm-spool-files)))
|
|
70
|
2519 (vm-unsaved-message "Checking for new mail for %s..."
|
|
0
|
2520 (or buffer-file-name (buffer-name)))
|
|
70
|
2521 (vm-unsaved-message "Checking for new mail..."))
|
|
0
|
2522 (let (totals-blurb)
|
|
70
|
2523 (if (and (vm-get-spooled-mail) (vm-assimilate-new-messages t))
|
|
0
|
2524 (progn
|
|
|
2525 ;; say this NOW, before the non-previewers read
|
|
|
2526 ;; a message, alter the new message count and
|
|
|
2527 ;; confuse themselves.
|
|
|
2528 (setq totals-blurb (vm-emit-totals-blurb))
|
|
|
2529 (vm-display nil nil '(vm-get-new-mail) '(vm-get-new-mail))
|
|
|
2530 (if (vm-thoughtfully-select-message)
|
|
|
2531 (vm-preview-current-message)
|
|
|
2532 (vm-update-summary-and-mode-line))
|
|
|
2533 (message totals-blurb))
|
|
|
2534 (if (consp (car (vm-spool-files)))
|
|
|
2535 (message "No new mail for %s"
|
|
|
2536 (or buffer-file-name (buffer-name)))
|
|
|
2537 (message "No new mail."))
|
|
70
|
2538 (and (interactive-p) (sit-for 4) (vm-unsaved-message "")))))
|
|
0
|
2539 (t
|
|
|
2540 (let ((buffer-read-only nil)
|
|
|
2541 folder mcount totals-blurb)
|
|
|
2542 (setq folder (read-file-name "Gather mail from folder: "
|
|
|
2543 vm-folder-directory t))
|
|
|
2544 (if (and vm-check-folder-types
|
|
|
2545 (not (vm-compatible-folder-p folder)))
|
|
|
2546 (error "Folder %s is not the same format as this folder."
|
|
|
2547 folder))
|
|
|
2548 (save-excursion
|
|
|
2549 (vm-save-restriction
|
|
|
2550 (widen)
|
|
|
2551 (goto-char (point-max))
|
|
70
|
2552 (insert-file-contents folder)))
|
|
0
|
2553 (setq mcount (length vm-message-list))
|
|
|
2554 (if (vm-assimilate-new-messages)
|
|
|
2555 (progn
|
|
|
2556 ;; say this NOW, before the non-previewers read
|
|
|
2557 ;; a message, alter the new message count and
|
|
|
2558 ;; confuse themselves.
|
|
|
2559 (setq totals-blurb (vm-emit-totals-blurb))
|
|
|
2560 (vm-display nil nil '(vm-get-new-mail) '(vm-get-new-mail))
|
|
|
2561 (if (vm-thoughtfully-select-message)
|
|
|
2562 (vm-preview-current-message)
|
|
|
2563 (vm-update-summary-and-mode-line))
|
|
|
2564 (message totals-blurb)
|
|
|
2565 ;; The gathered messages are actually still on disk
|
|
|
2566 ;; unless the user deletes the folder himself.
|
|
|
2567 ;; However, users may not understand what happened if
|
|
|
2568 ;; the messages go away after a "quit, no save".
|
|
|
2569 (setq vm-messages-not-on-disk
|
|
|
2570 (+ vm-messages-not-on-disk
|
|
|
2571 (- (length vm-message-list)
|
|
|
2572 mcount))))
|
|
|
2573 (message "No messages gathered."))))))
|
|
|
2574
|
|
|
2575 ;; returns non-nil if there were any new messages
|
|
70
|
2576 (defun vm-assimilate-new-messages (&optional dont-read-attributes gobble-order)
|
|
0
|
2577 (let ((tail-cons (vm-last vm-message-list))
|
|
|
2578 b-list new-messages)
|
|
|
2579 (save-excursion
|
|
|
2580 (vm-save-restriction
|
|
|
2581 (widen)
|
|
|
2582 (vm-build-message-list)
|
|
|
2583 (if (or (null tail-cons) (cdr tail-cons))
|
|
|
2584 (progn
|
|
|
2585 (setq vm-ml-sort-keys nil)
|
|
|
2586 (if dont-read-attributes
|
|
|
2587 (vm-set-default-attributes (cdr tail-cons))
|
|
|
2588 (vm-read-attributes (cdr tail-cons)))
|
|
|
2589 ;; Yuck. This has to be done here instead of in the
|
|
|
2590 ;; vm function because this needs to be done before
|
|
|
2591 ;; any initial thread sort (so that if the thread
|
|
|
2592 ;; sort matches the saved order the folder won't be
|
|
|
2593 ;; modified) but after the message list is created.
|
|
|
2594 ;; Since thread sorting is done here this has to be
|
|
|
2595 ;; done here too.
|
|
|
2596 (if gobble-order
|
|
|
2597 (vm-gobble-message-order))
|
|
|
2598 (if vm-thread-obarray
|
|
|
2599 (vm-build-threads (cdr tail-cons))))))
|
|
|
2600 (setq new-messages (if tail-cons (cdr tail-cons) vm-message-list))
|
|
|
2601 (vm-set-numbering-redo-start-point new-messages)
|
|
|
2602 (vm-set-summary-redo-start-point new-messages))
|
|
|
2603 ;; copy the new-messages list because sorting might scramble
|
|
|
2604 ;; it. Also something the user does when
|
|
|
2605 ;; vm-arrived-message-hook is run might affect it.
|
|
|
2606 ;; vm-assimilate-new-messages returns this value so it must
|
|
|
2607 ;; not be mangled.
|
|
|
2608 (setq new-messages (copy-sequence new-messages))
|
|
|
2609 (if vm-summary-show-threads
|
|
|
2610 (progn
|
|
|
2611 ;; get numbering and summary of new messages done now
|
|
|
2612 ;; so that the sort code only has to worry about the
|
|
|
2613 ;; changes it needs to make.
|
|
|
2614 (vm-update-summary-and-mode-line)
|
|
|
2615 (vm-sort-messages "thread")))
|
|
|
2616 (if (and vm-arrived-message-hook
|
|
|
2617 new-messages
|
|
|
2618 ;; tail-cons == nil means vm-message-list was empty.
|
|
|
2619 ;; Thus new-messages == vm-message-list. In this
|
|
|
2620 ;; case, run the hooks only if this is not the first
|
|
|
2621 ;; time vm-assimilate-new-messages has been called
|
|
|
2622 ;; in this folder. gobble-order non-nil is a good
|
|
|
2623 ;; indicator that this is the first time because the
|
|
|
2624 ;; order is gobbled only once per visit and always
|
|
|
2625 ;; the first time vm-assimilate-new-messages is
|
|
|
2626 ;; called.
|
|
|
2627 (or tail-cons (null gobble-order)))
|
|
|
2628 (let ((new-messages new-messages))
|
|
|
2629 ;; seems wise to do this so that if the user runs VM
|
|
|
2630 ;; command here they start with as much of a clean
|
|
|
2631 ;; slate as we can provide, given we're currently deep
|
|
|
2632 ;; in the guts of VM.
|
|
|
2633 (vm-update-summary-and-mode-line)
|
|
|
2634 (while new-messages
|
|
|
2635 (vm-run-message-hook (car new-messages) 'vm-arrived-message-hook)
|
|
|
2636 (setq new-messages (cdr new-messages)))))
|
|
|
2637 (vm-update-summary-and-mode-line)
|
|
|
2638 (run-hooks 'vm-arrived-messages-hook)
|
|
|
2639 (if (and new-messages vm-virtual-buffers)
|
|
|
2640 (save-excursion
|
|
|
2641 (setq b-list vm-virtual-buffers)
|
|
|
2642 (while b-list
|
|
|
2643 ;; buffer might be dead
|
|
|
2644 (if (buffer-name (car b-list))
|
|
|
2645 (let (tail-cons)
|
|
|
2646 (set-buffer (car b-list))
|
|
|
2647 (setq tail-cons (vm-last vm-message-list))
|
|
|
2648 (vm-build-virtual-message-list new-messages)
|
|
|
2649 (if (or (null tail-cons) (cdr tail-cons))
|
|
|
2650 (progn
|
|
|
2651 (setq vm-ml-sort-keys nil)
|
|
|
2652 (if vm-thread-obarray
|
|
|
2653 (vm-build-threads (cdr tail-cons)))
|
|
|
2654 (vm-set-summary-redo-start-point
|
|
|
2655 (or (cdr tail-cons) vm-message-list))
|
|
|
2656 (vm-set-numbering-redo-start-point
|
|
|
2657 (or (cdr tail-cons) vm-message-list))
|
|
|
2658 (if (null vm-message-pointer)
|
|
|
2659 (progn (setq vm-message-pointer vm-message-list
|
|
|
2660 vm-need-summary-pointer-update t)
|
|
|
2661 (if vm-message-pointer
|
|
|
2662 (vm-preview-current-message))))
|
|
|
2663 (if vm-summary-show-threads
|
|
|
2664 (progn
|
|
|
2665 (vm-update-summary-and-mode-line)
|
|
|
2666 (vm-sort-messages "thread")))))))
|
|
|
2667 (setq b-list (cdr b-list)))))
|
|
|
2668 new-messages ))
|
|
|
2669
|
|
|
2670 ;; return a list of all marked messages or the messages indicated by a
|
|
|
2671 ;; prefix argument.
|
|
|
2672 (defun vm-select-marked-or-prefixed-messages (prefix)
|
|
|
2673 (let (mlist)
|
|
|
2674 (if (eq last-command 'vm-next-command-uses-marks)
|
|
|
2675 (setq mlist (vm-marked-messages))
|
|
|
2676 (let ((direction (if (< prefix 0) 'backward 'forward))
|
|
|
2677 (count (vm-abs prefix))
|
|
|
2678 (vm-message-pointer vm-message-pointer))
|
|
|
2679 (if (not (eq vm-circular-folders t))
|
|
|
2680 (vm-check-count prefix))
|
|
|
2681 (while (not (zerop count))
|
|
|
2682 (setq mlist (cons (car vm-message-pointer) mlist))
|
|
|
2683 (vm-decrement count)
|
|
|
2684 (if (not (zerop count))
|
|
|
2685 (vm-move-message-pointer direction))))
|
|
|
2686 (nreverse mlist))))
|
|
|
2687
|
|
|
2688 (defun vm-display-startup-message ()
|
|
|
2689 (if (sit-for 5)
|
|
|
2690 (let ((lines vm-startup-message-lines))
|
|
70
|
2691 (message "VM %s, Copyright (C) 1996 Kyle E. Jones; type ? for help"
|
|
0
|
2692 vm-version)
|
|
|
2693 (setq vm-startup-message-displayed t)
|
|
|
2694 (while (and (sit-for 4) lines)
|
|
|
2695 (message (substitute-command-keys (car lines)))
|
|
|
2696 (setq lines (cdr lines)))))
|
|
70
|
2697 (vm-unsaved-message ""))
|
|
0
|
2698
|
|
|
2699 (defun vm-load-init-file (&optional interactive)
|
|
|
2700 (interactive "p")
|
|
|
2701 (if (or (not vm-init-file-loaded) interactive)
|
|
|
2702 (progn
|
|
|
2703 (and vm-init-file
|
|
|
2704 (load vm-init-file (not interactive) (not interactive) t))
|
|
70
|
2705 (and vm-options-file (load vm-options-file t t t))))
|
|
0
|
2706 (setq vm-init-file-loaded t)
|
|
|
2707 (vm-display nil nil '(vm-load-init-file) '(vm-load-init-file)))
|
|
|
2708
|
|
|
2709 (defun vm-session-initialization ()
|
|
|
2710 ;; If this is the first time VM has been run in this Emacs session,
|
|
|
2711 ;; do some necessary preparations.
|
|
|
2712 (if (or (not (boundp 'vm-session-beginning))
|
|
|
2713 vm-session-beginning)
|
|
|
2714 (progn
|
|
|
2715 (random t)
|
|
|
2716 (vm-load-init-file)
|
|
|
2717 (if (not vm-window-configuration-file)
|
|
|
2718 (setq vm-window-configurations vm-default-window-configuration)
|
|
|
2719 (or (vm-load-window-configurations vm-window-configuration-file)
|
|
|
2720 (setq vm-window-configurations vm-default-window-configuration)))
|
|
|
2721 (setq vm-buffers-needing-display-update (make-vector 29 0))
|
|
|
2722 (setq vm-session-beginning nil))))
|
|
|
2723
|
|
|
2724 (defun vm-toggle-read-only ()
|
|
|
2725 (interactive)
|
|
|
2726 (vm-select-folder-buffer)
|
|
|
2727 (setq vm-folder-read-only (not vm-folder-read-only))
|
|
|
2728 (intern (buffer-name) vm-buffers-needing-display-update)
|
|
|
2729 (message "Folder is now %s"
|
|
|
2730 (if vm-folder-read-only "read-only" "modifiable"))
|
|
|
2731 (vm-display nil nil '(vm-toggle-read-only) '(vm-toggle-read-only))
|
|
|
2732 (vm-update-summary-and-mode-line))
|
|
|
2733
|
|
|
2734 ;; this does the real major mode scutwork.
|
|
|
2735 (defun vm-mode-internal ()
|
|
|
2736 (widen)
|
|
|
2737 (make-local-variable 'require-final-newline)
|
|
|
2738 ;; don't kill local variables, as there is some state we'd like to
|
|
|
2739 ;; keep. rather than non-portably marking the variables we
|
|
|
2740 ;; want to keep, just avoid calling kill-local-variables and
|
|
|
2741 ;; reset everything that needs to be reset.
|
|
|
2742 (setq
|
|
|
2743 major-mode 'vm-mode
|
|
|
2744 mode-line-format vm-mode-line-format
|
|
|
2745 mode-name "VM"
|
|
|
2746 ;; must come after the setting of major-mode
|
|
70
|
2747 mode-popup-menu (and vm-use-menus
|
|
0
|
2748 (vm-menu-support-possible-p)
|
|
|
2749 (vm-menu-mode-menu))
|
|
|
2750 buffer-read-only t
|
|
|
2751 require-final-newline nil
|
|
|
2752 vm-thread-obarray nil
|
|
|
2753 vm-thread-subject-obarray nil
|
|
|
2754 vm-label-obarray (make-vector 29 0)
|
|
|
2755 vm-last-message-pointer nil
|
|
|
2756 vm-modification-counter 0
|
|
|
2757 vm-message-list nil
|
|
|
2758 vm-message-pointer nil
|
|
|
2759 vm-message-order-changed nil
|
|
|
2760 vm-message-order-header-present nil
|
|
|
2761 vm-summary-buffer nil
|
|
|
2762 vm-system-state nil
|
|
|
2763 vm-undo-record-list nil
|
|
|
2764 vm-undo-record-pointer nil
|
|
|
2765 vm-virtual-buffers (vm-link-to-virtual-buffers)
|
|
|
2766 vm-folder-type (vm-get-folder-type))
|
|
|
2767 (use-local-map vm-mode-map)
|
|
|
2768 (and (vm-menu-support-possible-p)
|
|
|
2769 (vm-menu-install-menus))
|
|
|
2770 (run-hooks 'vm-mode-hook)
|
|
|
2771 ;; compatibility
|
|
|
2772 (run-hooks 'vm-mode-hooks))
|
|
|
2773
|
|
|
2774 (defun vm-link-to-virtual-buffers ()
|
|
|
2775 (let ((b-list (buffer-list))
|
|
|
2776 (vbuffers nil)
|
|
|
2777 (folder-buffer (current-buffer))
|
|
|
2778 folders clauses)
|
|
|
2779 (save-excursion
|
|
|
2780 (while b-list
|
|
|
2781 (set-buffer (car b-list))
|
|
|
2782 (cond ((eq major-mode 'vm-virtual-mode)
|
|
|
2783 (setq clauses (cdr vm-virtual-folder-definition))
|
|
|
2784 (while clauses
|
|
|
2785 (setq folders (car (car clauses)))
|
|
|
2786 (while folders
|
|
|
2787 (if (eq folder-buffer (vm-get-file-buffer
|
|
|
2788 (expand-file-name
|
|
|
2789 (car folders)
|
|
|
2790 vm-folder-directory)))
|
|
|
2791 (setq vbuffers (cons (car b-list) vbuffers)
|
|
|
2792 vm-real-buffers (cons folder-buffer
|
|
|
2793 vm-real-buffers)
|
|
|
2794 folders nil
|
|
|
2795 clauses nil))
|
|
|
2796 (setq folders (cdr folders)))
|
|
|
2797 (setq clauses (cdr clauses)))))
|
|
|
2798 (setq b-list (cdr b-list)))
|
|
|
2799 vbuffers )))
|
|
|
2800
|
|
|
2801 (defun vm-change-folder-type (type)
|
|
|
2802 "Change folder type to TYPE.
|
|
|
2803 TYPE may be one of the following symbol values:
|
|
|
2804
|
|
|
2805 From_
|
|
|
2806 From_-with-Content-Length
|
|
|
2807 mmdf
|
|
|
2808 babyl
|
|
|
2809
|
|
|
2810 Interactively TYPE will be read from the minibuffer."
|
|
|
2811 (interactive
|
|
|
2812 (let ((this-command this-command)
|
|
|
2813 (last-command last-command)
|
|
|
2814 (types vm-supported-folder-types))
|
|
|
2815 (vm-select-folder-buffer)
|
|
|
2816 (vm-error-if-virtual-folder)
|
|
|
2817 (setq types (vm-delqual (symbol-name vm-folder-type)
|
|
|
2818 (copy-sequence types)))
|
|
|
2819 (list (intern (vm-read-string "Change folder to type: " types)))))
|
|
|
2820 (vm-select-folder-buffer)
|
|
|
2821 (vm-check-for-killed-summary)
|
|
|
2822 (vm-error-if-virtual-folder)
|
|
|
2823 (vm-error-if-folder-empty)
|
|
|
2824 (if (not (memq type '(From_ From_-with-Content-Length mmdf babyl)))
|
|
|
2825 (error "Unknown folder type: %s" type))
|
|
|
2826 (if (or (null vm-folder-type)
|
|
|
2827 (eq vm-folder-type 'unknown))
|
|
|
2828 (error "Current folder's type is unknown, can't change it."))
|
|
|
2829 (let ((mp vm-message-list)
|
|
|
2830 (buffer-read-only nil)
|
|
|
2831 (old-type vm-folder-type)
|
|
|
2832 ;; no interruptions
|
|
|
2833 (inhibit-quit t)
|
|
|
2834 (n 0)
|
|
|
2835 ;; Just for laughs, make the update interval vary.
|
|
|
2836 (modulus (+ (% (vm-abs (random)) 11) 5))
|
|
|
2837 text-end opoint)
|
|
|
2838 (save-excursion
|
|
|
2839 (vm-save-restriction
|
|
|
2840 (widen)
|
|
|
2841 (setq vm-folder-type type)
|
|
|
2842 (goto-char (point-min))
|
|
|
2843 (vm-convert-folder-header old-type type)
|
|
|
2844 (while mp
|
|
|
2845 (goto-char (vm-start-of (car mp)))
|
|
|
2846 (setq opoint (point))
|
|
|
2847 (insert (vm-leading-message-separator type (car mp)))
|
|
|
2848 (if (> (vm-headers-of (car mp)) (vm-start-of (car mp)))
|
|
|
2849 (delete-region (point) (vm-headers-of (car mp)))
|
|
|
2850 (set-marker (vm-headers-of (car mp)) (point))
|
|
|
2851 ;; if headers-of == start-of then so could vheaders-of
|
|
|
2852 ;; and text-of. clear them to force a recompute.
|
|
|
2853 (vm-set-vheaders-of (car mp) nil)
|
|
|
2854 (vm-set-text-of (car mp) nil))
|
|
|
2855 (vm-convert-folder-type-headers old-type type)
|
|
|
2856 (goto-char (vm-text-end-of (car mp)))
|
|
|
2857 (setq text-end (point))
|
|
|
2858 (insert-before-markers (vm-trailing-message-separator type))
|
|
|
2859 (delete-region (vm-text-end-of (car mp)) (vm-end-of (car mp)))
|
|
|
2860 (set-marker (vm-text-end-of (car mp)) text-end)
|
|
|
2861 (goto-char (vm-headers-of (car mp)))
|
|
|
2862 (vm-munge-message-separators type (vm-headers-of (car mp))
|
|
|
2863 (vm-text-end-of (car mp)))
|
|
|
2864 (vm-set-byte-count-of (car mp) nil)
|
|
|
2865 (vm-set-babyl-frob-flag-of (car mp) nil)
|
|
|
2866 (vm-set-message-type-of (car mp) type)
|
|
|
2867 ;; Technically we should mark each message for a
|
|
|
2868 ;; summary update since the message byte counts might
|
|
|
2869 ;; have changed. But I don't think anyone cares that
|
|
|
2870 ;; much and the summary regeneration would make this
|
|
|
2871 ;; process slower.
|
|
|
2872 (setq mp (cdr mp) n (1+ n))
|
|
|
2873 (if (zerop (% n modulus))
|
|
70
|
2874 (vm-unsaved-message "Converting... %d" n))))))
|
|
0
|
2875 (vm-clear-modification-flag-undos)
|
|
|
2876 (intern (buffer-name) vm-buffers-needing-display-update)
|
|
|
2877 (vm-update-summary-and-mode-line)
|
|
|
2878 (message "Conversion complete.")
|
|
|
2879 ;; message separator strings may have leaked into view
|
|
|
2880 (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))))
|
|
|
2882 (vm-display nil nil '(vm-change-folder-type) '(vm-change-folder-type)))
|
|
|
2883
|
|
|
2884 (if (not (memq 'vm-write-file-hook write-file-hooks))
|
|
|
2885 (setq write-file-hooks
|
|
|
2886 (cons 'vm-write-file-hook write-file-hooks)))
|
|
|
2887
|
|
|
2888 (if (not (memq 'vm-handle-file-recovery find-file-hooks))
|
|
|
2889 (setq find-file-hooks
|
|
|
2890 (nconc find-file-hooks
|
|
|
2891 '(vm-handle-file-recovery
|
|
|
2892 vm-handle-file-reversion))))
|
|
|
2893
|
|
|
2894 ;; after-revert-hook is new to FSF v19.23
|
|
|
2895 (defvar after-revert-hook)
|
|
|
2896 (if (boundp 'after-revert-hook)
|
|
|
2897 (setq after-revert-hook
|
|
|
2898 (cons 'vm-after-revert-buffer-hook after-revert-hook))
|
|
|
2899 (setq after-revert-hook (list 'vm-after-revert-buffer-hook)))
|
