Mercurial > hg > xemacs-beta

comparison lisp/utils/edmacro.el @ 134:34a5b81f86ba r20-2b1

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-2b1
author cvs
date Mon, 13 Aug 2007 09:30:11 +0200
parents 7d55a9ba150c
children b980b6286996
comparison
equal deleted inserted replaced
133:b27e67717092 134:34a5b81f86ba
3 ;; Copyright (C) 1993, 1994 Free Software Foundation, Inc. 3 ;; Copyright (C) 1993, 1994 Free Software Foundation, Inc.
4 4
5 ;; Author: Dave Gillespie <daveg@synaptics.com> 5 ;; Author: Dave Gillespie <daveg@synaptics.com>
6 ;; Hrvoje Niksic <hniksic@srce.hr> -- XEmacs port 6 ;; Hrvoje Niksic <hniksic@srce.hr> -- XEmacs port
7 ;; Maintainer: Hrvoje Niksic <hniksic@srce.hr> 7 ;; Maintainer: Hrvoje Niksic <hniksic@srce.hr>
8 ;; Version: 3.07 8 ;; Version: 3.09
9 ;; Keywords: abbrev 9 ;; Keywords: abbrev
10 10
11 ;; This file is part of XEmacs. 11 ;; This file is part of XEmacs.
12 12
13 ;; XEmacs is free software; you can redistribute it and/or modify 13 ;; XEmacs is free software; you can redistribute it and/or modify
52 ;; Also, the `read-kbd-macro' command parses the region as 52 ;; Also, the `read-kbd-macro' command parses the region as
53 ;; a keyboard macro, and installs it as the "current" macro. 53 ;; a keyboard macro, and installs it as the "current" macro.
54 ;; This and `format-kbd-macro' can also be called directly as 54 ;; This and `format-kbd-macro' can also be called directly as
55 ;; Lisp functions. 55 ;; Lisp functions.
56 56
57 ;; The `kbd' macro calls `read-kbd-macro', but it is evaluated at 57 ;; The `kbd' function is a shorter name for `read-kbd-macro'. It is
58 ;; compile-time. It is good to use in your programs and 58 ;; good to use in your programs and initializations, as you needn't
59 ;; initializations, as you needn't know the internal keysym 59 ;; know the internal keysym representation. For example:
60 ;; representation. For example:
61 ;; 60 ;;
62 ;; (define-key foo-mode-map (kbd "C-c <up>") 'foo-up) 61 ;; (define-key foo-mode-map (kbd "C-c <up>") 'foo-up)
62 ;;
63 ;; is the equivalent of 63 ;; is the equivalent of
64 ;;
64 ;; (define-key foo-mode-map [(control ?c) up] 'foo-up) 65 ;; (define-key foo-mode-map [(control ?c) up] 'foo-up)
66 ;;
65 67
66 ;; Type `C-h m', or see the documentation for `edmacro-mode' below, 68 ;; Type `C-h m', or see the documentation for `edmacro-mode' below,
67 ;; for information about the format of written keyboard macros. 69 ;; for information about the format of written keyboard macros.
68 70
69 ;; `edit-kbd-macro' formats the macro with one command per line, 71 ;; `edit-kbd-macro' formats the macro with one command per line,
78 ;; This package requires GNU Emacs 19 or later, and daveg's CL 80 ;; This package requires GNU Emacs 19 or later, and daveg's CL
79 ;; package 2.02 or later. (CL 2.02 comes standard starting with 81 ;; package 2.02 or later. (CL 2.02 comes standard starting with
80 ;; Emacs 19.18.) This package does not work with Emacs 18 or 82 ;; Emacs 19.18.) This package does not work with Emacs 18 or
81 ;; Lucid Emacs. 83 ;; Lucid Emacs.
82 84
83 ;; But it works with XEmacs. At least the modified version. -hniksic 85 ;; Ported to XEmacs. -hniksic
84 86
85 ;;; Code: 87 ;;; Code:
86 88
87 (eval-when-compile 89 (eval-when-compile
88 (require 'cl)) 90 (require 'cl))
93 95
94 ;;;###autoload 96 ;;;###autoload
95 (defvar edmacro-eight-bits nil 97 (defvar edmacro-eight-bits nil
96 "*Non-nil if edit-kbd-macro should leave 8-bit characters intact. 98 "*Non-nil if edit-kbd-macro should leave 8-bit characters intact.
97 Default nil means to write characters above \\177 in octal notation.") 99 Default nil means to write characters above \\177 in octal notation.")
100
101 (if (fboundp 'mapvector)
102 (defalias 'edmacro-mapvector 'mapvector)
103 (defun edmacro-mapvector (fun seq)
104 (map 'vector fun seq)))
98 105
99 (defvar edmacro-mode-map nil) 106 (defvar edmacro-mode-map nil)
100 (unless edmacro-mode-map 107 (unless edmacro-mode-map
101 (setq edmacro-mode-map (make-sparse-keymap)) 108 (setq edmacro-mode-map (make-sparse-keymap))
102 (define-key edmacro-mode-map "\C-c\C-c" 'edmacro-finish-edit) 109 (define-key edmacro-mode-map "\C-c\C-c" 'edmacro-finish-edit)
104 111
105 (defvar edmacro-store-hook) 112 (defvar edmacro-store-hook)
106 (defvar edmacro-finish-hook) 113 (defvar edmacro-finish-hook)
107 (defvar edmacro-original-buffer) 114 (defvar edmacro-original-buffer)
108 115
116 ;; A lot of cruft here, but I got it to work eventually. Could use
117 ;; some cleaning up.
109 ;;;###autoload 118 ;;;###autoload
110 (defun edit-kbd-macro (keys &optional prefix finish-hook store-hook) 119 (defun edit-kbd-macro (keys &optional prefix finish-hook store-hook)
111 "Edit a keyboard macro. 120 "Edit a keyboard macro.
112 At the prompt, type any key sequence which is bound to a keyboard macro. 121 At the prompt, type any key sequence which is bound to a keyboard macro.
113 Or, type `C-x e' or RET to edit the last keyboard macro, `C-h l' to edit 122 Or, type `C-x e' or RET to edit the last keyboard macro, `C-h l' to edit
215 (if (stringp start) 224 (if (stringp start)
216 (edmacro-parse-keys start end) 225 (edmacro-parse-keys start end)
217 (setq last-kbd-macro (edmacro-parse-keys (buffer-substring start end))))) 226 (setq last-kbd-macro (edmacro-parse-keys (buffer-substring start end)))))
218 227
219 ;;;###autoload 228 ;;;###autoload
220 (defmacro kbd (keys) 229 (defun kbd (keys)
221 "Convert KEYS to the internal Emacs key representation." 230 "Convert KEYS to the internal Emacs key representation."
222 `(eval-when-compile 231 (read-kbd-macro keys))
223 (read-kbd-macro ,keys)))
224 232
225 ;;;###autoload 233 ;;;###autoload
226 (defun format-kbd-macro (&optional macro verbose) 234 (defun format-kbd-macro (&optional macro verbose)
227 "Return the keyboard macro MACRO as a human-readable string. 235 "Return the keyboard macro MACRO as a human-readable string.
228 This string is suitable for passing to `read-kbd-macro'. 236 This string is suitable for passing to `read-kbd-macro'.
419 ;; Changes for XEmacs -- these two functions re-written from scratch. 427 ;; Changes for XEmacs -- these two functions re-written from scratch.
420 ;; edmacro-parse-keys always returns a vector. edmacro-format-keys 428 ;; edmacro-parse-keys always returns a vector. edmacro-format-keys
421 ;; accepts a vector (but works with a string too). Vector may contain 429 ;; accepts a vector (but works with a string too). Vector may contain
422 ;; keypress events. -hniksic 430 ;; keypress events. -hniksic
423 (defun edmacro-parse-keys (string &optional ignored) 431 (defun edmacro-parse-keys (string &optional ignored)
424 (let ((pos 0) 432 (let* ((pos 0)
425 (case-fold-search nil) 433 (case-fold-search nil)
426 (word-to-sym '(("NUL" . (control space)) 434 (word-to-sym '(("NUL" . (control space))
427 ("RET" . return) 435 ("RET" . return)
428 ("LFD" . linefeed) 436 ("LFD" . linefeed)
429 ("TAB" . tab) 437 ("TAB" . tab)
430 ("ESC" . escape) 438 ("ESC" . escape)
431 ("SPC" . space) 439 ("SPC" . space)
432 ("BS" . backspace) 440 ("BS" . backspace)
433 ("DEL" . delete))) 441 ("DEL" . delete)))
434 (char-to-word '((?\0 . "NUL") 442 (char-to-word '((?\0 . "NUL")
435 (?\r . "RET") 443 (?\r . "RET")
436 (?\n . "LFD") 444 (?\n . "LFD")
437 (?\t . "TAB") 445 (?\t . "TAB")
438 (?\e . "ESC") 446 (?\e . "ESC")
439 (?\ . "SPC") 447 (?\ . "SPC")
440 (?\C-? . "DEL"))) 448 (?\C-? . "DEL")))
441 (modifier-prefix-alist '(("C" . control) 449 (modifier-prefix-alist '(("C" . control)
442 ("M" . meta) 450 ("M" . meta)
443 ("S" . shift) 451 ("S" . shift)
444 ("Sh" . shift) 452 ("Sh" . shift)
445 ("A" . alt) 453 ("A" . alt)
446 ("H" . hyper) 454 ("H" . hyper)
447 ("s" . super))) 455 ("s" . super)))
448 ;; string-to-symbol-or-char converter 456 ;; string-to-symbol-or-char converter
449 (conv #'(lambda (arg) 457 (conv (lambda (arg)
450 (if (= (length arg) 1) 458 (if (= (length arg) 1)
451 (aref arg 0) 459 (aref arg 0)
452 (if (string-match "^<\\([^>]+\\)>$" arg) 460 (if (string-match "^<\\([^>]+\\)>$" arg)
453 (setq arg (match-string 1 arg))) 461 (setq arg (match-string 1 arg)))
454 (let ((match (assoc arg word-to-sym))) 462 (let ((match (assoc arg word-to-sym)))
455 (if match 463 (if match
456 (cdr match) 464 (cdr match)
457 (intern arg)))))) 465 (intern arg))))))
458 (conv-chars #'(lambda (arg) 466 (conv-chars (lambda (arg)
459 (let ((match (assoc arg char-to-word))) 467 (let ((match (assoc arg char-to-word)))
460 (if match 468 (if match
461 (cdr (assoc (cdr match) word-to-sym)) 469 (cdr (assoc (cdr match) word-to-sym))
462 arg)))) 470 arg))))
463 res) 471 res)
464 (while (and (< pos (length string)) 472 (while (and (< pos (length string))
465 (string-match "[^ \t\n\f]+" string pos)) 473 (string-match "[^ \t\n\f]+" string pos))
466 (let ((word (substring string (match-beginning 0) (match-end 0))) 474 (let ((word (substring string (match-beginning 0) (match-end 0)))
467 (times 1) 475 (times 1)
468 (force-sym nil) 476 (force-sym nil)
469 (add nil)) 477 (add nil)
478 match)
470 (setq pos (match-end 0)) 479 (setq pos (match-end 0))
471 (when (string-match "\\([0-9]+\\)\\*." word) 480 (when (string-match "\\([0-9]+\\)\\*." word)
472 (setq times (string-to-int (substring word 0 (match-end 1)))) 481 (setq times (string-to-int (substring word 0 (match-end 1))))
473 (setq word (substring word (1+ (match-end 1))))) 482 (setq word (substring word (1+ (match-end 1)))))
474 (when (string-match "^<\\([^<>]+\\)>$" word) 483 (when (string-match "^<\\([^<>]+\\)>$" word)
475 (setq word (match-string 1 word)) 484 (setq word (match-string 1 word))
476 (setq force-sym t)) 485 (setq force-sym t))
477 (setq match (assoc word word-to-sym)) 486 (setq match (assoc word word-to-sym))
478 ;; Add an element. 487 ;; Add an element; `add' holds the list of elements to be
488 ;; added.
479 (cond ((string-match "^\\\\[0-7]+" word) 489 (cond ((string-match "^\\\\[0-7]+" word)
480 ;; Octal value of character. 490 ;; Octal value of character.
481 (setq add 491 (setq add
482 (list 492 (list
483 (edmacro-int-char 493 (edmacro-int-char
494 'execute-extended-command)) 504 'execute-extended-command))
495 '(meta x)))) 505 '(meta x))))
496 (mapcar conv-chars (concat (substring word 2 -2) "\r"))) 506 (mapcar conv-chars (concat (substring word 2 -2) "\r")))
497 )) 507 ))
498 ((or (equal word "REM") (string-match "^;;" word)) 508 ((or (equal word "REM") (string-match "^;;" word))
499 ;; Comment. 509 ;; Comment (discard to EOL) .
500 (setq pos (string-match "$" string pos))) 510 (setq pos (string-match "$" string pos)))
501 (match 511 (match
502 ;; Convert to symbol. 512 ;; Convert to symbol.
503 (setq add (list (cdr match)))) 513 (setq add (list (cdr match))))
504 ((string-match "^\\^" word) 514 ((string-match "^\\^" word)
534 (setq add (mapcar conv-chars word)))) 544 (setq add (mapcar conv-chars word))))
535 (let ((new nil)) 545 (let ((new nil))
536 (loop repeat times do (setq new (append new add))) 546 (loop repeat times do (setq new (append new add)))
537 (setq add new)) 547 (setq add new))
538 (setq res (nconc res add)))) 548 (setq res (nconc res add))))
539 (mapvector 'identity res))) 549 (edmacro-mapvector 'identity res)))
540 550
541 (defun edmacro-conv (char-or-sym add-<>) 551 (defun edmacro-conv (char-or-sym add-<>)
542 (let ((char-to-word '((?\0 . "NUL") 552 (let ((char-to-word '((?\0 . "NUL")
543 (?\r . "RET") 553 (?\r . "RET")
544 (?\n . "LFD") 554 (?\n . "LFD")
567 (let ((found (assq char-or-sym char-to-word))) 577 (let ((found (assq char-or-sym char-to-word)))
568 (cond (found 578 (cond (found
569 (cdr found)) 579 (cdr found))
570 ((< char-or-sym 128) 580 ((< char-or-sym 128)
571 (single-key-description char-or-sym)) 581 (single-key-description char-or-sym))
582 ((and edmacro-eight-bits
583 (>= char-or-sym 128))
584 (char-to-string char-or-sym))
572 (t 585 (t
573 (format "\\%o" (edmacro-int-char char-or-sym))))))))) 586 (format "\\%o" (edmacro-int-char char-or-sym)))))))))
574 587
575 (defun edmacro-format-1 (keys command times togetherp) 588 (defun edmacro-format-1 (keys command times togetherp)
576 (let ((res "") 589 (let ((res "")
636 (t 649 (t
637 nil)) ; leave it be. 650 nil)) ; leave it be.
638 (if el 651 (if el
639 (setq new (nconc new (list el)))) 652 (setq new (nconc new (list el))))
640 (incf cnt)) 653 (incf cnt))
641 (mapvector 'identity new)))) 654 (edmacro-mapvector 'identity new))))
642 655
643 ;; Collapse a list of keys into a list of function keys, where 656 ;; Collapse a list of keys into a list of function keys, where
644 ;; applicable. 657 ;; applicable.
645 (defun edmacro-fkeys (keys) 658 (defun edmacro-fkeys (keys)
646 (let (new k) 659 (let (new k lookup)
647 (while keys 660 (while keys
648 (setq k (nconc k (list (car keys)))) 661 (setq k (nconc k (list (car keys))))
649 (setq lookup (lookup-key function-key-map (mapvector 'identity k))) 662 (setq lookup (lookup-key function-key-map (edmacro-mapvector 'identity k)))
650 (cond ((vectorp lookup) 663 (cond ((vectorp lookup)
651 (setq new (nconc new (mapcar 'identity lookup))) 664 (setq new (nconc new (mapcar 'identity lookup)))
652 (setq k nil)) 665 (setq k nil))
653 ((keymapp lookup) 666 ((keymapp lookup)
654 nil) 667 nil)
672 ;; I'm not sure I understand the original code, but this seems to 685 ;; I'm not sure I understand the original code, but this seems to
673 ;; work. 686 ;; work.
674 (and (eq verbose 1) 687 (and (eq verbose 1)
675 (setq verbose nil)) 688 (setq verbose nil))
676 689
677 ;; Oh come on -- I want a list! Much easier to process... 690 ;; We prefer a list -- much easier to process...
678 (setq macro (mapcar 'identity macro)) 691 (setq macro (mapcar 'identity macro))
679 (setq macro (edmacro-fkeys macro)) 692 (setq macro (edmacro-fkeys macro))
680 (while macro 693 (while macro
681 (let (key lookup (times 1) self-insert-p) 694 (let (key lookup (times 1) self-insert-p)
682 (loop do 695 (loop do
683 (setq key (nconc key (list (car macro))) 696 (setq key (nconc key (list (car macro)))
684 macro (cdr macro) 697 macro (cdr macro)
685 lookup (lookup-key global-map (mapvector 'identity key))) 698 lookup (lookup-key global-map (edmacro-mapvector
699 'identity key)))
686 while 700 while
687 (and lookup (not (commandp lookup)))) 701 (and macro lookup (not (commandp lookup))))
688 ;; (lookup-key [?\C-x ?e]) seems to return a vector! 702 ;; keyboard macro
689 (if (vectorp lookup) 703 (if (vectorp lookup)
690 (setq lookup nil)) 704 (setq lookup nil))
691 (if (and (eq lookup 'self-insert-command) 705 (if (and (eq lookup 'self-insert-command)
692 (= (length key) 1) 706 (= (length key) 1)
693 (not (memq (car key) 707 (not (memq (car key)
749 (when (vectorp macro) 763 (when (vectorp macro)
750 (let ((i 0) ev) 764 (let ((i 0) ev)
751 (while (< i (length macro)) 765 (while (< i (length macro))
752 (when (and (consp (setq ev (aref macro i))) 766 (when (and (consp (setq ev (aref macro i)))
753 (not (memq (car ev) ; ha ha 767 (not (memq (car ev) ; ha ha
754 '(hyper super control meta alt control shift)))) 768 '(hyper super meta alt control shift))))
755 (cond ((equal (cadadr ev) '(menu-bar)) 769 (cond ((equal (cadadr ev) '(menu-bar))
756 (setq macro (vconcat (edmacro-subseq macro 0 i) 770 (setq macro (vconcat (edmacro-subseq macro 0 i)
757 (vector 'menu-bar (car ev)) 771 (vector 'menu-bar (car ev))
758 (edmacro-subseq macro (1+ i)))) 772 (edmacro-subseq macro (1+ i))))
759 (incf i)) 773 (incf i))