0
|
1 ;;; viper-util.el --- Utilities used by viper.el
|
|
2
|
16
|
3 ;; Copyright (C) 1994, 1995, 1996, 1997 Free Software Foundation, Inc.
|
0
|
4
|
|
5 ;; This file is part of GNU Emacs.
|
|
6
|
|
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
|
|
9 ;; the Free Software Foundation; either version 2, or (at your option)
|
|
10 ;; any later version.
|
|
11
|
|
12 ;; GNU Emacs is distributed in the hope that it will be useful,
|
|
13 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
15 ;; GNU General Public License for more details.
|
|
16
|
|
17 ;; You should have received a copy of the GNU General Public License
|
|
18 ;; along with GNU Emacs; see the file COPYING. If not, write to the
|
|
19 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
|
20 ;; Boston, MA 02111-1307, USA.
|
|
21
|
|
22
|
|
23 ;; Code
|
|
24
|
|
25 ;; Compiler pacifier
|
|
26 (defvar vip-overriding-map)
|
|
27 (defvar pm-color-alist)
|
|
28 (defvar zmacs-region-stays)
|
|
29 (defvar vip-minibuffer-current-face)
|
|
30 (defvar vip-minibuffer-insert-face)
|
|
31 (defvar vip-minibuffer-vi-face)
|
|
32 (defvar vip-minibuffer-emacs-face)
|
|
33 (defvar vip-replace-overlay-face)
|
|
34 (defvar vip-fast-keyseq-timeout)
|
14
|
35 (defvar ex-unix-type-shell)
|
|
36 (defvar ex-unix-type-shell-options)
|
|
37 (defvar vip-ex-tmp-buf-name)
|
16
|
38
|
|
39 (require 'cl)
|
|
40 (require 'ring)
|
|
41
|
|
42 (and noninteractive
|
|
43 (eval-when-compile
|
|
44 (let ((load-path (cons (expand-file-name ".") load-path)))
|
|
45 (or (featurep 'viper-init)
|
|
46 (load "viper-init.el" nil nil 'nosuffix))
|
|
47 )))
|
14
|
48 ;; end pacifier
|
0
|
49
|
16
|
50 (require 'viper-init)
|
14
|
51
|
|
52
|
|
53
|
0
|
54 ;;; XEmacs support
|
|
55
|
26
|
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
|
0
|
64 (if vip-xemacs-p
|
|
65 (progn
|
|
66 (fset 'vip-read-event (symbol-function 'next-command-event))
|
|
67 (fset 'vip-make-overlay (symbol-function 'make-extent))
|
|
68 (fset 'vip-overlay-start (symbol-function 'extent-start-position))
|
|
69 (fset 'vip-overlay-end (symbol-function 'extent-end-position))
|
|
70 (fset 'vip-overlay-put (symbol-function 'set-extent-property))
|
|
71 (fset 'vip-overlay-p (symbol-function 'extentp))
|
|
72 (fset 'vip-overlay-get (symbol-function 'extent-property))
|
|
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 )))
|
|
81 (fset 'vip-read-event (symbol-function 'read-event))
|
|
82 (fset 'vip-make-overlay (symbol-function 'make-overlay))
|
|
83 (fset 'vip-overlay-start (symbol-function 'overlay-start))
|
|
84 (fset 'vip-overlay-end (symbol-function 'overlay-end))
|
|
85 (fset 'vip-overlay-put (symbol-function 'overlay-put))
|
|
86 (fset 'vip-overlay-p (symbol-function 'overlayp))
|
|
87 (fset 'vip-overlay-get (symbol-function 'overlay-get))
|
|
88 (fset 'vip-move-overlay (symbol-function 'move-overlay))
|
|
89 (if (vip-window-display-p)
|
|
90 (fset 'vip-iconify (symbol-function 'iconify-or-deiconify-frame)))
|
|
91 (cond ((vip-has-face-support-p)
|
|
92 (fset 'vip-get-face (symbol-function 'internal-get-face))
|
|
93 (fset 'vip-color-defined-p (symbol-function 'x-color-defined-p))
|
|
94 )))
|
|
95
|
26
|
96
|
0
|
97 (fset 'vip-characterp
|
|
98 (symbol-function
|
|
99 (if vip-xemacs-p 'characterp 'integerp)))
|
|
100
|
|
101 (defsubst vip-color-display-p ()
|
|
102 (if vip-emacs-p
|
|
103 (x-display-color-p)
|
|
104 (eq (device-class (selected-device)) 'color)))
|
|
105
|
|
106 (defsubst vip-get-cursor-color ()
|
12
|
107 (if vip-emacs-p
|
|
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
|
0
|
120
|
|
121 ;; OS/2
|
|
122 (cond ((eq (vip-device-type) 'pm)
|
|
123 (fset 'vip-color-defined-p
|
|
124 (function (lambda (color) (assoc color pm-color-alist))))))
|
|
125
|
|
126 ;; needed to smooth out the difference between Emacs and XEmacs
|
|
127 (defsubst vip-italicize-face (face)
|
|
128 (if vip-xemacs-p
|
|
129 (make-face-italic face)
|
|
130 (make-face-italic face nil 'noerror)))
|
|
131
|
|
132 ;; test if display is color and the colors are defined
|
|
133 (defsubst vip-can-use-colors (&rest colors)
|
|
134 (if (vip-color-display-p)
|
|
135 (not (memq nil (mapcar 'vip-color-defined-p colors)))
|
|
136 ))
|
|
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
|
|
142 ;; cursor colors
|
|
143 (defun vip-change-cursor-color (new-color)
|
|
144 (if (and (vip-window-display-p) (vip-color-display-p)
|
|
145 (stringp new-color) (vip-color-defined-p new-color)
|
|
146 (not (string= new-color (vip-get-cursor-color))))
|
|
147 (modify-frame-parameters
|
|
148 (selected-frame) (list (cons 'cursor-color new-color)))))
|
|
149
|
16
|
150 (defun vip-save-cursor-color ()
|
0
|
151 (if (and (vip-window-display-p) (vip-color-display-p))
|
|
152 (let ((color (vip-get-cursor-color)))
|
|
153 (if (and (stringp color) (vip-color-defined-p color)
|
|
154 (not (string= color vip-replace-overlay-cursor-color)))
|
|
155 (vip-overlay-put vip-replace-overlay 'vip-cursor-color color)))))
|
|
156
|
12
|
157 ;; restore cursor color from replace overlay
|
|
158 (defsubst vip-restore-cursor-color-after-replace ()
|
0
|
159 (vip-change-cursor-color
|
|
160 (vip-overlay-get vip-replace-overlay 'vip-cursor-color)))
|
12
|
161 (defsubst vip-restore-cursor-color-after-insert ()
|
|
162 (vip-change-cursor-color vip-saved-cursor-color))
|
14
|
163
|
0
|
164
|
16
|
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
|
0
|
274 ;; Check the current version against the major and minor version numbers
|
|
275 ;; 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
|
|
277 ;; is hopelessly outdated. We assume that emacs-major-version and
|
|
278 ;; 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
|
|
280 ;; 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
|
|
282 ;; testing for sufficiently high Emacs versions.
|
|
283 (defun vip-check-version (op major minor &optional type-of-emacs)
|
|
284 (if (and (boundp 'emacs-major-version) (boundp 'emacs-minor-version))
|
|
285 (and (cond ((eq type-of-emacs 'xemacs) vip-xemacs-p)
|
|
286 ((eq type-of-emacs 'emacs) vip-emacs-p)
|
|
287 (t t))
|
|
288 (cond ((eq op '=) (and (= emacs-minor-version minor)
|
|
289 (= emacs-major-version major)))
|
|
290 ((memq op '(> >= < <=))
|
|
291 (and (or (funcall op emacs-major-version major)
|
|
292 (= emacs-major-version major))
|
|
293 (if (= emacs-major-version major)
|
|
294 (funcall op emacs-minor-version minor)
|
|
295 t)))
|
|
296 (t
|
|
297 (error "%S: Invalid op in vip-check-version" op))))
|
|
298 (cond ((memq op '(= > >=)) nil)
|
|
299 ((memq op '(< <=)) t))))
|
|
300
|
|
301 ;;;; warn if it is a wrong version of emacs
|
16
|
302 ;;(if (or (vip-check-version '< 19 35 'emacs)
|
|
303 ;; (vip-check-version '< 19 15 'xemacs))
|
0
|
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 ;;
|
16
|
312 ;;\t Emacs 19.35 and higher
|
0
|
313 ;;\t OR
|
16
|
314 ;;\t XEmacs 19.15 and higher
|
0
|
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)
|
|
331 (get-buffer-window wind 'visible)))
|
|
332
|
|
333
|
|
334 ;; Return line position.
|
|
335 ;; 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.
|
|
337 ;; Pos = 'indent returns beginning of indentation.
|
|
338 ;; Otherwise, returns point. Current point is not moved in any case."
|
|
339 (defun vip-line-pos (pos)
|
|
340 (let ((cur-pos (point))
|
|
341 (result))
|
|
342 (cond
|
|
343 ((equal pos 'start)
|
|
344 (beginning-of-line))
|
|
345 ((equal pos 'end)
|
|
346 (end-of-line))
|
|
347 ((equal pos 'mid)
|
|
348 (goto-char (+ (vip-line-pos 'start) (vip-line-pos 'end) 2)))
|
|
349 ((equal pos 'indent)
|
|
350 (back-to-indentation))
|
|
351 (t nil))
|
|
352 (setq result (point))
|
|
353 (goto-char cur-pos)
|
|
354 result))
|
|
355
|
|
356
|
|
357 ;; Like move-marker but creates a virgin marker if arg isn't already a marker.
|
|
358 ;; The first argument must eval to a variable name.
|
|
359 ;; Arguments: (var-name position &optional buffer).
|
|
360 ;;
|
|
361 ;; 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.
|
|
363 ;; Then, each time this var is used in `vip-move-marker-locally' in a new
|
|
364 ;; buffer, a new marker will be created.
|
|
365 (defun vip-move-marker-locally (var pos &optional buffer)
|
|
366 (if (markerp (eval var))
|
|
367 ()
|
|
368 (set var (make-marker)))
|
|
369 (move-marker (eval var) pos buffer))
|
|
370
|
|
371
|
|
372 ;; Print CONDITIONS as a message.
|
|
373 (defun vip-message-conditions (conditions)
|
|
374 (let ((case (car conditions)) (msg (cdr conditions)))
|
|
375 (if (null msg)
|
|
376 (message "%s" case)
|
|
377 (message "%s: %s" case (mapconcat 'prin1-to-string msg " ")))
|
|
378 (beep 1)))
|
|
379
|
|
380
|
|
381
|
|
382 ;;; List/alist utilities
|
|
383
|
|
384 ;; Convert LIST to an alist
|
|
385 (defun vip-list-to-alist (lst)
|
|
386 (let ((alist))
|
|
387 (while lst
|
|
388 (setq alist (cons (list (car lst)) alist))
|
|
389 (setq lst (cdr lst)))
|
|
390 alist))
|
|
391
|
|
392 ;; Convert ALIST to a list.
|
|
393 (defun vip-alist-to-list (alst)
|
|
394 (let ((lst))
|
|
395 (while alst
|
|
396 (setq lst (cons (car (car alst)) lst))
|
|
397 (setq alst (cdr alst)))
|
|
398 lst))
|
|
399
|
|
400 ;; Filter ALIST using REGEXP. Return alist whose elements match the regexp.
|
|
401 (defun vip-filter-alist (regexp alst)
|
|
402 (interactive "s x")
|
|
403 (let ((outalst) (inalst alst))
|
|
404 (while (car inalst)
|
|
405 (if (string-match regexp (car (car inalst)))
|
|
406 (setq outalst (cons (car inalst) outalst)))
|
|
407 (setq inalst (cdr inalst)))
|
|
408 outalst))
|
|
409
|
|
410 ;; Filter LIST using REGEXP. Return list whose elements match the regexp.
|
|
411 (defun vip-filter-list (regexp lst)
|
|
412 (interactive "s x")
|
|
413 (let ((outlst) (inlst lst))
|
|
414 (while (car inlst)
|
|
415 (if (string-match regexp (car inlst))
|
|
416 (setq outlst (cons (car inlst) outlst)))
|
|
417 (setq inlst (cdr inlst)))
|
|
418 outlst))
|
|
419
|
|
420
|
|
421 ;; 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
|
|
423 ;; \(car elt\) such that (car elt') is in LIS1.
|
|
424 (defun vip-append-filter-alist (lis1 lis2)
|
|
425 (let ((temp lis1)
|
|
426 elt)
|
|
427
|
|
428 ;;filter-append the second list
|
|
429 (while temp
|
|
430 ;; delete all occurrences
|
|
431 (while (setq elt (assoc (car (car temp)) lis2))
|
|
432 (setq lis2 (delq elt lis2)))
|
|
433 (setq temp (cdr temp)))
|
|
434
|
|
435 (nconc lis1 lis2)))
|
|
436
|
|
437
|
|
438 ;;; Support for :e and file globbing
|
|
439
|
|
440 (defun vip-ex-nontrivial-find-file-unix (filespec)
|
|
441 "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.
|
|
443
|
|
444 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'
|
|
446 appropriately."
|
|
447 (let ((gshell
|
|
448 (cond (ex-unix-type-shell shell-file-name)
|
|
449 ((memq system-type '(vax-vms axp-vms)) "*dcl*") ; VAX VMS
|
|
450 (t "sh"))) ; probably Unix anyway
|
|
451 (gshell-options
|
|
452 ;; using cond in anticipation of further additions
|
|
453 (cond (ex-unix-type-shell-options)
|
|
454 ))
|
12
|
455 (command (cond (vip-ms-style-os-p (format "\"ls -1 -d %s\"" filespec))
|
|
456 (t (format "ls -1 -d %s" filespec))))
|
|
457 file-list status)
|
0
|
458 (save-excursion
|
12
|
459 (set-buffer (get-buffer-create vip-ex-tmp-buf-name))
|
0
|
460 (erase-buffer)
|
|
461 (setq status
|
|
462 (if gshell-options
|
|
463 (call-process gshell nil t nil
|
|
464 gshell-options
|
|
465 "-c"
|
|
466 command)
|
|
467 (call-process gshell nil t nil
|
|
468 "-c"
|
|
469 command)))
|
|
470 (goto-char (point-min))
|
|
471 ;; Issue an error, if no match.
|
|
472 (if (> status 0)
|
|
473 (save-excursion
|
|
474 (skip-chars-forward " \t\n\j")
|
|
475 (if (looking-at "ls:")
|
|
476 (vip-forward-Word 1))
|
|
477 (error "%s: %s"
|
|
478 (if (stringp gshell)
|
|
479 gshell
|
|
480 "shell")
|
|
481 (buffer-substring (point) (vip-line-pos 'end)))
|
|
482 ))
|
|
483 (goto-char (point-min))
|
|
484 (setq file-list (vip-get-filenames-from-buffer 'one-per-line)))
|
|
485
|
|
486 (mapcar 'find-file file-list)
|
|
487 ))
|
|
488
|
|
489 (defun vip-ex-nontrivial-find-file-ms (filespec)
|
|
490 "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
|
|
492 DOS. It may also work under OS/2.
|
|
493
|
|
494 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
|
|
496 `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'."
|
|
498 (save-excursion
|
12
|
499 (set-buffer (get-buffer-create vip-ex-tmp-buf-name))
|
0
|
500 (erase-buffer)
|
|
501 (insert filespec)
|
|
502 (goto-char (point-min))
|
|
503 (mapcar 'find-file
|
|
504 (vip-glob-ms-windows-files (vip-get-filenames-from-buffer)))
|
|
505 ))
|
|
506
|
|
507
|
|
508 ;; 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
|
|
510 ;; If optional arg is supplied, assume each filename is listed on a separate
|
|
511 ;; line
|
12
|
512 (defun vip-get-filenames-from-buffer (&optional one-per-line)
|
0
|
513 (let ((skip-chars (if one-per-line "\t\n" " \t\n"))
|
|
514 result fname delim)
|
|
515 (skip-chars-forward skip-chars)
|
|
516 (while (not (eobp))
|
|
517 (if (cond ((looking-at "\"")
|
|
518 (setq delim ?\")
|
|
519 (re-search-forward "[^\"]+" nil t)) ; noerror
|
|
520 ((looking-at "'")
|
|
521 (setq delim ?')
|
|
522 (re-search-forward "[^']+" nil t)) ; noerror
|
|
523 (t
|
|
524 (re-search-forward
|
|
525 (concat "[^" skip-chars "]+") nil t))) ;noerror
|
|
526 (setq fname
|
|
527 (buffer-substring (match-beginning 0) (match-end 0))))
|
|
528 (if delim
|
|
529 (forward-char 1))
|
|
530 (skip-chars-forward " \t\n")
|
|
531 (setq result (cons fname result)))
|
|
532 result))
|
|
533
|
|
534 ;; convert MS-DOS wildcards to regexp
|
|
535 (defun vip-wildcard-to-regexp (wcard)
|
|
536 (save-excursion
|
12
|
537 (set-buffer (get-buffer-create vip-ex-tmp-buf-name))
|
0
|
538 (erase-buffer)
|
|
539 (insert wcard)
|
|
540 (goto-char (point-min))
|
|
541 (while (not (eobp))
|
|
542 (skip-chars-forward "^*?.\\\\")
|
|
543 (cond ((eq (char-after (point)) ?*) (insert ".")(forward-char 1))
|
|
544 ((eq (char-after (point)) ?.) (insert "\\")(forward-char 1))
|
|
545 ((eq (char-after (point)) ?\\) (insert "\\")(forward-char 1))
|
|
546 ((eq (char-after (point)) ??) (delete-char 1)(insert ".")))
|
|
547 )
|
|
548 (buffer-string)
|
|
549 ))
|
|
550
|
|
551
|
|
552 ;; glob windows files
|
|
553 ;; LIST is expected to be in reverse order
|
|
554 (defun vip-glob-ms-windows-files (list)
|
|
555 (let ((tmp list)
|
|
556 (case-fold-search t)
|
|
557 tmp2)
|
|
558 (while tmp
|
|
559 (setq tmp2 (cons (directory-files
|
|
560 ;; the directory part
|
|
561 (or (file-name-directory (car tmp))
|
|
562 "")
|
|
563 t ; return full names
|
|
564 ;; the regexp part: globs the file names
|
|
565 (concat "^"
|
|
566 (vip-wildcard-to-regexp
|
|
567 (file-name-nondirectory (car tmp)))
|
|
568 "$"))
|
|
569 tmp2))
|
|
570 (setq tmp (cdr tmp)))
|
|
571 (reverse (apply 'append tmp2))))
|
|
572
|
|
573
|
|
574 ;;; Insertion ring
|
|
575
|
|
576 ;; Rotate RING's index. DIRection can be positive or negative.
|
|
577 (defun vip-ring-rotate1 (ring dir)
|
|
578 (if (and (ring-p ring) (> (ring-length ring) 0))
|
|
579 (progn
|
|
580 (setcar ring (cond ((> dir 0)
|
|
581 (ring-plus1 (car ring) (ring-length ring)))
|
|
582 ((< dir 0)
|
|
583 (ring-minus1 (car ring) (ring-length ring)))
|
|
584 ;; don't rotate if dir = 0
|
|
585 (t (car ring))))
|
|
586 (vip-current-ring-item ring)
|
|
587 )))
|
|
588
|
|
589 (defun vip-special-ring-rotate1 (ring dir)
|
|
590 (if (memq vip-intermediate-command
|
|
591 '(repeating-display-destructive-command
|
|
592 repeating-insertion-from-ring))
|
|
593 (vip-ring-rotate1 ring dir)
|
|
594 ;; don't rotate otherwise
|
|
595 (vip-ring-rotate1 ring 0)))
|
|
596
|
|
597 ;; current ring item; if N is given, then so many items back from the
|
|
598 ;; current
|
|
599 (defun vip-current-ring-item (ring &optional n)
|
|
600 (setq n (or n 0))
|
|
601 (if (and (ring-p ring) (> (ring-length ring) 0))
|
|
602 (aref (cdr (cdr ring)) (mod (- (car ring) 1 n) (ring-length ring)))))
|
|
603
|
|
604 ;; push item onto ring. the second argument is a ring-variable, not value.
|
|
605 (defun vip-push-onto-ring (item ring-var)
|
|
606 (or (ring-p (eval ring-var))
|
|
607 (set ring-var (make-ring (eval (intern (format "%S-size" ring-var))))))
|
|
608 (or (null item) ; don't push nil
|
|
609 (and (stringp item) (string= item "")) ; or empty strings
|
|
610 (equal item (vip-current-ring-item (eval ring-var))) ; or old stuff
|
|
611 ;; Since vip-set-destructive-command checks if we are inside vip-repeat,
|
|
612 ;; we don't check whether this-command-keys is a `.'.
|
|
613 ;; The cmd vip-repeat makes a call to the current function only if
|
|
614 ;; `.' is executing a command from the command history. It doesn't
|
|
615 ;; call the push-onto-ring function if `.' is simply repeating the
|
|
616 ;; last destructive command.
|
|
617 ;; We only check for ESC (which happens when we do insert with a
|
|
618 ;; prefix argument, or if this-command-keys doesn't give anything
|
|
619 ;; meaningful (in that case we don't know what to show to the user).
|
|
620 (and (eq ring-var 'vip-command-ring)
|
|
621 (string-match "\\([0-9]*\e\\|^[ \t]*$\\|escape\\)"
|
|
622 (vip-array-to-string (this-command-keys))))
|
|
623 (vip-ring-insert (eval ring-var) item))
|
|
624 )
|
|
625
|
|
626
|
|
627 ;; removing elts from ring seems to break it
|
|
628 (defun vip-cleanup-ring (ring)
|
|
629 (or (< (ring-length ring) 2)
|
|
630 (null (vip-current-ring-item ring))
|
|
631 ;; last and previous equal
|
|
632 (if (equal (vip-current-ring-item ring) (vip-current-ring-item ring 1))
|
|
633 (vip-ring-pop ring))))
|
|
634
|
|
635 ;; ring-remove seems to be buggy, so we concocted this for our purposes.
|
|
636 (defun vip-ring-pop (ring)
|
|
637 (let* ((ln (ring-length ring))
|
|
638 (vec (cdr (cdr ring)))
|
|
639 (veclen (length vec))
|
|
640 (hd (car ring))
|
|
641 (idx (max 0 (ring-minus1 hd ln)))
|
|
642 (top-elt (aref vec idx)))
|
|
643
|
|
644 ;; shift elements
|
|
645 (while (< (1+ idx) veclen)
|
|
646 (aset vec idx (aref vec (1+ idx)))
|
|
647 (setq idx (1+ idx)))
|
|
648 (aset vec idx nil)
|
|
649
|
|
650 (setq hd (max 0 (ring-minus1 hd ln)))
|
|
651 (if (= hd (1- ln)) (setq hd 0))
|
|
652 (setcar ring hd) ; move head
|
|
653 (setcar (cdr ring) (max 0 (1- ln))) ; adjust length
|
|
654 top-elt
|
|
655 ))
|
|
656
|
|
657 (defun vip-ring-insert (ring item)
|
|
658 (let* ((ln (ring-length ring))
|
|
659 (vec (cdr (cdr ring)))
|
|
660 (veclen (length vec))
|
|
661 (hd (car ring))
|
|
662 (vecpos-after-hd (if (= hd 0) ln hd))
|
|
663 (idx ln))
|
|
664
|
|
665 (if (= ln veclen)
|
|
666 (progn
|
|
667 (aset vec hd item) ; hd is always 1+ the actual head index in vec
|
|
668 (setcar ring (ring-plus1 hd ln)))
|
|
669 (setcar (cdr ring) (1+ ln))
|
|
670 (setcar ring (ring-plus1 vecpos-after-hd (1+ ln)))
|
|
671 (while (and (>= idx vecpos-after-hd) (> ln 0))
|
|
672 (aset vec idx (aref vec (1- idx)))
|
|
673 (setq idx (1- idx)))
|
|
674 (aset vec vecpos-after-hd item))
|
|
675 item))
|
|
676
|
|
677
|
|
678 ;;; String utilities
|
|
679
|
|
680 ;; If STRING is longer than MAX-LEN, truncate it and print ...... instead
|
|
681 ;; PRE-STRING is a string to prepend to the abbrev string.
|
|
682 ;; POST-STRING is a string to append to the abbrev string.
|
|
683 ;; ABBREV_SIGN is a string to be inserted before POST-STRING
|
|
684 ;; if the orig string was truncated.
|
|
685 (defun vip-abbreviate-string (string max-len
|
|
686 pre-string post-string abbrev-sign)
|
|
687 (let (truncated-str)
|
|
688 (setq truncated-str
|
|
689 (if (stringp string)
|
|
690 (substring string 0 (min max-len (length string)))))
|
|
691 (cond ((null truncated-str) "")
|
|
692 ((> (length string) max-len)
|
|
693 (format "%s%s%s%s"
|
|
694 pre-string truncated-str abbrev-sign post-string))
|
|
695 (t (format "%s%s%s" pre-string truncated-str post-string)))))
|
|
696
|
|
697 ;; tells if we are over a whitespace-only line
|
|
698 (defsubst vip-over-whitespace-line ()
|
|
699 (save-excursion
|
|
700 (beginning-of-line)
|
|
701 (looking-at "^[ \t]*$")))
|
|
702
|
|
703
|
|
704 ;;; Saving settings in custom file
|
|
705
|
|
706 ;; Save the current setting of VAR in CUSTOM-FILE.
|
|
707 ;; 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.
|
|
709 ;; Arguments: var message custom-file &optional erase-message
|
|
710 (defun vip-save-setting (var message custom-file &optional erase-msg)
|
|
711 (let* ((var-name (symbol-name var))
|
|
712 (var-val (if (boundp var) (eval var)))
|
|
713 (regexp (format "^[^;]*%s[ \t\n]*[a-zA-Z---_']*[ \t\n)]" var-name))
|
|
714 (buf (find-file-noselect (substitute-in-file-name custom-file)))
|
|
715 )
|
|
716 (message message)
|
|
717 (save-excursion
|
|
718 (set-buffer buf)
|
|
719 (goto-char (point-min))
|
|
720 (if (re-search-forward regexp nil t)
|
|
721 (let ((reg-end (1- (match-end 0))))
|
|
722 (search-backward var-name)
|
|
723 (delete-region (match-beginning 0) reg-end)
|
|
724 (goto-char (match-beginning 0))
|
|
725 (insert (format "%s '%S" var-name var-val)))
|
|
726 (goto-char (point-max))
|
|
727 (if (not (bolp)) (insert "\n"))
|
|
728 (insert (format "(setq %s '%S)\n" var-name var-val)))
|
|
729 (save-buffer))
|
|
730 (kill-buffer buf)
|
|
731 (if erase-msg
|
|
732 (progn
|
|
733 (sit-for 2)
|
|
734 (message "")))
|
|
735 ))
|
|
736
|
|
737 ;; Save STRING in CUSTOM-FILE. If PATTERN is non-nil, remove strings that
|
|
738 ;; match this pattern.
|
|
739 (defun vip-save-string-in-file (string custom-file &optional pattern)
|
|
740 (let ((buf (find-file-noselect (substitute-in-file-name custom-file))))
|
|
741 (save-excursion
|
|
742 (set-buffer buf)
|
|
743 (goto-char (point-min))
|
|
744 (if pattern (delete-matching-lines pattern))
|
|
745 (goto-char (point-max))
|
|
746 (if string (insert string))
|
|
747 (save-buffer))
|
|
748 (kill-buffer buf)
|
|
749 ))
|
|
750
|
|
751
|
|
752 ;;; Overlays
|
|
753
|
|
754 ;; Search
|
|
755
|
|
756 (defun vip-flash-search-pattern ()
|
|
757 (if (vip-overlay-p vip-search-overlay)
|
|
758 (vip-move-overlay vip-search-overlay (match-beginning 0) (match-end 0))
|
|
759 (setq vip-search-overlay
|
|
760 (vip-make-overlay
|
|
761 (match-beginning 0) (match-end 0) (current-buffer))))
|
|
762
|
|
763 (vip-overlay-put vip-search-overlay 'priority vip-search-overlay-priority)
|
|
764 (if (vip-has-face-support-p)
|
|
765 (progn
|
|
766 (vip-overlay-put vip-search-overlay 'face vip-search-face)
|
|
767 (sit-for 2)
|
|
768 (vip-overlay-put vip-search-overlay 'face nil))))
|
|
769
|
12
|
770
|
0
|
771 ;; Replace state
|
|
772
|
|
773 (defsubst vip-move-replace-overlay (beg end)
|
|
774 (vip-move-overlay vip-replace-overlay beg end))
|
|
775
|
|
776 (defun vip-set-replace-overlay (beg end)
|
|
777 (if (vip-overlay-p vip-replace-overlay)
|
|
778 (vip-move-replace-overlay beg end)
|
|
779 (setq vip-replace-overlay (vip-make-overlay beg end (current-buffer)))
|
|
780 ;; never detach
|
|
781 (vip-overlay-put
|
|
782 vip-replace-overlay (if vip-emacs-p 'evaporate 'detachable) nil)
|
|
783 (vip-overlay-put
|
16
|
784 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 )
|
0
|
793 (if (vip-has-face-support-p)
|
|
794 (vip-overlay-put vip-replace-overlay 'face vip-replace-overlay-face))
|
|
795 (vip-save-cursor-color)
|
|
796 (vip-change-cursor-color vip-replace-overlay-cursor-color)
|
|
797 )
|
|
798
|
|
799
|
16
|
800 (defun vip-set-replace-overlay-glyphs (before-glyph after-glyph)
|
0
|
801 (if (or (not (vip-has-face-support-p))
|
|
802 vip-use-replace-region-delimiters)
|
|
803 (let ((before-name (if vip-xemacs-p 'begin-glyph 'before-string))
|
|
804 (after-name (if vip-xemacs-p 'end-glyph 'after-string)))
|
|
805 (vip-overlay-put vip-replace-overlay before-name before-glyph)
|
|
806 (vip-overlay-put vip-replace-overlay after-name after-glyph))))
|
|
807
|
16
|
808 (defun vip-hide-replace-overlay ()
|
0
|
809 (vip-set-replace-overlay-glyphs nil nil)
|
12
|
810 (vip-restore-cursor-color-after-replace)
|
|
811 (vip-restore-cursor-color-after-insert)
|
0
|
812 (if (vip-has-face-support-p)
|
|
813 (vip-overlay-put vip-replace-overlay 'face nil)))
|
|
814
|
|
815
|
|
816 (defsubst vip-replace-start ()
|
|
817 (vip-overlay-start vip-replace-overlay))
|
|
818 (defsubst vip-replace-end ()
|
|
819 (vip-overlay-end vip-replace-overlay))
|
|
820
|
|
821
|
|
822 ;; Minibuffer
|
|
823
|
|
824 (defun vip-set-minibuffer-overlay ()
|
|
825 (vip-check-minibuffer-overlay)
|
|
826 (if (vip-has-face-support-p)
|
|
827 (progn
|
|
828 (vip-overlay-put
|
|
829 vip-minibuffer-overlay 'face vip-minibuffer-current-face)
|
|
830 (vip-overlay-put
|
|
831 vip-minibuffer-overlay 'priority vip-minibuffer-overlay-priority)
|
|
832 ;; never detach
|
|
833 (vip-overlay-put
|
|
834 vip-minibuffer-overlay (if vip-emacs-p 'evaporate 'detachable) nil)
|
|
835 ;; make vip-minibuffer-overlay open-ended
|
|
836 ;; In emacs, it is made open ended at creation time
|
|
837 (if vip-xemacs-p
|
|
838 (progn
|
|
839 (vip-overlay-put vip-minibuffer-overlay 'start-open nil)
|
|
840 (vip-overlay-put vip-minibuffer-overlay 'end-open nil)))
|
|
841 )))
|
|
842
|
|
843 (defun vip-check-minibuffer-overlay ()
|
|
844 (or (vip-overlay-p vip-minibuffer-overlay)
|
|
845 (setq vip-minibuffer-overlay
|
|
846 (if vip-xemacs-p
|
|
847 (vip-make-overlay 1 (1+ (buffer-size)) (current-buffer))
|
|
848 ;; make overlay open-ended
|
|
849 (vip-make-overlay
|
|
850 1 (1+ (buffer-size)) (current-buffer) nil 'rear-advance)))
|
|
851 ))
|
|
852
|
|
853
|
|
854 (defsubst vip-is-in-minibuffer ()
|
|
855 (string-match "\*Minibuf-" (buffer-name)))
|
|
856
|
|
857
|
|
858
|
|
859 ;;; XEmacs compatibility
|
|
860
|
|
861 (defun vip-abbreviate-file-name (file)
|
|
862 (if vip-emacs-p
|
|
863 (abbreviate-file-name file)
|
|
864 ;; XEmacs requires addl argument
|
|
865 (abbreviate-file-name file t)))
|
|
866
|
|
867 ;; Sit for VAL milliseconds. XEmacs doesn't support the millisecond arg
|
|
868 ;; in sit-for, so this function smoothes out the differences.
|
|
869 (defsubst vip-sit-for-short (val &optional nodisp)
|
|
870 (if vip-xemacs-p
|
|
871 (sit-for (/ val 1000.0) nodisp)
|
|
872 (sit-for 0 val nodisp)))
|
|
873
|
|
874 ;; EVENT may be a single event of a sequence of events
|
|
875 (defsubst vip-ESC-event-p (event)
|
|
876 (let ((ESC-keys '(?\e (control \[) escape))
|
|
877 (key (vip-event-key event)))
|
|
878 (member key ESC-keys)))
|
16
|
879
|
|
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))))))
|
0
|
888
|
|
889 (defsubst vip-mark-marker ()
|
|
890 (if vip-xemacs-p
|
|
891 (mark-marker t)
|
|
892 (mark-marker)))
|
|
893
|
|
894 ;; like (set-mark-command nil) but doesn't push twice, if (car mark-ring)
|
|
895 ;; is the same as (mark t).
|
|
896 (defsubst vip-set-mark-if-necessary ()
|
|
897 (setq mark-ring (delete (vip-mark-marker) mark-ring))
|
|
898 (set-mark-command nil))
|
|
899
|
|
900 ;; 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
|
|
902 ;; the user explicitly wants highlighting, e.g., by hitting '' or ``
|
|
903 (defun vip-deactivate-mark ()
|
|
904 (if vip-xemacs-p
|
|
905 (zmacs-deactivate-region)
|
|
906 (deactivate-mark)))
|
|
907
|
|
908 (defsubst vip-leave-region-active ()
|
|
909 (if vip-xemacs-p
|
|
910 (setq zmacs-region-stays t)))
|
|
911
|
16
|
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
|
0
|
927
|
|
928 (defsubst vip-events-to-keys (events)
|
|
929 (cond (vip-xemacs-p (events-to-keys events))
|
|
930 (t events)))
|
|
931
|
|
932
|
|
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.
|
|
945 ;;
|
|
946 ;;Add to the value of HOOK the function FUNCTION.
|
|
947 ;;FUNCTION is not added if already present.
|
|
948 ;;FUNCTION is added (if necessary) at the beginning of the hook list
|
|
949 ;;unless the optional argument APPEND is non-nil, in which case
|
|
950 ;;FUNCTION is added at the end.
|
|
951 ;;
|
|
952 ;;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
|
|
954 ;;function, it is changed to a list of functions."
|
|
955 (defun vip-add-hook (hook function &optional append)
|
|
956 (if (not (boundp hook)) (set hook nil))
|
|
957 ;; If the hook value is a single function, turn it into a list.
|
|
958 (let ((old (symbol-value hook)))
|
|
959 (if (or (not (listp old)) (eq (car old) 'lambda))
|
|
960 (setq old (list old)))
|
|
961 (if (member function old)
|
|
962 nil
|
|
963 (set hook (if append
|
|
964 (append old (list function)) ; don't nconc
|
|
965 (cons function old))))))
|
|
966
|
|
967 ;; This is here because of Emacs's changes in the semantics of add/remove-hooks
|
|
968 ;; and due to the bugs they introduced.
|
|
969 ;;
|
|
970 ;; Remove from the value of HOOK the function FUNCTION.
|
|
971 ;; 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
|
|
973 ;; list of hooks to run in HOOK, then nothing is done. See `vip-add-hook'."
|
|
974 (defun vip-remove-hook (hook function)
|
|
975 (if (or (not (boundp hook)) ;unbound symbol, or
|
|
976 (null (symbol-value hook)) ;value is nil, or
|
|
977 (null function)) ;function is nil, then
|
|
978 nil ;Do nothing.
|
|
979 (let ((hook-value (symbol-value hook)))
|
|
980 (if (consp hook-value)
|
|
981 ;; don't side-effect the list
|
|
982 (setq hook-value (delete function (copy-sequence hook-value)))
|
|
983 (if (equal hook-value function)
|
|
984 (setq hook-value nil)))
|
|
985 (set hook hook-value))))
|
|
986
|
|
987
|
14
|
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))
|
0
|
994
|
|
995 ;; like read-event, but in XEmacs also try to convert to char, if possible
|
|
996 (defun vip-read-event-convert-to-char ()
|
|
997 (let (event)
|
|
998 (if vip-emacs-p
|
|
999 (read-event)
|
|
1000 (setq event (next-command-event))
|
|
1001 (or (event-to-character event)
|
|
1002 event))
|
|
1003 ))
|
|
1004
|
|
1005 ;; 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
|
12
|
1007 ;; 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
|
|
1009 ;; terminal) into logical keys left, right, etc.
|
0
|
1010 (defun vip-read-key ()
|
14
|
1011 (let ((overriding-local-map vip-overriding-map)
|
12
|
1012 (inhibit-quit t)
|
0
|
1013 key)
|
|
1014 (use-global-map vip-overriding-map)
|
|
1015 (setq key (elt (read-key-sequence nil) 0))
|
|
1016 (use-global-map global-map)
|
12
|
1017 key))
|
0
|
1018
|
|
1019
|
|
1020 ;; Emacs has a bug in eventp, which causes (eventp nil) to return (nil)
|
|
1021 ;; instead of nil, if '(nil) was previously inadvertently assigned to
|
|
1022 ;; unread-command-events
|
|
1023 (defun vip-event-key (event)
|
|
1024 (or (and event (eventp event))
|
|
1025 (error "vip-event-key: Wrong type argument, eventp, %S" event))
|
16
|
1026 (when (cond (vip-xemacs-p (or (key-press-event-p event)
|
|
1027 (mouse-event-p event)))
|
|
1028 (t t))
|
|
1029 (let ((mod (event-modifiers event))
|
|
1030 basis)
|
|
1031 (setq basis
|
|
1032 (cond
|
|
1033 (vip-xemacs-p
|
|
1034 (cond ((key-press-event-p event)
|
|
1035 (event-key event))
|
|
1036 ((button-event-p event)
|
|
1037 (concat "mouse-" (prin1-to-string (event-button event))))
|
|
1038 (t
|
|
1039 (error "vip-event-key: Unknown event, %S" event))))
|
|
1040 (t
|
|
1041 ;; Emacs doesn't handle capital letters correctly, since
|
|
1042 ;; \S-a isn't considered the same as A (it behaves as
|
|
1043 ;; plain `a' instead). So we take care of this here
|
|
1044 (cond ((and (vip-characterp event) (<= ?A event) (<= event ?Z))
|
|
1045 (setq mod nil
|
|
1046 event event))
|
|
1047 ;; Emacs has the oddity whereby characters 128+char
|
|
1048 ;; represent M-char *if* this appears inside a string.
|
|
1049 ;; So, we convert them manually to (meta char).
|
|
1050 ((and (vip-characterp event)
|
|
1051 (< ?\C-? event) (<= event 255))
|
|
1052 (setq mod '(meta)
|
|
1053 event (- event ?\C-? 1)))
|
|
1054 (t (event-basic-type event)))
|
|
1055 )))
|
|
1056 (if (vip-characterp basis)
|
|
1057 (setq basis
|
|
1058 (if (= basis ?\C-?)
|
|
1059 (list 'control '\?) ; taking care of an emacs bug
|
|
1060 (intern (char-to-string basis)))))
|
|
1061 (if mod
|
|
1062 (append mod (list basis))
|
|
1063 basis))))
|
0
|
1064
|
|
1065 (defun vip-key-to-emacs-key (key)
|
|
1066 (let (key-name char-p modifiers mod-char-list base-key base-key-name)
|
|
1067 (cond (vip-xemacs-p key)
|
|
1068 ((symbolp key)
|
|
1069 (setq key-name (symbol-name key))
|
|
1070 (if (= (length key-name) 1) ; character event
|
|
1071 (string-to-char key-name)
|
|
1072 key))
|
|
1073 ((listp key)
|
|
1074 (setq modifiers (subseq key 0 (1- (length key)))
|
|
1075 base-key (vip-seq-last-elt key)
|
|
1076 base-key-name (symbol-name base-key)
|
|
1077 char-p (= (length base-key-name) 1))
|
|
1078 (setq mod-char-list
|
|
1079 (mapcar
|
|
1080 '(lambda (elt) (upcase (substring (symbol-name elt) 0 1)))
|
|
1081 modifiers))
|
|
1082 (if char-p
|
|
1083 (setq key-name
|
|
1084 (car (read-from-string
|
|
1085 (concat
|
|
1086 "?\\"
|
|
1087 (mapconcat 'identity mod-char-list "-\\")
|
|
1088 "-"
|
|
1089 base-key-name))))
|
|
1090 (setq key-name
|
|
1091 (intern
|
|
1092 (concat
|
|
1093 (mapconcat 'identity mod-char-list "-")
|
|
1094 "-"
|
|
1095 base-key-name))))))
|
|
1096 ))
|
|
1097
|
|
1098
|
|
1099 ;; Args can be a sequence of events, a string, or a Viper macro. Will try to
|
|
1100 ;; convert events to keys and, if all keys are regular printable
|
|
1101 ;; characters, will return a string. Otherwise, will return a string
|
|
1102 ;; representing a vector of converted events. If the input was a Viper macro,
|
|
1103 ;; will return a string that represents this macro as a vector.
|
|
1104 (defun vip-array-to-string (event-seq)
|
|
1105 (let (temp temp2)
|
|
1106 (cond ((stringp event-seq) event-seq)
|
|
1107 ((vip-event-vector-p event-seq)
|
|
1108 (setq temp (mapcar 'vip-event-key event-seq))
|
|
1109 (cond ((vip-char-symbol-sequence-p temp)
|
|
1110 (mapconcat 'symbol-name temp ""))
|
|
1111 ((and (vip-char-array-p
|
|
1112 (setq temp2 (mapcar 'vip-key-to-character temp))))
|
|
1113 (mapconcat 'char-to-string temp2 ""))
|
|
1114 (t (prin1-to-string (vconcat temp)))))
|
|
1115 ((vip-char-symbol-sequence-p event-seq)
|
|
1116 (mapconcat 'symbol-name event-seq ""))
|
|
1117 ((and (vectorp event-seq)
|
|
1118 (vip-char-array-p
|
|
1119 (setq temp (mapcar 'vip-key-to-character event-seq))))
|
|
1120 (mapconcat 'char-to-string temp ""))
|
|
1121 (t (prin1-to-string event-seq)))))
|
|
1122
|
|
1123 (defun vip-key-press-events-to-chars (events)
|
|
1124 (mapconcat (if vip-emacs-p
|
|
1125 'char-to-string
|
|
1126 (function
|
|
1127 (lambda (elt) (char-to-string (event-to-character elt)))))
|
|
1128 events
|
|
1129 ""))
|
|
1130
|
|
1131
|
|
1132 (defsubst vip-fast-keysequence-p ()
|
|
1133 (not (vip-sit-for-short vip-fast-keyseq-timeout t)))
|
|
1134
|
|
1135 (defun vip-read-char-exclusive ()
|
|
1136 (let (char
|
|
1137 (echo-keystrokes 1))
|
|
1138 (while (null char)
|
|
1139 (condition-case nil
|
|
1140 (setq char (read-char))
|
|
1141 (error
|
|
1142 ;; skip event if not char
|
|
1143 (vip-read-event))))
|
|
1144 char))
|
|
1145
|
|
1146 ;; key is supposed to be in viper's representation, e.g., (control l), a
|
|
1147 ;; character, etc.
|
|
1148 (defun vip-key-to-character (key)
|
|
1149 (cond ((eq key 'space) ?\ )
|
|
1150 ((eq key 'delete) ?\C-?)
|
|
1151 ((eq key 'backspace) ?\C-h)
|
|
1152 ((and (symbolp key)
|
|
1153 (= 1 (length (symbol-name key))))
|
|
1154 (string-to-char (symbol-name key)))
|
|
1155 ((and (listp key)
|
|
1156 (eq (car key) 'control)
|
|
1157 (symbol-name (nth 1 key))
|
|
1158 (= 1 (length (symbol-name (nth 1 key)))))
|
|
1159 (read (format "?\\C-%s" (symbol-name (nth 1 key)))))
|
|
1160 (t key)))
|
|
1161
|
|
1162
|
|
1163 (defun vip-setup-master-buffer (&rest other-files-or-buffers)
|
|
1164 "Set up the current buffer as a master buffer.
|
|
1165 Arguments become related buffers. This function should normally be used in
|
|
1166 the `Local variables' section of a file."
|
|
1167 (setq vip-related-files-and-buffers-ring
|
|
1168 (make-ring (1+ (length other-files-or-buffers))))
|
|
1169 (mapcar '(lambda (elt)
|
|
1170 (vip-ring-insert vip-related-files-and-buffers-ring elt))
|
|
1171 other-files-or-buffers)
|
|
1172 (vip-ring-insert vip-related-files-and-buffers-ring (buffer-name))
|
|
1173 )
|
|
1174
|
|
1175 ;;; Movement utilities
|
|
1176
|
|
1177 (defvar vip-syntax-preference 'strict-vi
|
|
1178 "*Syntax type characterizing Viper's alphanumeric symbols.
|
|
1179 `emacs' means only word constituents are considered to be alphanumeric.
|
|
1180 Word constituents are symbols specified as word constituents by the current
|
|
1181 syntax table.
|
|
1182 `extended' means word and symbol constituents.
|
|
1183 `reformed-vi' means Vi-ish behavior: word constituents and the symbol `_'.
|
|
1184 However, word constituents are determined according to Emacs syntax tables,
|
|
1185 which may be different from Vi in some major modes.
|
|
1186 `strict-vi' means Viper words are exactly as in Vi.")
|
|
1187
|
|
1188 (vip-deflocalvar vip-ALPHA-char-class "w"
|
|
1189 "String of syntax classes characterizing Viper's alphanumeric symbols.
|
|
1190 In addition, the symbol `_' may be considered alphanumeric if
|
|
1191 `vip-syntax-preference'is `reformed-vi'.")
|
|
1192
|
|
1193 (vip-deflocalvar vip-strict-ALPHA-chars "a-zA-Z0-9_"
|
|
1194 "Regexp matching the set of alphanumeric characters acceptable to strict
|
|
1195 Vi.")
|
|
1196 (vip-deflocalvar vip-strict-SEP-chars " \t\n"
|
|
1197 "Regexp matching the set of alphanumeric characters acceptable to strict
|
|
1198 Vi.")
|
|
1199
|
|
1200 (vip-deflocalvar vip-SEP-char-class " -"
|
|
1201 "String of syntax classes for Vi separators.
|
|
1202 Usually contains ` ', linefeed, TAB or formfeed.")
|
|
1203
|
|
1204 (defun vip-update-alphanumeric-class ()
|
12
|
1205 "Set the syntax class of Viper alphanumerals according to `vip-syntax-preference'.
|
|
1206 Must be called in order for changes to `vip-syntax-preference' to take effect."
|
0
|
1207 (interactive)
|
|
1208 (setq-default
|
|
1209 vip-ALPHA-char-class
|
|
1210 (cond ((eq vip-syntax-preference 'emacs) "w") ; only word constituents
|
|
1211 ((eq vip-syntax-preference 'extended) "w_") ; word & symbol chars
|
|
1212 (t "w")))) ; vi syntax: word constituents and the symbol `_'
|
|
1213
|
|
1214 ;; addl-chars are characters to be temporarily considered as alphanumerical
|
|
1215 (defun vip-looking-at-alpha (&optional addl-chars)
|
|
1216 (or (stringp addl-chars) (setq addl-chars ""))
|
|
1217 (if (eq vip-syntax-preference 'reformed-vi)
|
|
1218 (setq addl-chars (concat addl-chars "_")))
|
|
1219 (let ((char (char-after (point))))
|
|
1220 (if char
|
|
1221 (if (eq vip-syntax-preference 'strict-vi)
|
|
1222 (looking-at (concat "[" vip-strict-ALPHA-chars addl-chars "]"))
|
|
1223 (or (memq char
|
|
1224 ;; convert string to list
|
|
1225 (append (vconcat addl-chars) nil))
|
|
1226 (memq (char-syntax char)
|
|
1227 (append (vconcat vip-ALPHA-char-class) nil)))))
|
|
1228 ))
|
|
1229
|
16
|
1230 (defun vip-looking-at-separator ()
|
0
|
1231 (let ((char (char-after (point))))
|
|
1232 (if char
|
|
1233 (or (eq char ?\n) ; RET is always a separator in Vi
|
|
1234 (memq (char-syntax char)
|
|
1235 (append (vconcat vip-SEP-char-class) nil))))))
|
|
1236
|
|
1237 (defsubst vip-looking-at-alphasep (&optional addl-chars)
|
|
1238 (or (vip-looking-at-separator) (vip-looking-at-alpha addl-chars)))
|
|
1239
|
16
|
1240 (defun vip-skip-alpha-forward (&optional addl-chars)
|
0
|
1241 (or (stringp addl-chars) (setq addl-chars ""))
|
|
1242 (vip-skip-syntax
|
|
1243 'forward
|
|
1244 (cond ((eq vip-syntax-preference 'strict-vi)
|
|
1245 "")
|
|
1246 (t vip-ALPHA-char-class ))
|
|
1247 (cond ((eq vip-syntax-preference 'strict-vi)
|
|
1248 (concat vip-strict-ALPHA-chars addl-chars))
|
|
1249 (t addl-chars))))
|
|
1250
|
16
|
1251 (defun vip-skip-alpha-backward (&optional addl-chars)
|
0
|
1252 (or (stringp addl-chars) (setq addl-chars ""))
|
|
1253 (vip-skip-syntax
|
|
1254 'backward
|
|
1255 (cond ((eq vip-syntax-preference 'strict-vi)
|
|
1256 "")
|
|
1257 (t vip-ALPHA-char-class ))
|
|
1258 (cond ((eq vip-syntax-preference 'strict-vi)
|
|
1259 (concat vip-strict-ALPHA-chars addl-chars))
|
|
1260 (t addl-chars))))
|
|
1261
|
|
1262 ;; weird syntax tables may confuse strict-vi style
|
|
1263 (defsubst vip-skip-all-separators-forward (&optional within-line)
|
|
1264 (vip-skip-syntax 'forward
|
|
1265 vip-SEP-char-class
|
|
1266 (or within-line "\n")
|
|
1267 (if within-line (vip-line-pos 'end))))
|
|
1268 (defsubst vip-skip-all-separators-backward (&optional within-line)
|
|
1269 (vip-skip-syntax 'backward
|
|
1270 vip-SEP-char-class
|
|
1271 (or within-line "\n")
|
|
1272 (if within-line (vip-line-pos 'start))))
|
|
1273 (defun vip-skip-nonseparators (direction)
|
|
1274 (let ((func (intern (format "skip-syntax-%S" direction))))
|
|
1275 (funcall func (concat "^" vip-SEP-char-class)
|
|
1276 (vip-line-pos (if (eq direction 'forward) 'end 'start)))))
|
|
1277
|
16
|
1278 (defun vip-skip-nonalphasep-forward ()
|
0
|
1279 (if (eq vip-syntax-preference 'strict-vi)
|
|
1280 (skip-chars-forward
|
|
1281 (concat "^" vip-strict-SEP-chars vip-strict-ALPHA-chars))
|
|
1282 (skip-syntax-forward
|
|
1283 (concat
|
|
1284 "^" vip-ALPHA-char-class vip-SEP-char-class) (vip-line-pos 'end))))
|
16
|
1285 (defun vip-skip-nonalphasep-backward ()
|
0
|
1286 (if (eq vip-syntax-preference 'strict-vi)
|
|
1287 (skip-chars-backward
|
|
1288 (concat "^" vip-strict-SEP-chars vip-strict-ALPHA-chars))
|
|
1289 (skip-syntax-backward
|
|
1290 (concat
|
|
1291 "^" vip-ALPHA-char-class vip-SEP-char-class) (vip-line-pos 'start))))
|
|
1292
|
|
1293 ;; Skip SYNTAX like skip-syntax-* and ADDL-CHARS like skip-chars-*
|
|
1294 ;; Return the number of chars traveled.
|
|
1295 ;; Either SYNTAX or ADDL-CHARS can be nil, in which case they are interpreted
|
|
1296 ;; as an empty string.
|
|
1297 (defun vip-skip-syntax (direction syntax addl-chars &optional limit)
|
|
1298 (let ((total 0)
|
|
1299 (local 1)
|
|
1300 (skip-chars-func (intern (format "skip-chars-%S" direction)))
|
|
1301 (skip-syntax-func (intern (format "skip-syntax-%S" direction))))
|
|
1302 (or (stringp addl-chars) (setq addl-chars ""))
|
|
1303 (or (stringp syntax) (setq syntax ""))
|
|
1304 (while (and (not (= local 0)) (not (eobp)))
|
|
1305 (setq local
|
|
1306 (+ (funcall skip-syntax-func syntax limit)
|
|
1307 (funcall skip-chars-func addl-chars limit)))
|
|
1308 (setq total (+ total local)))
|
|
1309 total
|
|
1310 ))
|
|
1311
|
|
1312
|
|
1313
|
|
1314
|
|
1315 (provide 'viper-util)
|
|
1316
|
|
1317 ;;; viper-util.el ends here
|