241 lines
11 KiB
EmacsLisp
241 lines
11 KiB
EmacsLisp
;;; compat.el --- Thin backward-compatibility shim -*- lexical-binding: t; -*-
|
|
|
|
;;; Commentary:
|
|
|
|
;; I use different versionso of Emacs. Sometimes I have to copy-paste functions
|
|
;; from newer Emacs to make my customizations work. This is that file.
|
|
|
|
;; This is probably ill-advised.
|
|
|
|
;;; Code:
|
|
|
|
(unless (fboundp 'keymap--compile-check)
|
|
(defun keymap--compile-check (&rest keys)
|
|
(dolist (key keys)
|
|
(when (or (vectorp key)
|
|
(and (stringp key) (not (key-valid-p key))))
|
|
(byte-compile-warn "Invalid `kbd' syntax: %S" key)))))
|
|
|
|
(unless (fboundp 'keymap-lookup)
|
|
(defun keymap-lookup (keymap key &optional accept-default no-remap position)
|
|
"Return the binding for command KEY.
|
|
KEY is a string that satisfies `key-valid-p'.
|
|
|
|
If KEYMAP is nil, look up in the current keymaps. If non-nil, it
|
|
should either be a keymap or a list of keymaps, and only these
|
|
keymap(s) will be consulted.
|
|
|
|
The binding is probably a symbol with a function definition.
|
|
|
|
Normally, `keymap-lookup' ignores bindings for t, which act as
|
|
default bindings, used when nothing else in the keymap applies;
|
|
this makes it usable as a general function for probing keymaps.
|
|
However, if the optional second argument ACCEPT-DEFAULT is
|
|
non-nil, `keymap-lookup' does recognize the default bindings,
|
|
just as `read-key-sequence' does.
|
|
|
|
Like the normal command loop, `keymap-lookup' will remap the
|
|
command resulting from looking up KEY by looking up the command
|
|
in the current keymaps. However, if the optional third argument
|
|
NO-REMAP is non-nil, `keymap-lookup' returns the unmapped
|
|
command.
|
|
|
|
If KEY is a key sequence initiated with the mouse, the used keymaps
|
|
will depend on the clicked mouse position with regard to the buffer
|
|
and possible local keymaps on strings.
|
|
|
|
If the optional argument POSITION is non-nil, it specifies a mouse
|
|
position as returned by `event-start' and `event-end', and the lookup
|
|
occurs in the keymaps associated with it instead of KEY. It can also
|
|
be a number or marker, in which case the keymap properties at the
|
|
specified buffer position instead of point are used."
|
|
(declare (compiler-macro (lambda (form) (keymap--compile-check key) form)))
|
|
(keymap--check key)
|
|
(when (and keymap position)
|
|
(error "Can't pass in both keymap and position"))
|
|
(if keymap
|
|
(let ((value (lookup-key keymap (key-parse key) accept-default)))
|
|
(if (and (not no-remap)
|
|
(symbolp value))
|
|
(or (command-remapping value) value)
|
|
value))
|
|
(key-binding (kbd key) accept-default no-remap position))))
|
|
|
|
(unless (fboundp 'keymap--check)
|
|
(defun keymap--check (key)
|
|
"Signal an error if KEY doesn't have a valid syntax."
|
|
(unless (key-valid-p key)
|
|
(error "%S is not a valid key definition; see `key-valid-p'" key))))
|
|
|
|
(unless (fboundp 'key-valid-p)
|
|
(defun key-valid-p (keys)
|
|
"Say whether KEYS is a valid key.
|
|
A key is a string consisting of one or more key strokes.
|
|
The key strokes are separated by single space characters.
|
|
|
|
Each key stroke is either a single character, or the name of an
|
|
event, surrounded by angle brackets. In addition, any key stroke
|
|
may be preceded by one or more modifier keys. Finally, a limited
|
|
number of characters have a special shorthand syntax.
|
|
|
|
Here's some example key sequences.
|
|
|
|
\"f\" (the key 'f')
|
|
\"S o m\" (a three key sequence of the keys 'S', 'o' and 'm')
|
|
\"C-c o\" (a two key sequence of the keys 'c' with the control modifier
|
|
and then the key 'o')
|
|
\"H-<left>\" (the key named \"left\" with the hyper modifier)
|
|
\"M-RET\" (the \"return\" key with a meta modifier)
|
|
\"C-M-<space>\" (the \"space\" key with both the control and meta modifiers)
|
|
|
|
These are the characters that have shorthand syntax:
|
|
NUL, RET, TAB, LFD, ESC, SPC, DEL.
|
|
|
|
Modifiers have to be specified in this order:
|
|
|
|
A-C-H-M-S-s
|
|
|
|
which is
|
|
|
|
Alt-Control-Hyper-Meta-Shift-super"
|
|
(declare (pure t) (side-effect-free t))
|
|
(and
|
|
(stringp keys)
|
|
(string-match-p "\\`[^ ]+\\( [^ ]+\\)*\\'" keys)
|
|
(save-match-data
|
|
(catch 'exit
|
|
(let ((prefixes
|
|
"\\(A-\\)?\\(C-\\)?\\(H-\\)?\\(M-\\)?\\(S-\\)?\\(s-\\)?")
|
|
(case-fold-search nil))
|
|
(dolist (key (split-string keys " "))
|
|
;; Every key might have these modifiers, and they should be
|
|
;; in this order.
|
|
(when (string-match (concat "\\`" prefixes) key)
|
|
(setq key (substring key (match-end 0))))
|
|
(unless (or (and (= (length key) 1)
|
|
;; Don't accept control characters as keys.
|
|
(not (< (aref key 0) ?\s))
|
|
;; Don't accept Meta'd characters as keys.
|
|
(or (multibyte-string-p key)
|
|
(not (<= 127 (aref key 0) 255))))
|
|
(and (string-match-p "\\`<[-_A-Za-z0-9]+>\\'" key)
|
|
;; Don't allow <M-C-down>.
|
|
(= (progn
|
|
(string-match
|
|
(concat "\\`<" prefixes) key)
|
|
(match-end 0))
|
|
1))
|
|
(string-match-p
|
|
"\\`\\(NUL\\|RET\\|TAB\\|LFD\\|ESC\\|SPC\\|DEL\\)\\'"
|
|
key))
|
|
;; Invalid.
|
|
(throw 'exit nil)))
|
|
t))))))
|
|
|
|
(unless (fboundp 'key-parse)
|
|
(defun key-parse (keys)
|
|
"Convert KEYS to the internal Emacs key representation.
|
|
See `kbd' for a descripion of KEYS."
|
|
(declare (pure t) (side-effect-free t))
|
|
;; A pure function is expected to preserve the match data.
|
|
(save-match-data
|
|
(let ((case-fold-search nil)
|
|
(len (length keys)) ; We won't alter keys in the loop below.
|
|
(pos 0)
|
|
(res []))
|
|
(while (and (< pos len)
|
|
(string-match "[^ \t\n\f]+" keys pos))
|
|
(let* ((word-beg (match-beginning 0))
|
|
(word-end (match-end 0))
|
|
(word (substring keys word-beg len))
|
|
(times 1)
|
|
key)
|
|
;; Try to catch events of the form "<as df>".
|
|
(if (string-match "\\`<[^ <>\t\n\f][^>\t\n\f]*>" word)
|
|
(setq word (match-string 0 word)
|
|
pos (+ word-beg (match-end 0)))
|
|
(setq word (substring keys word-beg word-end)
|
|
pos word-end))
|
|
(when (string-match "\\([0-9]+\\)\\*." word)
|
|
(setq times (string-to-number (substring word 0 (match-end 1))))
|
|
(setq word (substring word (1+ (match-end 1)))))
|
|
(cond ((string-match "^<<.+>>$" word)
|
|
(setq key (vconcat (if (eq (key-binding [?\M-x])
|
|
'execute-extended-command)
|
|
[?\M-x]
|
|
(or (car (where-is-internal
|
|
'execute-extended-command))
|
|
[?\M-x]))
|
|
(substring word 2 -2) "\r")))
|
|
((and (string-match "^\\(\\([ACHMsS]-\\)*\\)<\\(.+\\)>$" word)
|
|
(progn
|
|
(setq word (concat (match-string 1 word)
|
|
(match-string 3 word)))
|
|
(not (string-match
|
|
"\\<\\(NUL\\|RET\\|LFD\\|ESC\\|SPC\\|DEL\\)$"
|
|
word))))
|
|
(setq key (list (intern word))))
|
|
((or (equal word "REM") (string-match "^;;" word))
|
|
(setq pos (string-match "$" keys pos)))
|
|
(t
|
|
(let ((orig-word word) (prefix 0) (bits 0))
|
|
(while (string-match "^[ACHMsS]-." word)
|
|
(setq bits (+ bits
|
|
(cdr
|
|
(assq (aref word 0)
|
|
'((?A . ?\A-\^@) (?C . ?\C-\^@)
|
|
(?H . ?\H-\^@) (?M . ?\M-\^@)
|
|
(?s . ?\s-\^@) (?S . ?\S-\^@))))))
|
|
(setq prefix (+ prefix 2))
|
|
(setq word (substring word 2)))
|
|
(when (string-match "^\\^.$" word)
|
|
(setq bits (+ bits ?\C-\^@))
|
|
(setq prefix (1+ prefix))
|
|
(setq word (substring word 1)))
|
|
(let ((found (assoc word '(("NUL" . "\0") ("RET" . "\r")
|
|
("LFD" . "\n") ("TAB" . "\t")
|
|
("ESC" . "\e") ("SPC" . " ")
|
|
("DEL" . "\177")))))
|
|
(when found (setq word (cdr found))))
|
|
(when (string-match "^\\\\[0-7]+$" word)
|
|
(let ((n 0))
|
|
(dolist (ch (cdr (string-to-list word)))
|
|
(setq n (+ (* n 8) ch -48)))
|
|
(setq word (vector n))))
|
|
(cond ((= bits 0)
|
|
(setq key word))
|
|
((and (= bits ?\M-\^@) (stringp word)
|
|
(string-match "^-?[0-9]+$" word))
|
|
(setq key (mapcar (lambda (x) (+ x bits))
|
|
(append word nil))))
|
|
((/= (length word) 1)
|
|
(error "%s must prefix a single character, not %s"
|
|
(substring orig-word 0 prefix) word))
|
|
((and (/= (logand bits ?\C-\^@) 0) (stringp word)
|
|
;; We used to accept . and ? here,
|
|
;; but . is simply wrong,
|
|
;; and C-? is not used (we use DEL instead).
|
|
(string-match "[@-_a-z]" word))
|
|
(setq key (list (+ bits (- ?\C-\^@)
|
|
(logand (aref word 0) 31)))))
|
|
(t
|
|
(setq key (list (+ bits (aref word 0)))))))))
|
|
(when key
|
|
(dolist (_ (number-sequence 1 times))
|
|
(setq res (vconcat res key))))))
|
|
(if (and (>= (length res) 4)
|
|
(eq (aref res 0) ?\C-x)
|
|
(eq (aref res 1) ?\()
|
|
(eq (aref res (- (length res) 2)) ?\C-x)
|
|
(eq (aref res (- (length res) 1)) ?\)))
|
|
(apply #'vector (let ((lres (append res nil)))
|
|
;; Remove the first and last two elements.
|
|
(setq lres (cdr (cdr lres)))
|
|
(nreverse lres)
|
|
(setq lres (cdr (cdr lres)))
|
|
(nreverse lres)))
|
|
res)))))
|
|
|
|
(provide 'compat)
|
|
;;; compat.el ends here
|