summary refs log tree commit diff stats
path: root/lisp/compat.el
diff options
context:
space:
mode:
Diffstat (limited to 'lisp/compat.el')
-rw-r--r--lisp/compat.el240
1 files changed, 240 insertions, 0 deletions
diff --git a/lisp/compat.el b/lisp/compat.el new file mode 100644 index 0000000..3107a0c --- /dev/null +++ b/lisp/compat.el
@@ -0,0 +1,240 @@
1;;; compat.el --- Thin backward-compatibility shim -*- lexical-binding: t; -*-
2
3;;; Commentary:
4
5;; I use different versionso of Emacs. Sometimes I have to copy-paste functions
6;; from newer Emacs to make my customizations work. This is that file.
7
8;; This is probably ill-advised.
9
10;;; Code:
11
12(unless (fboundp 'keymap--compile-check)
13 (defun keymap--compile-check (&rest keys)
14 (dolist (key keys)
15 (when (or (vectorp key)
16 (and (stringp key) (not (key-valid-p key))))
17 (byte-compile-warn "Invalid `kbd' syntax: %S" key)))))
18
19(unless (fboundp 'keymap-lookup)
20 (defun keymap-lookup (keymap key &optional accept-default no-remap position)
21 "Return the binding for command KEY.
22KEY is a string that satisfies `key-valid-p'.
23
24If KEYMAP is nil, look up in the current keymaps. If non-nil, it
25should either be a keymap or a list of keymaps, and only these
26keymap(s) will be consulted.
27
28The binding is probably a symbol with a function definition.
29
30Normally, `keymap-lookup' ignores bindings for t, which act as
31default bindings, used when nothing else in the keymap applies;
32this makes it usable as a general function for probing keymaps.
33However, if the optional second argument ACCEPT-DEFAULT is
34non-nil, `keymap-lookup' does recognize the default bindings,
35just as `read-key-sequence' does.
36
37Like the normal command loop, `keymap-lookup' will remap the
38command resulting from looking up KEY by looking up the command
39in the current keymaps. However, if the optional third argument
40NO-REMAP is non-nil, `keymap-lookup' returns the unmapped
41command.
42
43If KEY is a key sequence initiated with the mouse, the used keymaps
44will depend on the clicked mouse position with regard to the buffer
45and possible local keymaps on strings.
46
47If the optional argument POSITION is non-nil, it specifies a mouse
48position as returned by `event-start' and `event-end', and the lookup
49occurs in the keymaps associated with it instead of KEY. It can also
50be a number or marker, in which case the keymap properties at the
51specified buffer position instead of point are used."
52 (declare (compiler-macro (lambda (form) (keymap--compile-check key) form)))
53 (keymap--check key)
54 (when (and keymap position)
55 (error "Can't pass in both keymap and position"))
56 (if keymap
57 (let ((value (lookup-key keymap (key-parse key) accept-default)))
58 (if (and (not no-remap)
59 (symbolp value))
60 (or (command-remapping value) value)
61 value))
62 (key-binding (kbd key) accept-default no-remap position))))
63
64(unless (fboundp 'keymap--check)
65 (defun keymap--check (key)
66 "Signal an error if KEY doesn't have a valid syntax."
67 (unless (key-valid-p key)
68 (error "%S is not a valid key definition; see `key-valid-p'" key))))
69
70(unless (fboundp 'key-valid-p)
71 (defun key-valid-p (keys)
72 "Say whether KEYS is a valid key.
73A key is a string consisting of one or more key strokes.
74The key strokes are separated by single space characters.
75
76Each key stroke is either a single character, or the name of an
77event, surrounded by angle brackets. In addition, any key stroke
78may be preceded by one or more modifier keys. Finally, a limited
79number of characters have a special shorthand syntax.
80
81Here's some example key sequences.
82
83 \"f\" (the key 'f')
84 \"S o m\" (a three key sequence of the keys 'S', 'o' and 'm')
85 \"C-c o\" (a two key sequence of the keys 'c' with the control modifier
86 and then the key 'o')
87 \"H-<left>\" (the key named \"left\" with the hyper modifier)
88 \"M-RET\" (the \"return\" key with a meta modifier)
89 \"C-M-<space>\" (the \"space\" key with both the control and meta modifiers)
90
91These are the characters that have shorthand syntax:
92NUL, RET, TAB, LFD, ESC, SPC, DEL.
93
94Modifiers have to be specified in this order:
95
96 A-C-H-M-S-s
97
98which is
99
100 Alt-Control-Hyper-Meta-Shift-super"
101 (declare (pure t) (side-effect-free t))
102 (and
103 (stringp keys)
104 (string-match-p "\\`[^ ]+\\( [^ ]+\\)*\\'" keys)
105 (save-match-data
106 (catch 'exit
107 (let ((prefixes
108 "\\(A-\\)?\\(C-\\)?\\(H-\\)?\\(M-\\)?\\(S-\\)?\\(s-\\)?")
109 (case-fold-search nil))
110 (dolist (key (split-string keys " "))
111 ;; Every key might have these modifiers, and they should be
112 ;; in this order.
113 (when (string-match (concat "\\`" prefixes) key)
114 (setq key (substring key (match-end 0))))
115 (unless (or (and (= (length key) 1)
116 ;; Don't accept control characters as keys.
117 (not (< (aref key 0) ?\s))
118 ;; Don't accept Meta'd characters as keys.
119 (or (multibyte-string-p key)
120 (not (<= 127 (aref key 0) 255))))
121 (and (string-match-p "\\`<[-_A-Za-z0-9]+>\\'" key)
122 ;; Don't allow <M-C-down>.
123 (= (progn
124 (string-match
125 (concat "\\`<" prefixes) key)
126 (match-end 0))
127 1))
128 (string-match-p
129 "\\`\\(NUL\\|RET\\|TAB\\|LFD\\|ESC\\|SPC\\|DEL\\)\\'"
130 key))
131 ;; Invalid.
132 (throw 'exit nil)))
133 t))))))
134
135(unless (fboundp 'key-parse)
136 (defun key-parse (keys)
137 "Convert KEYS to the internal Emacs key representation.
138See `kbd' for a descripion of KEYS."
139 (declare (pure t) (side-effect-free t))
140 ;; A pure function is expected to preserve the match data.
141 (save-match-data
142 (let ((case-fold-search nil)
143 (len (length keys)) ; We won't alter keys in the loop below.
144 (pos 0)
145 (res []))
146 (while (and (< pos len)
147 (string-match "[^ \t\n\f]+" keys pos))
148 (let* ((word-beg (match-beginning 0))
149 (word-end (match-end 0))
150 (word (substring keys word-beg len))
151 (times 1)
152 key)
153 ;; Try to catch events of the form "<as df>".
154 (if (string-match "\\`<[^ <>\t\n\f][^>\t\n\f]*>" word)
155 (setq word (match-string 0 word)
156 pos (+ word-beg (match-end 0)))
157 (setq word (substring keys word-beg word-end)
158 pos word-end))
159 (when (string-match "\\([0-9]+\\)\\*." word)
160 (setq times (string-to-number (substring word 0 (match-end 1))))
161 (setq word (substring word (1+ (match-end 1)))))
162 (cond ((string-match "^<<.+>>$" word)
163 (setq key (vconcat (if (eq (key-binding [?\M-x])
164 'execute-extended-command)
165 [?\M-x]
166 (or (car (where-is-internal
167 'execute-extended-command))
168 [?\M-x]))
169 (substring word 2 -2) "\r")))
170 ((and (string-match "^\\(\\([ACHMsS]-\\)*\\)<\\(.+\\)>$" word)
171 (progn
172 (setq word (concat (match-string 1 word)
173 (match-string 3 word)))
174 (not (string-match
175 "\\<\\(NUL\\|RET\\|LFD\\|ESC\\|SPC\\|DEL\\)$"
176 word))))
177 (setq key (list (intern word))))
178 ((or (equal word "REM") (string-match "^;;" word))
179 (setq pos (string-match "$" keys pos)))
180 (t
181 (let ((orig-word word) (prefix 0) (bits 0))
182 (while (string-match "^[ACHMsS]-." word)
183 (setq bits (+ bits
184 (cdr
185 (assq (aref word 0)
186 '((?A . ?\A-\^@) (?C . ?\C-\^@)
187 (?H . ?\H-\^@) (?M . ?\M-\^@)
188 (?s . ?\s-\^@) (?S . ?\S-\^@))))))
189 (setq prefix (+ prefix 2))
190 (setq word (substring word 2)))
191 (when (string-match "^\\^.$" word)
192 (setq bits (+ bits ?\C-\^@))
193 (setq prefix (1+ prefix))
194 (setq word (substring word 1)))
195 (let ((found (assoc word '(("NUL" . "\0") ("RET" . "\r")
196 ("LFD" . "\n") ("TAB" . "\t")
197 ("ESC" . "\e") ("SPC" . " ")
198 ("DEL" . "\177")))))
199 (when found (setq word (cdr found))))
200 (when (string-match "^\\\\[0-7]+$" word)
201 (let ((n 0))
202 (dolist (ch (cdr (string-to-list word)))
203 (setq n (+ (* n 8) ch -48)))
204 (setq word (vector n))))
205 (cond ((= bits 0)
206 (setq key word))
207 ((and (= bits ?\M-\^@) (stringp word)
208 (string-match "^-?[0-9]+$" word))
209 (setq key (mapcar (lambda (x) (+ x bits))
210 (append word nil))))
211 ((/= (length word) 1)
212 (error "%s must prefix a single character, not %s"
213 (substring orig-word 0 prefix) word))
214 ((and (/= (logand bits ?\C-\^@) 0) (stringp word)
215 ;; We used to accept . and ? here,
216 ;; but . is simply wrong,
217 ;; and C-? is not used (we use DEL instead).
218 (string-match "[@-_a-z]" word))
219 (setq key (list (+ bits (- ?\C-\^@)
220 (logand (aref word 0) 31)))))
221 (t
222 (setq key (list (+ bits (aref word 0)))))))))
223 (when key
224 (dolist (_ (number-sequence 1 times))
225 (setq res (vconcat res key))))))
226 (if (and (>= (length res) 4)
227 (eq (aref res 0) ?\C-x)
228 (eq (aref res 1) ?\()
229 (eq (aref res (- (length res) 2)) ?\C-x)
230 (eq (aref res (- (length res) 1)) ?\)))
231 (apply #'vector (let ((lres (append res nil)))
232 ;; Remove the first and last two elements.
233 (setq lres (cdr (cdr lres)))
234 (nreverse lres)
235 (setq lres (cdr (cdr lres)))
236 (nreverse lres)))
237 res)))))
238
239(provide 'compat)
240;;; compat.el ends here