home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / elisp / misc / sun-fkeys.el < prev    next >
Encoding:
Text File  |  1991-05-11  |  8.4 KB  |  245 lines
  1. ; Date: Wed, 8 May 91 13:22:00 BST
  2. ; From: Graham Gough <graham@computer-science.manchester.ac.uk>
  3.  
  4. ;;
  5. ;; sun-fun.el
  6. ;;
  7. ;;
  8. ;; An attempt(!) to provide a uniform mechanism for binding Sun function keys
  9. ;;
  10. ;; Main functions are bind-sun-fun-key and local-bind-sun-fun-key
  11. ;; which use an appropriate global or local keymap
  12. ;;
  13. ;; Written by Graham Gough  graham@cs.man.ac.uk
  14. ;; Send all bugs/suggestions to author
  15. ;; 24/1/89
  16. ;;
  17. ;; Copyright (C) 1989 Graham D. Gough
  18. ;;
  19. ;; This file is not  part of GNU Emacs, however, GNU copyleft applies
  20. ;;
  21. ;; GNU Emacs is distributed in the hope that it will be useful,
  22. ;; but WITHOUT ANY WARRANTY.  No author or distributor
  23. ;; accepts responsibility to anyone for the consequences of using it
  24. ;; or for whether it serves any particular purpose or works at all,
  25. ;; unless he says so in writing.  Refer to the GNU Emacs General Public
  26. ;; License for full details.
  27.  
  28. ;; Everyone is granted permission to copy, modify and redistribute
  29. ;; GNU Emacs, but only under the conditions described in the
  30. ;; GNU Emacs General Public License.   A copy of this license is
  31. ;; supposed to have been given to you along with GNU Emacs so you
  32. ;; can know your rights and responsibilities.  It should be in a
  33. ;; file named COPYING.  Among other things, the copyright notice
  34. ;; and this notice must be preserved on all copies.
  35. ;;
  36.  
  37.  
  38. ;; The point of these functions is to separate the  user  from  the
  39. ;; exact control sequences produced by the Sun keys and just use their names.
  40.  
  41. ;; Here is a sample excerpt from a .emacs
  42. ;; 
  43. ;; (setq term-setup-hook 'term-setup-hook)
  44. ;; (defun term-setup-hook()
  45. ;;   (require 'sun-fun)
  46. ;;   (bind-sun-fun-key "l2" 'my-favourite-fuction) 
  47. ;;   (bind-sun-fun-key "M-l2" 'another-good-one) 
  48. ;;   (bind-sun-fun-key "f9" 'describe-sun-fun-bindings t) 
  49. ;;   (bind-sun-fun-key "f8" 'enscript-buffer t)
  50. ;;   (bind-sun-fun-key "r3" 'electric-command-history) 
  51. ;;   (bind-sun-fun-key "r5" 'dot-to-top)
  52. ;;   (bind-sun-fun-key "r7" 'sip:scroll-down-in-place))
  53. ;;  
  54.  
  55. (provide 'sun-fun)
  56.  
  57. (defun bind-sun-fun-key (str fun &optional warn)
  58.   "Bind Sun function key STR to FUN (using the appropriate keymap)
  59. Key names are l1, l2, etc, f1, f2 etc, r1, r2 etc. Capitalized versions work 
  60. for emacstool users. If the optional argument WARN is non-nil a warning will 
  61. be given for illegal keynames."
  62.   (if (boundp 'suntool-map)
  63.       (bind-sun-fun-key-st str fun warn)
  64.     (bind-sun-fun-key-raw str fun warn)))
  65.  
  66. (defun local-bind-sun-fun-key (str fun &optional warn)
  67.   "Bind Sun function key STR to FUN (using the local keymap)
  68. Key names are l1, l2, etc, f1, f2 etc, r1, r2 etc. Capitalized versions work 
  69. for emacstool users. If the optional argument WARN is non-nil a warning will 
  70. be given for illegal keynames."
  71.   (if (boundp 'suntool-map)
  72.       (local-bind-sun-fun-key-st str fun warn)
  73.     (local-bind-sun-fun-key-raw str fun warn)))
  74.  
  75. (defconst sun-raw-key-list 
  76.   '(("l1" . "192" )  ("l2" . "193" ) ("l3" . "194" ) ("l4" . "195" )
  77.     ("l5" . "196" )  ("l6" . "197" ) ("l7" . "198" ) ("l8" . "199" ) 
  78.     ("l9" . "200" )  ("l10" . "201" ) 
  79.     ("f1" . "224" ) ("f2" . "225" )  ("f3" . "226" ) ("f4" . "227" )
  80.     ("f5" . "228" ) ("f6" . "229" )  ("f7" . "230" ) ("f8" . "231" )
  81.     ("f9" . "232" )
  82.     ("r1" . "208" ) ("r2" . "209" ) ("r3" . "210" ) ("r4" . "211" ) 
  83.     ("r5" . "212" ) ("r6" . "213" ) ("r7" . "214" ) ("r8" . "215" ) 
  84.     ("r9" . "216" ) ("r10" . "217" ) ("r11" . "218" ) ("r12" . "219" ) 
  85.     ("r13" . "220" ) ("r14" . "221" ) ("r15" . "222" ) ("r16" . "223")))
  86.  
  87.  
  88. (defconst sun-st-key-list
  89.   '(("l1" . "bl" )  ("L1" . "bL" ) 
  90.     ("M-l1" . "b\M-l" ) ("M-L1" . "b\M-L" ) 
  91.     ("l2" . "bl" )  ("L2" . "bL" ) 
  92.     ("M-l2" . "b\M-l" ) ("M-L2" . "b\M-L" ) 
  93.     ("l3" . "cl" ) ("L3" . "cL" )
  94.     ("l4" . "dl" )  ("L4" . "dL" ) 
  95.     ("l5" . "el" )  ("L5" . "eL" ) 
  96.     ("l6" . "fl" )  ("L6" . "fL" ) 
  97.     ("C-l6" . "f," ) 
  98.     ("l7" . "gl" )  ("L7" . "gL" ) 
  99.     ("l8" . "hl" )  ("L8" . "hL" ) 
  100.     ("C-l8" . "h," )
  101.     ("l9" . "il" )  ("L9" . "iL" ) 
  102.     ("C-l9" . "i," ) ("M-l9" . "i\M-l" )
  103.     ("C-M-l9" . "i\M-," )
  104.     ("l10" . "jl" ) ("L10" . "jL" )
  105.     ("M-l10" . "j\M-l" ) ("C-l10" . "j," )
  106.     ("f1" . "at" ) ("F1" . "aT" )
  107.     ("f2" . "bt" ) ("F2" . "bT" )
  108.     ("f3" . "ct" ) ("F3" . "cT")
  109.     ("f4" . "dt" ) ("F4" . "dTt" )
  110.     ("f5" . "et" ) ("F5" . "eT" )
  111.     ("f6" . "ft" ) ("F6" . "fT" )
  112.     ("f7" . "gt" ) ("F7" . "gT" )
  113.     ("f8" . "ht" ) ("F8" . "hT" )
  114.     ("f9" . "it" ) ("F9" . "iT" )
  115.     ("r1" . "ar" )  ("R1" . "aR" ) 
  116.     ("r2" . "br" )  ("R2" . "bR" ) 
  117.     ("r3" . "cr" )  ("R3" . "cR" )
  118.     ("r4" . "dr" )  ("R4" . "dR" ) 
  119.     ("r5" . "er" )  ("R5" . "eR" ) 
  120.     ("r6" . "fr" )  ("R6" . "fR" ) 
  121.     ("r7" . "gr" )  ("R7" . "gR" ) 
  122.     ("r8" . "hr" )  ("R8" . "hR" ) 
  123.     ("r9" . "ir" )  ("R9" . "iR" ) 
  124.     ("r10" . "jr" ) ("R10" . "jR" ) 
  125.     ("r11" . "kr" ) ("R11" . "kR" )
  126.     ("r12" . "lr" ) ("R12" . "lR" ) 
  127.     ("r13" . "mr" ) ("R13" . "mR" ) 
  128.     ("r14" . "nr" ) ("R14" . "nR" )
  129.     ("r15" . "or" ) ("R15" . "oR" )
  130.     ))
  131.  
  132. (defun bind-sun-fun-key-raw (str fun &optional warn)
  133.   (let ((code (cdr (assoc str sun-raw-key-list))))
  134.     (if code
  135.     (define-key sun-raw-map (concat code "z") fun)
  136.       (if warn
  137.       (message (format "No key \"%s\"" str))))))
  138.  
  139. (defun bind-sun-fun-key-st (str fun &optional warn)
  140.   (let ((code (cdr (assoc str sun-st-key-list))))
  141.     (if code
  142.     (define-key suntool-map code fun)
  143.       (message (format "No key \"%s\"" str)))))
  144.  
  145.  
  146. (defun local-bind-sun-fun-key-raw (str fun &optional warn)
  147.   (let ((code (cdr (assoc str sun-raw-key-list))))
  148.     (if code
  149.     (local-set-key (concat "\e[" code "z") fun)
  150.       (if warn
  151.       (message (format "No key \"%s\"" str))))))
  152.  
  153. (defun local-bind-sun-fun-key-st (str fun &optional warn)
  154.   (let ((code (cdr (assoc str sun-st-key-list))))
  155.     (if code
  156.     (local-set-key (concat "\C-x*" code) fun)
  157.       (if warn
  158.       (message (format "No key \"%s\"" str))))))
  159.  
  160. ;;
  161. ;;
  162.  
  163. (defun describe-sun-fun-bindings ()
  164.   "Generate and display documentation strings for functions bound to fun keys"
  165.   (interactive)
  166.   (let ((docbuff (get-buffer-create "*Help*")))
  167.     (set-buffer docbuff)
  168.     (delete-region (point-min) (point-max))
  169.     (insert "           ****** Sun Function Key Bindings ******\n")
  170.     (if (boundp 'suntool-map)
  171.     (mapcar 'sf:one-key-binding-st sun-st-key-list)
  172.       (mapcar 'sf:one-key-binding-raw sun-raw-key-list))
  173.     (goto-char (point-min))
  174.     (pop-to-buffer docbuff)))
  175.  
  176. (defun sf:one-key-binding-raw(pr)
  177.   (let ((binding (key-binding (concat "\e[" (cdr pr) "z"))))
  178.     (if binding
  179.     (insert  (car pr) "\t\t" (format "%s\n" binding )))))
  180.  
  181. (defun sf:one-key-binding-st(pr)
  182.   (let ((binding (key-binding (concat "\C-x*" (cdr pr) ))))
  183.     (if binding
  184.     (insert  (car pr) "\t\t" (format "%s\n" binding )))))
  185.  
  186.  
  187. ;;
  188. ;; Inverse maps, used in exec-extended-sun
  189. ;;
  190.  
  191. (defun sf:swap (pair)
  192.   (cons (cdr pair) (car pair)))
  193.  
  194. (defvar sun-raw-inv-map nil)
  195.  
  196. (defvar sun-st-inv-map nil)
  197.  
  198. (defun sun-raw-inv-map ()
  199.   (or sun-raw-inv-map
  200.       (setq sun-raw-inv-map (mapcar 'sf:swap sun-raw-key-list))))
  201.  
  202. (defun sun-st-inv-map ()
  203.   (or sun-st-inv-map
  204.       (setq sun-st-inv-map (mapcar 'sf:swap sun-st-key-list))))
  205.  
  206.  
  207. (defvar sun-raw-regexp  (concat "^" (regexp-quote "\e[") "\\([12][0-9][0-9]\\)z$"))
  208. (defvar sun-st-regexp    (concat "^" (regexp-quote "*") "\\(.*\\)$"))
  209.  
  210. (defun  key-description-sun (str)
  211.   "Return a pretty description of key-sequence KEYS.
  212. Control characters turn into \"C-foo\" sequences, meta into \"M-foo\"
  213. spaces are put between sequence elements, etc.
  214. also converts codes for Sun function keys to key names."
  215.   (let ((map (cond ((string-match sun-raw-regexp str)
  216.               (sun-raw-inv-map))
  217.            ((string-match sun-st-regexp str)
  218.             (sun-st-inv-map))
  219.            (t nil))))
  220.     (if (not map)
  221.     (meta-key-description str)
  222.       (setq str (substring str (match-beginning 1) (match-end 1)))
  223.       (cdr (assoc str map)))))
  224.  
  225.  
  226. (defun meta-key-description (keys)
  227.   "Works like key-description except that sequences containing
  228. meta-prefix-char that can be expressed meta sequences, are.
  229. E.g. `\"\\ea\" becomes \"M-a\".
  230.  
  231. If the ambient value of meta-flag in nil, this function is equivalent to
  232. key-description."
  233.   (if (not (and meta-flag (numberp meta-prefix-char)))
  234.       (key-description keys)
  235.     (let (pattern start)
  236.       (setq pattern (concat (char-to-string meta-prefix-char) "[\000-\177]"))
  237.       (while (string-match pattern keys start)
  238.     (setq keys
  239.           (concat
  240.            (substring keys 0 (match-beginning 0))
  241.            (char-to-string (logior (aref keys (1- (match-end 0))) 128))
  242.            (substring keys (match-end 0)))
  243.           start (match-beginning 0)))
  244.       (key-description keys))))
  245.