edmacro.el 27.7 KB
Newer Older
Eric S. Raymond's avatar
Eric S. Raymond committed
1 2
;;; edmacro.el --- keyboard macro editor

Paul Eggert's avatar
Paul Eggert committed
3
;; Copyright (C) 1993-1994, 2001-2020 Free Software Foundation, Inc.
Eric S. Raymond's avatar
Eric S. Raymond committed
4

5 6
;; Author: Dave Gillespie <daveg@synaptics.com>
;; Version: 2.01
Eric S. Raymond's avatar
Eric S. Raymond committed
7
;; Keywords: abbrev
David Lawrence's avatar
David Lawrence committed
8 9 10

;; This file is part of GNU Emacs.

11
;; GNU Emacs is free software: you can redistribute it and/or modify
David Lawrence's avatar
David Lawrence committed
12
;; it under the terms of the GNU General Public License as published by
13 14
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
David Lawrence's avatar
David Lawrence committed
15 16 17 18 19 20 21

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
22
;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
David Lawrence's avatar
David Lawrence committed
23

Eric S. Raymond's avatar
Eric S. Raymond committed
24
;;; Commentary:
David Lawrence's avatar
David Lawrence committed
25

26 27
;;; Usage:
;;
28
;; The `C-x C-k e' (`edit-kbd-macro') command edits a keyboard macro
29 30 31
;; in a special buffer.  It prompts you to type a key sequence,
;; which should be one of:
;;
32
;;  * RET or `C-x e' (call-last-kbd-macro), to edit the most
33 34 35 36 37
;;    recently defined keyboard macro.
;;
;;  * `M-x' followed by a command name, to edit a named command
;;    whose definition is a keyboard macro.
;;
38
;;  * `C-h l' (view-lossage), to edit the 300 most recent keystrokes
39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62
;;    and install them as the "current" macro.
;;
;;  * any key sequence whose definition is a keyboard macro.
;;
;; This file includes a version of `insert-kbd-macro' that uses the
;; more readable format defined by these routines.
;;
;; Also, the `read-kbd-macro' command parses the region as
;; a keyboard macro, and installs it as the "current" macro.
;; This and `format-kbd-macro' can also be called directly as
;; Lisp functions.

;; Type `C-h m', or see the documentation for `edmacro-mode' below,
;; for information about the format of written keyboard macros.

;; `edit-kbd-macro' formats the macro with one command per line,
;; including the command names as comments on the right.  If the
;; formatter gets confused about which keymap was used for the
;; characters, the command-name comments will be wrong but that
;; won't hurt anything.

;; With a prefix argument, `edit-kbd-macro' will format the
;; macro in a more concise way that omits the comments.

Eric S. Raymond's avatar
Eric S. Raymond committed
63
;;; Code:
64

