cgit.sxemacs.org Git - packages/blob - xemacs-packages/hyperbole/hib-kbd.el

   1 ;;; hib-kbd.el --- Implicit button type for key sequences delimited with {}.
   2
   3 ;; Copyright (C) 1991-1995, 2008 Free Software Foundation, Inc.
   4 ;; Developed with support from Motorola Inc.
   5
   6 ;; Author: Bob Weiner, Brown U.
   7 ;; Maintainer: Mats Lidell <matsl@contactor.se>
   8 ;; Keywords: extensions, hypermedia
   9
  10 ;; This file is part of GNU Hyperbole.
  11
  12 ;; GNU Hyperbole is free software; you can redistribute it and/or
  13 ;; modify it under the terms of the GNU General Public License as
  14 ;; published by the Free Software Foundation; either version 3, or (at
  15 ;; your option) any later version.
  16
  17 ;; GNU Hyperbole 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 GNU
  20 ;; 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., 51 Franklin Street, Fifth Floor,
  25 ;; Boston, MA 02110-1301, USA.
  26
  27 ;;; Commentary:
  28 ;;
  29 ;;   A click of the Hyperbole execution key on a key sequence executes its
  30 ;;   command binding.
  31 ;;
  32 ;;   A click of the Hyperbole help key on a key sequence displays the
  33 ;;   documentation for its command binding.
  34 ;;
  35 ;;   Key sequences should be in human readable form, e.g. {C-b}.
  36 ;;   Forms such as {\C-b}, {\^b}, and {^b} will not be recognized.
  37 ;;
  38
  39 ;;; Code:
  40
  41 ;;;
  42 ;;; Public implicit button types
  43 ;;;
  44
  45 (defact kbd-key (key-sequence)
  46   "Executes the function binding for KEY-SEQUENCE, delimited by {}.
  47 Returns t if a KEY-SEQUENCE has a binding, else nil."
  48   (interactive "kKeyboard key to execute (no {}): ")
  49   (kbd-key:act key-sequence))
  50
  51 (defib kbd-key ()
  52   "Executes a key sequence delimited by curly braces.
  53 Key sequences should be in human readable form, e.g. {C-b}.
  54 Forms such as {\C-b}, {\^b}, and {^b} will not be recognized."
  55   (if (br-in-browser)
  56       nil
  57     (let* ((seq-and-pos (or (hbut:label-p t "{`" "'}" t)
  58                             (hbut:label-p t "{" "}" t)))
  59            (key-sequence (car seq-and-pos))
  60            (binding (and (stringp key-sequence)
  61                          (key-binding (kbd-key:normalize key-sequence)))))
  62       (and binding (not (integerp binding))
  63            (ibut:label-set seq-and-pos)
  64            (hact 'kbd-key key-sequence)))))
  65
  66 ;;;
  67 ;;; Public functions
  68 ;;;
  69
  70 (defun kbd-key:act (key-sequence)
  71   "Executes the command binding for KEY-SEQUENCE.
  72 Returns t if KEY-SEQUENCE has a binding, else nil."
  73   (interactive "kKeyboard key to execute (no {}): ")
  74   (setq current-prefix-arg nil) ;; kbd-key:normalize below sets it.
  75   (let ((binding (key-binding (kbd-key:normalize key-sequence))))
  76     (cond ((null binding) nil)
  77           ((memq binding '(action-key action-mouse-key hkey-either))
  78            (beep)
  79            (message "(kbd-key:act): This key does what the Action Key does.")
  80            t)
  81           (t (call-interactively binding) t))))
  82
  83 (defun kbd-key:doc (key &optional full)
  84   "Shows first line of doc for binding of keyboard KEY in minibuffer.
  85 With optional FULL, displays full documentation for command."
  86   (interactive "kKey sequence: \nP")
  87   (let* ((cmd (let ((cmd (key-binding (kbd-key:normalize key))))
  88                 (if (not (integerp cmd)) cmd)))
  89          (doc (and cmd (documentation cmd)))
  90          (end-line))
  91     (if doc
  92         (or full
  93             (setq end-line (string-match "[\n]" doc)
  94                   doc (substitute-command-keys (substring doc 0 end-line))))
  95       (setq doc (format "No documentation for {%s} %s" key (or cmd ""))))
  96     (if (and cmd doc)
  97         (if full
  98             (describe-function cmd)
  99           (message doc)))))
 100
 101 (defun kbd-key:help (but)
 102   "Display documentation for binding of keyboard key given by BUT's label."
 103   (let ((kbd-key (hbut:key-to-label (hattr:get but 'lbl-key))))
 104     (and kbd-key (kbd-key:doc kbd-key 'full))))
 105
 106 (defun kbd-key:normalize (key-sequence)
 107   "Returns KEY-SEQUENCE normalized into a form that can be parsed by commands."
 108   (interactive "kKeyboard key sequence to normalize (no {}): ")
 109   (let ((norm-key-seq (copy-sequence key-sequence))
 110         (case-fold-search nil) (case-replace t))
 111     ;; Quote Control and Meta key names
 112     (setq norm-key-seq (hypb:replace-match-string
 113                         "[ \t\n\^M]+" norm-key-seq "" t)
 114           norm-key-seq (hypb:replace-match-string
 115                         "@key{SPC}\\|SPC" norm-key-seq "\040" t)
 116           norm-key-seq (hypb:replace-match-string
 117                         "@key{DEL}\\|DEL" norm-key-seq "\177" t)
 118           norm-key-seq (hypb:replace-match-string
 119                         "@key{RET}\\|@key{RTN}\\|RET\\|RTN"
 120                         norm-key-seq "\015" t)
 121           norm-key-seq (hypb:replace-match-string
 122                         "ESCESC" norm-key-seq "\233" t)
 123           norm-key-seq (hypb:replace-match-string
 124                         "@key{ESC}\\|ESC" norm-key-seq "M-" t)
 125           ;; Unqote special {} chars.
 126           norm-key-seq (hypb:replace-match-string "\\\\\\([{}]\\)"
 127                                                   norm-key-seq "\\1")
 128           )
 129     (while (string-match "\\`\\(C-u\\|M-\\)\\(-?[0-9]+\\)" norm-key-seq)
 130       (setq current-prefix-arg
 131             (string-to-number (substring norm-key-seq (match-beginning 2)
 132                                       (match-end 2)))
 133             norm-key-seq (substring norm-key-seq (match-end 0))))
 134     (let (arg-val)
 135       (while (string-match "\\`C-u" norm-key-seq)
 136         (if (or (not (listp current-prefix-arg))
 137                 (not (integerp (setq arg-val (car current-prefix-arg)))))
 138             (setq current-prefix-arg '(1)
 139                   arg-val 1))
 140         (setq arg-val (* arg-val 4)
 141               current-prefix-arg (cons arg-val nil)
 142               norm-key-seq (substring norm-key-seq (match-end 0)))))
 143     (setq norm-key-seq (hypb:replace-match-string
 144                         "C-\\(.\\)" norm-key-seq
 145                         (function
 146                          (lambda (str)
 147                            (char-to-string
 148                             (1+ (- (downcase
 149                                     (string-to-char
 150                                      (substring str (match-beginning 1)
 151                                                 (1+ (match-beginning 1)))))
 152                                    ?a)))))))
 153     (hypb:replace-match-string
 154      "M-\\(.\\)" norm-key-seq
 155      (function
 156       (lambda (str)
 157         (char-to-string (+ (downcase (string-to-char
 158                                       (substring str (match-beginning 1)
 159                                                  (1+ (match-beginning 1)))))
 160                            128)))))))
 161
 162 (provide 'hib-kbd)
 163
 164 ;;; hib-kbd.el ends here