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