Source

xemacs-21.4 / lisp / keymap.el

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
;; keymap.el --- Keymap functions for XEmacs.

;; Copyright (C) 1993-4, 1997 Free Software Foundation, Inc.
;; Copyright (C) 1995 Tinker Systems and INS Engineering Corp.

;; Maintainer: XEmacs Development Team
;; Keywords: internals, dumped

;; This file is part of XEmacs.

;; XEmacs is free software; you can redistribute it and/or modify it
;; under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; XEmacs is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with XEmacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Synched up with: FSF 19.28.

;;; Commentary:

;; This file is dumped with XEmacs.

;;; Note: FSF does not have a file keymap.el.  This stuff is
;;; in keymap.c.

;Prevent the \{...} documentation construct
;from mentioning keys that run this command.

;;; Code:

(put 'undefined 'suppress-keymap t)

(defun undefined ()
  (interactive)
  (ding))

(defun suppress-keymap (map &optional nodigits)
  "Make MAP override all normally self-inserting keys to be undefined.
Normally, as an exception, digits and minus-sign are set to make prefix args,
but optional second arg NODIGITS non-nil treats them like other chars."
  (substitute-key-definition 'self-insert-command 'undefined map global-map)
  (or nodigits
      (let ((string (make-string 1 ?0)))
	(define-key map "-" 'negative-argument)
	;; Make plain numbers do numeric args.
	(while (<= (aref string 0) ?9)
	  (define-key map string 'digit-argument)
	  (incf (aref string 0))))))

(defun substitute-key-definition (olddef newdef keymap &optional oldmap prefix)
  "Replace OLDDEF with NEWDEF for any keys in KEYMAP now defined as OLDDEF.
In other words, OLDDEF is replaced with NEWDEF wherever it appears.
Prefix keymaps are checked recursively.  If optional fourth argument OLDMAP
is specified, we redefine in KEYMAP as NEWDEF those chars which are defined
as OLDDEF in OLDMAP, unless that keybinding is already present in keymap.
If optional fifth argument PREFIX is defined, then only those occurrences of
OLDDEF found in keymaps accessible through the keymap bound to PREFIX in
KEYMAP are redefined.  See also `accessible-keymaps'."
  (let ((maps (accessible-keymaps (or oldmap keymap) prefix))
	(shadowing (not (null oldmap)))
	prefix map)
    (while maps
      (setq prefix (car (car maps))
	    map (cdr (car maps))
	    maps (cdr maps))
      ;; Substitute in this keymap
      (map-keymap #'(lambda (key binding)
		      (if (eq binding olddef)
			  ;; The new bindings always go in KEYMAP even if we
			  ;; found them in OLDMAP or one of its children.
			  ;; If KEYMAP will be shadowing OLDMAP, then do not
			  ;; redefine the key if there is another binding
			  ;; in KEYMAP that will shadow OLDDEF.
			  (or (and shadowing
				   (lookup-key keymap key))
			      ;; define-key will give an error if a prefix
			      ;; of the key is already defined.  Otherwise
			      ;; it will define the key in the map.
			      ;; #### - Perhaps this should be protected?
			      (define-key
				keymap
				(vconcat prefix (list key))
				newdef))))
		  map)
      )))


;; From Bill Dubuque <wgd@martigny.ai.mit.edu>

;; This used to wrap forms into an interactive lambda.  It is unclear
;; to me why this is needed in this function.  Anyway,
;; `key-or-menu-binding' doesn't do it, so this function no longer
;; does it, either.
(defun insert-key-binding (key)         ; modeled after describe-key
  "Insert the command bound to KEY."
  (interactive "kInsert command bound to key: ")
  (let ((defn (key-or-menu-binding key)))
    (if (or (null defn) (integerp defn))
	(error "%s is undefined" (key-description key))
      (if (or (stringp defn) (vectorp defn))
          (setq defn (key-binding defn))) ;; a keyboard macro
      (insert (format "%s" defn)))))

;; From Bill Dubuque <wgd@martigny.ai.mit.edu>
(defun read-command-or-command-sexp (prompt)
  "Read a command symbol or command sexp.
A command sexp is wrapped in an interactive lambda if needed.
Prompts with PROMPT."
  ;; Todo: it would be better if we could reject symbols that are not
  ;; commandp (as does 'read-command') but that is not easy to do
  ;; because we must supply arg4 = require-match = nil for sexp case.
  (let ((result (car (read-from-string
                      (completing-read prompt obarray 'commandp)))))
    (if (and (consp result)
             (not (eq (car result) 'lambda)))
        `(lambda ()
	   (interactive)
	   ,result)
      result)))

(defun local-key-binding (keys)
  "Return the binding for command KEYS in current local keymap only.
KEYS is a string, a vector of events, or a vector of key-description lists
as described in the documentation for the `define-key' function.
The binding is probably a symbol with a function definition; see
the documentation for `lookup-key' for more information."
  (let ((map (current-local-map)))
    (if map
        (lookup-key map keys)
        nil)))

(defun global-key-binding (keys)
  "Return the binding for command KEYS in current global keymap only.
KEYS is a string or vector of events, a sequence of keystrokes.
The binding is probably a symbol with a function definition; see
the documentation for `lookup-key' for more information."
  (lookup-key (current-global-map) keys))

;; from Bill Dubuque <wgd@martigny.ai.mit.edu>
(defun global-set-key (key command)
  "Give KEY a global binding as COMMAND.
COMMAND is a symbol naming an interactively-callable function.
KEY is a string, a vector of events, or a vector of key-description lists
as described in the documentation for the `define-key' function.
Note that if KEY has a local binding in the current buffer
that local binding will continue to shadow any global binding."
  ;;(interactive "KSet key globally: \nCSet key %s to command: ")
  (interactive (list (setq key (read-key-sequence "Set key globally: "))
                     ;; Command sexps are allowed here so that this arg
                     ;; may be supplied interactively via insert-key-binding.
                     (read-command-or-command-sexp
                       (format "Set key %s to command: "
                               (key-description key)))))
  (define-key (current-global-map) key command)
  nil)

;; from Bill Dubuque <wgd@martigny.ai.mit.edu>
(defun local-set-key (key command)
  "Give KEY a local binding as COMMAND.
COMMAND is a symbol naming an interactively-callable function.
KEY is a string, a vector of events, or a vector of key-description lists
as described in the documentation for the `define-key' function.
The binding goes in the current buffer's local map,
which is shared with other buffers in the same major mode."
  ;;(interactive "KSet key locally: \nCSet key %s locally to command: ")
  (interactive (list (setq key (read-key-sequence "Set key locally: "))
                     ;; Command sexps are allowed here so that this arg
                     ;; may be supplied interactively via insert-key-binding.
                     (read-command-or-command-sexp
                       (format "Set key %s locally to command: "
                               (key-description key)))))
  (if (null (current-local-map))
      (use-local-map (make-sparse-keymap)))
  (define-key (current-local-map) key command)
  nil)

(defun global-unset-key (key)
  "Remove global binding of KEY.
KEY is a string, a vector of events, or a vector of key-description lists
as described in the documentation for the `define-key' function."
  (interactive "kUnset key globally: ")
  (global-set-key key nil))

(defun local-unset-key (key)
  "Remove local binding of KEY.
KEY is a string, a vector of events, or a vector of key-description lists
as described in the documentation for the `define-key' function."
  (interactive "kUnset key locally: ")
  (if (current-local-map)
      (define-key (current-local-map) key nil)))


;; FSF-inherited brain-death.
(defun minor-mode-key-binding (key &optional accept-default)
  "Find the visible minor mode bindings of KEY.
Return an alist of pairs (MODENAME . BINDING), where MODENAME is
the symbol which names the minor mode binding KEY, and BINDING is
KEY's definition in that mode.  In particular, if KEY has no
minor-mode bindings, return nil.  If the first binding is a
non-prefix, all subsequent bindings will be omitted, since they would
be ignored.  Similarly, the list doesn't include non-prefix bindings
that come after prefix bindings.

If optional argument ACCEPT-DEFAULT is non-nil, recognize default
bindings; see the description of `lookup-key' for more details about this."
  (let ((tail minor-mode-map-alist)
        a s v)
    (while tail
      (setq a (car tail)
            tail (cdr tail))
      (and (consp a)
           (symbolp (setq s (car a)))
           (boundp s)
           (symbol-value s)
           ;; indirect-function deals with autoloadable keymaps
           (setq v (indirect-function (cdr a)))
           (setq v (lookup-key v key accept-default))
           ;; Terminate loop, with v set to non-nil value
           (setq tail nil)))
    v))


(defun current-minor-mode-maps ()
  "Return a list of keymaps for the minor modes of the current buffer."
  (let ((l '())
        (tail minor-mode-map-alist)
        a s v)
    (while tail
      (setq a (car tail)
            tail (cdr tail))
      (and (consp a)
           (symbolp (setq s (car a)))
           (boundp s)
           (symbol-value s)
           ;; indirect-function deals with autoloadable keymaps
           (setq v (indirect-function (cdr a)))
           (setq l (cons v l))))
    (nreverse l)))


;;#### What a crock
(defun define-prefix-command (name &optional mapvar)
  "Define COMMAND as a prefix command.
A new sparse keymap is stored as COMMAND's function definition.
If second optional argument MAPVAR is not specified,
 COMMAND's value (as well as its function definition) is set to the keymap.
If a second optional argument MAPVAR is given and is not `t',
  the map is stored as its value.
Regardless of MAPVAR, COMMAND's function-value is always set to the keymap."
  (let ((map (make-sparse-keymap name)))
    (fset name map)
    (cond ((not mapvar)
           (set name map))
          ((eq mapvar 't)
           )
          (t
           (set mapvar map)))
    name))


;;; Converting vectors of events to a read-equivalent form.
;;; This is used both by call-interactively (for the command history)
;;; and by macros.el (for saving keyboard macros to a file).

;; ### why does (events-to-keys [backspace]) return "\C-h"?
;; BTW, this function is a mess, and macros.el does *not* use it, in
;; spite of the above comment.  `format-kbd-macro' is used to save
;; keyboard macros to a file.
(defun events-to-keys (events &optional no-mice)
 "Given a vector of event objects, returns a vector of key descriptors,
or a string (if they all fit in the ASCII range).
Optional arg NO-MICE means that button events are not allowed."
 (if (and events (symbolp events)) (setq events (vector events)))
 (cond ((stringp events)
        events)
       ((not (vectorp events))
        (signal 'wrong-type-argument (list 'vectorp events)))
       ((let* ((length (length events))
               (string (make-string length 0))
               c ce
               (i 0))
          (while (< i length)
            (setq ce (aref events i))
            (or (eventp ce) (setq ce (character-to-event ce)))
            ;; Normalize `c' to `?c' and `(control k)' to `?\C-k'
            ;; By passing t for the `allow-meta' arg we could get kbd macros
            ;; with meta in them to translate to the string form instead of
            ;; the list/symbol form; but I expect that would cause confusion,
            ;; so let's use the list/symbol form whenever there's
            ;; any ambiguity.
            (setq c (event-to-character ce))
            (if (and c
                     character-set-property
                     (key-press-event-p ce))
                (cond ((symbolp (event-key ce))
                       (if (get (event-key ce) character-set-property)
                           ;; Don't use a string for `backspace' and `tab' to
                           ;;  avoid that unpleasant little ambiguity.
                           (setq c nil)))
                      ((and (= (event-modifier-bits ce) 1) ;control
                            (integerp (event-key ce)))
                       (let* ((te (character-to-event c)))
                         (if (and (symbolp (event-key te))
                                  (get (event-key te) character-set-property))
                             ;; Don't "normalize" (control i) to tab
                             ;;  to avoid the ambiguity in the other direction
                             (setq c nil))
                         (deallocate-event te)))))
            (if c
                (aset string i c)
                (setq i length string nil))
            (setq i (1+ i)))
          string))
       (t
        (let* ((length (length events))
               (new (copy-sequence events))
               event mods key
               (i 0))
          (while (< i length)
            (setq event (aref events i))
            (cond ((key-press-event-p event)
                   (setq mods (event-modifiers event)
                         key (event-key event))
                   (if (numberp key)
                       (setq key (intern (make-string 1 key))))
                   (aset new i (if mods
                                   (nconc mods (cons key nil))
                                   key)))
                  ((misc-user-event-p event)
                   (aset new i (list 'menu-selection
                                     (event-function event)
                                     (event-object event))))
                  ((or (button-press-event-p event)
                       (button-release-event-p event))
                   (if no-mice
                       (error
                         "Mouse events can't be saved in keyboard macros."))
                   (setq mods (event-modifiers event)
                         key (intern (concat "button"
                                             (event-button event)
                                             (if (button-release-event-p event)
                                                 "up" ""))))
                   (aset new i (if mods
                                   (nconc mods (cons key nil))
                                   key)))
                  ((or (and event (symbolp event))
                       (and (consp event) (symbolp (car event))))
                   (aset new i event))
                  (t
                   (signal 'wrong-type-argument (list 'eventp event))))
            (setq i (1+ i)))
          new))))


(defun next-key-event ()
  "Return the next available keyboard event."
  (let (event)
    (while (not (key-press-event-p (setq event (next-command-event))))
      (dispatch-event event))
    event))

(defun key-sequence-list-description (keys)
  "Convert a key sequence KEYS to the full [(modifiers... key)...] form.
Argument KEYS can be in any form accepted by `define-key' function."
  (let ((vec
	  (cond ((vectorp keys)
		 keys)
		((stringp keys)
		 (vconcat keys))
		(t
		 (vector keys))))
	 (event-to-list
	  #'(lambda (ev)
	    (append (event-modifiers ev) (list (event-key ev))))))
    (mapvector
     #'(lambda (key)
       (cond ((key-press-event-p key)
	      (funcall event-to-list key))
	     ((characterp key)
	      (funcall event-to-list (character-to-event key)))
	     ((listp key)
	      key)
	     (t
	      (list key))))
     vec)))


;;; Support keyboard commands to turn on various modifiers.

;;; These functions -- which are not commands -- each add one modifier
;;; to the following event.

(defun event-apply-alt-modifier (ignore-prompt)
  (event-apply-modifier 'alt))
(defun event-apply-super-modifier (ignore-prompt)
  (event-apply-modifier 'super))
(defun event-apply-hyper-modifier (ignore-prompt)
  (event-apply-modifier 'hyper))
(defun event-apply-shift-modifier (ignore-prompt)
  (event-apply-modifier 'shift))
(defun event-apply-control-modifier (ignore-prompt)
  (event-apply-modifier 'control))
(defun event-apply-meta-modifier (ignore-prompt)
  (event-apply-modifier 'meta))

;;; #### `key-translate-map' is ignored for now.
(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' is scanned for prefix bindings."
  (let (events binding)
    ;; read keystrokes scanning `function-key-map'
    (while (keymapp
	    (setq binding
		  (lookup-key
		   function-key-map
		   (vconcat
		    (setq events
			  (append events (list (next-key-event)))))))))
    (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))))))

(defun synthesize-keysym (ignore-prompt)
  "Read a sequence of keys, and returned the corresponding key symbol.
The characters must be from the [-_a-zA-Z0-9].  Reading is terminated
 by RET (which is discarded)."
  (let ((continuep t)
	event char list)
    (while continuep
      (setq event (next-key-event))
      (cond ((and (setq char (event-to-character event))
		  (or (memq char '(?- ?_))
		      (eq ?w (char-syntax char (standard-syntax-table)))))
	     ;; Advance a character.
	     (push char list))
	    ((or (memq char '(?\r ?\n))
		 (memq (event-key event) '(return newline)))
	     ;; Legal termination.
	     (setq continuep nil))
	    (char
	     ;; Illegal character.
	     (error "Illegal character in keysym: %c" char))
	    (t
	     ;; Illegal event.
	     (error "Event has no character equivalent: %s" event))))
    (vector (intern (concat "" (nreverse list))))))

;; This looks dirty.  The following code should maybe go to another
;; file, and `create-console-hook' should maybe default to nil.
(add-hook
 'create-console-hook
 #'(lambda (console)
   (letf (((selected-console) console))
     (define-key function-key-map [?\C-x ?@ ?h] 'event-apply-hyper-modifier)
     (define-key function-key-map [?\C-x ?@ ?s] 'event-apply-super-modifier)
     (define-key function-key-map [?\C-x ?@ ?m] 'event-apply-meta-modifier)
     (define-key function-key-map [?\C-x ?@ ?S] 'event-apply-shift-modifier)
     (define-key function-key-map [?\C-x ?@ ?c] 'event-apply-control-modifier)
     (define-key function-key-map [?\C-x ?@ ?a] 'event-apply-alt-modifier)
     (define-key function-key-map [?\C-x ?@ ?k] 'synthesize-keysym))))

;;; keymap.el ends here
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.