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