lisp/edmacro.el

   1 ;;; edmacro.el --- keyboard macro editor
   2
   3 ;; Copyright (C) 1993, 1994 Free Software Foundation, Inc.
   4
   5 ;; Author: Dave Gillespie <daveg@synaptics.com>
   6 ;; Maintainer: Dave Gillespie <daveg@synaptics.com>
   7 ;; Version: 2.01
   8 ;; Keywords: abbrev
   9
  10 ;; This file is part of GNU Emacs.
  11
  12 ;; GNU Emacs is free software; you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation; either version 2, or (at your option)
  15 ;; any later version.
  16
  17 ;; GNU Emacs is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  25 ;; Boston, MA 02111-1307, USA.
  26
  27 ;;; Commentary:
  28
  29 ;;; Usage:
  30 ;;
  31 ;; The `C-x C-k' (`edit-kbd-macro') command edits a keyboard macro
  32 ;; in a special buffer.  It prompts you to type a key sequence,
  33 ;; which should be one of:
  34 ;;
  35 ;;  * RET or `C-x e' (call-last-kbd-macro), to edit the most
  36 ;;    recently defined keyboard macro.
  37 ;;
  38 ;;  * `M-x' followed by a command name, to edit a named command
  39 ;;    whose definition is a keyboard macro.
  40 ;;
  41 ;;  * `C-h l' (view-lossage), to edit the 100 most recent keystrokes
  42 ;;    and install them as the "current" macro.
  43 ;;
  44 ;;  * any key sequence whose definition is a keyboard macro.
  45 ;;
  46 ;; This file includes a version of `insert-kbd-macro' that uses the
  47 ;; more readable format defined by these routines.
  48 ;;
  49 ;; Also, the `read-kbd-macro' command parses the region as
  50 ;; a keyboard macro, and installs it as the "current" macro.
  51 ;; This and `format-kbd-macro' can also be called directly as
  52 ;; Lisp functions.
  53
  54 ;; Type `C-h m', or see the documentation for `edmacro-mode' below,
  55 ;; for information about the format of written keyboard macros.
  56
  57 ;; `edit-kbd-macro' formats the macro with one command per line,
  58 ;; including the command names as comments on the right.  If the
  59 ;; formatter gets confused about which keymap was used for the
  60 ;; characters, the command-name comments will be wrong but that
  61 ;; won't hurt anything.
  62
  63 ;; With a prefix argument, `edit-kbd-macro' will format the
  64 ;; macro in a more concise way that omits the comments.
  65
  66 ;; This package requires GNU Emacs 19 or later, and daveg's CL
  67 ;; package 2.02 or later.  (CL 2.02 comes standard starting with
  68 ;; Emacs 19.18.)  This package does not work with Emacs 18 or
  69 ;; Lucid Emacs.
  70
  71 ;;; Code:
  72 \f
  73 (eval-when-compile
  74  (require 'cl))
  75
  76 ;;; The user-level commands for editing macros.
  77
  78 ;;;###autoload (define-key ctl-x-map "\C-k" 'edit-kbd-macro)
  79
  80 ;;;###autoload
  81 (defvar edmacro-eight-bits nil
  82   "*Non-nil if edit-kbd-macro should leave 8-bit characters intact.
  83 Default nil means to write characters above \\177 in octal notation.")
  84
  85 (defvar edmacro-mode-map nil)
  86 (unless edmacro-mode-map
  87   (setq edmacro-mode-map (make-sparse-keymap))
  88   (define-key edmacro-mode-map "\C-c\C-c" 'edmacro-finish-edit)
  89   (define-key edmacro-mode-map "\C-c\C-q" 'edmacro-insert-key))
  90
  91 (defvar edmacro-store-hook)
  92 (defvar edmacro-finish-hook)
  93 (defvar edmacro-original-buffer)
  94
  95 ;;;###autoload
  96 (defun edit-kbd-macro (keys &optional prefix finish-hook store-hook)
  97   "Edit a keyboard macro.
  98 At the prompt, type any key sequence which is bound to a keyboard macro.
  99 Or, type `C-x e' or RET to edit the last keyboard macro, `C-h l' to edit
 100 the last 100 keystrokes as a keyboard macro, or `M-x' to edit a macro by
 101 its command name.
 102 With a prefix argument, format the macro in a more concise way."
 103   (interactive "kKeyboard macro to edit (C-x e, M-x, C-h l, or keys): \nP")
 104   (when keys
 105     (let ((cmd (if (arrayp keys) (key-binding keys) keys))
 106           (mac nil))
 107       (cond (store-hook
 108              (setq mac keys)
 109              (setq cmd nil))
 110             ((or (eq cmd 'call-last-kbd-macro)
 111                  (member keys '("\r" [return])))
 112              (or last-kbd-macro
 113                  (y-or-n-p "No keyboard macro defined.  Create one? ")
 114                  (keyboard-quit))
 115              (setq mac (or last-kbd-macro ""))
 116              (setq cmd 'last-kbd-macro))
 117             ((eq cmd 'execute-extended-command)
 118              (setq cmd (read-command "Name of keyboard macro to edit: "))
 119              (if (string-equal cmd "")
 120                  (error "No command name given"))
 121              (setq mac (symbol-function cmd)))
 122             ((memq cmd '(view-lossage electric-view-lossage))
 123              (setq mac (recent-keys))
 124              (setq cmd 'last-kbd-macro))
 125             ((null cmd)
 126              (error "Key sequence %s is not defined" (key-description keys)))
 127             ((symbolp cmd)
 128              (setq mac (symbol-function cmd)))
 129             (t
 130              (setq mac cmd)
 131              (setq cmd nil)))
 132       (unless (arrayp mac)
 133         (error "Key sequence %s is not a keyboard macro"
 134                (key-description keys)))
 135       (message "Formatting keyboard macro...")
 136       (let* ((oldbuf (current-buffer))
 137              (mmac (edmacro-fix-menu-commands mac))
 138              (fmt (edmacro-format-keys mmac 1))
 139              (fmtv (edmacro-format-keys mmac (not prefix)))
 140              (buf (get-buffer-create "*Edit Macro*")))
 141         (message "Formatting keyboard macro...done")
 142         (switch-to-buffer buf)
 143         (kill-all-local-variables)
 144         (use-local-map edmacro-mode-map)
 145         (setq buffer-read-only nil)
 146         (setq major-mode 'edmacro-mode)
 147         (setq mode-name "Edit Macro")
 148         (set (make-local-variable 'edmacro-original-buffer) oldbuf)
 149         (set (make-local-variable 'edmacro-finish-hook) finish-hook)
 150         (set (make-local-variable 'edmacro-store-hook) store-hook)
 151         (erase-buffer)
 152         (insert ";; Keyboard Macro Editor.  Press C-c C-c to finish; "
 153                 "press C-x k RET to cancel.\n")
 154         (insert ";; Original keys: " fmt "\n")
 155         (unless store-hook
 156           (insert "\nCommand: " (if cmd (symbol-name cmd) "none") "\n")
 157           (let ((keys (where-is-internal (or cmd mac) '(keymap))))
 158             (if keys
 159                 (while keys
 160                   (insert "Key: " (edmacro-format-keys (pop keys) 1) "\n"))
 161               (insert "Key: none\n"))))
 162         (insert "\nMacro:\n\n")
 163         (save-excursion
 164           (insert fmtv "\n"))
 165         (recenter '(4))
 166         (when (eq mac mmac)
 167           (set-buffer-modified-p nil))
 168         (run-hooks 'edmacro-format-hook)))))
 169
 170 ;;; The next two commands are provided for convenience and backward
 171 ;;; compatibility.
 172
 173 ;;;###autoload
 174 (defun edit-last-kbd-macro (&optional prefix)
 175   "Edit the most recently defined keyboard macro."
 176   (interactive "P")
 177   (edit-kbd-macro 'call-last-kbd-macro prefix))
 178
 179 ;;;###autoload
 180 (defun edit-named-kbd-macro (&optional prefix)
 181   "Edit a keyboard macro which has been given a name by `name-last-kbd-macro'."
 182   (interactive "P")
 183   (edit-kbd-macro 'execute-extended-command prefix))
 184
 185 ;;;###autoload
 186 (defun read-kbd-macro (start &optional end)
 187   "Read the region as a keyboard macro definition.
 188 The region is interpreted as spelled-out keystrokes, e.g., \"M-x abc RET\".
 189 See documentation for `edmacro-mode' for details.
 190 Leading/trailing \"C-x (\" and \"C-x )\" in the text are allowed and ignored.
 191 The resulting macro is installed as the \"current\" keyboard macro.
 192
 193 In Lisp, may also be called with a single STRING argument in which case
 194 the result is returned rather than being installed as the current macro.
 195 The result will be a string if possible, otherwise an event vector.
 196 Second argument NEED-VECTOR means to return an event vector always."
 197   (interactive "r")
 198   (if (stringp start)
 199       (edmacro-parse-keys start end)
 200     (setq last-kbd-macro (edmacro-parse-keys (buffer-substring start end)))))
 201
 202 ;;;###autoload
 203 (defun format-kbd-macro (&optional macro verbose)
 204   "Return the keyboard macro MACRO as a human-readable string.
 205 This string is suitable for passing to `read-kbd-macro'.
 206 Second argument VERBOSE means to put one command per line with comments.
 207 If VERBOSE is `1', put everything on one line.  If VERBOSE is omitted
 208 or nil, use a compact 80-column format."
 209   (and macro (symbolp macro) (setq macro (symbol-function macro)))
 210   (edmacro-format-keys (or macro last-kbd-macro) verbose))
 211 \f
 212 ;;; Commands for *Edit Macro* buffer.
 213
 214 (defun edmacro-finish-edit ()
 215   (interactive)
 216   (unless (eq major-mode 'edmacro-mode)
 217     (error
 218      "This command is valid only in buffers created by `edit-kbd-macro'"))
 219   (run-hooks 'edmacro-finish-hook)
 220   (let ((cmd nil) (keys nil) (no-keys nil)
 221         (top (point-min)))
 222     (goto-char top)
 223     (let ((case-fold-search nil))
 224       (while (cond ((looking-at "[ \t]*\\($\\|;;\\|REM[ \t\n]\\)")
 225                     t)
 226                    ((looking-at "Command:[ \t]*\\([^ \t\n]*\\)[ \t]*$")
 227                     (when edmacro-store-hook
 228                       (error "\"Command\" line not allowed in this context"))
 229                     (let ((str (buffer-substring (match-beginning 1)
 230                                                  (match-end 1))))
 231                       (unless (equal str "")
 232                         (setq cmd (and (not (equal str "none"))
 233                                        (intern str)))
 234                         (and (fboundp cmd) (not (arrayp (symbol-function cmd)))
 235                              (not (y-or-n-p
 236                                    (format "Command %s is already defined; %s"
 237                                            cmd "proceed? ")))
 238                              (keyboard-quit))))
 239                     t)
 240                    ((looking-at "Key:\\(.*\\)$")
 241                     (when edmacro-store-hook
 242                       (error "\"Key\" line not allowed in this context"))
 243                     (let ((key (edmacro-parse-keys
 244                                 (buffer-substring (match-beginning 1)
 245                                                   (match-end 1)))))
 246                       (unless (equal key "")
 247                         (if (equal key "none")
 248                             (setq no-keys t)
 249                           (push key keys)
 250                           (let ((b (key-binding key)))
 251                             (and b (commandp b) (not (arrayp b))
 252                                  (or (not (fboundp b))
 253                                      (not (arrayp (symbol-function b))))
 254                                  (not (y-or-n-p
 255                                        (format "Key %s is already defined; %s"
 256                                                (edmacro-format-keys key 1)
 257                                                "proceed? ")))
 258                                  (keyboard-quit))))))
 259                     t)
 260                    ((looking-at "Macro:[ \t\n]*")
 261                     (goto-char (match-end 0))
 262                     nil)
 263                    ((eobp) nil)
 264                    (t (error "Expected a `Macro:' line")))
 265         (forward-line 1))
 266       (setq top (point)))
 267     (let* ((buf (current-buffer))
 268            (str (buffer-substring top (point-max)))
 269            (modp (buffer-modified-p))
 270            (obuf edmacro-original-buffer)
 271            (store-hook edmacro-store-hook)
 272            (finish-hook edmacro-finish-hook))
 273       (unless (or cmd keys store-hook (equal str ""))
 274         (error "No command name or keys specified"))
 275       (when modp
 276         (when (buffer-name obuf)
 277           (set-buffer obuf))
 278         (message "Compiling keyboard macro...")
 279         (let ((mac (edmacro-parse-keys str)))
 280           (message "Compiling keyboard macro...done")
 281           (if store-hook
 282               (funcall store-hook mac)
 283             (when (eq cmd 'last-kbd-macro)
 284               (setq last-kbd-macro (and (> (length mac) 0) mac))
 285               (setq cmd nil))
 286             (when cmd
 287               (if (= (length mac) 0)
 288                   (fmakunbound cmd)
 289                 (fset cmd mac)))
 290             (if no-keys
 291                 (when cmd
 292                   (loop for key in (where-is-internal cmd '(keymap)) do
 293                         (global-unset-key key)))
 294               (when keys
 295                 (if (= (length mac) 0)
 296                     (loop for key in keys do (global-unset-key key))
 297                   (loop for key in keys do
 298                         (global-set-key key (or cmd mac)))))))))
 299       (kill-buffer buf)
 300       (when (buffer-name obuf)
 301         (switch-to-buffer obuf))
 302       (when finish-hook
 303         (funcall finish-hook)))))
 304
 305 (defun edmacro-insert-key (key)
 306   "Insert the written name of a key in the buffer."
 307   (interactive "kKey to insert: ")
 308   (if (bolp)
 309       (insert (edmacro-format-keys key t) "\n")
 310     (insert (edmacro-format-keys key) " ")))
 311
 312 (defun edmacro-mode ()
 313   "\\<edmacro-mode-map>Keyboard Macro Editing mode.  Press
 314 \\[edmacro-finish-edit] to save and exit.
 315 To abort the edit, just kill this buffer with \\[kill-buffer] RET.
 316
 317 Press \\[edmacro-insert-key] to insert the name of any key by typing the key.
 318
 319 The editing buffer contains a \"Command:\" line and any number of
 320 \"Key:\" lines at the top.  These are followed by a \"Macro:\" line
 321 and the macro itself as spelled-out keystrokes: `C-x C-f foo RET'.
 322
 323 The \"Command:\" line specifies the command name to which the macro
 324 is bound, or \"none\" for no command name.  Write \"last-kbd-macro\"
 325 to refer to the current keyboard macro (as used by \\[call-last-kbd-macro]).
 326
 327 The \"Key:\" lines specify key sequences to which the macro is bound,
 328 or \"none\" for no key bindings.
 329
 330 You can edit these lines to change the places where the new macro
 331 is stored.
 332
 333
 334 Format of keyboard macros during editing:
 335
 336 Text is divided into \"words\" separated by whitespace.  Except for
 337 the words described below, the characters of each word go directly
 338 as characters of the macro.  The whitespace that separates words
 339 is ignored.  Whitespace in the macro must be written explicitly,
 340 as in \"foo SPC bar RET\".
 341
 342  * The special words RET, SPC, TAB, DEL, LFD, ESC, and NUL represent
 343    special control characters.  The words must be written in uppercase.
 344
 345  * A word in angle brackets, e.g., <return>, <down>, or <f1>, represents
 346    a function key.  (Note that in the standard configuration, the
 347    function key <return> and the control key RET are synonymous.)
 348    You can use angle brackets on the words RET, SPC, etc., but they
 349    are not required there.
 350
 351  * Keys can be written by their ASCII code, using a backslash followed
 352    by up to six octal digits.  This is the only way to represent keys
 353    with codes above \\377.
 354
 355  * One or more prefixes M- (meta), C- (control), S- (shift), A- (alt),
 356    H- (hyper), and s- (super) may precede a character or key notation.
 357    For function keys, the prefixes may go inside or outside of the
 358    brackets:  C-<down> = <C-down>.  The prefixes may be written in
 359    any order:  M-C-x = C-M-x.
 360
 361    Prefixes are not allowed on multi-key words, e.g., C-abc, except
 362    that the Meta prefix is allowed on a sequence of digits and optional
 363    minus sign:  M--123 = M-- M-1 M-2 M-3.
 364
 365  * The `^' notation for control characters also works:  ^M = C-m.
 366
 367  * Double angle brackets enclose command names:  <<next-line>> is
 368    shorthand for M-x next-line RET.
 369
 370  * Finally, REM or ;; causes the rest of the line to be ignored as a
 371    comment.
 372
 373 Any word may be prefixed by a multiplier in the form of a decimal
 374 number and `*':  3*<right> = <right> <right> <right>, and
 375 10*foo = foofoofoofoofoofoofoofoofoofoo.
 376
 377 Multiple text keys can normally be strung together to form a word,
 378 but you may need to add whitespace if the word would look like one
 379 of the above notations:  `; ; ;' is a keyboard macro with three
 380 semicolons, but `;;;' is a comment.  Likewise, `\\ 1 2 3' is four
 381 keys but `\\123' is a single key written in octal, and `< right >'
 382 is seven keys but `<right>' is a single function key.  When in
 383 doubt, use whitespace."
 384   (interactive)
 385   (error "This mode can be enabled only by `edit-kbd-macro'"))
 386 (put 'edmacro-mode 'mode-class 'special)
 387 \f
 388 ;;; Formatting a keyboard macro as human-readable text.
 389
 390 (defun edmacro-format-keys (macro &optional verbose)
 391   (setq macro (edmacro-fix-menu-commands macro))
 392   (let* ((maps (append (current-minor-mode-maps)
 393                        (if (current-local-map)
 394                            (list (current-local-map)))
 395                        (list (current-global-map))))
 396          (pkeys '(end-macro ?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9 ?- ?\C-u
 397                   ?\M-- ?\M-0 ?\M-1 ?\M-2 ?\M-3 ?\M-4 ?\M-5 ?\M-6
 398                   ?\M-7 ?\M-8 ?\M-9))
 399          (mdigs (nthcdr 13 pkeys))
 400          (maxkey (if edmacro-eight-bits 255 127))
 401          (case-fold-search nil)
 402          (res-words '("NUL" "TAB" "LFD" "RET" "ESC" "SPC" "DEL" "REM"))
 403          (rest-mac (vconcat macro [end-macro]))
 404          (res "")
 405          (len 0)
 406          (one-line (eq verbose 1)))
 407     (if one-line (setq verbose nil))
 408     (when (stringp macro)
 409       (loop for i below (length macro) do
 410             (when (>= (aref rest-mac i) 128)
 411               (incf (aref rest-mac i) (- ?\M-\^@ 128)))))
 412     (while (not (eq (aref rest-mac 0) 'end-macro))
 413       (let* ((prefix
 414               (or (and (integerp (aref rest-mac 0))
 415                        (memq (aref rest-mac 0) mdigs)
 416                        (memq (key-binding (edmacro-subseq rest-mac 0 1))
 417                              '(digit-argument negative-argument))
 418                        (let ((i 1))
 419                          (while (memq (aref rest-mac i) (cdr mdigs))
 420                            (incf i))
 421                          (and (not (memq (aref rest-mac i) pkeys))
 422                               (prog1 (concat "M-" (edmacro-subseq rest-mac 0 i) " ")
 423                                 (callf edmacro-subseq rest-mac i)))))
 424                   (and (eq (aref rest-mac 0) ?\C-u)
 425                        (eq (key-binding [?\C-u]) 'universal-argument)
 426                        (let ((i 1))
 427                          (while (eq (aref rest-mac i) ?\C-u)
 428                            (incf i))
 429                          (and (not (memq (aref rest-mac i) pkeys))
 430                               (prog1 (loop repeat i concat "C-u ")
 431                                 (callf edmacro-subseq rest-mac i)))))
 432                   (and (eq (aref rest-mac 0) ?\C-u)
 433                        (eq (key-binding [?\C-u]) 'universal-argument)
 434                        (let ((i 1))
 435                          (when (eq (aref rest-mac i) ?-)
 436                            (incf i))
 437                          (while (memq (aref rest-mac i)
 438                                       '(?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9))
 439                            (incf i))
 440                          (and (not (memq (aref rest-mac i) pkeys))
 441                               (prog1 (concat "C-u " (edmacro-subseq rest-mac 1 i) " ")
 442                                 (callf edmacro-subseq rest-mac i)))))))
 443              (bind-len (apply 'max 1
 444                               (loop for map in maps
 445                                     for b = (lookup-key map rest-mac)
 446                                     when b collect b)))
 447              (key (edmacro-subseq rest-mac 0 bind-len))
 448              (fkey nil) tlen tkey
 449              (bind (or (loop for map in maps for b = (lookup-key map key)
 450                              thereis (and (not (integerp b)) b))
 451                        (and (setq fkey (lookup-key function-key-map rest-mac))
 452                             (setq tlen fkey tkey (edmacro-subseq rest-mac 0 tlen)
 453                                   fkey (lookup-key function-key-map tkey))
 454                             (loop for map in maps
 455                                   for b = (lookup-key map fkey)
 456                                   when (and (not (integerp b)) b)
 457                                   do (setq bind-len tlen key tkey)
 458                                   and return b
 459                                   finally do (setq fkey nil)))))
 460              (first (aref key 0))
 461              (text (loop for i from bind-len below (length rest-mac)
 462                          for ch = (aref rest-mac i)
 463                          while (and (integerp ch)
 464                                     (> ch 32) (< ch maxkey) (/= ch 92)
 465                                     (eq (key-binding (char-to-string ch))
 466                                         'self-insert-command)
 467                                     (or (> i (- (length rest-mac) 2))
 468                                         (not (eq ch (aref rest-mac (+ i 1))))
 469                                         (not (eq ch (aref rest-mac (+ i 2))))))
 470                          finally return i))
 471              desc)
 472         (if (stringp bind) (setq bind nil))
 473         (cond ((and (eq bind 'self-insert-command) (not prefix)
 474                     (> text 1) (integerp first)
 475                     (> first 32) (<= first maxkey) (/= first 92)
 476                     (progn
 477                       (if (> text 30) (setq text 30))
 478                       (setq desc (concat (edmacro-subseq rest-mac 0 text)))
 479                       (when (string-match "^[ACHMsS]-." desc)
 480                         (setq text 2)
 481                         (callf substring desc 0 2))
 482                       (not (string-match
 483                             "^;;\\|^<.*>$\\|^\\\\[0-9]+$\\|^[0-9]+\\*."
 484                             desc))))
 485                (when (or (string-match "^\\^.$" desc)
 486                          (member desc res-words))
 487                  (setq desc (mapconcat 'char-to-string desc " ")))
 488                (when verbose
 489                  (setq bind (format "%s * %d" bind text)))
 490                (setq bind-len text))
 491               ((and (eq bind 'execute-extended-command)
 492                     (> text bind-len)
 493                     (memq (aref rest-mac text) '(return 13))
 494                     (progn
 495                       (setq desc (concat (edmacro-subseq rest-mac bind-len text)))
 496                       (commandp (intern-soft desc))))
 497                (if (commandp (intern-soft desc)) (setq bind desc))
 498                (setq desc (format "<<%s>>" desc))
 499                (setq bind-len (1+ text)))
 500               (t
 501                (setq desc (mapconcat
 502                            (function
 503                             (lambda (ch)
 504                               (cond
 505                                ((integerp ch)
 506                                 (concat
 507                                  (loop for pf across "ACHMsS"
 508                                        for bit in '(?\A-\^@ ?\C-\^@ ?\H-\^@
 509                                                     ?\M-\^@ ?\s-\^@ ?\S-\^@)
 510                                        when (/= (logand ch bit) 0)
 511                                        concat (format "%c-" pf))
 512                                  (let ((ch2 (logand ch (1- (lsh 1 18)))))
 513                                    (cond ((<= ch2 32)
 514                                           (case ch2
 515                                             (0 "NUL") (9 "TAB") (10 "LFD")
 516                                             (13 "RET") (27 "ESC") (32 "SPC")
 517                                             (t
 518                                              (format "C-%c"
 519                                                      (+ (if (<= ch2 26) 96 64)
 520                                                         ch2)))))
 521                                          ((= ch2 127) "DEL")
 522                                          ((<= ch2 maxkey) (char-to-string ch2))
 523                                          (t (format "\\%o" ch2))))))
 524                                ((symbolp ch)
 525                                 (format "<%s>" ch))
 526                                (t
 527                                 (error "Unrecognized item in macro: %s" ch)))))
 528                            (or fkey key) " "))))
 529         (if prefix (setq desc (concat prefix desc)))
 530         (unless (string-match " " desc)
 531           (let ((times 1) (pos bind-len))
 532             (while (not (edmacro-mismatch rest-mac rest-mac
 533                                           0 bind-len pos (+ bind-len pos)))
 534               (incf times)
 535               (incf pos bind-len))
 536             (when (> times 1)
 537               (setq desc (format "%d*%s" times desc))
 538               (setq bind-len (* bind-len times)))))
 539         (setq rest-mac (edmacro-subseq rest-mac bind-len))
 540         (if verbose
 541             (progn
 542               (unless (equal res "") (callf concat res "\n"))
 543               (callf concat res desc)
 544               (when (and bind (or (stringp bind) (symbolp bind)))
 545                 (callf concat res
 546                   (make-string (max (- 3 (/ (length desc) 8)) 1) 9)
 547                   ";; " (if (stringp bind) bind (symbol-name bind))))
 548               (setq len 0))
 549           (if (and (> (+ len (length desc) 2) 72) (not one-line))
 550               (progn
 551                 (callf concat res "\n ")
 552                 (setq len 1))
 553             (unless (equal res "")
 554               (callf concat res " ")
 555               (incf len)))
 556           (callf concat res desc)
 557           (incf len (length desc)))))
 558     res))
 559
 560 (defun edmacro-mismatch (cl-seq1 cl-seq2 cl-start1 cl-end1 cl-start2 cl-end2)
 561   "Compare SEQ1 with SEQ2, return index of first mismatching element.
 562 Return nil if the sequences match.  If one sequence is a prefix of the
 563 other, the return value indicates the end of the shorted sequence."
 564   (let (cl-test cl-test-not cl-key cl-from-end)
 565     (or cl-end1 (setq cl-end1 (length cl-seq1)))
 566     (or cl-end2 (setq cl-end2 (length cl-seq2)))
 567     (if cl-from-end
 568         (progn
 569           (while (and (< cl-start1 cl-end1) (< cl-start2 cl-end2)
 570                       (cl-check-match (elt cl-seq1 (1- cl-end1))
 571                                       (elt cl-seq2 (1- cl-end2))))
 572             (setq cl-end1 (1- cl-end1) cl-end2 (1- cl-end2)))
 573           (and (or (< cl-start1 cl-end1) (< cl-start2 cl-end2))
 574                (1- cl-end1)))
 575       (let ((cl-p1 (and (listp cl-seq1) (nthcdr cl-start1 cl-seq1)))
 576             (cl-p2 (and (listp cl-seq2) (nthcdr cl-start2 cl-seq2))))
 577         (while (and (< cl-start1 cl-end1) (< cl-start2 cl-end2)
 578                     (cl-check-match (if cl-p1 (car cl-p1)
 579                                       (aref cl-seq1 cl-start1))
 580                                     (if cl-p2 (car cl-p2)
 581                                       (aref cl-seq2 cl-start2))))
 582           (setq cl-p1 (cdr cl-p1) cl-p2 (cdr cl-p2)
 583                 cl-start1 (1+ cl-start1) cl-start2 (1+ cl-start2)))
 584         (and (or (< cl-start1 cl-end1) (< cl-start2 cl-end2))
 585              cl-start1)))))
 586
 587 (defun edmacro-subseq (seq start &optional end)
 588   "Return the subsequence of SEQ from START to END.
 589 If END is omitted, it defaults to the length of the sequence.
 590 If START or END is negative, it counts from the end."
 591   (if (stringp seq) (substring seq start end)
 592     (let (len)
 593       (and end (< end 0) (setq end (+ end (setq len (length seq)))))
 594       (if (< start 0) (setq start (+ start (or len (setq len (length seq))))))
 595       (cond ((listp seq)
 596              (if (> start 0) (setq seq (nthcdr start seq)))
 597              (if end
 598                  (let ((res nil))
 599                    (while (>= (setq end (1- end)) start)
 600                      (cl-push (cl-pop seq) res))
 601                    (nreverse res))
 602                (copy-sequence seq)))
 603             (t
 604              (or end (setq end (or len (length seq))))
 605              (let ((res (make-vector (max (- end start) 0) nil))
 606                    (i 0))
 607                (while (< start end)
 608                  (aset res i (aref seq start))
 609                  (setq i (1+ i) start (1+ start)))
 610                res))))))
 611
 612 (defun edmacro-fix-menu-commands (macro)
 613   (when (vectorp macro)
 614     (let ((i 0) ev)
 615       (while (< i (length macro))
 616         (when (consp (setq ev (aref macro i)))
 617           (cond ((equal (cadadr ev) '(menu-bar))
 618                  (setq macro (vconcat (edmacro-subseq macro 0 i)
 619                                       (vector 'menu-bar (car ev))
 620                                       (edmacro-subseq macro (1+ i))))
 621                  (incf i))
 622                 ;; It would be nice to do pop-up menus, too, but not enough
 623                 ;; info is recorded in macros to make this possible.
 624                 (t
 625                  (error "Macros with mouse clicks are not %s"
 626                         "supported by this command"))))
 627         (incf i))))
 628   macro)
 629 \f
 630 ;;; Parsing a human-readable keyboard macro.
 631
 632 (defun edmacro-parse-keys (string &optional need-vector)
 633   (let ((case-fold-search nil)
 634         (pos 0)
 635         (res []))
 636     (while (and (< pos (length string))
 637                 (string-match "[^ \t\n\f]+" string pos))
 638       (let ((word (substring string (match-beginning 0) (match-end 0)))
 639             (key nil)
 640             (times 1))
 641         (setq pos (match-end 0))
 642         (when (string-match "\\([0-9]+\\)\\*." word)
 643           (setq times (string-to-int (substring word 0 (match-end 1))))
 644           (setq word (substring word (1+ (match-end 1)))))
 645         (cond ((string-match "^<<.+>>$" word)
 646                (setq key (vconcat (if (eq (key-binding [?\M-x])
 647                                           'execute-extended-command)
 648                                       [?\M-x]
 649                                     (or (car (where-is-internal
 650                                               'execute-extended-command))
 651                                         [?\M-x]))
 652                                   (substring word 2 -2) "\r")))
 653               ((and (string-match "^\\(\\([ACHMsS]-\\)*\\)<\\(.+\\)>$" word)
 654                     (progn
 655                       (setq word (concat (substring word (match-beginning 1)
 656                                                     (match-end 1))
 657                                          (substring word (match-beginning 3)
 658                                                     (match-end 3))))
 659                       (not (string-match
 660                             "\\<\\(NUL\\|RET\\|LFD\\|ESC\\|SPC\\|DEL\\)$"
 661                             word))))
 662                (setq key (list (intern word))))
 663               ((or (equal word "REM") (string-match "^;;" word))
 664                (setq pos (string-match "$" string pos)))
 665               (t
 666                (let ((orig-word word) (prefix 0) (bits 0))
 667                  (while (string-match "^[ACHMsS]-." word)
 668                    (incf bits (cdr (assq (aref word 0)
 669                                          '((?A . ?\A-\^@) (?C . ?\C-\^@)
 670                                            (?H . ?\H-\^@) (?M . ?\M-\^@)
 671                                            (?s . ?\s-\^@) (?S . ?\S-\^@)))))
 672                    (incf prefix 2)
 673                    (callf substring word 2))
 674                  (when (string-match "^\\^.$" word)
 675                    (incf bits ?\C-\^@)
 676                    (incf prefix)
 677                    (callf substring word 1))
 678                  (let ((found (assoc word '(("NUL" . "\0") ("RET" . "\r")
 679                                             ("LFD" . "\n") ("TAB" . "\t")
 680                                             ("ESC" . "\e") ("SPC" . " ")
 681                                             ("DEL" . "\177")))))
 682                    (when found (setq word (cdr found))))
 683                  (when (string-match "^\\\\[0-7]+$" word)
 684                    (loop for ch across word
 685                          for n = 0 then (+ (* n 8) ch -48)
 686                          finally do (setq word (vector n))))
 687                  (cond ((= bits 0)
 688                         (setq key word))
 689                        ((and (= bits ?\M-\^@) (stringp word)
 690                              (string-match "^-?[0-9]+$" word))
 691                         (setq key (loop for x across word collect (+ x bits))))
 692                        ((/= (length word) 1)
 693                         (error "%s must prefix a single character, not %s"
 694                                (substring orig-word 0 prefix) word))
 695                        ((and (/= (logand bits ?\C-\^@) 0) (stringp word)
 696                              ;; We used to accept . and ? here,
 697                              ;; but . is simply wrong,
 698                              ;; and C-? is not used (we use DEL instead).
 699                              (string-match "[@-_a-z]" word))
 700                         (setq key (list (+ bits (- ?\C-\^@)
 701                                            (logand (aref word 0) 31)))))
 702                        (t
 703                         (setq key (list (+ bits (aref word 0)))))))))
 704         (when key
 705           (loop repeat times do (callf vconcat res key)))))
 706     (when (and (>= (length res) 4)
 707                (eq (aref res 0) ?\C-x)
 708                (eq (aref res 1) ?\()
 709                (eq (aref res (- (length res) 2)) ?\C-x)
 710                (eq (aref res (- (length res) 1)) ?\)))
 711       (setq res (edmacro-subseq res 2 -2)))
 712     (if (and (not need-vector)
 713              (loop for ch across res
 714                    always (and (integerp ch)
 715                                (let ((ch2 (logand ch (lognot ?\M-\^@))))
 716                                  (and (>= ch2 0) (<= ch2 127))))))
 717         (concat (loop for ch across res
 718                       collect (if (= (logand ch ?\M-\^@) 0)
 719                                   ch (+ ch 128))))
 720       res)))
 721
 722 (provide 'edmacro)
 723
 724 ;;; edmacro.el ends here
 725