1 ;;; viper-util.el --- Utilities used by viper.el
3 ;; Copyright (C) 1994, 1995 Free Software Foundation, Inc.
5 ;; This file is part of GNU Emacs.
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)
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.
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.
24 ;; Whether it is XEmacs or not
25 (defconst vip-xemacs-p
(string-match "\\(Lucid\\|XEmacs\\)" emacs-version
))
26 ;; Whether it is Emacs or not
27 (defconst vip-emacs-p
(not vip-xemacs-p
))
28 ;; Tell whether we are running as a window application or on a TTY
29 (defsubst vip-device-type
()
32 (device-type (selected-device))))
33 ;; in XEmacs: device-type is tty on tty and stream in batch.
34 (defun vip-window-display-p ()
35 (and (vip-device-type) (not (memq (vip-device-type) '(tty stream
)))))
37 (defvar vip-force-faces nil
38 "If t, Viper will think that it is running on a display that supports faces.
39 This is provided as a temporary relief for users of face-capable displays
40 that Viper doesn't know about.")
42 (defun vip-has-face-support-p ()
43 (cond ((vip-window-display-p))
45 (vip-emacs-p (memq (vip-device-type) '(pc)))
46 (vip-xemacs-p (memq (vip-device-type) '(tty pc
)))))
51 (defmacro vip-deflocalvar
(var default-value
&optional documentation
)
53 (defvar (, var
) (, default-value
)
54 (, (format "%s\n\(buffer local\)" documentation
)))
55 (make-variable-buffer-local '(, var
))
58 (defmacro vip-loop
(count body
)
59 "(vip-loop COUNT BODY) Execute BODY COUNT times."
60 (list 'let
(list (list 'count count
))
61 (list 'while
'(> count
0)
63 '(setq count
(1- count
))
66 (defmacro vip-buffer-live-p
(buf)
67 (` (and (, buf
) (get-buffer (, buf
)) (buffer-name (get-buffer (, buf
))))))
69 ;; return buffer-specific macro definition, given a full macro definition
70 (defmacro vip-kbd-buf-alist
(macro-elt)
71 (` (nth 1 (, macro-elt
))))
72 ;; get a pair: (curr-buffer . macro-definition)
73 (defmacro vip-kbd-buf-pair
(macro-elt)
74 (` (assoc (buffer-name) (vip-kbd-buf-alist (, macro-elt
)))))
75 ;; get macro definition for current buffer
76 (defmacro vip-kbd-buf-definition
(macro-elt)
77 (` (cdr (vip-kbd-buf-pair (, macro-elt
)))))
79 ;; return mode-specific macro definitions, given a full macro definition
80 (defmacro vip-kbd-mode-alist
(macro-elt)
81 (` (nth 2 (, macro-elt
))))
82 ;; get a pair: (major-mode . macro-definition)
83 (defmacro vip-kbd-mode-pair
(macro-elt)
84 (` (assoc major-mode
(vip-kbd-mode-alist (, macro-elt
)))))
85 ;; get macro definition for the current major mode
86 (defmacro vip-kbd-mode-definition
(macro-elt)
87 (` (cdr (vip-kbd-mode-pair (, macro-elt
)))))
89 ;; return global macro definition, given a full macro definition
90 (defmacro vip-kbd-global-pair
(macro-elt)
91 (` (nth 3 (, macro-elt
))))
92 ;; get global macro definition from an elt of macro-alist
93 (defmacro vip-kbd-global-definition
(macro-elt)
94 (` (cdr (vip-kbd-global-pair (, macro-elt
)))))
96 ;; last elt of a sequence
97 (defsubst vip-seq-last-elt
(seq)
98 (elt seq
(1- (length seq
))))
100 ;; Check if arg is a valid character for register
101 ;; TYPE is a list that can contain `letter', `Letter', and `digit'.
102 ;; Letter means lowercase letters, Letter means uppercase letters, and
103 ;; digit means digits from 1 to 9.
104 ;; If TYPE is nil, then down/uppercase letters and digits are allowed.
105 (defun vip-valid-register (reg &optional type
)
106 (or type
(setq type
'(letter Letter digit
)))
107 (or (if (memq 'letter type
)
108 (and (<= ?a reg
) (<= reg ?z
)))
109 (if (memq 'digit type
)
110 (and (<= ?
1 reg
) (<= reg ?
9)))
111 (if (memq 'Letter type
)
112 (and (<= ?A reg
) (<= reg ?Z
)))
115 ;; checks if object is a marker, has a buffer, and points to within that buffer
116 (defun vip-valid-marker (marker)
117 (if (and (markerp marker
) (marker-buffer marker
))
118 (let ((buf (marker-buffer marker
))
119 (pos (marker-position marker
)))
122 (and (<= pos
(point-max)) (<= (point-min) pos
))))))
125 (defvar vip-minibuffer-overlay-priority
300)
126 (defvar vip-replace-overlay-priority
400)
127 (defvar vip-search-overlay-priority
500)
134 (fset 'vip-read-event
(symbol-function 'next-command-event
))
135 (fset 'vip-make-overlay
(symbol-function 'make-extent
))
136 (fset 'vip-overlay-start
(symbol-function 'extent-start-position
))
137 (fset 'vip-overlay-end
(symbol-function 'extent-end-position
))
138 (fset 'vip-overlay-put
(symbol-function 'set-extent-property
))
139 (fset 'vip-overlay-p
(symbol-function 'extentp
))
140 (fset 'vip-overlay-get
(symbol-function 'extent-property
))
141 (fset 'vip-move-overlay
(symbol-function 'set-extent-endpoints
))
142 (if (vip-window-display-p)
143 (fset 'vip-iconify
(symbol-function 'iconify-frame
)))
144 (cond ((vip-has-face-support-p)
145 (fset 'vip-get-face
(symbol-function 'get-face
))
146 (fset 'vip-color-defined-p
147 (symbol-function 'valid-color-name-p
))
149 (fset 'vip-read-event
(symbol-function 'read-event
))
150 (fset 'vip-make-overlay
(symbol-function 'make-overlay
))
151 (fset 'vip-overlay-start
(symbol-function 'overlay-start
))
152 (fset 'vip-overlay-end
(symbol-function 'overlay-end
))
153 (fset 'vip-overlay-put
(symbol-function 'overlay-put
))
154 (fset 'vip-overlay-p
(symbol-function 'overlayp
))
155 (fset 'vip-overlay-get
(symbol-function 'overlay-get
))
156 (fset 'vip-move-overlay
(symbol-function 'move-overlay
))
157 (if (vip-window-display-p)
158 (fset 'vip-iconify
(symbol-function 'iconify-or-deiconify-frame
)))
159 (cond ((vip-has-face-support-p)
160 (fset 'vip-get-face
(symbol-function 'internal-get-face
))
161 (fset 'vip-color-defined-p
(symbol-function 'x-color-defined-p
))
164 (defsubst vip-color-display-p
()
167 (eq (device-class (selected-device)) 'color
)))
170 (cond ((eq (vip-device-type) 'pm
)
171 (fset 'vip-color-defined-p
172 (function (lambda (color) (assoc color pm-color-alist
))))))
174 ;; needed to smooth out the difference between Emacs and XEmacs
175 (defsubst vip-italicize-face
(face)
177 (make-face-italic face
)
178 (make-face-italic face nil
'noerror
)))
180 ;; test if display is color and the colors are defined
181 (defsubst vip-can-use-colors
(&rest colors
)
182 (if (vip-color-display-p)
183 (not (memq nil
(mapcar 'vip-color-defined-p colors
)))
186 (defun vip-hide-face (face)
187 (if (and (vip-has-face-support-p) vip-emacs-p
)
188 (add-to-list 'facemenu-unlisted-faces face
)))
191 (defun vip-change-cursor-color (new-color)
192 (if (and (vip-window-display-p) (vip-color-display-p)
193 (stringp new-color
) (vip-color-defined-p new-color
)
194 (not (string= new-color
(vip-get-cursor-color))))
195 (modify-frame-parameters
196 (selected-frame) (list (cons 'cursor-color new-color
)))))
198 (defsubst vip-save-cursor-color
()
199 (if (and (vip-window-display-p) (vip-color-display-p))
200 (let ((color (vip-get-cursor-color)))
201 (if (and (stringp color
) (vip-color-defined-p color
)
202 (not (string= color vip-replace-overlay-cursor-color
)))
203 (vip-overlay-put vip-replace-overlay
'vip-cursor-color color
)))))
205 (defsubst vip-restore-cursor-color
()
206 (vip-change-cursor-color
207 (vip-overlay-get vip-replace-overlay
'vip-cursor-color
)))
209 (defsubst vip-get-cursor-color
()
210 (cdr (assoc 'cursor-color
(frame-parameters))))
213 ;; Check the current version against the major and minor version numbers
214 ;; using op: cur-vers op major.minor If emacs-major-version or
215 ;; emacs-minor-version are not defined, we assume that the current version
216 ;; is hopelessly outdated. We assume that emacs-major-version and
217 ;; emacs-minor-version are defined. Otherwise, for Emacs/XEmacs 19, if the
218 ;; current minor version is < 10 (xemacs) or < 23 (emacs) the return value
219 ;; will be nil (when op is =, >, or >=) and t (when op is <, <=), which may be
220 ;; incorrect. However, this gives correct result in our cases, since we are
221 ;; testing for sufficiently high Emacs versions.
222 (defun vip-check-version (op major minor
&optional type-of-emacs
)
223 (if (and (boundp 'emacs-major-version
) (boundp 'emacs-minor-version
))
224 (and (cond ((eq type-of-emacs
'xemacs
) vip-xemacs-p
)
225 ((eq type-of-emacs
'emacs
) vip-emacs-p
)
227 (cond ((eq op
'=) (and (= emacs-minor-version minor
)
228 (= emacs-major-version major
)))
229 ((memq op
'(> >= < <=))
230 (and (or (funcall op emacs-major-version major
)
231 (= emacs-major-version major
))
232 (if (= emacs-major-version major
)
233 (funcall op emacs-minor-version minor
)
236 (error "%S: Invalid op in vip-check-version" op
))))
237 (cond ((memq op
'(= > >=)) nil
)
238 ((memq op
'(< <=)) t
))))
240 ;;;; warn if it is a wrong version of emacs
241 ;;(if (or (vip-check-version '< 19 29 'emacs)
242 ;; (vip-check-version '< 19 12 'xemacs))
244 ;; (with-output-to-temp-buffer " *vip-info*"
245 ;; (switch-to-buffer " *vip-info*")
249 ;;This version of Viper requires
251 ;;\t Emacs 19.29 and higher
253 ;;\t XEmacs 19.12 and higher
255 ;;It is unlikely to work under Emacs version %s
256 ;;that you are using... " emacs-version))
258 ;; (if noninteractive
262 ;; (insert "\n\nType any key to continue... ")
263 ;; (vip-read-event)))
264 ;; (kill-buffer " *vip-info*")))
267 (defun vip-get-visible-buffer-window (wind)
269 (get-buffer-window wind t
)
270 (get-buffer-window wind
'visible
)))
273 ;; Return line position.
274 ;; If pos is 'start then returns position of line start.
275 ;; If pos is 'end, returns line end. If pos is 'mid, returns line center.
276 ;; Pos = 'indent returns beginning of indentation.
277 ;; Otherwise, returns point. Current point is not moved in any case."
278 (defun vip-line-pos (pos)
279 (let ((cur-pos (point))
287 (goto-char (+ (vip-line-pos 'start
) (vip-line-pos 'end
) 2)))
289 (back-to-indentation))
291 (setq result
(point))
296 ;; Like move-marker but creates a virgin marker if arg isn't already a marker.
297 ;; The first argument must eval to a variable name.
298 ;; Arguments: (var-name position &optional buffer).
300 ;; This is useful for moving markers that are supposed to be local.
301 ;; For this, VAR-NAME should be made buffer-local with nil as a default.
302 ;; Then, each time this var is used in `vip-move-marker-locally' in a new
303 ;; buffer, a new marker will be created.
304 (defun vip-move-marker-locally (var pos
&optional buffer
)
305 (if (markerp (eval var
))
307 (set var
(make-marker)))
308 (move-marker (eval var
) pos buffer
))
311 ;; Print CONDITIONS as a message.
312 (defun vip-message-conditions (conditions)
313 (let ((case (car conditions
)) (msg (cdr conditions
)))
316 (message "%s: %s" case
(mapconcat 'prin1-to-string msg
" ")))
321 ;;; List/alist utilities
323 ;; Convert LIST to an alist
324 (defun vip-list-to-alist (lst)
327 (setq alist
(cons (list (car lst
)) alist
))
328 (setq lst
(cdr lst
)))
331 ;; Convert ALIST to a list.
332 (defun vip-alist-to-list (alst)
335 (setq lst
(cons (car (car alst
)) lst
))
336 (setq alst
(cdr alst
)))
339 ;; Filter ALIST using REGEXP. Return alist whose elements match the regexp.
340 (defun vip-filter-alist (regexp alst
)
342 (let ((outalst) (inalst alst
))
344 (if (string-match regexp
(car (car inalst
)))
345 (setq outalst
(cons (car inalst
) outalst
)))
346 (setq inalst
(cdr inalst
)))
349 ;; Filter LIST using REGEXP. Return list whose elements match the regexp.
350 (defun vip-filter-list (regexp lst
)
352 (let ((outlst) (inlst lst
))
354 (if (string-match regexp
(car inlst
))
355 (setq outlst
(cons (car inlst
) outlst
)))
356 (setq inlst
(cdr inlst
)))
360 ;; Append LIS2 to LIS1, both alists, by side-effect and returns LIS1
361 ;; LIS2 is modified by filtering it: deleting its members of the form
362 ;; \(car elt\) such that (car elt') is in LIS1.
363 (defun vip-append-filter-alist (lis1 lis2
)
367 ;;filter-append the second list
369 ;; delete all occurrences
370 (while (setq elt
(assoc (car (car temp
)) lis2
))
371 (setq lis2
(delq elt lis2
)))
372 (setq temp
(cdr temp
)))
381 ;; Rotate RING's index. DIRection can be positive or negative.
382 (defun vip-ring-rotate1 (ring dir
)
383 (if (and (ring-p ring
) (> (ring-length ring
) 0))
385 (setcar ring
(cond ((> dir
0)
386 (ring-plus1 (car ring
) (ring-length ring
)))
388 (ring-minus1 (car ring
) (ring-length ring
)))
389 ;; don't rotate if dir = 0
391 (vip-current-ring-item ring
)
394 (defun vip-special-ring-rotate1 (ring dir
)
395 (if (memq vip-intermediate-command
396 '(repeating-display-destructive-command
397 repeating-insertion-from-ring
))
398 (vip-ring-rotate1 ring dir
)
399 ;; don't rotate otherwise
400 (vip-ring-rotate1 ring
0)))
402 ;; current ring item; if N is given, then so many items back from the
404 (defun vip-current-ring-item (ring &optional n
)
406 (if (and (ring-p ring
) (> (ring-length ring
) 0))
407 (aref (cdr (cdr ring
)) (mod (- (car ring
) 1 n
) (ring-length ring
)))))
409 ;; push item onto ring. the second argument is a ring-variable, not value.
410 (defun vip-push-onto-ring (item ring-var
)
411 (or (ring-p (eval ring-var
))
412 (set ring-var
(make-ring (eval (intern (format "%S-size" ring-var
))))))
413 (or (null item
) ; don't push nil
414 (and (stringp item
) (string= item
"")) ; or empty strings
415 (equal item
(vip-current-ring-item (eval ring-var
))) ; or old stuff
416 ;; Since vip-set-destructive-command checks if we are inside vip-repeat,
417 ;; we don't check whether this-command-keys is a `.'.
418 ;; The cmd vip-repeat makes a call to the current function only if
419 ;; `.' is executing a command from the command history. It doesn't
420 ;; call the push-onto-ring function if `.' is simply repeating the
421 ;; last destructive command.
422 ;; We only check for ESC (which happens when we do insert with a
423 ;; prefix argument, or if this-command-keys doesn't give anything
424 ;; meaningful (in that case we don't know what to show to the user).
425 (and (eq ring-var
'vip-command-ring
)
426 (string-match "\\([0-9]*\e\\|^[ \t]*$\\|escape\\)"
427 (vip-array-to-string (this-command-keys))))
428 (vip-ring-insert (eval ring-var
) item
))
432 ;; removing elts from ring seems to break it
433 (defun vip-cleanup-ring (ring)
434 (or (< (ring-length ring
) 2)
435 (null (vip-current-ring-item ring
))
436 ;; last and previous equal
437 (if (equal (vip-current-ring-item ring
) (vip-current-ring-item ring
1))
438 (vip-ring-pop ring
))))
440 ;; ring-remove seems to be buggy, so we concocted this for our purposes.
441 (defun vip-ring-pop (ring)
442 (let* ((ln (ring-length ring
))
443 (vec (cdr (cdr ring
)))
444 (veclen (length vec
))
446 (idx (max 0 (ring-minus1 hd ln
)))
447 (top-elt (aref vec idx
)))
450 (while (< (1+ idx
) veclen
)
451 (aset vec idx
(aref vec
(1+ idx
)))
455 (setq hd
(max 0 (ring-minus1 hd ln
)))
456 (if (= hd
(1- ln
)) (setq hd
0))
457 (setcar ring hd
) ; move head
458 (setcar (cdr ring
) (max 0 (1- ln
))) ; adjust length
462 (defun vip-ring-insert (ring item
)
463 (let* ((ln (ring-length ring
))
464 (vec (cdr (cdr ring
)))
465 (veclen (length vec
))
467 (vecpos-after-hd (if (= hd
0) ln hd
))
472 (aset vec hd item
) ; hd is always 1+ the actual head index in vec
473 (setcar ring
(ring-plus1 hd ln
)))
474 (setcar (cdr ring
) (1+ ln
))
475 (setcar ring
(ring-plus1 vecpos-after-hd
(1+ ln
)))
476 (while (and (>= idx vecpos-after-hd
) (> ln
0))
477 (aset vec idx
(aref vec
(1- idx
)))
479 (aset vec vecpos-after-hd item
))
485 ;; If STRING is longer than MAX-LEN, truncate it and print ...... instead
486 ;; PRE-STRING is a string to prepend to the abbrev string.
487 ;; POST-STRING is a string to append to the abbrev string.
488 ;; ABBREV_SIGN is a string to be inserted before POST-STRING
489 ;; if the orig string was truncated.
490 (defun vip-abbreviate-string (string max-len
491 pre-string post-string abbrev-sign
)
495 (substring string
0 (min max-len
(length string
)))))
496 (cond ((null truncated-str
) "")
497 ((> (length string
) max-len
)
499 pre-string truncated-str abbrev-sign post-string
))
500 (t (format "%s%s%s" pre-string truncated-str post-string
)))))
502 ;; tells if we are over a whitespace-only line
503 (defsubst vip-over-whitespace-line
()
506 (looking-at "^[ \t]*$")))
509 ;;; Saving settings in custom file
511 ;; Save the current setting of VAR in CUSTOM-FILE.
512 ;; If given, MESSAGE is a message to be displayed after that.
513 ;; This message is erased after 2 secs, if erase-msg is non-nil.
514 ;; Arguments: var message custom-file &optional erase-message
515 (defun vip-save-setting (var message custom-file
&optional erase-msg
)
516 (let* ((var-name (symbol-name var
))
517 (var-val (if (boundp var
) (eval var
)))
518 (regexp (format "^[^;]*%s[ \t\n]*[a-zA-Z---_']*[ \t\n)]" var-name
))
519 (buf (find-file-noselect (substitute-in-file-name custom-file
)))
524 (goto-char (point-min))
525 (if (re-search-forward regexp nil t
)
526 (let ((reg-end (1- (match-end 0))))
527 (search-backward var-name
)
528 (delete-region (match-beginning 0) reg-end
)
529 (goto-char (match-beginning 0))
530 (insert (format "%s '%S" var-name var-val
)))
531 (goto-char (point-max))
532 (if (not (bolp)) (insert "\n"))
533 (insert (format "(setq %s '%S)\n" var-name var-val
)))
542 ;; Save STRING in CUSTOM-FILE. If PATTERN is non-nil, remove strings that
543 ;; match this pattern.
544 (defun vip-save-string-in-file (string custom-file
&optional pattern
)
545 (let ((buf (find-file-noselect (substitute-in-file-name custom-file
))))
548 (goto-char (point-min))
549 (if pattern
(delete-matching-lines pattern
))
550 (goto-char (point-max))
551 (if string
(insert string
))
561 (defun vip-flash-search-pattern ()
562 (if (vip-overlay-p vip-search-overlay
)
563 (vip-move-overlay vip-search-overlay
(match-beginning 0) (match-end 0))
564 (setq vip-search-overlay
566 (match-beginning 0) (match-end 0) (current-buffer))))
568 (vip-overlay-put vip-search-overlay
'priority vip-search-overlay-priority
)
569 (if (vip-has-face-support-p)
571 (vip-overlay-put vip-search-overlay
'face vip-search-face
)
573 (vip-overlay-put vip-search-overlay
'face nil
))))
577 (defun vip-set-replace-overlay (beg end
)
578 (if (vip-overlay-p vip-replace-overlay
)
579 (vip-move-replace-overlay beg end
)
580 (setq vip-replace-overlay
(vip-make-overlay beg end
(current-buffer)))
582 vip-replace-overlay
'priority vip-replace-overlay-priority
))
583 (if (vip-has-face-support-p)
584 (vip-overlay-put vip-replace-overlay
'face vip-replace-overlay-face
))
585 (vip-save-cursor-color)
586 (vip-change-cursor-color vip-replace-overlay-cursor-color
)
590 (defsubst vip-hide-replace-overlay
()
591 (vip-set-replace-overlay-glyphs nil nil
)
592 (vip-restore-cursor-color)
593 (if (vip-has-face-support-p)
594 (vip-overlay-put vip-replace-overlay
'face nil
)))
596 (defsubst vip-set-replace-overlay-glyphs
(before-glyph after-glyph
)
597 (if (or (not (vip-has-face-support-p))
598 vip-use-replace-region-delimiters
)
599 (let ((before-name (if vip-xemacs-p
'begin-glyph
'before-string
))
600 (after-name (if vip-xemacs-p
'end-glyph
'after-string
)))
601 (vip-overlay-put vip-replace-overlay before-name before-glyph
)
602 (vip-overlay-put vip-replace-overlay after-name after-glyph
))))
605 (defsubst vip-replace-start
()
606 (vip-overlay-start vip-replace-overlay
))
607 (defsubst vip-replace-end
()
608 (vip-overlay-end vip-replace-overlay
))
610 (defsubst vip-move-replace-overlay
(beg end
)
611 (vip-move-overlay vip-replace-overlay beg end
)
617 (defun vip-set-minibuffer-overlay ()
618 (vip-check-minibuffer-overlay)
619 (if (vip-has-face-support-p)
622 vip-minibuffer-overlay
'face vip-minibuffer-current-face
)
624 vip-minibuffer-overlay
'priority vip-minibuffer-overlay-priority
)
625 ;; prevent detachment and make vip-minibuffer-overlay open-ended
626 ;; In emacs, it is made open ended at creation time
628 (vip-overlay-put vip-minibuffer-overlay
'evaporate nil
)
629 (vip-overlay-put vip-minibuffer-overlay
'detachable nil
)
630 (vip-overlay-put vip-minibuffer-overlay
'start-open nil
)
631 (vip-overlay-put vip-minibuffer-overlay
'end-open nil
))
634 (defun vip-check-minibuffer-overlay ()
635 (or (vip-overlay-p vip-minibuffer-overlay
)
636 (setq vip-minibuffer-overlay
638 (vip-make-overlay 1 (1+ (buffer-size)) (current-buffer))
639 ;; don't move front, move rear
640 (vip-make-overlay 1 (1+ (buffer-size)) (current-buffer) nil t
)))
644 (defsubst vip-is-in-minibuffer
()
645 (string-match "\*Minibuf-" (buffer-name)))
649 ;;; XEmacs compatibility
651 (defun vip-abbreviate-file-name (file)
653 (abbreviate-file-name file
)
654 ;; XEmacs requires addl argument
655 (abbreviate-file-name file t
)))
657 ;; Sit for VAL milliseconds. XEmacs doesn't support the millisecond arg
658 ;; in sit-for, so this function smoothes out the differences.
659 (defsubst vip-sit-for-short
(val &optional nodisp
)
661 (sit-for (/ val
1000.0) nodisp
)
662 (sit-for 0 val nodisp
)))
664 ;; EVENT may be a single event of a sequence of events
665 (defsubst vip-ESC-event-p
(event)
666 (let ((ESC-keys '(?\e
(control \
[) escape
))
667 (key (vip-event-key event
)))
668 (member key ESC-keys
)))
670 ;; like (set-mark-command nil) but doesn't push twice, if (car mark-ring)
671 ;; is the same as (mark t).
672 (defsubst vip-set-mark-if-necessary
()
673 (setq mark-ring
(delete (vip-mark-marker) mark-ring
))
674 (set-mark-command nil
))
676 (defsubst vip-mark-marker
()
681 ;; In transient mark mode (zmacs mode), it is annoying when regions become
682 ;; highlighted due to Viper's pushing marks. So, we deactivate marks, unless
683 ;; the user explicitly wants highlighting, e.g., by hitting '' or ``
684 (defun vip-deactivate-mark ()
686 (zmacs-deactivate-region)
689 (defsubst vip-leave-region-active
()
691 (setq zmacs-region-stays t
)))
694 (defsubst vip-events-to-keys
(events)
695 (cond (vip-xemacs-p (events-to-keys events
))
699 (defun vip-eval-after-load (file form
)
701 (eval-after-load file form
)
702 (or (assoc file after-load-alist
)
703 (setq after-load-alist
(cons (list file
) after-load-alist
)))
704 (let ((elt (assoc file after-load-alist
)))
705 (or (member form
(cdr elt
))
706 (setq elt
(nconc elt
(list form
)))))
710 ;; This is here because Emacs changed the way local hooks work.
712 ;;Add to the value of HOOK the function FUNCTION.
713 ;;FUNCTION is not added if already present.
714 ;;FUNCTION is added (if necessary) at the beginning of the hook list
715 ;;unless the optional argument APPEND is non-nil, in which case
716 ;;FUNCTION is added at the end.
718 ;;HOOK should be a symbol, and FUNCTION may be any valid function. If
719 ;;HOOK is void, it is first set to nil. If HOOK's value is a single
720 ;;function, it is changed to a list of functions."
721 (defun vip-add-hook (hook function
&optional append
)
722 (if (not (boundp hook
)) (set hook nil
))
723 ;; If the hook value is a single function, turn it into a list.
724 (let ((old (symbol-value hook
)))
725 (if (or (not (listp old
)) (eq (car old
) 'lambda
))
726 (setq old
(list old
)))
727 (if (member function old
)
730 (append old
(list function
)) ; don't nconc
731 (cons function old
))))))
733 ;; This is here because of Emacs's changes in the semantics of add/remove-hooks
734 ;; and due to the bugs they introduced.
736 ;; Remove from the value of HOOK the function FUNCTION.
737 ;; HOOK should be a symbol, and FUNCTION may be any valid function. If
738 ;; FUNCTION isn't the value of HOOK, or, if FUNCTION doesn't appear in the
739 ;; list of hooks to run in HOOK, then nothing is done. See `vip-add-hook'."
740 (defun vip-remove-hook (hook function
)
741 (if (or (not (boundp hook
)) ;unbound symbol, or
742 (null (symbol-value hook
)) ;value is nil, or
743 (null function
)) ;function is nil, then
745 (let ((hook-value (symbol-value hook
)))
746 (if (consp hook-value
)
747 ;; don't side-effect the list
748 (setq hook-value
(delete function
(copy-sequence hook-value
)))
749 (if (equal hook-value function
)
750 (setq hook-value nil
)))
751 (set hook hook-value
))))
755 ;; like read-event, but in XEmacs also try to convert to char, if possible
756 (defun vip-read-event-convert-to-char ()
760 (setq event
(next-command-event))
761 (or (event-to-character event
)
765 ;; This function lets function-key-map convert key sequences into logical
766 ;; keys. This does a better job than vip-read-event when it comes to kbd
767 ;; macros, since it enables certain macros to be shared between X and TTY
769 (defun vip-read-key ()
770 (let ((overriding-local-map vip-overriding-map
)
772 (use-global-map vip-overriding-map
)
773 (setq key
(elt (read-key-sequence nil
) 0))
774 (use-global-map global-map
)
778 ;; Emacs has a bug in eventp, which causes (eventp nil) to return (nil)
779 ;; instead of nil, if '(nil) was previously inadvertently assigned to
780 ;; unread-command-events
781 (defun vip-event-key (event)
782 (or (and event
(eventp event
))
783 (error "vip-event-key: Wrong type argument, eventp, %S" event
))
784 (let ((mod (event-modifiers event
))
789 (cond ((key-press-event-p event
)
791 ((button-event-p event
)
792 (concat "mouse-" (prin1-to-string (event-button event
))))
794 (error "vip-event-key: Unknown event, %S" event
))))
796 ;; Emacs doesn't handle capital letters correctly, since
797 ;; \S-a isn't considered the same as A (it behaves as
798 ;; plain `a' instead). So we take care of this here
799 (cond ((and (numberp event
) (<= ?A event
) (<= event ?Z
))
802 ;; Emacs has the oddity whereby characters 128+char
803 ;; represent M-char *if* this appears inside a string.
804 ;; So, we convert them manually to (meta char).
805 ((and (numberp event
) (< ?\C-? event
) (<= event
255))
807 event
(- event ?\C-?
1)))
808 (t (event-basic-type event
)))
813 (list 'control
'\?) ; taking care of an emacs bug
814 (intern (char-to-string basis
)))))
816 (append mod
(list basis
))
819 (defun vip-key-to-emacs-key (key)
820 (let (key-name char-p modifiers mod-char-list base-key base-key-name
)
821 (cond (vip-xemacs-p key
)
823 (setq key-name
(symbol-name key
))
824 (if (= (length key-name
) 1) ; character event
825 (string-to-char key-name
)
828 (setq modifiers
(subseq key
0 (1- (length key
)))
829 base-key
(vip-seq-last-elt key
)
830 base-key-name
(symbol-name base-key
)
831 char-p
(= (length base-key-name
) 1))
834 '(lambda (elt) (upcase (substring (symbol-name elt
) 0 1)))
838 (car (read-from-string
841 (mapconcat 'identity mod-char-list
"-\\")
847 (mapconcat 'identity mod-char-list
"-")
853 ;; Args can be a sequence of events, a string, or a Viper macro. Will try to
854 ;; convert events to keys and, if all keys are regular printable
855 ;; characters, will return a string. Otherwise, will return a string
856 ;; representing a vector of converted events. If the input was a Viper macro,
857 ;; will return a string that represents this macro as a vector.
858 (defun vip-array-to-string (event-seq &optional representation
)
860 (cond ((stringp event-seq
) event-seq
)
861 ((vip-event-vector-p event-seq
)
862 (setq temp
(mapcar 'vip-event-key event-seq
))
863 (if (vip-char-symbol-sequence-p temp
)
864 (mapconcat 'symbol-name temp
"")
865 (prin1-to-string (vconcat temp
))))
866 ((vip-char-symbol-sequence-p event-seq
)
867 (mapconcat 'symbol-name event-seq
""))
868 (t (prin1-to-string event-seq
)))))
870 (defun vip-key-press-events-to-chars (events)
871 (mapconcat (if vip-emacs-p
874 (lambda (elt) (char-to-string (event-to-character elt
)))))
879 (defsubst vip-fast-keysequence-p
()
880 (not (vip-sit-for-short vip-fast-keyseq-timeout t
)))
882 (defun vip-read-char-exclusive ()
887 (setq char
(read-char))
889 ;; skip event if not char
895 (defun vip-setup-master-buffer (&rest other-files-or-buffers
)
896 "Set up the current buffer as a master buffer.
897 Arguments become related buffers. This function should normally be used in
898 the `Local variables' section of a file."
899 (setq vip-related-files-and-buffers-ring
900 (make-ring (1+ (length other-files-or-buffers
))))
901 (mapcar '(lambda (elt)
902 (vip-ring-insert vip-related-files-and-buffers-ring elt
))
903 other-files-or-buffers
)
904 (vip-ring-insert vip-related-files-and-buffers-ring
(buffer-name))
907 ;;; Movement utilities
909 (defvar vip-syntax-preference
'strict-vi
910 "*Syntax type characterizing Viper's alphanumeric symbols.
911 `emacs' means only word constituents are considered to be alphanumeric.
912 Word constituents are symbols specified as word constituents by the current
914 `extended' means word and symbol constituents.
915 `reformed-vi' means Vi-ish behavior: word constituents and the symbol `_'.
916 However, word constituents are determined according to Emacs syntax tables,
917 which may be different from Vi in some major modes.
918 `strict-vi' means Viper words are exactly as in Vi.")
920 (vip-deflocalvar vip-ALPHA-char-class
"w"
921 "String of syntax classes characterizing Viper's alphanumeric symbols.
922 In addition, the symbol `_' may be considered alphanumeric if
923 `vip-syntax-preference'is `reformed-vi'.")
925 (vip-deflocalvar vip-strict-ALPHA-chars
"a-zA-Z0-9_"
926 "Regexp matching the set of alphanumeric characters acceptable to strict
928 (vip-deflocalvar vip-strict-SEP-chars
" \t\n"
929 "Regexp matching the set of alphanumeric characters acceptable to strict
932 (vip-deflocalvar vip-SEP-char-class
" -"
933 "String of syntax classes for Vi separators.
934 Usually contains ` ', linefeed, TAB or formfeed.")
936 (defun vip-update-alphanumeric-class ()
937 "Set the syntactic class of Viper alphanumeric symbols according to
938 the variable `vip-ALPHA-char-class'. Should be called in order for changes to
939 `vip-ALPHA-char-class' to take effect."
943 (cond ((eq vip-syntax-preference
'emacs
) "w") ; only word constituents
944 ((eq vip-syntax-preference
'extended
) "w_") ; word & symbol chars
945 (t "w")))) ; vi syntax: word constituents and the symbol `_'
947 ;; addl-chars are characters to be temporarily considered as alphanumerical
948 (defun vip-looking-at-alpha (&optional addl-chars
)
949 (or (stringp addl-chars
) (setq addl-chars
""))
950 (if (eq vip-syntax-preference
'reformed-vi
)
951 (setq addl-chars
(concat addl-chars
"_")))
952 (let ((char (char-after (point))))
954 (if (eq vip-syntax-preference
'strict-vi
)
955 (looking-at (concat "[" vip-strict-ALPHA-chars addl-chars
"]"))
957 ;; convert string to list
958 (append (vconcat addl-chars
) nil
))
959 (memq (char-syntax char
)
960 (append (vconcat vip-ALPHA-char-class
) nil
)))))
963 (defsubst vip-looking-at-separator
()
964 (let ((char (char-after (point))))
966 (or (eq char ?
\n) ; RET is always a separator in Vi
967 (memq (char-syntax char
)
968 (append (vconcat vip-SEP-char-class
) nil
))))))
970 (defsubst vip-looking-at-alphasep
(&optional addl-chars
)
971 (or (vip-looking-at-separator) (vip-looking-at-alpha addl-chars
)))
973 (defsubst vip-skip-alpha-forward
(&optional addl-chars
)
974 (or (stringp addl-chars
) (setq addl-chars
""))
977 (cond ((eq vip-syntax-preference
'strict-vi
)
979 (t vip-ALPHA-char-class
))
980 (cond ((eq vip-syntax-preference
'strict-vi
)
981 (concat vip-strict-ALPHA-chars addl-chars
))
984 (defsubst vip-skip-alpha-backward
(&optional addl-chars
)
985 (or (stringp addl-chars
) (setq addl-chars
""))
988 (cond ((eq vip-syntax-preference
'strict-vi
)
990 (t vip-ALPHA-char-class
))
991 (cond ((eq vip-syntax-preference
'strict-vi
)
992 (concat vip-strict-ALPHA-chars addl-chars
))
995 ;; weird syntax tables may confuse strict-vi style
996 (defsubst vip-skip-all-separators-forward
(&optional within-line
)
997 (vip-skip-syntax 'forward
999 (or within-line
"\n")
1000 (if within-line
(vip-line-pos 'end
))))
1001 (defsubst vip-skip-all-separators-backward
(&optional within-line
)
1002 (vip-skip-syntax 'backward
1004 (or within-line
"\n")
1005 (if within-line
(vip-line-pos 'start
))))
1006 (defun vip-skip-nonseparators (direction)
1007 (let ((func (intern (format "skip-syntax-%S" direction
))))
1008 (funcall func
(concat "^" vip-SEP-char-class
)
1009 (vip-line-pos (if (eq direction
'forward
) 'end
'start
)))))
1011 (defsubst vip-skip-nonalphasep-forward
()
1012 (if (eq vip-syntax-preference
'strict-vi
)
1014 (concat "^" vip-strict-SEP-chars vip-strict-ALPHA-chars
))
1015 (skip-syntax-forward
1017 "^" vip-ALPHA-char-class vip-SEP-char-class
) (vip-line-pos 'end
))))
1018 (defsubst vip-skip-nonalphasep-backward
()
1019 (if (eq vip-syntax-preference
'strict-vi
)
1020 (skip-chars-backward
1021 (concat "^" vip-strict-SEP-chars vip-strict-ALPHA-chars
))
1022 (skip-syntax-backward
1024 "^" vip-ALPHA-char-class vip-SEP-char-class
) (vip-line-pos 'start
))))
1026 ;; Skip SYNTAX like skip-syntax-* and ADDL-CHARS like skip-chars-*
1027 ;; Return the number of chars traveled.
1028 ;; Either SYNTAX or ADDL-CHARS can be nil, in which case they are interpreted
1029 ;; as an empty string.
1030 (defun vip-skip-syntax (direction syntax addl-chars
&optional limit
)
1033 (skip-chars-func (intern (format "skip-chars-%S" direction
)))
1034 (skip-syntax-func (intern (format "skip-syntax-%S" direction
))))
1035 (or (stringp addl-chars
) (setq addl-chars
""))
1036 (or (stringp syntax
) (setq syntax
""))
1037 (while (and (not (= local
0)) (not (eobp)))
1039 (+ (funcall skip-syntax-func syntax limit
)
1040 (funcall skip-chars-func addl-chars limit
)))
1041 (setq total
(+ total local
)))
1048 (provide 'viper-util
)
1050 ;;; viper-util.el ends here