lisp/edmacro.el

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