xemacs-beta: lisp/utils/edmacro.el comparison

comparison lisp/utils/edmacro.el @ 151:59463afc5666 r20-3b2

Import from CVS: tag r20-3b2

author	cvs
date	Mon, 13 Aug 2007 09:37:19 +0200
parents	b980b6286996
children	43dd3413c7c7

comparison

equal deleted inserted replaced

-:8ebb1c0f0f6f
+:59463afc5666
 ;; Copyright (C) 1993, 1994 Free Software Foundation, Inc.
 ;; Author: Dave Gillespie <daveg@synaptics.com>
 ;;         Hrvoje Niksic <hniksic@srce.hr>  -- XEmacs port
 ;; Maintainer: Hrvoje Niksic <hniksic@srce.hr>
-;; Version: 3.10
+;; Version: 3.14
 ;; Keywords: abbrev
 ;; This file is part of XEmacs.
 ;; XEmacs is free software; you can redistribute it and/or modify
 ;; This package requires GNU Emacs 19 or later, and daveg's CL
 ;; package 2.02 or later.  (CL 2.02 comes standard starting with
 ;; Emacs 19.18.)  This package does not work with Emacs 18 or
 ;; Lucid Emacs.
-;; Ported to XEmacs.  -hniksic
+;; Ported to XEmacs.  This code will not run on GNU Emacs 19.  -hniksic
 ;;; Code:
 (eval-when-compile
 (require 'cl))
+(defgroup edmacro nil
+"Keyboard macro editor."
+:group 'keyboard)
+(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 'edmacro)
+(defcustom edmacro-format-hook nil
+"*Hook run after formatting the keyboard macro."
+:type 'hook
+:group 'edmacro)
+(defvar edmacro-finish-hook nil)
+(defvar edmacro-store-hook nil)
+(defvar edmacro-original-buffer nil)
 ;;; The user-level commands for editing macros.
 ;;;###autoload (define-key ctl-x-map "\C-k" 'edit-kbd-macro)
-;;;###autoload
-(defvar 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.")
-(if (fboundp 'mapvector)
-(defalias 'edmacro-mapvector 'mapvector)
-(defun edmacro-mapvector (fun seq)
-(map 'vector fun seq)))
 (defvar edmacro-mode-map nil)
 (unless edmacro-mode-map
 (setq edmacro-mode-map (make-sparse-keymap))
 (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)
-;; A lot of cruft here, but I got it to work eventually.  Could use
-;; some cleaning up.
 ;;;###autoload
 (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.
 Or, type `C-x e' or RET to edit the last keyboard macro, `C-h l' to edit
 the last 100 keystrokes as a keyboard macro, or `M-x' to edit a macro by
 its command name.
 With a prefix argument, format the macro in a more concise way."
 (interactive "kKeyboard macro to edit (C-x e, M-x, C-h l, or keys): \nP")
-(when keys
+(when (vectorp keys)
-(setq keys (edmacro-events-to-keys keys))
+(setq keys (edmacro-events-to-keys keys)))
-(let ((cmd (if (arrayp keys) (key-binding keys) keys))
+(let ((cmd (if (symbolp keys) keys (key-binding keys)))
-	  (mac nil))
+	(mac nil))
 (cond (store-hook
-	     (setq mac keys)
+	   (setq mac keys)
-	     (setq cmd nil))
+	   (setq cmd nil))
-	    ((or (eq cmd 'call-last-kbd-macro)
+	  ((or (eq cmd 'call-last-kbd-macro)
-		 (and (arrayp keys)
+	       (and (arrayp keys)
-		      (= 1 (length keys))
+		    (= 1 (length keys))
-		      (eq ?\r (aref keys 0))))
+		    (or (eq 'return (aref keys 0))
-	     (or last-kbd-macro
+			(eq ?\r (aref keys 0))
-		 (y-or-n-p "No keyboard macro defined.  Create one? ")
+			(equal '(control ?m) (aref keys 0)))))
-		 (keyboard-quit))
+	   (or last-kbd-macro
-	     (setq mac (or last-kbd-macro ""))
+	       (y-or-n-p "No keyboard macro defined.  Create one? ")
-	     (setq cmd 'last-kbd-macro))
+	       (keyboard-quit))
-	    ((eq cmd 'execute-extended-command)
+	   (setq mac (or last-kbd-macro []))
-	     (setq cmd (read-command "Name of keyboard macro to edit: "))
+	   (setq cmd 'last-kbd-macro))
-	     (if (string-equal cmd "")
+	  ((eq cmd 'execute-extended-command)
-		 (error "No command name given"))
+	   (setq cmd (edmacro-minibuf-read "Name of keyboard macro to edit: "))
-	     (setq mac (symbol-function cmd)))
+	   (if (string-equal cmd "")
-	    ((eq cmd 'view-lossage)
+	   (error "No command name given"))
-	     (setq mac (recent-keys))
+	   (setq mac (symbol-function cmd)))
-	     (setq cmd 'last-kbd-macro))
+	  ((eq cmd 'view-lossage)
-	    ((null cmd)
+	   (setq mac (recent-keys))
-	     (error "Key sequence %s is not defined" (key-description keys)))
+	   (setq cmd 'last-kbd-macro))
-	    ((symbolp cmd)
+	  ((null cmd)
-	     (setq mac (symbol-function cmd)))
+	   (error "Key sequence `%s' is not defined" (key-description keys)))
-	    (t
+	  ((symbolp cmd)
-	     (setq mac cmd)
+	   (setq mac (symbol-function cmd)))
-	     (setq cmd nil)))
+	  (t
-(unless (arrayp mac)
+	   (setq mac cmd)
-	(error "Key sequence %s is not a keyboard macro"
+	   (setq cmd nil)))
-	       (key-description keys)))
+(unless (arrayp mac)
-(message "Formatting keyboard macro...")
+(error "Key sequence `%s' is not a keyboard macro"
-(let* ((oldbuf (current-buffer))
+	     (key-description keys)))
-	     (mmac (edmacro-fix-menu-commands mac))
+(message "Formatting keyboard macro...")
-	     (fmt (edmacro-format-keys mmac 1))
+(let ((oldbuf (current-buffer))
-	     (fmtv (edmacro-format-keys mmac (not prefix)))
+	  (fmt (edmacro-format-keys mac))
-	     (buf (get-buffer-create "*Edit Macro*")))
+	  (fmtv (edmacro-format-keys mac (not prefix)))
-	(message "Formatting keyboard macro...done")
+	  (buf (get-buffer-create "*Edit Macro*")))
-	(switch-to-buffer buf)
+(message "Formatting keyboard macro...done")
-	(kill-all-local-variables)
+(switch-to-buffer buf)
-	(use-local-map edmacro-mode-map)
+(kill-all-local-variables)
-	(setq buffer-read-only nil)
+(use-local-map edmacro-mode-map)
-	(setq major-mode 'edmacro-mode)
+(setq buffer-read-only nil)
-	(setq mode-name "Edit Macro")
+(setq major-mode 'edmacro-mode)
-	(set (make-local-variable 'edmacro-original-buffer) oldbuf)
+(setq mode-name "Edit Macro")
-	(set (make-local-variable 'edmacro-finish-hook) finish-hook)
+(set (make-local-variable 'edmacro-original-buffer) oldbuf)
-	(set (make-local-variable 'edmacro-store-hook) store-hook)
+(set (make-local-variable 'edmacro-finish-hook) finish-hook)
-	(erase-buffer)
+(set (make-local-variable 'edmacro-store-hook) store-hook)
-	(insert ";; Keyboard Macro Editor.  Press C-c C-c to finish; "
+(erase-buffer)
-		"press C-x k RET to cancel.\n")
+(insert ";; Keyboard Macro Editor.  Press C-c C-c to finish; "
-	(insert ";; Original keys: " fmt "\n")
+	      "press C-x k RET to cancel.\n")
-	(unless store-hook
+(insert ";; Original keys: " fmt "\n")
-	  (insert "\nCommand: " (if cmd (symbol-name cmd) "none") "\n")
+(unless store-hook
-	  (let ((keys (where-is-internal (or cmd mac))))
+	(insert "\nCommand: " (if cmd (symbol-name cmd) "none") "\n")
-	    (if keys
+	(let ((keys (where-is-internal (or cmd mac))))
-		(while keys
+	  (if keys
-		  (insert "Key: " (edmacro-format-keys (pop keys) 1) "\n"))
+	      (insert "Key: " (edmacro-format-keys (car keys)) "\n")
-	      (insert "Key: none\n"))))
+	    (insert "Key: none\n"))))
-	(insert "\nMacro:\n\n")
+(insert "\nMacro:\n\n")
-	(save-excursion
+(save-excursion
-	  (insert fmtv "\n"))
+	(insert fmtv "\n"))
-	(recenter '(4))
+(recenter '(4))
-	(when (eq mac mmac)
+(run-hooks 'edmacro-format-hook))))
-	  (set-buffer-modified-p nil))
-	(run-hooks 'edmacro-format-hook)))))
 ;;; The next two commands are provided for convenience and backward
 ;;; compatibility.
 ;;;###autoload
 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."
 (interactive "r")
 (if (stringp start)
-(edmacro-parse-keys start end)
+(edmacro-parse-keys start)
 (setq last-kbd-macro (edmacro-parse-keys (buffer-substring start end)))))
 ;;;###autoload
 (defmacro kbd (keys)
 "Convert KEYS to the internal Emacs key representation."
 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))
 ;;; Commands for *Edit Macro* buffer.
 (defun edmacro-finish-edit ()
 (interactive)
 			  (let ((b (key-binding key)))
 			    (and b (commandp b) (not (arrayp b))
 				 (or (not (fboundp b))
 				     (not (arrayp (symbol-function b))))
 				 (not (y-or-n-p
-				       (format "Key %s is already defined; %s"
+				       (format
-					       (edmacro-format-keys key 1)
+					"Key `%s' is already defined; %s"
-					       "proceed? ")))
+					(edmacro-format-keys key)
+					"proceed? ")))
 				 (keyboard-quit))))))
 		    t)
 		   ((looking-at "Macro:[ \t\n]*")
 		    (goto-char (match-end 0))
 		    nil)
 (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)
+	   (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))
 		    (loop for key in keys do (global-unset-key key))
 		  (loop for key in keys do
 			(global-set-key key (or cmd mac)))))))))
 (kill-buffer buf)
 (when (buffer-name obuf)
-	(switch-to-buffer 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)
 is seven keys but `<right>' is a single function key.  When in
 doubt, use whitespace."
 (interactive)
 (error "This mode can be enabled only by `edit-kbd-macro'"))
 (put 'edmacro-mode 'mode-class 'special)
 (defun edmacro-int-char (int)
-(if (fboundp 'char-to-int)
+(if (fboundp 'int-char)
-(char-to-int int)
+(int-char int)
 int))
+(defvar edmacro-read-history nil)
+;; Completing read on named keyboard macros only.
+(defun edmacro-minibuf-read (prompt)
+(intern (completing-read
+	   prompt obarray
+	   (lambda (arg)
+	     (and (commandp arg)
+		  (vectorp (symbol-function arg))))
+	   t nil 'edmacro-read-history)))
+(defvar edmacro-char-to-word
+'((?\0 . "NUL")
+(?\r . "RET")
+(?\n . "LFD")
+(?\t . "TAB")
+(?\e . "ESC")
+(?\  . "SPC")
+(?\C-? . "DEL")))
+(defvar edmacro-modifiers
+'(("C" . control)
+("M" . meta)
+("S" . shift)
+("Sh" . shift)
+("A" . alt)
+("H" . hyper)
+("s" . super)))
 ;;; Parsing a human-readable keyboard macro.
 ;; Changes for XEmacs -- these two functions re-written from scratch.
 ;; edmacro-parse-keys always returns a vector.  edmacro-format-keys
 ;; accepts a vector (but works with a string too).  Vector may contain
 ;; keypress events.      -hniksic
-(defun edmacro-parse-keys (string &optional ignored)
+(defun edmacro-parse-keys (string)
 (let* ((pos 0)
 	 (case-fold-search nil)
-	 (word-to-sym '(("NUL" . ?\0)
-			("RET" . return)
-			("LFD" . linefeed)
-			("TAB" . tab)
-			("ESC" . escape)
-			("SPC" . space)
-			("BS" . backspace)
-			("DEL" . delete)))
-	 (char-to-word '((?\0 . "NUL")
-			 (?\r . "RET")
-			 (?\n . "LFD")
-			 (?\t . "TAB")
-			 (?\e . "ESC")
-			 (?\  . "SPC")
-			 (?\C-? . "DEL")))
-	 (modifier-prefix-alist '(("C" . control)
-				  ("M" . meta)
-				  ("S" . shift)
-				  ("Sh" . shift)
-				  ("A" . alt)
-				  ("H" . hyper)
-				  ("s" . super)))
-	 ;; string-to-symbol-or-char converter
-	 (conv (lambda (arg)
-		 (if (= (length arg) 1)
-		     (aref arg 0)
-		   (if (string-match "^<\\([^>]+\\)>$" arg)
-		       (setq arg (match-string 1 arg)))
-		   (let ((match (assoc arg word-to-sym)))
-		     (if match
-			 (cdr match)
-			 (intern arg))))))
-	 (conv-chars (lambda (arg)
-		       (let ((match (assoc arg char-to-word)))
-			 (if match
-			     (cdr (assoc (cdr match) word-to-sym))
-			   arg))))
 	 res)
 (while (and (< pos (length string))
-		(string-match "[^ \t\n\f]+" string pos))
+		(string-match "[^ \t\r\n\f]+" string pos))
-(let ((word (substring string (match-beginning 0) (match-end 0)))
+(let ((word (substring string (match-beginning 0) (match-end 0))))
-	    (times 1)
-	    (force-sym nil)
-	    (add nil)
-	    match)
 	(setq pos (match-end 0))
-	(when (string-match "\\([0-9]+\\)\\*." word)
+	(if (or (equal word "REM") (string-match "^;;" word))
-	  (setq times (string-to-int (substring word 0 (match-end 1))))
+	    ;; Comment (discard to EOL) .
-	  (setq word (substring word (1+ (match-end 1)))))
+	    (setq pos (string-match "$" string pos))
-	(when (string-match "^<\\([^<>]+\\)>$" word)
+	  (push (edmacro-parse-word word) res))))
-	  (setq word (match-string 1 word))
+(mapvector 'identity (apply 'nconc (nreverse res)))))
-	  (setq force-sym t))
-	(setq match (assoc word word-to-sym))
+;; Parse a word.
-	;; Add an element; `add' holds the list of elements to be
+(defun edmacro-parse-word (word)
-	;; added.
+(let ((force-sym nil)
-	(cond ((string-match "^\\\\[0-7]+" word)
+	(times 1)
-	       ;; Octal value of character.
+	abbr)
-	       (setq add
+(when (string-match "\\([0-9]+\\)\\*." word)
-		     (list
+(setq times (string-to-int (substring word 0 (match-end 1))))
-		      (edmacro-int-char
+(setq word (substring word (1+ (match-end 1)))))
-		       (edmacro-octal-string-to-integer (substring word 1))))))
+(when (string-match "^<\\([^<>]+\\)>$" word)
-	      ((string-match "^<<.+>>$" word)
+(setq word (match-string 1 word))
-	       ;; Extended command.
+(setq force-sym t))
-	       (setq add
+(let* ((word-to-sym '(("NUL" . ?\0)
-		     (nconc
+			  ("RET" . return)
-		      (list
+			  ("LFD" . linefeed)
-		       (if (eq (key-binding [(meta x)])
+			  ("TAB" . tab)
-			       'execute-extended-command)
+			  ("ESC" . escape)
-			   '(meta x)
+			  ("SPC" . space)
-			 (or (car (where-is-internal
+			  ("BS" . backspace)
-				   'execute-extended-command))
+			  ("DEL" . delete)))
-			     '(meta x))))
+	   (conv (lambda (arg)
-		      (mapcar conv-chars (concat (substring word 2 -2) "\r")))
+		   ;; string-to-symbol-or-char converter
-		     ))
+		   (if (= (length arg) 1)
-	      ((or (equal word "REM") (string-match "^;;" word))
+		       (aref arg 0)
-	       ;; Comment (discard to EOL) .
+		     (if (string-match "^<\\([^>]+\\)>$" arg)
-	       (setq pos (string-match "$" string pos)))
+			 (setq arg (match-string 1 arg)))
-	      (match
+		     (let ((match (assoc arg word-to-sym)))
-	       ;; Convert to symbol.
+		       (if match
-	       (setq add (list (cdr match))))
+			   (cdr match)
-	      ((string-match "^\\^" word)
+			 (intern arg))))))
-	       ;; ^X == C-x
+	   (conv-chars (lambda (arg)
-	       (if (/= (length word) 2)
+			 (let ((match (assoc arg edmacro-char-to-word)))
-		   (error "^ must be followed by one character"))
+			   (if match
-	       (setq add (list 'control (aref word 0))))
+			       (cdr (assoc (cdr match) word-to-sym))
-	      ((string-match "^\\([MCSsAH]\\|Sh\\)-" word)
+			     arg))))
-	       ;; Parse C-* and stuff
+	   (add
-	       (setq
+	    (cond
-		add
+	     ((string-match "^\\\\[0-7]+" word)
-		(list
+	      ;; Octal value of character.
-		 (let ((pos1 0)
+	      (list
-		       (r1 nil)
+	       (edmacro-int-char
-		       follow curpart prefix)
+		(hexl-octal-string-to-integer (substring word 1)))))
-		   (while (progn (setq curpart (substring word pos1))
+	     ((string-match "^<<.+>>$" word)
-				 (string-match "^\\([MCSsAH]\\|Sh\\)-"
+	      ;; Extended command.
-					       curpart))
+	      (nconc
-		     (setq prefix (assoc (match-string 1 curpart)
+	       (list
-					 modifier-prefix-alist))
+		(if (eq (key-binding [(meta x)])
-		     (setq r1 (nconc r1 (list (cdr prefix))))
+			'execute-extended-command)
-		     (callf + pos1 (1+ (length (car prefix)))))
+		    '(meta x)
-		   (setq follow (substring word pos1))
+		  (or (car (where-is-internal
-		   (if (equal follow "")
+			    'execute-extended-command))
-		       (error "%s must precede a string"
+		      '(meta x))))
-			      (substring word 0 pos1)))
+	       (mapcar conv-chars (concat (substring word 2 -2) "\r"))))
-		   (nconc r1 (list (funcall conv follow)))))))
+	     ((setq abbr (assoc word word-to-sym))
-	      (force-sym
+	      ;; Convert to symbol.
-	       ;; This must be a symbol
+	      (list (cdr abbr)))
-	       (setq add (list (intern word))))
+	     ((string-match "^\\^" word)
-	      (t
+	      ;; ^X == C-x
-	       ;; Characters
+	      (if (/= (length word) 2)
-	       (setq add (mapcar conv-chars word))))
+		  (error "^ must be followed by one character"))
-	(let ((new nil))
+	      `((control ,(aref word 1))))
-	  (loop repeat times do (setq new (append new add)))
+	     ((string-match "^\\([MCSsAH]\\|Sh\\)-" word)
-	  (setq add new))
+	      ;; Parse C-* and stuff
-	(setq res (nconc res add))))
+	      (list
-(edmacro-mapvector 'identity res)))
+	       (let ((pos1 0)
+		     (r1 nil)
+		     follow curpart prefix)
+		 (while (progn (setq curpart (substring word pos1))
+			       (string-match "^\\([MCSsAH]\\|Sh\\)-"
+					     curpart))
+		   (setq prefix (assoc (match-string 1 curpart)
+				       edmacro-modifiers))
+		   (push (cdr prefix) r1)
+		   (incf pos1 (1+ (length (car prefix)))))
+		 (setq follow (substring word pos1))
+		 (if (equal follow "")
+		     (error "%s must precede a string"
+			    (substring word 0 pos1)))
+		 (nconc (nreverse r1) (list (funcall conv follow))))))
+	     (force-sym
+	      ;; This must be a symbol
+	      (list (intern word)))
+	     (t
+	      ;; Characters
+	      (mapcar conv-chars word))))
+	   (new nil))
+	   (loop repeat times do (setq new (append add new)))
+	   new)))
+;; Convert the keypress events in vector x to keys, and return a
+;; vector of keys.  If a list element is not a keypress event, ignore
+;; it.
+(defun edmacro-events-to-keys (x &optional list)
+(let (new)
+(mapc (lambda (el)
+	    (cond ((key-press-event-p el)
+		   (push (let ((mods (event-modifiers el)))
+			   (if mods
+			       (append mods (list (event-key el)))
+			     (event-key el)))
+			 new))
+		  ((or (characterp el)
+		       (symbolp el)
+		       (listp el))
+		   (push el new))))
+	  x)
+(setq new (nreverse new))
+(if list
+	new
+(mapvector 'identity new))))
+;; Collapse a list of keys into a list of function keys, where
+;; applicable.
+(defun edmacro-fkeys (keys)
+(let (new k lookup)
+(while keys
+(setq k (nconc k (list (car keys))))
+(setq lookup (lookup-key function-key-map (mapvector 'identity k)))
+(cond ((vectorp lookup)
+	     (push (mapcar 'identity lookup) new)
+	     (setq k nil))
+	    ((keymapp lookup)
+	     nil)
+	    ((null lookup)
+	     (push k new)
+	     (setq k nil))
+	    (t
+	     (setq k nil)))
+(pop keys))
+(when (keymapp lookup)
+	(push k new))
+(apply 'nconc (nreverse new))))
+;; Convert a character or symbol to string
 (defun edmacro-conv (char-or-sym add-<>)
 (let ((char-to-word '((?\0 . "NUL")
 			(?\r . "RET")
 			(?\n . "LFD")
 			(?\t . "TAB")
 (defun edmacro-format-1 (keys command times togetherp)
 (let ((res "")
 	(start keys)
 	el)
 (while keys
-(unless (or (eq start keys) togetherp)
+(when (or (eq (car keys) ?-)
+		(eq (car keys) '-)
+		(not (or togetherp (eq start keys))))
 	(callf concat res " "))
 (if (> times 1)
 	  (setq res (concat (format "%d*" times) res)))
 (setq el (car keys))
 (callf concat res
 	(cond ((listp el)
 	       (let ((my ""))
 		 (if (or
 		      (let (cnv)
 			(while el
-			  (let ((found (assq (car el)
+			  (let ((found (find (car el) edmacro-modifiers
-					     '((control . "C-")
+					     :key 'cdr)))
-					       (meta . "M-")
-					       (shift . "S-")
-					       (alt . "A-")
-					       (hyper . "H-")
-					       (super . "s-")))))
 			    (callf concat my
 			      (if found
-				  (cdr found)
+				  (concat (car found) "-")
 				(setq cnv (edmacro-conv (car el) nil))
 				(cdr cnv))))
-			  (setq el (cdr el)))
+			  (pop el))
 			(car cnv))
 		      (> times 1))
 		     (concat "<" my ">")
 		   my)))
 	      (t
 	       (cdr (edmacro-conv el t)))))
-(setq keys (cdr keys)))
+(pop keys))
 (if command
 	(callf concat res
-	  (concat
+	  (make-string (max (- 3 (/ (length res) tab-width)) 1) ?\t)
-	   (make-string (max (- 3 (/ (length res) tab-width)) 1) ?\t)
+	  ";; "
-	   ";; "
+	  (symbol-name command)
-	   (symbol-name command)
+	  (if togetherp (format " * %d" (length start)))))
-	   (if togetherp (format " * %d" (length start))))))
 res))
-;; Convert the keypress events in vector x to keys, and return a
+(defsubst edmacro-seq-equal (seq1 seq2)
-;; vector of keys.  If a list element is not a keypress event, ignore
+(while (and seq1 seq2
-;; it.
+	      (equal (car seq1) (car seq2)))
-(defun edmacro-events-to-keys (x)
+(pop seq1)
-(if (or (not (fboundp 'events-to-keys))
+(pop seq2))
-	  (not (arrayp x)))
+(not seq1))
-x
-(let ((cnt 0)
-	  (len (length x))
-	  new el)
-(while (< cnt len)
-	(setq el (aref x cnt))
-	(cond ((eventp el)
-	       (if (mouse-event-p el)
-		   (setq el nil)
-		 (setq el (aref (events-to-keys (vector el)) 0))))
-	      (t
-	       nil))			; leave it be.
-	(if el
-	    (setq new (nconc new (list el))))
-	(incf cnt))
-(edmacro-mapvector 'identity new))))
-;; Collapse a list of keys into a list of function keys, where
-;; applicable.
-(defun edmacro-fkeys (keys)
-(let (new k lookup)
-(while keys
-(setq k (nconc k (list (car keys))))
-(setq lookup (lookup-key function-key-map (edmacro-mapvector 'identity k)))
-(cond ((vectorp lookup)
-	     (setq new (nconc new (mapcar 'identity lookup)))
-	     (setq k nil))
-	    ((keymapp lookup)
-	     nil)
-	    ((null lookup)
-	     (setq new (nconc new k))
-	     (setq k nil))
-	    (t
-	     (setq k nil)))
-(setq keys (cdr keys)))
-(if (keymapp lookup)
-	(setq new (nconc new k)))
-new))
 ;;; Formatting a keyboard macro as human-readable text.
 (defun edmacro-format-keys (macro &optional verbose)
 ;; XEmacs:
-;; If we're dealing with events, convert them to symbols first.
+;; If we're dealing with events, convert them to symbols first;
-(setq macro (edmacro-events-to-keys macro))
+;; also, deal with Fkeys.
-(if (zerop (length macro))
+(setq macro (edmacro-fkeys (edmacro-events-to-keys macro t)))
-""
+(let ((res ""))
-(let ((res ""))
+(while macro
-;; I'm not sure I understand the original code, but this seems to
+(let (key lookup (times 1) self-insert-p)
-;; work.
+	(loop
-(and (eq verbose 1)
+	 do (setq key (nconc key (list (car macro)))
-	   (setq verbose nil))
+		  macro (cdr macro)
+		  lookup (lookup-key global-map (mapvector
-;; We prefer a list -- much easier to process...
+						 'identity key)))
-(setq macro (mapcar 'identity macro))
+	 while (and macro lookup (not (commandp lookup))))
-(setq macro (edmacro-fkeys macro))
+	;; keyboard macro
-(while macro
+	(if (vectorp lookup)
-	(let (key lookup (times 1) self-insert-p)
+	    (setq lookup nil))
-	  (loop do
+	(if (and (eq lookup 'self-insert-command)
-		(setq key (nconc key (list (car macro)))
+		 (= (length key) 1)
-		      macro (cdr macro)
+		 (not (memq (car key)
-		      lookup (lookup-key global-map (edmacro-mapvector
+			    '(?\  ?\r ?\n space return linefeed tab))))
-						     'identity key)))
+	    (while (and (< (length key) 23)
-		while
+			(eq (lookup-key global-map (car macro))
-		(and macro lookup (not (commandp lookup))))
+			    'self-insert-command)
-	  ;; keyboard macro
+			(not (memq
-	  (if (vectorp lookup)
+			      (car macro)
-	      (setq lookup nil))
-	  (if (and (eq lookup 'self-insert-command)
-		   (= (length key) 1)
-		   (not (memq (car key)
 			      '(?\  ?\r ?\n space return linefeed tab))))
-	      (while (and (< (length key) 23)
+	      (setq key (nconc key (list (car macro)))
-			  (eq (lookup-key global-map (car macro))
+		    macro (cdr macro)
-			      'self-insert-command)
+		    self-insert-p t))
-			  (not (memq
+	  (let ((keysize (length key)))
-				(car macro)
-				'(?\  ?\r ?\n space return linefeed tab))))
-		(setq key (nconc key (list (car macro)))
-		      macro (cdr macro)
-		      self-insert-p t))
 	    (while (edmacro-seq-equal key macro)
-	      (setq macro (nthcdr (length key) macro))
+	      (setq macro (nthcdr keysize macro))
-	      (incf times)))
+	      (incf times))))
-	  (if (or self-insert-p
+	(if (or self-insert-p
-		  (null (cdr key))
+		(null (cdr key))
-		  (= times 1))
+		(= times 1))
-	      (callf concat res (edmacro-format-1 key (if verbose lookup
+	    (callf concat res
-							nil)
+	      (edmacro-format-1 key (if verbose lookup
-						  times self-insert-p)
+				      nil)
-		     (and macro (if verbose "\n" " ")))
+				times self-insert-p)
-	    (loop repeat times
+	      (and macro (if verbose "\n" " ")))
-		  do
+	  (loop
-		  (callf concat res
+	   repeat times
-		    (edmacro-format-1 key (if verbose lookup
+	   do
-					    nil)
+	   (callf concat res
-				      1 self-insert-p)
+	     (edmacro-format-1 key (if verbose lookup
-		    (and macro (if verbose "\n" " ")))))))
+				     nil)
-res)))
+			       1 self-insert-p)
+	     (and macro (if verbose "\n" " ")))))))
-(defun edmacro-seq-equal (seq1 seq2)
+res))
-(while (and seq1 seq2
-	      (equal (car seq1) (car seq2)))
-(setq seq1 (cdr seq1)
-	  seq2 (cdr seq2)))
-(not seq1))
-(defsubst edmacro-oct-char-to-integer (character)
-"Take a char and return its value as if it was a octal digit."
-(if (and (>= character ?0) (<= character ?7))
-(- character ?0)
-(error (format "Invalid octal digit `%c'." character))))
-(defun edmacro-octal-string-to-integer (octal-string)
-"Return decimal integer for OCTAL-STRING."
-(interactive "sOctal number: ")
-(let ((oct-num 0))
-(while (not (equal octal-string ""))
-(setq oct-num (+ (* oct-num 8)
-		       (edmacro-oct-char-to-integer
-			(string-to-char octal-string))))
-(setq octal-string (substring octal-string 1)))
-oct-num))
-(defun edmacro-fix-menu-commands (macro)
-(when (vectorp macro)
-(let ((i 0) ev)
-(while (< i (length macro))
-	(when (and (consp (setq ev (aref macro i)))
-		   (not (memq (car ev)	; ha ha
-			      '(hyper super meta alt control shift))))
-	  (cond ((equal (cadadr ev) '(menu-bar))
-		 (setq macro (vconcat (edmacro-subseq macro 0 i)
-				      (vector 'menu-bar (car ev))
-				      (edmacro-subseq macro (1+ i))))
-		 (incf i))
-		;; It would be nice to do pop-up menus, too, but not enough
-		;; info is recorded in macros to make this possible.
-		(t
-		 (error "Macros with mouse clicks are not %s"
-			"supported by this command"))))
-	(incf i))))
-macro)
 ;;; The following probably ought to go in macros.el:
 ;;;###autoload
 (insert "))\n")
 (if keys
 	(let ((keys (where-is-internal macroname)))
 	  (while keys
 	    (insert (format "(global-set-key %S '%s)\n" (car keys) macroname))
-	    (setq keys (cdr keys)))))))
+	    (pop keys))))))
 (provide 'edmacro)
 ;;; edmacro.el ends here

Mercurial > hg > xemacs-beta

comparison lisp/utils/edmacro.el @ 151:59463afc5666 r20-3b2