lisp/emulation/viper-util.el

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