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