Mercurial > hg > xemacs-beta

comparison lisp/viper/viper-util.el @ 78:c7528f8e288d r20-0b34

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-0b34
author cvs
date Mon, 13 Aug 2007 09:05:42 +0200
parents 131b0175ea99
children 1ce6082ce73f
comparison
equal deleted inserted replaced
77:6cb4f478e7bc 78:c7528f8e288d
53 (if vip-emacs-p 53 (if vip-emacs-p
54 window-system 54 window-system
55 (device-type (selected-device)))) 55 (device-type (selected-device))))
56 ;; in XEmacs: device-type is tty on tty and stream in batch. 56 ;; in XEmacs: device-type is tty on tty and stream in batch.
57 (defun vip-window-display-p () 57 (defun vip-window-display-p ()
58 (and (vip-device-type) (not (memq (vip-device-type) '(tty stream))))) 58 (and (vip-device-type) (not (memq (vip-device-type) '(tty stream pc)))))
59
60 (defvar vip-ms-style-os-p (memq system-type '(ms-dos windows-nt windows-95))
61 "Tells if Emacs is running under an MS-style OS: ms-dos, windows-nt, W95.")
62 (defvar vip-vms-os-p (memq system-type '(vax-vms axp-vms))
63 "Tells if Emacs is running under VMS.")
59 64
60 (defvar vip-force-faces nil 65 (defvar vip-force-faces nil
61 "If t, Viper will think that it is running on a display that supports faces. 66 "If t, Viper will think that it is running on a display that supports faces.
62 This is provided as a temporary relief for users of face-capable displays 67 This is provided as a temporary relief for users of face-capable displays
63 that Viper doesn't know about.") 68 that Viper doesn't know about.")
192 (if vip-emacs-p 197 (if vip-emacs-p
193 (x-display-color-p) 198 (x-display-color-p)
194 (eq (device-class (selected-device)) 'color))) 199 (eq (device-class (selected-device)) 'color)))
195 200
196 (defsubst vip-get-cursor-color () 201 (defsubst vip-get-cursor-color ()
197 (cdr (assoc 'cursor-color (frame-parameters)))) 202 (if vip-emacs-p
203 (cdr (assoc 'cursor-color (frame-parameters)))
204 (color-instance-name (frame-property (selected-frame) 'cursor-color))))
205
206 (defun vip-set-face-pixmap (face pixmap)
207 "Set face pixmap on a monochrome display."
208 (if (and (vip-window-display-p) (not (vip-color-display-p)))
209 (condition-case nil
210 (set-face-background-pixmap face pixmap)
211 (error
212 (message "Pixmap not found for %S: %s" (face-name face) pixmap)
213 (sit-for 1)))))
214
198 215
199 ;; OS/2 216 ;; OS/2
200 (cond ((eq (vip-device-type) 'pm) 217 (cond ((eq (vip-device-type) 'pm)
201 (fset 'vip-color-defined-p 218 (fset 'vip-color-defined-p
202 (function (lambda (color) (assoc color pm-color-alist)))))) 219 (function (lambda (color) (assoc color pm-color-alist))))))
230 (let ((color (vip-get-cursor-color))) 247 (let ((color (vip-get-cursor-color)))
231 (if (and (stringp color) (vip-color-defined-p color) 248 (if (and (stringp color) (vip-color-defined-p color)
232 (not (string= color vip-replace-overlay-cursor-color))) 249 (not (string= color vip-replace-overlay-cursor-color)))
233 (vip-overlay-put vip-replace-overlay 'vip-cursor-color color))))) 250 (vip-overlay-put vip-replace-overlay 'vip-cursor-color color)))))
234 251
235 (defsubst vip-restore-cursor-color () 252 ;; restore cursor color from replace overlay
253 (defsubst vip-restore-cursor-color-after-replace ()
236 (vip-change-cursor-color 254 (vip-change-cursor-color
237 (vip-overlay-get vip-replace-overlay 'vip-cursor-color))) 255 (vip-overlay-get vip-replace-overlay 'vip-cursor-color)))
238 256 (defsubst vip-restore-cursor-color-after-insert ()
257 (vip-change-cursor-color vip-saved-cursor-color))
258
239 259
240 ;; Check the current version against the major and minor version numbers 260 ;; Check the current version against the major and minor version numbers
241 ;; using op: cur-vers op major.minor If emacs-major-version or 261 ;; using op: cur-vers op major.minor If emacs-major-version or
242 ;; emacs-minor-version are not defined, we assume that the current version 262 ;; emacs-minor-version are not defined, we assume that the current version
243 ;; is hopelessly outdated. We assume that emacs-major-version and 263 ;; is hopelessly outdated. We assume that emacs-major-version and
416 (t "sh"))) ; probably Unix anyway 436 (t "sh"))) ; probably Unix anyway
417 (gshell-options 437 (gshell-options
418 ;; using cond in anticipation of further additions 438 ;; using cond in anticipation of further additions
419 (cond (ex-unix-type-shell-options) 439 (cond (ex-unix-type-shell-options)
420 )) 440 ))
421 (command (cond (vip-ms-style-os-p (format "\"ls -1 %s\"" filespec)) 441 (command (cond (vip-ms-style-os-p (format "\"ls -1 -d %s\"" filespec))
422 (t (format "ls -1 %s" filespec)))) 442 (t (format "ls -1 -d %s" filespec))))
423 file-list) 443 file-list status)
424 (save-excursion 444 (save-excursion
425 (set-buffer (setq tmp-buf (get-buffer-create vip-ex-tmp-buf-name))) 445 (set-buffer (get-buffer-create vip-ex-tmp-buf-name))
426 (erase-buffer) 446 (erase-buffer)
427 (setq status 447 (setq status
428 (if gshell-options 448 (if gshell-options
429 (call-process gshell nil t nil 449 (call-process gshell nil t nil
430 gshell-options 450 gshell-options
460 The users of Unix-type shells should be able to use 480 The users of Unix-type shells should be able to use
461 `vip-ex-nontrivial-find-file-unix', making it into the value of the variable 481 `vip-ex-nontrivial-find-file-unix', making it into the value of the variable
462 `ex-nontrivial-find-file-function'. If this doesn't work, the user may have 482 `ex-nontrivial-find-file-function'. If this doesn't work, the user may have
463 to write a custom function, similar to `vip-ex-nontrivial-find-file-unix'." 483 to write a custom function, similar to `vip-ex-nontrivial-find-file-unix'."
464 (save-excursion 484 (save-excursion
465 (set-buffer (setq tmp-buf (get-buffer-create vip-ex-tmp-buf-name))) 485 (set-buffer (get-buffer-create vip-ex-tmp-buf-name))
466 (erase-buffer) 486 (erase-buffer)
467 (insert filespec) 487 (insert filespec)
468 (goto-char (point-min)) 488 (goto-char (point-min))
469 (mapcar 'find-file 489 (mapcar 'find-file
470 (vip-glob-ms-windows-files (vip-get-filenames-from-buffer))) 490 (vip-glob-ms-windows-files (vip-get-filenames-from-buffer)))
473 493
474 ;; Interpret the stuff in the buffer as a list of file names 494 ;; Interpret the stuff in the buffer as a list of file names
475 ;; return a list of file names listed in the buffer beginning at point 495 ;; return a list of file names listed in the buffer beginning at point
476 ;; If optional arg is supplied, assume each filename is listed on a separate 496 ;; If optional arg is supplied, assume each filename is listed on a separate
477 ;; line 497 ;; line
478 (defun vip-get-filenames-from-buffer (one-per-line) 498 (defun vip-get-filenames-from-buffer (&optional one-per-line)
479 (let ((skip-chars (if one-per-line "\t\n" " \t\n")) 499 (let ((skip-chars (if one-per-line "\t\n" " \t\n"))
480 result fname delim) 500 result fname delim)
481 (skip-chars-forward skip-chars) 501 (skip-chars-forward skip-chars)
482 (while (not (eobp)) 502 (while (not (eobp))
483 (if (cond ((looking-at "\"") 503 (if (cond ((looking-at "\"")
498 result)) 518 result))
499 519
500 ;; convert MS-DOS wildcards to regexp 520 ;; convert MS-DOS wildcards to regexp
501 (defun vip-wildcard-to-regexp (wcard) 521 (defun vip-wildcard-to-regexp (wcard)
502 (save-excursion 522 (save-excursion
503 (set-buffer (setq tmp-buf (get-buffer-create vip-ex-tmp-buf-name))) 523 (set-buffer (get-buffer-create vip-ex-tmp-buf-name))
504 (erase-buffer) 524 (erase-buffer)
505 (insert wcard) 525 (insert wcard)
506 (goto-char (point-min)) 526 (goto-char (point-min))
507 (while (not (eobp)) 527 (while (not (eobp))
508 (skip-chars-forward "^*?.\\\\") 528 (skip-chars-forward "^*?.\\\\")
534 "$")) 554 "$"))
535 tmp2)) 555 tmp2))
536 (setq tmp (cdr tmp))) 556 (setq tmp (cdr tmp)))
537 (reverse (apply 'append tmp2)))) 557 (reverse (apply 'append tmp2))))
538 558
539 559 (defun vip-convert-standard-file-name (fname)
560 (if vip-emacs-p
561 (convert-standard-filename fname)
562 ;; hopefully, XEmacs adds this functionality
563 fname))
540 564
541 565
542 566
543 ;;; Insertion ring 567 ;;; Insertion ring
544 568
734 (progn 758 (progn
735 (vip-overlay-put vip-search-overlay 'face vip-search-face) 759 (vip-overlay-put vip-search-overlay 'face vip-search-face)
736 (sit-for 2) 760 (sit-for 2)
737 (vip-overlay-put vip-search-overlay 'face nil)))) 761 (vip-overlay-put vip-search-overlay 'face nil))))
738 762
763
739 ;; Replace state 764 ;; Replace state
740 765
741 (defsubst vip-move-replace-overlay (beg end) 766 (defsubst vip-move-replace-overlay (beg end)
742 (vip-move-overlay vip-replace-overlay beg end)) 767 (vip-move-overlay vip-replace-overlay beg end))
743 768
765 (vip-overlay-put vip-replace-overlay before-name before-glyph) 790 (vip-overlay-put vip-replace-overlay before-name before-glyph)
766 (vip-overlay-put vip-replace-overlay after-name after-glyph)))) 791 (vip-overlay-put vip-replace-overlay after-name after-glyph))))
767 792
768 (defsubst vip-hide-replace-overlay () 793 (defsubst vip-hide-replace-overlay ()
769 (vip-set-replace-overlay-glyphs nil nil) 794 (vip-set-replace-overlay-glyphs nil nil)
770 (vip-restore-cursor-color) 795 (vip-restore-cursor-color-after-replace)
796 (vip-restore-cursor-color-after-insert)
771 (if (vip-has-face-support-p) 797 (if (vip-has-face-support-p)
772 (vip-overlay-put vip-replace-overlay 'face nil))) 798 (vip-overlay-put vip-replace-overlay 'face nil)))
773 799
774 800
775 (defsubst vip-replace-start () 801 (defsubst vip-replace-start ()
932 event)) 958 event))
933 )) 959 ))
934 960
935 ;; This function lets function-key-map convert key sequences into logical 961 ;; This function lets function-key-map convert key sequences into logical
936 ;; keys. This does a better job than vip-read-event when it comes to kbd 962 ;; keys. This does a better job than vip-read-event when it comes to kbd
937 ;; macros, since it enables certain macros to be shared between X and TTY 963 ;; macros, since it enables certain macros to be shared between X and TTY modes
938 ;; modes. 964 ;; by correctly mapping key sequences for Left/Right/... (one an ascii
965 ;; terminal) into logical keys left, right, etc.
939 (defun vip-read-key () 966 (defun vip-read-key ()
940 (let ((overriding-local-map vip-overriding-map) 967 (let ((overriding-local-map vip-overriding-map)
968 (inhibit-quit t)
941 key) 969 key)
942 (use-global-map vip-overriding-map) 970 (use-global-map vip-overriding-map)
943 (setq key (elt (read-key-sequence nil) 0)) 971 (setq key (elt (read-key-sequence nil) 0))
944 (use-global-map global-map) 972 (use-global-map global-map)
945 key)) 973 key))
946 974
947 975
948 ;; Emacs has a bug in eventp, which causes (eventp nil) to return (nil) 976 ;; Emacs has a bug in eventp, which causes (eventp nil) to return (nil)
949 ;; instead of nil, if '(nil) was previously inadvertently assigned to 977 ;; instead of nil, if '(nil) was previously inadvertently assigned to
950 ;; unread-command-events 978 ;; unread-command-events
1124 (vip-deflocalvar vip-SEP-char-class " -" 1152 (vip-deflocalvar vip-SEP-char-class " -"
1125 "String of syntax classes for Vi separators. 1153 "String of syntax classes for Vi separators.
1126 Usually contains ` ', linefeed, TAB or formfeed.") 1154 Usually contains ` ', linefeed, TAB or formfeed.")
1127 1155
1128 (defun vip-update-alphanumeric-class () 1156 (defun vip-update-alphanumeric-class ()
1129 "Set the syntactic class of Viper alphanumeric symbols according to 1157 "Set the syntax class of Viper alphanumerals according to `vip-syntax-preference'.
1130 the variable `vip-ALPHA-char-class'. Should be called in order for changes to 1158 Must be called in order for changes to `vip-syntax-preference' to take effect."
1131 `vip-ALPHA-char-class' to take effect."
1132 (interactive) 1159 (interactive)
1133 (setq-default 1160 (setq-default
1134 vip-ALPHA-char-class 1161 vip-ALPHA-char-class
1135 (cond ((eq vip-syntax-preference 'emacs) "w") ; only word constituents 1162 (cond ((eq vip-syntax-preference 'emacs) "w") ; only word constituents
1136 ((eq vip-syntax-preference 'extended) "w_") ; word & symbol chars 1163 ((eq vip-syntax-preference 'extended) "w_") ; word & symbol chars