Mercurial > hg > xemacs-beta

comparison lisp/vm/vm-misc.el @ 98:0d2f883870bc r20-1b1

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-1b1
author cvs
date Mon, 13 Aug 2007 09:13:56 +0200
parents c0c698873ce1
children 4be1180a9e89
comparison
equal deleted inserted replaced
97:498bf5da1c90 98:0d2f883870bc
1 ;;; Miscellaneous functions for VM 1 ;;; Miscellaneous functions for VM
2 ;;; Copyright (C) 1989, 1990, 1991, 1993, 1994 Kyle E. Jones 2 ;;; Copyright (C) 1989-1997 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.
129 (while mp 129 (while mp
130 (vm-set-su-start-of (car mp) nil) 130 (vm-set-su-start-of (car mp) nil)
131 (vm-set-su-end-of (car mp) nil) 131 (vm-set-su-end-of (car mp) nil)
132 (setq mp (cdr mp)))))) 132 (setq mp (cdr mp))))))
133 133
134 (defun vm-check-for-killed-presentation ()
135 (and (bufferp vm-presentation-buffer-handle)
136 (null (buffer-name vm-presentation-buffer-handle))
137 (progn
138 (setq vm-presentation-buffer-handle nil
139 vm-presentation-buffer nil))))
140
134 (defun vm-check-for-killed-folder () 141 (defun vm-check-for-killed-folder ()
135 (and (bufferp vm-mail-buffer) (null (buffer-name vm-mail-buffer)) 142 (and (bufferp vm-mail-buffer) (null (buffer-name vm-mail-buffer))
136 (setq vm-mail-buffer nil))) 143 (setq vm-mail-buffer nil)))
137 144
138 (defmacro vm-error-if-folder-read-only () 145 (defmacro vm-error-if-folder-read-only ()
235 (setcdr prev (cdr p)) 242 (setcdr prev (cdr p))
236 (setq p (cdr p))) 243 (setq p (cdr p)))
237 (setq prev p p (cdr p)))) 244 (setq prev p p (cdr p))))
238 list )) 245 list ))
239 246
247 (defun vm-delete-directory-file-names (list)
248 (vm-delete 'file-directory-p list))
249
250 (defun vm-delete-backup-file-names (list)
251 (vm-delete 'backup-file-name-p list))
252
253 (defun vm-delete-auto-save-file-names (list)
254 (vm-delete 'auto-save-file-name-p list))
255
240 (defun vm-delete-duplicates (list &optional all hack-addresses) 256 (defun vm-delete-duplicates (list &optional all hack-addresses)
241 "Delete duplicate equivalent strings from the list. 257 "Delete duplicate equivalent strings from the list.
242 If ALL is t, then if there is more than one occurrence of a string in the list, 258 If ALL is t, then if there is more than one occurrence of a string in the list,
243 then all occurrences of it are removed instead of just the subsequent ones. 259 then all occurrences of it are removed instead of just the subsequent ones.
244 If HACK-ADDRESSES is t, then the strings are considered to be mail addresses, 260 If HACK-ADDRESSES is t, then the strings are considered to be mail addresses,
315 object (cdr object))) 331 object (cdr object)))
316 (setcdr cons object) 332 (setcdr cons object)
317 return-value )) 333 return-value ))
318 ((vectorp object) (apply 'vector (mapcar 'vm-copy object))) 334 ((vectorp object) (apply 'vector (mapcar 'vm-copy object)))
319 ((stringp object) (copy-sequence object)) 335 ((stringp object) (copy-sequence object))
336 ((markerp object) (copy-marker object))
320 (t object))) 337 (t object)))
321 338
322 (defun vm-xemacs-p () 339 (defun vm-xemacs-p ()
323 (let ((case-fold-search nil)) 340 (let ((case-fold-search nil))
324 (string-match "XEmacs" emacs-version))) 341 (string-match "XEmacs" emacs-version)))
342
343 (defun vm-xemacs-mule-p ()
344 (and (vm-xemacs-p)
345 (fboundp 'set-file-coding-system)
346 (fboundp 'decode-coding-region)))
325 347
326 (defun vm-fsfemacs-19-p () 348 (defun vm-fsfemacs-19-p ()
327 (and (string-match "^19" emacs-version) 349 (and (string-match "^19" emacs-version)
328 (not (string-match "XEmacs\\|Lucid" emacs-version)))) 350 (not (string-match "XEmacs\\|Lucid" emacs-version))))
329 351
488 (function buffer-substring)) 510 (function buffer-substring))
489 (t (function vm-default-buffer-substring-no-properties)))) 511 (t (function vm-default-buffer-substring-no-properties))))
490 512
491 (defun vm-buffer-string-no-properties () 513 (defun vm-buffer-string-no-properties ()
492 (vm-buffer-substring-no-properties (point-min) (point-max))) 514 (vm-buffer-substring-no-properties (point-min) (point-max)))
515
516 (defun vm-insert-region-from-buffer (buffer &optional start end)
517 (let ((target-buffer (current-buffer)))
518 (set-buffer buffer)
519 (save-restriction
520 (widen)
521 (or start (setq start (point-min)))
522 (or end (setq end (point-max)))
523 (set-buffer target-buffer)
524 (insert-buffer-substring buffer start end)
525 (set-buffer buffer))
526 (set-buffer target-buffer)))
527
528 (if (fboundp 'overlay-get)
529 (fset 'vm-extent-property 'overlay-get)
530 (fset 'vm-extent-property 'extent-property))
531
532 (if (fboundp 'overlay-put)
533 (fset 'vm-set-extent-property 'overlay-put)
534 (fset 'vm-set-extent-property 'set-extent-property))
535
536 (if (fboundp 'make-overlay)
537 (fset 'vm-make-extent 'make-overlay)
538 (fset 'vm-make-extent 'make-extent))
539
540 (if (fboundp 'overlay-end)
541 (fset 'vm-extent-end-position 'overlay-end)
542 (fset 'vm-extent-end-position 'extent-end-position))
543
544 (if (fboundp 'overlay-start)
545 (fset 'vm-extent-start-position 'overlay-start)
546 (fset 'vm-extent-start-position 'extent-start-position))
547
548 (if (fboundp 'delete-overlay)
549 (fset 'vm-detach-extent 'delete-overlay)
550 (fset 'vm-detach-extent 'detach-extent))
551
552 (if (fboundp 'overlay-properties)
553 (fset 'vm-extent-properties 'overlay-properties)
554 (fset 'vm-extent-properties 'extent-properties))
555
556 (defun vm-copy-extent (e)
557 (let ((props (vm-extent-properties e))
558 (ee (vm-make-extent (vm-extent-start-position e)
559 (vm-extent-end-position e))))
560 (while props
561 (vm-set-extent-property ee (car props) (car (cdr props)))
562 (setq props (cdr props)))))
563
564 (defun vm-make-tempfile-name ()
565 (let ((done nil) (pid (emacs-pid)) filename)
566 (while (not done)
567 (setq filename (format "%s/vm%d.%d" vm-temp-file-directory pid
568 vm-tempfile-counter)
569 vm-tempfile-counter (1+ vm-tempfile-counter)
570 done (not (file-exists-p filename))))
571 filename ))
572
573 (defun vm-insert-char (char &optional count ignored buffer)
574 (condition-case nil
575 (progn
576 (insert-char char count ignored buffer)
577 (fset 'vm-insert-char 'insert-char))
578 (wrong-number-of-arguments
579 (fset 'vm-insert-char 'vm-xemacs-compatible-insert-char)
580 (vm-insert-char char count ignored buffer))))
581
582 (defun vm-xemacs-compatible-insert-char (char &optional count ignored buffer)
583 (if (and buffer (eq buffer (current-buffer)))
584 (insert-char char count)
585 (save-excursion
586 (set-buffer buffer)
587 (insert-char char count))))
588
589 (defun vm-symbol-lists-intersect-p (list1 list2)
590 (catch 'done
591 (while list1
592 (and (memq (car list1) list2)
593 (throw 'done t))
594 (setq list1 (cdr list1)))
595 nil ))
596
597 (defun vm-set-buffer-variable (buffer var value)
598 (save-excursion
599 (set-buffer buffer)
600 (set var value)))
601
602 (defsubst vm-with-string-as-temp-buffer (string function)
603 (let ((work-buffer nil))
604 (unwind-protect
605 (save-excursion
606 (setq work-buffer (generate-new-buffer " *work*"))
607 (set-buffer work-buffer)
608 (insert string)
609 (funcall function)
610 (buffer-string))
611 (and work-buffer (kill-buffer work-buffer)))))