Mercurial > hg > xemacs-beta

comparison lisp/viper/viper-util.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 441bb1e64a06
children c7528f8e288d
comparison
equal deleted inserted replaced
69:804d1389bcd6 70:131b0175ea99
1 ;;; viper-util.el --- Utilities used by viper.el 1 ;;; viper-util.el --- Utilities used by viper.el
2 2
3 ;; Copyright (C) 1994, 1995, 1996, 1997 Free Software Foundation, Inc. 3 ;; Copyright (C) 1994, 1995, 1996 Free Software Foundation, Inc.
4 4
5 ;; This file is part of GNU Emacs. 5 ;; This file is part of GNU Emacs.
6 6
7 ;; GNU Emacs is free software; you can redistribute it and/or modify 7 ;; GNU Emacs is free software; you can redistribute it and/or modify
8 ;; it under the terms of the GNU General Public License as published by 8 ;; it under the terms of the GNU General Public License as published by
20 ;; Boston, MA 02111-1307, USA. 20 ;; Boston, MA 02111-1307, USA.
21 21
22 22
23 ;; Code 23 ;; Code
24 24
25 (require 'ring)
26
25 ;; Compiler pacifier 27 ;; Compiler pacifier
26 (defvar vip-overriding-map) 28 (defvar vip-overriding-map)
27 (defvar pm-color-alist) 29 (defvar pm-color-alist)
28 (defvar zmacs-region-stays) 30 (defvar zmacs-region-stays)
31 (defvar vip-search-face)
29 (defvar vip-minibuffer-current-face) 32 (defvar vip-minibuffer-current-face)
30 (defvar vip-minibuffer-insert-face) 33 (defvar vip-minibuffer-insert-face)
31 (defvar vip-minibuffer-vi-face) 34 (defvar vip-minibuffer-vi-face)
32 (defvar vip-minibuffer-emacs-face) 35 (defvar vip-minibuffer-emacs-face)
33 (defvar vip-replace-overlay-face) 36 (defvar vip-replace-overlay-face)
37 (defvar vip-minibuffer-overlay)
38 (defvar vip-replace-overlay)
39 (defvar vip-search-overlay)
40 (defvar vip-replace-overlay-cursor-color)
41 (defvar vip-intermediate-command)
42 (defvar vip-use-replace-region-delimiters)
34 (defvar vip-fast-keyseq-timeout) 43 (defvar vip-fast-keyseq-timeout)
35 (defvar ex-unix-type-shell) 44 (defvar vip-related-files-and-buffers-ring)
36 (defvar ex-unix-type-shell-options) 45 ;; end compiler pacifier
37 (defvar vip-ex-tmp-buf-name) 46
38 47 ;; Is it XEmacs?
39 (require 'cl) 48 (defconst vip-xemacs-p (string-match "\\(Lucid\\|XEmacs\\)" emacs-version))
40 (require 'ring) 49 ;; Is it Emacs?
41 50 (defconst vip-emacs-p (not vip-xemacs-p))
42 (and noninteractive 51 ;; Tell whether we are running as a window application or on a TTY
43 (eval-when-compile 52 (defsubst vip-device-type ()
44 (let ((load-path (cons (expand-file-name ".") load-path))) 53 (if vip-emacs-p
45 (or (featurep 'viper-init) 54 window-system
46 (load "viper-init.el" nil nil 'nosuffix)) 55 (device-type (selected-device))))
47 ))) 56 ;; in XEmacs: device-type is tty on tty and stream in batch.
48 ;; end pacifier 57 (defun vip-window-display-p ()
49 58 (and (vip-device-type) (not (memq (vip-device-type) '(tty stream)))))
50 (require 'viper-init) 59
51 60 (defvar vip-force-faces nil
52 61 "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
63 that Viper doesn't know about.")
64
65 (defun vip-has-face-support-p ()
66 (cond ((vip-window-display-p))
67 (vip-force-faces)
68 (vip-emacs-p (memq (vip-device-type) '(pc)))
69 (vip-xemacs-p (memq (vip-device-type) '(tty pc)))))
70
71
72 ;;; Macros
73
74 (defmacro vip-deflocalvar (var default-value &optional documentation)
75 (` (progn
76 (defvar (, var) (, default-value)
77 (, (format "%s\n\(buffer local\)" documentation)))
78 (make-variable-buffer-local '(, var))
79 )))
80
81 (defmacro vip-loop (count body)
82 "(vip-loop COUNT BODY) Execute BODY COUNT times."
83 (list 'let (list (list 'count count))
84 (list 'while '(> count 0)
85 body
86 '(setq count (1- count))
87 )))
88
89 (defmacro vip-buffer-live-p (buf)
90 (` (and (, buf) (get-buffer (, buf)) (buffer-name (get-buffer (, buf))))))
91
92 ;; return buffer-specific macro definition, given a full macro definition
93 (defmacro vip-kbd-buf-alist (macro-elt)
94 (` (nth 1 (, macro-elt))))
95 ;; get a pair: (curr-buffer . macro-definition)
96 (defmacro vip-kbd-buf-pair (macro-elt)
97 (` (assoc (buffer-name) (vip-kbd-buf-alist (, macro-elt)))))
98 ;; get macro definition for current buffer
99 (defmacro vip-kbd-buf-definition (macro-elt)
100 (` (cdr (vip-kbd-buf-pair (, macro-elt)))))
101
102 ;; return mode-specific macro definitions, given a full macro definition
103 (defmacro vip-kbd-mode-alist (macro-elt)
104 (` (nth 2 (, macro-elt))))
105 ;; get a pair: (major-mode . macro-definition)
106 (defmacro vip-kbd-mode-pair (macro-elt)
107 (` (assoc major-mode (vip-kbd-mode-alist (, macro-elt)))))
108 ;; get macro definition for the current major mode
109 (defmacro vip-kbd-mode-definition (macro-elt)
110 (` (cdr (vip-kbd-mode-pair (, macro-elt)))))
111
112 ;; return global macro definition, given a full macro definition
113 (defmacro vip-kbd-global-pair (macro-elt)
114 (` (nth 3 (, macro-elt))))
115 ;; get global macro definition from an elt of macro-alist
116 (defmacro vip-kbd-global-definition (macro-elt)
117 (` (cdr (vip-kbd-global-pair (, macro-elt)))))
118
119 ;; last elt of a sequence
120 (defsubst vip-seq-last-elt (seq)
121 (elt seq (1- (length seq))))
122
123 ;; Check if arg is a valid character for register
124 ;; TYPE is a list that can contain `letter', `Letter', and `digit'.
125 ;; Letter means lowercase letters, Letter means uppercase letters, and
126 ;; digit means digits from 1 to 9.
127 ;; If TYPE is nil, then down/uppercase letters and digits are allowed.
128 (defun vip-valid-register (reg &optional type)
129 (or type (setq type '(letter Letter digit)))
130 (or (if (memq 'letter type)
131 (and (<= ?a reg) (<= reg ?z)))
132 (if (memq 'digit type)
133 (and (<= ?1 reg) (<= reg ?9)))
134 (if (memq 'Letter type)
135 (and (<= ?A reg) (<= reg ?Z)))
136 ))
137
138 ;; checks if object is a marker, has a buffer, and points to within that buffer
139 (defun vip-valid-marker (marker)
140 (if (and (markerp marker) (marker-buffer marker))
141 (let ((buf (marker-buffer marker))
142 (pos (marker-position marker)))
143 (save-excursion
144 (set-buffer buf)
145 (and (<= pos (point-max)) (<= (point-min) pos))))))
146
147
148 (defvar vip-minibuffer-overlay-priority 300)
149 (defvar vip-replace-overlay-priority 400)
150 (defvar vip-search-overlay-priority 500)
151
53 152
54 ;;; XEmacs support 153 ;;; XEmacs support
55
56 ;; A fix for NeXT Step
57 ;; Should probably be eliminated in later versions.
58 (if (and (vip-window-display-p) (eq (vip-device-type) 'ns))
59 (progn
60 (fset 'x-display-color-p (symbol-function 'ns-display-color-p))
61 (fset 'x-color-defined-p (symbol-function 'ns-color-defined-p))
62 ))
63 154
64 (if vip-xemacs-p 155 (if vip-xemacs-p
65 (progn 156 (progn
66 (fset 'vip-read-event (symbol-function 'next-command-event)) 157 (fset 'vip-read-event (symbol-function 'next-command-event))
67 (fset 'vip-make-overlay (symbol-function 'make-extent)) 158 (fset 'vip-make-overlay (symbol-function 'make-extent))
91 (cond ((vip-has-face-support-p) 182 (cond ((vip-has-face-support-p)
92 (fset 'vip-get-face (symbol-function 'internal-get-face)) 183 (fset 'vip-get-face (symbol-function 'internal-get-face))
93 (fset 'vip-color-defined-p (symbol-function 'x-color-defined-p)) 184 (fset 'vip-color-defined-p (symbol-function 'x-color-defined-p))
94 ))) 185 )))
95 186
96
97 (fset 'vip-characterp 187 (fset 'vip-characterp
98 (symbol-function 188 (symbol-function
99 (if vip-xemacs-p 'characterp 'integerp))) 189 (if vip-xemacs-p 'characterp 'integerp)))
100 190
101 (defsubst vip-color-display-p () 191 (defsubst vip-color-display-p ()
102 (if vip-emacs-p 192 (if vip-emacs-p
103 (x-display-color-p) 193 (x-display-color-p)
104 (eq (device-class (selected-device)) 'color))) 194 (eq (device-class (selected-device)) 'color)))
105 195
106 (defsubst vip-get-cursor-color () 196 (defsubst vip-get-cursor-color ()
107 (if vip-emacs-p 197 (cdr (assoc 'cursor-color (frame-parameters))))
108 (cdr (assoc 'cursor-color (frame-parameters)))
109 (color-instance-name (frame-property (selected-frame) 'cursor-color))))
110
111 (defun vip-set-face-pixmap (face pixmap)
112 "Set face pixmap on a monochrome display."
113 (if (and (vip-window-display-p) (not (vip-color-display-p)))
114 (condition-case nil
115 (set-face-background-pixmap face pixmap)
116 (error
117 (message "Pixmap not found for %S: %s" (face-name face) pixmap)
118 (sit-for 1)))))
119
120 198
121 ;; OS/2 199 ;; OS/2
122 (cond ((eq (vip-device-type) 'pm) 200 (cond ((eq (vip-device-type) 'pm)
123 (fset 'vip-color-defined-p 201 (fset 'vip-color-defined-p
124 (function (lambda (color) (assoc color pm-color-alist)))))) 202 (function (lambda (color) (assoc color pm-color-alist))))))
145 (stringp new-color) (vip-color-defined-p new-color) 223 (stringp new-color) (vip-color-defined-p new-color)
146 (not (string= new-color (vip-get-cursor-color)))) 224 (not (string= new-color (vip-get-cursor-color))))
147 (modify-frame-parameters 225 (modify-frame-parameters
148 (selected-frame) (list (cons 'cursor-color new-color))))) 226 (selected-frame) (list (cons 'cursor-color new-color)))))
149 227
150 (defun vip-save-cursor-color () 228 (defsubst vip-save-cursor-color ()
151 (if (and (vip-window-display-p) (vip-color-display-p)) 229 (if (and (vip-window-display-p) (vip-color-display-p))
152 (let ((color (vip-get-cursor-color))) 230 (let ((color (vip-get-cursor-color)))
153 (if (and (stringp color) (vip-color-defined-p color) 231 (if (and (stringp color) (vip-color-defined-p color)
154 (not (string= color vip-replace-overlay-cursor-color))) 232 (not (string= color vip-replace-overlay-cursor-color)))
155 (vip-overlay-put vip-replace-overlay 'vip-cursor-color color))))) 233 (vip-overlay-put vip-replace-overlay 'vip-cursor-color color)))))
156 234
157 ;; restore cursor color from replace overlay 235 (defsubst vip-restore-cursor-color ()
158 (defsubst vip-restore-cursor-color-after-replace ()
159 (vip-change-cursor-color 236 (vip-change-cursor-color
160 (vip-overlay-get vip-replace-overlay 'vip-cursor-color))) 237 (vip-overlay-get vip-replace-overlay 'vip-cursor-color)))
161 (defsubst vip-restore-cursor-color-after-insert ()
162 (vip-change-cursor-color vip-saved-cursor-color))
163 238
164
165 ;; Face-saving tricks
166
167 (defvar vip-search-face
168 (if (vip-has-face-support-p)
169 (progn
170 (make-face 'vip-search-face)
171 (vip-hide-face 'vip-search-face)
172 (or (face-differs-from-default-p 'vip-search-face)
173 ;; face wasn't set in .vip or .Xdefaults
174 (if (vip-can-use-colors "Black" "khaki")
175 (progn
176 (set-face-background 'vip-search-face "khaki")
177 (set-face-foreground 'vip-search-face "Black"))
178 (set-face-underline-p 'vip-search-face t)
179 (vip-set-face-pixmap 'vip-search-face vip-search-face-pixmap)))
180 'vip-search-face))
181 "*Face used to flash out the search pattern.")
182
183 (defvar vip-replace-overlay-face
184 (if (vip-has-face-support-p)
185 (progn
186 (make-face 'vip-replace-overlay-face)
187 (vip-hide-face 'vip-replace-overlay-face)
188 (or (face-differs-from-default-p 'vip-replace-overlay-face)
189 (progn
190 (if (vip-can-use-colors "darkseagreen2" "Black")
191 (progn
192 (set-face-background
193 'vip-replace-overlay-face "darkseagreen2")
194 (set-face-foreground 'vip-replace-overlay-face "Black")))
195 (set-face-underline-p 'vip-replace-overlay-face t)
196 (vip-set-face-pixmap
197 'vip-replace-overlay-face vip-replace-overlay-pixmap)))
198 'vip-replace-overlay-face))
199 "*Face for highlighting replace regions on a window display.")
200
201 (defvar vip-minibuffer-emacs-face
202 (if (vip-has-face-support-p)
203 (progn
204 (make-face 'vip-minibuffer-emacs-face)
205 (vip-hide-face 'vip-minibuffer-emacs-face)
206 (or (face-differs-from-default-p 'vip-minibuffer-emacs-face)
207 ;; face wasn't set in .vip or .Xdefaults
208 (if vip-vi-style-in-minibuffer
209 ;; emacs state is an exception in the minibuffer
210 (if (vip-can-use-colors "darkseagreen2" "Black")
211 (progn
212 (set-face-background
213 'vip-minibuffer-emacs-face "darkseagreen2")
214 (set-face-foreground
215 'vip-minibuffer-emacs-face "Black"))
216 (copy-face 'modeline 'vip-minibuffer-emacs-face))
217 ;; emacs state is the main state in the minibuffer
218 (if (vip-can-use-colors "Black" "pink")
219 (progn
220 (set-face-background 'vip-minibuffer-emacs-face "pink")
221 (set-face-foreground
222 'vip-minibuffer-emacs-face "Black"))
223 (copy-face 'italic 'vip-minibuffer-emacs-face))
224 ))
225 'vip-minibuffer-emacs-face))
226 "Face used in the Minibuffer when it is in Emacs state.")
227
228 (defvar vip-minibuffer-insert-face
229 (if (vip-has-face-support-p)
230 (progn
231 (make-face 'vip-minibuffer-insert-face)
232 (vip-hide-face 'vip-minibuffer-insert-face)
233 (or (face-differs-from-default-p 'vip-minibuffer-insert-face)
234 (if vip-vi-style-in-minibuffer
235 (if (vip-can-use-colors "Black" "pink")
236 (progn
237 (set-face-background 'vip-minibuffer-insert-face "pink")
238 (set-face-foreground
239 'vip-minibuffer-insert-face "Black"))
240 (copy-face 'italic 'vip-minibuffer-insert-face))
241 ;; If Insert state is an exception
242 (if (vip-can-use-colors "darkseagreen2" "Black")
243 (progn
244 (set-face-background
245 'vip-minibuffer-insert-face "darkseagreen2")
246 (set-face-foreground
247 'vip-minibuffer-insert-face "Black"))
248 (copy-face 'modeline 'vip-minibuffer-insert-face))
249 (vip-italicize-face 'vip-minibuffer-insert-face)))
250 'vip-minibuffer-insert-face))
251 "Face used in the Minibuffer when it is in Insert state.")
252
253 (defvar vip-minibuffer-vi-face
254 (if (vip-has-face-support-p)
255 (progn
256 (make-face 'vip-minibuffer-vi-face)
257 (vip-hide-face 'vip-minibuffer-vi-face)
258 (or (face-differs-from-default-p 'vip-minibuffer-vi-face)
259 (if vip-vi-style-in-minibuffer
260 (if (vip-can-use-colors "Black" "grey")
261 (progn
262 (set-face-background 'vip-minibuffer-vi-face "grey")
263 (set-face-foreground 'vip-minibuffer-vi-face "Black"))
264 (copy-face 'bold 'vip-minibuffer-vi-face))
265 (copy-face 'bold 'vip-minibuffer-vi-face)
266 (invert-face 'vip-minibuffer-vi-face)))
267 'vip-minibuffer-vi-face))
268 "Face used in the Minibuffer when it is in Vi state.")
269
270 ;; the current face to be used in the minibuffer
271 (vip-deflocalvar vip-minibuffer-current-face vip-minibuffer-emacs-face "")
272
273 239
274 ;; Check the current version against the major and minor version numbers 240 ;; Check the current version against the major and minor version numbers
275 ;; using op: cur-vers op major.minor If emacs-major-version or 241 ;; using op: cur-vers op major.minor If emacs-major-version or
276 ;; emacs-minor-version are not defined, we assume that the current version 242 ;; emacs-minor-version are not defined, we assume that the current version
277 ;; is hopelessly outdated. We assume that emacs-major-version and 243 ;; is hopelessly outdated. We assume that emacs-major-version and
297 (error "%S: Invalid op in vip-check-version" op)))) 263 (error "%S: Invalid op in vip-check-version" op))))
298 (cond ((memq op '(= > >=)) nil) 264 (cond ((memq op '(= > >=)) nil)
299 ((memq op '(< <=)) t)))) 265 ((memq op '(< <=)) t))))
300 266
301 ;;;; warn if it is a wrong version of emacs 267 ;;;; warn if it is a wrong version of emacs
302 ;;(if (or (vip-check-version '< 19 35 'emacs) 268 ;;(if (or (vip-check-version '< 19 29 'emacs)
303 ;; (vip-check-version '< 19 15 'xemacs)) 269 ;; (vip-check-version '< 19 12 'xemacs))
304 ;; (progn 270 ;; (progn
305 ;; (with-output-to-temp-buffer " *vip-info*" 271 ;; (with-output-to-temp-buffer " *vip-info*"
306 ;; (switch-to-buffer " *vip-info*") 272 ;; (switch-to-buffer " *vip-info*")
307 ;; (insert 273 ;; (insert
308 ;; (format " 274 ;; (format "
309 ;; 275 ;;
310 ;;This version of Viper requires 276 ;;This version of Viper requires
311 ;; 277 ;;
312 ;;\t Emacs 19.35 and higher 278 ;;\t Emacs 19.29 and higher
313 ;;\t OR 279 ;;\t OR
314 ;;\t XEmacs 19.15 and higher 280 ;;\t XEmacs 19.12 and higher
315 ;; 281 ;;
316 ;;It is unlikely to work under Emacs version %s 282 ;;It is unlikely to work under Emacs version %s
317 ;;that you are using... " emacs-version)) 283 ;;that you are using... " emacs-version))
318 ;; 284 ;;
319 ;; (if noninteractive 285 ;; (if noninteractive
450 (t "sh"))) ; probably Unix anyway 416 (t "sh"))) ; probably Unix anyway
451 (gshell-options 417 (gshell-options
452 ;; using cond in anticipation of further additions 418 ;; using cond in anticipation of further additions
453 (cond (ex-unix-type-shell-options) 419 (cond (ex-unix-type-shell-options)
454 )) 420 ))
455 (command (cond (vip-ms-style-os-p (format "\"ls -1 -d %s\"" filespec)) 421 (command (cond (vip-ms-style-os-p (format "\"ls -1 %s\"" filespec))
456 (t (format "ls -1 -d %s" filespec)))) 422 (t (format "ls -1 %s" filespec))))
457 file-list status) 423 file-list)
458 (save-excursion 424 (save-excursion
459 (set-buffer (get-buffer-create vip-ex-tmp-buf-name)) 425 (set-buffer (setq tmp-buf (get-buffer-create vip-ex-tmp-buf-name)))
460 (erase-buffer) 426 (erase-buffer)
461 (setq status 427 (setq status
462 (if gshell-options 428 (if gshell-options
463 (call-process gshell nil t nil 429 (call-process gshell nil t nil
464 gshell-options 430 gshell-options
494 The users of Unix-type shells should be able to use 460 The users of Unix-type shells should be able to use
495 `vip-ex-nontrivial-find-file-unix', making it into the value of the variable 461 `vip-ex-nontrivial-find-file-unix', making it into the value of the variable
496 `ex-nontrivial-find-file-function'. If this doesn't work, the user may have 462 `ex-nontrivial-find-file-function'. If this doesn't work, the user may have
497 to write a custom function, similar to `vip-ex-nontrivial-find-file-unix'." 463 to write a custom function, similar to `vip-ex-nontrivial-find-file-unix'."
498 (save-excursion 464 (save-excursion
499 (set-buffer (get-buffer-create vip-ex-tmp-buf-name)) 465 (set-buffer (setq tmp-buf (get-buffer-create vip-ex-tmp-buf-name)))
500 (erase-buffer) 466 (erase-buffer)
501 (insert filespec) 467 (insert filespec)
502 (goto-char (point-min)) 468 (goto-char (point-min))
503 (mapcar 'find-file 469 (mapcar 'find-file
504 (vip-glob-ms-windows-files (vip-get-filenames-from-buffer))) 470 (vip-glob-ms-windows-files (vip-get-filenames-from-buffer)))
507 473
508 ;; Interpret the stuff in the buffer as a list of file names 474 ;; Interpret the stuff in the buffer as a list of file names
509 ;; return a list of file names listed in the buffer beginning at point 475 ;; return a list of file names listed in the buffer beginning at point
510 ;; If optional arg is supplied, assume each filename is listed on a separate 476 ;; If optional arg is supplied, assume each filename is listed on a separate
511 ;; line 477 ;; line
512 (defun vip-get-filenames-from-buffer (&optional one-per-line) 478 (defun vip-get-filenames-from-buffer (one-per-line)
513 (let ((skip-chars (if one-per-line "\t\n" " \t\n")) 479 (let ((skip-chars (if one-per-line "\t\n" " \t\n"))
514 result fname delim) 480 result fname delim)
515 (skip-chars-forward skip-chars) 481 (skip-chars-forward skip-chars)
516 (while (not (eobp)) 482 (while (not (eobp))
517 (if (cond ((looking-at "\"") 483 (if (cond ((looking-at "\"")
532 result)) 498 result))
533 499
534 ;; convert MS-DOS wildcards to regexp 500 ;; convert MS-DOS wildcards to regexp
535 (defun vip-wildcard-to-regexp (wcard) 501 (defun vip-wildcard-to-regexp (wcard)
536 (save-excursion 502 (save-excursion
537 (set-buffer (get-buffer-create vip-ex-tmp-buf-name)) 503 (set-buffer (setq tmp-buf (get-buffer-create vip-ex-tmp-buf-name)))
538 (erase-buffer) 504 (erase-buffer)
539 (insert wcard) 505 (insert wcard)
540 (goto-char (point-min)) 506 (goto-char (point-min))
541 (while (not (eobp)) 507 (while (not (eobp))
542 (skip-chars-forward "^*?.\\\\") 508 (skip-chars-forward "^*?.\\\\")
567 (file-name-nondirectory (car tmp))) 533 (file-name-nondirectory (car tmp)))
568 "$")) 534 "$"))
569 tmp2)) 535 tmp2))
570 (setq tmp (cdr tmp))) 536 (setq tmp (cdr tmp)))
571 (reverse (apply 'append tmp2)))) 537 (reverse (apply 'append tmp2))))
538
539
540
572 541
573 542
574 ;;; Insertion ring 543 ;;; Insertion ring
575 544
576 ;; Rotate RING's index. DIRection can be positive or negative. 545 ;; Rotate RING's index. DIRection can be positive or negative.
765 (progn 734 (progn
766 (vip-overlay-put vip-search-overlay 'face vip-search-face) 735 (vip-overlay-put vip-search-overlay 'face vip-search-face)
767 (sit-for 2) 736 (sit-for 2)
768 (vip-overlay-put vip-search-overlay 'face nil)))) 737 (vip-overlay-put vip-search-overlay 'face nil))))
769 738
770
771 ;; Replace state 739 ;; Replace state
772 740
773 (defsubst vip-move-replace-overlay (beg end) 741 (defsubst vip-move-replace-overlay (beg end)
774 (vip-move-overlay vip-replace-overlay beg end)) 742 (vip-move-overlay vip-replace-overlay beg end))
775 743
779 (setq vip-replace-overlay (vip-make-overlay beg end (current-buffer))) 747 (setq vip-replace-overlay (vip-make-overlay beg end (current-buffer)))
780 ;; never detach 748 ;; never detach
781 (vip-overlay-put 749 (vip-overlay-put
782 vip-replace-overlay (if vip-emacs-p 'evaporate 'detachable) nil) 750 vip-replace-overlay (if vip-emacs-p 'evaporate 'detachable) nil)
783 (vip-overlay-put 751 (vip-overlay-put
784 vip-replace-overlay 'priority vip-replace-overlay-priority) 752 vip-replace-overlay 'priority vip-replace-overlay-priority))
785 ;; If Emacs will start supporting overlay maps, as it currently supports
786 ;; text-property maps, we could do away with vip-replace-minor-mode and
787 ;; just have keymap attached to replace overlay.
788 ;;(vip-overlay-put
789 ;; vip-replace-overlay
790 ;; (if vip-xemacs-p 'keymap 'local-map)
791 ;; vip-replace-map)
792 )
793 (if (vip-has-face-support-p) 753 (if (vip-has-face-support-p)
794 (vip-overlay-put vip-replace-overlay 'face vip-replace-overlay-face)) 754 (vip-overlay-put vip-replace-overlay 'face vip-replace-overlay-face))
795 (vip-save-cursor-color) 755 (vip-save-cursor-color)
796 (vip-change-cursor-color vip-replace-overlay-cursor-color) 756 (vip-change-cursor-color vip-replace-overlay-cursor-color)
797 ) 757 )
798 758
799 759
800 (defun vip-set-replace-overlay-glyphs (before-glyph after-glyph) 760 (defsubst vip-set-replace-overlay-glyphs (before-glyph after-glyph)
801 (if (or (not (vip-has-face-support-p)) 761 (if (or (not (vip-has-face-support-p))
802 vip-use-replace-region-delimiters) 762 vip-use-replace-region-delimiters)
803 (let ((before-name (if vip-xemacs-p 'begin-glyph 'before-string)) 763 (let ((before-name (if vip-xemacs-p 'begin-glyph 'before-string))
804 (after-name (if vip-xemacs-p 'end-glyph 'after-string))) 764 (after-name (if vip-xemacs-p 'end-glyph 'after-string)))
805 (vip-overlay-put vip-replace-overlay before-name before-glyph) 765 (vip-overlay-put vip-replace-overlay before-name before-glyph)
806 (vip-overlay-put vip-replace-overlay after-name after-glyph)))) 766 (vip-overlay-put vip-replace-overlay after-name after-glyph))))
807 767
808 (defun vip-hide-replace-overlay () 768 (defsubst vip-hide-replace-overlay ()
809 (vip-set-replace-overlay-glyphs nil nil) 769 (vip-set-replace-overlay-glyphs nil nil)
810 (vip-restore-cursor-color-after-replace) 770 (vip-restore-cursor-color)
811 (vip-restore-cursor-color-after-insert)
812 (if (vip-has-face-support-p) 771 (if (vip-has-face-support-p)
813 (vip-overlay-put vip-replace-overlay 'face nil))) 772 (vip-overlay-put vip-replace-overlay 'face nil)))
814 773
815 774
816 (defsubst vip-replace-start () 775 (defsubst vip-replace-start ()
874 ;; EVENT may be a single event of a sequence of events 833 ;; EVENT may be a single event of a sequence of events
875 (defsubst vip-ESC-event-p (event) 834 (defsubst vip-ESC-event-p (event)
876 (let ((ESC-keys '(?\e (control \[) escape)) 835 (let ((ESC-keys '(?\e (control \[) escape))
877 (key (vip-event-key event))) 836 (key (vip-event-key event)))
878 (member key ESC-keys))) 837 (member key ESC-keys)))
879 838
880 ;; checks if object is a marker, has a buffer, and points to within that buffer
881 (defun vip-valid-marker (marker)
882 (if (and (markerp marker) (marker-buffer marker))
883 (let ((buf (marker-buffer marker))
884 (pos (marker-position marker)))
885 (save-excursion
886 (set-buffer buf)
887 (and (<= pos (point-max)) (<= (point-min) pos))))))
888 839
889 (defsubst vip-mark-marker () 840 (defsubst vip-mark-marker ()
890 (if vip-xemacs-p 841 (if vip-xemacs-p
891 (mark-marker t) 842 (mark-marker t)
892 (mark-marker))) 843 (mark-marker)))
906 (deactivate-mark))) 857 (deactivate-mark)))
907 858
908 (defsubst vip-leave-region-active () 859 (defsubst vip-leave-region-active ()
909 (if vip-xemacs-p 860 (if vip-xemacs-p
910 (setq zmacs-region-stays t))) 861 (setq zmacs-region-stays t)))
911
912 ;; Check if arg is a valid character for register
913 ;; TYPE is a list that can contain `letter', `Letter', and `digit'.
914 ;; Letter means lowercase letters, Letter means uppercase letters, and
915 ;; digit means digits from 1 to 9.
916 ;; If TYPE is nil, then down/uppercase letters and digits are allowed.
917 (defun vip-valid-register (reg &optional type)
918 (or type (setq type '(letter Letter digit)))
919 (or (if (memq 'letter type)
920 (and (<= ?a reg) (<= reg ?z)))
921 (if (memq 'digit type)
922 (and (<= ?1 reg) (<= reg ?9)))
923 (if (memq 'Letter type)
924 (and (<= ?A reg) (<= reg ?Z)))
925 ))
926 862
927 863
928 (defsubst vip-events-to-keys (events) 864 (defsubst vip-events-to-keys (events)
929 (cond (vip-xemacs-p (events-to-keys events)) 865 (cond (vip-xemacs-p (events-to-keys events))
930 (t events))) 866 (t events)))
983 (if (equal hook-value function) 919 (if (equal hook-value function)
984 (setq hook-value nil))) 920 (setq hook-value nil)))
985 (set hook hook-value)))) 921 (set hook hook-value))))
986 922
987 923
988 ;; it is suggested that an event must be copied before it is assigned to
989 ;; last-command-event in XEmacs
990 (defun vip-copy-event (event)
991 (if vip-xemacs-p
992 (copy-event event)
993 event))
994 924
995 ;; like read-event, but in XEmacs also try to convert to char, if possible 925 ;; like read-event, but in XEmacs also try to convert to char, if possible
996 (defun vip-read-event-convert-to-char () 926 (defun vip-read-event-convert-to-char ()
997 (let (event) 927 (let (event)
998 (if vip-emacs-p 928 (if vip-emacs-p
1002 event)) 932 event))
1003 )) 933 ))
1004 934
1005 ;; This function lets function-key-map convert key sequences into logical 935 ;; This function lets function-key-map convert key sequences into logical
1006 ;; keys. This does a better job than vip-read-event when it comes to kbd 936 ;; keys. This does a better job than vip-read-event when it comes to kbd
1007 ;; macros, since it enables certain macros to be shared between X and TTY modes 937 ;; macros, since it enables certain macros to be shared between X and TTY
1008 ;; by correctly mapping key sequences for Left/Right/... (one an ascii 938 ;; modes.
1009 ;; terminal) into logical keys left, right, etc.
1010 (defun vip-read-key () 939 (defun vip-read-key ()
1011 (let ((overriding-local-map vip-overriding-map) 940 (let ((overriding-local-map vip-overriding-map)
1012 (inhibit-quit t)
1013 key) 941 key)
1014 (use-global-map vip-overriding-map) 942 (use-global-map vip-overriding-map)
1015 (setq key (elt (read-key-sequence nil) 0)) 943 (setq key (elt (read-key-sequence nil) 0))
1016 (use-global-map global-map) 944 (use-global-map global-map)
1017 key)) 945 key))
1018 946
1019 947
1020 ;; Emacs has a bug in eventp, which causes (eventp nil) to return (nil) 948 ;; Emacs has a bug in eventp, which causes (eventp nil) to return (nil)
1021 ;; instead of nil, if '(nil) was previously inadvertently assigned to 949 ;; instead of nil, if '(nil) was previously inadvertently assigned to
1022 ;; unread-command-events 950 ;; unread-command-events
1023 (defun vip-event-key (event) 951 (defun vip-event-key (event)
1024 (or (and event (eventp event)) 952 (or (and event (eventp event))
1025 (error "vip-event-key: Wrong type argument, eventp, %S" event)) 953 (error "vip-event-key: Wrong type argument, eventp, %S" event))
1026 (when (cond (vip-xemacs-p (or (key-press-event-p event) 954 (let ((mod (event-modifiers event))
1027 (mouse-event-p event))) 955 basis)
1028 (t t)) 956 (setq basis
1029 (let ((mod (event-modifiers event)) 957 (cond
1030 basis) 958 (vip-xemacs-p
1031 (setq basis 959 (cond ((key-press-event-p event)
1032 (cond 960 (event-key event))
1033 (vip-xemacs-p 961 ((button-event-p event)
1034 (cond ((key-press-event-p event) 962 (concat "mouse-" (prin1-to-string (event-button event))))
1035 (event-key event)) 963 (t
1036 ((button-event-p event) 964 (error "vip-event-key: Unknown event, %S" event))))
1037 (concat "mouse-" (prin1-to-string (event-button event)))) 965 (t
1038 (t 966 ;; Emacs doesn't handle capital letters correctly, since
1039 (error "vip-event-key: Unknown event, %S" event)))) 967 ;; \S-a isn't considered the same as A (it behaves as
1040 (t 968 ;; plain `a' instead). So we take care of this here
1041 ;; Emacs doesn't handle capital letters correctly, since 969 (cond ((and (vip-characterp event) (<= ?A event) (<= event ?Z))
1042 ;; \S-a isn't considered the same as A (it behaves as 970 (setq mod nil
1043 ;; plain `a' instead). So we take care of this here 971 event event))
1044 (cond ((and (vip-characterp event) (<= ?A event) (<= event ?Z)) 972 ;; Emacs has the oddity whereby characters 128+char
1045 (setq mod nil 973 ;; represent M-char *if* this appears inside a string.
1046 event event)) 974 ;; So, we convert them manually to (meta char).
1047 ;; Emacs has the oddity whereby characters 128+char 975 ((and (vip-characterp event) (< ?\C-? event) (<= event 255))
1048 ;; represent M-char *if* this appears inside a string. 976 (setq mod '(meta)
1049 ;; So, we convert them manually to (meta char). 977 event (- event ?\C-? 1)))
1050 ((and (vip-characterp event) 978 (t (event-basic-type event)))
1051 (< ?\C-? event) (<= event 255)) 979 )))
1052 (setq mod '(meta) 980 (if (vip-characterp basis)
1053 event (- event ?\C-? 1))) 981 (setq basis
1054 (t (event-basic-type event))) 982 (if (= basis ?\C-?)
1055 ))) 983 (list 'control '\?) ; taking care of an emacs bug
1056 (if (vip-characterp basis) 984 (intern (char-to-string basis)))))
1057 (setq basis 985 (if mod
1058 (if (= basis ?\C-?) 986 (append mod (list basis))
1059 (list 'control '\?) ; taking care of an emacs bug 987 basis)))
1060 (intern (char-to-string basis)))))
1061 (if mod
1062 (append mod (list basis))
1063 basis))))
1064 988
1065 (defun vip-key-to-emacs-key (key) 989 (defun vip-key-to-emacs-key (key)
1066 (let (key-name char-p modifiers mod-char-list base-key base-key-name) 990 (let (key-name char-p modifiers mod-char-list base-key base-key-name)
1067 (cond (vip-xemacs-p key) 991 (cond (vip-xemacs-p key)
1068 ((symbolp key) 992 ((symbolp key)
1200 (vip-deflocalvar vip-SEP-char-class " -" 1124 (vip-deflocalvar vip-SEP-char-class " -"
1201 "String of syntax classes for Vi separators. 1125 "String of syntax classes for Vi separators.
1202 Usually contains ` ', linefeed, TAB or formfeed.") 1126 Usually contains ` ', linefeed, TAB or formfeed.")
1203 1127
1204 (defun vip-update-alphanumeric-class () 1128 (defun vip-update-alphanumeric-class ()
1205 "Set the syntax class of Viper alphanumerals according to `vip-syntax-preference'. 1129 "Set the syntactic class of Viper alphanumeric symbols according to
1206 Must be called in order for changes to `vip-syntax-preference' to take effect." 1130 the variable `vip-ALPHA-char-class'. Should be called in order for changes to
1131 `vip-ALPHA-char-class' to take effect."
1207 (interactive) 1132 (interactive)
1208 (setq-default 1133 (setq-default
1209 vip-ALPHA-char-class 1134 vip-ALPHA-char-class
1210 (cond ((eq vip-syntax-preference 'emacs) "w") ; only word constituents 1135 (cond ((eq vip-syntax-preference 'emacs) "w") ; only word constituents
1211 ((eq vip-syntax-preference 'extended) "w_") ; word & symbol chars 1136 ((eq vip-syntax-preference 'extended) "w_") ; word & symbol chars
1225 (append (vconcat addl-chars) nil)) 1150 (append (vconcat addl-chars) nil))
1226 (memq (char-syntax char) 1151 (memq (char-syntax char)
1227 (append (vconcat vip-ALPHA-char-class) nil))))) 1152 (append (vconcat vip-ALPHA-char-class) nil)))))
1228 )) 1153 ))
1229 1154
1230 (defun vip-looking-at-separator () 1155 (defsubst vip-looking-at-separator ()
1231 (let ((char (char-after (point)))) 1156 (let ((char (char-after (point))))
1232 (if char 1157 (if char
1233 (or (eq char ?\n) ; RET is always a separator in Vi 1158 (or (eq char ?\n) ; RET is always a separator in Vi
1234 (memq (char-syntax char) 1159 (memq (char-syntax char)
1235 (append (vconcat vip-SEP-char-class) nil)))))) 1160 (append (vconcat vip-SEP-char-class) nil))))))
1236 1161
1237 (defsubst vip-looking-at-alphasep (&optional addl-chars) 1162 (defsubst vip-looking-at-alphasep (&optional addl-chars)
1238 (or (vip-looking-at-separator) (vip-looking-at-alpha addl-chars))) 1163 (or (vip-looking-at-separator) (vip-looking-at-alpha addl-chars)))
1239 1164
1240 (defun vip-skip-alpha-forward (&optional addl-chars) 1165 (defsubst vip-skip-alpha-forward (&optional addl-chars)
1241 (or (stringp addl-chars) (setq addl-chars "")) 1166 (or (stringp addl-chars) (setq addl-chars ""))
1242 (vip-skip-syntax 1167 (vip-skip-syntax
1243 'forward 1168 'forward
1244 (cond ((eq vip-syntax-preference 'strict-vi) 1169 (cond ((eq vip-syntax-preference 'strict-vi)
1245 "") 1170 "")
1246 (t vip-ALPHA-char-class )) 1171 (t vip-ALPHA-char-class ))
1247 (cond ((eq vip-syntax-preference 'strict-vi) 1172 (cond ((eq vip-syntax-preference 'strict-vi)
1248 (concat vip-strict-ALPHA-chars addl-chars)) 1173 (concat vip-strict-ALPHA-chars addl-chars))
1249 (t addl-chars)))) 1174 (t addl-chars))))
1250 1175
1251 (defun vip-skip-alpha-backward (&optional addl-chars) 1176 (defsubst vip-skip-alpha-backward (&optional addl-chars)
1252 (or (stringp addl-chars) (setq addl-chars "")) 1177 (or (stringp addl-chars) (setq addl-chars ""))
1253 (vip-skip-syntax 1178 (vip-skip-syntax
1254 'backward 1179 'backward
1255 (cond ((eq vip-syntax-preference 'strict-vi) 1180 (cond ((eq vip-syntax-preference 'strict-vi)
1256 "") 1181 "")
1273 (defun vip-skip-nonseparators (direction) 1198 (defun vip-skip-nonseparators (direction)
1274 (let ((func (intern (format "skip-syntax-%S" direction)))) 1199 (let ((func (intern (format "skip-syntax-%S" direction))))
1275 (funcall func (concat "^" vip-SEP-char-class) 1200 (funcall func (concat "^" vip-SEP-char-class)
1276 (vip-line-pos (if (eq direction 'forward) 'end 'start))))) 1201 (vip-line-pos (if (eq direction 'forward) 'end 'start)))))
1277 1202
1278 (defun vip-skip-nonalphasep-forward () 1203 (defsubst vip-skip-nonalphasep-forward ()
1279 (if (eq vip-syntax-preference 'strict-vi) 1204 (if (eq vip-syntax-preference 'strict-vi)
1280 (skip-chars-forward 1205 (skip-chars-forward
1281 (concat "^" vip-strict-SEP-chars vip-strict-ALPHA-chars)) 1206 (concat "^" vip-strict-SEP-chars vip-strict-ALPHA-chars))
1282 (skip-syntax-forward 1207 (skip-syntax-forward
1283 (concat 1208 (concat
1284 "^" vip-ALPHA-char-class vip-SEP-char-class) (vip-line-pos 'end)))) 1209 "^" vip-ALPHA-char-class vip-SEP-char-class) (vip-line-pos 'end))))
1285 (defun vip-skip-nonalphasep-backward () 1210 (defsubst vip-skip-nonalphasep-backward ()
1286 (if (eq vip-syntax-preference 'strict-vi) 1211 (if (eq vip-syntax-preference 'strict-vi)
1287 (skip-chars-backward 1212 (skip-chars-backward
1288 (concat "^" vip-strict-SEP-chars vip-strict-ALPHA-chars)) 1213 (concat "^" vip-strict-SEP-chars vip-strict-ALPHA-chars))
1289 (skip-syntax-backward 1214 (skip-syntax-backward
1290 (concat 1215 (concat