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