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