Mercurial > hg > xemacs-beta

comparison lisp/vm/vm-misc.el @ 70:131b0175ea99 r20-0b30

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-0b30
author cvs
date Mon, 13 Aug 2007 09:02:59 +0200
parents 05472e90ae02
children c0c698873ce1
comparison
equal deleted inserted replaced
69:804d1389bcd6 70:131b0175ea99
1 ;;; Miscellaneous functions for VM 1 ;;; Miscellaneous functions for VM
2 ;;; Copyright (C) 1989-1997 Kyle E. Jones 2 ;;; Copyright (C) 1989, 1990, 1991, 1993, 1994 Kyle E. Jones
3 ;;; 3 ;;;
4 ;;; This program is free software; you can redistribute it and/or modify 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 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) 6 ;;; the Free Software Foundation; either version 1, or (at your option)
7 ;;; any later version. 7 ;;; any later version.
68 ((= char ?,) 68 ((= char ?,)
69 (setq s (buffer-substring start (point))) 69 (setq s (buffer-substring start (point)))
70 (if (or (null (string-match "^[\t\f\n\r ]+$" s)) 70 (if (or (null (string-match "^[\t\f\n\r ]+$" s))
71 (not (string= s ""))) 71 (not (string= s "")))
72 (setq list (cons s list))) 72 (setq list (cons s list)))
73 (skip-chars-forward ",\t\f\n\r ") 73 (forward-char 1)
74 (skip-chars-forward "\t\f\n\r ")
74 (setq start (point))) 75 (setq start (point)))
75 ((= char ?\") 76 ((= char ?\")
77 (forward-char 1)
76 (re-search-forward "[^\\]\"" nil 0)) 78 (re-search-forward "[^\\]\"" nil 0))
77 ((= char ?\() 79 ((= char ?\()
78 (let ((parens 1)) 80 (let ((parens 1))
79 (forward-char 1) 81 (forward-char 1)
80 (while (and (not (eobp)) (not (zerop parens))) 82 (while (and (not (eobp)) (not (zerop parens)))
81 (re-search-forward "[()]" nil 0) 83 (re-search-forward "[^\\][()]" nil 0)
82 (cond ((or (eobp) 84 (cond ((eobp))
83 (= (char-after (- (point) 2)) ?\\)))
84 ((= (preceding-char) ?\() 85 ((= (preceding-char) ?\()
85 (setq parens (1+ parens))) 86 (setq parens (1+ parens)))
86 (t 87 ((= (preceding-char) ?\))
87 (setq parens (1- parens))))))))) 88 (setq parens (1- parens)))))))))
88 (setq s (buffer-substring start (point))) 89 (setq s (buffer-substring start (point)))
89 (if (and (null (string-match "^[\t\f\n\r ]+$" s)) 90 (if (and (null (string-match "^[\t\f\n\r ]+$" s))
90 (not (string= s ""))) 91 (not (string= s "")))
91 (setq list (cons s list))) 92 (setq list (cons s list)))
92 (nreverse list)) ; jwz: fixed order 93 (nreverse list)) ; jwz: fixed order
93 (and work-buffer (kill-buffer work-buffer)))))))
94
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))))))) 94 (and work-buffer (kill-buffer work-buffer)))))))
174 95
175 (defun vm-write-string (where string) 96 (defun vm-write-string (where string)
176 (if (bufferp where) 97 (if (bufferp where)
177 (vm-save-buffer-excursion 98 (vm-save-buffer-excursion
182 (unwind-protect 103 (unwind-protect
183 (save-excursion 104 (save-excursion
184 (setq temp-buffer (generate-new-buffer "*vm-work*")) 105 (setq temp-buffer (generate-new-buffer "*vm-work*"))
185 (set-buffer temp-buffer) 106 (set-buffer temp-buffer)
186 (insert string) 107 (insert string)
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.
191 (and vm-xemacs-mule-p
192 (set-file-coding-system 'no-conversion nil))
193 (write-region (point-min) (point-max) where t 'quiet)) 108 (write-region (point-min) (point-max) where t 'quiet))
194 (and temp-buffer (kill-buffer temp-buffer)))))) 109 (and temp-buffer (kill-buffer temp-buffer))))))
195 110
196 (defmacro vm-marker (pos &optional buffer) 111 (defmacro vm-marker (pos &optional buffer)
197 (list 'set-marker '(make-marker) pos buffer)) 112 (list 'set-marker '(make-marker) pos buffer))
215 (while mp 130 (while mp
216 (vm-set-su-start-of (car mp) nil) 131 (vm-set-su-start-of (car mp) nil)
217 (vm-set-su-end-of (car mp) nil) 132 (vm-set-su-end-of (car mp) nil)
218 (setq mp (cdr mp)))))) 133 (setq mp (cdr mp))))))
219 134
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
227 (defun vm-check-for-killed-folder () 135 (defun vm-check-for-killed-folder ()
228 (and (bufferp vm-mail-buffer) (null (buffer-name vm-mail-buffer)) 136 (and (bufferp vm-mail-buffer) (null (buffer-name vm-mail-buffer))
229 (setq vm-mail-buffer nil))) 137 (setq vm-mail-buffer nil)))
230 138
231 (defmacro vm-error-if-folder-read-only () 139 (defmacro vm-error-if-folder-read-only ()
232 '(while vm-folder-read-only 140 '(while vm-folder-read-only
233 (signal 'folder-read-only (list (current-buffer))))) 141 (signal 'folder-read-only (list (current-buffer)))))
234 142
235 (put 'folder-read-only 'error-conditions '(folder-read-only error)) 143 ;; XEmacs change
236 (put 'folder-read-only 'error-message "Folder is read-only") 144 (define-error 'folder-read-only "Folder is read-only")
237 145
238 (defmacro vm-error-if-virtual-folder () 146 (defmacro vm-error-if-virtual-folder ()
239 '(and (eq major-mode 'vm-virtual-mode) 147 '(and (eq major-mode 'vm-virtual-mode)
240 (error "%s cannot be applied to virtual folders." this-command))) 148 (error "%s cannot be applied to virtual folders." this-command)))
241 149
296 (if (< vlength length) 204 (if (< vlength length)
297 (apply 'vector (nconc (vm-vector-to-list vector) 205 (apply 'vector (nconc (vm-vector-to-list vector)
298 (make-list (- length vlength) fill))) 206 (make-list (- length vlength) fill)))
299 vector ))) 207 vector )))
300 208
301 (defun vm-obarray-to-string-list (blobarray) 209 (defun vm-obarray-to-string-list (obarray)
302 (let ((list nil)) 210 (let ((list nil))
303 (mapatoms (function (lambda (s) (setq list (cons (symbol-name s) list)))) 211 (mapatoms (function (lambda (s) (setq list (cons (symbol-name s) list))))
304 blobarray) 212 obarray)
305 list )) 213 list ))
306 214
307 (defun vm-mapcar (function &rest lists) 215 (defun vm-mapcar (function &rest lists)
308 (let (arglist result) 216 (let (arglist result)
309 (while (car lists) 217 (while (car lists)
327 (setq list (cdr list) p list) 235 (setq list (cdr list) p list)
328 (setcdr prev (cdr p)) 236 (setcdr prev (cdr p))
329 (setq p (cdr p))) 237 (setq p (cdr p)))
330 (setq prev p p (cdr p)))) 238 (setq prev p p (cdr p))))
331 list )) 239 list ))
332
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 240
342 (defun vm-delete-duplicates (list &optional all hack-addresses) 241 (defun vm-delete-duplicates (list &optional all hack-addresses)
343 "Delete duplicate equivalent strings from the list. 242 "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, 243 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. 244 then all occurrences of it are removed instead of just the subsequent ones.
353 (while list 252 (while list
354 (setq sym-string 253 (setq sym-string
355 (if hack-addresses 254 (if hack-addresses
356 (nth 1 (funcall vm-chop-full-name-function (car list))) 255 (nth 1 (funcall vm-chop-full-name-function (car list)))
357 (car list)) 256 (car list))
358 sym-string (or sym-string "-unparseable-garbage-")
359 sym (intern sym-string hashtable)) 257 sym (intern sym-string hashtable))
360 (if (boundp sym) 258 (if (boundp sym)
361 (and all (setcar (symbol-value sym) nil)) 259 (and all (setcar (symbol-value sym) nil))
362 (setq new-list (cons (car list) new-list)) 260 (setq new-list (cons (car list) new-list))
363 (set sym new-list)) 261 (set sym new-list))
392 (let ((values (mapcar 'symbol-value variables))) 290 (let ((values (mapcar 'symbol-value variables)))
393 (save-excursion 291 (save-excursion
394 (set-buffer buffer) 292 (set-buffer buffer)
395 (vm-mapc 'set variables values)))) 293 (vm-mapc 'set variables values))))
396 294
397 (put 'folder-empty 'error-conditions '(folder-empty error)) 295 ;; XEmacs change
398 (put 'folder-empty 'error-message "Folder is empty") 296 (define-error 'folder-empty "Folder is empty")
399 (put 'unrecognized-folder-type 'error-conditions 297 (define-error 'unrecognized-folder-type "Unrecognized folder type")
400 '(unrecognized-folder-type error))
401 (put 'unrecognized-folder-type 'error-message "Unrecognized folder type")
402 298
403 (defun vm-error-if-folder-empty () 299 (defun vm-error-if-folder-empty ()
404 (while (null vm-message-list) 300 (while (null vm-message-list)
405 (if vm-folder-type 301 (if vm-folder-type
406 (signal 'unrecognized-folder-type nil) 302 (signal 'unrecognized-folder-type nil)
418 object (cdr object))) 314 object (cdr object)))
419 (setcdr cons object) 315 (setcdr cons object)
420 return-value )) 316 return-value ))
421 ((vectorp object) (apply 'vector (mapcar 'vm-copy object))) 317 ((vectorp object) (apply 'vector (mapcar 'vm-copy object)))
422 ((stringp object) (copy-sequence object)) 318 ((stringp object) (copy-sequence object))
423 ((markerp object) (copy-marker object))
424 (t object))) 319 (t object)))
425 320
426 (defun vm-multiple-frames-possible-p () 321 (defun vm-xemacs-p ()
427 (cond (vm-xemacs-p 322 (let ((case-fold-search nil))
428 (or (memq 'win (device-matching-specifier-tag-list)) 323 (string-match "XEmacs" emacs-version)))
429 (featurep 'tty-frames))) 324
430 (vm-fsfemacs-19-p 325 (defun vm-fsfemacs-19-p ()
431 (fboundp 'make-frame)))) 326 (and (string-match "^19" emacs-version)
432 327 (not (string-match "XEmacs\\|Lucid" emacs-version))))
433 (defun vm-mouse-support-possible-p () 328
434 (cond (vm-xemacs-p 329 ;; make-frame might be defined and still not work. This would
435 (featurep 'window-system)) 330 ;; be true since the user could be running on a tty and using
436 (vm-fsfemacs-19-p 331 ;; XEmacs 19.12, or using FSF Emacs 19.28 (or prior FSF Emacs versions).
437 (fboundp 'track-mouse)))) 332 ;;
438 333 ;; make-frame works on ttys in FSF Emacs 19.29, but other than
439 (defun vm-mouse-support-possible-here-p () 334 ;; looking at the version number I don't know a sane way to
440 (cond (vm-xemacs-p 335 ;; test for it without just running make-frame. I'll just
441 (memq 'win (device-matching-specifier-tag-list))) 336 ;; let it not work for now... someone will complain eventually
442 (vm-fsfemacs-19-p 337 ;; and I'll think of something.
443 (eq window-system 'x)))) 338 (defun vm-multiple-frames-possible-p ()
339 (or (and (boundp 'window-system) (not (eq window-system nil)))
340 (and (fboundp 'device-type) (eq (device-type) 'x))))
341
342 (defun vm-mouse-support-possible-p ()
343 (vm-multiple-frames-possible-p))
444 344
445 (defun vm-menu-support-possible-p () 345 (defun vm-menu-support-possible-p ()
446 (cond (vm-xemacs-p 346 (or (and (boundp 'window-system) (eq window-system 'x))
447 (featurep 'menubar)) 347 (and (fboundp 'device-type) (eq (device-type) 'x))))
448 (vm-fsfemacs-19-p 348
449 (fboundp 'menu-bar-mode))))
450
451 (defun vm-toolbar-support-possible-p () 349 (defun vm-toolbar-support-possible-p ()
452 (and vm-xemacs-p (featurep 'toolbar))) 350 (and (vm-xemacs-p)
453 351 (vm-multiple-frames-possible-p)
454 (defun vm-multiple-fonts-possible-p () 352 (featurep 'toolbar)))
455 (cond (vm-xemacs-p
456 (eq (device-type) 'x))
457 (vm-fsfemacs-19-p
458 (or (eq window-system 'x)
459 (eq window-system 'win32)))))
460 353
461 (defun vm-run-message-hook (message &optional hook-variable) 354 (defun vm-run-message-hook (message &optional hook-variable)
462 (save-excursion 355 (save-excursion
463 (set-buffer (vm-buffer-of message)) 356 (set-buffer (vm-buffer-of message))
464 (vm-save-restriction 357 (vm-save-restriction
470 (defun vm-error-free-call (function &rest args) 363 (defun vm-error-free-call (function &rest args)
471 (condition-case nil 364 (condition-case nil
472 (apply function args) 365 (apply function args)
473 (error nil))) 366 (error nil)))
474 367
475 (put 'beginning-of-folder 'error-conditions '(beginning-of-folder error)) 368 ;; XEmacs change
476 (put 'beginning-of-folder 'error-message "Beginning of folder") 369 (define-error 'beginning-of-folder "Beginning of folder")
477 (put 'end-of-folder 'error-conditions '(end-of-folder error)) 370 (define-error 'end-of-folder "End of folder")
478 (put 'end-of-folder 'error-message "End of folder")
479 371
480 (defun vm-trace (&rest args) 372 (defun vm-trace (&rest args)
481 (save-excursion 373 (save-excursion
482 (set-buffer (get-buffer-create "*vm-trace*")) 374 (set-buffer (get-buffer-create "*vm-trace*"))
483 (apply 'insert args))) 375 (apply 'insert args)))
501 (if (equal (aref vect 5) "") 393 (if (equal (aref vect 5) "")
502 (aset vect 5 (vm-current-time-zone))) 394 (aset vect 5 (vm-current-time-zone)))
503 ;; save this work so we won't have to do it again 395 ;; save this work so we won't have to do it again
504 (setq vm-sortable-date-alist 396 (setq vm-sortable-date-alist
505 (cons (cons string 397 (cons (cons string
506 (condition-case nil 398 (timezone-make-date-sortable
507 (timezone-make-date-sortable 399 (format "%s %s %s %s %s"
508 (format "%s %s %s %s %s" 400 (aref vect 1)
509 (aref vect 1) 401 (aref vect 2)
510 (aref vect 2) 402 (aref vect 3)
511 (aref vect 3) 403 (aref vect 4)
512 (aref vect 4) 404 (aref vect 5))))
513 (aref vect 5)))
514 (error "1970010100:00:00")))
515 vm-sortable-date-alist)) 405 vm-sortable-date-alist))
516 ;; return result 406 ;; return result
517 (cdr (car vm-sortable-date-alist))))) 407 (cdr (car vm-sortable-date-alist)))))
518 408
519 (defun vm-current-time-zone () 409 (defun vm-current-time-zone ()
565 (or (get-file-buffer file) 455 (or (get-file-buffer file)
566 (and (fboundp 'file-truename) 456 (and (fboundp 'file-truename)
567 (get-file-buffer (file-truename file))))) 457 (get-file-buffer (file-truename file)))))
568 458
569 (defun vm-set-region-face (start end face) 459 (defun vm-set-region-face (start end face)
570 (let ((e (vm-make-extent start end))) 460 (cond ((fboundp 'make-overlay)
571 (vm-set-extent-property e 'face face))) 461 (let ((o (make-overlay start end)))
462 (overlay-put o 'face face)))
463 ((fboundp 'make-extent)
464 (let ((o (make-extent start end)))
465 (set-extent-property o 'face face)))))
466
467 (defun vm-unsaved-message (&rest args)
468 (let ((message-log-max nil))
469 (apply (function message) args)))
572 470
573 (defun vm-default-buffer-substring-no-properties (beg end &optional buffer) 471 (defun vm-default-buffer-substring-no-properties (beg end &optional buffer)
574 (let ((s (if buffer 472 (let ((s (if buffer
575 (save-excursion 473 (save-excursion
576 (set-buffer buffer) 474 (set-buffer buffer)
580 (copy-sequence s))) 478 (copy-sequence s)))
581 479
582 (fset 'vm-buffer-substring-no-properties 480 (fset 'vm-buffer-substring-no-properties
583 (cond ((fboundp 'buffer-substring-no-properties) 481 (cond ((fboundp 'buffer-substring-no-properties)
584 (function buffer-substring-no-properties)) 482 (function buffer-substring-no-properties))
585 (vm-xemacs-p 483 ((vm-xemacs-p)
586 (function buffer-substring)) 484 (function buffer-substring))
587 (t (function vm-default-buffer-substring-no-properties)))) 485 (t (function vm-default-buffer-substring-no-properties))))
588 486
589 (defun vm-buffer-string-no-properties () 487 (defun vm-buffer-string-no-properties ()
590 (vm-buffer-substring-no-properties (point-min) (point-max))) 488 (vm-buffer-substring-no-properties (point-min) (point-max)))
591
592 (defun vm-insert-region-from-buffer (buffer &optional start end)
593 (let ((target-buffer (current-buffer)))
594 (set-buffer buffer)
595 (save-restriction
596 (widen)
597 (or start (setq start (point-min)))
598 (or end (setq end (point-max)))
599 (set-buffer target-buffer)
600 (insert-buffer-substring buffer start end)
601 (set-buffer buffer))
602 (set-buffer target-buffer)))
603
604 (if (not (fboundp 'vm-extent-property))
605 (if (fboundp 'overlay-get)
606 (fset 'vm-extent-property 'overlay-get)
607 (fset 'vm-extent-property 'extent-property)))
608
609 (if (not (fboundp 'vm-set-extent-property))
610 (if (fboundp 'overlay-put)
611 (fset 'vm-set-extent-property 'overlay-put)
612 (fset 'vm-set-extent-property 'set-extent-property)))
613
614 (if (not (fboundp 'vm-set-extent-endpoints))
615 (if (fboundp 'move-overlay)
616 (fset 'vm-set-extent-endpoints 'move-overlay)
617 (fset 'vm-set-extent-endpoints 'set-extent-endpoints)))
618
619 (if (not (fboundp 'vm-make-extent))
620 (if (fboundp 'make-overlay)
621 (fset 'vm-make-extent 'make-overlay)
622 (fset 'vm-make-extent 'make-extent)))
623
624 (if (not (fboundp 'vm-extent-end-position))
625 (if (fboundp 'overlay-end)
626 (fset 'vm-extent-end-position 'overlay-end)
627 (fset 'vm-extent-end-position 'extent-end-position)))
628
629 (if (not (fboundp 'vm-extent-start-position))
630 (if (fboundp 'overlay-start)
631 (fset 'vm-extent-start-position 'overlay-start)
632 (fset 'vm-extent-start-position 'extent-start-position)))
633
634 (if (not (fboundp 'vm-detach-extent))
635 (if (fboundp 'delete-overlay)
636 (fset 'vm-detach-extent 'delete-overlay)
637 (fset 'vm-detach-extent 'detach-extent)))
638
639 (if (not (fboundp 'vm-extent-properties))
640 (if (fboundp 'overlay-properties)
641 (fset 'vm-extent-properties 'overlay-properties)
642 (fset 'vm-extent-properties 'extent-properties)))
643
644 (defun vm-copy-extent (e)
645 (let ((props (vm-extent-properties e))
646 (ee (vm-make-extent (vm-extent-start-position e)
647 (vm-extent-end-position e))))
648 (while props
649 (vm-set-extent-property ee (car props) (car (cdr props)))
650 (setq props (cdr (cdr props))))))
651
652 (defun vm-make-tempfile-name ()
653 (let ((done nil) (pid (emacs-pid)) filename)
654 (while (not done)
655 (setq filename (format "%s/vm%d.%d" vm-temp-file-directory pid
656 vm-tempfile-counter)
657 vm-tempfile-counter (1+ vm-tempfile-counter)
658 done (not (file-exists-p filename))))
659 filename ))
660
661 (defun vm-insert-char (char &optional count ignored buffer)
662 (condition-case nil
663 (progn
664 (insert-char char count ignored buffer)
665 (fset 'vm-insert-char 'insert-char))
666 (wrong-number-of-arguments
667 (fset 'vm-insert-char 'vm-xemacs-compatible-insert-char)
668 (vm-insert-char char count ignored buffer))))
669
670 (defun vm-xemacs-compatible-insert-char (char &optional count ignored buffer)
671 (if (and buffer (eq buffer (current-buffer)))
672 (insert-char char count)
673 (save-excursion
674 (set-buffer buffer)
675 (insert-char char count))))
676
677 (defun vm-symbol-lists-intersect-p (list1 list2)
678 (catch 'done
679 (while list1
680 (and (memq (car list1) list2)
681 (throw 'done t))
682 (setq list1 (cdr list1)))
683 nil ))
684
685 (defun vm-set-buffer-variable (buffer var value)
686 (save-excursion
687 (set-buffer buffer)
688 (set var value)))
689
690 (defun vm-buffer-variable-value (buffer var)
691 (save-excursion
692 (set-buffer buffer)
693 (symbol-value var)))
694
695 (defsubst vm-with-string-as-temp-buffer (string function)
696 (let ((work-buffer nil))
697 (unwind-protect
698 (save-excursion
699 (setq work-buffer (generate-new-buffer " *work*"))
700 (set-buffer work-buffer)
701 (insert string)
702 (funcall function)
703 (buffer-string))
704 (and work-buffer (kill-buffer work-buffer)))))
705
706 (defmacro vm-with-virtual-selector-variables (&rest forms)
707 (append '(let ((any 'vm-vs-any)
708 (and 'vm-vs-and)
709 (or 'vm-vs-or)
710 (not 'vm-vs-not)
711 (header 'vm-vs-header)
712 (label 'vm-vs-label)
713 (text 'vm-vs-text)
714 (recipient 'vm-vs-recipient)
715 (author 'vm-vs-author)
716 (subject 'vm-vs-subject)
717 (sent-before 'vm-vs-sent-before)
718 (sent-after 'vm-vs-sent-after)
719 (more-chars-than 'vm-vs-more-chars-than)
720 (less-chars-than 'vm-vs-less-chars-than)
721 (more-lines-than 'vm-vs-more-lines-than)
722 (less-lines-than 'vm-vs-less-lines-than)
723 (new 'vm-vs-new)
724 (unread 'vm-vs-unread)
725 (read 'vm-vs-read)
726 (deleted 'vm-vs-deleted)
727 (replied 'vm-vs-replied)
728 (forwarded 'vm-vs-forwarded)
729 (filed 'vm-vs-filed)
730 (written 'vm-vs-written)
731 (edited 'vm-vs-edited)
732 (marked 'vm-vs-marked)))
733 forms))
734
735 (defun vm-string-assoc (elt list)
736 (let ((case-fold-search t)
737 (found nil)
738 (elt (regexp-quote elt)))
739 (while (and list (not found))
740 (if (and (equal 0 (string-match elt (car (car list))))
741 (= (match-end 0) (length (car (car list)))))
742 (setq found t)
743 (setq list (cdr list))))
744 (car list)))
745
746 (defun vm-string-member (elt list)
747 (let ((case-fold-search t)
748 (found nil)
749 (elt (regexp-quote elt)))
750 (while (and list (not found))
751 (if (and (equal 0 (string-match elt (car list)))
752 (= (match-end 0) (length (car list))))
753 (setq found t)
754 (setq list (cdr list))))
755 list))
756
757 (defmacro vm-assert (expression)
758 (list 'or expression
759 (list 'progn
760 (list 'setq 'debug-on-error t)
761 (list 'error "assertion failed: %S"
762 (list 'quote expression)))))