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
|
;;; 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
|
