Mercurial > hg > xemacs-beta

comparison lisp/viper/viper-util.el @ 181:bfd6434d15b3 r20-3b17

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-3b17
author cvs
date Mon, 13 Aug 2007 09:53:19 +0200
parents 2d532a89d707
children 3d6bfa290dbd
comparison
equal deleted inserted replaced
180:add28d59e586 181:bfd6434d15b3
21 21
22 22
23 ;; Code 23 ;; Code
24 24
25 ;; Compiler pacifier 25 ;; Compiler pacifier
26 (defvar vip-overriding-map) 26 (defvar viper-overriding-map)
27 (defvar pm-color-alist) 27 (defvar pm-color-alist)
28 (defvar zmacs-region-stays) 28 (defvar zmacs-region-stays)
29 (defvar vip-minibuffer-current-face) 29 (defvar viper-minibuffer-current-face)
30 (defvar vip-minibuffer-insert-face) 30 (defvar viper-minibuffer-insert-face)
31 (defvar vip-minibuffer-vi-face) 31 (defvar viper-minibuffer-vi-face)
32 (defvar vip-minibuffer-emacs-face) 32 (defvar viper-minibuffer-emacs-face)
33 (defvar vip-replace-overlay-face) 33 (defvar viper-replace-overlay-face)
34 (defvar vip-fast-keyseq-timeout) 34 (defvar viper-fast-keyseq-timeout)
35 (defvar ex-unix-type-shell) 35 (defvar ex-unix-type-shell)
36 (defvar ex-unix-type-shell-options) 36 (defvar ex-unix-type-shell-options)
37 (defvar vip-ex-tmp-buf-name) 37 (defvar viper-ex-tmp-buf-name)
38 38
39 (require 'cl) 39 (require 'cl)
40 (require 'ring) 40 (require 'ring)
41 41
42 (if noninteractive 42 (if noninteractive
48 ;; end pacifier 48 ;; end pacifier
49 49
50 (require 'viper-init) 50 (require 'viper-init)
51 51
52 52
53 ;; A fix for NeXT Step
54 ;; Should go away, when NS people fix the design flaw, which leaves the
55 ;; two x-* functions undefined.
56 (if (and (not (fboundp 'x-display-color-p)) (fboundp 'ns-display-color-p))
57 (fset 'x-display-color-p (symbol-function 'ns-display-color-p)))
58 (if (and (not (fboundp 'x-color-defined-p)) (fboundp 'ns-color-defined-p))
59 (fset 'x-color-defined-p (symbol-function 'ns-color-defined-p)))
60
53 61
54 ;;; XEmacs support 62 ;;; XEmacs support
55 63
56 ;; A fix for NeXT Step 64
57 ;; Should probably be eliminated in later versions. 65 (if viper-xemacs-p
58 (if (and (vip-window-display-p) (eq (vip-device-type) 'ns))
59 (progn 66 (progn
60 (fset 'x-display-color-p (symbol-function 'ns-display-color-p)) 67 (fset 'viper-read-event (symbol-function 'next-command-event))
61 (fset 'x-color-defined-p (symbol-function 'ns-color-defined-p)) 68 (fset 'viper-make-overlay (symbol-function 'make-extent))
62 )) 69 (fset 'viper-overlay-start (symbol-function 'extent-start-position))
63 70 (fset 'viper-overlay-end (symbol-function 'extent-end-position))
64 (if vip-xemacs-p 71 (fset 'viper-overlay-put (symbol-function 'set-extent-property))
65 (progn 72 (fset 'viper-overlay-p (symbol-function 'extentp))
66 (fset 'vip-read-event (symbol-function 'next-command-event)) 73 (fset 'viper-overlay-get (symbol-function 'extent-property))
67 (fset 'vip-make-overlay (symbol-function 'make-extent)) 74 (fset 'viper-move-overlay (symbol-function 'set-extent-endpoints))
68 (fset 'vip-overlay-start (symbol-function 'extent-start-position)) 75 (if (viper-window-display-p)
69 (fset 'vip-overlay-end (symbol-function 'extent-end-position)) 76 (fset 'viper-iconify (symbol-function 'iconify-frame)))
70 (fset 'vip-overlay-put (symbol-function 'set-extent-property)) 77 (cond ((viper-has-face-support-p)
71 (fset 'vip-overlay-p (symbol-function 'extentp)) 78 (fset 'viper-get-face (symbol-function 'get-face))
72 (fset 'vip-overlay-get (symbol-function 'extent-property)) 79 (fset 'viper-color-defined-p
73 (fset 'vip-move-overlay (symbol-function 'set-extent-endpoints))
74 (if (vip-window-display-p)
75 (fset 'vip-iconify (symbol-function 'iconify-frame)))
76 (cond ((vip-has-face-support-p)
77 (fset 'vip-get-face (symbol-function 'get-face))
78 (fset 'vip-color-defined-p
79 (symbol-function 'valid-color-name-p)) 80 (symbol-function 'valid-color-name-p))
80 ))) 81 )))
81 (fset 'vip-read-event (symbol-function 'read-event)) 82 (fset 'viper-read-event (symbol-function 'read-event))
82 (fset 'vip-make-overlay (symbol-function 'make-overlay)) 83 (fset 'viper-make-overlay (symbol-function 'make-overlay))
83 (fset 'vip-overlay-start (symbol-function 'overlay-start)) 84 (fset 'viper-overlay-start (symbol-function 'overlay-start))
84 (fset 'vip-overlay-end (symbol-function 'overlay-end)) 85 (fset 'viper-overlay-end (symbol-function 'overlay-end))
85 (fset 'vip-overlay-put (symbol-function 'overlay-put)) 86 (fset 'viper-overlay-put (symbol-function 'overlay-put))
86 (fset 'vip-overlay-p (symbol-function 'overlayp)) 87 (fset 'viper-overlay-p (symbol-function 'overlayp))
87 (fset 'vip-overlay-get (symbol-function 'overlay-get)) 88 (fset 'viper-overlay-get (symbol-function 'overlay-get))
88 (fset 'vip-move-overlay (symbol-function 'move-overlay)) 89 (fset 'viper-move-overlay (symbol-function 'move-overlay))
89 (if (vip-window-display-p) 90 (if (viper-window-display-p)
90 (fset 'vip-iconify (symbol-function 'iconify-or-deiconify-frame))) 91 (fset 'viper-iconify (symbol-function 'iconify-or-deiconify-frame)))
91 (cond ((vip-has-face-support-p) 92 (cond ((viper-has-face-support-p)
92 (fset 'vip-get-face (symbol-function 'internal-get-face)) 93 (fset 'viper-get-face (symbol-function 'internal-get-face))
93 (fset 'vip-color-defined-p (symbol-function 'x-color-defined-p)) 94 (fset 'viper-color-defined-p (symbol-function 'x-color-defined-p))
94 ))) 95 )))
95 96
96 97
97 (fset 'vip-characterp 98 (fset 'viper-characterp
98 (symbol-function 99 (symbol-function
99 (if vip-xemacs-p 'characterp 'integerp))) 100 (if viper-xemacs-p 'characterp 'integerp)))
100 101
101 (defsubst vip-color-display-p () 102 (defsubst viper-color-display-p ()
102 (if vip-emacs-p 103 (if viper-emacs-p
103 (x-display-color-p) 104 (x-display-color-p)
104 (eq (device-class (selected-device)) 'color))) 105 (eq (device-class (selected-device)) 'color)))
105 106
106 (defsubst vip-get-cursor-color () 107 (defsubst viper-get-cursor-color ()
107 (if vip-emacs-p 108 (if viper-emacs-p
108 (cdr (assoc 'cursor-color (frame-parameters))) 109 (cdr (assoc 'cursor-color (frame-parameters)))
109 (color-instance-name (frame-property (selected-frame) 'cursor-color)))) 110 (color-instance-name (frame-property (selected-frame) 'cursor-color))))
110 111
111 (defun vip-set-face-pixmap (face pixmap) 112 ;;(defun viper-set-face-pixmap (face pixmap)
112 "Set face pixmap on a monochrome display." 113 ;; "Set face pixmap on a monochrome display."
113 (if (and (vip-window-display-p) (not (vip-color-display-p))) 114 ;; (if (and (viper-window-display-p) (not (viper-color-display-p)))
114 (condition-case nil 115 ;; (condition-case nil
115 (set-face-background-pixmap face pixmap) 116 ;; (set-face-background-pixmap face pixmap)
116 (error 117 ;; (error
117 (message "Pixmap not found for %S: %s" (face-name face) pixmap) 118 ;; (message "Pixmap not found for %S: %s" (face-name face) pixmap)
118 (sit-for 1))))) 119 ;; (sit-for 1)))))
119 120
120 121
121 ;; OS/2 122 ;; OS/2
122 (cond ((eq (vip-device-type) 'pm) 123 (cond ((eq (viper-device-type) 'pm)
123 (fset 'vip-color-defined-p 124 (fset 'viper-color-defined-p
124 (function (lambda (color) (assoc color pm-color-alist)))))) 125 (function (lambda (color) (assoc color pm-color-alist))))))
125 126
126 ;; needed to smooth out the difference between Emacs and XEmacs 127 ;; needed to smooth out the difference between Emacs and XEmacs
127 (defsubst vip-italicize-face (face) 128 ;;(defsubst viper-italicize-face (face)
128 (if vip-xemacs-p 129 ;; (if viper-xemacs-p
129 (make-face-italic face) 130 ;; (make-face-italic face)
130 (make-face-italic face nil 'noerror))) 131 ;; (make-face-italic face nil 'noerror)))
131 132
132 ;; test if display is color and the colors are defined 133 ;; test if display is color and the colors are defined
133 (defsubst vip-can-use-colors (&rest colors) 134 ;;(defsubst viper-can-use-colors (&rest colors)
134 (if (vip-color-display-p) 135 ;; (if (viper-color-display-p)
135 (not (memq nil (mapcar 'vip-color-defined-p colors))) 136 ;; (not (memq nil (mapcar 'viper-color-defined-p colors)))
136 )) 137 ;; ))
137
138 (defun vip-hide-face (face)
139 (if (and (vip-has-face-support-p) vip-emacs-p)
140 (add-to-list 'facemenu-unlisted-faces face)))
141 138
142 ;; cursor colors 139 ;; cursor colors
143 (defun vip-change-cursor-color (new-color) 140 (defun viper-change-cursor-color (new-color)
144 (if (and (vip-window-display-p) (vip-color-display-p) 141 (if (and (viper-window-display-p) (viper-color-display-p)
145 (stringp new-color) (vip-color-defined-p new-color) 142 (stringp new-color) (viper-color-defined-p new-color)
146 (not (string= new-color (vip-get-cursor-color)))) 143 (not (string= new-color (viper-get-cursor-color))))
147 (modify-frame-parameters 144 (modify-frame-parameters
148 (selected-frame) (list (cons 'cursor-color new-color))))) 145 (selected-frame) (list (cons 'cursor-color new-color)))))
149 146
150 (defun vip-save-cursor-color () 147 (defun viper-save-cursor-color ()
151 (if (and (vip-window-display-p) (vip-color-display-p)) 148 (if (and (viper-window-display-p) (viper-color-display-p))
152 (let ((color (vip-get-cursor-color))) 149 (let ((color (viper-get-cursor-color)))
153 (if (and (stringp color) (vip-color-defined-p color) 150 (if (and (stringp color) (viper-color-defined-p color)
154 (not (string= color vip-replace-overlay-cursor-color))) 151 (not (string= color viper-replace-overlay-cursor-color)))
155 (vip-overlay-put vip-replace-overlay 'vip-cursor-color color))))) 152 (viper-overlay-put viper-replace-overlay 'viper-cursor-color color)))))
156 153
157 ;; restore cursor color from replace overlay 154 ;; restore cursor color from replace overlay
158 (defsubst vip-restore-cursor-color-after-replace () 155 (defsubst viper-restore-cursor-color-after-replace ()
159 (vip-change-cursor-color 156 (viper-change-cursor-color
160 (vip-overlay-get vip-replace-overlay 'vip-cursor-color))) 157 (viper-overlay-get viper-replace-overlay 'viper-cursor-color)))
161 (defsubst vip-restore-cursor-color-after-insert () 158 (defsubst viper-restore-cursor-color-after-insert ()
162 (vip-change-cursor-color vip-saved-cursor-color)) 159 (viper-change-cursor-color viper-saved-cursor-color))
163 160
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 161
273 162
274 ;; Check the current version against the major and minor version numbers 163 ;; Check the current version against the major and minor version numbers
275 ;; using op: cur-vers op major.minor If emacs-major-version or 164 ;; 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 165 ;; emacs-minor-version are not defined, we assume that the current version
278 ;; emacs-minor-version are defined. Otherwise, for Emacs/XEmacs 19, if the 167 ;; emacs-minor-version are defined. Otherwise, for Emacs/XEmacs 19, if the
279 ;; current minor version is < 10 (xemacs) or < 23 (emacs) the return value 168 ;; current minor version is < 10 (xemacs) or < 23 (emacs) the return value
280 ;; will be nil (when op is =, >, or >=) and t (when op is <, <=), which may be 169 ;; will be nil (when op is =, >, or >=) and t (when op is <, <=), which may be
281 ;; incorrect. However, this gives correct result in our cases, since we are 170 ;; incorrect. However, this gives correct result in our cases, since we are
282 ;; testing for sufficiently high Emacs versions. 171 ;; testing for sufficiently high Emacs versions.
283 (defun vip-check-version (op major minor &optional type-of-emacs) 172 (defun viper-check-version (op major minor &optional type-of-emacs)
284 (if (and (boundp 'emacs-major-version) (boundp 'emacs-minor-version)) 173 (if (and (boundp 'emacs-major-version) (boundp 'emacs-minor-version))
285 (and (cond ((eq type-of-emacs 'xemacs) vip-xemacs-p) 174 (and (cond ((eq type-of-emacs 'xemacs) viper-xemacs-p)
286 ((eq type-of-emacs 'emacs) vip-emacs-p) 175 ((eq type-of-emacs 'emacs) viper-emacs-p)
287 (t t)) 176 (t t))
288 (cond ((eq op '=) (and (= emacs-minor-version minor) 177 (cond ((eq op '=) (and (= emacs-minor-version minor)
289 (= emacs-major-version major))) 178 (= emacs-major-version major)))
290 ((memq op '(> >= < <=)) 179 ((memq op '(> >= < <=))
291 (and (or (funcall op emacs-major-version major) 180 (and (or (funcall op emacs-major-version major)
292 (= emacs-major-version major)) 181 (= emacs-major-version major))
293 (if (= emacs-major-version major) 182 (if (= emacs-major-version major)
294 (funcall op emacs-minor-version minor) 183 (funcall op emacs-minor-version minor)
295 t))) 184 t)))
296 (t 185 (t
297 (error "%S: Invalid op in vip-check-version" op)))) 186 (error "%S: Invalid op in viper-check-version" op))))
298 (cond ((memq op '(= > >=)) nil) 187 (cond ((memq op '(= > >=)) nil)
299 ((memq op '(< <=)) t)))) 188 ((memq op '(< <=)) t))))
300 189
301 ;;;; warn if it is a wrong version of emacs 190
302 ;;(if (or (vip-check-version '< 19 35 'emacs) 191 (defun viper-get-visible-buffer-window (wind)
303 ;; (vip-check-version '< 19 15 'xemacs)) 192 (if viper-xemacs-p
304 ;; (progn
305 ;; (with-output-to-temp-buffer " *vip-info*"
306 ;; (switch-to-buffer " *vip-info*")
307 ;; (insert
308 ;; (format "
309 ;;
310 ;;This version of Viper requires
311 ;;
312 ;;\t Emacs 19.35 and higher
313 ;;\t OR
314 ;;\t XEmacs 19.15 and higher
315 ;;
316 ;;It is unlikely to work under Emacs version %s
317 ;;that you are using... " emacs-version))
318 ;;
319 ;; (if noninteractive
320 ;; ()
321 ;; (beep 1)
322 ;; (beep 1)
323 ;; (insert "\n\nType any key to continue... ")
324 ;; (vip-read-event)))
325 ;; (kill-buffer " *vip-info*")))
326
327
328 (defun vip-get-visible-buffer-window (wind)
329 (if vip-xemacs-p
330 (get-buffer-window wind t) 193 (get-buffer-window wind t)
331 (get-buffer-window wind 'visible))) 194 (get-buffer-window wind 'visible)))
332 195
333 196
334 ;; Return line position. 197 ;; Return line position.
335 ;; If pos is 'start then returns position of line start. 198 ;; If pos is 'start then returns position of line start.
336 ;; If pos is 'end, returns line end. If pos is 'mid, returns line center. 199 ;; If pos is 'end, returns line end. If pos is 'mid, returns line center.
337 ;; Pos = 'indent returns beginning of indentation. 200 ;; Pos = 'indent returns beginning of indentation.
338 ;; Otherwise, returns point. Current point is not moved in any case." 201 ;; Otherwise, returns point. Current point is not moved in any case."
339 (defun vip-line-pos (pos) 202 (defun viper-line-pos (pos)
340 (let ((cur-pos (point)) 203 (let ((cur-pos (point))
341 (result)) 204 (result))
342 (cond 205 (cond
343 ((equal pos 'start) 206 ((equal pos 'start)
344 (beginning-of-line)) 207 (beginning-of-line))
345 ((equal pos 'end) 208 ((equal pos 'end)
346 (end-of-line)) 209 (end-of-line))
347 ((equal pos 'mid) 210 ((equal pos 'mid)
348 (goto-char (+ (vip-line-pos 'start) (vip-line-pos 'end) 2))) 211 (goto-char (+ (viper-line-pos 'start) (viper-line-pos 'end) 2)))
349 ((equal pos 'indent) 212 ((equal pos 'indent)
350 (back-to-indentation)) 213 (back-to-indentation))
351 (t nil)) 214 (t nil))
352 (setq result (point)) 215 (setq result (point))
353 (goto-char cur-pos) 216 (goto-char cur-pos)
358 ;; The first argument must eval to a variable name. 221 ;; The first argument must eval to a variable name.
359 ;; Arguments: (var-name position &optional buffer). 222 ;; Arguments: (var-name position &optional buffer).
360 ;; 223 ;;
361 ;; This is useful for moving markers that are supposed to be local. 224 ;; This is useful for moving markers that are supposed to be local.
362 ;; For this, VAR-NAME should be made buffer-local with nil as a default. 225 ;; For this, VAR-NAME should be made buffer-local with nil as a default.
363 ;; Then, each time this var is used in `vip-move-marker-locally' in a new 226 ;; Then, each time this var is used in `viper-move-marker-locally' in a new
364 ;; buffer, a new marker will be created. 227 ;; buffer, a new marker will be created.
365 (defun vip-move-marker-locally (var pos &optional buffer) 228 (defun viper-move-marker-locally (var pos &optional buffer)
366 (if (markerp (eval var)) 229 (if (markerp (eval var))
367 () 230 ()
368 (set var (make-marker))) 231 (set var (make-marker)))
369 (move-marker (eval var) pos buffer)) 232 (move-marker (eval var) pos buffer))
370 233
371 234
372 ;; Print CONDITIONS as a message. 235 ;; Print CONDITIONS as a message.
373 (defun vip-message-conditions (conditions) 236 (defun viper-message-conditions (conditions)
374 (let ((case (car conditions)) (msg (cdr conditions))) 237 (let ((case (car conditions)) (msg (cdr conditions)))
375 (if (null msg) 238 (if (null msg)
376 (message "%s" case) 239 (message "%s" case)
377 (message "%s: %s" case (mapconcat 'prin1-to-string msg " "))) 240 (message "%s: %s" case (mapconcat 'prin1-to-string msg " ")))
378 (beep 1))) 241 (beep 1)))
380 243
381 244
382 ;;; List/alist utilities 245 ;;; List/alist utilities
383 246
384 ;; Convert LIST to an alist 247 ;; Convert LIST to an alist
385 (defun vip-list-to-alist (lst) 248 (defun viper-list-to-alist (lst)
386 (let ((alist)) 249 (let ((alist))
387 (while lst 250 (while lst
388 (setq alist (cons (list (car lst)) alist)) 251 (setq alist (cons (list (car lst)) alist))
389 (setq lst (cdr lst))) 252 (setq lst (cdr lst)))
390 alist)) 253 alist))
391 254
392 ;; Convert ALIST to a list. 255 ;; Convert ALIST to a list.
393 (defun vip-alist-to-list (alst) 256 (defun viper-alist-to-list (alst)
394 (let ((lst)) 257 (let ((lst))
395 (while alst 258 (while alst
396 (setq lst (cons (car (car alst)) lst)) 259 (setq lst (cons (car (car alst)) lst))
397 (setq alst (cdr alst))) 260 (setq alst (cdr alst)))
398 lst)) 261 lst))
399 262
400 ;; Filter ALIST using REGEXP. Return alist whose elements match the regexp. 263 ;; Filter ALIST using REGEXP. Return alist whose elements match the regexp.
401 (defun vip-filter-alist (regexp alst) 264 (defun viper-filter-alist (regexp alst)
402 (interactive "s x") 265 (interactive "s x")
403 (let ((outalst) (inalst alst)) 266 (let ((outalst) (inalst alst))
404 (while (car inalst) 267 (while (car inalst)
405 (if (string-match regexp (car (car inalst))) 268 (if (string-match regexp (car (car inalst)))
406 (setq outalst (cons (car inalst) outalst))) 269 (setq outalst (cons (car inalst) outalst)))
407 (setq inalst (cdr inalst))) 270 (setq inalst (cdr inalst)))
408 outalst)) 271 outalst))
409 272
410 ;; Filter LIST using REGEXP. Return list whose elements match the regexp. 273 ;; Filter LIST using REGEXP. Return list whose elements match the regexp.
411 (defun vip-filter-list (regexp lst) 274 (defun viper-filter-list (regexp lst)
412 (interactive "s x") 275 (interactive "s x")
413 (let ((outlst) (inlst lst)) 276 (let ((outlst) (inlst lst))
414 (while (car inlst) 277 (while (car inlst)
415 (if (string-match regexp (car inlst)) 278 (if (string-match regexp (car inlst))
416 (setq outlst (cons (car inlst) outlst))) 279 (setq outlst (cons (car inlst) outlst)))
419 282
420 283
421 ;; Append LIS2 to LIS1, both alists, by side-effect and returns LIS1 284 ;; Append LIS2 to LIS1, both alists, by side-effect and returns LIS1
422 ;; LIS2 is modified by filtering it: deleting its members of the form 285 ;; LIS2 is modified by filtering it: deleting its members of the form
423 ;; \(car elt\) such that (car elt') is in LIS1. 286 ;; \(car elt\) such that (car elt') is in LIS1.
424 (defun vip-append-filter-alist (lis1 lis2) 287 (defun viper-append-filter-alist (lis1 lis2)
425 (let ((temp lis1) 288 (let ((temp lis1)
426 elt) 289 elt)
427 290
428 ;;filter-append the second list 291 ;;filter-append the second list
429 (while temp 292 (while temp
435 (nconc lis1 lis2))) 298 (nconc lis1 lis2)))
436 299
437 300
438 ;;; Support for :e and file globbing 301 ;;; Support for :e and file globbing
439 302
440 (defun vip-ex-nontrivial-find-file-unix (filespec) 303 (defun viper-ex-nontrivial-find-file-unix (filespec)
441 "Glob the file spec and visit all files matching the spec. 304 "Glob the file spec and visit all files matching the spec.
442 This function is designed to work under Unix. It may also work under VMS. 305 This function is designed to work under Unix. It may also work under VMS.
443 306
444 Users who prefer other types of shells should write their own version of this 307 Users who prefer other types of shells should write their own version of this
445 function and set the variable `ex-nontrivial-find-file-function' 308 function and set the variable `ex-nontrivial-find-file-function'
450 (t "sh"))) ; probably Unix anyway 313 (t "sh"))) ; probably Unix anyway
451 (gshell-options 314 (gshell-options
452 ;; using cond in anticipation of further additions 315 ;; using cond in anticipation of further additions
453 (cond (ex-unix-type-shell-options) 316 (cond (ex-unix-type-shell-options)
454 )) 317 ))
455 (command (cond (vip-ms-style-os-p (format "\"ls -1 -d %s\"" filespec)) 318 (command (cond (viper-ms-style-os-p (format "\"ls -1 -d %s\"" filespec))
456 (t (format "ls -1 -d %s" filespec)))) 319 (t (format "ls -1 -d %s" filespec))))
457 file-list status) 320 file-list status)
458 (save-excursion 321 (save-excursion
459 (set-buffer (get-buffer-create vip-ex-tmp-buf-name)) 322 (set-buffer (get-buffer-create viper-ex-tmp-buf-name))
460 (erase-buffer) 323 (erase-buffer)
461 (setq status 324 (setq status
462 (if gshell-options 325 (if gshell-options
463 (call-process gshell nil t nil 326 (call-process gshell nil t nil
464 gshell-options 327 gshell-options
471 ;; Issue an error, if no match. 334 ;; Issue an error, if no match.
472 (if (> status 0) 335 (if (> status 0)
473 (save-excursion 336 (save-excursion
474 (skip-chars-forward " \t\n\j") 337 (skip-chars-forward " \t\n\j")
475 (if (looking-at "ls:") 338 (if (looking-at "ls:")
476 (vip-forward-Word 1)) 339 (viper-forward-Word 1))
477 (error "%s: %s" 340 (error "%s: %s"
478 (if (stringp gshell) 341 (if (stringp gshell)
479 gshell 342 gshell
480 "shell") 343 "shell")
481 (buffer-substring (point) (vip-line-pos 'end))) 344 (buffer-substring (point) (viper-line-pos 'end)))
482 )) 345 ))
483 (goto-char (point-min)) 346 (goto-char (point-min))
484 (setq file-list (vip-get-filenames-from-buffer 'one-per-line))) 347 (setq file-list (viper-get-filenames-from-buffer 'one-per-line)))
485 348
486 (mapcar 'find-file file-list) 349 (mapcar 'find-file file-list)
487 )) 350 ))
488 351
489 (defun vip-ex-nontrivial-find-file-ms (filespec) 352 (defun viper-ex-nontrivial-find-file-ms (filespec)
490 "Glob the file spec and visit all files matching the spec. 353 "Glob the file spec and visit all files matching the spec.
491 This function is designed to work under MS type systems, such as NT, W95, and 354 This function is designed to work under MS type systems, such as NT, W95, and
492 DOS. It may also work under OS/2. 355 DOS. It may also work under OS/2.
493 356
494 The users of Unix-type shells should be able to use 357 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 358 `viper-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 359 `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'." 360 to write a custom function, similar to `viper-ex-nontrivial-find-file-unix'."
498 (save-excursion 361 (save-excursion
499 (set-buffer (get-buffer-create vip-ex-tmp-buf-name)) 362 (set-buffer (get-buffer-create viper-ex-tmp-buf-name))
500 (erase-buffer) 363 (erase-buffer)
501 (insert filespec) 364 (insert filespec)
502 (goto-char (point-min)) 365 (goto-char (point-min))
503 (mapcar 'find-file 366 (mapcar 'find-file
504 (vip-glob-ms-windows-files (vip-get-filenames-from-buffer))) 367 (viper-glob-ms-windows-files (viper-get-filenames-from-buffer)))
505 )) 368 ))
506 369
507 370
508 ;; Interpret the stuff in the buffer as a list of file names 371 ;; 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 372 ;; 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 373 ;; If optional arg is supplied, assume each filename is listed on a separate
511 ;; line 374 ;; line
512 (defun vip-get-filenames-from-buffer (&optional one-per-line) 375 (defun viper-get-filenames-from-buffer (&optional one-per-line)
513 (let ((skip-chars (if one-per-line "\t\n" " \t\n")) 376 (let ((skip-chars (if one-per-line "\t\n" " \t\n"))
514 result fname delim) 377 result fname delim)
515 (skip-chars-forward skip-chars) 378 (skip-chars-forward skip-chars)
516 (while (not (eobp)) 379 (while (not (eobp))
517 (if (cond ((looking-at "\"") 380 (if (cond ((looking-at "\"")
530 (skip-chars-forward " \t\n") 393 (skip-chars-forward " \t\n")
531 (setq result (cons fname result))) 394 (setq result (cons fname result)))
532 result)) 395 result))
533 396
534 ;; convert MS-DOS wildcards to regexp 397 ;; convert MS-DOS wildcards to regexp
535 (defun vip-wildcard-to-regexp (wcard) 398 (defun viper-wildcard-to-regexp (wcard)
536 (save-excursion 399 (save-excursion
537 (set-buffer (get-buffer-create vip-ex-tmp-buf-name)) 400 (set-buffer (get-buffer-create viper-ex-tmp-buf-name))
538 (erase-buffer) 401 (erase-buffer)
539 (insert wcard) 402 (insert wcard)
540 (goto-char (point-min)) 403 (goto-char (point-min))
541 (while (not (eobp)) 404 (while (not (eobp))
542 (skip-chars-forward "^*?.\\\\") 405 (skip-chars-forward "^*?.\\\\")
549 )) 412 ))
550 413
551 414
552 ;; glob windows files 415 ;; glob windows files
553 ;; LIST is expected to be in reverse order 416 ;; LIST is expected to be in reverse order
554 (defun vip-glob-ms-windows-files (list) 417 (defun viper-glob-ms-windows-files (list)
555 (let ((tmp list) 418 (let ((tmp list)
556 (case-fold-search t) 419 (case-fold-search t)
557 tmp2) 420 tmp2)
558 (while tmp 421 (while tmp
559 (setq tmp2 (cons (directory-files 422 (setq tmp2 (cons (directory-files
561 (or (file-name-directory (car tmp)) 424 (or (file-name-directory (car tmp))
562 "") 425 "")
563 t ; return full names 426 t ; return full names
564 ;; the regexp part: globs the file names 427 ;; the regexp part: globs the file names
565 (concat "^" 428 (concat "^"
566 (vip-wildcard-to-regexp 429 (viper-wildcard-to-regexp
567 (file-name-nondirectory (car tmp))) 430 (file-name-nondirectory (car tmp)))
568 "$")) 431 "$"))
569 tmp2)) 432 tmp2))
570 (setq tmp (cdr tmp))) 433 (setq tmp (cdr tmp)))
571 (reverse (apply 'append tmp2)))) 434 (reverse (apply 'append tmp2))))
572 435
573 436
574 ;;; Insertion ring 437 ;;; Insertion ring
575 438
576 ;; Rotate RING's index. DIRection can be positive or negative. 439 ;; Rotate RING's index. DIRection can be positive or negative.
577 (defun vip-ring-rotate1 (ring dir) 440 (defun viper-ring-rotate1 (ring dir)
578 (if (and (ring-p ring) (> (ring-length ring) 0)) 441 (if (and (ring-p ring) (> (ring-length ring) 0))
579 (progn 442 (progn
580 (setcar ring (cond ((> dir 0) 443 (setcar ring (cond ((> dir 0)
581 (ring-plus1 (car ring) (ring-length ring))) 444 (ring-plus1 (car ring) (ring-length ring)))
582 ((< dir 0) 445 ((< dir 0)
583 (ring-minus1 (car ring) (ring-length ring))) 446 (ring-minus1 (car ring) (ring-length ring)))
584 ;; don't rotate if dir = 0 447 ;; don't rotate if dir = 0
585 (t (car ring)))) 448 (t (car ring))))
586 (vip-current-ring-item ring) 449 (viper-current-ring-item ring)
587 ))) 450 )))
588 451
589 (defun vip-special-ring-rotate1 (ring dir) 452 (defun viper-special-ring-rotate1 (ring dir)
590 (if (memq vip-intermediate-command 453 (if (memq viper-intermediate-command
591 '(repeating-display-destructive-command 454 '(repeating-display-destructive-command
592 repeating-insertion-from-ring)) 455 repeating-insertion-from-ring))
593 (vip-ring-rotate1 ring dir) 456 (viper-ring-rotate1 ring dir)
594 ;; don't rotate otherwise 457 ;; don't rotate otherwise
595 (vip-ring-rotate1 ring 0))) 458 (viper-ring-rotate1 ring 0)))
596 459
597 ;; current ring item; if N is given, then so many items back from the 460 ;; current ring item; if N is given, then so many items back from the
598 ;; current 461 ;; current
599 (defun vip-current-ring-item (ring &optional n) 462 (defun viper-current-ring-item (ring &optional n)
600 (setq n (or n 0)) 463 (setq n (or n 0))
601 (if (and (ring-p ring) (> (ring-length ring) 0)) 464 (if (and (ring-p ring) (> (ring-length ring) 0))
602 (aref (cdr (cdr ring)) (mod (- (car ring) 1 n) (ring-length ring))))) 465 (aref (cdr (cdr ring)) (mod (- (car ring) 1 n) (ring-length ring)))))
603 466
604 ;; push item onto ring. the second argument is a ring-variable, not value. 467 ;; push item onto ring. the second argument is a ring-variable, not value.
605 (defun vip-push-onto-ring (item ring-var) 468 (defun viper-push-onto-ring (item ring-var)
606 (or (ring-p (eval ring-var)) 469 (or (ring-p (eval ring-var))
607 (set ring-var (make-ring (eval (intern (format "%S-size" ring-var)))))) 470 (set ring-var (make-ring (eval (intern (format "%S-size" ring-var))))))
608 (or (null item) ; don't push nil 471 (or (null item) ; don't push nil
609 (and (stringp item) (string= item "")) ; or empty strings 472 (and (stringp item) (string= item "")) ; or empty strings
610 (equal item (vip-current-ring-item (eval ring-var))) ; or old stuff 473 (equal item (viper-current-ring-item (eval ring-var))) ; or old stuff
611 ;; Since vip-set-destructive-command checks if we are inside vip-repeat, 474 ;; Since viper-set-destructive-command checks if we are inside
612 ;; we don't check whether this-command-keys is a `.'. 475 ;; viper-repeat, we don't check whether this-command-keys is a `.'. The
613 ;; The cmd vip-repeat makes a call to the current function only if 476 ;; cmd viper-repeat makes a call to the current function only if `.' is
614 ;; `.' is executing a command from the command history. It doesn't 477 ;; executing a command from the command history. It doesn't call the
615 ;; call the push-onto-ring function if `.' is simply repeating the 478 ;; push-onto-ring function if `.' is simply repeating the last
616 ;; last destructive command. 479 ;; destructive command. We only check for ESC (which happens when we do
617 ;; We only check for ESC (which happens when we do insert with a 480 ;; insert with a prefix argument, or if this-command-keys doesn't give
618 ;; prefix argument, or if this-command-keys doesn't give anything 481 ;; anything meaningful (in that case we don't know what to show to the
619 ;; meaningful (in that case we don't know what to show to the user). 482 ;; user).
620 (and (eq ring-var 'vip-command-ring) 483 (and (eq ring-var 'viper-command-ring)
621 (string-match "\\([0-9]*\e\\|^[ \t]*$\\|escape\\)" 484 (string-match "\\([0-9]*\e\\|^[ \t]*$\\|escape\\)"
622 (vip-array-to-string (this-command-keys)))) 485 (viper-array-to-string (this-command-keys))))
623 (vip-ring-insert (eval ring-var) item)) 486 (viper-ring-insert (eval ring-var) item))
624 ) 487 )
625 488
626 489
627 ;; removing elts from ring seems to break it 490 ;; removing elts from ring seems to break it
628 (defun vip-cleanup-ring (ring) 491 (defun viper-cleanup-ring (ring)
629 (or (< (ring-length ring) 2) 492 (or (< (ring-length ring) 2)
630 (null (vip-current-ring-item ring)) 493 (null (viper-current-ring-item ring))
631 ;; last and previous equal 494 ;; last and previous equal
632 (if (equal (vip-current-ring-item ring) (vip-current-ring-item ring 1)) 495 (if (equal (viper-current-ring-item ring)
633 (vip-ring-pop ring)))) 496 (viper-current-ring-item ring 1))
497 (viper-ring-pop ring))))
634 498
635 ;; ring-remove seems to be buggy, so we concocted this for our purposes. 499 ;; ring-remove seems to be buggy, so we concocted this for our purposes.
636 (defun vip-ring-pop (ring) 500 (defun viper-ring-pop (ring)
637 (let* ((ln (ring-length ring)) 501 (let* ((ln (ring-length ring))
638 (vec (cdr (cdr ring))) 502 (vec (cdr (cdr ring)))
639 (veclen (length vec)) 503 (veclen (length vec))
640 (hd (car ring)) 504 (hd (car ring))
641 (idx (max 0 (ring-minus1 hd ln))) 505 (idx (max 0 (ring-minus1 hd ln)))
652 (setcar ring hd) ; move head 516 (setcar ring hd) ; move head
653 (setcar (cdr ring) (max 0 (1- ln))) ; adjust length 517 (setcar (cdr ring) (max 0 (1- ln))) ; adjust length
654 top-elt 518 top-elt
655 )) 519 ))
656 520
657 (defun vip-ring-insert (ring item) 521 (defun viper-ring-insert (ring item)
658 (let* ((ln (ring-length ring)) 522 (let* ((ln (ring-length ring))
659 (vec (cdr (cdr ring))) 523 (vec (cdr (cdr ring)))
660 (veclen (length vec)) 524 (veclen (length vec))
661 (hd (car ring)) 525 (hd (car ring))
662 (vecpos-after-hd (if (= hd 0) ln hd)) 526 (vecpos-after-hd (if (= hd 0) ln hd))
680 ;; If STRING is longer than MAX-LEN, truncate it and print ...... instead 544 ;; If STRING is longer than MAX-LEN, truncate it and print ...... instead
681 ;; PRE-STRING is a string to prepend to the abbrev string. 545 ;; PRE-STRING is a string to prepend to the abbrev string.
682 ;; POST-STRING is a string to append to the abbrev string. 546 ;; POST-STRING is a string to append to the abbrev string.
683 ;; ABBREV_SIGN is a string to be inserted before POST-STRING 547 ;; ABBREV_SIGN is a string to be inserted before POST-STRING
684 ;; if the orig string was truncated. 548 ;; if the orig string was truncated.
685 (defun vip-abbreviate-string (string max-len 549 (defun viper-abbreviate-string (string max-len
686 pre-string post-string abbrev-sign) 550 pre-string post-string abbrev-sign)
687 (let (truncated-str) 551 (let (truncated-str)
688 (setq truncated-str 552 (setq truncated-str
689 (if (stringp string) 553 (if (stringp string)
690 (substring string 0 (min max-len (length string))))) 554 (substring string 0 (min max-len (length string)))))
693 (format "%s%s%s%s" 557 (format "%s%s%s%s"
694 pre-string truncated-str abbrev-sign post-string)) 558 pre-string truncated-str abbrev-sign post-string))
695 (t (format "%s%s%s" pre-string truncated-str post-string))))) 559 (t (format "%s%s%s" pre-string truncated-str post-string)))))
696 560
697 ;; tells if we are over a whitespace-only line 561 ;; tells if we are over a whitespace-only line
698 (defsubst vip-over-whitespace-line () 562 (defsubst viper-over-whitespace-line ()
699 (save-excursion 563 (save-excursion
700 (beginning-of-line) 564 (beginning-of-line)
701 (looking-at "^[ \t]*$"))) 565 (looking-at "^[ \t]*$")))
702 566
703 567
705 569
706 ;; Save the current setting of VAR in CUSTOM-FILE. 570 ;; Save the current setting of VAR in CUSTOM-FILE.
707 ;; If given, MESSAGE is a message to be displayed after that. 571 ;; If given, MESSAGE is a message to be displayed after that.
708 ;; This message is erased after 2 secs, if erase-msg is non-nil. 572 ;; This message is erased after 2 secs, if erase-msg is non-nil.
709 ;; Arguments: var message custom-file &optional erase-message 573 ;; Arguments: var message custom-file &optional erase-message
710 (defun vip-save-setting (var message custom-file &optional erase-msg) 574 (defun viper-save-setting (var message custom-file &optional erase-msg)
711 (let* ((var-name (symbol-name var)) 575 (let* ((var-name (symbol-name var))
712 (var-val (if (boundp var) (eval var))) 576 (var-val (if (boundp var) (eval var)))
713 (regexp (format "^[^;]*%s[ \t\n]*[a-zA-Z---_']*[ \t\n)]" var-name)) 577 (regexp (format "^[^;]*%s[ \t\n]*[a-zA-Z---_']*[ \t\n)]" var-name))
714 (buf (find-file-noselect (substitute-in-file-name custom-file))) 578 (buf (find-file-noselect (substitute-in-file-name custom-file)))
715 ) 579 )
734 (message ""))) 598 (message "")))
735 )) 599 ))
736 600
737 ;; Save STRING in CUSTOM-FILE. If PATTERN is non-nil, remove strings that 601 ;; Save STRING in CUSTOM-FILE. If PATTERN is non-nil, remove strings that
738 ;; match this pattern. 602 ;; match this pattern.
739 (defun vip-save-string-in-file (string custom-file &optional pattern) 603 (defun viper-save-string-in-file (string custom-file &optional pattern)
740 (let ((buf (find-file-noselect (substitute-in-file-name custom-file)))) 604 (let ((buf (find-file-noselect (substitute-in-file-name custom-file))))
741 (save-excursion 605 (save-excursion
742 (set-buffer buf) 606 (set-buffer buf)
743 (goto-char (point-min)) 607 (goto-char (point-min))
744 (if pattern (delete-matching-lines pattern)) 608 (if pattern (delete-matching-lines pattern))
751 615
752 ;;; Overlays 616 ;;; Overlays
753 617
754 ;; Search 618 ;; Search
755 619
756 (defun vip-flash-search-pattern () 620 (defun viper-flash-search-pattern ()
757 (if (vip-overlay-p vip-search-overlay) 621 (if (viper-overlay-p viper-search-overlay)
758 (vip-move-overlay vip-search-overlay (match-beginning 0) (match-end 0)) 622 (viper-move-overlay
759 (setq vip-search-overlay 623 viper-search-overlay (match-beginning 0) (match-end 0))
760 (vip-make-overlay 624 (setq viper-search-overlay
625 (viper-make-overlay
761 (match-beginning 0) (match-end 0) (current-buffer)))) 626 (match-beginning 0) (match-end 0) (current-buffer))))
762 627
763 (vip-overlay-put vip-search-overlay 'priority vip-search-overlay-priority) 628 (viper-overlay-put
764 (if (vip-has-face-support-p) 629 viper-search-overlay 'priority viper-search-overlay-priority)
630 (if (viper-has-face-support-p)
765 (progn 631 (progn
766 (vip-overlay-put vip-search-overlay 'face vip-search-face) 632 (viper-overlay-put viper-search-overlay 'face viper-search-face)
767 (sit-for 2) 633 (sit-for 2)
768 (vip-overlay-put vip-search-overlay 'face nil)))) 634 (viper-overlay-put viper-search-overlay 'face nil))))
769 635
770 636
771 ;; Replace state 637 ;; Replace state
772 638
773 (defsubst vip-move-replace-overlay (beg end) 639 (defsubst viper-move-replace-overlay (beg end)
774 (vip-move-overlay vip-replace-overlay beg end)) 640 (viper-move-overlay viper-replace-overlay beg end))
775 641
776 (defun vip-set-replace-overlay (beg end) 642 (defun viper-set-replace-overlay (beg end)
777 (if (vip-overlay-p vip-replace-overlay) 643 (if (viper-overlay-p viper-replace-overlay)
778 (vip-move-replace-overlay beg end) 644 (viper-move-replace-overlay beg end)
779 (setq vip-replace-overlay (vip-make-overlay beg end (current-buffer))) 645 (setq viper-replace-overlay (viper-make-overlay beg end (current-buffer)))
780 ;; never detach 646 ;; never detach
781 (vip-overlay-put 647 (viper-overlay-put
782 vip-replace-overlay (if vip-emacs-p 'evaporate 'detachable) nil) 648 viper-replace-overlay (if viper-emacs-p 'evaporate 'detachable) nil)
783 (vip-overlay-put 649 (viper-overlay-put
784 vip-replace-overlay 'priority vip-replace-overlay-priority) 650 viper-replace-overlay 'priority viper-replace-overlay-priority)
785 ;; If Emacs will start supporting overlay maps, as it currently supports 651 ;; 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 652 ;; text-property maps, we could do away with viper-replace-minor-mode and
787 ;; just have keymap attached to replace overlay. 653 ;; just have keymap attached to replace overlay.
788 ;;(vip-overlay-put 654 ;;(viper-overlay-put
789 ;; vip-replace-overlay 655 ;; viper-replace-overlay
790 ;; (if vip-xemacs-p 'keymap 'local-map) 656 ;; (if viper-xemacs-p 'keymap 'local-map)
791 ;; vip-replace-map) 657 ;; viper-replace-map)
792 ) 658 )
793 (if (vip-has-face-support-p) 659 (if (viper-has-face-support-p)
794 (vip-overlay-put vip-replace-overlay 'face vip-replace-overlay-face)) 660 (viper-overlay-put
795 (vip-save-cursor-color) 661 viper-replace-overlay 'face viper-replace-overlay-face))
796 (vip-change-cursor-color vip-replace-overlay-cursor-color) 662 (viper-save-cursor-color)
663 (viper-change-cursor-color viper-replace-overlay-cursor-color)
797 ) 664 )
798 665
799 666
800 (defun vip-set-replace-overlay-glyphs (before-glyph after-glyph) 667 (defun viper-set-replace-overlay-glyphs (before-glyph after-glyph)
801 (if (or (not (vip-has-face-support-p)) 668 (if (or (not (viper-has-face-support-p))
802 vip-use-replace-region-delimiters) 669 viper-use-replace-region-delimiters)
803 (let ((before-name (if vip-xemacs-p 'begin-glyph 'before-string)) 670 (let ((before-name (if viper-xemacs-p 'begin-glyph 'before-string))
804 (after-name (if vip-xemacs-p 'end-glyph 'after-string))) 671 (after-name (if viper-xemacs-p 'end-glyph 'after-string)))
805 (vip-overlay-put vip-replace-overlay before-name before-glyph) 672 (viper-overlay-put viper-replace-overlay before-name before-glyph)
806 (vip-overlay-put vip-replace-overlay after-name after-glyph)))) 673 (viper-overlay-put viper-replace-overlay after-name after-glyph))))
807 674
808 (defun vip-hide-replace-overlay () 675 (defun viper-hide-replace-overlay ()
809 (vip-set-replace-overlay-glyphs nil nil) 676 (viper-set-replace-overlay-glyphs nil nil)
810 (vip-restore-cursor-color-after-replace) 677 (viper-restore-cursor-color-after-replace)
811 (vip-restore-cursor-color-after-insert) 678 (viper-restore-cursor-color-after-insert)
812 (if (vip-has-face-support-p) 679 (if (viper-has-face-support-p)
813 (vip-overlay-put vip-replace-overlay 'face nil))) 680 (viper-overlay-put viper-replace-overlay 'face nil)))
814 681
815 682
816 (defsubst vip-replace-start () 683 (defsubst viper-replace-start ()
817 (vip-overlay-start vip-replace-overlay)) 684 (viper-overlay-start viper-replace-overlay))
818 (defsubst vip-replace-end () 685 (defsubst viper-replace-end ()
819 (vip-overlay-end vip-replace-overlay)) 686 (viper-overlay-end viper-replace-overlay))
820 687
821 688
822 ;; Minibuffer 689 ;; Minibuffer
823 690
824 (defun vip-set-minibuffer-overlay () 691 (defun viper-set-minibuffer-overlay ()
825 (vip-check-minibuffer-overlay) 692 (viper-check-minibuffer-overlay)
826 (if (vip-has-face-support-p) 693 (if (viper-has-face-support-p)
827 (progn 694 (progn
828 (vip-overlay-put 695 (viper-overlay-put
829 vip-minibuffer-overlay 'face vip-minibuffer-current-face) 696 viper-minibuffer-overlay 'face viper-minibuffer-current-face)
830 (vip-overlay-put 697 (viper-overlay-put
831 vip-minibuffer-overlay 'priority vip-minibuffer-overlay-priority) 698 viper-minibuffer-overlay 'priority viper-minibuffer-overlay-priority)
832 ;; never detach 699 ;; never detach
833 (vip-overlay-put 700 (viper-overlay-put
834 vip-minibuffer-overlay (if vip-emacs-p 'evaporate 'detachable) nil) 701 viper-minibuffer-overlay
835 ;; make vip-minibuffer-overlay open-ended 702 (if viper-emacs-p 'evaporate 'detachable)
703 nil)
704 ;; make viper-minibuffer-overlay open-ended
836 ;; In emacs, it is made open ended at creation time 705 ;; In emacs, it is made open ended at creation time
837 (if vip-xemacs-p 706 (if viper-xemacs-p
838 (progn 707 (progn
839 (vip-overlay-put vip-minibuffer-overlay 'start-open nil) 708 (viper-overlay-put viper-minibuffer-overlay 'start-open nil)
840 (vip-overlay-put vip-minibuffer-overlay 'end-open nil))) 709 (viper-overlay-put viper-minibuffer-overlay 'end-open nil)))
841 ))) 710 )))
842 711
843 (defun vip-check-minibuffer-overlay () 712 (defun viper-check-minibuffer-overlay ()
844 (or (vip-overlay-p vip-minibuffer-overlay) 713 (or (viper-overlay-p viper-minibuffer-overlay)
845 (setq vip-minibuffer-overlay 714 (setq viper-minibuffer-overlay
846 (if vip-xemacs-p 715 (if viper-xemacs-p
847 (vip-make-overlay 1 (1+ (buffer-size)) (current-buffer)) 716 (viper-make-overlay 1 (1+ (buffer-size)) (current-buffer))
848 ;; make overlay open-ended 717 ;; make overlay open-ended
849 (vip-make-overlay 718 (viper-make-overlay
850 1 (1+ (buffer-size)) (current-buffer) nil 'rear-advance))) 719 1 (1+ (buffer-size)) (current-buffer) nil 'rear-advance)))
851 )) 720 ))
852 721
853 722
854 (defsubst vip-is-in-minibuffer () 723 (defsubst viper-is-in-minibuffer ()
855 (string-match "\*Minibuf-" (buffer-name))) 724 (string-match "\*Minibuf-" (buffer-name)))
856 725
857 726
858 727
859 ;;; XEmacs compatibility 728 ;;; XEmacs compatibility
860 729
861 (defun vip-abbreviate-file-name (file) 730 (defun viper-abbreviate-file-name (file)
862 (if vip-emacs-p 731 (if viper-emacs-p
863 (abbreviate-file-name file) 732 (abbreviate-file-name file)
864 ;; XEmacs requires addl argument 733 ;; XEmacs requires addl argument
865 (abbreviate-file-name file t))) 734 (abbreviate-file-name file t)))
866 735
867 ;; Sit for VAL milliseconds. XEmacs doesn't support the millisecond arg 736 ;; Sit for VAL milliseconds. XEmacs doesn't support the millisecond arg
868 ;; in sit-for, so this function smoothes out the differences. 737 ;; in sit-for, so this function smoothes out the differences.
869 (defsubst vip-sit-for-short (val &optional nodisp) 738 (defsubst viper-sit-for-short (val &optional nodisp)
870 (if vip-xemacs-p 739 (if viper-xemacs-p
871 (sit-for (/ val 1000.0) nodisp) 740 (sit-for (/ val 1000.0) nodisp)
872 (sit-for 0 val nodisp))) 741 (sit-for 0 val nodisp)))
873 742
874 ;; EVENT may be a single event of a sequence of events 743 ;; EVENT may be a single event of a sequence of events
875 (defsubst vip-ESC-event-p (event) 744 (defsubst viper-ESC-event-p (event)
876 (let ((ESC-keys '(?\e (control \[) escape)) 745 (let ((ESC-keys '(?\e (control \[) escape))
877 (key (vip-event-key event))) 746 (key (viper-event-key event)))
878 (member key ESC-keys))) 747 (member key ESC-keys)))
879 748
880 ;; checks if object is a marker, has a buffer, and points to within that buffer 749 ;; checks if object is a marker, has a buffer, and points to within that buffer
881 (defun vip-valid-marker (marker) 750 (defun viper-valid-marker (marker)
882 (if (and (markerp marker) (marker-buffer marker)) 751 (if (and (markerp marker) (marker-buffer marker))
883 (let ((buf (marker-buffer marker)) 752 (let ((buf (marker-buffer marker))
884 (pos (marker-position marker))) 753 (pos (marker-position marker)))
885 (save-excursion 754 (save-excursion
886 (set-buffer buf) 755 (set-buffer buf)
887 (and (<= pos (point-max)) (<= (point-min) pos)))))) 756 (and (<= pos (point-max)) (<= (point-min) pos))))))
888 757
889 (defsubst vip-mark-marker () 758 (defsubst viper-mark-marker ()
890 (if vip-xemacs-p 759 (if viper-xemacs-p
891 (mark-marker t) 760 (mark-marker t)
892 (mark-marker))) 761 (mark-marker)))
893 762
894 ;; like (set-mark-command nil) but doesn't push twice, if (car mark-ring) 763 ;; like (set-mark-command nil) but doesn't push twice, if (car mark-ring)
895 ;; is the same as (mark t). 764 ;; is the same as (mark t).
896 (defsubst vip-set-mark-if-necessary () 765 (defsubst viper-set-mark-if-necessary ()
897 (setq mark-ring (delete (vip-mark-marker) mark-ring)) 766 (setq mark-ring (delete (viper-mark-marker) mark-ring))
898 (set-mark-command nil)) 767 (set-mark-command nil))
899 768
900 ;; In transient mark mode (zmacs mode), it is annoying when regions become 769 ;; In transient mark mode (zmacs mode), it is annoying when regions become
901 ;; highlighted due to Viper's pushing marks. So, we deactivate marks, unless 770 ;; highlighted due to Viper's pushing marks. So, we deactivate marks, unless
902 ;; the user explicitly wants highlighting, e.g., by hitting '' or `` 771 ;; the user explicitly wants highlighting, e.g., by hitting '' or ``
903 (defun vip-deactivate-mark () 772 (defun viper-deactivate-mark ()
904 (if vip-xemacs-p 773 (if viper-xemacs-p
905 (zmacs-deactivate-region) 774 (zmacs-deactivate-region)
906 (deactivate-mark))) 775 (deactivate-mark)))
907 776
908 (defsubst vip-leave-region-active () 777 (defsubst viper-leave-region-active ()
909 (if vip-xemacs-p 778 (if viper-xemacs-p
910 (setq zmacs-region-stays t))) 779 (setq zmacs-region-stays t)))
911 780
912 ;; Check if arg is a valid character for register 781 ;; Check if arg is a valid character for register
913 ;; TYPE is a list that can contain `letter', `Letter', and `digit'. 782 ;; TYPE is a list that can contain `letter', `Letter', and `digit'.
914 ;; Letter means lowercase letters, Letter means uppercase letters, and 783 ;; Letter means lowercase letters, Letter means uppercase letters, and
915 ;; digit means digits from 1 to 9. 784 ;; digit means digits from 1 to 9.
916 ;; If TYPE is nil, then down/uppercase letters and digits are allowed. 785 ;; If TYPE is nil, then down/uppercase letters and digits are allowed.
917 (defun vip-valid-register (reg &optional type) 786 (defun viper-valid-register (reg &optional type)
918 (or type (setq type '(letter Letter digit))) 787 (or type (setq type '(letter Letter digit)))
919 (or (if (memq 'letter type) 788 (or (if (memq 'letter type)
920 (and (<= ?a reg) (<= reg ?z))) 789 (and (<= ?a reg) (<= reg ?z)))
921 (if (memq 'digit type) 790 (if (memq 'digit type)
922 (and (<= ?1 reg) (<= reg ?9))) 791 (and (<= ?1 reg) (<= reg ?9)))
923 (if (memq 'Letter type) 792 (if (memq 'Letter type)
924 (and (<= ?A reg) (<= reg ?Z))) 793 (and (<= ?A reg) (<= reg ?Z)))
925 )) 794 ))
926 795
927 796
928 (defsubst vip-events-to-keys (events) 797 (defsubst viper-events-to-keys (events)
929 (cond (vip-xemacs-p (events-to-keys events)) 798 (cond (viper-xemacs-p (events-to-keys events))
930 (t events))) 799 (t events)))
931 800
932 801
933 (defun vip-eval-after-load (file form)
934 (if vip-emacs-p
935 (eval-after-load file form)
936 (or (assoc file after-load-alist)
937 (setq after-load-alist (cons (list file) after-load-alist)))
938 (let ((elt (assoc file after-load-alist)))
939 (or (member form (cdr elt))
940 (setq elt (nconc elt (list form)))))
941 form
942 ))
943
944 ;; This is here because Emacs changed the way local hooks work. 802 ;; This is here because Emacs changed the way local hooks work.
945 ;; 803 ;;
946 ;;Add to the value of HOOK the function FUNCTION. 804 ;;Add to the value of HOOK the function FUNCTION.
947 ;;FUNCTION is not added if already present. 805 ;;FUNCTION is not added if already present.
948 ;;FUNCTION is added (if necessary) at the beginning of the hook list 806 ;;FUNCTION is added (if necessary) at the beginning of the hook list
950 ;;FUNCTION is added at the end. 808 ;;FUNCTION is added at the end.
951 ;; 809 ;;
952 ;;HOOK should be a symbol, and FUNCTION may be any valid function. If 810 ;;HOOK should be a symbol, and FUNCTION may be any valid function. If
953 ;;HOOK is void, it is first set to nil. If HOOK's value is a single 811 ;;HOOK is void, it is first set to nil. If HOOK's value is a single
954 ;;function, it is changed to a list of functions." 812 ;;function, it is changed to a list of functions."
955 (defun vip-add-hook (hook function &optional append) 813 (defun viper-add-hook (hook function &optional append)
956 (if (not (boundp hook)) (set hook nil)) 814 (if (not (boundp hook)) (set hook nil))
957 ;; If the hook value is a single function, turn it into a list. 815 ;; If the hook value is a single function, turn it into a list.
958 (let ((old (symbol-value hook))) 816 (let ((old (symbol-value hook)))
959 (if (or (not (listp old)) (eq (car old) 'lambda)) 817 (if (or (not (listp old)) (eq (car old) 'lambda))
960 (setq old (list old))) 818 (setq old (list old)))
968 ;; and due to the bugs they introduced. 826 ;; and due to the bugs they introduced.
969 ;; 827 ;;
970 ;; Remove from the value of HOOK the function FUNCTION. 828 ;; Remove from the value of HOOK the function FUNCTION.
971 ;; HOOK should be a symbol, and FUNCTION may be any valid function. If 829 ;; HOOK should be a symbol, and FUNCTION may be any valid function. If
972 ;; FUNCTION isn't the value of HOOK, or, if FUNCTION doesn't appear in the 830 ;; FUNCTION isn't the value of HOOK, or, if FUNCTION doesn't appear in the
973 ;; list of hooks to run in HOOK, then nothing is done. See `vip-add-hook'." 831 ;; list of hooks to run in HOOK, then nothing is done. See `viper-add-hook'."
974 (defun vip-remove-hook (hook function) 832 (defun viper-remove-hook (hook function)
975 (if (or (not (boundp hook)) ;unbound symbol, or 833 (if (or (not (boundp hook)) ;unbound symbol, or
976 (null (symbol-value hook)) ;value is nil, or 834 (null (symbol-value hook)) ;value is nil, or
977 (null function)) ;function is nil, then 835 (null function)) ;function is nil, then
978 nil ;Do nothing. 836 nil ;Do nothing.
979 (let ((hook-value (symbol-value hook))) 837 (let ((hook-value (symbol-value hook)))
985 (set hook hook-value)))) 843 (set hook hook-value))))
986 844
987 845
988 ;; it is suggested that an event must be copied before it is assigned to 846 ;; it is suggested that an event must be copied before it is assigned to
989 ;; last-command-event in XEmacs 847 ;; last-command-event in XEmacs
990 (defun vip-copy-event (event) 848 (defun viper-copy-event (event)
991 (if vip-xemacs-p 849 (if viper-xemacs-p
992 (copy-event event) 850 (copy-event event)
993 event)) 851 event))
994 852
995 ;; like read-event, but in XEmacs also try to convert to char, if possible 853 ;; like read-event, but in XEmacs also try to convert to char, if possible
996 (defun vip-read-event-convert-to-char () 854 (defun viper-read-event-convert-to-char ()
997 (let (event) 855 (let (event)
998 (if vip-emacs-p 856 (if viper-emacs-p
999 (read-event) 857 (read-event)
1000 (setq event (next-command-event)) 858 (setq event (next-command-event))
1001 (or (event-to-character event) 859 (or (event-to-character event)
1002 event)) 860 event))
1003 )) 861 ))
1004 862
1005 ;; This function lets function-key-map convert key sequences into logical 863 ;; 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 864 ;; keys. This does a better job than viper-read-event when it comes to kbd
1007 ;; macros, since it enables certain macros to be shared between X and TTY modes 865 ;; macros, since it enables certain macros to be shared between X and TTY modes
1008 ;; by correctly mapping key sequences for Left/Right/... (one an ascii 866 ;; by correctly mapping key sequences for Left/Right/... (one an ascii
1009 ;; terminal) into logical keys left, right, etc. 867 ;; terminal) into logical keys left, right, etc.
1010 (defun vip-read-key () 868 (defun viper-read-key ()
1011 (let ((overriding-local-map vip-overriding-map) 869 (let ((overriding-local-map viper-overriding-map)
1012 (inhibit-quit t) 870 (inhibit-quit t)
1013 key) 871 help-char key)
1014 (use-global-map vip-overriding-map) 872 (use-global-map viper-overriding-map)
1015 (setq key (elt (read-key-sequence nil) 0)) 873 (unwind-protect
1016 (use-global-map global-map) 874 (setq key (elt (read-key-sequence nil) 0))
875 (use-global-map global-map))
1017 key)) 876 key))
1018 877
1019 878
1020 ;; Emacs has a bug in eventp, which causes (eventp nil) to return (nil) 879 ;; Emacs has a bug in eventp, which causes (eventp nil) to return (nil)
1021 ;; instead of nil, if '(nil) was previously inadvertently assigned to 880 ;; instead of nil, if '(nil) was previously inadvertently assigned to
1022 ;; unread-command-events 881 ;; unread-command-events
1023 (defun vip-event-key (event) 882 (defun viper-event-key (event)
1024 (or (and event (eventp event)) 883 (or (and event (eventp event))
1025 (error "vip-event-key: Wrong type argument, eventp, %S" event)) 884 (error "viper-event-key: Wrong type argument, eventp, %S" event))
1026 (when (cond (vip-xemacs-p (or (key-press-event-p event) 885 (when (cond (viper-xemacs-p (or (key-press-event-p event)
1027 (mouse-event-p event))) 886 (mouse-event-p event)))
1028 (t t)) 887 (t t))
1029 (let ((mod (event-modifiers event)) 888 (let ((mod (event-modifiers event))
1030 basis) 889 basis)
1031 (setq basis 890 (setq basis
1032 (cond 891 (cond
1033 (vip-xemacs-p 892 (viper-xemacs-p
1034 (cond ((key-press-event-p event) 893 (cond ((key-press-event-p event)
1035 (event-key event)) 894 (event-key event))
1036 ((button-event-p event) 895 ((button-event-p event)
1037 (concat "mouse-" (prin1-to-string (event-button event)))) 896 (concat "mouse-" (prin1-to-string (event-button event))))
1038 (t 897 (t
1039 (error "vip-event-key: Unknown event, %S" event)))) 898 (error "viper-event-key: Unknown event, %S" event))))
1040 (t 899 (t
1041 ;; Emacs doesn't handle capital letters correctly, since 900 ;; Emacs doesn't handle capital letters correctly, since
1042 ;; \S-a isn't considered the same as A (it behaves as 901 ;; \S-a isn't considered the same as A (it behaves as
1043 ;; plain `a' instead). So we take care of this here 902 ;; plain `a' instead). So we take care of this here
1044 (cond ((and (vip-characterp event) (<= ?A event) (<= event ?Z)) 903 (cond ((and (viper-characterp event) (<= ?A event) (<= event ?Z))
1045 (setq mod nil 904 (setq mod nil
1046 event event)) 905 event event))
1047 ;; Emacs has the oddity whereby characters 128+char 906 ;; Emacs has the oddity whereby characters 128+char
1048 ;; represent M-char *if* this appears inside a string. 907 ;; represent M-char *if* this appears inside a string.
1049 ;; So, we convert them manually to (meta char). 908 ;; So, we convert them manually to (meta char).
1050 ((and (vip-characterp event) 909 ((and (viper-characterp event)
1051 (< ?\C-? event) (<= event 255)) 910 (< ?\C-? event) (<= event 255))
1052 (setq mod '(meta) 911 (setq mod '(meta)
1053 event (- event ?\C-? 1))) 912 event (- event ?\C-? 1)))
913 ((and (null mod) (eq event 'return))
914 (setq event ?\C-m))
915 ((and (null mod) (eq event 'space))
916 (setq event ?\ ))
917 ((and (null mod) (eq event 'delete))
918 (setq event ?\C-?))
919 ((and (null mod) (eq event 'backspace))
920 (setq event ?\C-h))
1054 (t (event-basic-type event))) 921 (t (event-basic-type event)))
1055 ))) 922 )))
1056 (if (vip-characterp basis) 923 (if (viper-characterp basis)
1057 (setq basis 924 (setq basis
1058 (if (= basis ?\C-?) 925 (if (= basis ?\C-?)
1059 (list 'control '\?) ; taking care of an emacs bug 926 (list 'control '\?) ; taking care of an emacs bug
1060 (intern (char-to-string basis))))) 927 (intern (char-to-string basis)))))
1061 (if mod 928 (if mod
1062 (append mod (list basis)) 929 (append mod (list basis))
1063 basis)))) 930 basis))))
1064 931
1065 (defun vip-key-to-emacs-key (key) 932 (defun viper-key-to-emacs-key (key)
1066 (let (key-name char-p modifiers mod-char-list base-key base-key-name) 933 (let (key-name char-p modifiers mod-char-list base-key base-key-name)
1067 (cond (vip-xemacs-p key) 934 (cond (viper-xemacs-p key)
1068 935
1069 ((symbolp key) 936 ((symbolp key)
1070 (setq key-name (symbol-name key)) 937 (setq key-name (symbol-name key))
1071 (cond ((= (length key-name) 1) ; character event 938 (cond ((= (length key-name) 1) ; character event
1072 (string-to-char key-name)) 939 (string-to-char key-name))
1073 ;; Emacs doesn't recognize `return' and `escape' as events on 940 ;; Emacs doesn't recognize `return' and `escape' as events on
1074 ;; dumb terminals, so we translate them into characters 941 ;; dumb terminals, so we translate them into characters
1075 ((and vip-emacs-p (not (vip-window-display-p)) 942 ((and viper-emacs-p (not (viper-window-display-p))
1076 (string= key-name "return")) 943 (string= key-name "return"))
1077 ?\C-m) 944 ?\C-m)
1078 ((and vip-emacs-p (not (vip-window-display-p)) 945 ((and viper-emacs-p (not (viper-window-display-p))
1079 (string= key-name "escape")) 946 (string= key-name "escape"))
1080 ?\e) 947 ?\e)
1081 ;; pass symbol-event as is 948 ;; pass symbol-event as is
1082 (t key))) 949 (t key)))
1083 950
1084 ((listp key) 951 ((listp key)
1085 (setq modifiers (subseq key 0 (1- (length key))) 952 (setq modifiers (subseq key 0 (1- (length key)))
1086 base-key (vip-seq-last-elt key) 953 base-key (viper-seq-last-elt key)
1087 base-key-name (symbol-name base-key) 954 base-key-name (symbol-name base-key)
1088 char-p (= (length base-key-name) 1)) 955 char-p (= (length base-key-name) 1))
1089 (setq mod-char-list 956 (setq mod-char-list
1090 (mapcar 957 (mapcar
1091 '(lambda (elt) (upcase (substring (symbol-name elt) 0 1))) 958 '(lambda (elt) (upcase (substring (symbol-name elt) 0 1)))
1110 ;; Args can be a sequence of events, a string, or a Viper macro. Will try to 977 ;; Args can be a sequence of events, a string, or a Viper macro. Will try to
1111 ;; convert events to keys and, if all keys are regular printable 978 ;; convert events to keys and, if all keys are regular printable
1112 ;; characters, will return a string. Otherwise, will return a string 979 ;; characters, will return a string. Otherwise, will return a string
1113 ;; representing a vector of converted events. If the input was a Viper macro, 980 ;; representing a vector of converted events. If the input was a Viper macro,
1114 ;; will return a string that represents this macro as a vector. 981 ;; will return a string that represents this macro as a vector.
1115 (defun vip-array-to-string (event-seq) 982 (defun viper-array-to-string (event-seq)
1116 (let (temp temp2) 983 (let (temp temp2)
1117 (cond ((stringp event-seq) event-seq) 984 (cond ((stringp event-seq) event-seq)
1118 ((vip-event-vector-p event-seq) 985 ((viper-event-vector-p event-seq)
1119 (setq temp (mapcar 'vip-event-key event-seq)) 986 (setq temp (mapcar 'viper-event-key event-seq))
1120 (cond ((vip-char-symbol-sequence-p temp) 987 (cond ((viper-char-symbol-sequence-p temp)
1121 (mapconcat 'symbol-name temp "")) 988 (mapconcat 'symbol-name temp ""))
1122 ((and (vip-char-array-p 989 ((and (viper-char-array-p
1123 (setq temp2 (mapcar 'vip-key-to-character temp)))) 990 (setq temp2 (mapcar 'viper-key-to-character temp))))
1124 (mapconcat 'char-to-string temp2 "")) 991 (mapconcat 'char-to-string temp2 ""))
1125 (t (prin1-to-string (vconcat temp))))) 992 (t (prin1-to-string (vconcat temp)))))
1126 ((vip-char-symbol-sequence-p event-seq) 993 ((viper-char-symbol-sequence-p event-seq)
1127 (mapconcat 'symbol-name event-seq "")) 994 (mapconcat 'symbol-name event-seq ""))
1128 ((and (vectorp event-seq) 995 ((and (vectorp event-seq)
1129 (vip-char-array-p 996 (viper-char-array-p
1130 (setq temp (mapcar 'vip-key-to-character event-seq)))) 997 (setq temp (mapcar 'viper-key-to-character event-seq))))
1131 (mapconcat 'char-to-string temp "")) 998 (mapconcat 'char-to-string temp ""))
1132 (t (prin1-to-string event-seq))))) 999 (t (prin1-to-string event-seq)))))
1133 1000
1134 (defun vip-key-press-events-to-chars (events) 1001 (defun viper-key-press-events-to-chars (events)
1135 (mapconcat (if vip-emacs-p 1002 (mapconcat (if viper-emacs-p
1136 'char-to-string 1003 'char-to-string
1137 (function 1004 (function
1138 (lambda (elt) (char-to-string (event-to-character elt))))) 1005 (lambda (elt) (char-to-string (event-to-character elt)))))
1139 events 1006 events
1140 "")) 1007 ""))
1141 1008
1142 1009
1143 ;; Uses different timeouts for ESC-sequences and others 1010 ;; Uses different timeouts for ESC-sequences and others
1144 (defsubst vip-fast-keysequence-p () 1011 (defsubst viper-fast-keysequence-p ()
1145 (not (vip-sit-for-short 1012 (not (viper-sit-for-short
1146 (if (vip-ESC-event-p last-input-event) 1013 (if (viper-ESC-event-p last-input-event)
1147 vip-ESC-keyseq-timeout 1014 viper-ESC-keyseq-timeout
1148 vip-fast-keyseq-timeout) 1015 viper-fast-keyseq-timeout)
1149 t))) 1016 t)))
1150 1017
1151 (defun vip-read-char-exclusive () 1018 (defun viper-read-char-exclusive ()
1152 (let (char 1019 (let (char
1153 (echo-keystrokes 1)) 1020 (echo-keystrokes 1))
1154 (while (null char) 1021 (while (null char)
1155 (condition-case nil 1022 (condition-case nil
1156 (setq char (read-char)) 1023 (setq char (read-char))
1157 (error 1024 (error
1158 ;; skip event if not char 1025 ;; skip event if not char
1159 (vip-read-event)))) 1026 (viper-read-event))))
1160 char)) 1027 char))
1161 1028
1162 ;; key is supposed to be in viper's representation, e.g., (control l), a 1029 ;; key is supposed to be in viper's representation, e.g., (control l), a
1163 ;; character, etc. 1030 ;; character, etc.
1164 (defun vip-key-to-character (key) 1031 (defun viper-key-to-character (key)
1165 (cond ((eq key 'space) ?\ ) 1032 (cond ((eq key 'space) ?\ )
1166 ((eq key 'delete) ?\C-?) 1033 ((eq key 'delete) ?\C-?)
1034 ((eq key 'return) ?\C-m)
1167 ((eq key 'backspace) ?\C-h) 1035 ((eq key 'backspace) ?\C-h)
1168 ((and (symbolp key) 1036 ((and (symbolp key)
1169 (= 1 (length (symbol-name key)))) 1037 (= 1 (length (symbol-name key))))
1170 (string-to-char (symbol-name key))) 1038 (string-to-char (symbol-name key)))
1171 ((and (listp key) 1039 ((and (listp key)
1174 (= 1 (length (symbol-name (nth 1 key))))) 1042 (= 1 (length (symbol-name (nth 1 key)))))
1175 (read (format "?\\C-%s" (symbol-name (nth 1 key))))) 1043 (read (format "?\\C-%s" (symbol-name (nth 1 key)))))
1176 (t key))) 1044 (t key)))
1177 1045
1178 1046
1179 (defun vip-setup-master-buffer (&rest other-files-or-buffers) 1047 (defun viper-setup-master-buffer (&rest other-files-or-buffers)
1180 "Set up the current buffer as a master buffer. 1048 "Set up the current buffer as a master buffer.
1181 Arguments become related buffers. This function should normally be used in 1049 Arguments become related buffers. This function should normally be used in
1182 the `Local variables' section of a file." 1050 the `Local variables' section of a file."
1183 (setq vip-related-files-and-buffers-ring 1051 (setq viper-related-files-and-buffers-ring
1184 (make-ring (1+ (length other-files-or-buffers)))) 1052 (make-ring (1+ (length other-files-or-buffers))))
1185 (mapcar '(lambda (elt) 1053 (mapcar '(lambda (elt)
1186 (vip-ring-insert vip-related-files-and-buffers-ring elt)) 1054 (viper-ring-insert viper-related-files-and-buffers-ring elt))
1187 other-files-or-buffers) 1055 other-files-or-buffers)
1188 (vip-ring-insert vip-related-files-and-buffers-ring (buffer-name)) 1056 (viper-ring-insert viper-related-files-and-buffers-ring (buffer-name))
1189 ) 1057 )
1190 1058
1191 ;;; Movement utilities 1059 ;;; Movement utilities
1192 1060
1193 (defcustom vip-syntax-preference 'strict-vi 1061 (defcustom viper-syntax-preference 'strict-vi
1194 "*Syntax type characterizing Viper's alphanumeric symbols. 1062 "*Syntax type characterizing Viper's alphanumeric symbols.
1195 `emacs' means only word constituents are considered to be alphanumeric. 1063 `emacs' means only word constituents are considered to be alphanumeric.
1196 Word constituents are symbols specified as word constituents by the current 1064 Word constituents are symbols specified as word constituents by the current
1197 syntax table. 1065 syntax table.
1198 `extended' means word and symbol constituents. 1066 `extended' means word and symbol constituents.
1202 `strict-vi' means Viper words are exactly as in Vi." 1070 `strict-vi' means Viper words are exactly as in Vi."
1203 :type '(radio (const strict-vi) (const reformed-vi) 1071 :type '(radio (const strict-vi) (const reformed-vi)
1204 (const extended) (const emacs)) 1072 (const extended) (const emacs))
1205 :group 'viper) 1073 :group 'viper)
1206 1074
1207 (vip-deflocalvar vip-ALPHA-char-class "w" 1075 (viper-deflocalvar viper-ALPHA-char-class "w"
1208 "String of syntax classes characterizing Viper's alphanumeric symbols. 1076 "String of syntax classes characterizing Viper's alphanumeric symbols.
1209 In addition, the symbol `_' may be considered alphanumeric if 1077 In addition, the symbol `_' may be considered alphanumeric if
1210 `vip-syntax-preference'is `reformed-vi'.") 1078 `viper-syntax-preference'is `reformed-vi'.")
1211 1079
1212 (vip-deflocalvar vip-strict-ALPHA-chars "a-zA-Z0-9_" 1080 (viper-deflocalvar viper-strict-ALPHA-chars "a-zA-Z0-9_"
1213 "Regexp matching the set of alphanumeric characters acceptable to strict 1081 "Regexp matching the set of alphanumeric characters acceptable to strict
1214 Vi.") 1082 Vi.")
1215 (vip-deflocalvar vip-strict-SEP-chars " \t\n" 1083 (viper-deflocalvar viper-strict-SEP-chars " \t\n"
1216 "Regexp matching the set of alphanumeric characters acceptable to strict 1084 "Regexp matching the set of alphanumeric characters acceptable to strict
1217 Vi.") 1085 Vi.")
1218 1086
1219 (vip-deflocalvar vip-SEP-char-class " -" 1087 (viper-deflocalvar viper-SEP-char-class " -"
1220 "String of syntax classes for Vi separators. 1088 "String of syntax classes for Vi separators.
1221 Usually contains ` ', linefeed, TAB or formfeed.") 1089 Usually contains ` ', linefeed, TAB or formfeed.")
1222 1090
1223 (defun vip-update-alphanumeric-class () 1091 (defun viper-update-alphanumeric-class ()
1224 "Set the syntax class of Viper alphanumerals according to `vip-syntax-preference'. 1092 "Set the syntax class of Viper alphanumerals according to `viper-syntax-preference'.
1225 Must be called in order for changes to `vip-syntax-preference' to take effect." 1093 Must be called in order for changes to `viper-syntax-preference' to take effect."
1226 (interactive) 1094 (interactive)
1227 (setq-default 1095 (setq-default
1228 vip-ALPHA-char-class 1096 viper-ALPHA-char-class
1229 (cond ((eq vip-syntax-preference 'emacs) "w") ; only word constituents 1097 (cond ((eq viper-syntax-preference 'emacs) "w") ; only word constituents
1230 ((eq vip-syntax-preference 'extended) "w_") ; word & symbol chars 1098 ((eq viper-syntax-preference 'extended) "w_") ; word & symbol chars
1231 (t "w")))) ; vi syntax: word constituents and the symbol `_' 1099 (t "w")))) ; vi syntax: word constituents and the symbol `_'
1232 1100
1233 ;; addl-chars are characters to be temporarily considered as alphanumerical 1101 ;; addl-chars are characters to be temporarily considered as alphanumerical
1234 (defun vip-looking-at-alpha (&optional addl-chars) 1102 (defun viper-looking-at-alpha (&optional addl-chars)
1235 (or (stringp addl-chars) (setq addl-chars "")) 1103 (or (stringp addl-chars) (setq addl-chars ""))
1236 (if (eq vip-syntax-preference 'reformed-vi) 1104 (if (eq viper-syntax-preference 'reformed-vi)
1237 (setq addl-chars (concat addl-chars "_"))) 1105 (setq addl-chars (concat addl-chars "_")))
1238 (let ((char (char-after (point)))) 1106 (let ((char (char-after (point))))
1239 (if char 1107 (if char
1240 (if (eq vip-syntax-preference 'strict-vi) 1108 (if (eq viper-syntax-preference 'strict-vi)
1241 (looking-at (concat "[" vip-strict-ALPHA-chars addl-chars "]")) 1109 (looking-at (concat "[" viper-strict-ALPHA-chars addl-chars "]"))
1242 (or (memq char 1110 (or (memq char
1243 ;; convert string to list 1111 ;; convert string to list
1244 (append (vconcat addl-chars) nil)) 1112 (append (vconcat addl-chars) nil))
1245 (memq (char-syntax char) 1113 (memq (char-syntax char)
1246 (append (vconcat vip-ALPHA-char-class) nil))))) 1114 (append (vconcat viper-ALPHA-char-class) nil)))))
1247 )) 1115 ))
1248 1116
1249 (defun vip-looking-at-separator () 1117 (defun viper-looking-at-separator ()
1250 (let ((char (char-after (point)))) 1118 (let ((char (char-after (point))))
1251 (if char 1119 (if char
1252 (or (eq char ?\n) ; RET is always a separator in Vi 1120 (or (eq char ?\n) ; RET is always a separator in Vi
1253 (memq (char-syntax char) 1121 (memq (char-syntax char)
1254 (append (vconcat vip-SEP-char-class) nil)))))) 1122 (append (vconcat viper-SEP-char-class) nil))))))
1255 1123
1256 (defsubst vip-looking-at-alphasep (&optional addl-chars) 1124 (defsubst viper-looking-at-alphasep (&optional addl-chars)
1257 (or (vip-looking-at-separator) (vip-looking-at-alpha addl-chars))) 1125 (or (viper-looking-at-separator) (viper-looking-at-alpha addl-chars)))
1258 1126
1259 (defun vip-skip-alpha-forward (&optional addl-chars) 1127 (defun viper-skip-alpha-forward (&optional addl-chars)
1260 (or (stringp addl-chars) (setq addl-chars "")) 1128 (or (stringp addl-chars) (setq addl-chars ""))
1261 (vip-skip-syntax 1129 (viper-skip-syntax
1262 'forward 1130 'forward
1263 (cond ((eq vip-syntax-preference 'strict-vi) 1131 (cond ((eq viper-syntax-preference 'strict-vi)
1264 "") 1132 "")
1265 (t vip-ALPHA-char-class )) 1133 (t viper-ALPHA-char-class))
1266 (cond ((eq vip-syntax-preference 'strict-vi) 1134 (cond ((eq viper-syntax-preference 'strict-vi)
1267 (concat vip-strict-ALPHA-chars addl-chars)) 1135 (concat viper-strict-ALPHA-chars addl-chars))
1268 (t addl-chars)))) 1136 (t addl-chars))))
1269 1137
1270 (defun vip-skip-alpha-backward (&optional addl-chars) 1138 (defun viper-skip-alpha-backward (&optional addl-chars)
1271 (or (stringp addl-chars) (setq addl-chars "")) 1139 (or (stringp addl-chars) (setq addl-chars ""))
1272 (vip-skip-syntax 1140 (viper-skip-syntax
1273 'backward 1141 'backward
1274 (cond ((eq vip-syntax-preference 'strict-vi) 1142 (cond ((eq viper-syntax-preference 'strict-vi)
1275 "") 1143 "")
1276 (t vip-ALPHA-char-class )) 1144 (t viper-ALPHA-char-class))
1277 (cond ((eq vip-syntax-preference 'strict-vi) 1145 (cond ((eq viper-syntax-preference 'strict-vi)
1278 (concat vip-strict-ALPHA-chars addl-chars)) 1146 (concat viper-strict-ALPHA-chars addl-chars))
1279 (t addl-chars)))) 1147 (t addl-chars))))
1280 1148
1281 ;; weird syntax tables may confuse strict-vi style 1149 ;; weird syntax tables may confuse strict-vi style
1282 (defsubst vip-skip-all-separators-forward (&optional within-line) 1150 (defsubst viper-skip-all-separators-forward (&optional within-line)
1283 (vip-skip-syntax 'forward 1151 (viper-skip-syntax 'forward
1284 vip-SEP-char-class 1152 viper-SEP-char-class
1285 (or within-line "\n") 1153 (or within-line "\n")
1286 (if within-line (vip-line-pos 'end)))) 1154 (if within-line (viper-line-pos 'end))))
1287 (defsubst vip-skip-all-separators-backward (&optional within-line) 1155 (defsubst viper-skip-all-separators-backward (&optional within-line)
1288 (vip-skip-syntax 'backward 1156 (viper-skip-syntax 'backward
1289 vip-SEP-char-class 1157 viper-SEP-char-class
1290 (or within-line "\n") 1158 (or within-line "\n")
1291 (if within-line (vip-line-pos 'start)))) 1159 (if within-line (viper-line-pos 'start))))
1292 (defun vip-skip-nonseparators (direction) 1160 (defun viper-skip-nonseparators (direction)
1293 (let ((func (intern (format "skip-syntax-%S" direction)))) 1161 (let ((func (intern (format "skip-syntax-%S" direction))))
1294 (funcall func (concat "^" vip-SEP-char-class) 1162 (funcall func (concat "^" viper-SEP-char-class)
1295 (vip-line-pos (if (eq direction 'forward) 'end 'start))))) 1163 (viper-line-pos (if (eq direction 'forward) 'end 'start)))))
1296 1164
1297 (defun vip-skip-nonalphasep-forward () 1165 (defun viper-skip-nonalphasep-forward ()
1298 (if (eq vip-syntax-preference 'strict-vi) 1166 (if (eq viper-syntax-preference 'strict-vi)
1299 (skip-chars-forward 1167 (skip-chars-forward
1300 (concat "^" vip-strict-SEP-chars vip-strict-ALPHA-chars)) 1168 (concat "^" viper-strict-SEP-chars viper-strict-ALPHA-chars))
1301 (skip-syntax-forward 1169 (skip-syntax-forward
1302 (concat 1170 (concat
1303 "^" vip-ALPHA-char-class vip-SEP-char-class) (vip-line-pos 'end)))) 1171 "^" viper-ALPHA-char-class viper-SEP-char-class) (viper-line-pos 'end))))
1304 (defun vip-skip-nonalphasep-backward () 1172 (defun viper-skip-nonalphasep-backward ()
1305 (if (eq vip-syntax-preference 'strict-vi) 1173 (if (eq viper-syntax-preference 'strict-vi)
1306 (skip-chars-backward 1174 (skip-chars-backward
1307 (concat "^" vip-strict-SEP-chars vip-strict-ALPHA-chars)) 1175 (concat "^" viper-strict-SEP-chars viper-strict-ALPHA-chars))
1308 (skip-syntax-backward 1176 (skip-syntax-backward
1309 (concat 1177 (concat
1310 "^" vip-ALPHA-char-class vip-SEP-char-class) (vip-line-pos 'start)))) 1178 "^"
1179 viper-ALPHA-char-class viper-SEP-char-class)
1180 (viper-line-pos 'start))))
1311 1181
1312 ;; Skip SYNTAX like skip-syntax-* and ADDL-CHARS like skip-chars-* 1182 ;; Skip SYNTAX like skip-syntax-* and ADDL-CHARS like skip-chars-*
1313 ;; Return the number of chars traveled. 1183 ;; Return the number of chars traveled.
1314 ;; Either SYNTAX or ADDL-CHARS can be nil, in which case they are interpreted 1184 ;; Either SYNTAX or ADDL-CHARS can be nil, in which case they are interpreted
1315 ;; as an empty string. 1185 ;; as an empty string.
1316 (defun vip-skip-syntax (direction syntax addl-chars &optional limit) 1186 (defun viper-skip-syntax (direction syntax addl-chars &optional limit)
1317 (let ((total 0) 1187 (let ((total 0)
1318 (local 1) 1188 (local 1)
1319 (skip-chars-func (intern (format "skip-chars-%S" direction))) 1189 (skip-chars-func (intern (format "skip-chars-%S" direction)))
1320 (skip-syntax-func (intern (format "skip-syntax-%S" direction)))) 1190 (skip-syntax-func (intern (format "skip-syntax-%S" direction))))
1321 (or (stringp addl-chars) (setq addl-chars "")) 1191 (or (stringp addl-chars) (setq addl-chars ""))
1332 1202
1333 (provide 'viper-util) 1203 (provide 'viper-util)
1334 1204
1335 1205
1336 ;;; Local Variables: 1206 ;;; Local Variables:
1337 ;;; eval: (put 'vip-deflocalvar 'lisp-indent-hook 'defun) 1207 ;;; eval: (put 'viper-deflocalvar 'lisp-indent-hook 'defun)
1338 ;;; End: 1208 ;;; End:
1339 1209
1340 ;;; viper-util.el ends here 1210 ;;; viper-util.el ends here