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