65
(require 'cl-lib)
66 67
(require 'kmacro)

David Lawrence's avatar
David Lawrence committed
68 69
;;; The user-level commands for editing macros.

Glenn Morris's avatar
Glenn Morris committed
70 71 72 73 74
(defcustom edmacro-eight-bits nil
  "Non-nil if `edit-kbd-macro' should leave 8-bit characters intact.
Default nil means to write characters above \\177 in octal notation."
  :type 'boolean
  :group 'kmacro)
75

76 77 78 79 80
(defvar edmacro-mode-map
  (let ((map (make-sparse-keymap)))
    (define-key map "\C-c\C-c" 'edmacro-finish-edit)
    (define-key map "\C-c\C-q" 'edmacro-insert-key)
    map))
81

82 83 84 85
(defvar edmacro-store-hook)
(defvar edmacro-finish-hook)
(defvar edmacro-original-buffer)

Jim Blandy's avatar
Jim Blandy committed
86
;;;###autoload
87 88 89
(defun edit-kbd-macro (keys &optional prefix finish-hook store-hook)
  "Edit a keyboard macro.
At the prompt, type any key sequence which is bound to a keyboard macro.
90 91 92 93
Or, type `\\[kmacro-end-and-call-macro]' or RET to edit the last
keyboard macro, `\\[view-lossage]' to edit the last 300
keystrokes as a keyboard macro, or `\\[execute-extended-command]'
to edit a macro by its command name.
94
With a prefix argument, format the macro in a more concise way."
95 96 97 98 99
  (interactive
   (list (read-key-sequence (substitute-command-keys "Keyboard macro to edit \
\(\\[kmacro-end-and-call-macro], \\[execute-extended-command], \\[view-lossage],\
 or keys): "))
         current-prefix-arg))
100 101
  (when keys
    (let ((cmd (if (arrayp keys) (key-binding keys) keys))
102
          (cmd-noremap (when (arrayp keys) (key-binding keys nil t)))
103 104
	  (mac nil) (mac-counter nil) (mac-format nil)
	  kmacro)
105 106 107
      (cond (store-hook
	     (setq mac keys)
	     (setq cmd nil))
108 109
	    ((or (memq cmd '(call-last-kbd-macro kmacro-call-macro kmacro-end-or-call-macro kmacro-end-and-call-macro))
                 (memq cmd-noremap '(call-last-kbd-macro kmacro-call-macro kmacro-end-or-call-macro kmacro-end-and-call-macro))
110 111 112 113 114
		 (member keys '("\r" [return])))
	     (or last-kbd-macro
		 (y-or-n-p "No keyboard macro defined.  Create one? ")
		 (keyboard-quit))
	     (setq mac (or last-kbd-macro ""))
115
	     (setq keys nil)
116
	     (setq cmd 'last-kbd-macro))
117
	    ((memq 'execute-extended-command (list cmd cmd-noremap))
118
	     (setq cmd (read-command "Name of keyboard macro to edit: "))
119 120
	     (if (string-equal cmd "")
		 (error "No command name given"))
121
	     (setq keys nil)
122
	     (setq mac (symbol-function cmd)))
123 124
	    ((or (memq cmd '(view-lossage electric-view-lossage))
                 (memq cmd-noremap '(view-lossage electric-view-lossage)))
125
	     (setq mac (recent-keys))
126
	     (setq keys nil)
127
	     (setq cmd 'last-kbd-macro))
128 129
	    ((null cmd)
	     (error "Key sequence %s is not defined" (key-description keys)))
130 131 132 133 134
	    ((symbolp cmd)
	     (setq mac (symbol-function cmd)))
	    (t
	     (setq mac cmd)
	     (setq cmd nil)))
135 136 137 138
      (when (setq kmacro (kmacro-extract-lambda mac))
	(setq mac (car kmacro)
	      mac-counter (nth 1 kmacro)
	      mac-format (nth 2 kmacro)))
139
      (unless (arrayp mac)
140 141
	(error "Key sequence %s is not a keyboard macro"
	       (key-description keys)))
142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163
      (message "Formatting keyboard macro...")
      (let* ((oldbuf (current-buffer))
	     (mmac (edmacro-fix-menu-commands mac))
	     (fmt (edmacro-format-keys mmac 1))
	     (fmtv (edmacro-format-keys mmac (not prefix)))
	     (buf (get-buffer-create "*Edit Macro*")))
	(message "Formatting keyboard macro...done")
	(switch-to-buffer buf)
	(kill-all-local-variables)
	(use-local-map edmacro-mode-map)
	(setq buffer-read-only nil)
	(setq major-mode 'edmacro-mode)
	(setq mode-name "Edit Macro")
	(set (make-local-variable 'edmacro-original-buffer) oldbuf)
	(set (make-local-variable 'edmacro-finish-hook) finish-hook)
	(set (make-local-variable 'edmacro-store-hook) store-hook)
	(erase-buffer)
	(insert ";; Keyboard Macro Editor.  Press C-c C-c to finish; "
		"press C-x k RET to cancel.\n")
	(insert ";; Original keys: " fmt "\n")
	(unless store-hook
	  (insert "\nCommand: " (if cmd (symbol-name cmd) "none") "\n")
164 165 166 167 168 169 170 171 172
	  (let ((gkeys (where-is-internal (or cmd mac) '(keymap))))
	    (if (and keys (not (member keys gkeys)))
		(setq gkeys (cons keys gkeys)))
	    (if gkeys
		(while gkeys
		  (insert "Key: " (edmacro-format-keys (pop gkeys) 1) "\n"))
	      (insert "Key: none\n")))
	  (when (and mac-counter mac-format)
	    (insert (format "Counter: %d\nFormat: \"%s\"\n" mac-counter mac-format))))
173 174 175 176 177 178 179 180 181 182 183 184 185
	(insert "\nMacro:\n\n")
	(save-excursion
	  (insert fmtv "\n"))
	(recenter '(4))
	(when (eq mac mmac)
	  (set-buffer-modified-p nil))
	(run-hooks 'edmacro-format-hook)))))

;;; The next two commands are provided for convenience and backward
;;; compatibility.

;;;###autoload
(defun edit-last-kbd-macro (&optional prefix)
David Lawrence's avatar
David Lawrence committed
186 187
  "Edit the most recently defined keyboard macro."
  (interactive "P")
188
  (edit-kbd-macro 'call-last-kbd-macro prefix))
David Lawrence's avatar
David Lawrence committed
189

Jim Blandy's avatar
Jim Blandy committed
190
;;;###autoload
191 192 193 194
(defun edit-named-kbd-macro (&optional prefix)
  "Edit a keyboard macro which has been given a name by `name-last-kbd-macro'."
  (interactive "P")
  (edit-kbd-macro 'execute-extended-command prefix))
David Lawrence's avatar
David Lawrence committed
195

Jim Blandy's avatar
Jim Blandy committed
196
;;;###autoload
197
(defun read-kbd-macro (start &optional end)
David Lawrence's avatar
David Lawrence committed
198
  "Read the region as a keyboard macro definition.
199
The region is interpreted as spelled-out keystrokes, e.g., \"M-x abc RET\".
200 201
See documentation for `edmacro-mode' for details.
Leading/trailing \"C-x (\" and \"C-x )\" in the text are allowed and ignored.
David Lawrence's avatar
David Lawrence committed
202 203
The resulting macro is installed as the \"current\" keyboard macro.

204 205 206 207
In Lisp, may also be called with a single STRING argument in which case
the result is returned rather than being installed as the current macro.
The result will be a string if possible, otherwise an event vector.
Second argument NEED-VECTOR means to return an event vector always."
David Lawrence's avatar
David Lawrence committed
208
  (interactive "r")
209 210 211
  (if (stringp start)
      (edmacro-parse-keys start end)
    (setq last-kbd-macro (edmacro-parse-keys (buffer-substring start end)))))
David Lawrence's avatar
David Lawrence committed
212

213 214 215 216 217 218 219 220 221
;;;###autoload
(defun format-kbd-macro (&optional macro verbose)
  "Return the keyboard macro MACRO as a human-readable string.
This string is suitable for passing to `read-kbd-macro'.
Second argument VERBOSE means to put one command per line with comments.
If VERBOSE is `1', put everything on one line.  If VERBOSE is omitted
or nil, use a compact 80-column format."
  (and macro (symbolp macro) (setq macro (symbol-function macro)))
  (edmacro-format-keys (or macro last-kbd-macro) verbose))
David Lawrence's avatar
David Lawrence committed
222

223
;;; Commands for *Edit Macro* buffer.
David Lawrence's avatar
David Lawrence committed
224 225 226

(defun edmacro-finish-edit ()
  (interactive)
227 228 229 230 231
  (unless (eq major-mode 'edmacro-mode)
    (error
     "This command is valid only in buffers created by `edit-kbd-macro'"))
  (run-hooks 'edmacro-finish-hook)
  (let ((cmd nil) (keys nil) (no-keys nil)
232
	(mac-counter nil) (mac-format nil)
233 234 235 236 237 238 239 240 241 242 243
	(top (point-min)))
    (goto-char top)
    (let ((case-fold-search nil))
      (while (cond ((looking-at "[ \t]*\\($\\|;;\\|REM[ \t\n]\\)")
		    t)
		   ((looking-at "Command:[ \t]*\\([^ \t\n]*\\)[ \t]*$")
		    (when edmacro-store-hook
		      (error "\"Command\" line not allowed in this context"))
		    (let ((str (buffer-substring (match-beginning 1)
						 (match-end 1))))
		      (unless (equal str "")
244
			(setq cmd (and (not (equal str "none"))
245 246
				       (intern str)))
			(and (fboundp cmd) (not (arrayp (symbol-function cmd)))
247
			     (not (get cmd 'kmacro))
248 249 250 251 252 253 254 255 256 257 258 259
			     (not (y-or-n-p
				   (format "Command %s is already defined; %s"
					   cmd "proceed? ")))
			     (keyboard-quit))))
		    t)
		   ((looking-at "Key:\\(.*\\)$")
		    (when edmacro-store-hook
		      (error "\"Key\" line not allowed in this context"))
		    (let ((key (edmacro-parse-keys
				(buffer-substring (match-beginning 1)
						  (match-end 1)))))
		      (unless (equal key "")
260
			(if (equal key "none")
261 262 263 264
			    (setq no-keys t)
			  (push key keys)
			  (let ((b (key-binding key)))
			    (and b (commandp b) (not (arrayp b))
265
				 (not (kmacro-extract-lambda b))
266
				 (or (not (fboundp b))
267 268
				     (not (or (arrayp (symbol-function b))
					      (get b 'kmacro))))
269 270 271 272 273 274
				 (not (y-or-n-p
				       (format "Key %s is already defined; %s"
					       (edmacro-format-keys key 1)
					       "proceed? ")))
				 (keyboard-quit))))))
		    t)
275 276 277 278 279 280
		   ((looking-at "Counter:[ \t]*\\([^ \t\n]*\\)[ \t]*$")
		    (when edmacro-store-hook
		      (error "\"Counter\" line not allowed in this context"))
		    (let ((str (buffer-substring (match-beginning 1)
						 (match-end 1))))
		      (unless (equal str "")
281
			(setq mac-counter (string-to-number str))))
282 283 284 285 286 287 288 289 290
		    t)
		   ((looking-at "Format:[ \t]*\"\\([^\n]*\\)\"[ \t]*$")
		    (when edmacro-store-hook
		      (error "\"Format\" line not allowed in this context"))
		    (let ((str (buffer-substring (match-beginning 1)
						 (match-end 1))))
		      (unless (equal str "")
			(setq mac-format str)))
		    t)
291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319
		   ((looking-at "Macro:[ \t\n]*")
		    (goto-char (match-end 0))
		    nil)
		   ((eobp) nil)
		   (t (error "Expected a `Macro:' line")))
	(forward-line 1))
      (setq top (point)))
    (let* ((buf (current-buffer))
	   (str (buffer-substring top (point-max)))
	   (modp (buffer-modified-p))
	   (obuf edmacro-original-buffer)
	   (store-hook edmacro-store-hook)
	   (finish-hook edmacro-finish-hook))
      (unless (or cmd keys store-hook (equal str ""))
	(error "No command name or keys specified"))
      (when modp
	(when (buffer-name obuf)
	  (set-buffer obuf))
	(message "Compiling keyboard macro...")
	(let ((mac (edmacro-parse-keys str)))
	  (message "Compiling keyboard macro...done")
	  (if store-hook
	      (funcall store-hook mac)
	    (when (eq cmd 'last-kbd-macro)
	      (setq last-kbd-macro (and (> (length mac) 0) mac))
	      (setq cmd nil))
	    (when cmd
	      (if (= (length mac) 0)
		  (fmakunbound cmd)
320 321 322 323
		(fset cmd
		      (if (and mac-counter mac-format)
			  (kmacro-lambda-form mac mac-counter mac-format)
			mac))))
324 325
	    (if no-keys
		(when cmd
Stefan Monnier's avatar
Stefan Monnier committed
326 327
		  (cl-loop for key in (where-is-internal cmd '(keymap)) do
                           (global-unset-key key)))
328 329
	      (when keys
		(if (= (length mac) 0)
Stefan Monnier's avatar
Stefan Monnier committed
330 331 332 333 334 335 336 337
		    (cl-loop for key in keys do (global-unset-key key))
		  (cl-loop for key in keys do
                           (global-set-key key
                                           (or cmd
                                               (if (and mac-counter mac-format)
                                                   (kmacro-lambda-form
                                                    mac mac-counter mac-format)
                                                 mac))))))))))
338 339 340 341 342 343 344 345 346 347 348 349
      (kill-buffer buf)
      (when (buffer-name obuf)
	(switch-to-buffer obuf))
      (when finish-hook
	(funcall finish-hook)))))

(defun edmacro-insert-key (key)
  "Insert the written name of a key in the buffer."
  (interactive "kKey to insert: ")
  (if (bolp)
      (insert (edmacro-format-keys key t) "\n")
    (insert (edmacro-format-keys key) " ")))
David Lawrence's avatar
David Lawrence committed
350 351

(defun edmacro-mode ()
352
  "\\<edmacro-mode-map>Keyboard Macro Editing mode.  Press \
353
\\[edmacro-finish-edit] to save and exit.
354
To abort the edit, just kill this buffer with \\[kill-buffer] RET.
David Lawrence's avatar
David Lawrence committed
355

356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422
Press \\[edmacro-insert-key] to insert the name of any key by typing the key.

The editing buffer contains a \"Command:\" line and any number of
\"Key:\" lines at the top.  These are followed by a \"Macro:\" line
and the macro itself as spelled-out keystrokes: `C-x C-f foo RET'.

The \"Command:\" line specifies the command name to which the macro
is bound, or \"none\" for no command name.  Write \"last-kbd-macro\"
to refer to the current keyboard macro (as used by \\[call-last-kbd-macro]).

The \"Key:\" lines specify key sequences to which the macro is bound,
or \"none\" for no key bindings.

You can edit these lines to change the places where the new macro
is stored.


Format of keyboard macros during editing:

Text is divided into \"words\" separated by whitespace.  Except for
the words described below, the characters of each word go directly
as characters of the macro.  The whitespace that separates words
is ignored.  Whitespace in the macro must be written explicitly,
as in \"foo SPC bar RET\".

 * The special words RET, SPC, TAB, DEL, LFD, ESC, and NUL represent
   special control characters.  The words must be written in uppercase.

 * A word in angle brackets, e.g., <return>, <down>, or <f1>, represents
   a function key.  (Note that in the standard configuration, the
   function key <return> and the control key RET are synonymous.)
   You can use angle brackets on the words RET, SPC, etc., but they
   are not required there.

 * Keys can be written by their ASCII code, using a backslash followed
   by up to six octal digits.  This is the only way to represent keys
   with codes above \\377.

 * One or more prefixes M- (meta), C- (control), S- (shift), A- (alt),
   H- (hyper), and s- (super) may precede a character or key notation.
   For function keys, the prefixes may go inside or outside of the
   brackets:  C-<down> = <C-down>.  The prefixes may be written in
   any order:  M-C-x = C-M-x.

   Prefixes are not allowed on multi-key words, e.g., C-abc, except
   that the Meta prefix is allowed on a sequence of digits and optional
   minus sign:  M--123 = M-- M-1 M-2 M-3.

 * The `^' notation for control characters also works:  ^M = C-m.

 * Double angle brackets enclose command names:  <<next-line>> is
   shorthand for M-x next-line RET.

 * Finally, REM or ;; causes the rest of the line to be ignored as a
   comment.

Any word may be prefixed by a multiplier in the form of a decimal
number and `*':  3*<right> = <right> <right> <right>, and
10*foo = foofoofoofoofoofoofoofoofoofoo.

Multiple text keys can normally be strung together to form a word,
but you may need to add whitespace if the word would look like one
of the above notations:  `; ; ;' is a keyboard macro with three
semicolons, but `;;;' is a comment.  Likewise, `\\ 1 2 3' is four
keys but `\\123' is a single key written in octal, and `< right >'
is seven keys but `<right>' is a single function key.  When in
doubt, use whitespace."
David Lawrence's avatar
David Lawrence committed
423
  (interactive)
424
  (error "This mode can be enabled only by `edit-kbd-macro'"))
David Lawrence's avatar
David Lawrence committed
425
(put 'edmacro-mode 'mode-class 'special)
426 427

;;; Formatting a keyboard macro as human-readable text.
David Lawrence's avatar
David Lawrence committed
428

429 430
(defun edmacro-format-keys (macro &optional verbose)
  (setq macro (edmacro-fix-menu-commands macro))
431
  (let* ((maps (current-active-maps))
432 433 434 435 436 437 438 439 440 441 442 443 444
	 (pkeys '(end-macro ?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9 ?- ?\C-u
		  ?\M-- ?\M-0 ?\M-1 ?\M-2 ?\M-3 ?\M-4 ?\M-5 ?\M-6
		  ?\M-7 ?\M-8 ?\M-9))
	 (mdigs (nthcdr 13 pkeys))
	 (maxkey (if edmacro-eight-bits 255 127))
	 (case-fold-search nil)
	 (res-words '("NUL" "TAB" "LFD" "RET" "ESC" "SPC" "DEL" "REM"))
	 (rest-mac (vconcat macro [end-macro]))
	 (res "")
	 (len 0)
	 (one-line (eq verbose 1)))
    (if one-line (setq verbose nil))
    (when (stringp macro)
Stefan Monnier's avatar
Stefan Monnier committed
445 446 447
      (cl-loop for i below (length macro) do
               (when (>= (aref rest-mac i) 128)
                 (cl-incf (aref rest-mac i) (- ?\M-\^@ 128)))))
448 449 450 451
    (while (not (eq (aref rest-mac 0) 'end-macro))
      (let* ((prefix
	      (or (and (integerp (aref rest-mac 0))
		       (memq (aref rest-mac 0) mdigs)
452
		       (memq (key-binding (cl-subseq rest-mac 0 1))
453 454 455
			     '(digit-argument negative-argument))
		       (let ((i 1))
			 (while (memq (aref rest-mac i) (cdr mdigs))
Stefan Monnier's avatar
Stefan Monnier committed
456
			   (cl-incf i))
457
			 (and (not (memq (aref rest-mac i) pkeys))
458 459
			      (prog1 (vconcat "M-" (cl-subseq rest-mac 0 i) " ")
				(cl-callf cl-subseq rest-mac i)))))
460 461 462 463
		  (and (eq (aref rest-mac 0) ?\C-u)
		       (eq (key-binding [?\C-u]) 'universal-argument)
		       (let ((i 1))
			 (while (eq (aref rest-mac i) ?\C-u)
Stefan Monnier's avatar
Stefan Monnier committed
464
			   (cl-incf i))
465
			 (and (not (memq (aref rest-mac i) pkeys))
Stefan Monnier's avatar
Stefan Monnier committed
466
			      (prog1 (cl-loop repeat i concat "C-u ")
467
				(cl-callf cl-subseq rest-mac i)))))
468 469 470 471
		  (and (eq (aref rest-mac 0) ?\C-u)
		       (eq (key-binding [?\C-u]) 'universal-argument)
		       (let ((i 1))
			 (when (eq (aref rest-mac i) ?-)
Stefan Monnier's avatar
Stefan Monnier committed
472
			   (cl-incf i))
473 474
			 (while (memq (aref rest-mac i)
				      '(?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9))
Stefan Monnier's avatar
Stefan Monnier committed
475
			   (cl-incf i))
476
			 (and (not (memq (aref rest-mac i) pkeys))
477 478
			      (prog1 (vconcat "C-u " (cl-subseq rest-mac 1 i) " ")
				(cl-callf cl-subseq rest-mac i)))))))
479
	     (bind-len (apply 'max 1
Stefan Monnier's avatar
Stefan Monnier committed
480 481 482
			      (cl-loop for map in maps
                                       for b = (lookup-key map rest-mac)
                                       when b collect b)))
483
	     (key (cl-subseq rest-mac 0 bind-len))
484
	     (fkey nil) tlen tkey
Stefan Monnier's avatar
Stefan Monnier committed
485 486
	     (bind (or (cl-loop for map in maps for b = (lookup-key map key)
                                thereis (and (not (integerp b)) b))
487
		       (and (setq fkey (lookup-key local-function-key-map rest-mac))
488
			    (setq tlen fkey tkey (cl-subseq rest-mac 0 tlen)
489
				  fkey (lookup-key local-function-key-map tkey))
Stefan Monnier's avatar
Stefan Monnier committed
490 491 492 493 494 495
			    (cl-loop for map in maps
                                     for b = (lookup-key map fkey)
                                     when (and (not (integerp b)) b)
                                     do (setq bind-len tlen key tkey)
                                     and return b
                                     finally do (setq fkey nil)))))
496
	     (first (aref key 0))
Stefan Monnier's avatar
Stefan Monnier committed
497 498 499 500 501 502 503 504 505 506 507
	     (text
              (cl-loop for i from bind-len below (length rest-mac)
                       for ch = (aref rest-mac i)
                       while (and (integerp ch)
                                  (> ch 32) (< ch maxkey) (/= ch 92)
                                  (eq (key-binding (char-to-string ch))
                                      'self-insert-command)
                                  (or (> i (- (length rest-mac) 2))
                                      (not (eq ch (aref rest-mac (+ i 1))))
                                      (not (eq ch (aref rest-mac (+ i 2))))))
                       finally return i))
508 509 510 511 512 513 514
	     desc)
	(if (stringp bind) (setq bind nil))
	(cond ((and (eq bind 'self-insert-command) (not prefix)
		    (> text 1) (integerp first)
		    (> first 32) (<= first maxkey) (/= first 92)
		    (progn
		      (if (> text 30) (setq text 30))
515
		      (setq desc (concat (cl-subseq rest-mac 0 text)))
516 517
		      (when (string-match "^[ACHMsS]-." desc)
			(setq text 2)
Stefan Monnier's avatar
Stefan Monnier committed
518
			(cl-callf substring desc 0 2))
519 520 521 522 523 524 525 526 527 528 529 530 531
		      (not (string-match
			    "^;;\\|^<.*>$\\|^\\\\[0-9]+$\\|^[0-9]+\\*."
			    desc))))
	       (when (or (string-match "^\\^.$" desc)
			 (member desc res-words))
		 (setq desc (mapconcat 'char-to-string desc " ")))
	       (when verbose
		 (setq bind (format "%s * %d" bind text)))
	       (setq bind-len text))
	      ((and (eq bind 'execute-extended-command)
		    (> text bind-len)
		    (memq (aref rest-mac text) '(return 13))
		    (progn
532
		      (setq desc (concat (cl-subseq rest-mac bind-len text)))
533 534 535 536 537 538 539 540 541 542 543
		      (commandp (intern-soft desc))))
	       (if (commandp (intern-soft desc)) (setq bind desc))
	       (setq desc (format "<<%s>>" desc))
	       (setq bind-len (1+ text)))
	      (t
	       (setq desc (mapconcat
			   (function
			    (lambda (ch)
			      (cond
			       ((integerp ch)
				(concat
Stefan Monnier's avatar
Stefan Monnier committed
544 545 546 547 548
				 (cl-loop for pf across "ACHMsS"
                                          for bit in '(?\A-\^@ ?\C-\^@ ?\H-\^@
                                                       ?\M-\^@ ?\s-\^@ ?\S-\^@)
                                          when (/= (logand ch bit) 0)
                                          concat (format "%c-" pf))
549
				 (let ((ch2 (logand ch (1- (ash 1 18)))))
550
				   (cond ((<= ch2 32)
Stefan Monnier's avatar
Stefan Monnier committed
551
					  (pcase ch2
552 553
					    (0 "NUL") (9 "TAB") (10 "LFD")
					    (13 "RET") (27 "ESC") (32 "SPC")
Stefan Monnier's avatar
Stefan Monnier committed
554
					    (_
555 556 557 558 559 560 561 562 563 564 565
					     (format "C-%c"
						     (+ (if (<= ch2 26) 96 64)
							ch2)))))
					 ((= ch2 127) "DEL")
					 ((<= ch2 maxkey) (char-to-string ch2))
					 (t (format "\\%o" ch2))))))
			       ((symbolp ch)
				(format "<%s>" ch))
			       (t
				(error "Unrecognized item in macro: %s" ch)))))
			   (or fkey key) " "))))
Kenichi Handa's avatar
Kenichi Handa committed
566 567
	(if prefix
	    (setq desc (concat (edmacro-sanitize-for-string prefix) desc)))
568 569
	(unless (string-match " " desc)
	  (let ((times 1) (pos bind-len))
570
	    (while (not (cl-mismatch rest-mac rest-mac
571 572
				     :start1 0 :end1 bind-len
				     :start2 pos :end2 (+ bind-len pos)))
Stefan Monnier's avatar
Stefan Monnier committed
573 574
	      (cl-incf times)
	      (cl-incf pos bind-len))
575 576 577
	    (when (> times 1)
	      (setq desc (format "%d*%s" times desc))
	      (setq bind-len (* bind-len times)))))
578
	(setq rest-mac (cl-subseq rest-mac bind-len))
579 580
	(if verbose
	    (progn
Stefan Monnier's avatar
Stefan Monnier committed
581 582
	      (unless (equal res "") (cl-callf concat res "\n"))
	      (cl-callf concat res desc)
583
	      (when (and bind (or (stringp bind) (symbolp bind)))
Stefan Monnier's avatar
Stefan Monnier committed
584
		(cl-callf concat res
585 586 587 588 589
		  (make-string (max (- 3 (/ (length desc) 8)) 1) 9)
		  ";; " (if (stringp bind) bind (symbol-name bind))))
	      (setq len 0))
	  (if (and (> (+ len (length desc) 2) 72) (not one-line))
	      (progn
Stefan Monnier's avatar
Stefan Monnier committed
590
		(cl-callf concat res "\n ")
591 592
		(setq len 1))
	    (unless (equal res "")
Stefan Monnier's avatar
Stefan Monnier committed
593 594 595 596
	      (cl-callf concat res " ")
	      (cl-incf len)))
	  (cl-callf concat res desc)
	  (cl-incf len (length desc)))))
597 598
    res))

Kenichi Handa's avatar
Kenichi Handa committed
599
(defun edmacro-sanitize-for-string (seq)
600
  "Convert a key sequence vector SEQ into a string.
Kenichi Handa's avatar
Kenichi Handa committed
601 602 603
The string represents the same events; Meta is indicated by bit 7.
This function assumes that the events can be stored in a string."
  (setq seq (copy-sequence seq))
Stefan Monnier's avatar
Stefan Monnier committed
604 605 606
  (cl-loop for i below (length seq) do
           (when (logand (aref seq i) 128)
             (setf (aref seq i) (logand (aref seq i) 127))))
Kenichi Handa's avatar
Kenichi Handa committed
607 608
  seq)

609 610 611 612 613 614 615 616 617
(defun edmacro-fix-menu-commands (macro &optional noerror)
  (if (vectorp macro)
      (let (result)
	;; Make a list of the elements.
	(setq macro (append macro nil))
	(dolist (ev macro)
	  (cond ((atom ev)
		 (push ev result))
		((eq (car ev) 'help-echo))
618
		((eq (car ev) 'switch-frame))
619 620
		((equal ev '(menu-bar))
		 (push 'menu-bar result))
621
		((equal (cl-cadadr ev) '(menu-bar))
622
		 (push (vector 'menu-bar (car ev)) result))
623 624
		;; It would be nice to do pop-up menus, too, but not enough
		;; info is recorded in macros to make this possible.
625 626 627 628 629
		((or (mouse-event-p ev) (mouse-movement-p ev)
		     (memq (event-basic-type ev)
			   (list mouse-wheel-down-event mouse-wheel-up-event
				 mouse-wheel-right-event
				 mouse-wheel-left-event)))
630
		 nil)
631
		(noerror nil)
632
		(t
633 634
		 (error "`edmacro-fix-menu-commands': Unsupported event: %S"
			ev))))
635 636 637
	;; Reverse them again and make them back into a vector.
	(vconcat (nreverse result)))
    macro))
638 639 640 641 642

;;; Parsing a human-readable keyboard macro.

(defun edmacro-parse-keys (string &optional need-vector)
  (let ((case-fold-search nil)
643
	(len (length string)) ; We won't alter string in the loop below.
644 645
	(pos 0)
	(res []))
646
    (while (and (< pos len)
647
		(string-match "[^ \t\n\f]+" string pos))
648 649 650 651 652 653
      (let* ((word-beg (match-beginning 0))
	     (word-end (match-end 0))
	     (word (substring string word-beg len))
	     (times 1)
	     key)
	;; Try to catch events of the form "<as df>".
654
	(if (string-match "\\`<[^ <>\t\n\f][^>\t\n\f]*>" word)
655 656 657 658
	    (setq word (match-string 0 word)
		  pos (+ word-beg (match-end 0)))
	  (setq word (substring string word-beg word-end)
		pos word-end))
659
	(when (string-match "\\([0-9]+\\)\\*." word)
660
	  (setq times (string-to-number (substring word 0 (match-end 1))))
661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684
	  (setq word (substring word (1+ (match-end 1)))))
	(cond ((string-match "^<<.+>>$" word)
	       (setq key (vconcat (if (eq (key-binding [?\M-x])
					  'execute-extended-command)
				      [?\M-x]
				    (or (car (where-is-internal
					      'execute-extended-command))
					[?\M-x]))
				  (substring word 2 -2) "\r")))
	      ((and (string-match "^\\(\\([ACHMsS]-\\)*\\)<\\(.+\\)>$" word)
		    (progn
		      (setq word (concat (substring word (match-beginning 1)
						    (match-end 1))
					 (substring word (match-beginning 3)
						    (match-end 3))))
		      (not (string-match
			    "\\<\\(NUL\\|RET\\|LFD\\|ESC\\|SPC\\|DEL\\)$"
			    word))))
	       (setq key (list (intern word))))
	      ((or (equal word "REM") (string-match "^;;" word))
	       (setq pos (string-match "$" string pos)))
	      (t
	       (let ((orig-word word) (prefix 0) (bits 0))
		 (while (string-match "^[ACHMsS]-." word)
Stefan Monnier's avatar
Stefan Monnier committed
685
		   (cl-incf bits (cdr (assq (aref word 0)
686 687 688
					 '((?A . ?\A-\^@) (?C . ?\C-\^@)
					   (?H . ?\H-\^@) (?M . ?\M-\^@)
					   (?s . ?\s-\^@) (?S . ?\S-\^@)))))
Stefan Monnier's avatar
Stefan Monnier committed
689 690
		   (cl-incf prefix 2)
		   (cl-callf substring word 2))
691
		 (when (string-match "^\\^.$" word)
Stefan Monnier's avatar
Stefan Monnier committed
692 693 694
		   (cl-incf bits ?\C-\^@)
		   (cl-incf prefix)
		   (cl-callf substring word 1))
695 696 697 698 699 700
		 (let ((found (assoc word '(("NUL" . "\0") ("RET" . "\r")
					    ("LFD" . "\n") ("TAB" . "\t")
					    ("ESC" . "\e") ("SPC" . " ")
					    ("DEL" . "\177")))))
		   (when found (setq word (cdr found))))
		 (when (string-match "^\\\\[0-7]+$" word)
Stefan Monnier's avatar
Stefan Monnier committed
701 702 703
		   (cl-loop for ch across word
                            for n = 0 then (+ (* n 8) ch -48)
                            finally do (setq word (vector n))))
704 705
		 (cond ((= bits 0)
			(setq key word))
706
		       ((and (= bits ?\M-\^@) (stringp word)
707
			     (string-match "^-?[0-9]+$" word))
Stefan Monnier's avatar
Stefan Monnier committed
708 709
			(setq key (cl-loop for x across word
                                           collect (+ x bits))))
710 711 712
		       ((/= (length word) 1)
			(error "%s must prefix a single character, not %s"
			       (substring orig-word 0 prefix) word))
713
		       ((and (/= (logand bits ?\C-\^@) 0) (stringp word)
714 715 716 717
			     ;; We used to accept . and ? here,
			     ;; but . is simply wrong,
			     ;; and C-? is not used (we use DEL instead).
			     (string-match "[@-_a-z]" word))
718
			(setq key (list (+ bits (- ?\C-\^@)
719
					   (logand (aref word 0) 31)))))
720 721 722
		       (t
			(setq key (list (+ bits (aref word 0)))))))))
	(when key
Stefan Monnier's avatar
Stefan Monnier committed
723
	  (cl-loop repeat times do (cl-callf vconcat res key)))))
724 725 726 727 728
    (when (and (>= (length res) 4)
	       (eq (aref res 0) ?\C-x)
	       (eq (aref res 1) ?\()
	       (eq (aref res (- (length res) 2)) ?\C-x)
	       (eq (aref res (- (length res) 1)) ?\)))
729
      (setq res (cl-subseq res 2 -2)))
730
    (if (and (not need-vector)
Stefan Monnier's avatar
Stefan Monnier committed
731 732 733 734 735 736 737
	     (cl-loop for ch across res
                      always (and (characterp ch)
                                  (let ((ch2 (logand ch (lognot ?\M-\^@))))
                                    (and (>= ch2 0) (<= ch2 127))))))
	(concat (cl-loop for ch across res
                         collect (if (= (logand ch ?\M-\^@) 0)
                                     ch (+ ch 128))))
738 739 740
      res)))

(provide 'edmacro)
Eric S. Raymond's avatar
Eric S. Raymond committed
741 742

;;; edmacro.el ends here