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 (defsubst vip-window-display-p
()
35 (and (vip-device-type) (not (memq (vip-device-type) '(tty stream
)))))
40 (defmacro vip-deflocalvar
(var default-value
&optional documentation
)
42 (defvar (, var
) (, default-value
)
43 (, (format "%s\n\(buffer local\)" documentation
)))
44 (make-variable-buffer-local '(, var
))
47 (defmacro vip-loop
(count body
)
48 "(vip-loop COUNT BODY) Execute BODY COUNT times."
49 (list 'let
(list (list 'count count
))
50 (list 'while
'(> count
0)
52 '(setq count
(1- count
))
55 (defmacro vip-buffer-live-p
(buf)
56 (` (and (, buf
) (get-buffer (, buf
)) (buffer-name (get-buffer (, buf
))))))
58 ;; return buffer-specific macro definition, given a full macro definition
59 (defmacro vip-kbd-buf-alist
(macro-elt)
60 (` (nth 1 (, macro-elt
))))
61 ;; get a pair: (curr-buffer . macro-definition)
62 (defmacro vip-kbd-buf-pair
(macro-elt)
63 (` (assoc (buffer-name) (vip-kbd-buf-alist (, macro-elt
)))))
64 ;; get macro definition for current buffer
65 (defmacro vip-kbd-buf-definition
(macro-elt)
66 (` (cdr (vip-kbd-buf-pair (, macro-elt
)))))
68 ;; return mode-specific macro definitions, given a full macro definition
69 (defmacro vip-kbd-mode-alist
(macro-elt)
70 (` (nth 2 (, macro-elt
))))
71 ;; get a pair: (major-mode . macro-definition)
72 (defmacro vip-kbd-mode-pair
(macro-elt)
73 (` (assoc major-mode
(vip-kbd-mode-alist (, macro-elt
)))))
74 ;; get macro definition for the current major mode
75 (defmacro vip-kbd-mode-definition
(macro-elt)
76 (` (cdr (vip-kbd-mode-pair (, macro-elt
)))))
78 ;; return global macro definition, given a full macro definition
79 (defmacro vip-kbd-global-pair
(macro-elt)
80 (` (nth 3 (, macro-elt
))))
81 ;; get global macro definition from an elt of macro-alist
82 (defmacro vip-kbd-global-definition
(macro-elt)
83 (` (cdr (vip-kbd-global-pair (, macro-elt
)))))
85 ;; last elt of a sequence
86 (defsubst vip-seq-last-elt
(seq)
87 (elt seq
(1- (length seq
))))
89 ;; Check if arg is a valid character for register
90 ;; TYPE is a list that can contain `letter', `Letter', and `digit'.
91 ;; Letter means lowercase letters, Letter means uppercase letters, and
92 ;; digit means digits from 1 to 9.
93 ;; If TYPE is nil, then down/uppercase letters and digits are allowed.
94 (defun vip-valid-register (reg &optional type
)
95 (or type
(setq type
'(letter Letter digit
)))
96 (or (if (memq 'letter type
)
97 (and (<= ?a reg
) (<= reg ?z
)))
98 (if (memq 'digit type
)
99 (and (<= ?
1 reg
) (<= reg ?
9)))
100 (if (memq 'Letter type
)
101 (and (<= ?A reg
) (<= reg ?Z
)))
104 ;; checks if object is a marker, has a buffer, and points to within that buffer
105 (defun vip-valid-marker (marker)
106 (if (and (markerp marker
) (marker-buffer marker
))
107 (let ((buf (marker-buffer marker
))
108 (pos (marker-position marker
)))
111 (and (<= pos
(point-max)) (<= (point-min) pos
))))))
114 (defvar vip-minibuffer-overlay-priority
300)
115 (defvar vip-replace-overlay-priority
400)
116 (defvar vip-search-overlay-priority
500)
123 (fset 'vip-read-event
(symbol-function 'next-command-event
))
124 (fset 'vip-make-overlay
(symbol-function 'make-extent
))
125 (fset 'vip-overlay-start
(symbol-function 'extent-start-position
))
126 (fset 'vip-overlay-end
(symbol-function 'extent-end-position
))
127 (fset 'vip-overlay-put
(symbol-function 'set-extent-property
))
128 (fset 'vip-overlay-p
(symbol-function 'extentp
))
129 (fset 'vip-overlay-get
(symbol-function 'extent-property
))
130 (fset 'vip-move-overlay
(symbol-function 'set-extent-endpoints
))
131 (if (vip-window-display-p)
132 (fset 'vip-iconify
(symbol-function 'iconify-frame
)))
133 (cond ((vip-window-display-p)
134 (fset 'vip-get-face
(symbol-function 'get-face
))
135 (fset 'vip-color-defined-p
136 (symbol-function 'valid-color-name-p
))
138 (fset 'vip-read-event
(symbol-function 'read-event
))
139 (fset 'vip-make-overlay
(symbol-function 'make-overlay
))
140 (fset 'vip-overlay-start
(symbol-function 'overlay-start
))
141 (fset 'vip-overlay-end
(symbol-function 'overlay-end
))
142 (fset 'vip-overlay-put
(symbol-function 'overlay-put
))
143 (fset 'vip-overlay-p
(symbol-function 'overlayp
))
144 (fset 'vip-overlay-get
(symbol-function 'overlay-get
))
145 (fset 'vip-move-overlay
(symbol-function 'move-overlay
))
146 (if (vip-window-display-p)
147 (fset 'vip-iconify
(symbol-function 'iconify-or-deiconify-frame
)))
148 (cond ((vip-window-display-p)
149 (fset 'vip-get-face
(symbol-function 'internal-get-face
))
150 (fset 'vip-color-defined-p
(symbol-function 'x-color-defined-p
))
153 (defsubst vip-color-display-p
()
156 (eq (device-class (selected-device)) 'color
)))
159 (cond ((eq (vip-device-type) 'pm
)
160 (fset 'vip-color-defined-p
161 (function (lambda (color) (assoc color pm-color-alist
))))))
163 ;; needed to smooth out the difference between Emacs and XEmacs
164 (defsubst vip-italicize-face
(face)
166 (make-face-italic face
)
167 (make-face-italic face nil
'noerror
)))
169 ;; test if display is color and the colors are defined
170 (defsubst vip-can-use-colors
(&rest colors
)
171 (if (vip-color-display-p)
172 (not (memq nil
(mapcar 'vip-color-defined-p colors
)))
175 (defun vip-hide-face (face)
176 (if (and (vip-window-display-p) vip-emacs-p
)
177 (add-to-list 'facemenu-unlisted-faces face
)))
180 (defun vip-change-cursor-color (new-color)
181 (if (and (vip-window-display-p) (vip-color-display-p)
182 (stringp new-color
) (vip-color-defined-p new-color
)
183 (not (string= new-color
(vip-get-cursor-color))))
184 (modify-frame-parameters
185 (selected-frame) (list (cons 'cursor-color new-color
)))))
187 (defsubst vip-save-cursor-color
()
188 (if (and (vip-window-display-p) (vip-color-display-p))
189 (let ((color (vip-get-cursor-color)))
190 (if (and (stringp color
) (vip-color-defined-p color
)
191 (not (string= color vip-replace-overlay-cursor-color
)))
192 (vip-overlay-put vip-replace-overlay
'vip-cursor-color color
)))))
194 (defsubst vip-restore-cursor-color
()
195 (vip-change-cursor-color
196 (vip-overlay-get vip-replace-overlay
'vip-cursor-color
)))
198 (defsubst vip-get-cursor-color
()
199 (cdr (assoc 'cursor-color
(frame-parameters))))
202 ;; Check the current version against the major and minor version numbers
203 ;; using op: cur-vers op major.minor If emacs-major-version or
204 ;; emacs-minor-version are not defined, we assume that the current version
205 ;; is hopelessly outdated. We assume that emacs-major-version and
206 ;; emacs-minor-version are defined. Otherwise, for Emacs/XEmacs 19, if the
207 ;; current minor version is < 10 (xemacs) or < 23 (emacs) the return value
208 ;; will be nil (when op is =, >, or >=) and t (when op is <, <=), which may be
209 ;; incorrect. However, this gives correct result in our cases, since we are
210 ;; testing for sufficiently high Emacs versions.
211 (defun vip-check-version (op major minor
&optional type-of-emacs
)
212 (if (and (boundp 'emacs-major-version
) (boundp 'emacs-minor-version
))
213 (and (cond ((eq type-of-emacs
'xemacs
) vip-xemacs-p
)
214 ((eq type-of-emacs
'emacs
) vip-emacs-p
)
216 (cond ((eq op
'=) (and (= emacs-minor-version minor
)
217 (= emacs-major-version major
)))
218 ((memq op
'(> >= < <=))
219 (and (or (funcall op emacs-major-version major
)
220 (= emacs-major-version major
))
221 (if (= emacs-major-version major
)
222 (funcall op emacs-minor-version minor
)
225 (error "%S: Invalid op in vip-check-version" op
))))
226 (cond ((memq op
'(= > >=)) nil
)
227 ((memq op
'(< <=)) t
))))
229 ;;;; warn if it is a wrong version of emacs
230 ;;(if (or (vip-check-version '< 19 29 'emacs)
231 ;; (vip-check-version '< 19 12 'xemacs))
233 ;; (with-output-to-temp-buffer " *vip-info*"
234 ;; (switch-to-buffer " *vip-info*")
238 ;;This version of Viper requires
240 ;;\t Emacs 19.29 and higher
242 ;;\t XEmacs 19.12 and higher
244 ;;It is unlikely to work under Emacs version %s
245 ;;that you are using... " emacs-version))
247 ;; (if noninteractive
251 ;; (insert "\n\nType any key to continue... ")
252 ;; (vip-read-event)))
253 ;; (kill-buffer " *vip-info*")))
256 (defun vip-get-visible-buffer-window (wind)
258 (get-buffer-window wind t
)
259 (get-buffer-window wind
'visible
)))
262 ;; Return line position.
263 ;; If pos is 'start then returns position of line start.
264 ;; If pos is 'end, returns line end. If pos is 'mid, returns line center.
265 ;; Pos = 'indent returns beginning of indentation.
266 ;; Otherwise, returns point. Current point is not moved in any case."
267 (defun vip-line-pos (pos)
268 (let ((cur-pos (point))
276 (goto-char (+ (vip-line-pos 'start
) (vip-line-pos 'end
) 2)))
278 (back-to-indentation))
280 (setq result
(point))
285 ;; Like move-marker but creates a virgin marker if arg isn't already a marker.
286 ;; The first argument must eval to a variable name.
287 ;; Arguments: (var-name position &optional buffer).
289 ;; This is useful for moving markers that are supposed to be local.
290 ;; For this, VAR-NAME should be made buffer-local with nil as a default.
291 ;; Then, each time this var is used in `vip-move-marker-locally' in a new
292 ;; buffer, a new marker will be created.
293 (defun vip-move-marker-locally (var pos
&optional buffer
)
294 (if (markerp (eval var
))
296 (set var
(make-marker)))
297 (move-marker (eval var
) pos buffer
))
300 ;; Print CONDITIONS as a message.
301 (defun vip-message-conditions (conditions)
302 (let ((case (car conditions
)) (msg (cdr conditions
)))
305 (message "%s: %s" case
(mapconcat 'prin1-to-string msg
" ")))
310 ;;; List/alist utilities
312 ;; Convert LIST to an alist
313 (defun vip-list-to-alist (lst)
316 (setq alist
(cons (list (car lst
)) alist
))
317 (setq lst
(cdr lst
)))
320 ;; Convert ALIST to a list.
321 (defun vip-alist-to-list (alst)
324 (setq lst
(cons (car (car alst
)) lst
))
325 (setq alst
(cdr alst
)))
328 ;; Filter ALIST using REGEXP. Return alist whose elements match the regexp.
329 (defun vip-filter-alist (regexp alst
)
331 (let ((outalst) (inalst alst
))
333 (if (string-match regexp
(car (car inalst
)))
334 (setq outalst
(cons (car inalst
) outalst
)))
335 (setq inalst
(cdr inalst
)))
338 ;; Filter LIST using REGEXP. Return list whose elements match the regexp.
339 (defun vip-filter-list (regexp lst
)
341 (let ((outlst) (inlst lst
))
343 (if (string-match regexp
(car inlst
))
344 (setq outlst
(cons (car inlst
) outlst
)))
345 (setq inlst
(cdr inlst
)))
349 ;; Append LIS2 to LIS1, both alists, by side-effect and returns LIS1
350 ;; LIS2 is modified by filtering it: deleting its members of the form
351 ;; \(car elt\) such that (car elt') is in LIS1.
352 (defun vip-append-filter-alist (lis1 lis2
)
356 ;;filter-append the second list
358 ;; delete all occurrences
359 (while (setq elt
(assoc (car (car temp
)) lis2
))
360 (setq lis2
(delq elt lis2
)))
361 (setq temp
(cdr temp
)))
370 ;; Rotate RING's index. DIRection can be positive or negative.
371 (defun vip-ring-rotate1 (ring dir
)
372 (if (and (ring-p ring
) (> (ring-length ring
) 0))
374 (setcar ring
(cond ((> dir
0)
375 (ring-plus1 (car ring
) (ring-length ring
)))
377 (ring-minus1 (car ring
) (ring-length ring
)))
378 ;; don't rotate if dir = 0
380 (vip-current-ring-item ring
)
383 (defun vip-special-ring-rotate1 (ring dir
)
384 (if (memq vip-intermediate-command
385 '(repeating-display-destructive-command
386 repeating-insertion-from-ring
))
387 (vip-ring-rotate1 ring dir
)
388 ;; don't rotate otherwise
389 (vip-ring-rotate1 ring
0)))
391 ;; current ring item; if N is given, then so many items back from the
393 (defun vip-current-ring-item (ring &optional n
)
395 (if (and (ring-p ring
) (> (ring-length ring
) 0))
396 (aref (cdr (cdr ring
)) (mod (- (car ring
) 1 n
) (ring-length ring
)))))
398 ;; push item onto ring. the second argument is a ring-variable, not value.
399 (defun vip-push-onto-ring (item ring-var
)
400 (or (ring-p (eval ring-var
))
401 (set ring-var
(make-ring (eval (intern (format "%S-size" ring-var
))))))
402 (or (null item
) ; don't push nil
403 (and (stringp item
) (string= item
"")) ; or empty strings
404 (equal item
(vip-current-ring-item (eval ring-var
))) ; or old stuff
405 ;; Since vip-set-destructive-command checks if we are inside vip-repeat,
406 ;; we don't check whether this-command-keys is a `.'.
407 ;; The cmd vip-repeat makes a call to the current function only if
408 ;; `.' is executing a command from the command history. It doesn't
409 ;; call the push-onto-ring function if `.' is simply repeating the
410 ;; last destructive command.
411 ;; We only check for ESC (which happens when we do insert with a
412 ;; prefix argument, or if this-command-keys doesn't give anything
413 ;; meaningful (in that case we don't know what to show to the user).
414 (and (eq ring-var
'vip-command-ring
)
415 (string-match "\\([0-9]*\e\\|^[ \t]*$\\|escape\\)"
416 (vip-array-to-string (this-command-keys))))
417 (vip-ring-insert (eval ring-var
) item
))
421 ;; removing elts from ring seems to break it
422 (defun vip-cleanup-ring (ring)
423 (or (< (ring-length ring
) 2)
424 (null (vip-current-ring-item ring
))
425 ;; last and previous equal
426 (if (equal (vip-current-ring-item ring
) (vip-current-ring-item ring
1))
427 (vip-ring-pop ring
))))
429 ;; ring-remove seems to be buggy, so we concocted this for our purposes.
430 (defun vip-ring-pop (ring)
431 (let* ((ln (ring-length ring
))
432 (vec (cdr (cdr ring
)))
433 (veclen (length vec
))
435 (idx (max 0 (ring-minus1 hd ln
)))
436 (top-elt (aref vec idx
)))
439 (while (< (1+ idx
) veclen
)
440 (aset vec idx
(aref vec
(1+ idx
)))
444 (setq hd
(max 0 (ring-minus1 hd ln
)))
445 (if (= hd
(1- ln
)) (setq hd
0))
446 (setcar ring hd
) ; move head
447 (setcar (cdr ring
) (max 0 (1- ln
))) ; adjust length
451 (defun vip-ring-insert (ring item
)
452 (let* ((ln (ring-length ring
))
453 (vec (cdr (cdr ring
)))
454 (veclen (length vec
))
456 (vecpos-after-hd (if (= hd
0) ln hd
))
461 (aset vec hd item
) ; hd is always 1+ the actual head index in vec
462 (setcar ring
(ring-plus1 hd ln
)))
463 (setcar (cdr ring
) (1+ ln
))
464 (setcar ring
(ring-plus1 vecpos-after-hd
(1+ ln
)))
465 (while (and (>= idx vecpos-after-hd
) (> ln
0))
466 (aset vec idx
(aref vec
(1- idx
)))
468 (aset vec vecpos-after-hd item
))
474 ;; If STRING is longer than MAX-LEN, truncate it and print ...... instead
475 ;; PRE-STRING is a string to prepend to the abbrev string.
476 ;; POST-STRING is a string to append to the abbrev string.
477 ;; ABBREV_SIGN is a string to be inserted before POST-STRING
478 ;; if the orig string was truncated.
479 (defun vip-abbreviate-string (string max-len
480 pre-string post-string abbrev-sign
)
484 (substring string
0 (min max-len
(length string
)))))
485 (cond ((null truncated-str
) "")
486 ((> (length string
) max-len
)
488 pre-string truncated-str abbrev-sign post-string
))
489 (t (format "%s%s%s" pre-string truncated-str post-string
)))))
491 ;; tells if we are over a whitespace-only line
492 (defsubst vip-over-whitespace-line
()
495 (looking-at "^[ \t]*$")))
498 ;;; Saving settings in custom file
500 ;; Save the current setting of VAR in CUSTOM-FILE.
501 ;; If given, MESSAGE is a message to be displayed after that.
502 ;; This message is erased after 2 secs, if erase-msg is non-nil.
503 ;; Arguments: var message custom-file &optional erase-message
504 (defun vip-save-setting (var message custom-file
&optional erase-msg
)
505 (let* ((var-name (symbol-name var
))
506 (var-val (if (boundp var
) (eval var
)))
507 (regexp (format "^[^;]*%s[ \t\n]*[a-zA-Z---_']*[ \t\n)]" var-name
))
508 (buf (find-file-noselect (substitute-in-file-name custom-file
)))
513 (goto-char (point-min))
514 (if (re-search-forward regexp nil t
)
515 (let ((reg-end (1- (match-end 0))))
516 (search-backward var-name
)
517 (delete-region (match-beginning 0) reg-end
)
518 (goto-char (match-beginning 0))
519 (insert (format "%s '%S" var-name var-val
)))
520 (goto-char (point-max))
521 (if (not (bolp)) (insert "\n"))
522 (insert (format "(setq %s '%S)\n" var-name var-val
)))
531 ;; Save STRING in CUSTOM-FILE. If PATTERN is non-nil, remove strings that
532 ;; match this pattern.
533 (defun vip-save-string-in-file (string custom-file
&optional pattern
)
534 (let ((buf (find-file-noselect (substitute-in-file-name custom-file
))))
537 (goto-char (point-min))
538 (if pattern
(delete-matching-lines pattern
))
539 (goto-char (point-max))
540 (if string
(insert string
))
550 (defun vip-flash-search-pattern ()
551 (if (vip-overlay-p vip-search-overlay
)
552 (vip-move-overlay vip-search-overlay
(match-beginning 0) (match-end 0))
553 (setq vip-search-overlay
555 (match-beginning 0) (match-end 0) (current-buffer))))
557 (vip-overlay-put vip-search-overlay
'priority vip-search-overlay-priority
)
558 (if (vip-window-display-p)
560 (vip-overlay-put vip-search-overlay
'face vip-search-face
)
562 (vip-overlay-put vip-search-overlay
'face nil
))))
566 (defun vip-set-replace-overlay (beg end
)
567 (if (vip-overlay-p vip-replace-overlay
)
568 (vip-move-replace-overlay beg end
)
569 (setq vip-replace-overlay
(vip-make-overlay beg end
(current-buffer)))
571 vip-replace-overlay
'priority vip-replace-overlay-priority
))
572 (if (vip-window-display-p)
573 (vip-overlay-put vip-replace-overlay
'face vip-replace-overlay-face
))
574 (vip-save-cursor-color)
575 (vip-change-cursor-color vip-replace-overlay-cursor-color
)
579 (defsubst vip-hide-replace-overlay
()
580 (vip-set-replace-overlay-glyphs nil nil
)
581 (vip-restore-cursor-color)
582 (if (vip-window-display-p)
583 (vip-overlay-put vip-replace-overlay
'face nil
)))
585 (defsubst vip-set-replace-overlay-glyphs
(before-glyph after-glyph
)
586 (if (or (not (vip-window-display-p))
587 vip-use-replace-region-delimiters
)
588 (let ((before-name (if vip-xemacs-p
'begin-glyph
'before-string
))
589 (after-name (if vip-xemacs-p
'end-glyph
'after-string
)))
590 (vip-overlay-put vip-replace-overlay before-name before-glyph
)
591 (vip-overlay-put vip-replace-overlay after-name after-glyph
))))
594 (defsubst vip-replace-start
()
595 (vip-overlay-start vip-replace-overlay
))
596 (defsubst vip-replace-end
()
597 (vip-overlay-end vip-replace-overlay
))
599 (defsubst vip-move-replace-overlay
(beg end
)
600 (vip-move-overlay vip-replace-overlay beg end
)
606 (defun vip-set-minibuffer-overlay ()
607 (vip-check-minibuffer-overlay)
608 (if (vip-window-display-p)
611 vip-minibuffer-overlay
'face vip-minibuffer-current-face
)
613 vip-minibuffer-overlay
'priority vip-minibuffer-overlay-priority
)
614 ;; prevent detachment and make vip-minibuffer-overlay open-ended
615 ;; In emacs, it is made open ended at creation time
617 (vip-overlay-put vip-minibuffer-overlay
'evaporate nil
)
618 (vip-overlay-put vip-minibuffer-overlay
'detachable nil
)
619 (vip-overlay-put vip-minibuffer-overlay
'start-open nil
)
620 (vip-overlay-put vip-minibuffer-overlay
'end-open nil
))
623 (defun vip-check-minibuffer-overlay ()
624 (or (vip-overlay-p vip-minibuffer-overlay
)
625 (setq vip-minibuffer-overlay
627 (vip-make-overlay 1 (1+ (buffer-size)) (current-buffer))
628 ;; don't move front, move rear
629 (vip-make-overlay 1 (1+ (buffer-size)) (current-buffer) nil t
)))
633 (defsubst vip-is-in-minibuffer
()
634 (string-match "\*Minibuf-" (buffer-name)))
638 ;;; XEmacs compatibility
640 ;; Sit for VAL milliseconds. XEmacs doesn't support the millisecond arg
641 ;; in sit-for, so this function smoothes out the differences.
642 (defsubst vip-sit-for-short
(val &optional nodisp
)
644 (sit-for (/ val
1000.0) nodisp
)
645 (sit-for 0 val nodisp
)))
647 ;; EVENT may be a single event of a sequence of events
648 (defsubst vip-ESC-event-p
(event)
649 (let ((ESC-keys '(?\e
(control \
[) escape
))
650 (key (vip-event-key event
)))
651 (member key ESC-keys
)))
653 ;; like (set-mark-command nil) but doesn't push twice, if (car mark-ring)
654 ;; is the same as (mark t).
655 (defsubst vip-set-mark-if-necessary
()
656 (setq mark-ring
(delete (vip-mark-marker) mark-ring
))
657 (set-mark-command nil
))
659 (defsubst vip-mark-marker
()
664 ;; In transient mark mode (zmacs mode), it is annoying when regions become
665 ;; highlighted due to Viper's pushing marks. So, we deactivate marks, unless
666 ;; the user explicitly wants highlighting, e.g., by hitting '' or ``
667 (defun vip-deactivate-mark ()
669 (zmacs-deactivate-region)
672 (defsubst vip-leave-region-active
()
674 (setq zmacs-region-stays t
)))
677 (defsubst vip-events-to-keys
(events)
678 (cond (vip-xemacs-p (events-to-keys events
))
682 (defun vip-eval-after-load (file form
)
684 (eval-after-load file form
)
685 (or (assoc file after-load-alist
)
686 (setq after-load-alist
(cons (list file
) after-load-alist
)))
687 (let ((elt (assoc file after-load-alist
)))
688 (or (member form
(cdr elt
))
689 (setq elt
(nconc elt
(list form
)))))
693 ;; This is here because Emacs changed the way local hooks work.
695 ;;Add to the value of HOOK the function FUNCTION.
696 ;;FUNCTION is not added if already present.
697 ;;FUNCTION is added (if necessary) at the beginning of the hook list
698 ;;unless the optional argument APPEND is non-nil, in which case
699 ;;FUNCTION is added at the end.
701 ;;HOOK should be a symbol, and FUNCTION may be any valid function. If
702 ;;HOOK is void, it is first set to nil. If HOOK's value is a single
703 ;;function, it is changed to a list of functions."
704 (defun vip-add-hook (hook function
&optional append
)
705 (if (not (boundp hook
)) (set hook nil
))
706 ;; If the hook value is a single function, turn it into a list.
707 (let ((old (symbol-value hook
)))
708 (if (or (not (listp old
)) (eq (car old
) 'lambda
))
709 (setq old
(list old
)))
710 (if (member function old
)
713 (append old
(list function
)) ; don't nconc
714 (cons function old
))))))
716 ;; This is here because of Emacs's changes in the semantics of add/remove-hooks
717 ;; and due to the bugs they introduced.
719 ;; Remove from the value of HOOK the function FUNCTION.
720 ;; HOOK should be a symbol, and FUNCTION may be any valid function. If
721 ;; FUNCTION isn't the value of HOOK, or, if FUNCTION doesn't appear in the
722 ;; list of hooks to run in HOOK, then nothing is done. See `vip-add-hook'."
723 (defun vip-remove-hook (hook function
)
724 (if (or (not (boundp hook
)) ;unbound symbol, or
725 (null (symbol-value hook
)) ;value is nil, or
726 (null function
)) ;function is nil, then
728 (let ((hook-value (symbol-value hook
)))
729 (if (consp hook-value
)
730 ;; don't side-effect the list
731 (setq hook-value
(delete function
(copy-sequence hook-value
)))
732 (if (equal hook-value function
)
733 (setq hook-value nil
)))
734 (set hook hook-value
))))
738 ;; like read-event, but in XEmacs also try to convert to char, if possible
739 (defun vip-read-event-convert-to-char ()
743 (setq event
(next-command-event))
744 (or (event-to-character event
)
748 ;; This function lets function-key-map convert key sequences into logical
749 ;; keys. This does a better job than vip-read-event when it comes to kbd
750 ;; macros, since it enables certain macros to be shared between X and TTY
752 (defun vip-read-key ()
753 (let ((overriding-local-map vip-overriding-map
)
755 (use-global-map vip-overriding-map
)
756 (setq key
(elt (read-key-sequence nil
) 0))
757 (use-global-map global-map
)
761 ;; Emacs has a bug in eventp, which causes (eventp nil) to return (nil)
762 ;; instead of nil, if '(nil) was previously inadvertantly assigned to
763 ;; unread-command-events
764 (defun vip-event-key (event)
765 (or (and event
(eventp event
))
766 (error "vip-event-key: Wrong type argument, eventp, %S" event
))
767 (let ((mod (event-modifiers event
))
772 (cond ((key-press-event-p event
)
774 ((button-event-p event
)
775 (concat "mouse-" (prin1-to-string (event-button event
))))
777 (error "vip-event-key: Unknown event, %S" event
))))
779 ;; Emacs doesn't handle capital letters correctly, since
780 ;; \S-a isn't considered the same as A (it behaves as
781 ;; plain `a' instead). So we take care of this here
782 (cond ((and (numberp event
) (<= ?A event
) (<= event ?Z
))
785 ;; Emacs has the oddity whereby characters 128+char
786 ;; represent M-char *if* this appears inside a string.
787 ;; So, we convert them manually into (mata char).
788 ((and (numberp event
) (< ?\C-? event
) (<= event
255))
790 event
(- event ?\C-?
1)))
791 (t (event-basic-type event
)))
797 (list 'control
'\?) ; taking care of an emacs bug
798 (intern (char-to-string basis
)))))
801 (append mod
(list basis
))
805 (defun vip-key-to-emacs-key (key)
806 (let (key-name char-p modifiers mod-char-list base-key base-key-name
)
807 (cond (vip-xemacs-p key
)
809 (setq key-name
(symbol-name key
))
810 (if (= (length key-name
) 1) ; character event
811 (string-to-char key-name
)
814 (setq modifiers
(subseq key
0 (1- (length key
)))
815 base-key
(vip-seq-last-elt key
)
816 base-key-name
(symbol-name base-key
)
817 char-p
(= (length base-key-name
) 1))
820 '(lambda (elt) (upcase (substring (symbol-name elt
) 0 1)))
824 (car (read-from-string
827 (mapconcat 'identity mod-char-list
"-\\")
833 (mapconcat 'identity mod-char-list
"-")
839 ;; Args can be a sequence of events, a string, or a Viper macro. Will try to
840 ;; convert events to keys and, if all keys are regular printable
841 ;; characters, will return a string. Otherwise, will return a string
842 ;; representing a vector of converted events. If the input was a Viper macro,
843 ;; will return a string that represents this macro as a vector.
844 (defun vip-array-to-string (event-seq &optional representation
)
846 (cond ((stringp event-seq
) event-seq
)
847 ((vip-event-vector-p event-seq
)
848 (setq temp
(mapcar 'vip-event-key event-seq
))
849 (if (vip-char-symbol-sequence-p temp
)
850 (mapconcat 'symbol-name temp
"")
851 (prin1-to-string (vconcat temp
))))
852 ((vip-char-symbol-sequence-p event-seq
)
853 (mapconcat 'symbol-name event-seq
""))
854 (t (prin1-to-string event-seq
)))))
856 (defun vip-key-press-events-to-chars (events)
857 (mapconcat (if vip-emacs-p
860 (lambda (elt) (char-to-string (event-to-character elt
)))))
865 (defsubst vip-fast-keysequence-p
()
866 (not (vip-sit-for-short vip-fast-keyseq-timeout t
)))
868 (defun vip-read-char-exclusive ()
873 (setq char
(read-char))
875 ;; skip event if not char
881 (defun vip-setup-master-buffer (&rest other-files-or-buffers
)
882 "Set up the current buffer as a master buffer.
883 Arguments become related buffers. This function should normally be used in
884 the `Local variables' section of a file."
885 (setq vip-related-files-and-buffers-ring
886 (make-ring (1+ (length other-files-or-buffers
))))
887 (mapcar '(lambda (elt)
888 (vip-ring-insert vip-related-files-and-buffers-ring elt
))
889 other-files-or-buffers
)
890 (vip-ring-insert vip-related-files-and-buffers-ring
(buffer-name))
893 ;;; Movement utilities
895 (defvar vip-syntax-preference
'strict-vi
896 "*Syntax type characterizing Viper's alphanumeric symbols.
897 `emacs' means only word constituents are considered to be alphanumeric.
898 Word constituents are symbols specified as word constituents by the current
900 `extended' means word and symbol constituents.
901 `reformed-vi' means Vi-ish behavior: word constituents and the symbol `_'.
902 However, word constituents are determined according to Emacs syntax tables,
903 which may be different from Vi in some major modes.
904 `strict-vi' means Viper words are exactly as in Vi.")
906 (vip-deflocalvar vip-ALPHA-char-class
"w"
907 "String of syntax classes characterizing Viper's alphanumeric symbols.
908 In addition, the symbol `_' may be considered alphanumeric if
909 `vip-syntax-preference'is `reformed-vi'.")
911 (vip-deflocalvar vip-strict-ALPHA-chars
"a-zA-Z0-9_"
912 "Regexp matching the set of alphanumeric characters acceptable to strict
914 (vip-deflocalvar vip-strict-SEP-chars
" \t\n"
915 "Regexp matching the set of alphanumeric characters acceptable to strict
918 (vip-deflocalvar vip-SEP-char-class
" -"
919 "String of syntax classes for Vi separators.
920 Usually contains ` ', linefeed, TAB or formfeed.")
922 (defun vip-update-alphanumeric-class ()
923 "Set the syntactic class of Viper alphanumeric symbols according to
924 the variable `vip-ALPHA-char-class'. Should be called in order for changes to
925 `vip-ALPHA-char-class' to take effect."
929 (cond ((eq vip-syntax-preference
'emacs
) "w") ; only word constituents
930 ((eq vip-syntax-preference
'extended
) "w_") ; word & symbol chars
931 (t "w")))) ; vi syntax: word constituents and the symbol `_'
933 ;; addl-chars are characters to be temporarily considered as alphanumerical
934 (defun vip-looking-at-alpha (&optional addl-chars
)
935 (or (stringp addl-chars
) (setq addl-chars
""))
936 (if (eq vip-syntax-preference
'reformed-vi
)
937 (setq addl-chars
(concat addl-chars
"_")))
938 (let ((char (char-after (point))))
940 (if (eq vip-syntax-preference
'strict-vi
)
941 (looking-at (concat "[" vip-strict-ALPHA-chars addl-chars
"]"))
943 ;; convert string to list
944 (append (vconcat addl-chars
) nil
))
945 (memq (char-syntax char
)
946 (append (vconcat vip-ALPHA-char-class
) nil
)))))
949 (defsubst vip-looking-at-separator
()
950 (let ((char (char-after (point))))
952 (or (eq char ?
\n) ; RET is always a separator in Vi
953 (memq (char-syntax char
)
954 (append (vconcat vip-SEP-char-class
) nil
))))))
956 (defsubst vip-looking-at-alphasep
(&optional addl-chars
)
957 (or (vip-looking-at-separator) (vip-looking-at-alpha addl-chars
)))
959 (defsubst vip-skip-alpha-forward
(&optional addl-chars
)
960 (or (stringp addl-chars
) (setq addl-chars
""))
963 (cond ((eq vip-syntax-preference
'strict-vi
)
965 (t vip-ALPHA-char-class
))
966 (cond ((eq vip-syntax-preference
'strict-vi
)
967 (concat vip-strict-ALPHA-chars addl-chars
))
970 (defsubst vip-skip-alpha-backward
(&optional addl-chars
)
971 (or (stringp addl-chars
) (setq addl-chars
""))
974 (cond ((eq vip-syntax-preference
'strict-vi
)
976 (t vip-ALPHA-char-class
))
977 (cond ((eq vip-syntax-preference
'strict-vi
)
978 (concat vip-strict-ALPHA-chars addl-chars
))
981 ;; weird syntax tables may confuse strict-vi style
982 (defsubst vip-skip-all-separators-forward
(&optional within-line
)
983 (vip-skip-syntax 'forward
985 (or within-line
"\n")
986 (if within-line
(vip-line-pos 'end
))))
987 (defsubst vip-skip-all-separators-backward
(&optional within-line
)
988 (vip-skip-syntax 'backward
990 (or within-line
"\n")
991 (if within-line
(vip-line-pos 'start
))))
992 (defun vip-skip-nonseparators (direction)
993 (let ((func (intern (format "skip-syntax-%S" direction
))))
994 (funcall func
(concat "^" vip-SEP-char-class
)
995 (vip-line-pos (if (eq direction
'forward
) 'end
'start
)))))
997 (defsubst vip-skip-nonalphasep-forward
()
998 (if (eq vip-syntax-preference
'strict-vi
)
1000 (concat "^" vip-strict-SEP-chars vip-strict-ALPHA-chars
))
1001 (skip-syntax-forward
1003 "^" vip-ALPHA-char-class vip-SEP-char-class
) (vip-line-pos 'end
))))
1004 (defsubst vip-skip-nonalphasep-backward
()
1005 (if (eq vip-syntax-preference
'strict-vi
)
1006 (skip-chars-backward
1007 (concat "^" vip-strict-SEP-chars vip-strict-ALPHA-chars
))
1008 (skip-syntax-backward
1010 "^" vip-ALPHA-char-class vip-SEP-char-class
) (vip-line-pos 'start
))))
1012 ;; Skip SYNTAX like skip-syntax-* and ADDL-CHARS like skip-chars-*
1013 ;; Return the number of chars traveled.
1014 ;; Either SYNTAX or ADDL-CHARS can be nil, in which case they are interpreted
1015 ;; as an empty string.
1016 (defun vip-skip-syntax (direction syntax addl-chars
&optional limit
)
1019 (skip-chars-func (intern (format "skip-chars-%S" direction
)))
1020 (skip-syntax-func (intern (format "skip-syntax-%S" direction
))))
1021 (or (stringp addl-chars
) (setq addl-chars
""))
1022 (or (stringp syntax
) (setq syntax
""))
1023 (while (and (not (= local
0)) (not (eobp)))
1025 (+ (funcall skip-syntax-func syntax limit
)
1026 (funcall skip-chars-func addl-chars limit
)))
1027 (setq total
(+ total local
)))
1034 (provide 'viper-util
)
1036 ;;; viper-util.el ends here