|
0
|
1 ;;; Miscellaneous functions for VM
|
|
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-misc)
|
|
|
19
|
|
|
20 (defun vm-delete-non-matching-strings (regexp list &optional destructively)
|
|
|
21 "Delete strings matching REGEXP from LIST.
|
|
|
22 Optional third arg non-nil means to destructively alter LIST, instead of
|
|
|
23 working on a copy.
|
|
|
24
|
|
|
25 The new version of the list, minus the deleted strings, is returned."
|
|
|
26 (or destructively (setq list (copy-sequence list)))
|
|
|
27 (let ((curr list) (prev nil))
|
|
|
28 (while curr
|
|
|
29 (if (string-match regexp (car curr))
|
|
|
30 (setq prev curr
|
|
|
31 curr (cdr curr))
|
|
|
32 (if (null prev)
|
|
|
33 (setq list (cdr list)
|
|
|
34 curr list)
|
|
|
35 (setcdr prev (cdr curr))
|
|
|
36 (setq curr (cdr curr)))))
|
|
|
37 list ))
|
|
|
38
|
|
|
39 (defun vm-parse (string regexp &optional matchn)
|
|
|
40 (or matchn (setq matchn 1))
|
|
|
41 (let (list)
|
|
|
42 (store-match-data nil)
|
|
|
43 (while (string-match regexp string (match-end 0))
|
|
|
44 (setq list (cons (substring string (match-beginning matchn)
|
|
|
45 (match-end matchn)) list)))
|
|
|
46 (nreverse list)))
|
|
|
47
|
|
|
48 (defun vm-parse-addresses (string)
|
|
|
49 (if (null string)
|
|
|
50 ()
|
|
|
51 (let (work-buffer)
|
|
|
52 (save-excursion
|
|
|
53 (unwind-protect
|
|
|
54 (let (list start s char)
|
|
|
55 (setq work-buffer (generate-new-buffer "*vm-work*"))
|
|
|
56 (set-buffer work-buffer)
|
|
|
57 (insert string)
|
|
|
58 (goto-char (point-min))
|
|
|
59 (skip-chars-forward "\t\f\n\r ")
|
|
|
60 (setq start (point))
|
|
|
61 (while (not (eobp))
|
|
|
62 (skip-chars-forward "^\"\\,(")
|
|
|
63 (setq char (following-char))
|
|
|
64 (cond ((= char ?\\)
|
|
|
65 (forward-char 1)
|
|
|
66 (if (not (eobp))
|
|
|
67 (forward-char 1)))
|
|
|
68 ((= char ?,)
|
|
|
69 (setq s (buffer-substring start (point)))
|
|
|
70 (if (or (null (string-match "^[\t\f\n\r ]+$" s))
|
|
|
71 (not (string= s "")))
|
|
|
72 (setq list (cons s list)))
|
|
76
|
73 (skip-chars-forward ",\t\f\n\r ")
|
|
0
|
74 (setq start (point)))
|
|
|
75 ((= char ?\")
|
|
|
76 (re-search-forward "[^\\]\"" nil 0))
|
|
|
77 ((= char ?\()
|
|
|
78 (let ((parens 1))
|
|
|
79 (forward-char 1)
|
|
|
80 (while (and (not (eobp)) (not (zerop parens)))
|
|
76
|
81 (re-search-forward "[()]" nil 0)
|
|
|
82 (cond ((or (eobp)
|
|
|
83 (= (char-after (- (point) 2)) ?\\)))
|
|
0
|
84 ((= (preceding-char) ?\()
|
|
|
85 (setq parens (1+ parens)))
|
|
76
|
86 (t
|
|
0
|
87 (setq parens (1- parens)))))))))
|
|
|
88 (setq s (buffer-substring start (point)))
|
|
|
89 (if (and (null (string-match "^[\t\f\n\r ]+$" s))
|
|
|
90 (not (string= s "")))
|
|
|
91 (setq list (cons s list)))
|
|
|
92 (nreverse list)) ; jwz: fixed order
|
|
|
93 (and work-buffer (kill-buffer work-buffer)))))))
|
|
|
94
|
|
118
|
95 (defun vm-parse-structured-header (string &optional sepchar keep-quotes)
|
|
|
96 (if (null string)
|
|
|
97 ()
|
|
|
98 (let ((work-buffer nil))
|
|
|
99 (save-excursion
|
|
|
100 (unwind-protect
|
|
|
101 (let ((list nil)
|
|
|
102 (nonspecials "^\"\\( \t\n\r\f")
|
|
|
103 start s char sp+sepchar)
|
|
|
104 (if sepchar
|
|
|
105 (setq nonspecials (concat nonspecials (list sepchar))
|
|
|
106 sp+sepchar (concat "\t\f\n\r " (list sepchar))))
|
|
|
107 (setq work-buffer (generate-new-buffer "*vm-work*"))
|
|
|
108 (buffer-disable-undo work-buffer)
|
|
|
109 (set-buffer work-buffer)
|
|
|
110 (insert string)
|
|
|
111 (goto-char (point-min))
|
|
|
112 (skip-chars-forward "\t\f\n\r ")
|
|
|
113 (setq start (point))
|
|
|
114 (while (not (eobp))
|
|
|
115 (skip-chars-forward nonspecials)
|
|
|
116 (setq char (following-char))
|
|
|
117 (cond ((looking-at "[ \t\n\r\f]")
|
|
|
118 (delete-char 1))
|
|
|
119 ((= char ?\\)
|
|
|
120 (forward-char 1)
|
|
|
121 (if (not (eobp))
|
|
|
122 (forward-char 1)))
|
|
|
123 ((and sepchar (= char sepchar))
|
|
|
124 (setq s (buffer-substring start (point)))
|
|
|
125 (if (or (null (string-match "^[\t\f\n\r ]+$" s))
|
|
|
126 (not (string= s "")))
|
|
|
127 (setq list (cons s list)))
|
|
|
128 (skip-chars-forward sp+sepchar)
|
|
|
129 (setq start (point)))
|
|
|
130 ((looking-at " \t\n\r\f")
|
|
|
131 (skip-chars-forward " \t\n\r\f"))
|
|
|
132 ((= char ?\")
|
|
|
133 (let ((done nil))
|
|
|
134 (if keep-quotes
|
|
|
135 (forward-char 1)
|
|
|
136 (delete-char 1))
|
|
|
137 (while (not done)
|
|
|
138 (if (null (re-search-forward "[\\\"]" nil t))
|
|
|
139 (setq done t)
|
|
|
140 (setq char (char-after (1- (point))))
|
|
|
141 (cond ((char-equal char ?\\)
|
|
|
142 (delete-char -1)
|
|
|
143 (if (eobp)
|
|
|
144 (setq done t)
|
|
|
145 (forward-char 1)))
|
|
|
146 (t (if (not keep-quotes)
|
|
|
147 (delete-char -1))
|
|
|
148 (setq done t)))))))
|
|
|
149 ((= char ?\()
|
|
|
150 (let ((done nil)
|
|
|
151 (pos (point))
|
|
|
152 (parens 1))
|
|
|
153 (forward-char 1)
|
|
|
154 (while (not done)
|
|
|
155 (if (null (re-search-forward "[\\()]" nil t))
|
|
|
156 (setq done t)
|
|
|
157 (setq char (char-after (1- (point))))
|
|
|
158 (cond ((char-equal char ?\\)
|
|
|
159 (if (eobp)
|
|
|
160 (setq done t)
|
|
|
161 (forward-char 1)))
|
|
|
162 ((char-equal char ?\()
|
|
|
163 (setq parens (1+ parens)))
|
|
|
164 (t
|
|
|
165 (setq parens (1- parens)
|
|
|
166 done (zerop parens))))))
|
|
|
167 (delete-region pos (point))))))
|
|
|
168 (setq s (buffer-substring start (point)))
|
|
|
169 (if (and (null (string-match "^[\t\f\n\r ]+$" s))
|
|
|
170 (not (string= s "")))
|
|
|
171 (setq list (cons s list)))
|
|
|
172 (nreverse list))
|
|
|
173 (and work-buffer (kill-buffer work-buffer)))))))
|
|
|
174
|
|
0
|
175 (defun vm-write-string (where string)
|
|
|
176 (if (bufferp where)
|
|
|
177 (vm-save-buffer-excursion
|
|
|
178 (set-buffer where)
|
|
|
179 (goto-char (point-max))
|
|
|
180 (insert string))
|
|
|
181 (let ((temp-buffer nil))
|
|
|
182 (unwind-protect
|
|
|
183 (save-excursion
|
|
|
184 (setq temp-buffer (generate-new-buffer "*vm-work*"))
|
|
|
185 (set-buffer temp-buffer)
|
|
|
186 (insert string)
|
|
100
|
187 ;; correct for VM's uses of this function---
|
|
|
188 ;; writing out message separators
|
|
|
189 (setq buffer-file-type nil)
|
|
|
190 ;; Tell XEmacs/MULE to pick the correct newline conversion.
|
|
120
|
191 (and vm-xemacs-mule-p
|
|
100
|
192 (set-file-coding-system 'no-conversion nil))
|
|
0
|
193 (write-region (point-min) (point-max) where t 'quiet))
|
|
|
194 (and temp-buffer (kill-buffer temp-buffer))))))
|
|
|
195
|
|
|
196 (defmacro vm-marker (pos &optional buffer)
|
|
|
197 (list 'set-marker '(make-marker) pos buffer))
|
|
|
198
|
|
|
199 (defmacro vm-increment (variable)
|
|
|
200 (list 'setq variable (list '1+ variable)))
|
|
|
201
|
|
|
202 (defmacro vm-decrement (variable)
|
|
|
203 (list 'setq variable (list '1- variable)))
|
|
|
204
|
|
|
205 (defmacro vm-select-folder-buffer ()
|
|
|
206 '(and vm-mail-buffer
|
|
|
207 (or (buffer-name vm-mail-buffer)
|
|
|
208 (error "Folder buffer has been killed."))
|
|
|
209 (set-buffer vm-mail-buffer)))
|
|
|
210
|
|
|
211 (defun vm-check-for-killed-summary ()
|
|
|
212 (and (bufferp vm-summary-buffer) (null (buffer-name vm-summary-buffer))
|
|
|
213 (let ((mp vm-message-list))
|
|
|
214 (setq vm-summary-buffer nil)
|
|
|
215 (while mp
|
|
|
216 (vm-set-su-start-of (car mp) nil)
|
|
|
217 (vm-set-su-end-of (car mp) nil)
|
|
|
218 (setq mp (cdr mp))))))
|
|
|
219
|
|
98
|
220 (defun vm-check-for-killed-presentation ()
|
|
|
221 (and (bufferp vm-presentation-buffer-handle)
|
|
|
222 (null (buffer-name vm-presentation-buffer-handle))
|
|
|
223 (progn
|
|
|
224 (setq vm-presentation-buffer-handle nil
|
|
|
225 vm-presentation-buffer nil))))
|
|
|
226
|
|
0
|
227 (defun vm-check-for-killed-folder ()
|
|
|
228 (and (bufferp vm-mail-buffer) (null (buffer-name vm-mail-buffer))
|
|
|
229 (setq vm-mail-buffer nil)))
|
|
|
230
|
|
|
231 (defmacro vm-error-if-folder-read-only ()
|
|
|
232 '(while vm-folder-read-only
|
|
|
233 (signal 'folder-read-only (list (current-buffer)))))
|
|
|
234
|
|
76
|
235 (put 'folder-read-only 'error-conditions '(folder-read-only error))
|
|
|
236 (put 'folder-read-only 'error-message "Folder is read-only")
|
|
0
|
237
|
|
|
238 (defmacro vm-error-if-virtual-folder ()
|
|
|
239 '(and (eq major-mode 'vm-virtual-mode)
|
|
|
240 (error "%s cannot be applied to virtual folders." this-command)))
|
|
|
241
|
|
|
242 (defmacro vm-build-threads-if-unbuilt ()
|
|
|
243 '(if (null vm-thread-obarray)
|
|
|
244 (vm-build-threads nil)))
|
|
|
245
|
|
|
246 (defun vm-abs (n) (if (< n 0) (- n) n))
|
|
|
247
|
|
|
248 ;; save-restriction flubs restoring the clipping region if you
|
|
|
249 ;; (widen) and modify text outside the old region.
|
|
|
250 ;; This should do it right.
|
|
|
251 (defmacro vm-save-restriction (&rest forms)
|
|
|
252 (let ((vm-sr-clip (make-symbol "vm-sr-clip"))
|
|
|
253 (vm-sr-min (make-symbol "vm-sr-min"))
|
|
|
254 (vm-sr-max (make-symbol "vm-sr-max")))
|
|
|
255 (list 'let (list (list vm-sr-clip '(> (buffer-size)
|
|
|
256 (- (point-max) (point-min))))
|
|
|
257 ;; this shouldn't be necessary but the
|
|
|
258 ;; byte-compiler turns these into interned symbols
|
|
|
259 ;; which utterly defeats the purpose of the
|
|
|
260 ;; make-symbol calls above. Soooo, until the compiler
|
|
|
261 ;; is fixed, these must be made into (let ...)
|
|
|
262 ;; temporaries so that nested calls to this macros
|
|
|
263 ;; won't misbehave.
|
|
|
264 vm-sr-min vm-sr-max)
|
|
|
265 (list 'and vm-sr-clip
|
|
|
266 (list 'setq vm-sr-min '(set-marker (make-marker) (point-min)))
|
|
|
267 (list 'setq vm-sr-max '(set-marker (make-marker) (point-max))))
|
|
|
268 (list 'unwind-protect (cons 'progn forms)
|
|
|
269 '(widen)
|
|
|
270 (list 'and vm-sr-clip
|
|
|
271 (list 'progn
|
|
|
272 (list 'narrow-to-region vm-sr-min vm-sr-max)
|
|
|
273 (list 'set-marker vm-sr-min nil)
|
|
|
274 (list 'set-marker vm-sr-max nil)))))))
|
|
|
275
|
|
|
276 (defmacro vm-save-buffer-excursion (&rest forms)
|
|
|
277 (list 'let '((vm-sbe-buffer (current-buffer)))
|
|
|
278 (list 'unwind-protect
|
|
|
279 (cons 'progn forms)
|
|
|
280 '(and (not (eq vm-sbe-buffer (current-buffer)))
|
|
|
281 (buffer-name vm-sbe-buffer)
|
|
|
282 (set-buffer vm-sbe-buffer)))))
|
|
|
283
|
|
|
284 (defun vm-last (list) (while (cdr-safe list) (setq list (cdr list))) list)
|
|
|
285
|
|
|
286 (defun vm-vector-to-list (vector)
|
|
|
287 (let ((i (1- (length vector)))
|
|
|
288 list)
|
|
|
289 (while (>= i 0)
|
|
|
290 (setq list (cons (aref vector i) list))
|
|
|
291 (vm-decrement i))
|
|
|
292 list ))
|
|
|
293
|
|
|
294 (defun vm-extend-vector (vector length &optional fill)
|
|
|
295 (let ((vlength (length vector)))
|
|
|
296 (if (< vlength length)
|
|
|
297 (apply 'vector (nconc (vm-vector-to-list vector)
|
|
|
298 (make-list (- length vlength) fill)))
|
|
|
299 vector )))
|
|
|
300
|
|
108
|
301 (defun vm-obarray-to-string-list (blobarray)
|
|
0
|
302 (let ((list nil))
|
|
|
303 (mapatoms (function (lambda (s) (setq list (cons (symbol-name s) list))))
|
|
108
|
304 blobarray)
|
|
0
|
305 list ))
|
|
|
306
|
|
|
307 (defun vm-mapcar (function &rest lists)
|
|
|
308 (let (arglist result)
|
|
|
309 (while (car lists)
|
|
|
310 (setq arglist (mapcar 'car lists))
|
|
|
311 (setq result (cons (apply function arglist) result))
|
|
|
312 (setq lists (mapcar 'cdr lists)))
|
|
|
313 (nreverse result)))
|
|
|
314
|
|
|
315 (defun vm-mapc (function &rest lists)
|
|
|
316 (let (arglist)
|
|
|
317 (while (car lists)
|
|
|
318 (setq arglist (mapcar 'car lists))
|
|
|
319 (apply function arglist)
|
|
|
320 (setq lists (mapcar 'cdr lists)))))
|
|
|
321
|
|
|
322 (defun vm-delete (predicate list &optional reverse)
|
|
|
323 (let ((p list) (reverse (if reverse 'not 'identity)) prev)
|
|
|
324 (while p
|
|
|
325 (if (funcall reverse (funcall predicate (car p)))
|
|
|
326 (if (null prev)
|
|
|
327 (setq list (cdr list) p list)
|
|
|
328 (setcdr prev (cdr p))
|
|
|
329 (setq p (cdr p)))
|
|
|
330 (setq prev p p (cdr p))))
|
|
|
331 list ))
|
|
|
332
|
|
98
|
333 (defun vm-delete-directory-file-names (list)
|
|
|
334 (vm-delete 'file-directory-p list))
|
|
|
335
|
|
|
336 (defun vm-delete-backup-file-names (list)
|
|
|
337 (vm-delete 'backup-file-name-p list))
|
|
|
338
|
|
|
339 (defun vm-delete-auto-save-file-names (list)
|
|
|
340 (vm-delete 'auto-save-file-name-p list))
|
|
|
341
|
|
0
|
342 (defun vm-delete-duplicates (list &optional all hack-addresses)
|
|
|
343 "Delete duplicate equivalent strings from the list.
|
|
|
344 If ALL is t, then if there is more than one occurrence of a string in the list,
|
|
|
345 then all occurrences of it are removed instead of just the subsequent ones.
|
|
|
346 If HACK-ADDRESSES is t, then the strings are considered to be mail addresses,
|
|
|
347 and only the address part is compared (so that \"Name <foo>\" and \"foo\"
|
|
|
348 would be considered to be equivalent.)"
|
|
|
349 (let ((hashtable vm-delete-duplicates-obarray)
|
|
|
350 (new-list nil)
|
|
|
351 sym-string sym)
|
|
|
352 (fillarray hashtable 0)
|
|
|
353 (while list
|
|
|
354 (setq sym-string
|
|
|
355 (if hack-addresses
|
|
|
356 (nth 1 (funcall vm-chop-full-name-function (car list)))
|
|
|
357 (car list))
|
|
100
|
358 sym-string (or sym-string "-unparseable-garbage-")
|
|
0
|
359 sym (intern sym-string hashtable))
|
|
|
360 (if (boundp sym)
|
|
|
361 (and all (setcar (symbol-value sym) nil))
|
|
|
362 (setq new-list (cons (car list) new-list))
|
|
|
363 (set sym new-list))
|
|
|
364 (setq list (cdr list)))
|
|
|
365 (delq nil (nreverse new-list))))
|
|
|
366
|
|
|
367 (defun vm-member-0 (thing list)
|
|
|
368 (catch 'done
|
|
|
369 (while list
|
|
|
370 (and (equal (car list) thing)
|
|
|
371 (throw 'done list))
|
|
|
372 (setq list (cdr list)))
|
|
|
373 nil ))
|
|
|
374
|
|
|
375 (fset 'vm-member (symbol-function (if (fboundp 'member) 'member 'vm-member-0)))
|
|
|
376
|
|
|
377 (defun vm-delqual (ob list)
|
|
|
378 (let ((prev nil)
|
|
|
379 (curr list))
|
|
|
380 (while curr
|
|
|
381 (if (not (equal ob (car curr)))
|
|
|
382 (setq prev curr
|
|
|
383 curr (cdr curr))
|
|
|
384 (if (null prev)
|
|
|
385 (setq list (cdr list)
|
|
|
386 curr list)
|
|
|
387 (setq curr (cdr curr))
|
|
|
388 (setcdr prev curr))))
|
|
|
389 list ))
|
|
|
390
|
|
|
391 (defun vm-copy-local-variables (buffer &rest variables)
|
|
|
392 (let ((values (mapcar 'symbol-value variables)))
|
|
|
393 (save-excursion
|
|
|
394 (set-buffer buffer)
|
|
|
395 (vm-mapc 'set variables values))))
|
|
|
396
|
|
76
|
397 (put 'folder-empty 'error-conditions '(folder-empty error))
|
|
|
398 (put 'folder-empty 'error-message "Folder is empty")
|
|
|
399 (put 'unrecognized-folder-type 'error-conditions
|
|
|
400 '(unrecognized-folder-type error))
|
|
|
401 (put 'unrecognized-folder-type 'error-message "Unrecognized folder type")
|
|
0
|
402
|
|
|
403 (defun vm-error-if-folder-empty ()
|
|
|
404 (while (null vm-message-list)
|
|
|
405 (if vm-folder-type
|
|
|
406 (signal 'unrecognized-folder-type nil)
|
|
|
407 (signal 'folder-empty nil))))
|
|
|
408
|
|
|
409 (defun vm-copy (object)
|
|
|
410 (cond ((consp object)
|
|
|
411 (let (return-value cons)
|
|
|
412 (setq return-value (cons (vm-copy (car object)) nil)
|
|
|
413 cons return-value
|
|
|
414 object (cdr object))
|
|
|
415 (while (consp object)
|
|
|
416 (setcdr cons (cons (vm-copy (car object)) nil))
|
|
|
417 (setq cons (cdr cons)
|
|
|
418 object (cdr object)))
|
|
|
419 (setcdr cons object)
|
|
|
420 return-value ))
|
|
|
421 ((vectorp object) (apply 'vector (mapcar 'vm-copy object)))
|
|
|
422 ((stringp object) (copy-sequence object))
|
|
98
|
423 ((markerp object) (copy-marker object))
|
|
0
|
424 (t object)))
|
|
|
425
|
|
146
|
426 (defun vm-multiple-frames-possible-p ()
|
|
|
427 (cond (vm-xemacs-p
|
|
155
|
428 (or (memq 'win (device-matching-specifier-tag-list))
|
|
|
429 (featurep 'tty-frames)))
|
|
146
|
430 (vm-fsfemacs-19-p
|
|
155
|
431 (fboundp 'make-frame))))
|
|
146
|
432
|
|
|
433 (defun vm-mouse-support-possible-p ()
|
|
155
|
434 (cond (vm-xemacs-p
|
|
|
435 (featurep 'window-system))
|
|
|
436 (vm-fsfemacs-19-p
|
|
|
437 (fboundp 'track-mouse))))
|
|
146
|
438
|
|
155
|
439 (defun vm-mouse-support-possible-here-p ()
|
|
|
440 (cond (vm-xemacs-p
|
|
|
441 (memq 'win (device-matching-specifier-tag-list)))
|
|
|
442 (vm-fsfemacs-19-p
|
|
|
443 (eq window-system 'x))))
|
|
|
444
|
|
0
|
445 (defun vm-menu-support-possible-p ()
|
|
140
|
446 (cond (vm-xemacs-p
|
|
|
447 (featurep 'menubar))
|
|
|
448 (vm-fsfemacs-19-p
|
|
155
|
449 (fboundp 'menu-bar-mode))))
|
|
146
|
450
|
|
0
|
451 (defun vm-toolbar-support-possible-p ()
|
|
146
|
452 (and vm-xemacs-p (featurep 'toolbar)))
|
|
24
|
453
|
|
100
|
454 (defun vm-multiple-fonts-possible-p ()
|
|
146
|
455 (cond (vm-xemacs-p
|
|
|
456 (eq (device-type) 'x))
|
|
|
457 (vm-fsfemacs-19-p
|
|
|
458 (eq window-system 'x))))
|
|
100
|
459
|
|
0
|
460 (defun vm-run-message-hook (message &optional hook-variable)
|
|
|
461 (save-excursion
|
|
|
462 (set-buffer (vm-buffer-of message))
|
|
|
463 (vm-save-restriction
|
|
|
464 (widen)
|
|
|
465 (save-excursion
|
|
|
466 (narrow-to-region (vm-headers-of message) (vm-text-end-of message))
|
|
|
467 (run-hooks hook-variable)))))
|
|
|
468
|
|
|
469 (defun vm-error-free-call (function &rest args)
|
|
|
470 (condition-case nil
|
|
|
471 (apply function args)
|
|
|
472 (error nil)))
|
|
|
473
|
|
76
|
474 (put 'beginning-of-folder 'error-conditions '(beginning-of-folder error))
|
|
|
475 (put 'beginning-of-folder 'error-message "Beginning of folder")
|
|
|
476 (put 'end-of-folder 'error-conditions '(end-of-folder error))
|
|
|
477 (put 'end-of-folder 'error-message "End of folder")
|
|
0
|
478
|
|
|
479 (defun vm-trace (&rest args)
|
|
|
480 (save-excursion
|
|
|
481 (set-buffer (get-buffer-create "*vm-trace*"))
|
|
|
482 (apply 'insert args)))
|
|
|
483
|
|
|
484 (defun vm-timezone-make-date-sortable (string)
|
|
|
485 (or (cdr (assq string vm-sortable-date-alist))
|
|
|
486 (let ((vect (vm-parse-date string))
|
|
|
487 (date (vm-parse (current-time-string) " *\\([^ ]+\\)")))
|
|
|
488 ;; if specified date is incomplete fill in the holes
|
|
|
489 ;; with useful information, defaulting to the current
|
|
|
490 ;; date and timezone for everything except hh:mm:ss which
|
|
|
491 ;; defaults to midnight.
|
|
|
492 (if (equal (aref vect 1) "")
|
|
|
493 (aset vect 1 (nth 2 date)))
|
|
|
494 (if (equal (aref vect 2) "")
|
|
|
495 (aset vect 2 (nth 1 date)))
|
|
|
496 (if (equal (aref vect 3) "")
|
|
|
497 (aset vect 3 (nth 4 date)))
|
|
|
498 (if (equal (aref vect 4) "")
|
|
|
499 (aset vect 4 "00:00:00"))
|
|
|
500 (if (equal (aref vect 5) "")
|
|
|
501 (aset vect 5 (vm-current-time-zone)))
|
|
|
502 ;; save this work so we won't have to do it again
|
|
|
503 (setq vm-sortable-date-alist
|
|
|
504 (cons (cons string
|
|
118
|
505 (condition-case nil
|
|
|
506 (timezone-make-date-sortable
|
|
|
507 (format "%s %s %s %s %s"
|
|
|
508 (aref vect 1)
|
|
|
509 (aref vect 2)
|
|
|
510 (aref vect 3)
|
|
|
511 (aref vect 4)
|
|
|
512 (aref vect 5)))
|
|
|
513 (error "1970010100:00:00")))
|
|
0
|
514 vm-sortable-date-alist))
|
|
|
515 ;; return result
|
|
|
516 (cdr (car vm-sortable-date-alist)))))
|
|
|
517
|
|
|
518 (defun vm-current-time-zone ()
|
|
|
519 (or (condition-case nil
|
|
|
520 (let* ((zone (car (current-time-zone)))
|
|
|
521 (absmin (/ (vm-abs zone) 60)))
|
|
|
522 (format "%c%02d%02d" (if (< zone 0) ?- ?+)
|
|
|
523 (/ absmin 60) (% absmin 60)))
|
|
|
524 (error nil))
|
|
|
525 (let ((temp-buffer nil))
|
|
|
526 (condition-case nil
|
|
|
527 (unwind-protect
|
|
|
528 (save-excursion
|
|
|
529 (setq temp-buffer (generate-new-buffer "*vm-work*"))
|
|
|
530 (set-buffer temp-buffer)
|
|
|
531 (call-process "date" nil temp-buffer nil)
|
|
|
532 (nth 4 (vm-parse (vm-buffer-string-no-properties)
|
|
|
533 " *\\([^ ]+\\)")))
|
|
|
534 (and temp-buffer (kill-buffer temp-buffer)))
|
|
|
535 (error nil)))
|
|
|
536 ""))
|
|
|
537
|
|
|
538 (defun vm-should-generate-summary ()
|
|
|
539 (cond ((eq vm-startup-with-summary t) t)
|
|
|
540 ((integerp vm-startup-with-summary)
|
|
|
541 (let ((n vm-startup-with-summary))
|
|
|
542 (cond ((< n 0) (null (nth (vm-abs n) vm-message-list)))
|
|
|
543 (t (nth (1- n) vm-message-list)))))
|
|
|
544 (vm-startup-with-summary t)
|
|
|
545 (t nil)))
|
|
|
546
|
|
|
547 (defun vm-find-composition-buffer (&optional not-picky)
|
|
|
548 (let ((b-list (buffer-list)) choice alternate)
|
|
|
549 (save-excursion
|
|
|
550 (while b-list
|
|
|
551 (set-buffer (car b-list))
|
|
|
552 (if (eq major-mode 'mail-mode)
|
|
|
553 (if (buffer-modified-p)
|
|
|
554 (setq choice (current-buffer)
|
|
|
555 b-list nil)
|
|
|
556 (and not-picky (null alternate)
|
|
|
557 (setq alternate (current-buffer)))
|
|
|
558 (setq b-list (cdr b-list)))
|
|
|
559 (setq b-list (cdr b-list))))
|
|
|
560 (or choice alternate))))
|
|
|
561
|
|
|
562 (defun vm-get-file-buffer (file)
|
|
|
563 "Like get-file-buffer, but also checks buffers against FILE's truename"
|
|
|
564 (or (get-file-buffer file)
|
|
|
565 (and (fboundp 'file-truename)
|
|
|
566 (get-file-buffer (file-truename file)))))
|
|
|
567
|
|
|
568 (defun vm-set-region-face (start end face)
|
|
120
|
569 (let ((e (vm-make-extent start end)))
|
|
|
570 (vm-set-extent-property e 'face face)))
|
|
70
|
571
|
|
0
|
572 (defun vm-default-buffer-substring-no-properties (beg end &optional buffer)
|
|
|
573 (let ((s (if buffer
|
|
|
574 (save-excursion
|
|
|
575 (set-buffer buffer)
|
|
|
576 (buffer-substring beg end))
|
|
|
577 (buffer-substring beg end))))
|
|
|
578 (set-text-properties 0 (length s) nil s)
|
|
|
579 (copy-sequence s)))
|
|
|
580
|
|
|
581 (fset 'vm-buffer-substring-no-properties
|
|
|
582 (cond ((fboundp 'buffer-substring-no-properties)
|
|
|
583 (function buffer-substring-no-properties))
|
|
120
|
584 (vm-xemacs-p
|
|
0
|
585 (function buffer-substring))
|
|
|
586 (t (function vm-default-buffer-substring-no-properties))))
|
|
|
587
|
|
|
588 (defun vm-buffer-string-no-properties ()
|
|
|
589 (vm-buffer-substring-no-properties (point-min) (point-max)))
|
|
98
|
590
|
|
|
591 (defun vm-insert-region-from-buffer (buffer &optional start end)
|
|
|
592 (let ((target-buffer (current-buffer)))
|
|
|
593 (set-buffer buffer)
|
|
|
594 (save-restriction
|
|
|
595 (widen)
|
|
|
596 (or start (setq start (point-min)))
|
|
|
597 (or end (setq end (point-max)))
|
|
|
598 (set-buffer target-buffer)
|
|
|
599 (insert-buffer-substring buffer start end)
|
|
|
600 (set-buffer buffer))
|
|
|
601 (set-buffer target-buffer)))
|
|
|
602
|
|
120
|
603 (if (not (fboundp 'vm-extent-property))
|
|
|
604 (if (fboundp 'overlay-get)
|
|
|
605 (fset 'vm-extent-property 'overlay-get)
|
|
|
606 (fset 'vm-extent-property 'extent-property)))
|
|
98
|
607
|
|
120
|
608 (if (not (fboundp 'vm-set-extent-property))
|
|
|
609 (if (fboundp 'overlay-put)
|
|
|
610 (fset 'vm-set-extent-property 'overlay-put)
|
|
|
611 (fset 'vm-set-extent-property 'set-extent-property)))
|
|
98
|
612
|
|
120
|
613 (if (not (fboundp 'vm-set-extent-endpoints))
|
|
|
614 (if (fboundp 'move-overlay)
|
|
|
615 (fset 'vm-set-extent-endpoints 'move-overlay)
|
|
|
616 (fset 'vm-set-extent-endpoints 'set-extent-endpoints)))
|
|
108
|
617
|
|
120
|
618 (if (not (fboundp 'vm-make-extent))
|
|
|
619 (if (fboundp 'make-overlay)
|
|
|
620 (fset 'vm-make-extent 'make-overlay)
|
|
|
621 (fset 'vm-make-extent 'make-extent)))
|
|
98
|
622
|
|
120
|
623 (if (not (fboundp 'vm-extent-end-position))
|
|
|
624 (if (fboundp 'overlay-end)
|
|
|
625 (fset 'vm-extent-end-position 'overlay-end)
|
|
|
626 (fset 'vm-extent-end-position 'extent-end-position)))
|
|
98
|
627
|
|
120
|
628 (if (not (fboundp 'vm-extent-start-position))
|
|
|
629 (if (fboundp 'overlay-start)
|
|
|
630 (fset 'vm-extent-start-position 'overlay-start)
|
|
|
631 (fset 'vm-extent-start-position 'extent-start-position)))
|
|
98
|
632
|
|
120
|
633 (if (not (fboundp 'vm-detach-extent))
|
|
|
634 (if (fboundp 'delete-overlay)
|
|
|
635 (fset 'vm-detach-extent 'delete-overlay)
|
|
|
636 (fset 'vm-detach-extent 'detach-extent)))
|
|
98
|
637
|
|
120
|
638 (if (not (fboundp 'vm-extent-properties))
|
|
|
639 (if (fboundp 'overlay-properties)
|
|
|
640 (fset 'vm-extent-properties 'overlay-properties)
|
|
|
641 (fset 'vm-extent-properties 'extent-properties)))
|
|
98
|
642
|
|
|
643 (defun vm-copy-extent (e)
|
|
|
644 (let ((props (vm-extent-properties e))
|
|
|
645 (ee (vm-make-extent (vm-extent-start-position e)
|
|
|
646 (vm-extent-end-position e))))
|
|
|
647 (while props
|
|
|
648 (vm-set-extent-property ee (car props) (car (cdr props)))
|
|
100
|
649 (setq props (cdr (cdr props))))))
|
|
98
|
650
|
|
|
651 (defun vm-make-tempfile-name ()
|
|
|
652 (let ((done nil) (pid (emacs-pid)) filename)
|
|
|
653 (while (not done)
|
|
|
654 (setq filename (format "%s/vm%d.%d" vm-temp-file-directory pid
|
|
|
655 vm-tempfile-counter)
|
|
|
656 vm-tempfile-counter (1+ vm-tempfile-counter)
|
|
|
657 done (not (file-exists-p filename))))
|
|
|
658 filename ))
|
|
|
659
|
|
|
660 (defun vm-insert-char (char &optional count ignored buffer)
|
|
|
661 (condition-case nil
|
|
|
662 (progn
|
|
|
663 (insert-char char count ignored buffer)
|
|
|
664 (fset 'vm-insert-char 'insert-char))
|
|
|
665 (wrong-number-of-arguments
|
|
|
666 (fset 'vm-insert-char 'vm-xemacs-compatible-insert-char)
|
|
|
667 (vm-insert-char char count ignored buffer))))
|
|
|
668
|
|
|
669 (defun vm-xemacs-compatible-insert-char (char &optional count ignored buffer)
|
|
|
670 (if (and buffer (eq buffer (current-buffer)))
|
|
|
671 (insert-char char count)
|
|
|
672 (save-excursion
|
|
|
673 (set-buffer buffer)
|
|
|
674 (insert-char char count))))
|
|
|
675
|
|
|
676 (defun vm-symbol-lists-intersect-p (list1 list2)
|
|
|
677 (catch 'done
|
|
|
678 (while list1
|
|
|
679 (and (memq (car list1) list2)
|
|
|
680 (throw 'done t))
|
|
|
681 (setq list1 (cdr list1)))
|
|
|
682 nil ))
|
|
|
683
|
|
|
684 (defun vm-set-buffer-variable (buffer var value)
|
|
|
685 (save-excursion
|
|
|
686 (set-buffer buffer)
|
|
|
687 (set var value)))
|
|
|
688
|
|
100
|
689 (defun vm-buffer-variable-value (buffer var)
|
|
|
690 (save-excursion
|
|
|
691 (set-buffer buffer)
|
|
|
692 (symbol-value var)))
|
|
|
693
|
|
98
|
694 (defsubst vm-with-string-as-temp-buffer (string function)
|
|
|
695 (let ((work-buffer nil))
|
|
|
696 (unwind-protect
|
|
|
697 (save-excursion
|
|
|
698 (setq work-buffer (generate-new-buffer " *work*"))
|
|
|
699 (set-buffer work-buffer)
|
|
|
700 (insert string)
|
|
|
701 (funcall function)
|
|
|
702 (buffer-string))
|
|
|
703 (and work-buffer (kill-buffer work-buffer)))))
|
|
100
|
704
|
|
|
705 (defmacro vm-with-virtual-selector-variables (&rest forms)
|
|
|
706 (append '(let ((any 'vm-vs-any)
|
|
|
707 (and 'vm-vs-and)
|
|
|
708 (or 'vm-vs-or)
|
|
|
709 (not 'vm-vs-not)
|
|
|
710 (header 'vm-vs-header)
|
|
|
711 (label 'vm-vs-label)
|
|
|
712 (text 'vm-vs-text)
|
|
|
713 (recipient 'vm-vs-recipient)
|
|
|
714 (author 'vm-vs-author)
|
|
|
715 (subject 'vm-vs-subject)
|
|
|
716 (sent-before 'vm-vs-sent-before)
|
|
|
717 (sent-after 'vm-vs-sent-after)
|
|
|
718 (more-chars-than 'vm-vs-more-chars-than)
|
|
|
719 (less-chars-than 'vm-vs-less-chars-than)
|
|
|
720 (more-lines-than 'vm-vs-more-lines-than)
|
|
|
721 (less-lines-than 'vm-vs-less-lines-than)
|
|
|
722 (new 'vm-vs-new)
|
|
|
723 (unread 'vm-vs-unread)
|
|
|
724 (read 'vm-vs-read)
|
|
|
725 (deleted 'vm-vs-deleted)
|
|
|
726 (replied 'vm-vs-replied)
|
|
|
727 (forwarded 'vm-vs-forwarded)
|
|
|
728 (filed 'vm-vs-filed)
|
|
|
729 (written 'vm-vs-written)
|
|
|
730 (edited 'vm-vs-edited)
|
|
|
731 (marked 'vm-vs-marked)))
|
|
|
732 forms))
|
|
|
733
|
|
|
734 (defun vm-string-assoc (elt list)
|
|
|
735 (let ((case-fold-search t)
|
|
|
736 (found nil)
|
|
|
737 (elt (regexp-quote elt)))
|
|
|
738 (while (and list (not found))
|
|
|
739 (if (and (equal 0 (string-match elt (car (car list))))
|
|
|
740 (= (match-end 0) (length (car (car list)))))
|
|
|
741 (setq found t)
|
|
|
742 (setq list (cdr list))))
|
|
|
743 (car list)))
|
|
|
744
|
|
|
745 (defun vm-string-member (elt list)
|
|
|
746 (let ((case-fold-search t)
|
|
|
747 (found nil)
|
|
|
748 (elt (regexp-quote elt)))
|
|
|
749 (while (and list (not found))
|
|
|
750 (if (and (equal 0 (string-match elt (car list)))
|
|
|
751 (= (match-end 0) (length (car list))))
|
|
|
752 (setq found t)
|
|
|
753 (setq list (cdr list))))
|
|
|
754 list))
|
|
108
|
755
|
|
|
756 (defmacro vm-assert (expression)
|
|
|
757 (list 'or expression
|
|
|
758 (list 'progn
|
|
|
759 (list 'setq 'debug-on-error t)
|
|
|
760 (list 'error "assertion failed: %S"
|
|
|
761 (list 'quote expression)))))
|
