|
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
|
|
140
|
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)
|
|
120
|
1169 oldpoint 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 ()
|
|
120
|
1185 (progn
|
|
|
1186 (setq oldpoint (point)
|
|
|
1187 data (read (current-buffer)))
|
|
|
1188 (if (and (or (not (listp data)) (not (= 3 (length data))))
|
|
|
1189 (not (vectorp data)))
|
|
|
1190 (progn
|
|
|
1191 (error "Bad x-vm-v5-data at %d in buffer %s"
|
|
|
1192 oldpoint (buffer-name))))
|
|
|
1193 data )
|
|
|
1194 (error
|
|
|
1195 (message "Bad x-vm-v5-data header at %d in buffer %s, ignoring"
|
|
|
1196 oldpoint (buffer-name))
|
|
|
1197 (setq data
|
|
|
1198 (list
|
|
|
1199 (make-vector vm-attributes-vector-length nil)
|
|
|
1200 (make-vector vm-cache-vector-length nil)
|
|
|
1201 nil))
|
|
|
1202 ;; In lieu of a valid attributes header
|
|
|
1203 ;; assume the message is new. avoid
|
|
|
1204 ;; vm-set-new-flag because it asks for a
|
|
|
1205 ;; summary update.
|
|
|
1206 (vm-set-new-flag-in-vector (car data) t)))
|
|
0
|
1207 ;; support version 4 format
|
|
|
1208 (cond ((vectorp data)
|
|
|
1209 (setq data (vm-convert-v4-attributes data))
|
|
|
1210 ;; tink the message modflag so that if the
|
|
|
1211 ;; user saves we get rid of the old v4
|
|
|
1212 ;; attributes header. otherwise we could be
|
|
|
1213 ;; dealing with these things for all eternity.
|
|
|
1214 (vm-set-modflag-of (car mp) t))
|
|
|
1215 (t
|
|
|
1216 ;; extend vectors if necessary to accomodate
|
|
|
1217 ;; more caching and attributes without alienating
|
|
|
1218 ;; other version 5 folders.
|
|
|
1219 (cond ((< (length (car data))
|
|
|
1220 vm-attributes-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 data (vm-extend-vector
|
|
|
1228 (car data)
|
|
|
1229 vm-attributes-vector-length))))
|
|
|
1230 (cond ((< (length (car (cdr data)))
|
|
|
1231 vm-cache-vector-length)
|
|
|
1232 ;; tink the message modflag so that if
|
|
|
1233 ;; the user saves we get rid of the old
|
|
|
1234 ;; short vector. otherwise we could be
|
|
|
1235 ;; dealing with these things for all
|
|
|
1236 ;; eternity.
|
|
|
1237 (vm-set-modflag-of (car mp) t)
|
|
|
1238 (setcar (cdr data)
|
|
|
1239 (vm-extend-vector
|
|
|
1240 (car (cdr data))
|
|
|
1241 vm-cache-vector-length))))))
|
|
|
1242 (vm-set-labels-of (car mp) (nth 2 data))
|
|
|
1243 (vm-set-cache-of (car mp) (car (cdr data)))
|
|
|
1244 (vm-set-attributes-of (car mp) (car data)))
|
|
|
1245 ((and vm-berkeley-mail-compatibility
|
|
|
1246 (re-search-forward vm-berkeley-mail-status-header-regexp
|
|
|
1247 (vm-text-of (car mp)) t))
|
|
|
1248 (vm-set-cache-of (car mp) (make-vector vm-cache-vector-length
|
|
|
1249 nil))
|
|
|
1250 (goto-char (match-beginning 1))
|
|
|
1251 (vm-set-attributes-of
|
|
|
1252 (car mp)
|
|
|
1253 (make-vector vm-attributes-vector-length nil))
|
|
|
1254 (vm-set-unread-flag (car mp) (not (looking-at ".*R.*")) t))
|
|
|
1255 (t
|
|
|
1256 (vm-set-cache-of (car mp) (make-vector vm-cache-vector-length
|
|
|
1257 nil))
|
|
|
1258 (vm-set-attributes-of
|
|
|
1259 (car mp)
|
|
|
1260 (make-vector vm-attributes-vector-length nil))
|
|
|
1261 ;; In lieu of a valid attributes header
|
|
|
1262 ;; assume the message is new. avoid
|
|
|
1263 ;; vm-set-new-flag because it asks for a
|
|
|
1264 ;; summary update.
|
|
|
1265 (vm-set-new-flag-of (car mp) t)))
|
|
|
1266 ;; let babyl attributes override the normal VM
|
|
|
1267 ;; attributes header.
|
|
|
1268 (cond ((eq vm-folder-type 'babyl)
|
|
|
1269 (vm-read-babyl-attributes (car mp)))))
|
|
|
1270 (cond ((vm-deleted-flag (car mp))
|
|
|
1271 (vm-increment vm-deleted-count))
|
|
|
1272 ((vm-new-flag (car mp))
|
|
|
1273 (vm-increment vm-new-count))
|
|
|
1274 ((vm-unread-flag (car mp))
|
|
|
1275 (vm-increment vm-unread-count)))
|
|
|
1276 (if (zerop (% vm-total-count modulus))
|
|
102
|
1277 (message "Reading attributes... %d" vm-total-count))
|
|
0
|
1278 (setq mp (cdr mp)))
|
|
|
1279 (if (>= vm-total-count modulus)
|
|
102
|
1280 (message "Reading attributes... done"))
|
|
0
|
1281 (if (null message-list)
|
|
|
1282 (setq vm-totals (list vm-modification-counter
|
|
|
1283 vm-total-count
|
|
|
1284 vm-new-count
|
|
|
1285 vm-unread-count
|
|
|
1286 vm-deleted-count))))))
|
|
|
1287
|
|
|
1288 (defun vm-read-babyl-attributes (message)
|
|
|
1289 (let ((case-fold-search t)
|
|
|
1290 (labels nil)
|
|
|
1291 (vect (make-vector vm-attributes-vector-length nil)))
|
|
|
1292 (vm-set-attributes-of message vect)
|
|
|
1293 (save-excursion
|
|
|
1294 (goto-char (vm-start-of message))
|
|
|
1295 ;; skip past ^L\n
|
|
|
1296 (forward-char 2)
|
|
|
1297 (vm-set-babyl-frob-flag-of message (if (= (following-char) ?1) t nil))
|
|
|
1298 ;; skip past 0,
|
|
|
1299 (forward-char 2)
|
|
|
1300 ;; loop, noting attributes as we go.
|
|
|
1301 (while (and (not (eobp)) (not (looking-at ",")))
|
|
|
1302 (cond ((looking-at " unseen,")
|
|
|
1303 (vm-set-unread-flag-of message t))
|
|
|
1304 ((looking-at " recent,")
|
|
|
1305 (vm-set-new-flag-of message t))
|
|
|
1306 ((looking-at " deleted,")
|
|
|
1307 (vm-set-deleted-flag-of message t))
|
|
|
1308 ((looking-at " answered,")
|
|
|
1309 (vm-set-replied-flag-of message t))
|
|
|
1310 ((looking-at " forwarded,")
|
|
|
1311 (vm-set-forwarded-flag-of message t))
|
|
|
1312 ((looking-at " filed,")
|
|
|
1313 (vm-set-filed-flag-of message t))
|
|
|
1314 ((looking-at " redistributed,")
|
|
|
1315 (vm-set-redistributed-flag-of message t))
|
|
|
1316 ;; only VM knows about these, as far as I know.
|
|
|
1317 ((looking-at " edited,")
|
|
|
1318 (vm-set-forwarded-flag-of message t))
|
|
|
1319 ((looking-at " written,")
|
|
|
1320 (vm-set-forwarded-flag-of message t)))
|
|
|
1321 (skip-chars-forward "^,")
|
|
|
1322 (and (not (eobp)) (forward-char 1)))
|
|
|
1323 (and (not (eobp)) (forward-char 1))
|
|
|
1324 (while (looking-at " \\([^\000-\040,\177-\377]+\\),")
|
|
|
1325 (setq labels (cons (vm-buffer-substring-no-properties
|
|
|
1326 (match-beginning 1)
|
|
|
1327 (match-end 1))
|
|
|
1328 labels))
|
|
|
1329 (goto-char (match-end 0)))
|
|
|
1330 (vm-set-labels-of message labels))))
|
|
|
1331
|
|
|
1332 (defun vm-set-default-attributes (message-list)
|
|
|
1333 (let ((mp (or message-list vm-message-list)) attr cache)
|
|
|
1334 (while mp
|
|
|
1335 (setq attr (make-vector vm-attributes-vector-length nil)
|
|
|
1336 cache (make-vector vm-cache-vector-length nil))
|
|
|
1337 (vm-set-cache-of (car mp) cache)
|
|
|
1338 (vm-set-attributes-of (car mp) attr)
|
|
|
1339 ;; make message be new by default, but avoid vm-set-new-flag
|
|
|
1340 ;; because it asks for a summary update for the message.
|
|
|
1341 (vm-set-new-flag-of (car mp) t)
|
|
|
1342 ;; since this function is usually called in lieu of reading
|
|
|
1343 ;; attributes from the buffer, the attributes may be
|
|
|
1344 ;; untrustworthy. tink the message modflag to force the
|
|
|
1345 ;; new attributes out if the user saves.
|
|
|
1346 (vm-set-modflag-of (car mp) t)
|
|
|
1347 (setq mp (cdr mp)))))
|
|
|
1348
|
|
|
1349 (defun vm-emit-totals-blurb ()
|
|
|
1350 (save-excursion
|
|
|
1351 (vm-select-folder-buffer)
|
|
|
1352 (if (not (equal (nth 0 vm-totals) vm-modification-counter))
|
|
|
1353 (let ((mp vm-message-list)
|
|
|
1354 (vm-new-count 0)
|
|
|
1355 (vm-unread-count 0)
|
|
|
1356 (vm-deleted-count 0)
|
|
|
1357 (vm-total-count 0))
|
|
|
1358 (while mp
|
|
|
1359 (vm-increment vm-total-count)
|
|
|
1360 (cond ((vm-deleted-flag (car mp))
|
|
|
1361 (vm-increment vm-deleted-count))
|
|
|
1362 ((vm-new-flag (car mp))
|
|
|
1363 (vm-increment vm-new-count))
|
|
|
1364 ((vm-unread-flag (car mp))
|
|
|
1365 (vm-increment vm-unread-count)))
|
|
|
1366 (setq mp (cdr mp)))
|
|
|
1367 (setq vm-totals (list vm-modification-counter
|
|
|
1368 vm-total-count
|
|
|
1369 vm-new-count
|
|
|
1370 vm-unread-count
|
|
|
1371 vm-deleted-count))))
|
|
|
1372 (if (equal (nth 1 vm-totals) 0)
|
|
|
1373 (message "No messages.")
|
|
|
1374 (message "%d message%s, %d new, %d unread, %d deleted"
|
|
|
1375 (nth 1 vm-totals) (if (= (nth 1 vm-totals) 1) "" "s")
|
|
|
1376 (nth 2 vm-totals)
|
|
|
1377 (nth 3 vm-totals)
|
|
|
1378 (nth 4 vm-totals)))))
|
|
|
1379
|
|
|
1380 (defun vm-convert-v4-attributes (data)
|
|
|
1381 (list (apply 'vector
|
|
|
1382 (nconc (vm-vector-to-list data)
|
|
|
1383 (make-list (- vm-attributes-vector-length
|
|
|
1384 (length data))
|
|
|
1385 nil)))
|
|
|
1386 (make-vector vm-cache-vector-length nil)))
|
|
|
1387
|
|
|
1388 (defun vm-gobble-labels ()
|
|
|
1389 (let ((case-fold-search t)
|
|
|
1390 lim)
|
|
|
1391 (save-excursion
|
|
|
1392 (vm-save-restriction
|
|
|
1393 (widen)
|
|
|
1394 (if (eq vm-folder-type 'babyl)
|
|
|
1395 (progn
|
|
|
1396 (goto-char (point-min))
|
|
|
1397 (vm-skip-past-folder-header)
|
|
|
1398 (setq lim (point))
|
|
|
1399 (goto-char (point-min))
|
|
|
1400 (if (re-search-forward "^Labels:" lim t)
|
|
|
1401 (let (string list)
|
|
|
1402 (setq string (buffer-substring
|
|
|
1403 (point)
|
|
|
1404 (progn (end-of-line) (point)))
|
|
|
1405 list (vm-parse string
|
|
|
1406 "[\000-\040,\177-\377]*\\([^\000-\040,\177-\377]+\\)[\000-\040,\177-\377]*"))
|
|
|
1407 (mapcar (function
|
|
|
1408 (lambda (s)
|
|
|
1409 (intern (downcase s) vm-label-obarray)))
|
|
|
1410 list))))
|
|
|
1411 (goto-char (point-min))
|
|
|
1412 (vm-skip-past-folder-header)
|
|
|
1413 (vm-skip-past-leading-message-separator)
|
|
|
1414 (search-forward "\n\n" nil t)
|
|
|
1415 (setq lim (point))
|
|
|
1416 (goto-char (point-min))
|
|
|
1417 (vm-skip-past-folder-header)
|
|
|
1418 (vm-skip-past-leading-message-separator)
|
|
|
1419 (if (re-search-forward vm-labels-header-regexp lim t)
|
|
120
|
1420 (let ((oldpoint (point))
|
|
|
1421 list)
|
|
|
1422 (condition-case ()
|
|
|
1423 (progn
|
|
|
1424 (setq list (read (current-buffer)))
|
|
|
1425 (if (not (listp list))
|
|
|
1426 (error "Bad global label list at %d in buffer %s"
|
|
|
1427 oldpoint (buffer-name)))
|
|
|
1428 list )
|
|
|
1429 (error
|
|
|
1430 (message "Bad global label list at %d in buffer %s, ignoring"
|
|
|
1431 oldpoint (buffer-name))
|
|
|
1432 (setq list nil) ))
|
|
0
|
1433 (mapcar (function
|
|
|
1434 (lambda (s)
|
|
|
1435 (intern s vm-label-obarray)))
|
|
|
1436 list))))))
|
|
|
1437 t ))
|
|
|
1438
|
|
|
1439 ;; Go to the message specified in a bookmark and eat the bookmark.
|
|
|
1440 ;; Returns non-nil if successful, nil otherwise.
|
|
|
1441 (defun vm-gobble-bookmark ()
|
|
|
1442 (let ((case-fold-search t)
|
|
120
|
1443 (n nil)
|
|
|
1444 lim oldpoint)
|
|
0
|
1445 (save-excursion
|
|
|
1446 (vm-save-restriction
|
|
|
1447 (widen)
|
|
|
1448 (goto-char (point-min))
|
|
|
1449 (vm-skip-past-folder-header)
|
|
|
1450 (vm-skip-past-leading-message-separator)
|
|
|
1451 (search-forward "\n\n" nil t)
|
|
|
1452 (setq lim (point))
|
|
|
1453 (goto-char (point-min))
|
|
|
1454 (vm-skip-past-folder-header)
|
|
|
1455 (vm-skip-past-leading-message-separator)
|
|
|
1456 (if (re-search-forward vm-bookmark-header-regexp lim t)
|
|
120
|
1457 (condition-case ()
|
|
|
1458 (progn
|
|
|
1459 (setq oldpoint (point)
|
|
|
1460 n (read (current-buffer)))
|
|
|
1461 (if (not (natnump n))
|
|
|
1462 (error "Bad bookmark at %d in buffer %s"
|
|
|
1463 oldpoint (buffer-name)))
|
|
|
1464 n )
|
|
|
1465 (error
|
|
|
1466 (message "Bad bookmark at %d in buffer %s, ignoring"
|
|
|
1467 oldpoint (buffer-name))
|
|
|
1468 (setq n 1))))))
|
|
0
|
1469 (if n
|
|
|
1470 (vm-record-and-change-message-pointer
|
|
|
1471 vm-message-pointer
|
|
|
1472 (nthcdr (1- n) vm-message-list)))
|
|
|
1473 t ))
|
|
|
1474
|
|
|
1475 (defun vm-gobble-visible-header-variables ()
|
|
|
1476 (save-excursion
|
|
|
1477 (vm-save-restriction
|
|
|
1478 (let ((case-fold-search t)
|
|
|
1479 lim)
|
|
|
1480 (widen)
|
|
|
1481 (goto-char (point-min))
|
|
|
1482 (vm-skip-past-folder-header)
|
|
|
1483 (vm-skip-past-leading-message-separator)
|
|
|
1484 (search-forward "\n\n" nil t)
|
|
|
1485 (setq lim (point))
|
|
|
1486 (goto-char (point-min))
|
|
|
1487 (vm-skip-past-folder-header)
|
|
|
1488 (vm-skip-past-leading-message-separator)
|
|
|
1489 (if (re-search-forward vm-vheader-header-regexp lim t)
|
|
|
1490 (let (vis invis (got nil))
|
|
|
1491 (condition-case ()
|
|
|
1492 (setq vis (read (current-buffer))
|
|
|
1493 invis (read (current-buffer))
|
|
|
1494 got t)
|
|
|
1495 (error nil))
|
|
|
1496 ;; if the variables don't match the values stored when this
|
|
|
1497 ;; folder was saved, then we have to discard any cached
|
|
|
1498 ;; vheader info so the user will see the right headers.
|
|
|
1499 (and got (or (not (equal vis vm-visible-headers))
|
|
|
1500 (not (equal invis vm-invisible-header-regexp)))
|
|
|
1501 (let ((mp vm-message-list))
|
|
102
|
1502 (message "Discarding visible header info...")
|
|
0
|
1503 (while mp
|
|
|
1504 (vm-set-vheaders-regexp-of (car mp) nil)
|
|
|
1505 (vm-set-vheaders-of (car mp) nil)
|
|
|
1506 (setq mp (cdr mp)))))))))))
|
|
|
1507
|
|
|
1508 ;; Read and delete the header that gives the folder's desired
|
|
|
1509 ;; message order.
|
|
|
1510 (defun vm-gobble-message-order ()
|
|
|
1511 (let ((case-fold-search t)
|
|
|
1512 lim v order
|
|
|
1513 (mp vm-message-list)
|
|
|
1514 list-length)
|
|
|
1515 (save-excursion
|
|
|
1516 (save-restriction
|
|
|
1517 (widen)
|
|
|
1518 (goto-char (point-min))
|
|
|
1519 (vm-skip-past-folder-header)
|
|
|
1520 (vm-skip-past-leading-message-separator)
|
|
|
1521 (search-forward "\n\n" nil t)
|
|
|
1522 (setq lim (point))
|
|
|
1523 (goto-char (point-min))
|
|
|
1524 (vm-skip-past-folder-header)
|
|
|
1525 (vm-skip-past-leading-message-separator)
|
|
|
1526 (if (re-search-forward vm-message-order-header-regexp lim t)
|
|
120
|
1527 (let ((oldpoint (point)))
|
|
102
|
1528 (message "Reordering messages...")
|
|
120
|
1529 (condition-case nil
|
|
|
1530 (progn
|
|
|
1531 (setq order (read (current-buffer)))
|
|
|
1532 (if (not (listp order))
|
|
|
1533 (error "Bad order header at %d in buffer %s"
|
|
|
1534 oldpoint (buffer-name)))
|
|
|
1535 order )
|
|
|
1536 (error
|
|
|
1537 (message "Bad order header at %d in buffer %s, ignoring"
|
|
|
1538 oldpoint (buffer-name))
|
|
|
1539 (setq order nil)))
|
|
|
1540 (setq list-length (length vm-message-list)
|
|
0
|
1541 v (make-vector (max list-length (length order)) nil))
|
|
|
1542 (while (and order mp)
|
|
120
|
1543 (condition-case nil
|
|
|
1544 (aset v (1- (car order)) (car mp))
|
|
|
1545 (args-out-of-range nil))
|
|
0
|
1546 (setq order (cdr order) mp (cdr mp)))
|
|
|
1547 ;; lock out interrupts while the message list is in
|
|
|
1548 ;; an inconsistent state.
|
|
|
1549 (let ((inhibit-quit t))
|
|
|
1550 (setq vm-message-list (delq nil (append v mp))
|
|
|
1551 vm-message-order-changed nil
|
|
|
1552 vm-message-order-header-present t
|
|
|
1553 vm-message-pointer (memq (car vm-message-pointer)
|
|
|
1554 vm-message-list))
|
|
|
1555 (vm-set-numbering-redo-start-point t)
|
|
|
1556 (vm-reverse-link-messages))
|
|
102
|
1557 (message "Reordering messages... done")))))))
|
|
0
|
1558
|
|
|
1559 ;; Read the header that gives the folder's cached summary format
|
|
|
1560 ;; If the current summary format is different, then the cached
|
|
|
1561 ;; summary lines are discarded.
|
|
|
1562 (defun vm-gobble-summary ()
|
|
|
1563 (let ((case-fold-search t)
|
|
|
1564 summary lim
|
|
|
1565 (mp vm-message-list))
|
|
|
1566 (save-excursion
|
|
|
1567 (vm-save-restriction
|
|
|
1568 (widen)
|
|
|
1569 (goto-char (point-min))
|
|
|
1570 (vm-skip-past-folder-header)
|
|
|
1571 (vm-skip-past-leading-message-separator)
|
|
|
1572 (search-forward "\n\n" nil t)
|
|
|
1573 (setq lim (point))
|
|
|
1574 (goto-char (point-min))
|
|
|
1575 (vm-skip-past-folder-header)
|
|
|
1576 (vm-skip-past-leading-message-separator)
|
|
|
1577 (if (re-search-forward vm-summary-header-regexp lim t)
|
|
120
|
1578 (let ((oldpoint (point)))
|
|
|
1579 (condition-case ()
|
|
|
1580 (setq summary (read (current-buffer)))
|
|
|
1581 (error
|
|
|
1582 (message "Bad summary header at %d in buffer %s, ignoring"
|
|
|
1583 oldpoint (buffer-name))
|
|
|
1584 (setq summary "")))
|
|
0
|
1585 (if (not (equal summary vm-summary-format))
|
|
|
1586 (while mp
|
|
|
1587 (vm-set-summary-of (car mp) nil)
|
|
|
1588 ;; force restuffing of cache to clear old
|
|
|
1589 ;; summary entry cache.
|
|
|
1590 (vm-set-modflag-of (car mp) t)
|
|
|
1591 (setq mp (cdr mp))))))))))
|
|
|
1592
|
|
|
1593 ;; Stuff the message attributes back into the message as headers.
|
|
|
1594 (defun vm-stuff-attributes (m &optional for-other-folder)
|
|
|
1595 (save-excursion
|
|
|
1596 (vm-save-restriction
|
|
|
1597 (widen)
|
|
|
1598 (let ((old-buffer-modified-p (buffer-modified-p))
|
|
|
1599 attributes cache
|
|
|
1600 (case-fold-search t)
|
|
|
1601 (buffer-read-only nil)
|
|
|
1602 opoint
|
|
|
1603 ;; This prevents file locking from occuring. Disabling
|
|
|
1604 ;; locking can speed things noticeably if the lock
|
|
|
1605 ;; directory is on a slow device. We don't need locking
|
|
|
1606 ;; here because the user shouldn't care about VM stuffing
|
|
|
1607 ;; its own status headers.
|
|
|
1608 (buffer-file-name nil)
|
|
|
1609 (delflag (vm-deleted-flag m)))
|
|
|
1610 (unwind-protect
|
|
|
1611 (progn
|
|
|
1612 ;; don't put this folder's summary entry into another folder.
|
|
|
1613 (if for-other-folder
|
|
|
1614 (vm-set-summary-of m nil)
|
|
|
1615 (if (vm-su-start-of m)
|
|
|
1616 ;; fill the summary cache if it's not done already.
|
|
|
1617 (vm-su-summary m)))
|
|
|
1618 (setq attributes (vm-attributes-of m)
|
|
|
1619 cache (vm-cache-of m))
|
|
|
1620 (and delflag for-other-folder
|
|
|
1621 (vm-set-deleted-flag-in-vector
|
|
|
1622 (setq attributes (copy-sequence attributes)) nil))
|
|
|
1623 (if (eq vm-folder-type 'babyl)
|
|
|
1624 (vm-stuff-babyl-attributes m for-other-folder))
|
|
|
1625 (goto-char (vm-headers-of m))
|
|
|
1626 (while (re-search-forward vm-attributes-header-regexp
|
|
|
1627 (vm-text-of m) t)
|
|
|
1628 (delete-region (match-beginning 0) (match-end 0)))
|
|
|
1629 (goto-char (vm-headers-of m))
|
|
|
1630 (setq opoint (point))
|
|
|
1631 (insert-before-markers
|
|
|
1632 vm-attributes-header " ("
|
|
|
1633 (let ((print-escape-newlines t))
|
|
|
1634 (prin1-to-string attributes))
|
|
|
1635 "\n\t"
|
|
|
1636 (let ((print-escape-newlines t))
|
|
|
1637 (prin1-to-string cache))
|
|
|
1638 "\n\t"
|
|
|
1639 (let ((print-escape-newlines t))
|
|
|
1640 (prin1-to-string (vm-labels-of m)))
|
|
|
1641 ")\n")
|
|
|
1642 (set-marker (vm-headers-of m) opoint)
|
|
|
1643 (cond ((and (eq vm-folder-type 'From_)
|
|
|
1644 vm-berkeley-mail-compatibility)
|
|
|
1645 (goto-char (vm-headers-of m))
|
|
|
1646 (while (re-search-forward
|
|
|
1647 vm-berkeley-mail-status-header-regexp
|
|
|
1648 (vm-text-of m) t)
|
|
|
1649 (delete-region (match-beginning 0) (match-end 0)))
|
|
|
1650 (goto-char (vm-headers-of m))
|
|
|
1651 (cond ((not (vm-new-flag m))
|
|
|
1652 (insert-before-markers
|
|
|
1653 vm-berkeley-mail-status-header
|
|
|
1654 (if (vm-unread-flag m) "" "R")
|
|
|
1655 "O\n")
|
|
|
1656 (set-marker (vm-headers-of m) opoint)))))
|
|
|
1657 (vm-set-modflag-of m nil))
|
|
|
1658 (set-buffer-modified-p old-buffer-modified-p))))))
|
|
|
1659
|
|
98
|
1660 (defun vm-stuff-folder-attributes (&optional abort-if-input-pending)
|
|
|
1661 (let ((newlist nil) mp)
|
|
|
1662 ;; stuff the attributes of messages that need it.
|
|
|
1663 ;; build a list of messages that need their attributes stuffed
|
|
|
1664 (setq mp vm-message-list)
|
|
|
1665 (while mp
|
|
|
1666 (if (vm-modflag-of (car mp))
|
|
|
1667 (setq newlist (cons (car mp) newlist)))
|
|
|
1668 (setq mp (cdr mp)))
|
|
|
1669 ;; now sort the list by physical order so that we
|
|
|
1670 ;; reduce the amount of gap motion induced by modifying
|
|
|
1671 ;; the buffer. what we want to avoid is updating
|
|
|
1672 ;; message 3, then 234, then 10, then 500, thus causing
|
|
|
1673 ;; large chunks of memory to be copied repeatedly as
|
|
|
1674 ;; the gap moves to accomodate the insertions.
|
|
|
1675 (let ((vm-key-functions '(vm-sort-compare-physical-order-r)))
|
|
|
1676 (setq mp (sort newlist 'vm-sort-compare-xxxxxx)))
|
|
|
1677 (while (and mp (or (not abort-if-input-pending) (not (input-pending-p))))
|
|
|
1678 (vm-stuff-attributes (car mp))
|
|
|
1679 (setq mp (cdr mp)))
|
|
|
1680 (if mp nil t)))
|
|
|
1681
|
|
0
|
1682 ;; we can be a bit lazy in this function since it's only called
|
|
|
1683 ;; from within vm-stuff-attributes. we don't worry about
|
|
|
1684 ;; restoring the modified flag, setting buffer-read-only, or
|
|
|
1685 ;; about not moving point.
|
|
|
1686 (defun vm-stuff-babyl-attributes (m for-other-folder)
|
|
|
1687 (goto-char (vm-start-of m))
|
|
|
1688 (forward-char 2)
|
|
|
1689 (if (vm-babyl-frob-flag-of m)
|
|
|
1690 (insert "1")
|
|
|
1691 (insert "0"))
|
|
|
1692 (delete-char 1)
|
|
|
1693 (forward-char 1)
|
|
|
1694 (if (looking-at "\\( [^\000-\040,\177-\377]+,\\)+")
|
|
|
1695 (delete-region (match-beginning 0) (match-end 0)))
|
|
|
1696 (if (vm-new-flag m)
|
|
|
1697 (insert " recent, unseen,")
|
|
|
1698 (if (vm-unread-flag m)
|
|
|
1699 (insert " unseen,")))
|
|
|
1700 (if (and (not for-other-folder) (vm-deleted-flag m))
|
|
|
1701 (insert " deleted,"))
|
|
|
1702 (if (vm-replied-flag m)
|
|
|
1703 (insert " answered,"))
|
|
|
1704 (if (vm-forwarded-flag m)
|
|
|
1705 (insert " forwarded,"))
|
|
|
1706 (if (vm-redistributed-flag m)
|
|
|
1707 (insert " redistributed,"))
|
|
|
1708 (if (vm-filed-flag m)
|
|
|
1709 (insert " filed,"))
|
|
|
1710 (if (vm-edited-flag m)
|
|
|
1711 (insert " edited,"))
|
|
|
1712 (if (vm-written-flag m)
|
|
|
1713 (insert " written,"))
|
|
|
1714 (forward-char 1)
|
|
|
1715 (if (looking-at "\\( [^\000-\040,\177-\377]+,\\)+")
|
|
|
1716 (delete-region (match-beginning 0) (match-end 0)))
|
|
|
1717 (mapcar (function (lambda (label) (insert " " label ",")))
|
|
|
1718 (vm-labels-of m)))
|
|
|
1719
|
|
|
1720 (defun vm-babyl-attributes-string (m for-other-folder)
|
|
|
1721 (concat
|
|
|
1722 (if (vm-new-flag m)
|
|
|
1723 " recent, unseen,"
|
|
|
1724 (if (vm-unread-flag m)
|
|
|
1725 " unseen,"))
|
|
|
1726 (if (and (not for-other-folder) (vm-deleted-flag m))
|
|
|
1727 " deleted,")
|
|
|
1728 (if (vm-replied-flag m)
|
|
|
1729 " answered,")
|
|
|
1730 (if (vm-forwarded-flag m)
|
|
|
1731 " forwarded,")
|
|
|
1732 (if (vm-redistributed-flag m)
|
|
|
1733 " redistributed,")
|
|
|
1734 (if (vm-filed-flag m)
|
|
|
1735 " filed,")
|
|
|
1736 (if (vm-edited-flag m)
|
|
|
1737 " edited,")
|
|
|
1738 (if (vm-written-flag m)
|
|
|
1739 " written,")))
|
|
|
1740
|
|
|
1741 (defun vm-babyl-labels-string (m)
|
|
|
1742 (let ((list nil)
|
|
|
1743 (labels (vm-labels-of m)))
|
|
|
1744 (while labels
|
|
|
1745 (setq list (cons "," (cons (car labels) (cons " " list)))
|
|
|
1746 labels (cdr labels)))
|
|
|
1747 (apply 'concat (nreverse list))))
|
|
|
1748
|
|
|
1749 (defun vm-stuff-virtual-attributes (message)
|
|
|
1750 (let ((virtual (vm-virtual-message-p message)))
|
|
|
1751 (if (or (not virtual) (and virtual (vm-virtual-messages-of message)))
|
|
|
1752 (save-excursion
|
|
|
1753 (set-buffer
|
|
|
1754 (vm-buffer-of
|
|
|
1755 (vm-real-message-of message)))
|
|
|
1756 (vm-stuff-attributes (vm-real-message-of message))))))
|
|
|
1757
|
|
|
1758 (defun vm-stuff-labels ()
|
|
|
1759 (if vm-message-pointer
|
|
|
1760 (save-excursion
|
|
|
1761 (vm-save-restriction
|
|
|
1762 (widen)
|
|
|
1763 (let ((old-buffer-modified-p (buffer-modified-p))
|
|
|
1764 (case-fold-search t)
|
|
|
1765 ;; This prevents file locking from occuring. Disabling
|
|
|
1766 ;; locking can speed things noticeably if the lock
|
|
|
1767 ;; directory is on a slow device. We don't need locking
|
|
|
1768 ;; here because the user shouldn't care about VM stuffing
|
|
|
1769 ;; its own status headers.
|
|
|
1770 (buffer-file-name nil)
|
|
|
1771 (buffer-read-only nil)
|
|
|
1772 lim)
|
|
|
1773 (if (eq vm-folder-type 'babyl)
|
|
|
1774 (progn
|
|
|
1775 (goto-char (point-min))
|
|
|
1776 (vm-skip-past-folder-header)
|
|
|
1777 (delete-region (point) (point-min))
|
|
|
1778 (insert-before-markers (vm-folder-header vm-folder-type
|
|
|
1779 vm-label-obarray))))
|
|
|
1780 (goto-char (point-min))
|
|
|
1781 (vm-skip-past-folder-header)
|
|
|
1782 (vm-find-leading-message-separator)
|
|
|
1783 (vm-skip-past-leading-message-separator)
|
|
|
1784 (search-forward "\n\n" nil t)
|
|
|
1785 (setq lim (point))
|
|
|
1786 (goto-char (point-min))
|
|
|
1787 (vm-skip-past-folder-header)
|
|
|
1788 (vm-find-leading-message-separator)
|
|
|
1789 (vm-skip-past-leading-message-separator)
|
|
|
1790 (while (re-search-forward vm-labels-header-regexp lim t)
|
|
|
1791 (progn (goto-char (match-beginning 0))
|
|
|
1792 (if (vm-match-header vm-labels-header)
|
|
|
1793 (delete-region (vm-matched-header-start)
|
|
|
1794 (vm-matched-header-end)))))
|
|
|
1795 ;; To insert or to insert-before-markers, that is the question.
|
|
|
1796 ;;
|
|
|
1797 ;; If we insert-before-markers we push a header behind
|
|
|
1798 ;; vm-headers-of, which is clearly undesirable. So we
|
|
|
1799 ;; just insert. This will cause the summary header
|
|
|
1800 ;; to be visible if there are no non-visible headers,
|
|
|
1801 ;; oh well, no way around this.
|
|
|
1802 (insert vm-labels-header " "
|
|
|
1803 (let ((print-escape-newlines t)
|
|
|
1804 (list nil))
|
|
|
1805 (mapatoms (function
|
|
|
1806 (lambda (sym)
|
|
|
1807 (setq list (cons (symbol-name sym) list))))
|
|
|
1808 vm-label-obarray)
|
|
|
1809 (prin1-to-string list))
|
|
|
1810 "\n")
|
|
|
1811 (set-buffer-modified-p old-buffer-modified-p))))))
|
|
|
1812
|
|
|
1813 ;; Insert a bookmark into the first message in the folder.
|
|
|
1814 (defun vm-stuff-bookmark ()
|
|
|
1815 (if vm-message-pointer
|
|
|
1816 (save-excursion
|
|
|
1817 (vm-save-restriction
|
|
|
1818 (widen)
|
|
|
1819 (let ((old-buffer-modified-p (buffer-modified-p))
|
|
|
1820 (case-fold-search t)
|
|
|
1821 ;; This prevents file locking from occuring. Disabling
|
|
|
1822 ;; locking can speed things noticeably if the lock
|
|
|
1823 ;; directory is on a slow device. We don't need locking
|
|
|
1824 ;; here because the user shouldn't care about VM stuffing
|
|
|
1825 ;; its own status headers.
|
|
|
1826 (buffer-file-name nil)
|
|
|
1827 (buffer-read-only nil)
|
|
|
1828 lim)
|
|
|
1829 (goto-char (point-min))
|
|
|
1830 (vm-skip-past-folder-header)
|
|
|
1831 (vm-find-leading-message-separator)
|
|
|
1832 (vm-skip-past-leading-message-separator)
|
|
|
1833 (search-forward "\n\n" nil t)
|
|
|
1834 (setq lim (point))
|
|
|
1835 (goto-char (point-min))
|
|
|
1836 (vm-skip-past-folder-header)
|
|
|
1837 (vm-find-leading-message-separator)
|
|
|
1838 (vm-skip-past-leading-message-separator)
|
|
|
1839 (if (re-search-forward vm-bookmark-header-regexp lim t)
|
|
|
1840 (progn (goto-char (match-beginning 0))
|
|
|
1841 (if (vm-match-header vm-bookmark-header)
|
|
|
1842 (delete-region (vm-matched-header-start)
|
|
|
1843 (vm-matched-header-end)))))
|
|
|
1844 ;; To insert or to insert-before-markers, that is the question.
|
|
|
1845 ;;
|
|
|
1846 ;; If we insert-before-markers we push a header behind
|
|
|
1847 ;; vm-headers-of, which is clearly undesirable. So we
|
|
|
1848 ;; just insert. This will cause the bookmark header
|
|
|
1849 ;; to be visible if there are no non-visible headers,
|
|
|
1850 ;; oh well, no way around this.
|
|
|
1851 (insert vm-bookmark-header " "
|
|
|
1852 (vm-number-of (car vm-message-pointer))
|
|
|
1853 "\n")
|
|
|
1854 (set-buffer-modified-p old-buffer-modified-p))))))
|
|
|
1855
|
|
|
1856 ;; Insert the summary format variable header into the first message.
|
|
|
1857 (defun vm-stuff-summary ()
|
|
|
1858 (if vm-message-pointer
|
|
|
1859 (save-excursion
|
|
|
1860 (vm-save-restriction
|
|
|
1861 (widen)
|
|
|
1862 (let ((old-buffer-modified-p (buffer-modified-p))
|
|
|
1863 (case-fold-search t)
|
|
|
1864 ;; This prevents file locking from occuring. Disabling
|
|
|
1865 ;; locking can speed things noticeably if the lock
|
|
|
1866 ;; directory is on a slow device. We don't need locking
|
|
|
1867 ;; here because the user shouldn't care about VM stuffing
|
|
|
1868 ;; its own status headers.
|
|
|
1869 (buffer-file-name nil)
|
|
|
1870 (buffer-read-only nil)
|
|
|
1871 lim)
|
|
|
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 (search-forward "\n\n" nil t)
|
|
|
1877 (setq lim (point))
|
|
|
1878 (goto-char (point-min))
|
|
|
1879 (vm-skip-past-folder-header)
|
|
|
1880 (vm-find-leading-message-separator)
|
|
|
1881 (vm-skip-past-leading-message-separator)
|
|
|
1882 (while (re-search-forward vm-summary-header-regexp lim t)
|
|
|
1883 (progn (goto-char (match-beginning 0))
|
|
|
1884 (if (vm-match-header vm-summary-header)
|
|
|
1885 (delete-region (vm-matched-header-start)
|
|
|
1886 (vm-matched-header-end)))))
|
|
|
1887 ;; To insert or to insert-before-markers, that is the question.
|
|
|
1888 ;;
|
|
|
1889 ;; If we insert-before-markers we push a header behind
|
|
|
1890 ;; vm-headers-of, which is clearly undesirable. So we
|
|
|
1891 ;; just insert. This will cause the summary header
|
|
|
1892 ;; to be visible if there are no non-visible headers,
|
|
|
1893 ;; oh well, no way around this.
|
|
|
1894 (insert vm-summary-header " "
|
|
|
1895 (let ((print-escape-newlines t))
|
|
|
1896 (prin1-to-string vm-summary-format))
|
|
|
1897 "\n")
|
|
|
1898 (set-buffer-modified-p old-buffer-modified-p))))))
|
|
|
1899
|
|
|
1900 ;; stuff the current values of the header variables for future messages.
|
|
|
1901 (defun vm-stuff-header-variables ()
|
|
|
1902 (if vm-message-pointer
|
|
|
1903 (save-excursion
|
|
|
1904 (vm-save-restriction
|
|
|
1905 (widen)
|
|
|
1906 (let ((old-buffer-modified-p (buffer-modified-p))
|
|
|
1907 (case-fold-search t)
|
|
|
1908 (print-escape-newlines t)
|
|
|
1909 lim
|
|
|
1910 (buffer-read-only nil)
|
|
|
1911 ;; This prevents file locking from occuring. Disabling
|
|
|
1912 ;; locking can speed things noticeably if the lock
|
|
|
1913 ;; directory is on a slow device. We don't need locking
|
|
|
1914 ;; here because the user shouldn't care about VM stuffing
|
|
|
1915 ;; its own status headers.
|
|
|
1916 (buffer-file-name nil))
|
|
|
1917 (goto-char (point-min))
|
|
|
1918 (vm-skip-past-folder-header)
|
|
|
1919 (vm-find-leading-message-separator)
|
|
|
1920 (vm-skip-past-leading-message-separator)
|
|
|
1921 (search-forward "\n\n" nil t)
|
|
|
1922 (setq lim (point))
|
|
|
1923 (goto-char (point-min))
|
|
|
1924 (vm-skip-past-folder-header)
|
|
|
1925 (vm-find-leading-message-separator)
|
|
|
1926 (vm-skip-past-leading-message-separator)
|
|
|
1927 (while (re-search-forward vm-vheader-header-regexp lim t)
|
|
|
1928 (progn (goto-char (match-beginning 0))
|
|
|
1929 (if (vm-match-header vm-vheader-header)
|
|
|
1930 (delete-region (vm-matched-header-start)
|
|
|
1931 (vm-matched-header-end)))))
|
|
|
1932 ;; To insert or to insert-before-markers, that is the question.
|
|
|
1933 ;;
|
|
|
1934 ;; If we insert-before-markers we push a header behind
|
|
|
1935 ;; vm-headers-of, which is clearly undesirable. So we
|
|
|
1936 ;; just insert. This header will be visible if there
|
|
|
1937 ;; are no non-visible headers, oh well, no way around this.
|
|
|
1938 (insert vm-vheader-header " "
|
|
|
1939 (prin1-to-string vm-visible-headers) " "
|
|
|
1940 (prin1-to-string vm-invisible-header-regexp)
|
|
|
1941 "\n")
|
|
|
1942 (set-buffer-modified-p old-buffer-modified-p))))))
|
|
|
1943
|
|
|
1944 ;; Insert a header into the first message of the folder that lists
|
|
|
1945 ;; the folder's message order.
|
|
|
1946 (defun vm-stuff-message-order ()
|
|
|
1947 (if (cdr vm-message-list)
|
|
|
1948 (save-excursion
|
|
|
1949 (vm-save-restriction
|
|
|
1950 (widen)
|
|
|
1951 (let ((old-buffer-modified-p (buffer-modified-p))
|
|
|
1952 (case-fold-search t)
|
|
|
1953 ;; This prevents file locking from occuring. Disabling
|
|
|
1954 ;; locking can speed things noticeably if the lock
|
|
|
1955 ;; directory is on a slow device. We don't need locking
|
|
|
1956 ;; here because the user shouldn't care about VM stuffing
|
|
|
1957 ;; its own status headers.
|
|
|
1958 (buffer-file-name nil)
|
|
|
1959 lim n
|
|
|
1960 (buffer-read-only nil)
|
|
|
1961 (mp (copy-sequence vm-message-list)))
|
|
|
1962 (setq mp
|
|
|
1963 (sort mp
|
|
|
1964 (function
|
|
|
1965 (lambda (p q)
|
|
|
1966 (< (vm-start-of p) (vm-start-of q))))))
|
|
|
1967 (goto-char (point-min))
|
|
|
1968 (vm-skip-past-folder-header)
|
|
|
1969 (vm-find-leading-message-separator)
|
|
|
1970 (vm-skip-past-leading-message-separator)
|
|
|
1971 (search-forward "\n\n" nil t)
|
|
|
1972 (setq lim (point))
|
|
|
1973 (goto-char (point-min))
|
|
|
1974 (vm-skip-past-folder-header)
|
|
|
1975 (vm-find-leading-message-separator)
|
|
|
1976 (vm-skip-past-leading-message-separator)
|
|
|
1977 (while (re-search-forward vm-message-order-header-regexp lim t)
|
|
|
1978 (progn (goto-char (match-beginning 0))
|
|
|
1979 (if (vm-match-header vm-message-order-header)
|
|
|
1980 (delete-region (vm-matched-header-start)
|
|
|
1981 (vm-matched-header-end)))))
|
|
|
1982 ;; To insert or to insert-before-markers, that is the question.
|
|
|
1983 ;;
|
|
|
1984 ;; If we insert-before-markers we push a header behind
|
|
|
1985 ;; vm-headers-of, which is clearly undesirable. So we
|
|
|
1986 ;; just insert. This header will be visible if there
|
|
|
1987 ;; are no non-visible headers, oh well, no way around this.
|
|
|
1988 (insert vm-message-order-header "\n\t(")
|
|
|
1989 (setq n 0)
|
|
|
1990 (while mp
|
|
|
1991 (insert (vm-number-of (car mp)))
|
|
|
1992 (setq n (1+ n) mp (cdr mp))
|
|
|
1993 (and mp (insert
|
|
|
1994 (if (zerop (% n 15))
|
|
|
1995 "\n\t "
|
|
|
1996 " "))))
|
|
|
1997 (insert ")\n")
|
|
|
1998 (setq vm-message-order-changed nil
|
|
|
1999 vm-message-order-header-present t)
|
|
|
2000 (set-buffer-modified-p old-buffer-modified-p))))))
|
|
|
2001
|
|
|
2002 ;; Remove the message order header.
|
|
|
2003 (defun vm-remove-message-order ()
|
|
|
2004 (if (cdr vm-message-list)
|
|
|
2005 (save-excursion
|
|
|
2006 (vm-save-restriction
|
|
|
2007 (widen)
|
|
|
2008 (let ((old-buffer-modified-p (buffer-modified-p))
|
|
|
2009 (case-fold-search t)
|
|
|
2010 lim
|
|
|
2011 ;; This prevents file locking from occuring. Disabling
|
|
|
2012 ;; locking can speed things noticeably if the lock
|
|
|
2013 ;; directory is on a slow device. We don't need locking
|
|
|
2014 ;; here because the user shouldn't care about VM stuffing
|
|
|
2015 ;; its own status headers.
|
|
|
2016 (buffer-file-name nil)
|
|
|
2017 (buffer-read-only nil))
|
|
|
2018 (goto-char (point-min))
|
|
|
2019 (vm-skip-past-folder-header)
|
|
|
2020 (vm-skip-past-leading-message-separator)
|
|
|
2021 (search-forward "\n\n" nil t)
|
|
|
2022 (setq lim (point))
|
|
|
2023 (goto-char (point-min))
|
|
|
2024 (vm-skip-past-folder-header)
|
|
|
2025 (vm-skip-past-leading-message-separator)
|
|
|
2026 (while (re-search-forward vm-message-order-header-regexp lim t)
|
|
|
2027 (progn (goto-char (match-beginning 0))
|
|
|
2028 (if (vm-match-header vm-message-order-header)
|
|
|
2029 (delete-region (vm-matched-header-start)
|
|
|
2030 (vm-matched-header-end)))))
|
|
|
2031 (setq vm-message-order-header-present nil)
|
|
|
2032 (set-buffer-modified-p old-buffer-modified-p))))))
|
|
|
2033
|
|
|
2034 (defun vm-change-all-new-to-unread ()
|
|
|
2035 (let ((mp vm-message-list))
|
|
|
2036 (while mp
|
|
|
2037 (if (vm-new-flag (car mp))
|
|
|
2038 (progn
|
|
|
2039 (vm-set-new-flag (car mp) nil)
|
|
|
2040 (vm-set-unread-flag (car mp) t)))
|
|
|
2041 (setq mp (cdr mp)))))
|
|
|
2042
|
|
|
2043 (defun vm-unread-message (&optional count)
|
|
|
2044 "Set the `unread' attribute for the current message. If the message is
|
|
|
2045 already new or unread, then it is left unchanged.
|
|
|
2046
|
|
|
2047 Numeric prefix argument N means to unread the current message plus the
|
|
|
2048 next N-1 messages. A negative N means unread the current message and
|
|
|
2049 the previous N-1 messages.
|
|
|
2050
|
|
|
2051 When invoked on marked messages (via vm-next-command-uses-marks),
|
|
|
2052 all marked messages are affected, other messages are ignored."
|
|
|
2053 (interactive "p")
|
|
|
2054 (or count (setq count 1))
|
|
|
2055 (vm-follow-summary-cursor)
|
|
|
2056 (vm-select-folder-buffer)
|
|
|
2057 (vm-check-for-killed-summary)
|
|
|
2058 (vm-error-if-folder-empty)
|
|
|
2059 (let ((mlist (vm-select-marked-or-prefixed-messages count)))
|
|
|
2060 (while mlist
|
|
|
2061 (if (and (not (vm-unread-flag (car mlist)))
|
|
|
2062 (not (vm-new-flag (car mlist))))
|
|
|
2063 (vm-set-unread-flag (car mlist) t))
|
|
|
2064 (setq mlist (cdr mlist))))
|
|
|
2065 (vm-display nil nil '(vm-unread-message) '(vm-unread-message))
|
|
|
2066 (vm-update-summary-and-mode-line))
|
|
|
2067
|
|
|
2068 (defun vm-quit-just-bury ()
|
|
|
2069 "Bury the current VM folder and summary buffers.
|
|
|
2070 The folder is not altered and Emacs is still visiting it. You
|
|
|
2071 can switch back to it with switch-to-buffer or by using the
|
|
|
2072 Buffer Menu."
|
|
|
2073 (interactive)
|
|
|
2074 (vm-select-folder-buffer)
|
|
|
2075 (if (not (memq major-mode '(vm-mode vm-virtual-mode)))
|
|
|
2076 (error "%s must be invoked from a VM buffer." this-command))
|
|
|
2077 (vm-check-for-killed-summary)
|
|
98
|
2078 (vm-check-for-killed-presentation)
|
|
0
|
2079
|
|
98
|
2080 (save-excursion (run-hooks 'vm-quit-hook))
|
|
|
2081
|
|
|
2082 (vm-garbage-collect-message)
|
|
0
|
2083
|
|
|
2084 (vm-display nil nil '(vm-quit-just-bury)
|
|
|
2085 '(vm-quit-just-bury quitting))
|
|
|
2086 (if vm-summary-buffer
|
|
|
2087 (vm-display vm-summary-buffer nil nil nil))
|
|
|
2088 (if vm-summary-buffer
|
|
|
2089 (vm-bury-buffer vm-summary-buffer))
|
|
98
|
2090 (if vm-presentation-buffer-handle
|
|
|
2091 (vm-display vm-presentation-buffer-handle nil nil nil))
|
|
|
2092 (if vm-presentation-buffer-handle
|
|
|
2093 (vm-bury-buffer vm-presentation-buffer-handle))
|
|
0
|
2094 (vm-display (current-buffer) nil nil nil)
|
|
|
2095 (vm-bury-buffer (current-buffer)))
|
|
|
2096
|
|
|
2097 (defun vm-quit-just-iconify ()
|
|
|
2098 "Iconify the frame and bury the current VM folder and summary buffers.
|
|
|
2099 The folder is not altered and Emacs is still visiting it."
|
|
|
2100 (interactive)
|
|
|
2101 (vm-select-folder-buffer)
|
|
|
2102 (if (not (memq major-mode '(vm-mode vm-virtual-mode)))
|
|
|
2103 (error "%s must be invoked from a VM buffer." this-command))
|
|
|
2104 (vm-check-for-killed-summary)
|
|
98
|
2105 (vm-check-for-killed-presentation)
|
|
0
|
2106
|
|
98
|
2107 (save-excursion (run-hooks 'vm-quit-hook))
|
|
|
2108
|
|
|
2109 (vm-garbage-collect-message)
|
|
0
|
2110
|
|
|
2111 (vm-display nil nil '(vm-quit-just-iconify)
|
|
|
2112 '(vm-quit-just-iconify quitting))
|
|
98
|
2113 (let ((summary-buffer vm-summary-buffer)
|
|
|
2114 (pres-buffer vm-presentation-buffer-handle))
|
|
|
2115 (vm-bury-buffer (current-buffer))
|
|
|
2116 (if summary-buffer
|
|
|
2117 (vm-bury-buffer summary-buffer))
|
|
|
2118 (if pres-buffer
|
|
|
2119 (vm-bury-buffer pres-buffer))
|
|
|
2120 (vm-iconify-frame)))
|
|
0
|
2121
|
|
|
2122 (defun vm-quit-no-change ()
|
|
76
|
2123 "Quit visiting the current folder without saving changes made to the folder."
|
|
0
|
2124 (interactive)
|
|
|
2125 (vm-quit t))
|
|
|
2126
|
|
|
2127 (defun vm-quit (&optional no-change)
|
|
76
|
2128 "Quit visiting the current folder, saving changes. Deleted messages are not expunged."
|
|
0
|
2129 (interactive)
|
|
|
2130 (vm-select-folder-buffer)
|
|
|
2131 (if (not (memq major-mode '(vm-mode vm-virtual-mode)))
|
|
|
2132 (error "%s must be invoked from a VM buffer." this-command))
|
|
|
2133 (vm-check-for-killed-summary)
|
|
98
|
2134 (vm-check-for-killed-presentation)
|
|
0
|
2135 (vm-display nil nil '(vm-quit vm-quit-no-change)
|
|
|
2136 (list this-command 'quitting))
|
|
|
2137 (let ((virtual (eq major-mode 'vm-virtual-mode)))
|
|
|
2138 (cond
|
|
|
2139 ((and (not virtual) no-change (buffer-modified-p)
|
|
98
|
2140 (or buffer-file-name buffer-offer-save)
|
|
0
|
2141 (not (zerop vm-messages-not-on-disk))
|
|
|
2142 ;; Folder may have been saved with C-x C-s and attributes may have
|
|
|
2143 ;; been changed after that; in that case vm-messages-not-on-disk
|
|
|
2144 ;; would not have been zeroed. However, all modification flag
|
|
|
2145 ;; undos are cleared if VM actually modifies the folder buffer
|
|
|
2146 ;; (as opposed to the folder's attributes), so this can be used
|
|
|
2147 ;; to verify that there are indeed unsaved messages.
|
|
|
2148 (null (assq 'vm-set-buffer-modified-p vm-undo-record-list))
|
|
|
2149 (not
|
|
|
2150 (y-or-n-p
|
|
|
2151 (format
|
|
|
2152 "%d message%s have not been saved to disk, quit anyway? "
|
|
|
2153 vm-messages-not-on-disk
|
|
|
2154 (if (= 1 vm-messages-not-on-disk) "" "s")))))
|
|
|
2155 (error "Aborted"))
|
|
|
2156 ((and (not virtual)
|
|
98
|
2157 no-change
|
|
|
2158 (or buffer-file-name buffer-offer-save)
|
|
|
2159 (buffer-modified-p)
|
|
|
2160 vm-confirm-quit
|
|
0
|
2161 (not (y-or-n-p "There are unsaved changes, quit anyway? ")))
|
|
|
2162 (error "Aborted"))
|
|
|
2163 ((and (eq vm-confirm-quit t)
|
|
|
2164 (not (y-or-n-p "Do you really want to quit? ")))
|
|
|
2165 (error "Aborted")))
|
|
|
2166
|
|
98
|
2167 (save-excursion (run-hooks 'vm-quit-hook))
|
|
|
2168
|
|
|
2169 (vm-garbage-collect-message)
|
|
|
2170 (vm-garbage-collect-folder)
|
|
0
|
2171
|
|
|
2172 (vm-virtual-quit)
|
|
|
2173 (if (and (not no-change) (not virtual))
|
|
|
2174 (progn
|
|
|
2175 ;; this could take a while, so give the user some feedback
|
|
102
|
2176 (message "Quitting...")
|
|
0
|
2177 (or vm-folder-read-only (eq major-mode 'vm-virtual-mode)
|
|
|
2178 (vm-change-all-new-to-unread))))
|
|
98
|
2179 (if (and (buffer-modified-p)
|
|
|
2180 (or buffer-file-name buffer-offer-save)
|
|
|
2181 (not no-change)
|
|
|
2182 (not virtual))
|
|
0
|
2183 (vm-save-folder))
|
|
102
|
2184 (message "")
|
|
0
|
2185 (let ((summary-buffer vm-summary-buffer)
|
|
98
|
2186 (pres-buffer vm-presentation-buffer-handle)
|
|
0
|
2187 (mail-buffer (current-buffer)))
|
|
|
2188 (if summary-buffer
|
|
|
2189 (progn
|
|
98
|
2190 (vm-display summary-buffer nil nil nil)
|
|
0
|
2191 (kill-buffer summary-buffer)))
|
|
98
|
2192 (if pres-buffer
|
|
|
2193 (progn
|
|
|
2194 (vm-display pres-buffer nil nil nil)
|
|
|
2195 (kill-buffer pres-buffer)))
|
|
0
|
2196 (set-buffer mail-buffer)
|
|
|
2197 (vm-display mail-buffer nil nil nil)
|
|
|
2198 ;; vm-display is not supposed to change the current buffer.
|
|
98
|
2199 ;; still it's better to be safe here.
|
|
0
|
2200 (set-buffer mail-buffer)
|
|
|
2201 (set-buffer-modified-p nil)
|
|
|
2202 (kill-buffer (current-buffer)))
|
|
|
2203 (vm-update-summary-and-mode-line)))
|
|
|
2204
|
|
|
2205 (defun vm-start-itimers-if-needed ()
|
|
98
|
2206 (cond ((and (not (natnump vm-flush-interval))
|
|
100
|
2207 (not (natnump vm-auto-get-new-mail))
|
|
|
2208 (not (natnump vm-mail-check-interval))))
|
|
98
|
2209 ((condition-case data
|
|
|
2210 (progn (require 'itimer) t)
|
|
|
2211 (error nil))
|
|
|
2212 (and (natnump vm-flush-interval) (not (get-itimer "vm-flush"))
|
|
|
2213 (start-itimer "vm-flush" 'vm-flush-itimer-function
|
|
|
2214 vm-flush-interval nil))
|
|
|
2215 (and (natnump vm-auto-get-new-mail) (not (get-itimer "vm-get-mail"))
|
|
|
2216 (start-itimer "vm-get-mail" 'vm-get-mail-itimer-function
|
|
100
|
2217 vm-auto-get-new-mail nil))
|
|
|
2218 (and (natnump vm-mail-check-interval)
|
|
|
2219 (not (get-itimer "vm-check-mail"))
|
|
|
2220 (start-itimer "vm-check-mail" 'vm-check-mail-itimer-function
|
|
|
2221 vm-mail-check-interval nil)))
|
|
98
|
2222 ((condition-case data
|
|
|
2223 (progn (require 'timer) t)
|
|
|
2224 (error nil))
|
|
|
2225 (let (timer)
|
|
|
2226 (and (natnump vm-flush-interval)
|
|
118
|
2227 (not (vm-timer-using 'vm-flush-itimer-function))
|
|
98
|
2228 (setq timer (run-at-time vm-flush-interval vm-flush-interval
|
|
|
2229 'vm-flush-itimer-function nil))
|
|
|
2230 (timer-set-function timer 'vm-flush-itimer-function
|
|
|
2231 (list timer)))
|
|
100
|
2232 (and (natnump vm-mail-check-interval)
|
|
118
|
2233 (not (vm-timer-using 'vm-check-mail-itimer-function))
|
|
100
|
2234 (setq timer (run-at-time vm-mail-check-interval
|
|
|
2235 vm-mail-check-interval
|
|
|
2236 'vm-check-mail-itimer-function nil))
|
|
|
2237 (timer-set-function timer 'vm-check-mail-itimer-function
|
|
|
2238 (list timer)))
|
|
98
|
2239 (and (natnump vm-auto-get-new-mail)
|
|
118
|
2240 (not (vm-timer-using 'vm-get-mail-itimer-function))
|
|
98
|
2241 (setq timer (run-at-time vm-auto-get-new-mail
|
|
|
2242 vm-auto-get-new-mail
|
|
|
2243 'vm-get-mail-itimer-function nil))
|
|
|
2244 (timer-set-function timer 'vm-get-mail-itimer-function
|
|
|
2245 (list timer)))))
|
|
|
2246 (t
|
|
|
2247 (setq vm-flush-interval t
|
|
|
2248 vm-auto-get-new-mail t))))
|
|
0
|
2249
|
|
118
|
2250 (defun vm-timer-using (fun)
|
|
|
2251 (let ((p timer-list)
|
|
|
2252 (done nil))
|
|
|
2253 (while (and p (not done))
|
|
|
2254 (if (eq (aref (car p) 5) fun)
|
|
|
2255 (setq done t)
|
|
|
2256 (setq p (cdr p))))
|
|
|
2257 p ))
|
|
|
2258
|
|
100
|
2259 ;; support for vm-mail-check-interval
|
|
|
2260 ;; if timer argument is present, this means we're using the Emacs
|
|
|
2261 ;; 'timer package rather than the 'itimer package.
|
|
|
2262 (defun vm-check-mail-itimer-function (&optional timer)
|
|
|
2263 ;; FSF Emacs sets this non-nil, which means the user can't
|
|
|
2264 ;; interrupt the check. Bogus.
|
|
|
2265 (setq inhibit-quit nil)
|
|
|
2266 (if (integerp vm-mail-check-interval)
|
|
|
2267 (if timer
|
|
|
2268 (timer-set-time timer (current-time) vm-mail-check-interval)
|
|
102
|
2269 (set-itimer-restart current-itimer vm-mail-check-interval))
|
|
108
|
2270 ;; user has changed the variable value to something that
|
|
102
|
2271 ;; isn't a number, make the timer go away.
|
|
|
2272 (if timer
|
|
|
2273 (cancel-timer timer)
|
|
|
2274 (set-itimer-restart current-itimer nil)))
|
|
100
|
2275 (let ((b-list (buffer-list))
|
|
102
|
2276 (found-one nil)
|
|
100
|
2277 oldval)
|
|
|
2278 (while (and (not (input-pending-p)) b-list)
|
|
|
2279 (save-excursion
|
|
|
2280 (set-buffer (car b-list))
|
|
|
2281 (if (and (eq major-mode 'vm-mode)
|
|
102
|
2282 (setq found-one t)
|
|
108
|
2283 ;; to avoid reentrance into the pop code
|
|
|
2284 (not vm-block-new-mail)
|
|
|
2285 ;; Don't bother checking if we already know from
|
|
|
2286 ;; a previous check that there's mail waiting
|
|
|
2287 ;; and the user hasn't retrieved it yet. Not
|
|
|
2288 ;; completely accurate, but saves network
|
|
|
2289 ;; connection build and tear down which is slow
|
|
|
2290 ;; for some users.
|
|
|
2291 (not vm-spooled-mail-waiting))
|
|
100
|
2292 (progn
|
|
|
2293 (setq oldval vm-spooled-mail-waiting)
|
|
|
2294 (vm-check-for-spooled-mail nil)
|
|
|
2295 (if (not (eq oldval vm-spooled-mail-waiting))
|
|
|
2296 (progn
|
|
|
2297 (intern (buffer-name) vm-buffers-needing-display-update)
|
|
|
2298 (vm-update-summary-and-mode-line))))))
|
|
102
|
2299 (setq b-list (cdr b-list)))
|
|
|
2300 ;; make the timer go away if we didn't encounter a vm-mode buffer.
|
|
|
2301 (if (and (not found-one) (null b-list))
|
|
|
2302 (if timer
|
|
|
2303 (cancel-timer timer)
|
|
|
2304 (set-itimer-restart current-itimer nil)))))
|
|
100
|
2305
|
|
70
|
2306 ;; support for numeric vm-auto-get-new-mail
|
|
98
|
2307 ;; if timer argument is present, this means we're using the Emacs
|
|
|
2308 ;; 'timer package rather than the 'itimer package.
|
|
|
2309 (defun vm-get-mail-itimer-function (&optional timer)
|
|
100
|
2310 ;; FSF Emacs sets this non-nil, which means the user can't
|
|
|
2311 ;; interrupt mail retrieval. Bogus.
|
|
|
2312 (setq inhibit-quit nil)
|
|
70
|
2313 (if (integerp vm-auto-get-new-mail)
|
|
98
|
2314 (if timer
|
|
|
2315 (timer-set-time timer (current-time) vm-auto-get-new-mail)
|
|
102
|
2316 (set-itimer-restart current-itimer vm-auto-get-new-mail))
|
|
108
|
2317 ;; user has changed the variable value to something that
|
|
102
|
2318 ;; isn't a number, make the timer go away.
|
|
|
2319 (if timer
|
|
|
2320 (cancel-timer timer)
|
|
|
2321 (set-itimer-restart current-itimer nil)))
|
|
|
2322 (let ((b-list (buffer-list))
|
|
|
2323 (found-one nil))
|
|
24
|
2324 (while (and (not (input-pending-p)) b-list)
|
|
|
2325 (save-excursion
|
|
|
2326 (set-buffer (car b-list))
|
|
|
2327 (if (and (eq major-mode 'vm-mode)
|
|
102
|
2328 (setq found-one t)
|
|
0
|
2329 (not (and (not (buffer-modified-p))
|
|
|
2330 buffer-file-name
|
|
|
2331 (file-newer-than-file-p
|
|
|
2332 (make-auto-save-file-name)
|
|
|
2333 buffer-file-name)))
|
|
|
2334 (not vm-block-new-mail)
|
|
|
2335 (not vm-folder-read-only)
|
|
100
|
2336 (vm-get-spooled-mail nil)
|
|
0
|
2337 (vm-assimilate-new-messages t))
|
|
|
2338 (progn
|
|
|
2339 ;; don't move the message pointer unless the folder
|
|
|
2340 ;; was empty.
|
|
|
2341 (if (and (null vm-message-pointer)
|
|
|
2342 (vm-thoughtfully-select-message))
|
|
|
2343 (vm-preview-current-message)
|
|
|
2344 (vm-update-summary-and-mode-line)))))
|
|
102
|
2345 (setq b-list (cdr b-list)))
|
|
|
2346 ;; make the timer go away if we didn't encounter a vm-mode buffer.
|
|
|
2347 (if (and (not found-one) (null b-list))
|
|
|
2348 (if timer
|
|
|
2349 (cancel-timer timer)
|
|
|
2350 (set-itimer-restart current-itimer nil)))))
|
|
0
|
2351
|
|
|
2352 ;; support for numeric vm-flush-interval
|
|
98
|
2353 ;; if timer argument is present, this means we're using the Emacs
|
|
|
2354 ;; 'timer package rather than the 'itimer package.
|
|
|
2355 (defun vm-flush-itimer-function (&optional timer)
|
|
0
|
2356 (if (integerp vm-flush-interval)
|
|
98
|
2357 (if timer
|
|
|
2358 (timer-set-time timer (current-time) vm-flush-interval)
|
|
|
2359 (set-itimer-restart current-itimer vm-flush-interval)))
|
|
0
|
2360 ;; if no vm-mode buffers are found, we might as well shut down the
|
|
|
2361 ;; flush itimer.
|
|
|
2362 (if (not (vm-flush-cached-data))
|
|
98
|
2363 (if timer
|
|
|
2364 (cancel-timer timer)
|
|
|
2365 (set-itimer-restart current-itimer nil))))
|
|
0
|
2366
|
|
|
2367 ;; flush cached data in all vm-mode buffers.
|
|
|
2368 ;; returns non-nil if any vm-mode buffers were found.
|
|
|
2369 (defun vm-flush-cached-data ()
|
|
|
2370 (save-excursion
|
|
|
2371 (let ((buf-list (buffer-list))
|
|
|
2372 (found-one nil))
|
|
|
2373 (while (and buf-list (not (input-pending-p)))
|
|
|
2374 (set-buffer (car buf-list))
|
|
|
2375 (cond ((and (eq major-mode 'vm-mode) vm-message-list)
|
|
|
2376 (setq found-one t)
|
|
|
2377 (if (not (eq vm-modification-counter
|
|
|
2378 vm-flushed-modification-counter))
|
|
98
|
2379 (progn
|
|
0
|
2380 (vm-stuff-summary)
|
|
|
2381 (vm-stuff-labels)
|
|
|
2382 (and vm-message-order-changed
|
|
|
2383 (vm-stuff-message-order))
|
|
98
|
2384 (and (vm-stuff-folder-attributes t)
|
|
0
|
2385 (setq vm-flushed-modification-counter
|
|
|
2386 vm-modification-counter))))))
|
|
|
2387 (setq buf-list (cdr buf-list)))
|
|
|
2388 ;; if we haven't checked them all return non-nil so
|
|
|
2389 ;; the flusher won't give up trying.
|
|
|
2390 (or buf-list found-one) )))
|
|
|
2391
|
|
|
2392 ;; This allows C-x C-s to do the right thing for VM mail buffers.
|
|
|
2393 ;; Note that deleted messages are not expunged.
|
|
|
2394 (defun vm-write-file-hook ()
|
|
|
2395 (if (and (eq major-mode 'vm-mode) (not vm-inhibit-write-file-hook))
|
|
|
2396 ;; The vm-save-restriction isn't really necessary here, since
|
|
|
2397 ;; the stuff routines clean up after themselves, but should remain
|
|
|
2398 ;; as a safeguard against the time when other stuff is added here.
|
|
|
2399 (vm-save-restriction
|
|
98
|
2400 (let ((buffer-read-only))
|
|
|
2401 (vm-stuff-folder-attributes nil)
|
|
|
2402 (if vm-message-list
|
|
|
2403 (progn
|
|
|
2404 ;; get summary cache up-to-date
|
|
|
2405 (vm-update-summary-and-mode-line)
|
|
|
2406 (vm-stuff-bookmark)
|
|
|
2407 (vm-stuff-header-variables)
|
|
|
2408 (vm-stuff-labels)
|
|
|
2409 (vm-stuff-summary)
|
|
|
2410 (and vm-message-order-changed
|
|
|
2411 (vm-stuff-message-order))))
|
|
|
2412 nil ))))
|
|
0
|
2413
|
|
|
2414 (defun vm-save-buffer (prefix)
|
|
|
2415 (interactive "P")
|
|
|
2416 (vm-select-folder-buffer)
|
|
|
2417 (vm-error-if-virtual-folder)
|
|
|
2418 (save-buffer prefix)
|
|
|
2419 (intern (buffer-name) vm-buffers-needing-display-update)
|
|
|
2420 (setq vm-block-new-mail nil)
|
|
|
2421 (vm-display nil nil '(vm-save-buffer) '(vm-save-buffer))
|
|
|
2422 (vm-update-summary-and-mode-line))
|
|
|
2423
|
|
|
2424 (defun vm-write-file ()
|
|
|
2425 (interactive)
|
|
|
2426 (vm-select-folder-buffer)
|
|
|
2427 (vm-error-if-virtual-folder)
|
|
|
2428 (call-interactively 'write-file)
|
|
|
2429 (intern (buffer-name) vm-buffers-needing-display-update)
|
|
|
2430 (setq vm-block-new-mail nil)
|
|
|
2431 (vm-display nil nil '(vm-write-file) '(vm-write-file))
|
|
|
2432 (vm-update-summary-and-mode-line))
|
|
|
2433
|
|
|
2434 (defun vm-save-folder (&optional prefix)
|
|
|
2435 "Save current folder to disk.
|
|
|
2436 Deleted messages are not expunged.
|
|
|
2437 Prefix arg is handled the same as for the command save-buffer.
|
|
|
2438
|
|
|
2439 When applied to a virtual folder, this command runs itself on
|
|
|
2440 each of the underlying real folders associated with the virtual
|
|
|
2441 folder."
|
|
|
2442 (interactive (list current-prefix-arg))
|
|
|
2443 (vm-select-folder-buffer)
|
|
|
2444 (vm-check-for-killed-summary)
|
|
|
2445 (vm-display nil nil '(vm-save-folder) '(vm-save-folder))
|
|
|
2446 (if (eq major-mode 'vm-virtual-mode)
|
|
|
2447 (vm-virtual-save-folder prefix)
|
|
|
2448 (if (buffer-modified-p)
|
|
98
|
2449 (let (mp (newlist nil))
|
|
0
|
2450 ;; stuff the attributes of messages that need it.
|
|
102
|
2451 (message "Stuffing attributes...")
|
|
98
|
2452 (vm-stuff-folder-attributes nil)
|
|
0
|
2453 ;; stuff bookmark and header variable values
|
|
|
2454 (if vm-message-list
|
|
|
2455 (progn
|
|
|
2456 ;; get summary cache up-to-date
|
|
|
2457 (vm-update-summary-and-mode-line)
|
|
|
2458 (vm-stuff-bookmark)
|
|
|
2459 (vm-stuff-header-variables)
|
|
|
2460 (vm-stuff-labels)
|
|
|
2461 (vm-stuff-summary)
|
|
|
2462 (and vm-message-order-changed
|
|
|
2463 (vm-stuff-message-order))))
|
|
102
|
2464 (message "Saving...")
|
|
0
|
2465 (let ((vm-inhibit-write-file-hook t))
|
|
|
2466 (save-buffer prefix))
|
|
|
2467 (vm-set-buffer-modified-p nil)
|
|
|
2468 (vm-clear-modification-flag-undos)
|
|
|
2469 (setq vm-messages-not-on-disk 0)
|
|
|
2470 (setq vm-block-new-mail nil)
|
|
|
2471 (and (zerop (buffer-size))
|
|
|
2472 vm-delete-empty-folders
|
|
|
2473 buffer-file-name
|
|
|
2474 (or (eq vm-delete-empty-folders t)
|
|
|
2475 (y-or-n-p (format "%s is empty, remove it? "
|
|
|
2476 (or buffer-file-name (buffer-name)))))
|
|
|
2477 (condition-case ()
|
|
|
2478 (progn
|
|
|
2479 (delete-file buffer-file-name)
|
|
114
|
2480 (clear-visited-file-modtime)
|
|
0
|
2481 (message "%s removed" buffer-file-name))
|
|
|
2482 ;; no can do, oh well.
|
|
|
2483 (error nil)))
|
|
|
2484 (vm-update-summary-and-mode-line))
|
|
|
2485 (message "No changes need to be saved"))))
|
|
|
2486
|
|
|
2487 (defun vm-save-and-expunge-folder (&optional prefix)
|
|
|
2488 "Expunge folder, then save it to disk.
|
|
|
2489 Prefix arg is handled the same as for the command save-buffer.
|
|
|
2490 Expunge won't be done if folder is read-only.
|
|
|
2491
|
|
|
2492 When applied to a virtual folder, this command works as if you had
|
|
|
2493 run vm-expunge-folder followed by vm-save-folder."
|
|
|
2494 (interactive (list current-prefix-arg))
|
|
|
2495 (vm-select-folder-buffer)
|
|
|
2496 (vm-check-for-killed-summary)
|
|
|
2497 (vm-display nil nil '(vm-save-and-expunge-folder)
|
|
|
2498 '(vm-save-and-expunge-folder))
|
|
|
2499 (if (not vm-folder-read-only)
|
|
|
2500 (progn
|
|
102
|
2501 (message "Expunging...")
|
|
0
|
2502 (vm-expunge-folder t)))
|
|
|
2503 (vm-save-folder prefix))
|
|
|
2504
|
|
|
2505 (defun vm-handle-file-recovery-or-reversion (recovery)
|
|
|
2506 (if (and vm-summary-buffer (buffer-name vm-summary-buffer))
|
|
|
2507 (kill-buffer vm-summary-buffer))
|
|
|
2508 (vm-virtual-quit)
|
|
|
2509 ;; reset major mode, this will cause vm to start from scratch.
|
|
|
2510 (setq major-mode 'fundamental-mode)
|
|
|
2511 ;; If this is a recovery, we can't allow the user to get new
|
|
|
2512 ;; mail until a real save is performed. Until then the buffer
|
|
|
2513 ;; and the disk don't match.
|
|
|
2514 (if recovery
|
|
|
2515 (setq vm-block-new-mail t))
|
|
|
2516 (vm buffer-file-name))
|
|
|
2517
|
|
|
2518 ;; detect if a recover-file is being performed
|
|
|
2519 ;; and handle things properly.
|
|
|
2520 (defun vm-handle-file-recovery ()
|
|
|
2521 (if (and (buffer-modified-p)
|
|
|
2522 (eq major-mode 'vm-mode)
|
|
|
2523 vm-message-list
|
|
|
2524 (= (vm-end-of (car vm-message-list)) 1))
|
|
|
2525 (vm-handle-file-recovery-or-reversion t)))
|
|
|
2526
|
|
|
2527 ;; detect if a revert-buffer is being performed
|
|
|
2528 ;; and handle things properly.
|
|
|
2529 (defun vm-handle-file-reversion ()
|
|
|
2530 (if (and (not (buffer-modified-p))
|
|
|
2531 (eq major-mode 'vm-mode)
|
|
|
2532 vm-message-list
|
|
|
2533 (= (vm-end-of (car vm-message-list)) 1))
|
|
|
2534 (vm-handle-file-recovery-or-reversion nil)))
|
|
|
2535
|
|
|
2536 ;; FSF v19.23 revert-buffer doesn't mash all the markers together
|
|
|
2537 ;; like v18 and prior v19 versions, so the check in
|
|
|
2538 ;; vm-handle-file-reversion doesn't work. However v19.23 has a
|
|
|
2539 ;; hook we can use, after-revert-hook.
|
|
|
2540 (defun vm-after-revert-buffer-hook ()
|
|
|
2541 (if (eq major-mode 'vm-mode)
|
|
|
2542 (vm-handle-file-recovery-or-reversion nil)))
|
|
|
2543
|
|
|
2544 (defun vm-help ()
|
|
|
2545 "Display help for various VM activities."
|
|
|
2546 (interactive)
|
|
|
2547 (if (eq major-mode 'vm-summary-mode)
|
|
|
2548 (vm-select-folder-buffer))
|
|
|
2549 (let ((pop-up-windows (and pop-up-windows (eq vm-mutable-windows t)))
|
|
70
|
2550 (pop-up-frames vm-mutable-frames))
|
|
0
|
2551 (cond
|
|
|
2552 ((eq last-command 'vm-help)
|
|
|
2553 (describe-function major-mode))
|
|
|
2554 ((eq vm-system-state 'previewing)
|
|
|
2555 (message "Type SPC to read message, n previews next message (? gives more help)"))
|
|
|
2556 ((memq vm-system-state '(showing reading))
|
|
|
2557 (message "SPC and b scroll, (d)elete, (s)ave, (n)ext, (r)eply (? gives more help)"))
|
|
|
2558 ((eq vm-system-state 'editing)
|
|
|
2559 (message
|
|
|
2560 (substitute-command-keys
|
|
|
2561 "Type \\[vm-edit-message-end] to end edit, \\[vm-edit-message-abort] to abort with no change.")))
|
|
|
2562 ((eq major-mode 'mail-mode)
|
|
|
2563 (message
|
|
|
2564 (substitute-command-keys
|
|
70
|
2565 "Type \\[vm-mail-send-and-exit] to send message, \\[kill-buffer] to discard this message")))
|
|
0
|
2566 (t (describe-mode)))))
|
|
|
2567
|
|
|
2568 (defun vm-spool-move-mail (source destination)
|
|
|
2569 (let ((handler (and (fboundp 'find-file-name-handler)
|
|
|
2570 (condition-case ()
|
|
|
2571 (find-file-name-handler source 'vm-spool-move-mail)
|
|
|
2572 (wrong-number-of-arguments
|
|
|
2573 (find-file-name-handler source)))))
|
|
|
2574 status error-buffer)
|
|
|
2575 (if handler
|
|
|
2576 (funcall handler 'vm-spool-move-mail source destination)
|
|
|
2577 (setq error-buffer
|
|
|
2578 (get-buffer-create
|
|
|
2579 (format "*output of %s %s %s*"
|
|
|
2580 vm-movemail-program source destination)))
|
|
|
2581 (save-excursion
|
|
|
2582 (set-buffer error-buffer)
|
|
|
2583 (erase-buffer))
|
|
|
2584 (setq status
|
|
|
2585 (call-process vm-movemail-program nil error-buffer t
|
|
|
2586 source destination))
|
|
|
2587 (save-excursion
|
|
|
2588 (set-buffer error-buffer)
|
|
|
2589 (if (and (numberp status) (not (= 0 status)))
|
|
|
2590 (insert (format "\n%s exited with code %s\n"
|
|
|
2591 vm-movemail-program status)))
|
|
|
2592 (if (> (buffer-size) 0)
|
|
|
2593 (progn
|
|
|
2594 (vm-display-buffer error-buffer)
|
|
|
2595 (if (and (numberp status) (not (= 0 status)))
|
|
|
2596 (error "Failed getting new mail from %s" source)
|
|
|
2597 (message "Warning: unexpected output from %s"
|
|
|
2598 vm-movemail-program)
|
|
|
2599 (sleep-for 2)))
|
|
|
2600 ;; nag, nag, nag.
|
|
|
2601 (kill-buffer error-buffer))
|
|
|
2602 t ))))
|
|
|
2603
|
|
|
2604 (defun vm-gobble-crash-box (crash-box)
|
|
|
2605 (save-excursion
|
|
|
2606 (vm-save-restriction
|
|
|
2607 (widen)
|
|
|
2608 (let ((opoint-max (point-max)) crash-buf
|
|
|
2609 (buffer-read-only nil)
|
|
|
2610 (inbox-buffer-file buffer-file-name)
|
|
|
2611 (inbox-folder-type vm-folder-type)
|
|
|
2612 (inbox-empty (zerop (buffer-size)))
|
|
|
2613 got-mail crash-folder-type
|
|
|
2614 (old-buffer-modified-p (buffer-modified-p)))
|
|
|
2615 (setq crash-buf
|
|
|
2616 ;; crash box could contain a letter bomb...
|
|
|
2617 ;; force user notification of file variables for v18 Emacses
|
|
|
2618 ;; enable-local-variables == nil disables them for newer Emacses
|
|
|
2619 (let ((inhibit-local-variables t)
|
|
100
|
2620 (enable-local-variables nil)
|
|
140
|
2621 (coding-system-for-read 'no-conversion))
|
|
0
|
2622 (find-file-noselect crash-box)))
|
|
|
2623 (save-excursion
|
|
|
2624 (set-buffer crash-buf)
|
|
|
2625 (setq crash-folder-type (vm-get-folder-type))
|
|
|
2626 (if (and crash-folder-type vm-check-folder-types)
|
|
|
2627 (cond ((eq crash-folder-type 'unknown)
|
|
|
2628 (error "crash box %s's type is unrecognized" crash-box))
|
|
|
2629 ((eq inbox-folder-type 'unknown)
|
|
|
2630 (error "inbox %s's type is unrecognized"
|
|
|
2631 inbox-buffer-file))
|
|
|
2632 ((null inbox-folder-type)
|
|
|
2633 (if vm-default-folder-type
|
|
|
2634 (if (not (eq vm-default-folder-type
|
|
|
2635 crash-folder-type))
|
|
|
2636 (if vm-convert-folder-types
|
|
|
2637 (progn
|
|
|
2638 (vm-convert-folder-type
|
|
|
2639 crash-folder-type
|
|
|
2640 vm-default-folder-type)
|
|
|
2641 ;; so that kill-buffer won't ask a
|
|
|
2642 ;; question later...
|
|
|
2643 (set-buffer-modified-p nil))
|
|
|
2644 (error "crash box %s mismatches vm-default-folder-type: %s, %s"
|
|
|
2645 crash-box crash-folder-type
|
|
|
2646 vm-default-folder-type)))))
|
|
|
2647 ((not (eq inbox-folder-type crash-folder-type))
|
|
|
2648 (if vm-convert-folder-types
|
|
|
2649 (progn
|
|
|
2650 (vm-convert-folder-type crash-folder-type
|
|
|
2651 inbox-folder-type)
|
|
|
2652 ;; so that kill-buffer won't ask a
|
|
|
2653 ;; question later...
|
|
|
2654 (set-buffer-modified-p nil))
|
|
|
2655 (error "crash box %s mismatches %s's folder type: %s, %s"
|
|
|
2656 crash-box inbox-buffer-file
|
|
|
2657 crash-folder-type inbox-folder-type)))))
|
|
|
2658 ;; toss the folder header if the inbox is not empty
|
|
|
2659 (goto-char (point-min))
|
|
|
2660 (if (not inbox-empty)
|
|
|
2661 (progn
|
|
|
2662 (vm-convert-folder-header (or inbox-folder-type
|
|
|
2663 vm-default-folder-type)
|
|
|
2664 nil)
|
|
|
2665 (set-buffer-modified-p nil))))
|
|
|
2666 (goto-char (point-max))
|
|
|
2667 (insert-buffer-substring crash-buf
|
|
|
2668 1 (1+ (save-excursion
|
|
|
2669 (set-buffer crash-buf)
|
|
|
2670 (widen)
|
|
|
2671 (buffer-size))))
|
|
|
2672 (setq got-mail (/= opoint-max (point-max)))
|
|
100
|
2673 (if (not got-mail)
|
|
|
2674 nil
|
|
|
2675 (write-region opoint-max (point-max) buffer-file-name t t)
|
|
|
2676 (vm-increment vm-modification-counter)
|
|
116
|
2677 (set-buffer-modified-p old-buffer-modified-p))
|
|
|
2678 (kill-buffer crash-buf)
|
|
|
2679 (if (not (stringp vm-keep-crash-boxes))
|
|
|
2680 (vm-error-free-call 'delete-file crash-box)
|
|
|
2681 (let ((time (decode-time (current-time)))
|
|
|
2682 name)
|
|
|
2683 (setq name
|
|
|
2684 (expand-file-name (format "Z-%02d-%02d-%05d"
|
|
|
2685 (nth 4 time)
|
|
|
2686 (nth 3 time)
|
|
|
2687 (% (vm-abs (random)) 100000))
|
|
|
2688 vm-keep-crash-boxes))
|
|
|
2689 (while (file-exists-p name)
|
|
108
|
2690 (setq name
|
|
|
2691 (expand-file-name (format "Z-%02d-%02d-%05d"
|
|
|
2692 (nth 4 time)
|
|
|
2693 (nth 3 time)
|
|
|
2694 (% (vm-abs (random)) 100000))
|
|
116
|
2695 vm-keep-crash-boxes)))
|
|
|
2696 (rename-file crash-box name)))
|
|
0
|
2697 got-mail ))))
|
|
|
2698
|
|
100
|
2699 (defun vm-compute-spool-files ()
|
|
|
2700 (let ((fallback-triples nil)
|
|
|
2701 triples)
|
|
98
|
2702 (cond ((and buffer-file-name
|
|
|
2703 (consp vm-spool-file-suffixes)
|
|
|
2704 (stringp vm-crash-box-suffix))
|
|
|
2705 (setq fallback-triples
|
|
|
2706 (mapcar (function
|
|
|
2707 (lambda (suffix)
|
|
|
2708 (list buffer-file-name
|
|
|
2709 (concat buffer-file-name suffix)
|
|
|
2710 (concat buffer-file-name
|
|
|
2711 vm-crash-box-suffix))))
|
|
|
2712 vm-spool-file-suffixes))))
|
|
|
2713 (cond ((and buffer-file-name
|
|
|
2714 vm-make-spool-file-name vm-make-crash-box-name)
|
|
|
2715 (setq fallback-triples
|
|
100
|
2716 (nconc fallback-triples
|
|
98
|
2717 (list (list buffer-file-name
|
|
|
2718 (save-excursion
|
|
|
2719 (funcall vm-make-spool-file-name
|
|
|
2720 buffer-file-name))
|
|
|
2721 (save-excursion
|
|
|
2722 (funcall vm-make-crash-box-name
|
|
|
2723 buffer-file-name))))))))
|
|
0
|
2724 (cond ((null (vm-spool-files))
|
|
|
2725 (setq triples (list
|
|
|
2726 (list vm-primary-inbox
|
|
|
2727 (concat vm-spool-directory (user-login-name))
|
|
|
2728 vm-crash-box))))
|
|
|
2729 ((stringp (car (vm-spool-files)))
|
|
|
2730 (setq triples
|
|
|
2731 (mapcar (function
|
|
|
2732 (lambda (s) (list vm-primary-inbox s vm-crash-box)))
|
|
|
2733 (vm-spool-files))))
|
|
|
2734 ((consp (car (vm-spool-files)))
|
|
|
2735 (setq triples (vm-spool-files))))
|
|
98
|
2736 (setq triples (append triples fallback-triples))
|
|
100
|
2737 triples ))
|
|
|
2738
|
|
|
2739 (defun vm-spool-check-mail (source)
|
|
|
2740 (let ((handler (and (fboundp 'find-file-name-handler)
|
|
|
2741 (condition-case ()
|
|
|
2742 (find-file-name-handler source 'vm-spool-check-mail)
|
|
|
2743 (wrong-number-of-arguments
|
|
|
2744 (find-file-name-handler source))))))
|
|
|
2745 (if handler
|
|
|
2746 (funcall handler 'vm-spool-check-mail source)
|
|
|
2747 (and (not (equal 0 (nth 7 (file-attributes source))))
|
|
|
2748 (file-readable-p source)))))
|
|
|
2749
|
|
|
2750 (defun vm-check-for-spooled-mail (&optional interactive)
|
|
|
2751 (if vm-block-new-mail
|
|
|
2752 nil
|
|
|
2753 (let ((triples (vm-compute-spool-files))
|
|
|
2754 ;; since we could accept-process-output here (POP code),
|
|
|
2755 ;; a timer process might try to start retrieving mail
|
|
|
2756 ;; before we finish. block these attempts.
|
|
|
2757 (vm-block-new-mail t)
|
|
|
2758 (vm-pop-ok-to-ask interactive)
|
|
|
2759 (done nil)
|
|
|
2760 crash in maildrop popdrop
|
|
|
2761 (mail-waiting nil))
|
|
|
2762 (while (and triples (not done))
|
|
|
2763 (setq in (expand-file-name (nth 0 (car triples)) vm-folder-directory)
|
|
|
2764 maildrop (nth 1 (car triples))
|
|
|
2765 crash (nth 2 (car triples)))
|
|
|
2766 (if (eq (current-buffer) (vm-get-file-buffer in))
|
|
|
2767 (progn
|
|
|
2768 (if (file-exists-p crash)
|
|
|
2769 (progn
|
|
|
2770 (setq mail-waiting t
|
|
|
2771 done t))
|
|
|
2772 (setq popdrop (and vm-recognize-pop-maildrops
|
|
|
2773 (string-match vm-recognize-pop-maildrops
|
|
|
2774 maildrop)))
|
|
|
2775 (if (not interactive)
|
|
|
2776 ;; allow no error to be signaled
|
|
|
2777 (condition-case nil
|
|
|
2778 (setq mail-waiting
|
|
|
2779 (or mail-waiting
|
|
|
2780 (if popdrop
|
|
|
2781 (vm-pop-check-mail maildrop)
|
|
|
2782 (vm-spool-check-mail maildrop))))
|
|
|
2783 (error nil))
|
|
|
2784 (setq mail-waiting (or mail-waiting
|
|
|
2785 (if popdrop
|
|
|
2786 (vm-pop-check-mail maildrop)
|
|
|
2787 (vm-spool-check-mail maildrop)))))
|
|
|
2788 (if mail-waiting
|
|
|
2789 (setq done t)))))
|
|
|
2790 (setq triples (cdr triples)))
|
|
|
2791 (setq vm-spooled-mail-waiting mail-waiting)
|
|
|
2792 mail-waiting )))
|
|
|
2793
|
|
|
2794 (defun vm-get-spooled-mail (&optional interactive)
|
|
|
2795 (if vm-block-new-mail
|
|
|
2796 (error "Can't get new mail until you save this folder."))
|
|
|
2797 (let ((triples (vm-compute-spool-files))
|
|
|
2798 ;; since we could accept-process-output here (POP code),
|
|
|
2799 ;; a timer process might try to start retrieving mail
|
|
|
2800 ;; before we finish. block these attempts.
|
|
|
2801 (vm-block-new-mail t)
|
|
|
2802 (vm-pop-ok-to-ask interactive)
|
|
|
2803 crash in maildrop popdrop
|
|
|
2804 (got-mail nil))
|
|
114
|
2805 (if (and (not (verify-visited-file-modtime (current-buffer)))
|
|
|
2806 (or (null interactive)
|
|
|
2807 (not (yes-or-no-p
|
|
|
2808 (format
|
|
|
2809 "Folder %s changed on disk, discard those changes? "
|
|
|
2810 (buffer-name (current-buffer)))))))
|
|
|
2811 (progn
|
|
|
2812 (message "Folder %s changed on disk, consider M-x revert-buffer"
|
|
|
2813 (buffer-name (current-buffer)))
|
|
|
2814 (sleep-for 1)
|
|
|
2815 nil )
|
|
|
2816 (while triples
|
|
|
2817 (setq in (expand-file-name (nth 0 (car triples)) vm-folder-directory)
|
|
|
2818 maildrop (nth 1 (car triples))
|
|
|
2819 crash (nth 2 (car triples)))
|
|
|
2820 (if (eq (current-buffer) (vm-get-file-buffer in))
|
|
|
2821 (let (retrieval-function)
|
|
|
2822 (if (file-exists-p crash)
|
|
|
2823 (progn
|
|
|
2824 (message "Recovering messages from %s..." crash)
|
|
|
2825 (setq got-mail (or (vm-gobble-crash-box crash) got-mail))
|
|
|
2826 (message "Recovering messages from %s... done" crash)))
|
|
|
2827 (setq popdrop (and vm-recognize-pop-maildrops
|
|
|
2828 (string-match vm-recognize-pop-maildrops
|
|
|
2829 maildrop)
|
|
|
2830 ;; maildrop with password clipped
|
|
|
2831 (vm-safe-popdrop-string maildrop)))
|
|
|
2832 (if (or popdrop
|
|
|
2833 (and (not (equal 0 (nth 7 (file-attributes maildrop))))
|
|
|
2834 (file-readable-p maildrop)))
|
|
|
2835 (progn
|
|
|
2836 (setq crash (expand-file-name crash vm-folder-directory))
|
|
|
2837 (if (not popdrop)
|
|
|
2838 (setq maildrop (expand-file-name maildrop)
|
|
|
2839 retrieval-function 'vm-spool-move-mail)
|
|
|
2840 (setq retrieval-function 'vm-pop-move-mail))
|
|
|
2841 (if (if got-mail
|
|
|
2842 ;; don't allow errors to be signaled unless no
|
|
|
2843 ;; mail has been appended to the incore
|
|
|
2844 ;; copy of the folder. otherwise the
|
|
|
2845 ;; user will wonder where the mail is,
|
|
|
2846 ;; since it is not in the crash box or
|
|
|
2847 ;; the spool file and doesn't _appear_ to
|
|
|
2848 ;; be in the folder either.
|
|
|
2849 (condition-case error-data
|
|
|
2850 (funcall retrieval-function maildrop crash)
|
|
|
2851 (error (message "%s signaled: %s"
|
|
|
2852 (if popdrop
|
|
|
2853 'vm-pop-move-mail
|
|
|
2854 'vm-spool-move-mail)
|
|
|
2855 error-data)
|
|
|
2856 (sleep-for 2)
|
|
|
2857 ;; we don't know if mail was
|
|
|
2858 ;; put into the crash box or
|
|
|
2859 ;; not, so return t just to be
|
|
|
2860 ;; safe.
|
|
|
2861 t )
|
|
|
2862 (quit (message "quitting from %s..."
|
|
|
2863 (if popdrop
|
|
|
2864 'vm-pop-move-mail
|
|
|
2865 'vm-spool-move-mail))
|
|
|
2866 (sleep-for 1)
|
|
|
2867 ;; we don't know if mail was
|
|
|
2868 ;; put into the crash box or
|
|
|
2869 ;; not, so return t just to be
|
|
|
2870 ;; safe.
|
|
|
2871 t ))
|
|
|
2872 (funcall retrieval-function maildrop crash))
|
|
|
2873 (if (vm-gobble-crash-box crash)
|
|
|
2874 (progn
|
|
|
2875 (setq got-mail t)
|
|
|
2876 (message "Got mail from %s."
|
|
|
2877 (or popdrop maildrop)))))))))
|
|
|
2878 (setq triples (cdr triples)))
|
|
|
2879 ;; not really correct, but it is what the user expects to see.
|
|
|
2880 (if got-mail
|
|
|
2881 (setq vm-spooled-mail-waiting nil))
|
|
|
2882 (intern (buffer-name) vm-buffers-needing-display-update)
|
|
|
2883 (vm-update-summary-and-mode-line)
|
|
|
2884 (if got-mail
|
|
|
2885 (run-hooks 'vm-retrieved-spooled-mail-hook))
|
|
|
2886 got-mail )))
|
|
0
|
2887
|
|
|
2888 (defun vm-safe-popdrop-string (drop)
|
|
|
2889 (or (and (string-match "^\\([^:]+\\):[^:]+:[^:]+:\\([^:]+\\):[^:]+" drop)
|
|
|
2890 (concat (substring drop (match-beginning 2) (match-end 2))
|
|
|
2891 "@"
|
|
|
2892 (substring drop (match-beginning 1) (match-end 1))))
|
|
|
2893 "???"))
|
|
|
2894
|
|
|
2895 (defun vm-get-new-mail (&optional arg)
|
|
|
2896 "Move any new mail that has arrived in any of the spool files for the
|
|
|
2897 current folder into the folder. New mail is appended to the disk
|
|
|
2898 and buffer copies of the folder.
|
|
|
2899
|
|
|
2900 Prefix arg means to gather mail from a user specified folder, instead of
|
|
|
2901 the usual spool files. The file name will be read from the minibuffer.
|
|
|
2902 Unlike when getting mail from a spool file, the source file is left
|
|
|
2903 undisturbed after its messages have been copied.
|
|
|
2904
|
|
|
2905 When applied to a virtual folder, this command runs itself on
|
|
|
2906 each of the underlying real folders associated with this virtual folder.
|
|
|
2907 A prefix argument has no effect; mail is always gathered from the
|
|
|
2908 spool files."
|
|
|
2909 (interactive "P")
|
|
|
2910 (vm-select-folder-buffer)
|
|
|
2911 (vm-check-for-killed-summary)
|
|
|
2912 (vm-error-if-folder-read-only)
|
|
|
2913 (cond ((eq major-mode 'vm-virtual-mode)
|
|
|
2914 (vm-virtual-get-new-mail))
|
|
|
2915 ((null arg)
|
|
|
2916 (if (not (eq major-mode 'vm-mode))
|
|
|
2917 (vm-mode))
|
|
|
2918 (if (consp (car (vm-spool-files)))
|
|
102
|
2919 (message "Checking for new mail for %s..."
|
|
0
|
2920 (or buffer-file-name (buffer-name)))
|
|
102
|
2921 (message "Checking for new mail..."))
|
|
0
|
2922 (let (totals-blurb)
|
|
100
|
2923 (if (and (vm-get-spooled-mail t) (vm-assimilate-new-messages t))
|
|
0
|
2924 (progn
|
|
|
2925 ;; say this NOW, before the non-previewers read
|
|
|
2926 ;; a message, alter the new message count and
|
|
|
2927 ;; confuse themselves.
|
|
|
2928 (setq totals-blurb (vm-emit-totals-blurb))
|
|
|
2929 (vm-display nil nil '(vm-get-new-mail) '(vm-get-new-mail))
|
|
|
2930 (if (vm-thoughtfully-select-message)
|
|
|
2931 (vm-preview-current-message)
|
|
|
2932 (vm-update-summary-and-mode-line))
|
|
|
2933 (message totals-blurb))
|
|
|
2934 (if (consp (car (vm-spool-files)))
|
|
|
2935 (message "No new mail for %s"
|
|
|
2936 (or buffer-file-name (buffer-name)))
|
|
|
2937 (message "No new mail."))
|
|
102
|
2938 (and (interactive-p) (sit-for 4) (message "")))))
|
|
0
|
2939 (t
|
|
|
2940 (let ((buffer-read-only nil)
|
|
|
2941 folder mcount totals-blurb)
|
|
|
2942 (setq folder (read-file-name "Gather mail from folder: "
|
|
|
2943 vm-folder-directory t))
|
|
|
2944 (if (and vm-check-folder-types
|
|
|
2945 (not (vm-compatible-folder-p folder)))
|
|
|
2946 (error "Folder %s is not the same format as this folder."
|
|
|
2947 folder))
|
|
|
2948 (save-excursion
|
|
|
2949 (vm-save-restriction
|
|
|
2950 (widen)
|
|
|
2951 (goto-char (point-max))
|
|
140
|
2952 (let ((coding-system-for-read 'binary))
|
|
100
|
2953 (insert-file-contents folder))))
|
|
0
|
2954 (setq mcount (length vm-message-list))
|
|
|
2955 (if (vm-assimilate-new-messages)
|
|
|
2956 (progn
|
|
|
2957 ;; say this NOW, before the non-previewers read
|
|
|
2958 ;; a message, alter the new message count and
|
|
|
2959 ;; confuse themselves.
|
|
|
2960 (setq totals-blurb (vm-emit-totals-blurb))
|
|
|
2961 (vm-display nil nil '(vm-get-new-mail) '(vm-get-new-mail))
|
|
|
2962 (if (vm-thoughtfully-select-message)
|
|
|
2963 (vm-preview-current-message)
|
|
|
2964 (vm-update-summary-and-mode-line))
|
|
|
2965 (message totals-blurb)
|
|
|
2966 ;; The gathered messages are actually still on disk
|
|
|
2967 ;; unless the user deletes the folder himself.
|
|
|
2968 ;; However, users may not understand what happened if
|
|
|
2969 ;; the messages go away after a "quit, no save".
|
|
|
2970 (setq vm-messages-not-on-disk
|
|
|
2971 (+ vm-messages-not-on-disk
|
|
|
2972 (- (length vm-message-list)
|
|
|
2973 mcount))))
|
|
|
2974 (message "No messages gathered."))))))
|
|
|
2975
|
|
|
2976 ;; returns non-nil if there were any new messages
|
|
98
|
2977 (defun vm-assimilate-new-messages (&optional
|
|
|
2978 dont-read-attributes
|
|
|
2979 gobble-order
|
|
|
2980 labels)
|
|
0
|
2981 (let ((tail-cons (vm-last vm-message-list))
|
|
|
2982 b-list new-messages)
|
|
|
2983 (save-excursion
|
|
|
2984 (vm-save-restriction
|
|
|
2985 (widen)
|
|
|
2986 (vm-build-message-list)
|
|
|
2987 (if (or (null tail-cons) (cdr tail-cons))
|
|
|
2988 (progn
|
|
|
2989 (setq vm-ml-sort-keys nil)
|
|
|
2990 (if dont-read-attributes
|
|
|
2991 (vm-set-default-attributes (cdr tail-cons))
|
|
|
2992 (vm-read-attributes (cdr tail-cons)))
|
|
|
2993 ;; Yuck. This has to be done here instead of in the
|
|
|
2994 ;; vm function because this needs to be done before
|
|
|
2995 ;; any initial thread sort (so that if the thread
|
|
|
2996 ;; sort matches the saved order the folder won't be
|
|
|
2997 ;; modified) but after the message list is created.
|
|
|
2998 ;; Since thread sorting is done here this has to be
|
|
|
2999 ;; done here too.
|
|
|
3000 (if gobble-order
|
|
|
3001 (vm-gobble-message-order))
|
|
|
3002 (if vm-thread-obarray
|
|
|
3003 (vm-build-threads (cdr tail-cons))))))
|
|
|
3004 (setq new-messages (if tail-cons (cdr tail-cons) vm-message-list))
|
|
|
3005 (vm-set-numbering-redo-start-point new-messages)
|
|
|
3006 (vm-set-summary-redo-start-point new-messages))
|
|
|
3007 ;; copy the new-messages list because sorting might scramble
|
|
|
3008 ;; it. Also something the user does when
|
|
|
3009 ;; vm-arrived-message-hook is run might affect it.
|
|
|
3010 ;; vm-assimilate-new-messages returns this value so it must
|
|
|
3011 ;; not be mangled.
|
|
|
3012 (setq new-messages (copy-sequence new-messages))
|
|
98
|
3013 ;; add the labels
|
|
|
3014 (if (and labels vm-burst-digest-messages-inherit-labels)
|
|
|
3015 (let ((mp new-messages))
|
|
|
3016 (while mp
|
|
|
3017 (vm-set-labels-of (car mp) (copy-sequence labels))
|
|
|
3018 (setq mp (cdr mp)))))
|
|
0
|
3019 (if vm-summary-show-threads
|
|
|
3020 (progn
|
|
|
3021 ;; get numbering and summary of new messages done now
|
|
|
3022 ;; so that the sort code only has to worry about the
|
|
|
3023 ;; changes it needs to make.
|
|
|
3024 (vm-update-summary-and-mode-line)
|
|
|
3025 (vm-sort-messages "thread")))
|
|
|
3026 (if (and vm-arrived-message-hook
|
|
|
3027 new-messages
|
|
|
3028 ;; tail-cons == nil means vm-message-list was empty.
|
|
|
3029 ;; Thus new-messages == vm-message-list. In this
|
|
|
3030 ;; case, run the hooks only if this is not the first
|
|
|
3031 ;; time vm-assimilate-new-messages has been called
|
|
|
3032 ;; in this folder. gobble-order non-nil is a good
|
|
|
3033 ;; indicator that this is the first time because the
|
|
|
3034 ;; order is gobbled only once per visit and always
|
|
|
3035 ;; the first time vm-assimilate-new-messages is
|
|
|
3036 ;; called.
|
|
|
3037 (or tail-cons (null gobble-order)))
|
|
|
3038 (let ((new-messages new-messages))
|
|
|
3039 ;; seems wise to do this so that if the user runs VM
|
|
|
3040 ;; command here they start with as much of a clean
|
|
|
3041 ;; slate as we can provide, given we're currently deep
|
|
|
3042 ;; in the guts of VM.
|
|
|
3043 (vm-update-summary-and-mode-line)
|
|
|
3044 (while new-messages
|
|
|
3045 (vm-run-message-hook (car new-messages) 'vm-arrived-message-hook)
|
|
|
3046 (setq new-messages (cdr new-messages)))))
|
|
|
3047 (vm-update-summary-and-mode-line)
|
|
|
3048 (run-hooks 'vm-arrived-messages-hook)
|
|
|
3049 (if (and new-messages vm-virtual-buffers)
|
|
|
3050 (save-excursion
|
|
|
3051 (setq b-list vm-virtual-buffers)
|
|
|
3052 (while b-list
|
|
|
3053 ;; buffer might be dead
|
|
|
3054 (if (buffer-name (car b-list))
|
|
|
3055 (let (tail-cons)
|
|
|
3056 (set-buffer (car b-list))
|
|
|
3057 (setq tail-cons (vm-last vm-message-list))
|
|
|
3058 (vm-build-virtual-message-list new-messages)
|
|
|
3059 (if (or (null tail-cons) (cdr tail-cons))
|
|
|
3060 (progn
|
|
|
3061 (setq vm-ml-sort-keys nil)
|
|
|
3062 (if vm-thread-obarray
|
|
|
3063 (vm-build-threads (cdr tail-cons)))
|
|
|
3064 (vm-set-summary-redo-start-point
|
|
|
3065 (or (cdr tail-cons) vm-message-list))
|
|
|
3066 (vm-set-numbering-redo-start-point
|
|
|
3067 (or (cdr tail-cons) vm-message-list))
|
|
|
3068 (if (null vm-message-pointer)
|
|
|
3069 (progn (setq vm-message-pointer vm-message-list
|
|
|
3070 vm-need-summary-pointer-update t)
|
|
|
3071 (if vm-message-pointer
|
|
|
3072 (vm-preview-current-message))))
|
|
|
3073 (if vm-summary-show-threads
|
|
|
3074 (progn
|
|
|
3075 (vm-update-summary-and-mode-line)
|
|
|
3076 (vm-sort-messages "thread")))))))
|
|
|
3077 (setq b-list (cdr b-list)))))
|
|
|
3078 new-messages ))
|
|
|
3079
|
|
|
3080 ;; return a list of all marked messages or the messages indicated by a
|
|
|
3081 ;; prefix argument.
|
|
|
3082 (defun vm-select-marked-or-prefixed-messages (prefix)
|
|
|
3083 (let (mlist)
|
|
|
3084 (if (eq last-command 'vm-next-command-uses-marks)
|
|
|
3085 (setq mlist (vm-marked-messages))
|
|
|
3086 (let ((direction (if (< prefix 0) 'backward 'forward))
|
|
|
3087 (count (vm-abs prefix))
|
|
|
3088 (vm-message-pointer vm-message-pointer))
|
|
|
3089 (if (not (eq vm-circular-folders t))
|
|
|
3090 (vm-check-count prefix))
|
|
|
3091 (while (not (zerop count))
|
|
|
3092 (setq mlist (cons (car vm-message-pointer) mlist))
|
|
|
3093 (vm-decrement count)
|
|
|
3094 (if (not (zerop count))
|
|
|
3095 (vm-move-message-pointer direction))))
|
|
|
3096 (nreverse mlist))))
|
|
|
3097
|
|
|
3098 (defun vm-display-startup-message ()
|
|
|
3099 (if (sit-for 5)
|
|
|
3100 (let ((lines vm-startup-message-lines))
|
|
98
|
3101 (message "VM %s, Copyright (C) 1997 Kyle E. Jones; type ? for help"
|
|
0
|
3102 vm-version)
|
|
|
3103 (setq vm-startup-message-displayed t)
|
|
|
3104 (while (and (sit-for 4) lines)
|
|
|
3105 (message (substitute-command-keys (car lines)))
|
|
|
3106 (setq lines (cdr lines)))))
|
|
102
|
3107 (message ""))
|
|
0
|
3108
|
|
|
3109 (defun vm-load-init-file (&optional interactive)
|
|
|
3110 (interactive "p")
|
|
|
3111 (if (or (not vm-init-file-loaded) interactive)
|
|
|
3112 (progn
|
|
|
3113 (and vm-init-file
|
|
|
3114 (load vm-init-file (not interactive) (not interactive) t))
|
|
98
|
3115 (and vm-preferences-file (load vm-preferences-file t t t))))
|
|
0
|
3116 (setq vm-init-file-loaded t)
|
|
|
3117 (vm-display nil nil '(vm-load-init-file) '(vm-load-init-file)))
|
|
|
3118
|
|
|
3119 (defun vm-session-initialization ()
|
|
|
3120 ;; If this is the first time VM has been run in this Emacs session,
|
|
|
3121 ;; do some necessary preparations.
|
|
|
3122 (if (or (not (boundp 'vm-session-beginning))
|
|
|
3123 vm-session-beginning)
|
|
|
3124 (progn
|
|
|
3125 (random t)
|
|
|
3126 (vm-load-init-file)
|
|
|
3127 (if (not vm-window-configuration-file)
|
|
|
3128 (setq vm-window-configurations vm-default-window-configuration)
|
|
|
3129 (or (vm-load-window-configurations vm-window-configuration-file)
|
|
|
3130 (setq vm-window-configurations vm-default-window-configuration)))
|
|
|
3131 (setq vm-buffers-needing-display-update (make-vector 29 0))
|
|
|
3132 (setq vm-session-beginning nil))))
|
|
|
3133
|
|
|
3134 (defun vm-toggle-read-only ()
|
|
|
3135 (interactive)
|
|
|
3136 (vm-select-folder-buffer)
|
|
|
3137 (setq vm-folder-read-only (not vm-folder-read-only))
|
|
|
3138 (intern (buffer-name) vm-buffers-needing-display-update)
|
|
|
3139 (message "Folder is now %s"
|
|
|
3140 (if vm-folder-read-only "read-only" "modifiable"))
|
|
|
3141 (vm-display nil nil '(vm-toggle-read-only) '(vm-toggle-read-only))
|
|
|
3142 (vm-update-summary-and-mode-line))
|
|
|
3143
|
|
100
|
3144 (defvar scroll-in-place)
|
|
|
3145
|
|
0
|
3146 ;; this does the real major mode scutwork.
|
|
|
3147 (defun vm-mode-internal ()
|
|
|
3148 (widen)
|
|
|
3149 (make-local-variable 'require-final-newline)
|
|
|
3150 ;; don't kill local variables, as there is some state we'd like to
|
|
|
3151 ;; keep. rather than non-portably marking the variables we
|
|
|
3152 ;; want to keep, just avoid calling kill-local-variables and
|
|
|
3153 ;; reset everything that needs to be reset.
|
|
|
3154 (setq
|
|
|
3155 major-mode 'vm-mode
|
|
|
3156 mode-line-format vm-mode-line-format
|
|
|
3157 mode-name "VM"
|
|
|
3158 ;; must come after the setting of major-mode
|
|
98
|
3159 mode-popup-menu (and vm-use-menus vm-popup-menu-on-mouse-3
|
|
0
|
3160 (vm-menu-support-possible-p)
|
|
|
3161 (vm-menu-mode-menu))
|
|
|
3162 buffer-read-only t
|
|
98
|
3163 ;; If the user quits a vm-mode buffer, the default action is
|
|
|
3164 ;; to kill the buffer. Make a note that we should offer to
|
|
|
3165 ;; save this buffer even if it has no file associated with it.
|
|
|
3166 ;; We have no idea of the value of the data in the buffer
|
|
|
3167 ;; before it was put into vm-mode.
|
|
|
3168 buffer-offer-save t
|
|
0
|
3169 require-final-newline nil
|
|
|
3170 vm-thread-obarray nil
|
|
|
3171 vm-thread-subject-obarray nil
|
|
|
3172 vm-label-obarray (make-vector 29 0)
|
|
|
3173 vm-last-message-pointer nil
|
|
|
3174 vm-modification-counter 0
|
|
|
3175 vm-message-list nil
|
|
|
3176 vm-message-pointer nil
|
|
|
3177 vm-message-order-changed nil
|
|
|
3178 vm-message-order-header-present nil
|
|
|
3179 vm-summary-buffer nil
|
|
|
3180 vm-system-state nil
|
|
|
3181 vm-undo-record-list nil
|
|
|
3182 vm-undo-record-pointer nil
|
|
|
3183 vm-virtual-buffers (vm-link-to-virtual-buffers)
|
|
|
3184 vm-folder-type (vm-get-folder-type))
|
|
|
3185 (use-local-map vm-mode-map)
|
|
|
3186 (and (vm-menu-support-possible-p)
|
|
|
3187 (vm-menu-install-menus))
|
|
98
|
3188 (add-hook 'kill-buffer-hook 'vm-garbage-collect-folder)
|
|
|
3189 (add-hook 'kill-buffer-hook 'vm-garbage-collect-message)
|
|
|
3190 ;; avoid the XEmacs file dialog box.
|
|
100
|
3191 (defvar use-dialog-box)
|
|
|
3192 (make-local-variable 'use-dialog-box)
|
|
|
3193 (setq use-dialog-box nil)
|
|
98
|
3194 ;; mail folders are precious. protect them by default.
|
|
|
3195 (make-local-variable 'file-precious-flag)
|
|
|
3196 (setq file-precious-flag t)
|
|
100
|
3197 ;; scroll in place messes with scroll-up and this loses
|
|
|
3198 (make-local-variable 'scroll-in-place)
|
|
|
3199 (setq scroll-in-place nil)
|
|
0
|
3200 (run-hooks 'vm-mode-hook)
|
|
|
3201 ;; compatibility
|
|
|
3202 (run-hooks 'vm-mode-hooks))
|
|
|
3203
|
|
|
3204 (defun vm-link-to-virtual-buffers ()
|
|
|
3205 (let ((b-list (buffer-list))
|
|
|
3206 (vbuffers nil)
|
|
|
3207 (folder-buffer (current-buffer))
|
|
|
3208 folders clauses)
|
|
|
3209 (save-excursion
|
|
|
3210 (while b-list
|
|
|
3211 (set-buffer (car b-list))
|
|
|
3212 (cond ((eq major-mode 'vm-virtual-mode)
|
|
|
3213 (setq clauses (cdr vm-virtual-folder-definition))
|
|
|
3214 (while clauses
|
|
|
3215 (setq folders (car (car clauses)))
|
|
|
3216 (while folders
|
|
|
3217 (if (eq folder-buffer (vm-get-file-buffer
|
|
|
3218 (expand-file-name
|
|
|
3219 (car folders)
|
|
|
3220 vm-folder-directory)))
|
|
|
3221 (setq vbuffers (cons (car b-list) vbuffers)
|
|
|
3222 vm-real-buffers (cons folder-buffer
|
|
|
3223 vm-real-buffers)
|
|
|
3224 folders nil
|
|
|
3225 clauses nil))
|
|
|
3226 (setq folders (cdr folders)))
|
|
|
3227 (setq clauses (cdr clauses)))))
|
|
|
3228 (setq b-list (cdr b-list)))
|
|
|
3229 vbuffers )))
|
|
|
3230
|
|
|
3231 (defun vm-change-folder-type (type)
|
|
|
3232 "Change folder type to TYPE.
|
|
|
3233 TYPE may be one of the following symbol values:
|
|
|
3234
|
|
|
3235 From_
|
|
|
3236 From_-with-Content-Length
|
|
|
3237 mmdf
|
|
|
3238 babyl
|
|
|
3239
|
|
|
3240 Interactively TYPE will be read from the minibuffer."
|
|
|
3241 (interactive
|
|
|
3242 (let ((this-command this-command)
|
|
|
3243 (last-command last-command)
|
|
|
3244 (types vm-supported-folder-types))
|
|
|
3245 (vm-select-folder-buffer)
|
|
|
3246 (vm-error-if-virtual-folder)
|
|
|
3247 (setq types (vm-delqual (symbol-name vm-folder-type)
|
|
|
3248 (copy-sequence types)))
|
|
|
3249 (list (intern (vm-read-string "Change folder to type: " types)))))
|
|
|
3250 (vm-select-folder-buffer)
|
|
|
3251 (vm-check-for-killed-summary)
|
|
|
3252 (vm-error-if-virtual-folder)
|
|
|
3253 (vm-error-if-folder-empty)
|
|
|
3254 (if (not (memq type '(From_ From_-with-Content-Length mmdf babyl)))
|
|
|
3255 (error "Unknown folder type: %s" type))
|
|
|
3256 (if (or (null vm-folder-type)
|
|
|
3257 (eq vm-folder-type 'unknown))
|
|
|
3258 (error "Current folder's type is unknown, can't change it."))
|
|
|
3259 (let ((mp vm-message-list)
|
|
|
3260 (buffer-read-only nil)
|
|
|
3261 (old-type vm-folder-type)
|
|
|
3262 ;; no interruptions
|
|
|
3263 (inhibit-quit t)
|
|
|
3264 (n 0)
|
|
|
3265 ;; Just for laughs, make the update interval vary.
|
|
|
3266 (modulus (+ (% (vm-abs (random)) 11) 5))
|
|
|
3267 text-end opoint)
|
|
|
3268 (save-excursion
|
|
|
3269 (vm-save-restriction
|
|
|
3270 (widen)
|
|
|
3271 (setq vm-folder-type type)
|
|
|
3272 (goto-char (point-min))
|
|
|
3273 (vm-convert-folder-header old-type type)
|
|
|
3274 (while mp
|
|
|
3275 (goto-char (vm-start-of (car mp)))
|
|
|
3276 (setq opoint (point))
|
|
|
3277 (insert (vm-leading-message-separator type (car mp)))
|
|
|
3278 (if (> (vm-headers-of (car mp)) (vm-start-of (car mp)))
|
|
|
3279 (delete-region (point) (vm-headers-of (car mp)))
|
|
|
3280 (set-marker (vm-headers-of (car mp)) (point))
|
|
|
3281 ;; if headers-of == start-of then so could vheaders-of
|
|
|
3282 ;; and text-of. clear them to force a recompute.
|
|
|
3283 (vm-set-vheaders-of (car mp) nil)
|
|
|
3284 (vm-set-text-of (car mp) nil))
|
|
|
3285 (vm-convert-folder-type-headers old-type type)
|
|
|
3286 (goto-char (vm-text-end-of (car mp)))
|
|
|
3287 (setq text-end (point))
|
|
|
3288 (insert-before-markers (vm-trailing-message-separator type))
|
|
|
3289 (delete-region (vm-text-end-of (car mp)) (vm-end-of (car mp)))
|
|
|
3290 (set-marker (vm-text-end-of (car mp)) text-end)
|
|
|
3291 (goto-char (vm-headers-of (car mp)))
|
|
|
3292 (vm-munge-message-separators type (vm-headers-of (car mp))
|
|
|
3293 (vm-text-end-of (car mp)))
|
|
|
3294 (vm-set-byte-count-of (car mp) nil)
|
|
|
3295 (vm-set-babyl-frob-flag-of (car mp) nil)
|
|
|
3296 (vm-set-message-type-of (car mp) type)
|
|
|
3297 ;; Technically we should mark each message for a
|
|
|
3298 ;; summary update since the message byte counts might
|
|
|
3299 ;; have changed. But I don't think anyone cares that
|
|
|
3300 ;; much and the summary regeneration would make this
|
|
|
3301 ;; process slower.
|
|
|
3302 (setq mp (cdr mp) n (1+ n))
|
|
|
3303 (if (zerop (% n modulus))
|
|
102
|
3304 (message "Converting... %d" n))))))
|
|
0
|
3305 (vm-clear-modification-flag-undos)
|
|
|
3306 (intern (buffer-name) vm-buffers-needing-display-update)
|
|
|
3307 (vm-update-summary-and-mode-line)
|
|
|
3308 (message "Conversion complete.")
|
|
|
3309 ;; message separator strings may have leaked into view
|
|
|
3310 (if (> (point-max) (vm-text-end-of (car vm-message-pointer)))
|
|
|
3311 (narrow-to-region (point-min) (vm-text-end-of (car vm-message-pointer))))
|
|
|
3312 (vm-display nil nil '(vm-change-folder-type) '(vm-change-folder-type)))
|
|
|
3313
|
|
98
|
3314 (defun vm-garbage-collect-folder ()
|
|
|
3315 (save-excursion
|
|
|
3316 (while vm-folder-garbage-alist
|
|
|
3317 (condition-case nil
|
|
|
3318 (funcall (cdr (car vm-folder-garbage-alist))
|
|
|
3319 (car (car vm-folder-garbage-alist)))
|
|
|
3320 (error nil))
|
|
|
3321 (setq vm-folder-garbage-alist (cdr vm-folder-garbage-alist)))))
|
|
|
3322
|
|
|
3323 (defun vm-garbage-collect-message ()
|
|
|
3324 (save-excursion
|
|
|
3325 (while vm-message-garbage-alist
|
|
|
3326 (condition-case nil
|
|
|
3327 (funcall (cdr (car vm-message-garbage-alist))
|
|
|
3328 (car (car vm-message-garbage-alist)))
|
|
|
3329 (error nil))
|
|
|
3330 (setq vm-message-garbage-alist (cdr vm-message-garbage-alist)))))
|
|
|
3331
|
|
0
|
3332 (if (not (memq 'vm-write-file-hook write-file-hooks))
|
|
|
3333 (setq write-file-hooks
|
|
|
3334 (cons 'vm-write-file-hook write-file-hooks)))
|
|
|
3335
|
|
|
3336 (if (not (memq 'vm-handle-file-recovery find-file-hooks))
|
|
|
3337 (setq find-file-hooks
|
|
|
3338 (nconc find-file-hooks
|
|
|
3339 '(vm-handle-file-recovery
|
|
|
3340 vm-handle-file-reversion))))
|
|
|
3341
|
|
|
3342 ;; after-revert-hook is new to FSF v19.23
|
|
|
3343 (defvar after-revert-hook)
|
|
|
3344 (if (boundp 'after-revert-hook)
|
|
|
3345 (setq after-revert-hook
|
|
|
3346 (cons 'vm-after-revert-buffer-hook after-revert-hook))
|
|
|
3347 (setq after-revert-hook (list 'vm-after-revert-buffer-hook)))
|
