home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / hyperbole / hib-kbd.el < prev    next >
Encoding:
Text File  |  1995-04-17  |  5.6 KB  |  156 lines
  1. ;;!emacs
  2. ;;
  3. ;; FILE:         hib-kbd.el
  4. ;; SUMMARY:      Implicit button type for key sequences delimited with {}.
  5. ;; USAGE:        GNU Emacs Lisp Library
  6. ;; KEYWORDS:     extensions, hypermedia
  7. ;;
  8. ;; AUTHOR:       Bob Weiner
  9. ;; ORG:          Brown U.
  10. ;;
  11. ;; ORIG-DATE:    22-Nov-91 at 01:37:57
  12. ;; LAST-MOD:     14-Apr-95 at 15:58:32 by Bob Weiner
  13. ;;
  14. ;; This file is part of Hyperbole.
  15. ;; Available for use and distribution under the same terms as GNU Emacs.
  16. ;;
  17. ;; Copyright (C) 1991-1995, Free Software Foundation, Inc.
  18. ;; Developed with support from Motorola Inc.
  19. ;;
  20. ;; DESCRIPTION:  
  21. ;;
  22. ;;   A click of the Hyperbole execution key on a key sequence executes its
  23. ;;   command binding.
  24. ;;
  25. ;;   A click of the Hyperbole help key on a key sequence displays the
  26. ;;   documentation for its command binding.
  27. ;;
  28. ;;   Key sequences should be in human readable form, e.g. {C-b}.
  29. ;;   Forms such as {\C-b}, {\^b}, and {^b} will not be recognized.
  30. ;;
  31. ;; DESCRIP-END.
  32.  
  33. ;;; ************************************************************************
  34. ;;; Public implicit button types
  35. ;;; ************************************************************************
  36.   
  37. (defact kbd-key (key-sequence)
  38.   "Executes the function binding for KEY-SEQUENCE, delimited by {}.
  39. Returns t if a KEY-SEQUENCE has a binding, else nil."
  40.   (interactive "kKeyboard key to execute (no {}): ")
  41.   (kbd-key:act key-sequence))
  42.  
  43. (defib kbd-key ()
  44.   "Executes a key sequence delimited by curly braces.
  45. Key sequences should be in human readable form, e.g. {C-b}.
  46. Forms such as {\C-b}, {\^b}, and {^b} will not be recognized."
  47.   (if (br-in-browser)
  48.       nil
  49.     (let* ((seq-and-pos (or (hbut:label-p t "{`" "'}" t)
  50.                 (hbut:label-p t "{" "}" t)))
  51.        (key-sequence (car seq-and-pos))
  52.        (binding (and (stringp key-sequence)
  53.              (key-binding (kbd-key:normalize key-sequence)))))
  54.       (and binding (not (integerp binding))
  55.        (ibut:label-set seq-and-pos)
  56.        (hact 'kbd-key key-sequence)))))
  57.  
  58. ;;; ************************************************************************
  59. ;;; Public functions
  60. ;;; ************************************************************************
  61.  
  62. (defun kbd-key:act (key-sequence)
  63.   "Executes the command binding for KEY-SEQUENCE.
  64. Returns t if KEY-SEQUENCE has a binding, else nil."
  65.   (interactive "kKeyboard key to execute (no {}): ")
  66.   (setq current-prefix-arg nil) ;; kbd-key:normalize below sets it.
  67.   (let ((binding (key-binding (kbd-key:normalize key-sequence))))
  68.     (cond ((null binding) nil)
  69.       ((memq binding '(action-key action-mouse-key hkey-either))
  70.        (beep)
  71.        (message "(kbd-key:act): This key does what the Action Key does.")
  72.        t)
  73.       (t (call-interactively binding) t))))
  74.  
  75. (defun kbd-key:doc (key &optional full)
  76.   "Shows first line of doc for binding of keyboard KEY in minibuffer.
  77. With optional FULL, displays full documentation for command."
  78.   (interactive "kKey sequence: \nP")
  79.   (let* ((cmd (let ((cmd (key-binding (kbd-key:normalize key))))
  80.         (if (not (integerp cmd)) cmd)))
  81.      (doc (and cmd (documentation cmd)))
  82.      (end-line))
  83.     (if doc
  84.     (or full
  85.         (setq end-line (string-match "[\n]" doc)
  86.           doc (substitute-command-keys (substring doc 0 end-line))))
  87.       (setq doc (format "No documentation for {%s} %s" key (or cmd ""))))
  88.     (if (and cmd doc)
  89.     (if full
  90.         (describe-function cmd)
  91.       (message doc)))))
  92.  
  93. (defun kbd-key:help (but)
  94.   "Display documentation for binding of keyboard key given by BUT's label."
  95.   (let ((kbd-key (hbut:key-to-label (hattr:get but 'lbl-key))))
  96.     (and kbd-key (kbd-key:doc kbd-key 'full))))
  97.  
  98. (defun kbd-key:normalize (key-sequence)
  99.   "Returns KEY-SEQUENCE normalized into a form that can be parsed by commands."
  100.   (interactive "kKeyboard key sequence to normalize (no {}): ")
  101.   (let ((start) (end) (norm-key-seq (copy-sequence key-sequence))
  102.     (obuf (current-buffer))
  103.     (case-fold-search nil) (case-replace t))
  104.     ;; Quote Control and Meta key names
  105.     (setq norm-key-seq (hypb:replace-match-string
  106.             "[ \t\n\^M]+" norm-key-seq "")
  107.       norm-key-seq (hypb:replace-match-string
  108.             "@key{SPC}\\|SPC"    norm-key-seq "\040")
  109.       norm-key-seq (hypb:replace-match-string
  110.             "@key{DEL}\\|DEL"    norm-key-seq "\177")
  111.       norm-key-seq (hypb:replace-match-string
  112.             "@key{RET}\\|@key{RTN}\\|RET\\|RTN"
  113.             norm-key-seq "\015")
  114.       norm-key-seq (hypb:replace-match-string
  115.             "ESCESC" norm-key-seq "\233")
  116.       norm-key-seq (hypb:replace-match-string
  117.             "@key{ESC}\\|ESC"    norm-key-seq "M-")
  118.       ;; Unqote special {} chars.
  119.       norm-key-seq (hypb:replace-match-string "\\\\\\([{}]\\)"
  120.                           norm-key-seq "\\1")
  121.       )
  122.     (while (string-match "\\`\\(C-u\\|M-\\)\\(-?[0-9]+\\)" norm-key-seq)
  123.       (setq current-prefix-arg
  124.         (string-to-int (substring norm-key-seq (match-beginning 2)
  125.                       (match-end 2)))
  126.         norm-key-seq (substring norm-key-seq (match-end 0))))
  127.     (let (arg-val)
  128.       (while (string-match "\\`C-u" norm-key-seq)
  129.     (if (or (not (listp current-prefix-arg))
  130.         (not (integerp (setq arg-val (car current-prefix-arg)))))
  131.         (setq current-prefix-arg '(1)
  132.           arg-val 1))
  133.     (setq arg-val (* arg-val 4)
  134.           current-prefix-arg (cons arg-val nil)
  135.           norm-key-seq (substring norm-key-seq (match-end 0)))))
  136.     (setq norm-key-seq (hypb:replace-match-string
  137.             "C-\\(.\\)" norm-key-seq
  138.             (function
  139.              (lambda (str)
  140.                (char-to-string
  141.                 (1+ (- (downcase
  142.                     (string-to-char
  143.                      (substring str (match-beginning 1)
  144.                         (1+ (match-beginning 1)))))
  145.                    ?a)))))))
  146.     (hypb:replace-match-string
  147.      "M-\\(.\\)" norm-key-seq
  148.      (function
  149.       (lambda (str)
  150.     (char-to-string (+ (downcase (string-to-char
  151.                       (substring str (match-beginning 1)
  152.                          (1+ (match-beginning 1)))))
  153.                128)))))))
  154.  
  155. (provide 'hib-kbd)
  156.