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