;;; edmacro.el --- keyboard macro editor
-;; Copyright (C) 1993, 1994 Free Software Foundation, Inc.
+;; Copyright (C) 1993, 1994, 2002, 2003, 2004,
+;; 2005, 2006 Free Software Foundation, Inc.
;; Author: Dave Gillespie <daveg@synaptics.com>
;; Maintainer: Dave Gillespie <daveg@synaptics.com>
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to
-;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+;; along with GNU Emacs; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
;;; Commentary:
;;; Usage:
;;
-;; The `C-x C-k' (`edit-kbd-macro') command edits a keyboard macro
+;; The `C-x C-k e' (`edit-kbd-macro') command edits a keyboard macro
;; in a special buffer. It prompts you to type a key sequence,
;; which should be one of:
;;
-;; * RET or `C-x e' (call-last-kbd-macro), to edit the most
+;; * RET or `C-x e' (call-last-kbd-macro), to edit the most
;; recently defined keyboard macro.
;;
;; * `M-x' followed by a command name, to edit a named command
;;; Code:
\f
-(require 'cl)
+(eval-when-compile
+ (require 'cl))
-;;; The user-level commands for editing macros.
+(require 'kmacro)
-;;;###autoload (define-key ctl-x-map "\C-k" 'edit-kbd-macro)
+;;; The user-level commands for editing macros.
;;;###autoload
(defvar edmacro-eight-bits nil
(define-key edmacro-mode-map "\C-c\C-c" 'edmacro-finish-edit)
(define-key edmacro-mode-map "\C-c\C-q" 'edmacro-insert-key))
+(defvar edmacro-store-hook)
+(defvar edmacro-finish-hook)
+(defvar edmacro-original-buffer)
+
;;;###autoload
(defun edit-kbd-macro (keys &optional prefix finish-hook store-hook)
"Edit a keyboard macro.
(interactive "kKeyboard macro to edit (C-x e, M-x, C-h l, or keys): \nP")
(when keys
(let ((cmd (if (arrayp keys) (key-binding keys) keys))
- (mac nil))
+ (mac nil) (mac-counter nil) (mac-format nil)
+ kmacro)
(cond (store-hook
(setq mac keys)
(setq cmd nil))
- ((or (eq cmd 'call-last-kbd-macro)
+ ((or (memq cmd '(call-last-kbd-macro kmacro-call-macro
+ kmacro-end-or-call-macro kmacro-end-and-call-macro))
(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 ""))
+ (setq keys nil)
(setq cmd 'last-kbd-macro))
((eq cmd 'execute-extended-command)
(setq cmd (read-command "Name of keyboard macro to edit: "))
+ (if (string-equal cmd "")
+ (error "No command name given"))
+ (setq keys nil)
(setq mac (symbol-function cmd)))
- ((eq cmd 'view-lossage)
+ ((memq cmd '(view-lossage electric-view-lossage))
(setq mac (recent-keys))
+ (setq keys nil)
(setq cmd 'last-kbd-macro))
((null cmd)
(error "Key sequence %s is not defined" (key-description keys)))
(t
(setq mac cmd)
(setq cmd nil)))
+ (when (setq kmacro (kmacro-extract-lambda mac))
+ (setq mac (car kmacro)
+ mac-counter (nth 1 kmacro)
+ mac-format (nth 2 kmacro)))
(unless (arrayp mac)
(error "Key sequence %s is not a keyboard macro"
(key-description keys)))
(insert ";; Original keys: " fmt "\n")
(unless store-hook
(insert "\nCommand: " (if cmd (symbol-name cmd) "none") "\n")
- (let ((keys (where-is-internal (or cmd mac) '(keymap))))
- (if keys
- (while keys
- (insert "Key: " (edmacro-format-keys (pop keys) 1) "\n"))
- (insert "Key: none\n"))))
+ (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))))
(insert "\nMacro:\n\n")
(save-excursion
(insert fmtv "\n"))
"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)
+ (mac-counter nil) (mac-format nil) (kmacro nil)
(top (point-min)))
(goto-char top)
(let ((case-fold-search nil))
(let ((str (buffer-substring (match-beginning 1)
(match-end 1))))
(unless (equal str "")
- (setq cmd (and (not (equalp str "none"))
+ (setq cmd (and (not (equal str "none"))
(intern str)))
(and (fboundp cmd) (not (arrayp (symbol-function cmd)))
+ (not (setq kmacro (get cmd 'kmacro)))
(not (y-or-n-p
(format "Command %s is already defined; %s"
cmd "proceed? ")))
(buffer-substring (match-beginning 1)
(match-end 1)))))
(unless (equal key "")
- (if (equalp key "none")
+ (if (equal key "none")
(setq no-keys t)
(push key keys)
(let ((b (key-binding key)))
(and b (commandp b) (not (arrayp b))
+ (not (kmacro-extract-lambda b))
(or (not (fboundp b))
- (not (arrayp (symbol-function b))))
+ (not (or (arrayp (symbol-function b))
+ (get b 'kmacro))))
(not (y-or-n-p
(format "Key %s is already defined; %s"
(edmacro-format-keys key 1)
"proceed? ")))
(keyboard-quit))))))
t)
+ ((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 "")
+ (setq mac-counter (string-to-number str))))
+ 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)
((looking-at "Macro:[ \t\n]*")
(goto-char (match-end 0))
nil)
(when cmd
(if (= (length mac) 0)
(fmakunbound cmd)
- (fset cmd mac)))
+ (fset cmd
+ (if (and mac-counter mac-format)
+ (kmacro-lambda-form mac mac-counter mac-format)
+ mac))))
(if no-keys
(when cmd
(loop for key in (where-is-internal cmd '(keymap)) do
(if (= (length mac) 0)
(loop for key in keys do (global-unset-key key))
(loop for key in keys do
- (global-set-key key (or cmd mac)))))))))
+ (global-set-key key
+ (or cmd
+ (if (and mac-counter mac-format)
+ (kmacro-lambda-form mac mac-counter mac-format)
+ mac))))))))))
(kill-buffer buf)
(when (buffer-name obuf)
(switch-to-buffer obuf))
(let* ((prefix
(or (and (integerp (aref rest-mac 0))
(memq (aref rest-mac 0) mdigs)
- (memq (key-binding (subseq rest-mac 0 1))
+ (memq (key-binding (edmacro-subseq rest-mac 0 1))
'(digit-argument negative-argument))
(let ((i 1))
(while (memq (aref rest-mac i) (cdr mdigs))
(incf i))
(and (not (memq (aref rest-mac i) pkeys))
- (prog1 (concat "M-" (subseq rest-mac 0 i) " ")
- (callf subseq rest-mac i)))))
+ (prog1 (vconcat "M-" (edmacro-subseq rest-mac 0 i) " ")
+ (callf edmacro-subseq rest-mac i)))))
(and (eq (aref rest-mac 0) ?\C-u)
(eq (key-binding [?\C-u]) 'universal-argument)
(let ((i 1))
(incf i))
(and (not (memq (aref rest-mac i) pkeys))
(prog1 (loop repeat i concat "C-u ")
- (callf subseq rest-mac i)))))
+ (callf edmacro-subseq rest-mac i)))))
(and (eq (aref rest-mac 0) ?\C-u)
(eq (key-binding [?\C-u]) 'universal-argument)
(let ((i 1))
'(?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9))
(incf i))
(and (not (memq (aref rest-mac i) pkeys))
- (prog1 (concat "C-u " (subseq rest-mac 1 i) " ")
- (callf subseq rest-mac i)))))))
+ (prog1 (vconcat "C-u " (edmacro-subseq rest-mac 1 i) " ")
+ (callf edmacro-subseq rest-mac i)))))))
(bind-len (apply 'max 1
(loop for map in maps
for b = (lookup-key map rest-mac)
when b collect b)))
- (key (subseq rest-mac 0 bind-len))
+ (key (edmacro-subseq rest-mac 0 bind-len))
(fkey nil) tlen tkey
(bind (or (loop for map in maps for b = (lookup-key map key)
thereis (and (not (integerp b)) b))
(and (setq fkey (lookup-key function-key-map rest-mac))
- (setq tlen fkey tkey (subseq rest-mac 0 tlen)
+ (setq tlen fkey tkey (edmacro-subseq rest-mac 0 tlen)
fkey (lookup-key function-key-map tkey))
(loop for map in maps
for b = (lookup-key map fkey)
(> first 32) (<= first maxkey) (/= first 92)
(progn
(if (> text 30) (setq text 30))
- (setq desc (concat (subseq rest-mac 0 text)))
+ (setq desc (concat (edmacro-subseq rest-mac 0 text)))
(when (string-match "^[ACHMsS]-." desc)
(setq text 2)
(callf substring desc 0 2))
(> text bind-len)
(memq (aref rest-mac text) '(return 13))
(progn
- (setq desc (concat (subseq rest-mac bind-len text)))
+ (setq desc (concat (edmacro-subseq rest-mac bind-len text)))
(commandp (intern-soft desc))))
(if (commandp (intern-soft desc)) (setq bind desc))
(setq desc (format "<<%s>>" desc))
(t
(error "Unrecognized item in macro: %s" ch)))))
(or fkey key) " "))))
- (if prefix (setq desc (concat prefix desc)))
+ (if prefix
+ (setq desc (concat (edmacro-sanitize-for-string prefix) desc)))
(unless (string-match " " desc)
(let ((times 1) (pos bind-len))
- (while (not (mismatch rest-mac rest-mac
- :end1 bind-len :start2 pos
- :end2 (+ bind-len pos)))
+ (while (not (edmacro-mismatch rest-mac rest-mac
+ 0 bind-len pos (+ bind-len pos)))
(incf times)
(incf pos bind-len))
(when (> times 1)
(setq desc (format "%d*%s" times desc))
(setq bind-len (* bind-len times)))))
- (setq rest-mac (subseq rest-mac bind-len))
+ (setq rest-mac (edmacro-subseq rest-mac bind-len))
(if verbose
(progn
(unless (equal res "") (callf concat res "\n"))
(incf len (length desc)))))
res))
-(defun edmacro-fix-menu-commands (macro)
- (when (vectorp macro)
- (let ((i 0) ev)
- (while (< i (length macro))
- (when (consp (setq ev (aref macro i)))
- (cond ((equal (cadadr ev) '(menu-bar))
- (setq macro (vconcat (subseq macro 0 i)
- (vector 'menu-bar (car ev))
- (subseq macro (1+ i))))
- (incf i))
+(defun edmacro-mismatch (cl-seq1 cl-seq2 cl-start1 cl-end1 cl-start2 cl-end2)
+ "Compare SEQ1 with SEQ2, return index of first mismatching element.
+Return nil if the sequences match. If one sequence is a prefix of the
+other, the return value indicates the end of the shorted sequence."
+ (let (cl-test cl-test-not cl-key cl-from-end)
+ (or cl-end1 (setq cl-end1 (length cl-seq1)))
+ (or cl-end2 (setq cl-end2 (length cl-seq2)))
+ (if cl-from-end
+ (progn
+ (while (and (< cl-start1 cl-end1) (< cl-start2 cl-end2)
+ (cl-check-match (elt cl-seq1 (1- cl-end1))
+ (elt cl-seq2 (1- cl-end2))))
+ (setq cl-end1 (1- cl-end1) cl-end2 (1- cl-end2)))
+ (and (or (< cl-start1 cl-end1) (< cl-start2 cl-end2))
+ (1- cl-end1)))
+ (let ((cl-p1 (and (listp cl-seq1) (nthcdr cl-start1 cl-seq1)))
+ (cl-p2 (and (listp cl-seq2) (nthcdr cl-start2 cl-seq2))))
+ (while (and (< cl-start1 cl-end1) (< cl-start2 cl-end2)
+ (cl-check-match (if cl-p1 (car cl-p1)
+ (aref cl-seq1 cl-start1))
+ (if cl-p2 (car cl-p2)
+ (aref cl-seq2 cl-start2))))
+ (setq cl-p1 (cdr cl-p1) cl-p2 (cdr cl-p2)
+ cl-start1 (1+ cl-start1) cl-start2 (1+ cl-start2)))
+ (and (or (< cl-start1 cl-end1) (< cl-start2 cl-end2))
+ cl-start1)))))
+
+(defun edmacro-subseq (seq start &optional end)
+ "Return the subsequence of SEQ from START to END.
+If END is omitted, it defaults to the length of the sequence.
+If START or END is negative, it counts from the end."
+ (if (stringp seq) (substring seq start end)
+ (let (len)
+ (and end (< end 0) (setq end (+ end (setq len (length seq)))))
+ (if (< start 0) (setq start (+ start (or len (setq len (length seq))))))
+ (cond ((listp seq)
+ (if (> start 0) (setq seq (nthcdr start seq)))
+ (if end
+ (let ((res nil))
+ (while (>= (setq end (1- end)) start)
+ (push (pop seq) res))
+ (nreverse res))
+ (copy-sequence seq)))
+ (t
+ (or end (setq end (or len (length seq))))
+ (let ((res (make-vector (max (- end start) 0) nil))
+ (i 0))
+ (while (< start end)
+ (aset res i (aref seq start))
+ (setq i (1+ i) start (1+ start)))
+ res))))))
+
+(defun edmacro-sanitize-for-string (seq)
+ "Convert a key sequence vector into a string.
+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))
+ (loop for i below (length seq) do
+ (when (logand (aref seq i) 128)
+ (setf (aref seq i) (logand (aref seq i) 127))))
+ seq)
+
+(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))
+ ((equal ev '(menu-bar))
+ (push 'menu-bar result))
+ ((equal (cadadr ev) '(menu-bar))
+ (push (vector 'menu-bar (car ev)) result))
;; It would be nice to do pop-up menus, too, but not enough
;; info is recorded in macros to make this possible.
+ (noerror
+ ;; Just ignore mouse events.
+ nil)
(t
(error "Macros with mouse clicks are not %s"
"supported by this command"))))
- (incf i))))
- macro)
+ ;; Reverse them again and make them back into a vector.
+ (vconcat (nreverse result)))
+ macro))
\f
;;; Parsing a human-readable keyboard macro.
(times 1))
(setq pos (match-end 0))
(when (string-match "\\([0-9]+\\)\\*." word)
- (setq times (string-to-int (substring word 0 (match-end 1))))
+ (setq times (string-to-number (substring word 0 (match-end 1))))
(setq word (substring word (1+ (match-end 1)))))
(cond ((string-match "^<<.+>>$" word)
(setq key (vconcat (if (eq (key-binding [?\M-x])
(error "%s must prefix a single character, not %s"
(substring orig-word 0 prefix) word))
((and (/= (logand bits ?\C-\^@) 0) (stringp word)
- (string-match "[@-_.a-z?]" word))
+ ;; We used to accept . and ? here,
+ ;; but . is simply wrong,
+ ;; and C-? is not used (we use DEL instead).
+ (string-match "[@-_a-z]" word))
(setq key (list (+ bits (- ?\C-\^@)
- (if (equal word "?") 127
- (logand (aref word 0) 31))))))
+ (logand (aref word 0) 31)))))
(t
(setq key (list (+ bits (aref word 0)))))))))
(when key
(eq (aref res 1) ?\()
(eq (aref res (- (length res) 2)) ?\C-x)
(eq (aref res (- (length res) 1)) ?\)))
- (setq res (subseq res 2 -2)))
+ (setq res (edmacro-subseq res 2 -2)))
(if (and (not need-vector)
(loop for ch across res
- always (and (integerp ch)
+ always (and (char-valid-p ch)
(let ((ch2 (logand ch (lognot ?\M-\^@))))
(and (>= ch2 0) (<= ch2 127))))))
(concat (loop for ch across res
collect (if (= (logand ch ?\M-\^@) 0)
ch (+ ch 128))))
res)))
-\f
-;;; The following probably ought to go in macros.el:
-
-;;;###autoload
-(defun insert-kbd-macro (macroname &optional keys)
- "Insert in buffer the definition of kbd macro NAME, as Lisp code.
-Optional second arg KEYS means also record the keys it is on
-\(this is the prefix argument, when calling interactively).
-
-This Lisp code will, when executed, define the kbd macro with the same
-definition it has now. If you say to record the keys, the Lisp code
-will also rebind those keys to the macro. Only global key bindings
-are recorded since executing this Lisp code always makes global
-bindings.
-
-To save a kbd macro, visit a file of Lisp code such as your `~/.emacs',
-use this command, and then save the file."
- (interactive "CInsert kbd macro (name): \nP")
- (let (definition)
- (if (string= (symbol-name macroname) "")
- (progn
- (setq definition (format-kbd-macro))
- (insert "(setq last-kbd-macro"))
- (setq definition (format-kbd-macro macroname))
- (insert (format "(defalias '%s" macroname)))
- (if (> (length definition) 50)
- (insert " (read-kbd-macro\n")
- (insert "\n (read-kbd-macro "))
- (prin1 definition (current-buffer))
- (insert "))\n")
- (if keys
- (let ((keys (where-is-internal macroname '(keymap))))
- (while keys
- (insert (format "(global-set-key %S '%s)\n" (car keys) macroname))
- (setq keys (cdr keys)))))))
(provide 'edmacro)
+;;; arch-tag: 726807b4-3ae6-49de-b0ae-b9590973e0d7
;;; edmacro.el ends here
-