(defvar viper-overriding-map)
(defvar pm-color-alist)
(defvar zmacs-region-stays)
(defvar viper-minibuffer-current-face)
(defvar viper-minibuffer-insert-face)
(defvar viper-minibuffer-vi-face)
(defvar viper-minibuffer-emacs-face)
(defvar viper-replace-overlay-face)
(defvar viper-fast-keyseq-timeout)
(defvar ex-unix-type-shell)
(defvar ex-unix-type-shell-options)
(defvar viper-ex-tmp-buf-name)
(defvar viper-syntax-preference)
(defvar viper-saved-mark)
(require 'ring)
(if noninteractive
(eval-when-compile
(let ((load-path (cons (expand-file-name ".") load-path)))
(or (featurep 'viper-init)
(load "viper-init.el" nil nil 'nosuffix))
)))
(require 'viper-init)
(if (and (not (fboundp 'x-display-color-p)) (fboundp 'ns-display-color-p))
(fset 'x-display-color-p (symbol-function 'ns-display-color-p)))
(if (and (not (fboundp 'x-color-defined-p)) (fboundp 'ns-color-defined-p))
(fset 'x-color-defined-p (symbol-function 'ns-color-defined-p)))
(viper-cond-compile-for-xemacs-or-emacs
(progn (fset 'viper-overlay-p (symbol-function 'extentp))
(fset 'viper-make-overlay (symbol-function 'make-extent))
(fset 'viper-overlay-live-p (symbol-function 'extent-live-p))
(fset 'viper-move-overlay (symbol-function 'set-extent-endpoints))
(fset 'viper-overlay-start (symbol-function 'extent-start-position))
(fset 'viper-overlay-end (symbol-function 'extent-end-position))
(fset 'viper-overlay-get (symbol-function 'extent-property))
(fset 'viper-overlay-put (symbol-function 'set-extent-property))
(fset 'viper-read-event (symbol-function 'next-command-event))
(fset 'viper-characterp (symbol-function 'characterp))
(fset 'viper-int-to-char (symbol-function 'int-to-char))
(if (viper-window-display-p)
(fset 'viper-iconify (symbol-function 'iconify-frame)))
(cond ((viper-has-face-support-p)
(fset 'viper-get-face (symbol-function 'get-face))
(fset 'viper-color-defined-p (symbol-function 'valid-color-name-p))
)))
(progn (fset 'viper-overlay-p (symbol-function 'overlayp))
(fset 'viper-make-overlay (symbol-function 'make-overlay))
(fset 'viper-overlay-live-p (symbol-function 'overlayp))
(fset 'viper-move-overlay (symbol-function 'move-overlay))
(fset 'viper-overlay-start (symbol-function 'overlay-start))
(fset 'viper-overlay-end (symbol-function 'overlay-end))
(fset 'viper-overlay-get (symbol-function 'overlay-get))
(fset 'viper-overlay-put (symbol-function 'overlay-put))
(fset 'viper-read-event (symbol-function 'read-event))
(fset 'viper-characterp (symbol-function 'integerp))
(fset 'viper-int-to-char (symbol-function 'identity))
(if (viper-window-display-p)
(fset 'viper-iconify (symbol-function 'iconify-or-deiconify-frame)))
(cond ((viper-has-face-support-p)
(fset 'viper-get-face (symbol-function 'internal-get-face))
(fset 'viper-color-defined-p (symbol-function 'x-color-defined-p))
)))
)
(defun viper-memq-char (char list)
(cond ((and (integerp char) (>= char 0))
(memq (viper-int-to-char char) list))
((memq char list))))
(defun viper-char-equal (char-or-int char)
(cond ((and (integerp char-or-int) (>= char-or-int 0))
(= (viper-int-to-char char-or-int) char))
((eq char-or-int char))))
(defun viper= (char char1)
(cond ((eq char char1) t)
((and (viper-characterp char) (viper-characterp char1))
(= char char1))
(t nil)))
(defsubst viper-color-display-p ()
(viper-cond-compile-for-xemacs-or-emacs
(eq (device-class (selected-device)) 'color) (x-display-color-p) ))
(defun viper-get-cursor-color (&optional frame)
(viper-cond-compile-for-xemacs-or-emacs
(color-instance-name
(frame-property (or frame (selected-frame)) 'cursor-color)) (cdr (assoc 'cursor-color (frame-parameters))) ))
(cond ((eq (viper-device-type) 'pm)
(fset 'viper-color-defined-p
(lambda (color) (assoc color pm-color-alist)))))
(defun viper-change-cursor-color (new-color &optional frame)
(if (and (viper-window-display-p) (viper-color-display-p)
(stringp new-color) (viper-color-defined-p new-color)
(not (string= new-color (viper-get-cursor-color))))
(viper-cond-compile-for-xemacs-or-emacs
(set-frame-property
(or frame (selected-frame))
'cursor-color (make-color-instance new-color))
(modify-frame-parameters
(or frame (selected-frame))
(list (cons 'cursor-color new-color)))
)
))
(defun viper-set-cursor-color-according-to-state (&optional frame)
(cond ((eq viper-current-state 'replace-state)
(viper-change-cursor-color viper-replace-state-cursor-color frame))
((and (eq viper-current-state 'emacs-state)
viper-emacs-state-cursor-color)
(viper-change-cursor-color viper-emacs-state-cursor-color frame))
((eq viper-current-state 'insert-state)
(viper-change-cursor-color viper-insert-state-cursor-color frame))
(t
(viper-change-cursor-color viper-vi-state-cursor-color frame))))
(defun viper-save-cursor-color (before-which-mode)
(if (and (viper-window-display-p) (viper-color-display-p))
(let ((color (viper-get-cursor-color)))
(if (and (stringp color) (viper-color-defined-p color)
(not (string= color viper-replace-overlay-cursor-color)))
(modify-frame-parameters
(selected-frame)
(list
(cons
(cond ((eq before-which-mode 'before-replace-mode)
'viper-saved-cursor-color-in-replace-mode)
((eq before-which-mode 'before-emacs-mode)
'viper-saved-cursor-color-in-emacs-mode)
(t
'viper-saved-cursor-color-in-insert-mode))
color)))
))))
(defsubst viper-get-saved-cursor-color-in-replace-mode ()
(or
(funcall
(if viper-emacs-p 'frame-parameter 'frame-property)
(selected-frame)
'viper-saved-cursor-color-in-replace-mode)
(if (and (eq viper-current-state 'emacs-mode) viper-emacs-state-cursor-color)
viper-emacs-state-cursor-color
viper-vi-state-cursor-color)))
(defsubst viper-get-saved-cursor-color-in-insert-mode ()
(or
(funcall
(if viper-emacs-p 'frame-parameter 'frame-property)
(selected-frame)
'viper-saved-cursor-color-in-insert-mode)
(if (and (eq viper-current-state 'emacs-mode) viper-emacs-state-cursor-color)
viper-emacs-state-cursor-color
viper-vi-state-cursor-color)))
(defsubst viper-get-saved-cursor-color-in-emacs-mode ()
(or
(funcall
(if viper-emacs-p 'frame-parameter 'frame-property)
(selected-frame)
'viper-saved-cursor-color-in-emacs-mode)
viper-vi-state-cursor-color))
(defun viper-restore-cursor-color(after-which-mode)
(if (viper-overlay-p viper-replace-overlay)
(viper-change-cursor-color
(cond ((eq after-which-mode 'after-replace-mode)
(viper-get-saved-cursor-color-in-replace-mode))
((eq after-which-mode 'after-emacs-mode)
(viper-get-saved-cursor-color-in-emacs-mode))
(t (viper-get-saved-cursor-color-in-insert-mode)))
)))
(defun viper-check-version (op major minor &optional type-of-emacs)
(if (and (boundp 'emacs-major-version) (boundp 'emacs-minor-version))
(and (cond ((eq type-of-emacs 'xemacs) viper-xemacs-p)
((eq type-of-emacs 'emacs) viper-emacs-p)
(t t))
(cond ((eq op '=) (and (= emacs-minor-version minor)
(= emacs-major-version major)))
((memq op '(> >= < <=))
(and (or (funcall op emacs-major-version major)
(= emacs-major-version major))
(if (= emacs-major-version major)
(funcall op emacs-minor-version minor)
t)))
(t
(error "%S: Invalid op in viper-check-version" op))))
(cond ((memq op '(= > >=)) nil)
((memq op '(< <=)) t))))
(defun viper-get-visible-buffer-window (wind)
(if viper-xemacs-p
(get-buffer-window wind t)
(get-buffer-window wind 'visible)))
(defun viper-line-pos (pos)
(let ((cur-pos (point))
(result))
(cond
((equal pos 'start)
(beginning-of-line))
((equal pos 'end)
(end-of-line))
((equal pos 'mid)
(goto-char (+ (viper-line-pos 'start) (viper-line-pos 'end) 2)))
((equal pos 'indent)
(back-to-indentation))
(t nil))
(setq result (point))
(goto-char cur-pos)
result))
(defun viper-chars-in-region (beg end &optional preserve-sign)
(let ((count (abs (- end beg))))
(if (and (< end beg) preserve-sign)
(- count)
count)))
(defsubst viper-pos-within-region (pos beg end)
(and (>= pos (min beg end)) (>= (max beg end) pos)))
(defun viper-move-marker-locally (var pos &optional buffer)
(if (markerp (eval var))
()
(set var (make-marker)))
(move-marker (eval var) pos buffer))
(defun viper-message-conditions (conditions)
(let ((case (car conditions)) (msg (cdr conditions)))
(if (null msg)
(message "%s" case)
(message "%s: %s" case (mapconcat 'prin1-to-string msg " ")))
(beep 1)))
(defun viper-list-to-alist (lst)
(let ((alist))
(while lst
(setq alist (cons (list (car lst)) alist))
(setq lst (cdr lst)))
alist))
(defun viper-alist-to-list (alst)
(let ((lst))
(while alst
(setq lst (cons (car (car alst)) lst))
(setq alst (cdr alst)))
lst))
(defun viper-filter-alist (regexp alst)
(interactive "s x")
(let ((outalst) (inalst alst))
(while (car inalst)
(if (string-match regexp (car (car inalst)))
(setq outalst (cons (car inalst) outalst)))
(setq inalst (cdr inalst)))
outalst))
(defun viper-filter-list (regexp lst)
(interactive "s x")
(let ((outlst) (inlst lst))
(while (car inlst)
(if (string-match regexp (car inlst))
(setq outlst (cons (car inlst) outlst)))
(setq inlst (cdr inlst)))
outlst))
(defun viper-append-filter-alist (lis1 lis2)
(let ((temp lis1)
elt)
(while temp
(while (setq elt (assoc (car (car temp)) lis2))
(setq lis2 (delq elt lis2)))
(setq temp (cdr temp)))
(append lis1 lis2)))
(defun viper-glob-unix-files (filespec)
(let ((gshell
(cond (ex-unix-type-shell shell-file-name)
((memq system-type '(vax-vms axp-vms)) "*dcl*") (t "sh"))) (gshell-options
(cond (ex-unix-type-shell-options)
))
(command (cond (viper-ms-style-os-p (format "\"ls -1 -d %s\"" filespec))
(t (format "ls -1 -d %s" filespec))))
status)
(save-excursion
(set-buffer (get-buffer-create viper-ex-tmp-buf-name))
(erase-buffer)
(setq status
(if gshell-options
(call-process gshell nil t nil
gshell-options
"-c"
command)
(call-process gshell nil t nil
"-c"
command)))
(goto-char (point-min))
(unless (eq 0 status)
(save-excursion
(skip-chars-forward " \t\n\j")
(if (looking-at "ls:")
(viper-forward-Word 1))
(error "%s: %s"
(if (stringp gshell)
gshell
"shell")
(buffer-substring (point) (viper-line-pos 'end)))
))
(goto-char (point-min))
(viper-get-filenames-from-buffer 'one-per-line))
))
(defun viper-get-filenames-from-buffer (&optional one-per-line)
(let ((skip-chars (if one-per-line "\t\n" " \t\n"))
result fname delim)
(skip-chars-forward skip-chars)
(while (not (eobp))
(if (cond ((looking-at "\"")
(setq delim ?\")
(re-search-forward "[^\"]+" nil t)) ((looking-at "'")
(setq delim ?')
(re-search-forward "[^']+" nil t)) (t
(re-search-forward
(concat "[^" skip-chars "]+") nil t))) (setq fname
(buffer-substring (match-beginning 0) (match-end 0))))
(if delim
(forward-char 1))
(skip-chars-forward " \t\n")
(setq result (cons fname result)))
result))
(defun viper-wildcard-to-regexp (wcard)
(save-excursion
(set-buffer (get-buffer-create viper-ex-tmp-buf-name))
(erase-buffer)
(insert wcard)
(goto-char (point-min))
(while (not (eobp))
(skip-chars-forward "^*?.\\\\")
(cond ((eq (char-after (point)) ?*) (insert ".")(forward-char 1))
((eq (char-after (point)) ?.) (insert "\\")(forward-char 1))
((eq (char-after (point)) ?\\) (insert "\\")(forward-char 1))
((eq (char-after (point)) ??) (delete-char 1)(insert ".")))
)
(buffer-string)
))
(defun viper-glob-mswindows-files (filespec)
(let ((case-fold-search t)
tmp tmp2)
(save-excursion
(set-buffer (get-buffer-create viper-ex-tmp-buf-name))
(erase-buffer)
(insert filespec)
(goto-char (point-min))
(setq tmp (viper-get-filenames-from-buffer))
(while tmp
(setq tmp2 (cons (directory-files
(or (file-name-directory (car tmp))
"")
t (concat "^"
(viper-wildcard-to-regexp
(file-name-nondirectory (car tmp)))
"$"))
tmp2))
(setq tmp (cdr tmp)))
(reverse (apply 'append tmp2)))))
(defun viper-ring-rotate1 (ring dir)
(if (and (ring-p ring) (> (ring-length ring) 0))
(progn
(setcar ring (cond ((> dir 0)
(ring-plus1 (car ring) (ring-length ring)))
((< dir 0)
(ring-minus1 (car ring) (ring-length ring)))
(t (car ring))))
(viper-current-ring-item ring)
)))
(defun viper-special-ring-rotate1 (ring dir)
(if (memq viper-intermediate-command
'(repeating-display-destructive-command
repeating-insertion-from-ring))
(viper-ring-rotate1 ring dir)
(viper-ring-rotate1 ring 0)))
(defun viper-current-ring-item (ring &optional n)
(setq n (or n 0))
(if (and (ring-p ring) (> (ring-length ring) 0))
(aref (cdr (cdr ring)) (mod (- (car ring) 1 n) (ring-length ring)))))
(defun viper-push-onto-ring (item ring-var)
(or (ring-p (eval ring-var))
(set ring-var (make-ring (eval (intern (format "%S-size" ring-var))))))
(or (null item) (and (stringp item) (string= item "")) (equal item (viper-current-ring-item (eval ring-var))) (and (eq ring-var 'viper-command-ring)
(string-match "\\([0-9]*\e\\|^[ \t]*$\\|escape\\)"
(viper-array-to-string (this-command-keys))))
(viper-ring-insert (eval ring-var) item))
)
(defun viper-cleanup-ring (ring)
(or (< (ring-length ring) 2)
(null (viper-current-ring-item ring))
(if (equal (viper-current-ring-item ring)
(viper-current-ring-item ring 1))
(viper-ring-pop ring))))
(defun viper-ring-pop (ring)
(let* ((ln (ring-length ring))
(vec (cdr (cdr ring)))
(veclen (length vec))
(hd (car ring))
(idx (max 0 (ring-minus1 hd ln)))
(top-elt (aref vec idx)))
(while (< (1+ idx) veclen)
(aset vec idx (aref vec (1+ idx)))
(setq idx (1+ idx)))
(aset vec idx nil)
(setq hd (max 0 (ring-minus1 hd ln)))
(if (= hd (1- ln)) (setq hd 0))
(setcar ring hd) (setcar (cdr ring) (max 0 (1- ln))) top-elt
))
(defun viper-ring-insert (ring item)
(let* ((ln (ring-length ring))
(vec (cdr (cdr ring)))
(veclen (length vec))
(hd (car ring))
(vecpos-after-hd (if (= hd 0) ln hd))
(idx ln))
(if (= ln veclen)
(progn
(aset vec hd item) (setcar ring (ring-plus1 hd ln)))
(setcar (cdr ring) (1+ ln))
(setcar ring (ring-plus1 vecpos-after-hd (1+ ln)))
(while (and (>= idx vecpos-after-hd) (> ln 0))
(aset vec idx (aref vec (1- idx)))
(setq idx (1- idx)))
(aset vec vecpos-after-hd item))
item))
(defun viper-abbreviate-string (string max-len
pre-string post-string abbrev-sign)
(let (truncated-str)
(setq truncated-str
(if (stringp string)
(substring string 0 (min max-len (length string)))))
(cond ((null truncated-str) "")
((> (length string) max-len)
(format "%s%s%s%s"
pre-string truncated-str abbrev-sign post-string))
(t (format "%s%s%s" pre-string truncated-str post-string)))))
(defsubst viper-over-whitespace-line ()
(save-excursion
(beginning-of-line)
(looking-at "^[ \t]*$")))
(defun viper-save-setting (var message custom-file &optional erase-msg)
(let* ((var-name (symbol-name var))
(var-val (if (boundp var) (eval var)))
(regexp (format "^[^;]*%s[ \t\n]*[a-zA-Z---_']*[ \t\n)]" var-name))
(buf (find-file-noselect (substitute-in-file-name custom-file)))
)
(message message)
(save-excursion
(set-buffer buf)
(goto-char (point-min))
(if (re-search-forward regexp nil t)
(let ((reg-end (1- (match-end 0))))
(search-backward var-name)
(delete-region (match-beginning 0) reg-end)
(goto-char (match-beginning 0))
(insert (format "%s '%S" var-name var-val)))
(goto-char (point-max))
(if (not (bolp)) (insert "\n"))
(insert (format "(setq %s '%S)\n" var-name var-val)))
(save-buffer))
(kill-buffer buf)
(if erase-msg
(progn
(sit-for 2)
(message "")))
))
(defun viper-save-string-in-file (string custom-file &optional pattern)
(let ((buf (find-file-noselect (substitute-in-file-name custom-file))))
(save-excursion
(set-buffer buf)
(let (buffer-read-only)
(goto-char (point-min))
(if pattern (delete-matching-lines pattern))
(goto-char (point-max))
(if string (insert string))
(save-buffer)))
(kill-buffer buf)
))
(defun viper-file-remote-p (file-name)
(file-remote-p file-name))
(defsubst viper-file-checked-in-p (file)
(and (featurep 'vc-hooks)
(not (memq (vc-backend file) '(nil CVS)))
(if (fboundp 'vc-state)
(and
(not (memq (vc-state file) '(edited needs-merge)))
(not (stringp (vc-state file))))
(not (vc-locking-user file)))
))
(defun viper-maybe-checkout (buf)
(let ((file (expand-file-name (buffer-file-name buf)))
(checkout-function (key-binding "\C-x\C-q")))
(if (and (viper-file-checked-in-p file)
(or (beep 1) t)
(y-or-n-p
(format
"File %s is checked in. Check it out? "
(viper-abbreviate-file-name file))))
(with-current-buffer buf
(command-execute checkout-function)))))
(defun viper-put-on-search-overlay (beg end)
(if (viper-overlay-p viper-search-overlay)
(viper-move-overlay viper-search-overlay beg end)
(setq viper-search-overlay (viper-make-overlay beg end (current-buffer)))
(viper-overlay-put
viper-search-overlay 'priority viper-search-overlay-priority))
(viper-overlay-put viper-search-overlay 'face viper-search-face))
(defun viper-flash-search-pattern ()
(if (not (viper-has-face-support-p))
nil
(viper-put-on-search-overlay (match-beginning 0) (match-end 0))
(sit-for 2)
(viper-overlay-put viper-search-overlay 'face nil)))
(defun viper-hide-search-overlay ()
(if (not (viper-overlay-p viper-search-overlay))
(progn
(setq viper-search-overlay
(viper-make-overlay (point-min) (point-min) (current-buffer)))
(viper-overlay-put
viper-search-overlay 'priority viper-search-overlay-priority)))
(viper-overlay-put viper-search-overlay 'face nil))
(defsubst viper-move-replace-overlay (beg end)
(viper-move-overlay viper-replace-overlay beg end))
(defun viper-set-replace-overlay (beg end)
(if (viper-overlay-live-p viper-replace-overlay)
(viper-move-replace-overlay beg end)
(setq viper-replace-overlay (viper-make-overlay beg end (current-buffer)))
(viper-overlay-put
viper-replace-overlay (if viper-emacs-p 'evaporate 'detachable) nil)
(viper-overlay-put
viper-replace-overlay 'priority viper-replace-overlay-priority)
)
(if (viper-has-face-support-p)
(viper-overlay-put
viper-replace-overlay 'face viper-replace-overlay-face))
(viper-save-cursor-color 'before-replace-mode)
(viper-change-cursor-color viper-replace-overlay-cursor-color)
)
(defun viper-set-replace-overlay-glyphs (before-glyph after-glyph)
(or (viper-overlay-live-p viper-replace-overlay)
(viper-set-replace-overlay (point-min) (point-min)))
(if (or (not (viper-has-face-support-p))
viper-use-replace-region-delimiters)
(let ((before-name (if viper-xemacs-p 'begin-glyph 'before-string))
(after-name (if viper-xemacs-p 'end-glyph 'after-string)))
(viper-overlay-put viper-replace-overlay before-name before-glyph)
(viper-overlay-put viper-replace-overlay after-name after-glyph))))
(defun viper-hide-replace-overlay ()
(viper-set-replace-overlay-glyphs nil nil)
(viper-restore-cursor-color 'after-replace-mode)
(viper-restore-cursor-color 'after-insert-mode)
(if (viper-has-face-support-p)
(viper-overlay-put viper-replace-overlay 'face nil)))
(defsubst viper-replace-start ()
(viper-overlay-start viper-replace-overlay))
(defsubst viper-replace-end ()
(viper-overlay-end viper-replace-overlay))
(defun viper-set-minibuffer-overlay ()
(viper-check-minibuffer-overlay)
(if (viper-has-face-support-p)
(progn
(viper-overlay-put
viper-minibuffer-overlay 'face viper-minibuffer-current-face)
(viper-overlay-put
viper-minibuffer-overlay 'priority viper-minibuffer-overlay-priority)
(viper-overlay-put
viper-minibuffer-overlay
(if viper-emacs-p 'evaporate 'detachable)
nil)
(if viper-xemacs-p
(progn
(viper-overlay-put viper-minibuffer-overlay 'start-open nil)
(viper-overlay-put viper-minibuffer-overlay 'end-open nil)))
)))
(defun viper-check-minibuffer-overlay ()
(if (viper-overlay-live-p viper-minibuffer-overlay)
(viper-move-overlay
viper-minibuffer-overlay
(if (fboundp 'minibuffer-prompt-end) (minibuffer-prompt-end) 1)
(1+ (buffer-size)))
(setq viper-minibuffer-overlay
(if viper-xemacs-p
(viper-make-overlay 1 (1+ (buffer-size)) (current-buffer))
(viper-make-overlay
(if (fboundp 'minibuffer-prompt-end) (minibuffer-prompt-end) 1)
(1+ (buffer-size))
(current-buffer) nil 'rear-advance)))
))
(defsubst viper-is-in-minibuffer ()
(save-match-data
(string-match "\*Minibuf-" (buffer-name))))
(defun viper-abbreviate-file-name (file)
(viper-cond-compile-for-xemacs-or-emacs
(abbreviate-file-name file t)
(abbreviate-file-name file)
))
(defsubst viper-sit-for-short (val &optional nodisp)
(if viper-xemacs-p
(sit-for (/ val 1000.0) nodisp)
(sit-for 0 val nodisp)))
(defsubst viper-ESC-event-p (event)
(let ((ESC-keys '(?\e (control \[) escape))
(key (viper-event-key event)))
(member key ESC-keys)))
(defun viper-valid-marker (marker)
(if (and (markerp marker) (marker-buffer marker))
(let ((buf (marker-buffer marker))
(pos (marker-position marker)))
(save-excursion
(set-buffer buf)
(and (<= pos (point-max)) (<= (point-min) pos))))))
(defsubst viper-mark-marker ()
(viper-cond-compile-for-xemacs-or-emacs
(mark-marker t) (mark-marker) ))
(defsubst viper-set-mark-if-necessary ()
(setq mark-ring (delete (viper-mark-marker) mark-ring))
(set-mark-command nil)
(setq viper-saved-mark (point)))
(defun viper-deactivate-mark ()
(viper-cond-compile-for-xemacs-or-emacs
(zmacs-deactivate-region)
(deactivate-mark)
))
(defsubst viper-leave-region-active ()
(viper-cond-compile-for-xemacs-or-emacs
(setq zmacs-region-stays t)
nil
))
(defun viper-valid-register (reg &optional type)
(or type (setq type '(letter Letter digit)))
(or (if (memq 'letter type)
(and (<= ?a reg) (<= reg ?z)))
(if (memq 'digit type)
(and (<= ?1 reg) (<= reg ?9)))
(if (memq 'Letter type)
(and (<= ?A reg) (<= reg ?Z)))
))
(defun viper-copy-event (event)
(viper-cond-compile-for-xemacs-or-emacs
(copy-event event) event ))
(defsubst viper-fast-keysequence-p ()
(not (viper-sit-for-short
(if (viper-ESC-event-p last-input-event)
viper-ESC-keyseq-timeout
viper-fast-keyseq-timeout)
t)))
(defun viper-read-event-convert-to-char ()
(let (event)
(viper-cond-compile-for-xemacs-or-emacs
(progn
(setq event (next-command-event))
(or (event-to-character event)
event))
(read-event)
)
))
(defun viper-read-key-sequence (prompt &optional continue-echo)
(let (inhibit-quit event keyseq)
(setq keyseq (read-key-sequence prompt continue-echo))
(setq event (if viper-xemacs-p
(elt keyseq 0) (elt (listify-key-sequence keyseq) 0)))
(if (viper-ESC-event-p event)
(let (unread-command-events)
(if (viper-fast-keysequence-p)
(let ((viper-vi-global-user-minor-mode nil)
(viper-vi-local-user-minor-mode nil)
(viper-vi-intercept-minor-mode nil)
(viper-insert-intercept-minor-mode nil)
(viper-replace-minor-mode nil) (viper-insert-global-user-minor-mode nil)
(viper-insert-local-user-minor-mode nil))
(viper-set-unread-command-events keyseq)
(setq keyseq (read-key-sequence nil)))
(viper-set-unread-command-events keyseq)
(setq keyseq (read-key-sequence nil)))))
keyseq))
(defun viper-read-key ()
(let ((overriding-local-map viper-overriding-map)
(inhibit-quit t)
help-char key)
(use-global-map viper-overriding-map)
(unwind-protect
(setq key (elt (viper-read-key-sequence nil) 0))
(use-global-map global-map))
key))
(defun viper-event-key (event)
(or (and event (eventp event))
(error "viper-event-key: Wrong type argument, eventp, %S" event))
(when (viper-cond-compile-for-xemacs-or-emacs
(or (key-press-event-p event) (mouse-event-p event)) t )
(let ((mod (event-modifiers event))
basis)
(setq basis
(viper-cond-compile-for-xemacs-or-emacs
(cond ((key-press-event-p event)
(event-key event))
((button-event-p event)
(concat "mouse-" (prin1-to-string (event-button event))))
(t
(error "viper-event-key: Unknown event, %S" event)))
(cond ((and (viper-characterp event) (<= ?A event) (<= event ?Z))
(setq mod nil
event event))
((and (viper-characterp event)
(< ?\C-? event) (<= event 255))
(setq mod '(meta)
event (- event ?\C-? 1)))
((and (null mod) (eq event 'return))
(setq event ?\C-m))
((and (null mod) (eq event 'space))
(setq event ?\ ))
((and (null mod) (eq event 'delete))
(setq event ?\C-?))
((and (null mod) (eq event 'backspace))
(setq event ?\C-h))
(t (event-basic-type event)))
) )
(if (viper-characterp basis)
(setq basis
(if (viper= basis ?\C-?)
(list 'control '\?) (intern (char-to-string basis)))))
(if mod
(append mod (list basis))
basis))))
(defun viper-key-to-emacs-key (key)
(let (key-name char-p modifiers mod-char-list base-key base-key-name)
(cond (viper-xemacs-p key)
((symbolp key)
(setq key-name (symbol-name key))
(cond ((= (length key-name) 1) (string-to-char key-name))
((and viper-emacs-p (not (viper-window-display-p))
(string= key-name "return"))
?\C-m)
((and viper-emacs-p (not (viper-window-display-p))
(string= key-name "escape"))
?\e)
(t key)))
((listp key)
(setq modifiers (viper-subseq key 0 (1- (length key)))
base-key (viper-seq-last-elt key)
base-key-name (symbol-name base-key)
char-p (= (length base-key-name) 1))
(setq mod-char-list
(mapcar
'(lambda (elt) (upcase (substring (symbol-name elt) 0 1)))
modifiers))
(if char-p
(setq key-name
(car (read-from-string
(concat
"?\\"
(mapconcat 'identity mod-char-list "-\\")
"-"
base-key-name))))
(setq key-name
(intern
(concat
(mapconcat 'identity mod-char-list "-")
"-"
base-key-name))))))
))
(defun viper-eventify-list-xemacs (lis)
(mapcar
(lambda (elt)
(cond ((viper-characterp elt) (character-to-event elt))
((eventp elt) elt)
(t (error
"viper-eventify-list-xemacs: can't convert to event, %S"
elt))))
lis))
(defun viper-set-unread-command-events (arg)
(if viper-emacs-p
(setq
unread-command-events
(let ((new-events
(cond ((eventp arg) (list arg))
((listp arg) arg)
((sequencep arg)
(listify-key-sequence arg))
(t (error
"viper-set-unread-command-events: Invalid argument, %S"
arg)))))
(if (not (eventp nil))
(setq new-events (delq nil new-events)))
(append new-events unread-command-events)))
(setq
unread-command-events
(append
(cond ((viper-characterp arg) (list (character-to-event arg)))
((eventp arg) (list arg))
((stringp arg) (mapcar 'character-to-event arg))
((vectorp arg) (append arg nil)) ((listp arg) (viper-eventify-list-xemacs arg))
(t (error
"viper-set-unread-command-events: Invalid argument, %S" arg)))
unread-command-events))))
(defun viper-event-vector-p (vec)
(and (vectorp vec)
(eval (cons 'and (mapcar '(lambda (elt) (if (eventp elt) t)) vec)))))
(defun viper-char-symbol-sequence-p (vec)
(and
(sequencep vec)
(eval
(cons 'and
(mapcar (lambda (elt)
(and (symbolp elt) (= (length (symbol-name elt)) 1)))
vec)))))
(defun viper-char-array-p (array)
(eval (cons 'and (mapcar 'viper-characterp array))))
(defun viper-array-to-string (event-seq)
(let (temp temp2)
(cond ((stringp event-seq) event-seq)
((viper-event-vector-p event-seq)
(setq temp (mapcar 'viper-event-key event-seq))
(cond ((viper-char-symbol-sequence-p temp)
(mapconcat 'symbol-name temp ""))
((and (viper-char-array-p
(setq temp2 (mapcar 'viper-key-to-character temp))))
(mapconcat 'char-to-string temp2 ""))
(t (prin1-to-string (vconcat temp)))))
((viper-char-symbol-sequence-p event-seq)
(mapconcat 'symbol-name event-seq ""))
((and (vectorp event-seq)
(viper-char-array-p
(setq temp (mapcar 'viper-key-to-character event-seq))))
(mapconcat 'char-to-string temp ""))
(t (prin1-to-string event-seq)))))
(defun viper-key-press-events-to-chars (events)
(mapconcat (viper-cond-compile-for-xemacs-or-emacs
(lambda (elt) (char-to-string (event-to-character elt))) 'char-to-string )
events
""))
(defun viper-read-char-exclusive ()
(let (char
(echo-keystrokes 1))
(while (null char)
(condition-case nil
(setq char (read-char))
(error
(viper-read-event))))
char))
(defun viper-key-to-character (key)
(cond ((eq key 'space) ?\ )
((eq key 'delete) ?\C-?)
((eq key 'return) ?\C-m)
((eq key 'backspace) ?\C-h)
((and (symbolp key)
(= 1 (length (symbol-name key))))
(string-to-char (symbol-name key)))
((and (listp key)
(eq (car key) 'control)
(symbol-name (nth 1 key))
(= 1 (length (symbol-name (nth 1 key)))))
(read (format "?\\C-%s" (symbol-name (nth 1 key)))))
(t key)))
(defun viper-setup-master-buffer (&rest other-files-or-buffers)
"Set up the current buffer as a master buffer.
Arguments become related buffers. This function should normally be used in
the `Local variables' section of a file."
(setq viper-related-files-and-buffers-ring
(make-ring (1+ (length other-files-or-buffers))))
(mapcar '(lambda (elt)
(viper-ring-insert viper-related-files-and-buffers-ring elt))
other-files-or-buffers)
(viper-ring-insert viper-related-files-and-buffers-ring (buffer-name))
)
(defconst viper-non-word-characters-reformed-vi
"!@#$%^&*()\\-+=|\\~`{}[];:'\",<.>/?")
(viper-deflocalvar viper-non-word-characters nil)
(viper-deflocalvar viper-ALPHA-char-class "w"
"String of syntax classes characterizing Viper's alphanumeric symbols.
In addition, the symbol `_' may be considered alphanumeric if
`viper-syntax-preference' is `strict-vi' or `reformed-vi'.")
(defconst viper-strict-ALPHA-chars "a-zA-Z0-9_"
"Regexp matching the set of alphanumeric characters acceptable to strict
Vi.")
(defconst viper-strict-SEP-chars " \t\n"
"Regexp matching the set of alphanumeric characters acceptable to strict
Vi.")
(defconst viper-strict-SEP-chars-sans-newline " \t"
"Regexp matching the set of alphanumeric characters acceptable to strict
Vi.")
(defconst viper-SEP-char-class " -"
"String of syntax classes for Vi separators.
Usually contains ` ', linefeed, TAB or formfeed.")
(defun viper-update-syntax-classes (&optional set-default)
(let ((preference (cond ((eq viper-syntax-preference 'emacs)
"w") ((eq viper-syntax-preference 'extended)
"w_") (t "w"))) (non-word-chars (cond ((eq viper-syntax-preference 'reformed-vi)
(viper-string-to-list
viper-non-word-characters-reformed-vi))
(t nil))))
(if set-default
(setq-default viper-ALPHA-char-class preference
viper-non-word-characters non-word-chars)
(setq viper-ALPHA-char-class preference
viper-non-word-characters non-word-chars))
))
(defun viper-set-syntax-preference (&optional symbol value)
"Set Viper syntax preference.
If called interactively or if SYMBOL is nil, sets syntax preference in current
buffer. If called non-interactively, preferably via the customization widget,
sets the default value."
(interactive)
(or value
(setq value
(completing-read
"Viper syntax preference: "
'(("strict-vi") ("reformed-vi") ("extended") ("emacs"))
nil 'require-match)))
(if (stringp value) (setq value (intern value)))
(or (memq value '(strict-vi reformed-vi extended emacs))
(error "Invalid Viper syntax preference, %S" value))
(if symbol
(setq-default viper-syntax-preference value)
(setq viper-syntax-preference value))
(viper-update-syntax-classes))
(defcustom viper-syntax-preference 'reformed-vi
"*Syntax type characterizing Viper's alphanumeric symbols.
Affects movement and change commands that deal with Vi-style words.
Works best when set in the hooks to various major modes.
`strict-vi' means Viper words are (hopefully) exactly as in Vi.
`reformed-vi' means Viper words are like Emacs words \(as determined using
Emacs syntax tables, which are different for different major modes\) with two
exceptions: the symbol `_' is always part of a word and typical Vi non-word
symbols, such as `,',:,\",),{, etc., are excluded.
This behaves very close to `strict-vi', but also works well with non-ASCII
characters from various alphabets.
`extended' means Viper word constituents are symbols that are marked as being
parts of words OR symbols in Emacs syntax tables.
This is most appropriate for major modes intended for editing programs.
`emacs' means Viper words are the same as Emacs words as specified by Emacs
syntax tables.
This option is appropriate if you like Emacs-style words."
:type '(radio (const strict-vi) (const reformed-vi)
(const extended) (const emacs))
:set 'viper-set-syntax-preference
:group 'viper)
(make-variable-buffer-local 'viper-syntax-preference)
(defun viper-looking-at-alpha (&optional addl-chars)
(or (stringp addl-chars) (setq addl-chars ""))
(if (eq viper-syntax-preference 'reformed-vi)
(setq addl-chars (concat addl-chars "_")))
(let ((char (char-after (point))))
(if char
(if (eq viper-syntax-preference 'strict-vi)
(looking-at (concat "[" viper-strict-ALPHA-chars addl-chars "]"))
(or
(viper-memq-char char (viper-string-to-list addl-chars))
(and
(not (viper-memq-char char viper-non-word-characters))
(viper-memq-char (char-syntax char)
(viper-string-to-list viper-ALPHA-char-class))))))
))
(defun viper-looking-at-separator ()
(let ((char (char-after (point))))
(if char
(if (eq viper-syntax-preference 'strict-vi)
(viper-memq-char char (viper-string-to-list viper-strict-SEP-chars))
(or (eq char ?\n) (viper-memq-char (char-syntax char)
(viper-string-to-list viper-SEP-char-class)))))
))
(defsubst viper-looking-at-alphasep (&optional addl-chars)
(or (viper-looking-at-separator) (viper-looking-at-alpha addl-chars)))
(defun viper-skip-alpha-forward (&optional addl-chars)
(or (stringp addl-chars) (setq addl-chars ""))
(viper-skip-syntax
'forward
(cond ((eq viper-syntax-preference 'strict-vi)
"")
(t viper-ALPHA-char-class))
(cond ((eq viper-syntax-preference 'strict-vi)
(concat viper-strict-ALPHA-chars addl-chars))
(t addl-chars))))
(defun viper-skip-alpha-backward (&optional addl-chars)
(or (stringp addl-chars) (setq addl-chars ""))
(viper-skip-syntax
'backward
(cond ((eq viper-syntax-preference 'strict-vi)
"")
(t viper-ALPHA-char-class))
(cond ((eq viper-syntax-preference 'strict-vi)
(concat viper-strict-ALPHA-chars addl-chars))
(t addl-chars))))
(defsubst viper-skip-all-separators-forward (&optional within-line)
(if (eq viper-syntax-preference 'strict-vi)
(if within-line
(skip-chars-forward viper-strict-SEP-chars-sans-newline)
(skip-chars-forward viper-strict-SEP-chars))
(viper-skip-syntax 'forward
viper-SEP-char-class
(or within-line "\n")
(if within-line (viper-line-pos 'end)))))
(defsubst viper-skip-all-separators-backward (&optional within-line)
(if (eq viper-syntax-preference 'strict-vi)
(if within-line
(skip-chars-backward viper-strict-SEP-chars-sans-newline)
(skip-chars-backward viper-strict-SEP-chars))
(viper-skip-syntax 'backward
viper-SEP-char-class
(or within-line "\n")
(if within-line (viper-line-pos 'start)))))
(defun viper-skip-nonseparators (direction)
(viper-skip-syntax
direction
(concat "^" viper-SEP-char-class)
nil
(viper-line-pos (if (eq direction 'forward) 'end 'start))))
(defun viper-skip-nonalphasep-forward ()
(if (eq viper-syntax-preference 'strict-vi)
(skip-chars-forward
(concat "^" viper-strict-SEP-chars viper-strict-ALPHA-chars))
(viper-skip-syntax
'forward
(concat "^" viper-ALPHA-char-class viper-SEP-char-class)
viper-non-word-characters
(viper-line-pos 'end))))
(defun viper-skip-nonalphasep-backward ()
(if (eq viper-syntax-preference 'strict-vi)
(skip-chars-backward
(concat "^" viper-strict-SEP-chars viper-strict-ALPHA-chars))
(viper-skip-syntax
'backward
(concat "^" viper-ALPHA-char-class viper-SEP-char-class)
viper-non-word-characters
(viper-line-pos 'start))))
(defun viper-skip-syntax (direction syntax addl-chars &optional limit)
(let ((total 0)
(local 1)
(skip-chars-func
(if (eq direction 'forward)
'skip-chars-forward 'skip-chars-backward))
(skip-syntax-func
(if (eq direction 'forward)
'viper-forward-char-carefully 'viper-backward-char-carefully))
char-looked-at syntax-of-char-looked-at negated-syntax)
(setq addl-chars
(cond ((listp addl-chars) (viper-charlist-to-string addl-chars))
((stringp addl-chars) addl-chars)
(t "")))
(setq syntax
(cond ((listp syntax) syntax)
((stringp syntax) (viper-string-to-list syntax))
(t nil)))
(if (memq ?^ syntax) (setq negated-syntax t))
(while (and (not (= local 0))
(cond ((eq direction 'forward)
(not (eobp)))
(t (not (bobp)))))
(setq char-looked-at (viper-char-at-pos direction)
syntax-of-char-looked-at (if char-looked-at
(char-syntax char-looked-at)))
(setq local
(+ (if (and
(cond ((and limit (eq direction 'forward))
(< (point) limit))
(limit (> (point) limit))
(t t)) (if negated-syntax
(not (memq syntax-of-char-looked-at syntax))
(memq syntax-of-char-looked-at syntax))
(if (and (eq syntax-of-char-looked-at ?w)
(not negated-syntax))
(not (viper-memq-char
char-looked-at viper-non-word-characters))
t))
(funcall skip-syntax-func 1)
0)
(funcall skip-chars-func addl-chars limit)))
(setq total (+ total local)))
total
))
(defun viper-beginning-of-field ()
(or (bobp)
(not (eq (get-char-property (point) 'field)
(get-char-property (1- (point)) 'field)))))
(defun viper-subseq (seq start &optional end)
(if (stringp seq) (substring seq start end)
(let (len)
(and end (< end 0) (setq end (+ end (setq len (length seq)))))
(if (< start 0) (setq start (+ start (or len (setq len (length seq))))))
(cond ((listp seq)
(if (> start 0) (setq seq (nthcdr start seq)))
(if end
(let ((res nil))
(while (>= (setq end (1- end)) start)
(push (pop seq) res))
(nreverse res))
(copy-sequence seq)))
(t
(or end (setq end (or len (length seq))))
(let ((res (make-vector (max (- end start) 0) nil))
(i 0))
(while (< start end)
(aset res i (aref seq start))
(setq i (1+ i) start (1+ start)))
res))))))
(provide 'viper-util)