| 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 | ((eq cmd '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 | (string-match "[@-_.a-z?]" word)) |
| 697 | (setq key (list (+ bits (- ?\C-\^@) |
| 698 | (if (equal word "?") 127 |
| 699 | (logand (aref word 0) 31)))))) |
| 700 | (t |
| 701 | (setq key (list (+ bits (aref word 0))))))))) |
| 702 | (when key |
| 703 | (loop repeat times do (callf vconcat res key))))) |
| 704 | (when (and (>= (length res) 4) |
| 705 | (eq (aref res 0) ?\C-x) |
| 706 | (eq (aref res 1) ?\() |
| 707 | (eq (aref res (- (length res) 2)) ?\C-x) |
| 708 | (eq (aref res (- (length res) 1)) ?\))) |
| 709 | (setq res (edmacro-subseq res 2 -2))) |
| 710 | (if (and (not need-vector) |
| 711 | (loop for ch across res |
| 712 | always (and (integerp ch) |
| 713 | (let ((ch2 (logand ch (lognot ?\M-\^@)))) |
| 714 | (and (>= ch2 0) (<= ch2 127)))))) |
| 715 | (concat (loop for ch across res |
| 716 | collect (if (= (logand ch ?\M-\^@) 0) |
| 717 | ch (+ ch 128)))) |
| 718 | res))) |
| 719 | \f |
| 720 | ;;; The following probably ought to go in macros.el: |
| 721 | |
| 722 | ;;;###autoload |
| 723 | (defun insert-kbd-macro (macroname &optional keys) |
| 724 | "Insert in buffer the definition of kbd macro NAME, as Lisp code. |
| 725 | Optional second arg KEYS means also record the keys it is on |
| 726 | \(this is the prefix argument, when calling interactively). |
| 727 | |
| 728 | This Lisp code will, when executed, define the kbd macro with the same |
| 729 | definition it has now. If you say to record the keys, the Lisp code |
| 730 | will also rebind those keys to the macro. Only global key bindings |
| 731 | are recorded since executing this Lisp code always makes global |
| 732 | bindings. |
| 733 | |
| 734 | To save a kbd macro, visit a file of Lisp code such as your `~/.emacs', |
| 735 | use this command, and then save the file." |
| 736 | (interactive "CInsert kbd macro (name): \nP") |
| 737 | (let (definition) |
| 738 | (if (string= (symbol-name macroname) "") |
| 739 | (progn |
| 740 | (setq definition (format-kbd-macro)) |
| 741 | (insert "(setq last-kbd-macro")) |
| 742 | (setq definition (format-kbd-macro macroname)) |
| 743 | (insert (format "(defalias '%s" macroname))) |
| 744 | (if (> (length definition) 50) |
| 745 | (insert " (read-kbd-macro\n") |
| 746 | (insert "\n (read-kbd-macro ")) |
| 747 | (prin1 definition (current-buffer)) |
| 748 | (insert "))\n") |
| 749 | (if keys |
| 750 | (let ((keys (where-is-internal macroname '(keymap)))) |
| 751 | (while keys |
| 752 | (insert (format "(global-set-key %S '%s)\n" (car keys) macroname)) |
| 753 | (setq keys (cdr keys))))))) |
| 754 | |
| 755 | (provide 'edmacro) |
| 756 | |
| 757 | ;;; edmacro.el ends here |
| 758 | |