lisp/emulation/viper-macs.el

   1 ;;; viper-macs.el --- functions implementing keyboard macros for Viper
   2
   3 ;; Copyright (C) 1994, 1995 Free Software Foundation, Inc.
   4
   5 ;; This file is part of GNU Emacs.
   6
   7 ;; GNU Emacs is free software; you can redistribute it and/or modify
   8 ;; it under the terms of the GNU General Public License as published by
   9 ;; the Free Software Foundation; either version 2, or (at your option)
  10 ;; any later version.
  11
  12 ;; GNU Emacs is distributed in the hope that it will be useful,
  13 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;; GNU General Public License for more details.
  16
  17 ;; You should have received a copy of the GNU General Public License
  18 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  19 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  20 ;; Boston, MA 02111-1307, USA.
  21
  22 (require 'viper-util)
  23
  24 ;;; Variables
  25
  26 ;; Register holding last macro.
  27 (defvar vip-last-macro-reg nil)
  28
  29 ;; format of the elements of kbd alists:
  30 ;; (name ((buf . macr)...(buf . macr)) ((maj-mode . macr)...) (t . macr))
  31 ;; kbd macro alist for Vi state
  32 (defvar vip-vi-kbd-macro-alist nil)
  33 ;; same for insert/replace state
  34 (defvar vip-insert-kbd-macro-alist nil)
  35 ;; same for emacs state
  36 (defvar vip-emacs-kbd-macro-alist nil)
  37
  38 ;; Internal var that passes info between start-kbd-macro and end-kbd-macro
  39 ;; in :map and :map!
  40 (defvar vip-kbd-macro-parameters nil)
  41
  42 (defvar vip-this-kbd-macro nil
  43   "Vector of keys representing the name of currently running Viper kbd macro.")
  44 (defvar vip-last-kbd-macro nil
  45   "Vector of keys representing the name of last Viper keyboard macro.")
  46
  47 (defconst vip-fast-keyseq-timeout 200
  48   "*Key sequence separated by no more than this many milliseconds is viewed as a macro, if such a macro is defined.
  49 This also controls ESC-keysequences generated by keyboard function keys.")
  50
  51
  52 (defvar vip-repeat-from-history-key 'f12
  53   "Prefix key for invocation of vip-repeat-from-history function,
  54 which repeats previous destructive commands from the history of such
  55 commands.
  56 This function can then be invoked as <this-key> 1 or <this-key> 2.
  57 The notation for these keys is borrowed from XEmacs. Basically,
  58 a key is a symbol, e.g., `a', `\\1', `f2', etc., or a list, e.g.,
  59 `(meta control f1)'.")
  60
  61
  62 \f
  63 ;;; Code
  64
  65 ;; Ex map command
  66 (defun ex-map ()
  67   (let ((mod-char "")
  68         macro-name macro-body map-args ins)
  69     (save-window-excursion
  70       (set-buffer vip-ex-work-buf)
  71       (if (looking-at "!")
  72           (progn
  73             (setq ins t
  74                   mod-char "!")
  75             (forward-char 1))))
  76     (setq map-args (ex-map-read-args mod-char)
  77           macro-name (car map-args)
  78           macro-body (cdr map-args))
  79     (setq vip-kbd-macro-parameters (list ins mod-char macro-name macro-body))
  80     (if macro-body
  81         (vip-end-mapping-kbd-macro 'ignore)
  82       (ex-fixup-history (format "map%s %S" mod-char
  83                                 (vip-display-macro macro-name)))
  84       ;; if defining macro for insert, switch there for authentic WYSIWYG
  85       (if ins (vip-change-state-to-insert))
  86       (start-kbd-macro nil)
  87       (define-key vip-vi-intercept-map "\C-x)" 'vip-end-mapping-kbd-macro)
  88       (define-key vip-insert-intercept-map "\C-x)" 'vip-end-mapping-kbd-macro)
  89       (define-key vip-emacs-intercept-map "\C-x)" 'vip-end-mapping-kbd-macro)
  90       (message "Mapping %S in %s state. Hit `C-x )' to complete the mapping"
  91                (vip-display-macro macro-name)
  92                (if ins "Insert" "Vi")))
  93     ))
  94
  95
  96 ;; Ex unmap
  97 (defun ex-unmap ()
  98   (let ((mod-char "")
  99         temp macro-name ins)
 100     (save-window-excursion
 101       (set-buffer vip-ex-work-buf)
 102       (if (looking-at "!")
 103           (progn
 104             (setq ins t
 105                   mod-char "!")
 106             (forward-char 1))))
 107
 108     (setq macro-name (ex-unmap-read-args mod-char))
 109     (setq temp (vip-fixup-macro (vconcat macro-name))) ;; copy and fixup
 110     (ex-fixup-history (format "unmap%s %S" mod-char
 111                               (vip-display-macro temp)))
 112     (vip-unrecord-kbd-macro macro-name (if ins 'insert-state 'vi-state))
 113     ))
 114
 115
 116 ;; read arguments for ex-map
 117 (defun ex-map-read-args (variant)
 118   (let ((cursor-in-echo-area t)
 119         (key-seq [])
 120         temp key event message
 121         macro-name macro-body args)
 122
 123     (condition-case nil
 124         (setq args (concat (ex-get-inline-cmd-args ".*map[!]*[ \t]?" "\n\C-m")
 125                            " nil nil ")
 126               temp (read-from-string args)
 127               macro-name (car temp)
 128               macro-body (car (read-from-string args (cdr temp))))
 129       (error
 130        (signal
 131         'error
 132         '("map: Macro name and body must be a quoted string or a vector"))))
 133
 134     ;; We expect macro-name to be a vector, a string, or a quoted string.
 135     ;; In the second case, it will emerge as a symbol when read from
 136     ;; the above read-from-string. So we need to convert it into a string
 137     (if macro-name
 138         (cond ((vectorp macro-name) nil)
 139               ((stringp macro-name)
 140                (setq macro-name (vconcat macro-name)))
 141               (t (setq macro-name (vconcat (prin1-to-string macro-name)))))
 142       (message ":map%s <Name>" variant)(sit-for 2)
 143       (while
 144           (not (member key
 145                        '(?\C-m ?\n (control m) (control j) return linefeed)))
 146         (setq key-seq (vconcat key-seq (if key (vector key) [])))
 147         ;; the only keys available for editing are these-- no help while there
 148         (if (member
 149              key
 150              '(?\b ?\d '^? '^H (control h) (control \?) backspace delete))
 151             (setq key-seq (subseq key-seq 0 (- (length key-seq) 2))))
 152         (setq message
 153               (format
 154                ":map%s %s"
 155                variant (if (> (length key-seq) 0)
 156                            (prin1-to-string (vip-display-macro key-seq))
 157                          "")))
 158         (message message)
 159         (setq event (vip-read-key))
 160         ;;(setq event (vip-read-event))
 161         (setq key
 162               (if (vip-mouse-event-p event)
 163                   (progn
 164                     (message "%s (No mouse---only keyboard keys, please)"
 165                              message)
 166                     (sit-for 2)
 167                     nil)
 168                 (vip-event-key event)))
 169         )
 170       (setq macro-name key-seq))
 171
 172     (if (= (length macro-name) 0)
 173         (error "Can't map an empty macro name"))
 174     (setq macro-name (vip-fixup-macro macro-name))
 175     (if (vip-char-array-p macro-name)
 176         (setq macro-name (vip-char-array-to-macro macro-name)))
 177
 178     (if macro-body
 179         (cond ((vip-char-array-p macro-body)
 180                (setq macro-body (vip-char-array-to-macro macro-body)))
 181               ((vectorp macro-body) nil)
 182               (t (error "map: Invalid syntax in macro definition"))))
 183     (setq cursor-in-echo-area nil)(sit-for 0) ; this overcomes xemacs tty bug
 184     (cons macro-name macro-body)))
 185
 186
 187
 188 ;; read arguments for ex-unmap
 189 (defun ex-unmap-read-args (variant)
 190   (let ((cursor-in-echo-area t)
 191         (macro-alist (if (string= variant "!")
 192                          vip-insert-kbd-macro-alist
 193                        vip-vi-kbd-macro-alist))
 194         ;; these are disabled just in case, to avoid surprises when doing
 195         ;; completing-read
 196         vip-vi-kbd-minor-mode vip-insert-kbd-minor-mode
 197         vip-emacs-kbd-minor-mode
 198         vip-vi-intercept-minor-mode vip-insert-intercept-minor-mode
 199         vip-emacs-intercept-minor-mode
 200         event message
 201         key key-seq macro-name)
 202     (setq macro-name (ex-get-inline-cmd-args ".*unma?p?[!]*[ \t]*"))
 203
 204     (if (> (length macro-name) 0)
 205         ()
 206       (message ":unmap%s <Name>" variant) (sit-for 2)
 207       (while
 208           (not
 209            (member key '(?\C-m ?\n (control m) (control j) return linefeed)))
 210         (setq key-seq (vconcat key-seq (if key (vector key) [])))
 211         ;; the only keys available for editing are these-- no help while there
 212         (cond ((member
 213                 key
 214                 '(?\b ?\d '^? '^H (control h) (control \?) backspace delete))
 215                (setq key-seq (subseq key-seq 0 (- (length key-seq) 2))))
 216               ((member key '(tab (control i) ?\t))
 217                (setq key-seq (subseq key-seq 0 (1- (length key-seq))))
 218                (setq message
 219                      (format
 220                       ":unmap%s %s"
 221                       variant (if (> (length key-seq) 0)
 222                                   (prin1-to-string
 223                                    (vip-display-macro key-seq))
 224                                 "")))
 225                (setq key-seq
 226                      (vip-do-sequence-completion key-seq macro-alist message))
 227                ))
 228         (setq message
 229               (format
 230                ":unmap%s %s"
 231                variant (if (> (length key-seq) 0)
 232                            (prin1-to-string
 233                             (vip-display-macro key-seq))
 234                          "")))
 235         (message message)
 236         (setq event (vip-read-key))
 237         ;;(setq event (vip-read-event))
 238         (setq key
 239               (if (vip-mouse-event-p event)
 240                   (progn
 241                     (message "%s (No mouse---only keyboard keys, please)"
 242                              message)
 243                     (sit-for 2)
 244                     nil)
 245                 (vip-event-key event)))
 246         )
 247       (setq macro-name key-seq))
 248
 249     (if (= (length macro-name) 0)
 250         (error "Can't unmap an empty macro name"))
 251
 252     ;; convert macro names into vector, if starts with a `['
 253     (if (memq (elt macro-name 0) '(?\[ ?\"))
 254         (car (read-from-string macro-name))
 255       (vconcat macro-name))
 256     ))
 257
 258
 259 ;; Terminate a Vi kbd macro.
 260 ;; optional argument IGNORE, if t, indicates that we are dealing with an
 261 ;; existing macro that needs to be registered, but there is no need to
 262 ;; terminate a kbd macro.
 263 (defun vip-end-mapping-kbd-macro (&optional ignore)
 264   (interactive)
 265   (define-key vip-vi-intercept-map "\C-x)" nil)
 266   (define-key vip-insert-intercept-map "\C-x)" nil)
 267   (define-key vip-emacs-intercept-map "\C-x)" nil)
 268   (if (and (not ignore)
 269            (or (not vip-kbd-macro-parameters)
 270                (not defining-kbd-macro)))
 271       (error "Not mapping a kbd-macro"))
 272   (let ((mod-char (nth 1 vip-kbd-macro-parameters))
 273         (ins (nth 0 vip-kbd-macro-parameters))
 274         (macro-name (nth 2 vip-kbd-macro-parameters))
 275         (macro-body (nth 3 vip-kbd-macro-parameters)))
 276     (setq vip-kbd-macro-parameters nil)
 277     (or ignore
 278         (progn
 279           (end-kbd-macro nil)
 280           (setq macro-body (vip-events-to-macro last-kbd-macro))
 281           ;; always go back to Vi, since this is where we started
 282           ;; defining macro
 283           (vip-change-state-to-vi)))
 284
 285     (vip-record-kbd-macro macro-name
 286                           (if ins 'insert-state 'vi-state)
 287                           (vip-display-macro macro-body))
 288
 289     (ex-fixup-history (format "map%s %S %S" mod-char
 290                               (vip-display-macro macro-name)
 291                               (vip-display-macro macro-body)))
 292     ))
 293
 294
 295
 296 (defadvice start-kbd-macro (after vip-kbd-advice activate)
 297   "Remove Viper's intercepting bindings for C-x ).
 298 This may be needed if the previous `:map' command terminated abnormally."
 299   (define-key vip-vi-intercept-map "\C-x)" nil)
 300   (define-key vip-insert-intercept-map "\C-x)" nil)
 301   (define-key vip-emacs-intercept-map "\C-x)" nil))
 302
 303
 304 \f
 305 ;;; Recording, unrecording, executing
 306
 307 ;; accepts as macro names: strings and vectors.
 308 ;; strings must be strings of characters; vectors must be vectors of keys
 309 ;; in canonic form. the canonic form is essentially the form used in XEmacs
 310 (defun vip-record-kbd-macro (macro-name state macro-body &optional scope)
 311   "Record a Vi macro. Can be used in `.vip' file to define permanent macros.
 312 MACRO-NAME is a string of characters or a vector of keys. STATE is
 313 either `vi-state' or `insert-state'. It specifies the Viper state in which to
 314 define the macro. MACRO-BODY is a string that represents the keyboard macro.
 315 Optional SCOPE says whether the macro should be global \(t\), mode-specific
 316 \(a major-mode symbol\), or buffer-specific \(buffer name, a string\).
 317 If SCOPE is nil, the user is asked to specify the scope."
 318   (let* (state-name keymap
 319          (macro-alist-var
 320           (cond ((eq state 'vi-state)
 321                  (setq state-name "Vi state"
 322                        keymap vip-vi-kbd-map)
 323                  'vip-vi-kbd-macro-alist)
 324                 ((memq state '(insert-state replace-state))
 325                  (setq state-name "Insert state"
 326                        keymap vip-insert-kbd-map)
 327                  'vip-insert-kbd-macro-alist)
 328                 (t
 329                  (setq state-name "Emacs state"
 330                        keymap vip-emacs-kbd-map)
 331                  'vip-emacs-kbd-macro-alist)
 332                  ))
 333          new-elt old-elt old-sub-elt msg
 334          temp lis lis2)
 335
 336     (if (= (length macro-name) 0)
 337         (error "Can't map an empty macro name"))
 338
 339     ;; Macro-name is usually a vector. However, command history or macros
 340     ;; recorded in ~/.vip may be recorded as strings. So, convert to vectors.
 341     (setq macro-name (vip-fixup-macro macro-name))
 342     (if (vip-char-array-p macro-name)
 343         (setq macro-name (vip-char-array-to-macro macro-name)))
 344     (setq macro-body (vip-fixup-macro macro-body))
 345     (if (vip-char-array-p macro-body)
 346         (setq macro-body (vip-char-array-to-macro macro-body)))
 347
 348     ;; don't ask if scope is given and is of the right type
 349     (or (eq scope t)
 350         (stringp scope)
 351         (and scope (symbolp scope))
 352         (progn
 353           (setq scope
 354                 (cond
 355                  ((y-or-n-p
 356                    (format
 357                     "Map this macro for buffer `%s' only? "
 358                     (buffer-name)))
 359                   (setq msg
 360                         (format
 361                          "%S is mapped to %s for %s in `%s'"
 362                          (vip-display-macro macro-name)
 363                          (vip-abbreviate-string
 364                           (format
 365                            "%S"
 366                            (setq temp (vip-display-macro macro-body)))
 367                           14 "" ""
 368                           (if (stringp temp) "  ....\"" "  ....]"))
 369                          state-name (buffer-name)))
 370                   (buffer-name))
 371                  ((y-or-n-p
 372                    (format
 373                     "Map this macro for the major mode `%S' only? "
 374                     major-mode))
 375                   (setq msg
 376                         (format
 377                          "%S is mapped to %s for %s in `%S'"
 378                          (vip-display-macro macro-name)
 379                          (vip-abbreviate-string
 380                           (format
 381                            "%S"
 382                            (setq temp (vip-display-macro macro-body)))
 383                           14 "" ""
 384                           (if (stringp macro-body) "  ....\"" "  ....]"))
 385                          state-name major-mode))
 386                   major-mode)
 387                  (t
 388                   (setq msg
 389                         (format
 390                          "%S is globally mapped to %s in %s"
 391                          (vip-display-macro macro-name)
 392                          (vip-abbreviate-string
 393                           (format
 394                            "%S"
 395                            (setq temp (vip-display-macro macro-body)))
 396                           14 "" ""
 397                           (if (stringp macro-body) "  ....\"" "  ....]"))
 398                          state-name))
 399                   t)))
 400           (if (y-or-n-p
 401                (format "Save this macro in %s? "
 402                        (vip-abbreviate-file-name vip-custom-file-name)))
 403               (vip-save-string-in-file
 404                (format "\n(vip-record-kbd-macro %S '%S %s '%S)"
 405                        (vip-display-macro macro-name)
 406                        state
 407                        ;; if we don't let vector macro-body through %S,
 408                        ;; the symbols `\.' `\[' etc will be converted into
 409                        ;; characters, causing invalid read  error on recorded
 410                        ;; macros in .vip.
 411                        ;; I am not sure is macro-body can still be a string at
 412                        ;; this point, but I am preserving this option anyway.
 413                        (if (vectorp macro-body)
 414                            (format "%S" macro-body)
 415                          macro-body)
 416                        scope)
 417                vip-custom-file-name))
 418
 419           (message msg)
 420           ))
 421
 422     (setq new-elt
 423           (cons macro-name
 424                 (cond ((eq scope t) (list nil nil (cons t nil)))
 425                       ((symbolp scope)
 426                        (list nil (list (cons scope nil)) (cons t nil)))
 427                       ((stringp scope)
 428                        (list (list (cons scope nil)) nil (cons t nil))))))
 429     (setq old-elt (assoc macro-name (eval macro-alist-var)))
 430
 431       (if (null old-elt)
 432           (progn
 433             ;; insert new-elt in macro-alist-var and keep the list sorted
 434             (define-key
 435               keymap
 436               (vector (vip-key-to-emacs-key (aref macro-name 0)))
 437               'vip-exec-mapped-kbd-macro)
 438             (setq lis (eval macro-alist-var))
 439             (while (and lis (string< (vip-array-to-string (car (car lis)))
 440                                      (vip-array-to-string macro-name)))
 441               (setq lis2 (cons (car lis) lis2))
 442               (setq lis (cdr lis)))
 443
 444             (setq lis2 (reverse lis2))
 445             (set macro-alist-var (append lis2 (cons new-elt lis)))
 446             (setq old-elt new-elt)))
 447     (setq old-sub-elt
 448           (cond ((eq scope t) (vip-kbd-global-pair old-elt))
 449                 ((symbolp scope) (assoc scope (vip-kbd-mode-alist old-elt)))
 450                 ((stringp scope) (assoc scope (vip-kbd-buf-alist old-elt)))))
 451     (if old-sub-elt
 452         (setcdr old-sub-elt macro-body)
 453       (cond ((symbolp scope) (setcar (cdr (cdr old-elt))
 454                                      (cons (cons scope macro-body)
 455                                            (vip-kbd-mode-alist old-elt))))
 456             ((stringp scope) (setcar (cdr old-elt)
 457                                      (cons (cons scope macro-body)
 458                                            (vip-kbd-buf-alist old-elt))))))
 459     ))
 460
 461
 462
 463 ;; macro name must be a vector of vip-style keys
 464 (defun vip-unrecord-kbd-macro (macro-name state)
 465   "Delete macro MACRO-NAME from Viper STATE.
 466 MACRO-NAME must be a vector of vip-style keys. This command is used by Viper
 467 internally, but the user can also use it in ~/.vip to delete pre-defined macros
 468 supplied with Viper. The best way to avoid mistakes in macro names to be passed
 469 to this function is to use vip-describe-kbd-macros and copy the name from
 470 there."
 471   (let* (state-name keymap
 472          (macro-alist-var
 473           (cond ((eq state 'vi-state)
 474                  (setq state-name "Vi state"
 475                        keymap vip-vi-kbd-map)
 476                  'vip-vi-kbd-macro-alist)
 477                 ((memq state '(insert-state replace-state))
 478                  (setq state-name "Insert state"
 479                        keymap vip-insert-kbd-map)
 480                  'vip-insert-kbd-macro-alist)
 481                 (t
 482                  (setq state-name "Emacs state"
 483                        keymap vip-emacs-kbd-map)
 484                  'vip-emacs-kbd-macro-alist)
 485                 ))
 486          buf-mapping mode-mapping global-mapping
 487          macro-pair macro-entry)
 488
 489     ;; Macro-name is usually a vector. However, command history or macros
 490     ;; recorded in ~/.vip may appear as strings. So, convert to vectors.
 491     (setq macro-name (vip-fixup-macro macro-name))
 492     (if (vip-char-array-p macro-name)
 493         (setq macro-name (vip-char-array-to-macro macro-name)))
 494
 495     (setq macro-entry (assoc macro-name (eval macro-alist-var)))
 496     (if (= (length macro-name) 0)
 497         (error "Can't unmap an empty macro name"))
 498     (if (null macro-entry)
 499         (error "%S is not mapped to a macro for %s in `%s'"
 500                (vip-display-macro macro-name)
 501                state-name (buffer-name)))
 502
 503     (setq buf-mapping (vip-kbd-buf-pair macro-entry)
 504           mode-mapping (vip-kbd-mode-pair macro-entry)
 505           global-mapping (vip-kbd-global-pair macro-entry))
 506
 507     (cond ((and (cdr buf-mapping)
 508                 (or (and (not (cdr mode-mapping)) (not (cdr global-mapping)))
 509                     (y-or-n-p
 510                      (format "Unmap %S for `%s' only? "
 511                              (vip-display-macro macro-name)
 512                              (buffer-name)))))
 513            (setq macro-pair buf-mapping)
 514            (message "%S is unmapped for %s in `%s'"
 515                     (vip-display-macro macro-name)
 516                     state-name (buffer-name)))
 517           ((and (cdr mode-mapping)
 518                 (or (not (cdr global-mapping))
 519                     (y-or-n-p
 520                      (format "Unmap %S for the major mode `%S' only? "
 521                              (vip-display-macro macro-name)
 522                              major-mode))))
 523            (setq macro-pair mode-mapping)
 524            (message "%S is unmapped for %s in %S"
 525                     (vip-display-macro macro-name) state-name major-mode))
 526           ((cdr (setq macro-pair (vip-kbd-global-pair macro-entry)))
 527            (message
 528             "Global mapping of %S for %s is removed"
 529             (vip-display-macro macro-name) state-name))
 530           (t (error "%S is not mapped to a macro for %s in `%s'"
 531                     (vip-display-macro macro-name)
 532                     state-name (buffer-name))))
 533     (setcdr macro-pair nil)
 534     (or (cdr buf-mapping)
 535         (cdr mode-mapping)
 536         (cdr global-mapping)
 537         (progn
 538           (set macro-alist-var (delq macro-entry (eval macro-alist-var)))
 539           (if (vip-can-release-key (aref macro-name 0)
 540                                    (eval macro-alist-var))
 541               (define-key
 542                 keymap
 543                 (vector (vip-key-to-emacs-key (aref macro-name 0)))
 544                 nil))
 545           ))
 546     ))
 547
 548 ;; Check if MACRO-ALIST has an entry for a macro name starting with
 549 ;; CHAR. If not, this indicates that the binding for this char
 550 ;; in vip-vi/insert-kbd-map can be released.
 551 (defun vip-can-release-key (char macro-alist)
 552   (let ((lis macro-alist)
 553         (can-release t)
 554         macro-name)
 555
 556     (while (and lis can-release)
 557       (setq macro-name (car (car lis)))
 558       (if (eq char (aref macro-name 0))
 559           (setq can-release nil))
 560       (setq lis (cdr lis)))
 561     can-release))
 562
 563
 564 (defun vip-exec-mapped-kbd-macro (count)
 565   "Dispatch kbd macro."
 566   (interactive "P")
 567   (let* ((macro-alist (cond ((eq vip-current-state 'vi-state)
 568                              vip-vi-kbd-macro-alist)
 569                             ((memq vip-current-state
 570                                    '(insert-state replace-state))
 571                              vip-insert-kbd-macro-alist)
 572                             (t
 573                              vip-emacs-kbd-macro-alist)))
 574         (unmatched-suffix "")
 575         ;; Macros and keys are executed with other macros turned off
 576         ;; For macros, this is done to avoid macro recursion
 577         vip-vi-kbd-minor-mode vip-insert-kbd-minor-mode
 578         vip-emacs-kbd-minor-mode
 579         next-best-match keyseq event-seq
 580         macro-first-char macro-alist-elt macro-body
 581         command)
 582
 583     (setq macro-first-char last-command-event
 584           event-seq (vip-read-fast-keysequence macro-first-char macro-alist)
 585           keyseq (vip-events-to-macro event-seq)
 586           macro-alist-elt (assoc keyseq macro-alist)
 587           next-best-match (vip-find-best-matching-macro macro-alist keyseq))
 588
 589     (if (null macro-alist-elt)
 590         (setq macro-alist-elt (car next-best-match)
 591               unmatched-suffix (subseq event-seq (cdr next-best-match))))
 592
 593     (cond ((null macro-alist-elt))
 594           ((setq macro-body (vip-kbd-buf-definition macro-alist-elt)))
 595           ((setq macro-body (vip-kbd-mode-definition macro-alist-elt)))
 596           ((setq macro-body (vip-kbd-global-definition macro-alist-elt))))
 597
 598     ;; when defining keyboard macro, don't use the macro mappings
 599     (if (and macro-body (not defining-kbd-macro))
 600         ;; block cmd executed as part of a macro from entering command history
 601         (let ((command-history command-history))
 602           (setq vip-this-kbd-macro (car macro-alist-elt))
 603           (execute-kbd-macro (vip-macro-to-events macro-body) count)
 604           (setq vip-this-kbd-macro nil
 605                 vip-last-kbd-macro (car macro-alist-elt))
 606           (vip-set-unread-command-events unmatched-suffix))
 607       ;; If not a macro, or the macro is suppressed while defining another
 608       ;; macro, put keyseq back on the event queue
 609       (vip-set-unread-command-events event-seq)
 610       ;; if the user typed arg, then use it if prefix arg is not set by
 611       ;; some other command (setting prefix arg can happen if we do, say,
 612       ;; 2dw and there is a macro starting with 2. Then control will go to
 613       ;; this routine
 614       (or prefix-arg (setq  prefix-arg count))
 615       (setq command (key-binding (read-key-sequence nil)))
 616       (if (commandp command)
 617           (command-execute command)
 618         (beep 1)))
 619     ))
 620
 621
 622 \f
 623 ;;; Displaying and completing macros
 624
 625 (defun vip-describe-kbd-macros ()
 626   "Show currently defined keyboard macros."
 627   (interactive)
 628   (with-output-to-temp-buffer " *vip-info*"
 629     (princ "Macros in Vi state:\n===================\n")
 630     (mapcar 'vip-describe-one-macro vip-vi-kbd-macro-alist)
 631     (princ "\n\nMacros in Insert and Replace states:\n====================================\n")
 632     (mapcar 'vip-describe-one-macro vip-insert-kbd-macro-alist)
 633     (princ "\n\nMacros in Emacs state:\n======================\n")
 634     (mapcar 'vip-describe-one-macro vip-emacs-kbd-macro-alist)
 635     ))
 636
 637 (defun vip-describe-one-macro (macro)
 638   (princ (format "\n  *** Mappings for %S:\n      ------------\n"
 639                  (vip-display-macro (car macro))))
 640   (princ "   ** Buffer-specific:")
 641   (if (vip-kbd-buf-alist macro)
 642       (mapcar 'vip-describe-one-macro-elt (vip-kbd-buf-alist macro))
 643     (princ "  none\n"))
 644   (princ "\n   ** Mode-specific:")
 645   (if (vip-kbd-mode-alist macro)
 646       (mapcar 'vip-describe-one-macro-elt (vip-kbd-mode-alist macro))
 647     (princ "  none\n"))
 648   (princ "\n   ** Global:")
 649   (if (vip-kbd-global-definition macro)
 650       (princ (format "\n           %S" (cdr (vip-kbd-global-pair macro))))
 651     (princ "  none"))
 652   (princ "\n"))
 653
 654 (defun vip-describe-one-macro-elt (elt)
 655   (let ((name (car elt))
 656         (defn (cdr elt)))
 657     (princ (format "\n       * %S:\n           %S\n" name defn))))
 658
 659
 660
 661 ;; check if SEQ is a prefix of some car of an element in ALIST
 662 (defun vip-keyseq-is-a-possible-macro (seq alist)
 663   (let ((converted-seq (vip-events-to-macro seq)))
 664     (eval (cons 'or
 665                 (mapcar
 666                  (function (lambda (elt)
 667                              (vip-prefix-subseq-p converted-seq elt)))
 668                  (vip-this-buffer-macros alist))))))
 669
 670 ;; whether SEQ1 is a prefix of SEQ2
 671 (defun vip-prefix-subseq-p (seq1 seq2)
 672   (let ((len1 (length seq1))
 673         (len2 (length seq2)))
 674     (if (<= len1 len2)
 675         (equal seq1 (subseq seq2 0 len1)))))
 676
 677 ;; find the longest common prefix
 678 (defun vip-common-seq-prefix (&rest seqs)
 679   (let* ((first (car seqs))
 680          (rest (cdr seqs))
 681          (pref [])
 682          (idx 0)
 683          len)
 684     (if (= (length seqs) 0)
 685         (setq len 0)
 686       (setq len (apply 'min (mapcar 'length seqs))))
 687     (while (< idx len)
 688       (if (eval (cons 'and
 689                       (mapcar (function (lambda (s)
 690                                           (equal (elt first idx)
 691                                                  (elt s idx))))
 692                               rest)))
 693           (setq pref (vconcat pref (vector (elt first idx)))))
 694       (setq idx (1+ idx)))
 695     pref))
 696
 697 ;; get all sequences that match PREFIX from a given A-LIST
 698 (defun vip-extract-matching-alist-members (pref alist)
 699   (delq nil (mapcar (function (lambda (elt)
 700                                 (if (vip-prefix-subseq-p pref elt)
 701                                     elt)))
 702                     (vip-this-buffer-macros alist))))
 703
 704 (defun vip-do-sequence-completion (seq alist compl-message)
 705   (let* ((matches (vip-extract-matching-alist-members seq alist))
 706          (new-seq (apply 'vip-common-seq-prefix matches))
 707          )
 708     (cond ((and (equal seq new-seq) (= (length matches) 1))
 709            (message "%s (Sole completion)" compl-message)
 710            (sit-for 2))
 711           ((null matches)
 712            (message "%s (No match)" compl-message)
 713            (sit-for 2)
 714            (setq new-seq seq))
 715           ((member seq matches)
 716            (message "%s (Complete, but not unique)" compl-message)
 717            (sit-for 2)
 718            (vip-display-vector-completions matches))
 719           ((equal seq new-seq)
 720            (vip-display-vector-completions matches)))
 721     new-seq))
 722
 723
 724 (defun vip-display-vector-completions (list)
 725   (with-output-to-temp-buffer "*Completions*"
 726     (display-completion-list
 727      (mapcar 'prin1-to-string
 728              (mapcar 'vip-display-macro list)))))
 729
 730
 731
 732 ;; alist is the alist of macros
 733 ;; str is the fast key sequence entered
 734 ;; returns: (matching-macro-def . unmatched-suffix-start-index)
 735 (defun vip-find-best-matching-macro (alist str)
 736   (let ((lis alist)
 737         (def-len 0)
 738         (str-len (length str))
 739         match unmatched-start-idx found macro-def)
 740     (while (and (not found) lis)
 741       (setq macro-def (car lis)
 742             def-len (length (car macro-def)))
 743       (if (and (>= str-len def-len)
 744                (equal (car macro-def) (subseq str 0 def-len)))
 745           (if (or (vip-kbd-buf-definition macro-def)
 746                   (vip-kbd-mode-definition macro-def)
 747                   (vip-kbd-global-definition macro-def))
 748               (setq found t))
 749         )
 750       (setq lis (cdr lis)))
 751
 752     (if found
 753         (setq match macro-def
 754               unmatched-start-idx def-len)
 755       (setq match nil
 756             unmatched-start-idx 0))
 757
 758     (cons match unmatched-start-idx)))
 759
 760
 761
 762 ;; returns a list of names of macros defined for the current buffer
 763 (defun vip-this-buffer-macros (macro-alist)
 764   (let (candidates)
 765     (setq candidates
 766           (mapcar (function
 767                    (lambda (elt)
 768                      (if (or (vip-kbd-buf-definition elt)
 769                              (vip-kbd-mode-definition elt)
 770                              (vip-kbd-global-definition elt))
 771                          (car elt))))
 772                   macro-alist))
 773     (setq candidates (delq nil candidates))))
 774
 775
 776 ;; if seq of Viper key symbols (representing a macro) can be converted to a
 777 ;; string--do so. Otherwise, do nothing.
 778 (defun vip-display-macro (macro-name-or-body)
 779   (cond ((vip-char-symbol-sequence-p macro-name-or-body)
 780          (mapconcat 'symbol-name macro-name-or-body ""))
 781         ((vip-char-array-p macro-name-or-body)
 782          (mapconcat 'char-to-string macro-name-or-body ""))
 783         (t macro-name-or-body)))
 784
 785 ;; convert sequence of events (that came presumably from emacs kbd macro) into
 786 ;; Viper's macro, which is a vector of the form
 787 ;; [ desc desc ... ]
 788 ;; Each desc is either a symbol of (meta symb), (shift symb), etc.
 789 ;; Here we purge events that happen to be lists. In most cases, these events
 790 ;; got into a macro definition unintentionally; say, when the user moves mouse
 791 ;; during a macro definition, then something like (switch-frame ...) might get
 792 ;; in. Another reason for purging lists-events is that we can't store them in
 793 ;; textual form (say, in .emacs) and then read them back.
 794 (defun vip-events-to-macro (event-seq)
 795   (vconcat (delq nil (mapcar (function (lambda (elt)
 796                                          (if (consp elt)
 797                                              nil
 798                                            (vip-event-key elt))))
 799                              event-seq))))
 800
 801 ;; convert strings or arrays of characters to Viper macro form
 802 (defun vip-char-array-to-macro (array)
 803   (let ((vec (vconcat array))
 804         macro)
 805     (if vip-xemacs-p
 806         (setq macro (mapcar 'character-to-event vec))
 807       (setq macro vec))
 808     (vconcat (mapcar 'vip-event-key macro))))
 809
 810 ;; For macros bodies and names, goes over MACRO and checks if all members are
 811 ;; names of keys (actually, it only checks if they are symbols or lists
 812 ;; if a digit is found, it is converted into a symbol (e.g., 0 -> \0, etc).
 813 ;; If MACRO is not a list or vector -- doesn't change MACRO.
 814 (defun vip-fixup-macro (macro)
 815   (let ((len (length macro))
 816         (idx 0)
 817         elt break)
 818     (if (or (vectorp macro) (listp macro))
 819         (while (and (< idx len) (not break))
 820           (setq elt (elt macro idx))
 821           (cond ((numberp elt)
 822                  ;; fix number
 823                  (if (and (<= 0 elt) (<= elt 9))
 824                      (cond ((arrayp macro)
 825                             (aset macro
 826                                   idx
 827                                   (intern (char-to-string (+ ?0 elt)))))
 828                            ((listp macro)
 829                             (setcar (nthcdr idx macro)
 830                                     (intern (char-to-string (+ ?0 elt)))))
 831                            )))
 832                 ((listp elt)
 833                  (vip-fixup-macro elt))
 834                 ((symbolp elt) nil)
 835                 (t (setq break t)))
 836           (setq idx (1+ idx))))
 837
 838       (if break
 839           (error "Wrong type macro component, symbol-or-listp, %S" elt)
 840         macro)))
 841
 842 (defun vip-char-array-p (array)
 843   (eval (cons 'and (mapcar 'numberp array))))
 844
 845 (defun vip-macro-to-events (macro-body)
 846   (vconcat (mapcar 'vip-key-to-emacs-key macro-body)))
 847
 848
 849 ;; check if vec is a vector of character symbols
 850 (defun vip-char-symbol-sequence-p (vec)
 851   (and
 852    (sequencep vec)
 853    (eval
 854     (cons 'and
 855           (mapcar
 856            (function (lambda (elt)
 857                        (and (symbolp elt) (= (length (symbol-name elt)) 1))))
 858            vec)))))
 859
 860
 861 ;; Check if vec is a vector of key-press events representing characters
 862 ;; XEmacs only
 863 (defun vip-event-vector-p (vec)
 864   (and (vectorp vec)
 865        (eval (cons 'and (mapcar '(lambda (elt) (if (eventp elt) t)) vec)))))
 866
 867 \f
 868 ;;; Reading fast key sequences
 869
 870 ;; Assuming that CHAR was the first character in a fast succession of key
 871 ;; strokes, read the rest. Return the vector of keys that was entered in
 872 ;; this fast succession of key strokes.
 873 ;; A fast keysequence is one that is terminated by a pause longer than
 874 ;; vip-fast-keyseq-timeout.
 875 (defun vip-read-fast-keysequence (event macro-alist)
 876   (let ((lis (vector event))
 877         next-event)
 878     (while (and (vip-fast-keysequence-p)
 879                 (vip-keyseq-is-a-possible-macro lis macro-alist))
 880       (setq next-event (vip-read-key))
 881       ;;(setq next-event (vip-read-event))
 882       (or (vip-mouse-event-p next-event)
 883           (setq lis (vconcat lis (vector next-event)))))
 884     lis))
 885
 886 \f
 887 ;;; Keyboard macros in registers
 888
 889 ;; sets register to last-kbd-macro carefully.
 890 (defun vip-set-register-macro (reg)
 891   (if (get-register reg)
 892       (if (y-or-n-p "Register contains data. Overwrite? ")
 893           ()
 894         (error
 895          "Macro not saved in register. Can still be invoked via `C-x e'")))
 896   (set-register reg last-kbd-macro))
 897
 898 (defun vip-register-macro (count)
 899   "Keyboard macros in registers - a modified \@ command."
 900   (interactive "P")
 901   (let ((reg (downcase (read-char))))
 902     (cond ((or (and (<= ?a reg) (<= reg ?z)))
 903            (setq vip-last-macro-reg reg)
 904            (if defining-kbd-macro
 905                (progn
 906                  (end-kbd-macro)
 907                  (vip-set-register-macro reg))
 908              (execute-kbd-macro (get-register reg) count)))
 909           ((or (= ?@ reg) (= ?\^j reg) (= ?\^m reg))
 910            (if vip-last-macro-reg
 911                nil
 912                (error "No previous kbd macro"))
 913            (execute-kbd-macro (get-register vip-last-macro-reg) count))
 914           ((= ?\# reg)
 915            (start-kbd-macro count))
 916           ((= ?! reg)
 917            (setq reg (downcase (read-char)))
 918            (if (or (and (<= ?a reg) (<= reg ?z)))
 919                (progn
 920                (setq vip-last-macro-reg reg)
 921                (vip-set-register-macro reg))))
 922           (t
 923            (error "`%c': Unknown register" reg)))))
 924
 925
 926 (defun vip-global-execute ()
 927   "Call last keyboad macro for each line in the region."
 928   (if (> (point) (mark t)) (exchange-point-and-mark))
 929   (beginning-of-line)
 930   (call-last-kbd-macro)
 931   (while (< (point) (mark t))
 932     (forward-line 1)
 933     (beginning-of-line)
 934     (call-last-kbd-macro)))
 935
 936
 937 (provide 'viper-macs)
 938
 939 ;;;  viper-macs.el ends here