Mercurial > hg > xemacs-beta

comparison lisp/keymap.el @ 5808:1b984807a299

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Support control shift u for Unicode input as does GTK. lisp/ChangeLog addition: 2014-08-05 Aidan Kehoe <kehoea@parhasard.net> * keymap.el: * keymap.el (event-apply-modifiers): When a character keysym has case information, apply the shift modifier to it by upcasing it. * keymap.el (synthesize-keysym): Document this a little. * keymap.el (synthesize-unicode-codepoint): New. Like #'synthesize-keysym, but synthesizing a Unicode codepoint. * keymap.el (function-key-map-parent): Bind control shift u to synthesize a Unicode character input, as does GTK+ and as specified by ISO 14755.
author Aidan Kehoe <kehoea@parhasard.net>
date Fri, 22 Aug 2014 10:58:09 +0100
parents 0e9f791cc655
children c87b776ab0e1
comparison
equal deleted inserted replaced
5807:080c1762f7a1 5808:1b984807a299
443 ;;; #### `key-translate-map' is ignored for now. 443 ;;; #### `key-translate-map' is ignored for now.
444 (defun event-apply-modifiers (list) 444 (defun event-apply-modifiers (list)
445 "Return the next key event, with a list of modifiers applied. 445 "Return the next key event, with a list of modifiers applied.
446 LIST describes the names of these modifier, a list of symbols. 446 LIST describes the names of these modifier, a list of symbols.
447 `function-key-map' is scanned for prefix bindings." 447 `function-key-map' is scanned for prefix bindings."
448 (let (events binding) 448 (let (events binding key-sequence-list-description symbol-name)
449 ;; read keystrokes scanning `function-key-map' 449 ;; read keystrokes scanning `function-key-map'
450 (while (keymapp 450 (while (keymapp
451 (setq binding 451 (setq binding
452 (lookup-key 452 (lookup-key
453 function-key-map 453 function-key-map
463 ;; put remaining keystrokes back into input queue 463 ;; put remaining keystrokes back into input queue
464 (setq unread-command-events 464 (setq unread-command-events
465 (mapcar 'character-to-event (cdr events)))) 465 (mapcar 'character-to-event (cdr events))))
466 (setq unread-command-events (cdr events))) 466 (setq unread-command-events (cdr events)))
467 ;; add modifiers LIST to the first keystroke or event 467 ;; add modifiers LIST to the first keystroke or event
468 (setf key-sequence-list-description
469 (aref (key-sequence-list-description (car events)) 0))
470 (if (and (member 'shift list)
471 (symbolp (car (last key-sequence-list-description)))
472 (eql 1 (length
473 (setq symbol-name
474 (symbol-name
475 (car (last key-sequence-list-description))))))
476 (not (eql (aref symbol-name 0) (upcase (aref symbol-name 0)))))
477 (setf (car (last key-sequence-list-description))
478 (intern (upcase symbol-name))
479 list (remove* 'shift list)))
468 (vector 480 (vector
469 (append list 481 (append list
470 (set-difference (aref (key-sequence-list-description (car events)) 482 (set-difference key-sequence-list-description list :stable t)))))
471 0)
472 list :stable t)))))
473 483
474 (defun event-apply-modifier (symbol) 484 (defun event-apply-modifier (symbol)
475 "Return the next key event, with a single modifier applied. 485 "Return the next key event, with a single modifier applied.
476 See `event-apply-modifiers'." 486 See `event-apply-modifiers'."
477 (event-apply-modifiers (list symbol))) 487 (event-apply-modifiers (list symbol)))
478 488
479 (defun synthesize-keysym (ignore-prompt) 489 (defun synthesize-keysym (ignore-prompt)
480 "Read a sequence of characters, and return the corresponding keysym. 490 "Read a sequence of characters, and return the corresponding keysym.
481 The characters must be ?-, or ?_, or have word syntax. Reading is 491 The characters must be ?-, or ?_, or have word syntax. Reading is
482 terminated by RET (which is discarded)." 492 terminated by RET (which is discarded)."
493 ;; This has the disadvantage that only X11 keysyms (and space, backspace
494 ;; and friends, together with the trivial one-character keysyms) are
495 ;; recognised, and then only on a build with X11 support which has had an
496 ;; X11 frame open at some point.
483 (let ((continuep t) 497 (let ((continuep t)
484 event char list) 498 event char list)
485 (while continuep 499 (while continuep
486 (setq event (next-key-event)) 500 (setq event (next-key-event))
487 (cond ((and (setq char (event-to-character event)) 501 (cond ((and (setq char (event-to-character event))
499 (t 513 (t
500 ;; Illegal event. 514 ;; Illegal event.
501 (error "Event has no character equivalent: %s" event)))) 515 (error "Event has no character equivalent: %s" event))))
502 (vector (intern (concat "" (nreverse list)))))) 516 (vector (intern (concat "" (nreverse list))))))
503 517
518 (defun synthesize-unicode-codepoint (ignore-prompt)
519 "Read a sequence of hexadecimal digits and return a one-char keyboard macro.
520
521 The character has the Unicode code point corresponding to those hexadecimal
522 digits."
523 (symbol-macrolet ((first-prompt "Unicode hex input: u"))
524 (let* ((prompt first-prompt) (integer 0)
525 (extent (make-extent (1- (length first-prompt))
526 (length first-prompt) prompt))
527 character digit-char-p)
528 (setf (extent-face extent) 'underline
529 (extent-property extent 'duplicable) t)
530 (while (not (member (setq character
531 ;; Discard non-enter non-hex-digit characters,
532 ;; as GTK does.
533 (read-char-exclusive prompt))
534 '(?\r ?\n)))
535 (when (setq digit-char-p (digit-char-p character 16))
536 (setq integer (logior (lsh integer 4) digit-char-p)
537 prompt (concat prompt (list character)))
538 (if (>= integer #x110000)
539 (error 'args-out-of-range "Not a Unicode code point" integer))
540 (set-extent-endpoints extent (1- (length first-prompt))
541 (length prompt) prompt)))
542 (vector (list (decode-char 'ucs integer))))))
543
504 (define-key function-key-map-parent [?\C-x ?@ ?h] 'event-apply-hyper-modifier) 544 (define-key function-key-map-parent [?\C-x ?@ ?h] 'event-apply-hyper-modifier)
505 (define-key function-key-map-parent [?\C-x ?@ ?s] 'event-apply-super-modifier) 545 (define-key function-key-map-parent [?\C-x ?@ ?s] 'event-apply-super-modifier)
506 (define-key function-key-map-parent [?\C-x ?@ ?m] 'event-apply-meta-modifier) 546 (define-key function-key-map-parent [?\C-x ?@ ?m] 'event-apply-meta-modifier)
507 (define-key function-key-map-parent [?\C-x ?@ ?S] 'event-apply-shift-modifier) 547 (define-key function-key-map-parent [?\C-x ?@ ?S] 'event-apply-shift-modifier)
508 (define-key function-key-map-parent [?\C-x ?@ ?c] 'event-apply-control-modifier) 548 (define-key function-key-map-parent [?\C-x ?@ ?c] 'event-apply-control-modifier)
509 (define-key function-key-map-parent [?\C-x ?@ ?a] 'event-apply-alt-modifier) 549 (define-key function-key-map-parent [?\C-x ?@ ?a] 'event-apply-alt-modifier)
510 (define-key function-key-map-parent [?\C-x ?@ ?k] 'synthesize-keysym) 550 (define-key function-key-map-parent [?\C-x ?@ ?k] 'synthesize-keysym)
551 (define-key function-key-map-parent [(control U)] 'synthesize-unicode-codepoint)
511 552
512 ;; The autoloads for the compose map, and their bindings in 553 ;; The autoloads for the compose map, and their bindings in
513 ;; function-key-map-parent are used by GTK as well as X11. And Julian 554 ;; function-key-map-parent are used by GTK as well as X11. And Julian
514 ;; Bradfield, at least, uses x-compose on the TTY, it's reasonable to make 555 ;; Bradfield, at least, uses x-compose on the TTY, it's reasonable to make
515 ;; them generally available. 556 ;; them generally available.