;;; gawd-keys.el --- Startup code that sets keybindings, for the Gordianet. ;;; Copyright (C) 1999--2001 Nix . ;; Author: Nix ;; Created: 1999-04-18 ;; Keywords: local ;; Version: $Revision: 1.12 $ ;; This file is not part of XEmacs. ;;; Commentary: ;; This file's sole purpose is to shrink site-start.el. ;; The keybindings use a good bit of code, so this is definitely in a Good ;; Cause(tm). ;; Much of this file is historical, existing purely to rebind keys on old ;; terminal emulators. ;; To be precise, this does not set any keybindings, merely defines some ;; functions that are useful when bound to keys and defines an alist ;; of useful bindings and a fucntion to apply that alist. The actual ;; call to that function takes place in `default.el' so that the user ;; may override it, set the bindings alist to nothing, that sort of thing. ;;; Code: ;; Define a few useful commands; without exception these just make things ;; interactive that beforehand were not, or that were only accessible via the ;; mouse. (defun jump-scroll-down () "Jump point up (thus, the document down) by six lines. Like `previous-line' with an argument of 6." (interactive "_") (previous-line 6)) (defun jump-scroll-up () "Jump point down (thus, the document up) by six lines. Like `next-line' with an argument of 6." (interactive "_") (next-line 6)) (defun join-line-to-next (&optional arg) "Join this line to the next one. Call `delete-indentation' with a prefix argument if none was provided, and without one if one was provided." (interactive "*P") (delete-indentation (not arg))) ;; XEmacs-specifics. ;; Provide key composition in XEmacs. (Emacs has `ucs-insert'). (when (featurep 'xemacs) (require 'x-compose) ;; Hardwire a keymap in. (define-key global-map (kbd "s-c") compose-map) ; If we have a scroll-in-place user here, isolate the jump-scrolling commands in ; their own group. (setq scroll-command-groups '((jump-scroll-up jump-scroll-down))) ;; XEmacs uses scroll-in-place, which is more primitive than ;; Eli and my rewrite in Emacs, so needs explicit definitions of some commands ;; that that package provides. ;; Scroll-in-place / preserve-screen-position interfere with the next two, so we force it off in them. (defun scroll-down-1-stay (&optional other) "Shift the screen down by one line, taking point with it if necessary. If OTHER is non-nil, do it to the `other-window' instead." (interactive "_") (let ((scroll-in-place nil)) (if other (scroll-other-window-down 1) (scroll-down-command 1)))) (defun scroll-up-1-stay (&optional other) "Shift the screen up by one line, taking point with it if necessary. If OTHER is non-nil, do it to the `other-window' instead." (interactive "_") (let ((scroll-in-place nil)) (if other (scroll-other-window 1) (scroll-up-command 1)))) (defun scroll-modeline-left (n &optional window) "Scroll the text of WINDOW's modeline N columns leftwards. Prefix argument is the number of columns to scroll" (interactive "p") (let ((window (or window (selected-window)))) (set-modeline-hscroll window (+ (modeline-hscroll window) n)))) (defun scroll-modeline-right (n &optional window) "Scroll the text of WINDOW's modeline N columns rightwards. Prefix argument is the number of columns to scroll" (interactive "p") (let ((window (or window (selected-window)))) (set-modeline-hscroll window (- (modeline-hscroll window) n)))) (defun pushpop-window-configuration (unpop) "Push or pop the window configuration. Pop a window off the window-configuration stack; see `pop-window-configuration'. With prefix argument, push the most recently popped window back onto the stack again." (interactive "P") (if unpop (unpop-window-configuration) (pop-window-configuration))) (put 'pushpop-window-configuration 'disabled t) ;; Handling non-ASCII-coded keys and characters ;; ;; These are quite tricky. You can't transmit a (control up) or similar over a ;; VT terminal, just as you can't differentiate C-x from C-X; so you can remap ;; control-up and control-down in your terminal emulator to functions that do a ;; C-c M-o u and C-c M-o d. These prefix keys should be sufficiently weird as ;; not to collide with anyone else's use of the same, while in any case being ;; vaguely similar to the M-O {foo} used by VT terminals for their escape codes. ;; ;; Similarly, shift-up and shift-down have gone to C-c M-o U and C-c M-o D, and ;; C-i has gone to C-c M-o i, to differentiate it from TAB. Meta-(shift ;; control)-(up down next prior) are also handled here because they are ;; disambiguated wrongly otherwise, owing to the binding of M-C-c to ;; exit-recursive-edit. ;; ;; A much larger remapping is the mapping of C-c M-1 [A-Z] to (control [A-Z]), ;; and of M-C-c M-1 [A-Z] to (meta control [A-Z]). (I'd have liked to use C-c ;; M-o {foo}, but that collided with the other specialist remappings and/or the ;; VT mappings.) ;; ;; Finally, we put Meta, Alt, Super and Hyper keys on PF1 to PF4. ;; First, define the extended terminal control prefix keys, and change the ;; binding of exit-recursive-edit because it collides with a set of VT100 ;; bindings that everyone missed :( Specifically, change it to use a capitalised ;; control key ;} ;; This could be implemented in Emacs, but there is very little point: This code ;; is largely historical at this point. (global-set-key (kbd "C-c M-o") (define-prefix-command 'vt100-console-function-key-map)) (global-set-key (kbd "C-c M-1") (define-prefix-command 'vt100-capctrl-console-function-key-map)) (global-set-key (kbd "M-C-c") (define-prefix-command 'vt100-meta-userdefs-key-map)) (global-set-key (kbd "M-C-c M-o") (define-prefix-command 'vt100-meta-console-function-key-map)) (global-set-key (kbd "M-C-c M-1") (define-prefix-command 'vt100-meta-ctrl-console-function-key-map)) (global-set-key (kbd "M-escape [") (define-prefix-command 'vt100-next-prior-map)) (global-set-key (kbd "M-escape O") (define-prefix-command 'vt100-meta-map)) (global-set-key (kbd "M-C-C") 'exit-recursive-edit) ;; Now, for ASCII-only devices only, bind the relevant Weird Key Sequences(tm) ;; to the appropriate *real* key events. (In one case, the Weird Key ;; Sequence(TM) is a perfectly normal VT100 key sequence for PF[1-4], but as we ;; have to rebind it in the function-key-map anyway, we may as well do it here.) ;; We allow other devices, too, because even in X some of these bindings are ;; useful; mainly those that allow super and hyper to be bound. ;; We have a table that does much of the mapping for us, in a similar manner as ;; the gawd-key-bind-alist below does the key->command binding, and simply stick ;; the contents of this table into the right place later on. ;; FIXME - The meta-next, meta-prior, meta-up and meta-down mappings here are VT ;; terminal specific. (However, what *doesn't* emulate a VT terminal, at least ;; in that?) (defvar key-translation-alist '(((eq (console-type) 'tty) . ((function-key-map . (("\C-c\eoU" . [(shift up)]) ("\C-c\eoD" . [(shift down)]) ("\C-c\eou" . [(control up)]) ("\C-c\eod" . [(control down)]) ("\C-c\eop" . [(control prior)]) ("\C-c\eon" . [(control next)]) ("\e\C-c\eoU" . [(meta shift up)]) ("\e\C-c\eoD" . [(meta shift down)]) ("\e\C-c\eou" . [(meta control up)]) ("\e\C-c\eod" . [(meta control down)]) ("\e\C-c\eop" . [(meta control prior)]) ("\e\C-c\eon" . [(meta control next)]) ("\e\e[5~" . [(meta prior)]) ("\e\e[6~" . [(meta next)]) ("\e\eOA" . [(meta up)]) ("\e\eOB" . [(meta down)]) ("\e\eOC" . [(meta right)]) ("\e\eOD" . [(meta left)]) ("\C-c\eoi" . [(control i)]) ("\eOP" . event-apply-meta-modifier) ("\eOQ" . event-apply-alt-modifier) ("\eOR" . event-apply-super-modifier) ("\eOS" . event-apply-hyper-modifier))))) ((eq (console-type) 'x) . ; X knows these keys' names already. ((key-translation-map . (([kp-divide] . event-apply-alt-modifier) ([kp-multiply] . event-apply-super-modifier) ([kp-subtract] . event-apply-hyper-modifier)))))) "Which keys to translate into which non-ASCII-coded events. An alist mapping a predicate identifying a device to a keymap set, where a keymap set is an alist mapping a keymap name to (an alist mapping an identifying input key, in raw XEmacs format, to an internal event to transform it into). (Not very clear, I fear.) The entry for TTYs must be first in this list. The terminal emulator provides the key sequence and it is translated it to the events via `function-key-map'.") ;; In order for all that to work, we need a version of `event-apply-modifier' ;; that pays attention to the `key-translation-map', as well as the ;; `function-key-map'. (defun event-apply-modifier (symbol) "Return the next key event, with a modifier flag applied. SYMBOL is the name of this modifier, as a symbol. `function-key-map' and `key-translation-map' are scanned for prefix bindings." (let (events binding) ;; read keystrokes scanning `function-key-map' and `key-translation-map'. (while (keymapp (setq binding (progn (setq events (append events (list (next-key-event)))) (or (lookup-key function-key-map (vconcat events)) (lookup-key key-translation-map (vconcat events))))))) (if binding ; found a binding (progn ;; allow for several modifiers (if (and (symbolp binding) (fboundp binding)) (setq binding (funcall binding nil))) (setq events (append binding nil)) ;; put remaining keystrokes back into input queue (setq unread-command-events (mapcar 'character-to-event (cdr events)))) (setq unread-command-events (cdr events))) ;; add a modifier SYMBOL to the first keystroke or event (vector (append (list symbol) (delq symbol (aref (key-sequence-list-description (car events)) 0)))))) ;; Go through the capital alphabet and map C-c M-1 {letter} to (control letter), ;; and M-C-c M-1 {letter} to (meta control letter). This is especially tricky ;; because some of the keys we try to automatically bind here are subsets of ;; others that we try to bind; i.e. [(control c) (meta 1) {letter}] is a subset ;; of [(meta control c) (meta 1) {letter}], so we have to be sure to bind the ;; latter *first* so it matches first. (let ((char-to-set ?A)) (while (not (> char-to-set ?Z)) (nconc (assoc function-key-map (car key-translation-alist)) `((,(concat "\e\C-c\e1" (char-to-string char-to-set)) . [(meta control ,char-to-set)]))) (nconc (assoc function-key-map (car key-translation-alist)) `((,(concat "\C-c\e1" (char-to-string char-to-set)) . [(control ,char-to-set)]))) (setq char-to-set (int-to-char (1+ char-to-set)))) nil) (defun gawd-setup-console-function-key-map (console) "Set up our console shortcut keys. These provide for things like ctrl-up, ctrl-down &c, if appropriate bindings are made in the terminal emulator. It applies the bindings given in `key-translation-alist'." (let ((old-console (selected-console))) (unwind-protect (progn (select-console console) (mapc #'(lambda (device-mapping) (if (eval (car device-mapping)) (mapc #'(lambda (keymap-binding) (let ((keymap (symbol-value (car keymap-binding)))) (mapc #'(lambda (keypair) (define-key keymap (car keypair) (cdr keypair))) (cdr keymap-binding)))) (cdr device-mapping)))) key-translation-alist) (select-console old-console)))) nil) ;; Set up the VT special keys for each console, and immediately after we have ;; loaded the terminal-specific init file. (We can't run it now because the ;; terminal-specific init file is loaded after even default.el. Why? ;; Beats me.) (add-hook 'create-console-hook 'gawd-setup-console-function-key-map) (add-hook 'term-setup-hook (function (lambda () (gawd-setup-console-function-key-map (selected-console)))))) ;; Define a useful variable to make keymapping a comparative doddle ; TODO: extend this to local keymaps for not-yet-loaded modes (defvar gawd-key-bind-alist `((,(current-global-map) ("M-up" . 'jump-scroll-down) ("M-down" . 'jump-scroll-up) ("S-up" . 'scroll-down-1-stay) ("S-down" . 'scroll-up-1-stay) ("M-C-next" . 'scroll-other-window) ("M-C-prior" . 'scroll-other-window-down) ("A-M-down" . 'down-list) ("A-M-up" . 'backward-up-list) ("A-M-home" . 'beginning-of-defun) ("A-M-end" . 'end-of-defun) ("A-M-left" . 'backward-sexp) ("A-M-right" . 'forward-sexp) ("C-x M-b" . 'bury-buffer) ("C-x O" . 'backward-other-window) ("C-iso-left-tab" . 'backward-other-window) ("C-x C-^" . 'shrink-window) ("C-c j" . 'join-line-to-next) ("C-c y" . 'browse-kill-ring) ("C-x M-k" . 'kill-buffer-and-window) ("A-x b" . (function (lambda (interactive) (replace-buffer-in-windows (current-buffer))))) ; This fixes a documentation bug ,@(if (featurep 'xemacs) `(("C-x z" . 'vi-dot) ("C-x C-n" . 'set-goal-column) ("M-S-up" . (function (lambda () (interactive (scroll-down-1-stay t))))) ("M-S-down" . (function (lambda () (interactive (scroll-up-1-stay t))))) ("C-x C-}" . 'scroll-modeline-left) ("C-x C-{" . 'scroll-modeline-right) ("C-c p" . 'pushpop-window-configuration)) ; Emacs has winner-mode `(("C-h a" . 'apropos-toc) ("C-h C-m" 'manual-entry) ("M-S-up" . 'scroll-other-window-down-1-stay) ("M-S-down" . 'scroll-other-window-up-1-stay) ("A-k" 'kill-whole-line)))) ,@(if (not (featurep 'xemacs)) (,help-mode-map ("S-BS" . 'help-go-back)) "Alist from key definitions to bindings. Each element is of the form (MODE-MAP (KEY . BINDING) ...), where the MODE-MAP is the name of a major mode's keymap, the KEY may be any string acceptable to `kbd', and the BINDING is anything that makes sense as the DEF argument to `define-key'. (Note that not all these arguments may make sense for all keymaps.)") ;; This function applies the bindings. Note its use of `read-kbd-macro' rather ;; than `kbd' as `kbd' does not evaluate its arguments, and they must be ;; evaluated in this case. `kbd' simply calls `read-kbd-macro', so no harm ;; is done. (defun gawd-apply-key-bindings () "Apply the key bindings given in the `gawd-key-bind-alist'. See the documentation for that variable for more information." (mapc (lambda (maplist) ; For each map (let ((map-to-fiddle (car maplist))) (mapc (lambda (keybinding) ; For each keybinding (define-key map-to-fiddle (read-kbd-macro (car keybinding)) (eval (cdr keybinding)))) (cdr maplist)))) gawd-key-bind-alist)) (provide 'gawd-keys)