about summary refs log tree commit diff stats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--lisp/compat.el229
-rw-r--r--lisp/compat/keymap.el590
-rw-r--r--lisp/compat/tab-bar.el2424
3 files changed, 3017 insertions, 226 deletions
diff --git a/lisp/compat.el b/lisp/compat.el index 3107a0c..0cc4c42 100644 --- a/lisp/compat.el +++ b/lisp/compat.el
@@ -9,232 +9,9 @@
9 9
10;;; Code: 10;;; Code:
11 11
12(unless (fboundp 'keymap--compile-check) 12;; Load stuff in compat/ subdirectory
13 (defun keymap--compile-check (&rest keys) 13(dolist (file (directory-files (locate-user-emacs-file "lisp/compat") :full "\\.el\\'"))
14 (dolist (key keys) 14 (load file :noerror))
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 15
239(provide 'compat) 16(provide 'compat)
240;;; compat.el ends here 17;;; compat.el ends here
diff --git a/lisp/compat/keymap.el b/lisp/compat/keymap.el new file mode 100644 index 0000000..3e9189f --- /dev/null +++ b/lisp/compat/keymap.el
@@ -0,0 +1,590 @@
1;;; keymap.el --- Keymap functions -*- lexical-binding: t; -*-
2
3;; Copyright (C) 2021-2022 Free Software Foundation, Inc.
4
5;; This file is part of GNU Emacs.
6
7;; GNU Emacs is free software: you can redistribute it and/or modify
8;; it under the terms of the GNU General Public License as published by
9;; the Free Software Foundation, either version 3 of the License, or
10;; (at your option) any later version.
11
12;; GNU Emacs is distributed in the hope that it will be useful,
13;; but WITHOUT ANY WARRANTY; without even the implied warranty of
14;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15;; GNU General Public License for more details.
16
17;; You should have received a copy of the GNU General Public License
18;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
19
20;;; Commentary:
21
22;; This library deals with the "new" keymap binding interface: The
23;; only key syntax allowed by these functions is the `kbd' one.
24
25;;; Code:
26
27
28
29(defun keymap--check (key)
30 "Signal an error if KEY doesn't have a valid syntax."
31 (unless (key-valid-p key)
32 (error "%S is not a valid key definition; see `key-valid-p'" key)))
33
34(defun keymap--compile-check (&rest keys)
35 (dolist (key keys)
36 (when (or (vectorp key)
37 (and (stringp key) (not (key-valid-p key))))
38 (byte-compile-warn "Invalid `kbd' syntax: %S" key))))
39
40(defun keymap-set (keymap key definition)
41 "Set KEY to DEFINITION in KEYMAP.
42KEY is a string that satisfies `key-valid-p'.
43
44DEFINITION is anything that can be a key's definition:
45 nil (means key is undefined in this keymap),
46 a command (a Lisp function suitable for interactive calling),
47 a string (treated as a keyboard macro),
48 a keymap (to define a prefix key),
49 a symbol (when the key is looked up, the symbol will stand for its
50 function definition, which should at that time be one of the above,
51 or another symbol whose function definition is used, etc.),
52 a cons (STRING . DEFN), meaning that DEFN is the definition
53 (DEFN should be a valid definition in its own right) and
54 STRING is the menu item name (which is used only if the containing
55 keymap has been created with a menu name, see `make-keymap'),
56 or a cons (MAP . CHAR), meaning use definition of CHAR in keymap MAP,
57 or an extended menu item definition.
58 (See info node `(elisp)Extended Menu Items'.)"
59 (declare (compiler-macro (lambda (form) (keymap--compile-check key) form)))
60 (keymap--check key)
61 ;; If we're binding this key to another key, then parse that other
62 ;; key, too.
63 (when (stringp definition)
64 (keymap--check definition)
65 (setq definition (key-parse definition)))
66 (define-key keymap (key-parse key) definition))
67
68(defun keymap-global-set (key command)
69 "Give KEY a global binding as COMMAND.
70COMMAND is the command definition to use; usually it is
71a symbol naming an interactively-callable function.
72
73KEY is a string that satisfies `key-valid-p'.
74
75Note that if KEY has a local binding in the current buffer,
76that local binding will continue to shadow any global binding
77that you make with this function."
78 (declare (compiler-macro (lambda (form) (keymap--compile-check key) form)))
79 (interactive
80 (let* ((menu-prompting nil)
81 (key (read-key-sequence "Set key globally: " nil t)))
82 (list key
83 (read-command (format "Set key %s to command: "
84 (key-description key))))))
85 (keymap-set (current-global-map) key command))
86
87(defun keymap-local-set (key command)
88 "Give KEY a local binding as COMMAND.
89COMMAND is the command definition to use; usually it is
90a symbol naming an interactively-callable function.
91
92KEY is a string that satisfies `key-valid-p'.
93
94The binding goes in the current buffer's local map, which in most
95cases is shared with all other buffers in the same major mode."
96 (declare (compiler-macro (lambda (form) (keymap--compile-check key) form)))
97 (interactive "KSet key locally: \nCSet key %s locally to command: ")
98 (let ((map (current-local-map)))
99 (unless map
100 (use-local-map (setq map (make-sparse-keymap))))
101 (keymap-set map key command)))
102
103(defun keymap-global-unset (key &optional remove)
104 "Remove global binding of KEY (if any).
105KEY is a string that satisfies `key-valid-p'.
106
107If REMOVE (interactively, the prefix arg), remove the binding
108instead of unsetting it. See `keymap-unset' for details."
109 (declare (compiler-macro (lambda (form) (keymap--compile-check key) form)))
110 (interactive
111 (list (key-description (read-key-sequence "Set key locally: "))
112 current-prefix-arg))
113 (keymap-unset (current-global-map) key remove))
114
115(defun keymap-local-unset (key &optional remove)
116 "Remove local binding of KEY (if any).
117KEY is a string that satisfies `key-valid-p'.
118
119If REMOVE (interactively, the prefix arg), remove the binding
120instead of unsetting it. See `keymap-unset' for details."
121 (declare (compiler-macro (lambda (form) (keymap--compile-check key) form)))
122 (interactive
123 (list (key-description (read-key-sequence "Unset key locally: "))
124 current-prefix-arg))
125 (when (current-local-map)
126 (keymap-unset (current-local-map) key remove)))
127
128(defun keymap-unset (keymap key &optional remove)
129 "Remove key sequence KEY from KEYMAP.
130KEY is a string that satisfies `key-valid-p'.
131
132If REMOVE, remove the binding instead of unsetting it. This only
133makes a difference when there's a parent keymap. When unsetting
134a key in a child map, it will still shadow the same key in the
135parent keymap. Removing the binding will allow the key in the
136parent keymap to be used."
137 (declare (compiler-macro (lambda (form) (keymap--compile-check key) form)))
138 (keymap--check key)
139 (define-key keymap (key-parse key) nil remove))
140
141(defun keymap-substitute (keymap olddef newdef &optional oldmap prefix)
142 "Replace OLDDEF with NEWDEF for any keys in KEYMAP now defined as OLDDEF.
143In other words, OLDDEF is replaced with NEWDEF wherever it appears.
144Alternatively, if optional fourth argument OLDMAP is specified, we redefine
145in KEYMAP as NEWDEF those keys that are defined as OLDDEF in OLDMAP.
146
147If you don't specify OLDMAP, you can usually get the same results
148in a cleaner way with command remapping, like this:
149 (define-key KEYMAP [remap OLDDEF] NEWDEF)
150\n(fn OLDDEF NEWDEF KEYMAP &optional OLDMAP)"
151 ;; Don't document PREFIX in the doc string because we don't want to
152 ;; advertise it. It's meant for recursive calls only. Here's its
153 ;; meaning
154
155 ;; If optional argument PREFIX is specified, it should be a key
156 ;; prefix, a string. Redefined bindings will then be bound to the
157 ;; original key, with PREFIX added at the front.
158 (unless prefix
159 (setq prefix ""))
160 (let* ((scan (or oldmap keymap))
161 (prefix1 (vconcat prefix [nil]))
162 (key-substitution-in-progress
163 (cons scan key-substitution-in-progress)))
164 ;; Scan OLDMAP, finding each char or event-symbol that
165 ;; has any definition, and act on it with hack-key.
166 (map-keymap
167 (lambda (char defn)
168 (aset prefix1 (length prefix) char)
169 (substitute-key-definition-key defn olddef newdef prefix1 keymap))
170 scan)))
171
172(defun keymap-set-after (keymap key definition &optional after)
173 "Add binding in KEYMAP for KEY => DEFINITION, right after AFTER's binding.
174This is like `keymap-set' except that the binding for KEY is placed
175just after the binding for the event AFTER, instead of at the beginning
176of the map. Note that AFTER must be an event type (like KEY), NOT a command
177\(like DEFINITION).
178
179If AFTER is t or omitted, the new binding goes at the end of the keymap.
180AFTER should be a single event type--a symbol or a character, not a sequence.
181
182Bindings are always added before any inherited map.
183
184The order of bindings in a keymap matters only when it is used as
185a menu, so this function is not useful for non-menu keymaps."
186 (declare (indent defun)
187 (compiler-macro (lambda (form) (keymap--compile-check key) form)))
188 (keymap--check key)
189 (when after
190 (keymap--check after))
191 (define-key-after keymap (key-parse key) definition
192 (and after (key-parse after))))
193
194(defun key-parse (keys)
195 "Convert KEYS to the internal Emacs key representation.
196See `kbd' for a descripion of KEYS."
197 (declare (pure t) (side-effect-free t))
198 ;; A pure function is expected to preserve the match data.
199 (save-match-data
200 (let ((case-fold-search nil)
201 (len (length keys)) ; We won't alter keys in the loop below.
202 (pos 0)
203 (res []))
204 (while (and (< pos len)
205 (string-match "[^ \t\n\f]+" keys pos))
206 (let* ((word-beg (match-beginning 0))
207 (word-end (match-end 0))
208 (word (substring keys word-beg len))
209 (times 1)
210 key)
211 ;; Try to catch events of the form "<as df>".
212 (if (string-match "\\`<[^ <>\t\n\f][^>\t\n\f]*>" word)
213 (setq word (match-string 0 word)
214 pos (+ word-beg (match-end 0)))
215 (setq word (substring keys word-beg word-end)
216 pos word-end))
217 (when (string-match "\\([0-9]+\\)\\*." word)
218 (setq times (string-to-number (substring word 0 (match-end 1))))
219 (setq word (substring word (1+ (match-end 1)))))
220 (cond ((string-match "^<<.+>>$" word)
221 (setq key (vconcat (if (eq (key-binding [?\M-x])
222 'execute-extended-command)
223 [?\M-x]
224 (or (car (where-is-internal
225 'execute-extended-command))
226 [?\M-x]))
227 (substring word 2 -2) "\r")))
228 ((and (string-match "^\\(\\([ACHMsS]-\\)*\\)<\\(.+\\)>$" word)
229 (progn
230 (setq word (concat (match-string 1 word)
231 (match-string 3 word)))
232 (not (string-match
233 "\\<\\(NUL\\|RET\\|LFD\\|ESC\\|SPC\\|DEL\\)$"
234 word))))
235 (setq key (list (intern word))))
236 ((or (equal word "REM") (string-match "^;;" word))
237 (setq pos (string-match "$" keys pos)))
238 (t
239 (let ((orig-word word) (prefix 0) (bits 0))
240 (while (string-match "^[ACHMsS]-." word)
241 (setq bits (+ bits
242 (cdr
243 (assq (aref word 0)
244 '((?A . ?\A-\^@) (?C . ?\C-\^@)
245 (?H . ?\H-\^@) (?M . ?\M-\^@)
246 (?s . ?\s-\^@) (?S . ?\S-\^@))))))
247 (setq prefix (+ prefix 2))
248 (setq word (substring word 2)))
249 (when (string-match "^\\^.$" word)
250 (setq bits (+ bits ?\C-\^@))
251 (setq prefix (1+ prefix))
252 (setq word (substring word 1)))
253 (let ((found (assoc word '(("NUL" . "\0") ("RET" . "\r")
254 ("LFD" . "\n") ("TAB" . "\t")
255 ("ESC" . "\e") ("SPC" . " ")
256 ("DEL" . "\177")))))
257 (when found (setq word (cdr found))))
258 (when (string-match "^\\\\[0-7]+$" word)
259 (let ((n 0))
260 (dolist (ch (cdr (string-to-list word)))
261 (setq n (+ (* n 8) ch -48)))
262 (setq word (vector n))))
263 (cond ((= bits 0)
264 (setq key word))
265 ((and (= bits ?\M-\^@) (stringp word)
266 (string-match "^-?[0-9]+$" word))
267 (setq key (mapcar (lambda (x) (+ x bits))
268 (append word nil))))
269 ((/= (length word) 1)
270 (error "%s must prefix a single character, not %s"
271 (substring orig-word 0 prefix) word))
272 ((and (/= (logand bits ?\C-\^@) 0) (stringp word)
273 ;; We used to accept . and ? here,
274 ;; but . is simply wrong,
275 ;; and C-? is not used (we use DEL instead).
276 (string-match "[@-_a-z]" word))
277 (setq key (list (+ bits (- ?\C-\^@)
278 (logand (aref word 0) 31)))))
279 (t
280 (setq key (list (+ bits (aref word 0)))))))))
281 (when key
282 (dolist (_ (number-sequence 1 times))
283 (setq res (vconcat res key))))))
284 (if (and (>= (length res) 4)
285 (eq (aref res 0) ?\C-x)
286 (eq (aref res 1) ?\()
287 (eq (aref res (- (length res) 2)) ?\C-x)
288 (eq (aref res (- (length res) 1)) ?\)))
289 (apply #'vector (let ((lres (append res nil)))
290 ;; Remove the first and last two elements.
291 (setq lres (cdr (cdr lres)))
292 (nreverse lres)
293 (setq lres (cdr (cdr lres)))
294 (nreverse lres)))
295 res))))
296
297(defun key-valid-p (keys)
298 "Say whether KEYS is a valid key.
299A key is a string consisting of one or more key strokes.
300The key strokes are separated by single space characters.
301
302Each key stroke is either a single character, or the name of an
303event, surrounded by angle brackets. In addition, any key stroke
304may be preceded by one or more modifier keys. Finally, a limited
305number of characters have a special shorthand syntax.
306
307Here's some example key sequences.
308
309 \"f\" (the key 'f')
310 \"S o m\" (a three key sequence of the keys 'S', 'o' and 'm')
311 \"C-c o\" (a two key sequence of the keys 'c' with the control modifier
312 and then the key 'o')
313 \"H-<left>\" (the key named \"left\" with the hyper modifier)
314 \"M-RET\" (the \"return\" key with a meta modifier)
315 \"C-M-<space>\" (the \"space\" key with both the control and meta modifiers)
316
317These are the characters that have shorthand syntax:
318NUL, RET, TAB, LFD, ESC, SPC, DEL.
319
320Modifiers have to be specified in this order:
321
322 A-C-H-M-S-s
323
324which is
325
326 Alt-Control-Hyper-Meta-Shift-super"
327 (declare (pure t) (side-effect-free t))
328 (and
329 (stringp keys)
330 (string-match-p "\\`[^ ]+\\( [^ ]+\\)*\\'" keys)
331 (save-match-data
332 (catch 'exit
333 (let ((prefixes
334 "\\(A-\\)?\\(C-\\)?\\(H-\\)?\\(M-\\)?\\(S-\\)?\\(s-\\)?")
335 (case-fold-search nil))
336 (dolist (key (split-string keys " "))
337 ;; Every key might have these modifiers, and they should be
338 ;; in this order.
339 (when (string-match (concat "\\`" prefixes) key)
340 (setq key (substring key (match-end 0))))
341 (unless (or (and (= (length key) 1)
342 ;; Don't accept control characters as keys.
343 (not (< (aref key 0) ?\s))
344 ;; Don't accept Meta'd characters as keys.
345 (or (multibyte-string-p key)
346 (not (<= 127 (aref key 0) 255))))
347 (and (string-match-p "\\`<[-_A-Za-z0-9]+>\\'" key)
348 ;; Don't allow <M-C-down>.
349 (= (progn
350 (string-match
351 (concat "\\`<" prefixes) key)
352 (match-end 0))
353 1))
354 (string-match-p
355 "\\`\\(NUL\\|RET\\|TAB\\|LFD\\|ESC\\|SPC\\|DEL\\)\\'"
356 key))
357 ;; Invalid.
358 (throw 'exit nil)))
359 t)))))
360
361(defun key-translate (from to)
362 "Translate character FROM to TO on the current terminal.
363This function creates a `keyboard-translate-table' if necessary
364and then modifies one entry in it.
365
366Both KEY and TO are strings that satisfy `key-valid-p'."
367 (declare (compiler-macro
368 (lambda (form) (keymap--compile-check from to) form)))
369 (keymap--check from)
370 (keymap--check to)
371 (or (char-table-p keyboard-translate-table)
372 (setq keyboard-translate-table
373 (make-char-table 'keyboard-translate-table nil)))
374 (aset keyboard-translate-table (key-parse from) (key-parse to)))
375
376(defun keymap-lookup (keymap key &optional accept-default no-remap position)
377 "Return the binding for command KEY.
378KEY is a string that satisfies `key-valid-p'.
379
380If KEYMAP is nil, look up in the current keymaps. If non-nil, it
381should either be a keymap or a list of keymaps, and only these
382keymap(s) will be consulted.
383
384The binding is probably a symbol with a function definition.
385
386Normally, `keymap-lookup' ignores bindings for t, which act as
387default bindings, used when nothing else in the keymap applies;
388this makes it usable as a general function for probing keymaps.
389However, if the optional second argument ACCEPT-DEFAULT is
390non-nil, `keymap-lookup' does recognize the default bindings,
391just as `read-key-sequence' does.
392
393Like the normal command loop, `keymap-lookup' will remap the
394command resulting from looking up KEY by looking up the command
395in the current keymaps. However, if the optional third argument
396NO-REMAP is non-nil, `keymap-lookup' returns the unmapped
397command.
398
399If KEY is a key sequence initiated with the mouse, the used keymaps
400will depend on the clicked mouse position with regard to the buffer
401and possible local keymaps on strings.
402
403If the optional argument POSITION is non-nil, it specifies a mouse
404position as returned by `event-start' and `event-end', and the lookup
405occurs in the keymaps associated with it instead of KEY. It can also
406be a number or marker, in which case the keymap properties at the
407specified buffer position instead of point are used."
408 (declare (compiler-macro (lambda (form) (keymap--compile-check key) form)))
409 (keymap--check key)
410 (when (and keymap position)
411 (error "Can't pass in both keymap and position"))
412 (if keymap
413 (let ((value (lookup-key keymap (key-parse key) accept-default)))
414 (if (and (not no-remap)
415 (symbolp value))
416 (or (command-remapping value) value)
417 value))
418 (key-binding (kbd key) accept-default no-remap position)))
419
420(defun keymap-local-lookup (keys &optional accept-default)
421 "Return the binding for command KEYS in current local keymap only.
422KEY is a string that satisfies `key-valid-p'.
423
424The binding is probably a symbol with a function definition.
425
426If optional argument ACCEPT-DEFAULT is non-nil, recognize default
427bindings; see the description of `keymap-lookup' for more details
428about this."
429 (declare (compiler-macro (lambda (form) (keymap--compile-check keys) form)))
430 (when-let ((map (current-local-map)))
431 (keymap-lookup map keys accept-default)))
432
433(defun keymap-global-lookup (keys &optional accept-default message)
434 "Return the binding for command KEYS in current global keymap only.
435KEY is a string that satisfies `key-valid-p'.
436
437The binding is probably a symbol with a function definition.
438This function's return values are the same as those of `keymap-lookup'
439\(which see).
440
441If optional argument ACCEPT-DEFAULT is non-nil, recognize default
442bindings; see the description of `keymap-lookup' for more details
443about this.
444
445If MESSAGE (and interactively), message the result."
446 (declare (compiler-macro (lambda (form) (keymap--compile-check keys) form)))
447 (interactive
448 (list (key-description (read-key-sequence "Look up key in global keymap: "))
449 nil t))
450 (let ((def (keymap-lookup (current-global-map) keys accept-default)))
451 (when message
452 (message "%s is bound to %s globally" keys def))
453 def))
454
455
456;;; define-keymap and defvar-keymap
457
458(defun define-keymap--compile (form &rest args)
459 ;; This compiler macro is only there for compile-time
460 ;; error-checking; it does not change the call in any way.
461 (while (and args
462 (keywordp (car args))
463 (not (eq (car args) :menu)))
464 (unless (memq (car args) '(:full :keymap :parent :suppress :name :prefix))
465 (byte-compile-warn "Invalid keyword: %s" (car args)))
466 (setq args (cdr args))
467 (when (null args)
468 (byte-compile-warn "Uneven number of keywords in %S" form))
469 (setq args (cdr args)))
470 ;; Bindings.
471 (while args
472 (let ((key (pop args)))
473 (when (and (stringp key) (not (key-valid-p key)))
474 (byte-compile-warn "Invalid `kbd' syntax: %S" key)))
475 (when (null args)
476 (byte-compile-warn "Uneven number of key bindings in %S" form))
477 (setq args (cdr args)))
478 form)
479
480(defun define-keymap (&rest definitions)
481 "Create a new keymap and define KEY/DEFINITION pairs as key bindings.
482The new keymap is returned.
483
484Options can be given as keywords before the KEY/DEFINITION
485pairs. Available keywords are:
486
487:full If non-nil, create a chartable alist (see `make-keymap').
488 If nil (i.e., the default), create a sparse keymap (see
489 `make-sparse-keymap').
490
491:suppress If non-nil, the keymap will be suppressed (see `suppress-keymap').
492 If `nodigits', treat digits like other chars.
493
494:parent If non-nil, this should be a keymap to use as the parent
495 (see `set-keymap-parent').
496
497:keymap If non-nil, instead of creating a new keymap, the given keymap
498 will be destructively modified instead.
499
500:name If non-nil, this should be a string to use as the menu for
501 the keymap in case you use it as a menu with `x-popup-menu'.
502
503:prefix If non-nil, this should be a symbol to be used as a prefix
504 command (see `define-prefix-command'). If this is the case,
505 this symbol is returned instead of the map itself.
506
507KEY/DEFINITION pairs are as KEY and DEF in `keymap-set'. KEY can
508also be the special symbol `:menu', in which case DEFINITION
509should be a MENU form as accepted by `easy-menu-define'.
510
511\(fn &key FULL PARENT SUPPRESS NAME PREFIX KEYMAP &rest [KEY DEFINITION]...)"
512 (declare (indent defun)
513 (compiler-macro define-keymap--compile))
514 (let (full suppress parent name prefix keymap)
515 ;; Handle keywords.
516 (while (and definitions
517 (keywordp (car definitions))
518 (not (eq (car definitions) :menu)))
519 (let ((keyword (pop definitions)))
520 (unless definitions
521 (error "Missing keyword value for %s" keyword))
522 (let ((value (pop definitions)))
523 (pcase keyword
524 (:full (setq full value))
525 (:keymap (setq keymap value))
526 (:parent (setq parent value))
527 (:suppress (setq suppress value))
528 (:name (setq name value))
529 (:prefix (setq prefix value))
530 (_ (error "Invalid keyword: %s" keyword))))))
531
532 (when (and prefix
533 (or full parent suppress keymap))
534 (error "A prefix keymap can't be defined with :full/:parent/:suppress/:keymap keywords"))
535
536 (when (and keymap full)
537 (error "Invalid combination: :keymap with :full"))
538
539 (let ((keymap (cond
540 (keymap keymap)
541 (prefix (define-prefix-command prefix nil name))
542 (full (make-keymap name))
543 (t (make-sparse-keymap name)))))
544 (when suppress
545 (suppress-keymap keymap (eq suppress 'nodigits)))
546 (when parent
547 (set-keymap-parent keymap parent))
548
549 ;; Do the bindings.
550 (while definitions
551 (let ((key (pop definitions)))
552 (unless definitions
553 (error "Uneven number of key/definition pairs"))
554 (let ((def (pop definitions)))
555 (if (eq key :menu)
556 (easy-menu-define nil keymap "" def)
557 (keymap-set keymap key def)))))
558 keymap)))
559
560(defmacro defvar-keymap (variable-name &rest defs)
561 "Define VARIABLE-NAME as a variable with a keymap definition.
562See `define-keymap' for an explanation of the keywords and KEY/DEFINITION.
563
564In addition to the keywords accepted by `define-keymap', this
565macro also accepts a `:doc' keyword, which (if present) is used
566as the variable documentation string.
567
568\(fn VARIABLE-NAME &key DOC FULL PARENT SUPPRESS NAME PREFIX KEYMAP &rest [KEY DEFINITION]...)"
569 (declare (indent 1))
570 (let ((opts nil)
571 doc)
572 (while (and defs
573 (keywordp (car defs))
574 (not (eq (car defs) :menu)))
575 (let ((keyword (pop defs)))
576 (unless defs
577 (error "Uneven number of keywords"))
578 (if (eq keyword :doc)
579 (setq doc (pop defs))
580 (push keyword opts)
581 (push (pop defs) opts))))
582 (unless (zerop (% (length defs) 2))
583 (error "Uneven number of key/definition pairs: %s" defs))
584 `(defvar ,variable-name
585 (define-keymap ,@(nreverse opts) ,@defs)
586 ,@(and doc (list doc)))))
587
588(provide 'keymap)
589
590;;; keymap.el ends here
diff --git a/lisp/compat/tab-bar.el b/lisp/compat/tab-bar.el new file mode 100644 index 0000000..d49fc2e --- /dev/null +++ b/lisp/compat/tab-bar.el
@@ -0,0 +1,2424 @@
1;;; tab-bar.el --- frame-local tabs with named persistent window configurations -*- lexical-binding: t; -*-
2
3;; Copyright (C) 2019-2022 Free Software Foundation, Inc.
4
5;; Author: Juri Linkov <juri@linkov.net>
6;; Keywords: frames tabs
7;; Maintainer: emacs-devel@gnu.org
8
9;; This file is part of GNU Emacs.
10
11;; GNU Emacs is free software: you can redistribute it and/or modify
12;; it under the terms of the GNU General Public License as published by
13;; the Free Software Foundation, either version 3 of the License, or
14;; (at your option) any later version.
15
16;; GNU Emacs is distributed in the hope that it will be useful,
17;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19;; GNU General Public License for more details.
20
21;; You should have received a copy of the GNU General Public License
22;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
23
24;;; Commentary:
25
26;; Provides `tab-bar-mode' to control display of the tab bar and
27;; bindings for the global tab bar.
28
29;; The normal global binding for [tab-bar] (below) uses the value of
30;; `tab-bar-map' as the actual keymap to define the tab bar.
31
32;;; Code:
33
34(eval-when-compile
35 (require 'cl-lib)
36 (require 'seq))
37
38
39(defgroup tab-bar nil
40 "Frame-local tabs."
41 :group 'convenience
42 :version "27.1")
43
44(defgroup tab-bar-faces '((tab-bar custom-face)) ; tab-bar is defined in faces.el
45 "Faces used in the tab bar."
46 :group 'tab-bar
47 :group 'faces
48 :version "27.1")
49
50(defface tab-bar-tab
51 '((default
52 :inherit tab-bar)
53 (((class color) (min-colors 88))
54 :box (:line-width 1 :style released-button))
55 (t
56 :inverse-video nil))
57 "Tab bar face for selected tab."
58 :version "27.1"
59 :group 'tab-bar-faces)
60
61(defface tab-bar-tab-inactive
62 '((default
63 :inherit tab-bar-tab)
64 (((class color) (min-colors 88))
65 :background "grey75")
66 (t
67 :inverse-video t))
68 "Tab bar face for non-selected tab."
69 :version "27.1"
70 :group 'tab-bar-faces)
71
72(defface tab-bar-tab-group-current
73 '((t :inherit tab-bar-tab :box nil :weight bold))
74 "Tab bar face for current group tab."
75 :version "28.1"
76 :group 'tab-bar-faces)
77
78(defface tab-bar-tab-group-inactive
79 '((t :inherit (shadow tab-bar-tab-inactive)))
80 "Tab bar face for inactive group tab."
81 :version "28.1"
82 :group 'tab-bar-faces)
83
84(defface tab-bar-tab-ungrouped
85 '((t :inherit (shadow tab-bar-tab-inactive)))
86 "Tab bar face for ungrouped tab when tab groups are used."
87 :version "28.1"
88 :group 'tab-bar-faces)
89
90
91(defcustom tab-bar-select-tab-modifiers '()
92 "List of modifier keys for selecting tab-bar tabs by their numbers.
93Possible modifier keys are `control', `meta', `shift', `hyper', `super' and
94`alt'. Pressing one of the modifiers in the list and a digit selects the
95tab whose number equals the digit (see `tab-bar-select-tab').
96The digit 9 selects the last (rightmost) tab (see `tab-last').
97The digit 0 selects the most recently visited tab (see `tab-recent').
98For easier selection of tabs by their numbers, consider customizing
99`tab-bar-tab-hints', which will show tab numbers alongside the tab name."
100 :type '(set :tag "Tab selection modifier keys"
101 (const control)
102 (const meta)
103 (const shift)
104 (const hyper)
105 (const super)
106 (const alt))
107 :initialize 'custom-initialize-default
108 :set (lambda (sym val)
109 (set-default sym val)
110 ;; Reenable the tab-bar with new keybindings
111 (when tab-bar-mode
112 (tab-bar--undefine-keys)
113 (tab-bar--define-keys)))
114 :group 'tab-bar
115 :version "27.1")
116
117(defun tab-bar--define-keys ()
118 "Install key bindings for switching between tabs if the user has configured them."
119 (when tab-bar-select-tab-modifiers
120 (global-set-key (vector (append tab-bar-select-tab-modifiers (list ?0)))
121 'tab-recent)
122 (dotimes (i 8)
123 (global-set-key (vector (append tab-bar-select-tab-modifiers
124 (list (+ i 1 ?0))))
125 'tab-bar-select-tab))
126 (global-set-key (vector (append tab-bar-select-tab-modifiers (list ?9)))
127 'tab-last))
128 ;; Don't override user customized key bindings
129 (unless (global-key-binding [(control tab)])
130 (global-set-key [(control tab)] 'tab-next))
131 (unless (global-key-binding [(control shift tab)])
132 (global-set-key [(control shift tab)] 'tab-previous))
133 (unless (global-key-binding [(control shift iso-lefttab)])
134 (global-set-key [(control shift iso-lefttab)] 'tab-previous))
135
136 ;; Replace default value with a condition that supports displaying
137 ;; global-mode-string in the tab bar instead of the mode line.
138 (when (and (memq 'tab-bar-format-global tab-bar-format)
139 (member '(global-mode-string ("" global-mode-string))
140 mode-line-misc-info))
141 (setf (alist-get 'global-mode-string mode-line-misc-info)
142 '(("" (:eval (if (and tab-bar-mode
143 (memq 'tab-bar-format-global
144 tab-bar-format))
145 "" global-mode-string)))))))
146
147(defun tab-bar--undefine-keys ()
148 "Uninstall key bindings previously bound by `tab-bar--define-keys'."
149 (when (eq (global-key-binding [(control tab)]) 'tab-next)
150 (global-unset-key [(control tab)]))
151 (when (eq (global-key-binding [(control shift tab)]) 'tab-previous)
152 (global-unset-key [(control shift tab)]))
153 (when (eq (global-key-binding [(control shift iso-lefttab)]) 'tab-previous)
154 (global-unset-key [(control shift iso-lefttab)])))
155
156(defun tab-bar--load-buttons ()
157 "Load the icons for the tab buttons."
158 (when (and tab-bar-new-button
159 (not (get-text-property 0 'display tab-bar-new-button)))
160 ;; This file is pre-loaded so only here we can use the right data-directory:
161 (add-text-properties 0 (length tab-bar-new-button)
162 `(display (image :type xpm
163 :file "tabs/new.xpm"
164 :margin ,tab-bar-button-margin
165 :ascent center))
166 tab-bar-new-button))
167
168 (when (and tab-bar-close-button
169 (not (get-text-property 0 'display tab-bar-close-button)))
170 ;; This file is pre-loaded so only here we can use the right data-directory:
171 (add-text-properties 0 (length tab-bar-close-button)
172 `(display (image :type xpm
173 :file "tabs/close.xpm"
174 :margin ,tab-bar-button-margin
175 :ascent center))
176 tab-bar-close-button)))
177
178(defun tab-bar--tab-bar-lines-for-frame (frame)
179 "Determine and return the value of `tab-bar-lines' for FRAME.
180Return 0 if `tab-bar-mode' is not enabled. Otherwise return
181either 1 or 0 depending on the value of the customizable variable
182`tab-bar-show', which see."
183 (cond
184 ((not tab-bar-mode) 0)
185 ((not tab-bar-show) 0)
186 ((eq tab-bar-show t) 1)
187 ((natnump tab-bar-show)
188 (if (> (length (funcall tab-bar-tabs-function frame)) tab-bar-show) 1 0))))
189
190(defun tab-bar--update-tab-bar-lines (&optional frames)
191 "Update the `tab-bar-lines' frame parameter in FRAMES.
192If the optional parameter FRAMES is omitted, update only
193the currently selected frame. If it is t, update all frames
194as well as the default for new frames. Otherwise FRAMES should be
195a list of frames to update."
196 (let ((frame-lst (cond ((null frames)
197 (list (selected-frame)))
198 ((eq frames t)
199 (frame-list))
200 (t frames))))
201 ;; Loop over all frames and update `tab-bar-lines'
202 (dolist (frame frame-lst)
203 (unless (frame-parameter frame 'tab-bar-lines-keep-state)
204 (set-frame-parameter frame 'tab-bar-lines
205 (tab-bar--tab-bar-lines-for-frame frame)))))
206 ;; Update `default-frame-alist'
207 (when (eq frames t)
208 (setq default-frame-alist
209 (cons (cons 'tab-bar-lines (if (and tab-bar-mode (eq tab-bar-show t)) 1 0))
210 (assq-delete-all 'tab-bar-lines default-frame-alist)))))
211
212(define-minor-mode tab-bar-mode
213 "Toggle the tab bar in all graphical frames (Tab Bar mode)."
214 :global t
215 ;; It's defined in C/cus-start, this stops the d-m-m macro defining it again.
216 :variable tab-bar-mode
217
218 ;; Recalculate `tab-bar-lines' for all frames
219 (tab-bar--update-tab-bar-lines t)
220
221 (when tab-bar-mode
222 (tab-bar--load-buttons))
223 (if tab-bar-mode
224 (tab-bar--define-keys)
225 (tab-bar--undefine-keys)))
226
227
228;;; Key bindings
229
230(defun tab-bar--key-to-number (key)
231 "Return the tab number represented by KEY.
232If KEY is a symbol 'tab-N', where N is a tab number, the value is N.
233If KEY is \\='current-tab, the value is nil.
234For any other value of KEY, the value is t."
235 (cond
236 ((null key) t)
237 ((eq key 'current-tab) nil)
238 ((let ((key-name (format "%S" key)))
239 (when (string-prefix-p "tab-" key-name)
240 (string-to-number (string-replace "tab-" "" key-name)))))
241 (t t)))
242
243(defvar tab-bar--dragging-in-progress)
244
245(defun tab-bar--event-to-item (posn)
246 "This function extracts extra info from the mouse event at position POSN.
247It returns a list of the form (KEY KEY-BINDING CLOSE-P), where:
248 KEY is a symbol representing a tab, such as \\='tab-1 or \\='current-tab;
249 KEY-BINDING is the binding of KEY;
250 CLOSE-P is non-nil if the mouse event was a click on the close button \"x\",
251 nil otherwise."
252 (setq tab-bar--dragging-in-progress nil)
253 (if (posn-window posn)
254 (let ((caption (car (posn-string posn))))
255 (when caption
256 (get-text-property 0 'menu-item caption)))
257 ;; Text-mode emulation of switching tabs on the tab bar.
258 ;; This code is used when you click the mouse in the tab bar
259 ;; on a console which has no window system but does have a mouse.
260 (let* ((x-position (car (posn-x-y posn)))
261 (keymap (lookup-key (cons 'keymap (nreverse (current-active-maps))) [tab-bar]))
262 (column 0))
263 (when x-position
264 (catch 'done
265 (map-keymap
266 (lambda (key binding)
267 (when (eq (car-safe binding) 'menu-item)
268 (when (> (+ column (length (nth 1 binding))) x-position)
269 (throw 'done (list key (nth 2 binding)
270 (get-text-property
271 (- x-position column)
272 'close-tab (nth 1 binding)))))
273 (setq column (+ column (length (nth 1 binding))))))
274 keymap))))))
275
276(defun tab-bar-mouse-down-1 (event)
277 "Select the tab at mouse click, or add a new tab on the tab bar.
278Whether this command adds a new tab or selects an existing tab
279depends on whether the click is on the \"+\" button or on an
280existing tab."
281 (interactive "e")
282 (let* ((item (tab-bar--event-to-item (event-start event)))
283 (tab-number (tab-bar--key-to-number (nth 0 item))))
284 (setq tab-bar--dragging-in-progress t)
285 ;; Don't close the tab when clicked on the close button. Also
286 ;; don't add new tab on down-mouse. Let `tab-bar-mouse-1' do this.
287 (unless (or (memq (car item) '(add-tab history-back history-forward))
288 (nth 2 item))
289 (if (functionp (nth 1 item))
290 (call-interactively (nth 1 item))
291 (unless (eq tab-number t)
292 (tab-bar-select-tab tab-number))))))
293
294(defun tab-bar-mouse-1 (event)
295 "Close the tab whose \"x\" close button you click.
296See also `tab-bar-mouse-close-tab', which closes the tab
297regardless of where you click on it. Also add a new tab."
298 (interactive "e")
299 (let* ((item (tab-bar--event-to-item (event-start event)))
300 (tab-number (tab-bar--key-to-number (nth 0 item))))
301 (cond
302 ((and (memq (car item) '(add-tab history-back history-forward))
303 (functionp (nth 1 item)))
304 (call-interactively (nth 1 item)))
305 ((and (nth 2 item) (not (eq tab-number t)))
306 (tab-bar-close-tab tab-number)))))
307
308(defun tab-bar-mouse-close-tab (event)
309 "Close the tab you click on.
310This is in contrast with `tab-bar-mouse-1' that closes a tab
311only when you click on its \"x\" close button."
312 (interactive "e")
313 (let* ((item (tab-bar--event-to-item (event-start event)))
314 (tab-number (tab-bar--key-to-number (nth 0 item))))
315 (unless (eq tab-number t)
316 (tab-bar-close-tab tab-number))))
317
318(defun tab-bar-mouse-context-menu (event)
319 "Pop up the context menu for the tab on which you click."
320 (interactive "e")
321 (let* ((item (tab-bar--event-to-item (event-start event)))
322 (tab-number (tab-bar--key-to-number (nth 0 item)))
323 (menu (make-sparse-keymap (propertize "Context Menu" 'hide t))))
324
325 (cond
326 ((eq tab-number t)
327 (define-key-after menu [new-tab]
328 '(menu-item "New tab" tab-bar-new-tab
329 :help "Create a new tab"))
330 (when tab-bar-closed-tabs
331 (define-key-after menu [undo-close]
332 '(menu-item "Reopen closed tab" tab-bar-undo-close-tab
333 :help "Undo closing the tab"))))
334
335 (t
336 (define-key-after menu [duplicate-tab]
337 `(menu-item "Duplicate" (lambda () (interactive)
338 (tab-bar-duplicate-tab
339 nil ,tab-number))
340 :help "Clone the tab"))
341 (define-key-after menu [detach-tab]
342 `(menu-item "Detach" (lambda () (interactive)
343 (tab-bar-detach-tab
344 ,tab-number))
345 :help "Move the tab to new frame"))
346 (define-key-after menu [close]
347 `(menu-item "Close" (lambda () (interactive)
348 (tab-bar-close-tab ,tab-number))
349 :help "Close the tab"))
350 (define-key-after menu [close-other]
351 `(menu-item "Close other tabs"
352 (lambda () (interactive)
353 (tab-bar-close-other-tabs ,tab-number))
354 :help "Close all other tabs"))))
355
356 (popup-menu menu event)))
357
358(defun tab-bar-mouse-move-tab (event)
359 "Move a tab to a different position on the tab bar.
360This command should be bound to a drag event. It moves the tab
361at the mouse-down event to the position at mouse-up event."
362 (interactive "e")
363 (setq tab-bar--dragging-in-progress nil)
364 (let ((from (tab-bar--key-to-number
365 (nth 0 (tab-bar--event-to-item
366 (event-start event)))))
367 (to (tab-bar--key-to-number
368 (nth 0 (tab-bar--event-to-item
369 (event-end event))))))
370 (unless (or (eq from to) (eq from t) (eq to t))
371 (tab-bar-move-tab-to
372 (if (null to) (1+ (tab-bar--current-tab-index)) to) from))))
373
374(defvar tab-bar-map
375 (let ((map (make-sparse-keymap)))
376 (define-key map [down-mouse-1] 'tab-bar-mouse-down-1)
377 (define-key map [drag-mouse-1] 'tab-bar-mouse-move-tab)
378 (define-key map [mouse-1] 'tab-bar-mouse-1)
379 (define-key map [down-mouse-2] 'tab-bar-mouse-close-tab)
380 (define-key map [mouse-2] 'ignore)
381 (define-key map [down-mouse-3] 'tab-bar-mouse-context-menu)
382
383 (define-key map [mouse-4] 'tab-previous)
384 (define-key map [mouse-5] 'tab-next)
385 (define-key map [wheel-up] 'tab-previous)
386 (define-key map [wheel-down] 'tab-next)
387 (define-key map [wheel-left] 'tab-previous)
388 (define-key map [wheel-right] 'tab-next)
389
390 (define-key map [S-mouse-4] 'tab-bar-move-tab-backward)
391 (define-key map [S-mouse-5] 'tab-bar-move-tab)
392 (define-key map [S-wheel-up] 'tab-bar-move-tab-backward)
393 (define-key map [S-wheel-down] 'tab-bar-move-tab)
394 (define-key map [S-wheel-left] 'tab-bar-move-tab-backward)
395 (define-key map [S-wheel-right] 'tab-bar-move-tab)
396
397 map)
398 "Keymap for the commands used on the tab bar.")
399
400(global-set-key [tab-bar]
401 `(menu-item ,(purecopy "tab bar") ignore
402 :filter tab-bar-make-keymap))
403
404(defun tab-bar-make-keymap (&optional _ignore)
405 "Generate an actual keymap from `tab-bar-map'.
406Its main job is to show tabs in the tab bar
407and to bind mouse events to the commands."
408 (tab-bar-make-keymap-1))
409
410
411(defun toggle-tab-bar-mode-from-frame (&optional arg)
412 "Toggle tab bar on or off, based on the status of the current frame.
413Used in the Show/Hide menu, to have the toggle reflect the current frame.
414See `tab-bar-mode' for more information."
415 (interactive (list (or current-prefix-arg 'toggle)))
416 (if (eq arg 'toggle)
417 (tab-bar-mode (if (> (frame-parameter nil 'tab-bar-lines) 0) 0 1))
418 (tab-bar-mode arg)))
419
420(defun toggle-frame-tab-bar (&optional frame)
421 "Toggle tab bar of the selected frame.
422When calling from Lisp, use the optional argument FRAME to toggle
423the tab bar on that frame.
424This is useful if you want to enable the tab bar individually
425on each new frame when the global `tab-bar-mode' is disabled,
426or if you want to disable the tab bar individually on each
427new frame when the global `tab-bar-mode' is enabled, by using
428
429 (add-hook 'after-make-frame-functions 'toggle-frame-tab-bar)"
430 (interactive)
431 (set-frame-parameter frame 'tab-bar-lines
432 (if (> (frame-parameter frame 'tab-bar-lines) 0) 0 1))
433 (set-frame-parameter frame 'tab-bar-lines-keep-state
434 (not (frame-parameter frame 'tab-bar-lines-keep-state))))
435
436
437(defcustom tab-bar-show t
438 "Defines when to show the tab bar.
439If t, the default, enable `tab-bar-mode' automatically upon using
440the commands that create new window configurations (e.g., `tab-new').
441If a non-negative integer, show the tab bar only if the number of
442the tabs exceeds the value of this variable. In particular,
443if the value is 1, hide the tab bar when it has only one tab, and
444show it again once more tabs are created. A value that is a
445non-negative integer also makes the tab bar appearance be different
446on different frames: the tab bar can be shown on some frames and
447hidden on others, depending on how many tab-bar tabs are on that
448frame, and whether that number is greater than the numerical value
449of this variable.
450If nil, always keep the tab bar hidden. In this case it's still
451possible to use persistent named window configurations by relying on
452keyboard commands `tab-new', `tab-close', `tab-next', `tab-switcher', etc.
453
454Setting this variable directly does not take effect; please customize
455it (see the info node `Easy Customization'), then it will automatically
456update the tab bar on all frames according to the new value.
457
458To enable or disable the tab bar individually on each frame,
459you can use the command `toggle-frame-tab-bar'."
460 :type '(choice (const :tag "Always" t)
461 (const :tag "When more than one tab" 1)
462 (const :tag "Never" nil))
463 :initialize 'custom-initialize-default
464 :set (lambda (sym val)
465 (set-default sym val)
466 (if val
467 (tab-bar-mode 1)
468 (tab-bar--update-tab-bar-lines t)))
469 :group 'tab-bar
470 :version "27.1")
471
472(defcustom tab-bar-new-tab-choice t
473 "Defines what to show in a new tab.
474If t, start a new tab with the current buffer, i.e. the buffer
475that was current before calling the command that adds a new tab
476(this is the same what `make-frame' does by default).
477If the value is a string, use it as a buffer name to switch to
478if such buffer exists, or switch to a buffer visiting the file or
479directory that the string specifies. If the value is a function,
480call it with no arguments and switch to the buffer that it returns.
481If nil, duplicate the contents of the tab that was active
482before calling the command that adds a new tab."
483 :type '(choice (const :tag "Current buffer" t)
484 (string :tag "Buffer" "*scratch*")
485 (directory :tag "Directory" :value "~/")
486 (file :tag "File" :value "~/.emacs")
487 (function :tag "Function")
488 (const :tag "Duplicate tab" nil))
489 :group 'tab-bar
490 :version "27.1")
491
492(defcustom tab-bar-new-tab-group t
493 "Defines what group to assign to a new tab.
494If nil, don't set a default group automatically.
495If t, inherit the group name from the previous tab.
496If the value is a string, use it as the group name of a new tab.
497If the value is a function, call it with no arguments
498to get the group name."
499 :type '(choice (const :tag "No automatic group" nil)
500 (const :tag "Inherit group from previous tab" t)
501 (string :tag "Fixed group name")
502 (function :tag "Function that returns group name"))
503 :group 'tab-bar
504 :version "28.1")
505
506(defcustom tab-bar-new-button-show t
507 "If non-nil, show the \"New tab\" button in the tab bar.
508When this is nil, you can create new tabs with \\[tab-new]."
509 :type 'boolean
510 :initialize 'custom-initialize-default
511 :set (lambda (sym val)
512 (set-default sym val)
513 (force-mode-line-update))
514 :group 'tab-bar
515 :version "27.1")
516(make-obsolete-variable 'tab-bar-new-button-show 'tab-bar-format "28.1")
517
518(defvar tab-bar-new-button " + "
519 "Button for creating a new tab.")
520
521(defcustom tab-bar-close-button-show t
522 "Defines where to show the close tab button.
523If t, show the close tab button on all tabs.
524If `selected', show it only on the selected tab.
525If `non-selected', show it only on non-selected tab.
526If nil, don't show it at all."
527 :type '(choice (const :tag "On all tabs" t)
528 (const :tag "On selected tab" selected)
529 (const :tag "On non-selected tabs" non-selected)
530 (const :tag "None" nil))
531 :initialize 'custom-initialize-default
532 :set (lambda (sym val)
533 (set-default sym val)
534 (force-mode-line-update))
535 :group 'tab-bar
536 :version "27.1")
537
538(defvar tab-bar-close-button
539 (propertize " x"
540 'close-tab t
541 :help "Click to close tab")
542 "Button for closing the clicked tab.")
543
544(defvar tab-bar-back-button " < "
545 "Button for going back in tab history.")
546
547(defvar tab-bar-forward-button " > "
548 "Button for going forward in tab history.")
549
550(defcustom tab-bar-tab-hints nil
551 "Show absolute numbers on tabs in the tab bar before the tab name.
552This helps to select the tab by its number using `tab-bar-select-tab'
553and `tab-bar-select-tab-modifiers'."
554 :type 'boolean
555 :initialize 'custom-initialize-default
556 :set (lambda (sym val)
557 (set-default sym val)
558 (force-mode-line-update))
559 :group 'tab-bar
560 :version "27.1")
561
562(defvar tab-bar-separator nil
563 "String that delimits tabs.")
564
565(defun tab-bar-separator ()
566 "Separator between tabs."
567 (or tab-bar-separator (if window-system " " "|")))
568
569
570(defcustom tab-bar-tab-name-function #'tab-bar-tab-name-current
571 "Function to get a tab name.
572Function gets no arguments.
573The choice is between displaying only the name of the current buffer
574in the tab name (default), or displaying the names of all buffers
575from all windows in the window configuration."
576 :type '(choice (const :tag "Selected window buffer"
577 tab-bar-tab-name-current)
578 (const :tag "Selected window buffer with window count"
579 tab-bar-tab-name-current-with-count)
580 (const :tag "Truncated buffer name"
581 tab-bar-tab-name-truncated)
582 (const :tag "All window buffers"
583 tab-bar-tab-name-all)
584 (function :tag "Function"))
585 :initialize 'custom-initialize-default
586 :set (lambda (sym val)
587 (set-default sym val)
588 (force-mode-line-update))
589 :group 'tab-bar
590 :version "27.1")
591
592(defun tab-bar-tab-name-current ()
593 "Generate tab name from the buffer of the selected window."
594 (buffer-name (window-buffer (minibuffer-selected-window))))
595
596(defun tab-bar-tab-name-current-with-count ()
597 "Generate tab name from the buffer of the selected window.
598Also add the number of windows in the window configuration."
599 (let ((count (length (window-list-1 nil 'nomini)))
600 (name (window-buffer (minibuffer-selected-window))))
601 (if (> count 1)
602 (format "%s (%d)" name count)
603 (format "%s" name))))
604
605(defun tab-bar-tab-name-all ()
606 "Generate tab name from buffers of all windows."
607 (mapconcat #'buffer-name
608 (delete-dups (mapcar #'window-buffer
609 (window-list-1 (frame-first-window)
610 'nomini)))
611 ", "))
612
613(defcustom tab-bar-tab-name-truncated-max 20
614 "Maximum length of the tab name from the current buffer.
615Effective when `tab-bar-tab-name-function' is customized
616to `tab-bar-tab-name-truncated'."
617 :type 'integer
618 :group 'tab-bar
619 :version "27.1")
620
621(defvar tab-bar-tab-name-ellipsis t)
622
623(defun tab-bar-tab-name-truncated ()
624 "Generate tab name from the buffer of the selected window.
625Truncate it to the length specified by `tab-bar-tab-name-truncated-max'.
626Append ellipsis `tab-bar-tab-name-ellipsis' in this case."
627 (let ((tab-name (buffer-name (window-buffer (minibuffer-selected-window)))))
628 (if (< (length tab-name) tab-bar-tab-name-truncated-max)
629 tab-name
630 (propertize (truncate-string-to-width
631 tab-name tab-bar-tab-name-truncated-max nil nil
632 tab-bar-tab-name-ellipsis)
633 'help-echo tab-name))))
634
635
636(defvar tab-bar-tabs-function #'tab-bar-tabs
637 "Function to get a list of tabs to display in the tab bar.
638This function should have one optional argument FRAME,
639defaulting to the selected frame when nil.
640It should return a list of alists with parameters
641that include at least the element (name . TAB-NAME).
642For example, \\='((tab (name . \"Tab 1\")) (current-tab (name . \"Tab 2\")))
643By default, use function `tab-bar-tabs'.")
644
645(defun tab-bar-tabs (&optional frame)
646 "Return a list of tabs belonging to the FRAME.
647Ensure the frame parameter `tabs' is pre-populated.
648Update the current tab name when it exists.
649Return its existing value or a new value."
650 (let ((tabs (frame-parameter frame 'tabs)))
651 (if tabs
652 (let* ((current-tab (tab-bar--current-tab-find tabs))
653 (current-tab-name (assq 'name current-tab))
654 (current-tab-explicit-name (assq 'explicit-name current-tab)))
655 (when (and current-tab-name
656 current-tab-explicit-name
657 (not (cdr current-tab-explicit-name)))
658 (setf (cdr current-tab-name)
659 (funcall tab-bar-tab-name-function))))
660 ;; Create default tabs
661 (setq tabs (list (tab-bar--current-tab-make)))
662 (tab-bar-tabs-set tabs frame))
663 tabs))
664
665(defun tab-bar-tabs-set (tabs &optional frame)
666 "Set a list of TABS on the FRAME."
667 (set-frame-parameter frame 'tabs tabs))
668
669
670(defcustom tab-bar-tab-face-function #'tab-bar-tab-face-default
671 "Function to define a tab face.
672Function gets one argument: a tab."
673 :type 'function
674 :group 'tab-bar
675 :version "28.1")
676
677(defun tab-bar-tab-face-default (tab)
678 (if (eq (car tab) 'current-tab) 'tab-bar-tab 'tab-bar-tab-inactive))
679
680(defcustom tab-bar-tab-name-format-function #'tab-bar-tab-name-format-default
681 "Function to format a tab name.
682Function gets two arguments, the tab and its number, and should return
683the formatted tab name to display in the tab bar."
684 :type 'function
685 :initialize 'custom-initialize-default
686 :set (lambda (sym val)
687 (set-default sym val)
688 (force-mode-line-update))
689 :group 'tab-bar
690 :version "28.1")
691
692(defun tab-bar-tab-name-format-default (tab i)
693 (let ((current-p (eq (car tab) 'current-tab)))
694 (propertize
695 (concat (if tab-bar-tab-hints (format "%d " i) "")
696 (alist-get 'name tab)
697 (or (and tab-bar-close-button-show
698 (not (eq tab-bar-close-button-show
699 (if current-p 'non-selected 'selected)))
700 tab-bar-close-button)
701 ""))
702 'face (funcall tab-bar-tab-face-function tab))))
703
704(defcustom tab-bar-format '(tab-bar-format-history
705 tab-bar-format-tabs
706 tab-bar-separator
707 tab-bar-format-add-tab)
708 "Template for displaying tab bar items.
709Every item in the list is a function that returns
710a string, or a list of menu-item elements, or nil.
711Adding a function to the list causes the tab bar to show
712that string, or display a tab button which, when clicked,
713will invoke the command that is the binding of the menu item.
714The menu-item binding of nil will produce a tab clicking
715on which will select that tab. The menu-item's title is
716displayed as the label of the tab.
717If a function returns nil, it doesn't directly affect the
718tab bar appearance, but can do that by some side-effect.
719If the list ends with `tab-bar-format-align-right' and
720`tab-bar-format-global', then after enabling `display-time-mode'
721(or any other mode that uses `global-mode-string'),
722it will display time aligned to the right on the tab bar instead
723of the mode line. Replacing `tab-bar-format-tabs' with
724`tab-bar-format-tabs-groups' will group tabs on the tab bar."
725 :type 'hook
726 :options '(tab-bar-format-menu-bar
727 tab-bar-format-history
728 tab-bar-format-tabs
729 tab-bar-format-tabs-groups
730 tab-bar-separator
731 tab-bar-format-add-tab
732 tab-bar-format-align-right
733 tab-bar-format-global)
734 :initialize 'custom-initialize-default
735 :set (lambda (sym val)
736 (set-default sym val)
737 (force-mode-line-update))
738 :group 'tab-bar
739 :version "28.1")
740
741(defun tab-bar-menu-bar (event)
742 "Pop up the same menu as displayed by the menu bar.
743Used by `tab-bar-format-menu-bar'."
744 (interactive "e")
745 (let ((menu (make-sparse-keymap (propertize "Menu Bar" 'hide t))))
746 (run-hooks 'activate-menubar-hook 'menu-bar-update-hook)
747 (map-keymap (lambda (key binding)
748 (when (consp binding)
749 (define-key-after menu (vector key)
750 (copy-sequence binding))))
751 (menu-bar-keymap))
752 (popup-menu menu event)))
753
754(defun tab-bar-format-menu-bar ()
755 "Produce the Menu button for the tab bar that shows the menu bar."
756 `((menu-bar menu-item (propertize "Menu" 'face 'tab-bar-tab-inactive)
757 tab-bar-menu-bar :help "Menu Bar")))
758
759(defun tab-bar-format-history ()
760 "Produce back and forward buttons for the tab bar.
761These buttons will be shown when `tab-bar-history-mode' is enabled.
762You can hide these buttons by customizing `tab-bar-format' and removing
763`tab-bar-format-history' from it."
764 (when tab-bar-history-mode
765 `((sep-history-back menu-item ,(tab-bar-separator) ignore)
766 (history-back
767 menu-item ,tab-bar-back-button tab-bar-history-back
768 :help "Click to go back in tab history")
769 (sep-history-forward menu-item ,(tab-bar-separator) ignore)
770 (history-forward
771 menu-item ,tab-bar-forward-button tab-bar-history-forward
772 :help "Click to go forward in tab history"))))
773
774(defun tab-bar--format-tab (tab i)
775 "Format TAB using its index I and return the result as a keymap."
776 (append
777 `((,(intern (format "sep-%i" i)) menu-item ,(tab-bar-separator) ignore))
778 (cond
779 ((eq (car tab) 'current-tab)
780 `((current-tab
781 menu-item
782 ,(funcall tab-bar-tab-name-format-function tab i)
783 ignore
784 :help "Current tab")))
785 (t
786 `((,(intern (format "tab-%i" i))
787 menu-item
788 ,(funcall tab-bar-tab-name-format-function tab i)
789 ,(alist-get 'binding tab)
790 :help "Click to visit tab"))))
791 (when (alist-get 'close-binding tab)
792 `((,(if (eq (car tab) 'current-tab) 'C-current-tab (intern (format "C-tab-%i" i)))
793 menu-item ""
794 ,(alist-get 'close-binding tab))))))
795
796(defun tab-bar-format-tabs ()
797 "Produce all the tabs for the tab bar."
798 (let ((i 0))
799 (mapcan
800 (lambda (tab)
801 (setq i (1+ i))
802 (tab-bar--format-tab tab i))
803 (funcall tab-bar-tabs-function))))
804
805(defcustom tab-bar-tab-group-function #'tab-bar-tab-group-default
806 "Function to get a tab group name.
807Function gets one argument: a tab."
808 :type 'function
809 :initialize 'custom-initialize-default
810 :set (lambda (sym val)
811 (set-default sym val)
812 (force-mode-line-update))
813 :group 'tab-bar
814 :version "28.1")
815
816(defun tab-bar-tab-group-default (tab)
817 (alist-get 'group tab))
818
819(defcustom tab-bar-tab-group-format-function #'tab-bar-tab-group-format-default
820 "Function to format a tab group name.
821Function gets two arguments, a tab with a group name and its number,
822and should return the formatted tab group name to display in the tab bar."
823 :type 'function
824 :initialize 'custom-initialize-default
825 :set (lambda (sym val)
826 (set-default sym val)
827 (force-mode-line-update))
828 :group 'tab-bar
829 :version "28.1")
830
831(defun tab-bar-tab-group-format-default (tab i)
832 (propertize
833 (concat (if tab-bar-tab-hints (format "%d " i) "")
834 (funcall tab-bar-tab-group-function tab))
835 'face 'tab-bar-tab-group-inactive))
836
837(defcustom tab-bar-tab-group-face-function #'tab-bar-tab-group-face-default
838 "Function to define a tab group face.
839Function gets one argument: a tab."
840 :type 'function
841 :group 'tab-bar
842 :version "28.1")
843
844(defun tab-bar-tab-group-face-default (tab)
845 (if (not (or (eq (car tab) 'current-tab)
846 (funcall tab-bar-tab-group-function tab)))
847 'tab-bar-tab-ungrouped
848 (tab-bar-tab-face-default tab)))
849
850(defun tab-bar--format-tab-group (tab i &optional current-p)
851 "Format TAB as a tab that represents a group of tabs.
852The argument I is the tab index, and CURRENT-P is non-nil
853when the tab is current. Return the result as a keymap."
854 (append
855 `((,(intern (format "sep-%i" i)) menu-item ,(tab-bar-separator) ignore))
856 `((,(intern (format "group-%i" i))
857 menu-item
858 ,(if current-p
859 (propertize (funcall tab-bar-tab-group-function tab)
860 'face 'tab-bar-tab-group-current)
861 (funcall tab-bar-tab-group-format-function tab i))
862 ,(if current-p 'ignore
863 (or
864 (alist-get 'binding tab)
865 `(lambda ()
866 (interactive)
867 (tab-bar-select-tab ,i))))
868 :help "Click to visit group"))))
869
870(defun tab-bar-format-tabs-groups ()
871 "Produce tabs for the tab bar grouped according to their groups."
872 (let* ((tabs (funcall tab-bar-tabs-function))
873 (current-group (funcall tab-bar-tab-group-function
874 (tab-bar--current-tab-find tabs)))
875 (previous-group nil)
876 (i 0))
877 (mapcan
878 (lambda (tab)
879 (let ((tab-group (funcall tab-bar-tab-group-function tab)))
880 (setq i (1+ i))
881 (prog1 (cond
882 ;; Show current group tabs and ungrouped tabs
883 ((or (equal tab-group current-group) (not tab-group))
884 (append
885 ;; Prepend current group name before first tab
886 (when (and (not (equal previous-group tab-group)) tab-group)
887 (tab-bar--format-tab-group tab i t))
888 ;; Override default tab faces to use group faces
889 (let ((tab-bar-tab-face-function tab-bar-tab-group-face-function))
890 (tab-bar--format-tab tab i))))
891 ;; Show first tab of other groups with a group name
892 ((not (equal previous-group tab-group))
893 (tab-bar--format-tab-group tab i))
894 ;; Hide other group tabs
895 (t nil))
896 (setq previous-group tab-group))))
897 tabs)))
898
899(defun tab-bar-format-add-tab ()
900 "Button to add a new tab."
901 (when (and tab-bar-new-button-show tab-bar-new-button)
902 `((add-tab menu-item ,tab-bar-new-button tab-bar-new-tab
903 :help "New tab"))))
904
905(defun tab-bar-format-align-right ()
906 "Align the rest of tab bar items to the right."
907 (let* ((rest (cdr (memq 'tab-bar-format-align-right tab-bar-format)))
908 (rest (tab-bar-format-list rest))
909 (rest (mapconcat (lambda (item) (nth 2 item)) rest ""))
910 (hpos (length rest))
911 (str (propertize " " 'display `(space :align-to (- right ,hpos)))))
912 `((align-right menu-item ,str ignore))))
913
914(defun tab-bar-format-global ()
915 "Produce display of `global-mode-string' in the tab bar.
916When `tab-bar-format-global' is added to `tab-bar-format'
917(possibly appended after `tab-bar-format-align-right'),
918then modes that display information on the mode line
919using `global-mode-string' will display the same text
920on the tab bar instead."
921 `((global menu-item ,(string-trim-right (format-mode-line global-mode-string)) ignore)))
922
923(defun tab-bar-format-list (format-list)
924 (let ((i 0))
925 (apply #'append
926 (mapcar
927 (lambda (format)
928 (setq i (1+ i))
929 (cond
930 ((functionp format)
931 (let ((ret (funcall format)))
932 (when (stringp ret)
933 (setq ret `((,(intern (format "str-%i" i))
934 menu-item ,ret ignore))))
935 ret))))
936 format-list))))
937
938(defun tab-bar-make-keymap-1 ()
939 "Generate an actual keymap from `tab-bar-map', without caching."
940 (append tab-bar-map (tab-bar-format-list tab-bar-format)))
941
942
943;; Some window-configuration parameters don't need to be persistent.
944;; Don't save to the desktop file such tab parameters that are saved
945;; as "Unprintable entity" so can't be used after restoring the desktop.
946;; Actually tab-bar-select-tab already can handle unprintable entities,
947;; but it's better not to waste the desktop file with useless data.
948(defun frameset-filter-tabs (current _filtered _parameters saving)
949 (if saving
950 (mapcar (lambda (current)
951 (if (consp current)
952 (seq-reduce (lambda (current param)
953 (assq-delete-all param current))
954 '(wc wc-point wc-bl wc-bbl
955 wc-history-back wc-history-forward)
956 (copy-sequence current))
957 current))
958 current)
959 current))
960
961(push '(tabs . frameset-filter-tabs) frameset-filter-alist)
962
963(defun tab-bar--tab (&optional frame)
964 "Make a new tab data structure that can be added to tabs on the FRAME."
965 (let* ((tab (tab-bar--current-tab-find nil frame))
966 (tab-explicit-name (alist-get 'explicit-name tab))
967 (tab-group (alist-get 'group tab))
968 (bl (seq-filter #'buffer-live-p (frame-parameter
969 frame 'buffer-list)))
970 (bbl (seq-filter #'buffer-live-p (frame-parameter
971 frame 'buried-buffer-list))))
972 `(tab
973 (name . ,(if tab-explicit-name
974 (alist-get 'name tab)
975 (funcall tab-bar-tab-name-function)))
976 (explicit-name . ,tab-explicit-name)
977 ,@(if tab-group `((group . ,tab-group)))
978 (time . ,(float-time))
979 (ws . ,(window-state-get
980 (frame-root-window (or frame (selected-frame))) 'writable))
981 (wc . ,(current-window-configuration))
982 (wc-point . ,(point-marker))
983 (wc-bl . ,bl)
984 (wc-bbl . ,bbl)
985 ,@(when tab-bar-history-mode
986 `((wc-history-back . ,(gethash (or frame (selected-frame))
987 tab-bar-history-back))
988 (wc-history-forward . ,(gethash (or frame (selected-frame))
989 tab-bar-history-forward))))
990 ;; Copy other possible parameters
991 ,@(mapcan (lambda (param)
992 (unless (memq (car param)
993 '(name explicit-name group time
994 ws wc wc-point wc-bl wc-bbl
995 wc-history-back wc-history-forward))
996 (list param)))
997 (cdr tab)))))
998
999(defun tab-bar--current-tab (&optional tab frame)
1000 "Make the current tab data structure from TAB on FRAME."
1001 (tab-bar--current-tab-make (or tab (tab-bar--current-tab-find nil frame))))
1002
1003(defun tab-bar--current-tab-make (&optional tab)
1004 "Make the current tab data structure from TAB.
1005TAB here is an argument meaning \"use tab as template\",
1006i.e. the tab is created using data from TAB. This is
1007necessary when switching tabs, otherwise the destination tab
1008inherits the current tab's `explicit-name' parameter."
1009 (let* ((tab-explicit-name (alist-get 'explicit-name tab))
1010 (tab-group (if tab
1011 (alist-get 'group tab)
1012 (pcase tab-bar-new-tab-group
1013 ((pred stringp) tab-bar-new-tab-group)
1014 ((pred functionp) (funcall tab-bar-new-tab-group))))))
1015 `(current-tab
1016 (name . ,(if tab-explicit-name
1017 (alist-get 'name tab)
1018 (funcall tab-bar-tab-name-function)))
1019 (explicit-name . ,tab-explicit-name)
1020 ,@(if tab-group `((group . ,tab-group)))
1021 ;; Copy other possible parameters
1022 ,@(mapcan (lambda (param)
1023 (unless (memq (car param)
1024 '(name explicit-name group time
1025 ws wc wc-point wc-bl wc-bbl
1026 wc-history-back wc-history-forward))
1027 (list param)))
1028 (cdr tab)))))
1029
1030(defun tab-bar--current-tab-find (&optional tabs frame)
1031 ;; Find the current tab as a pointer to its data structure.
1032 (assq 'current-tab (or tabs (funcall tab-bar-tabs-function frame))))
1033
1034(defun tab-bar--current-tab-index (&optional tabs frame)
1035 ;; Return the index of the current tab.
1036 (seq-position (or tabs (funcall tab-bar-tabs-function frame))
1037 'current-tab (lambda (a b) (eq (car a) b))))
1038
1039(defun tab-bar--tab-index (tab &optional tabs frame)
1040 ;; Return the index of TAB.
1041 (seq-position (or tabs (funcall tab-bar-tabs-function frame))
1042 tab #'eq))
1043
1044(defun tab-bar--tab-index-by-name (name &optional tabs frame)
1045 ;; Return the index of TAB by the its NAME.
1046 (seq-position (or tabs (funcall tab-bar-tabs-function frame))
1047 name (lambda (a b) (equal (alist-get 'name a) b))))
1048
1049(defun tab-bar--tab-index-recent (nth &optional tabs frame)
1050 ;; Return the index of NTH recent tab.
1051 (let* ((tabs (or tabs (funcall tab-bar-tabs-function frame)))
1052 (sorted-tabs (tab-bar--tabs-recent tabs frame))
1053 (tab (nth (1- nth) sorted-tabs)))
1054 (tab-bar--tab-index tab tabs)))
1055
1056(defun tab-bar--tabs-recent (&optional tabs frame)
1057 ;; Return the list of tabs sorted by recency.
1058 (let* ((tabs (or tabs (funcall tab-bar-tabs-function frame))))
1059 (seq-sort-by (lambda (tab) (alist-get 'time tab)) #'>
1060 (seq-remove (lambda (tab)
1061 (eq (car tab) 'current-tab))
1062 tabs))))
1063
1064
1065(defun tab-bar-select-tab (&optional tab-number)
1066 "Switch to the tab by its absolute position TAB-NUMBER in the tab bar.
1067When this command is bound to a numeric key (with a key prefix or modifier key
1068using `tab-bar-select-tab-modifiers'), calling it without an argument
1069will translate its bound numeric key to the numeric argument.
1070Also the prefix argument TAB-NUMBER can be used to override
1071the numeric key, so it takes precedence over the bound digit key.
1072For example, `<MODIFIER>-2' will select the second tab, but `C-u 15
1073<MODIFIER>-2' will select the 15th tab. TAB-NUMBER counts from 1.
1074Negative TAB-NUMBER counts tabs from the end of the tab bar."
1075 (interactive "P")
1076 (unless (integerp tab-number)
1077 (let ((key (event-basic-type last-command-event)))
1078 (setq tab-number (if (and (characterp key) (>= key ?1) (<= key ?9))
1079 (- key ?0)
1080 0))))
1081
1082 (let* ((tabs (funcall tab-bar-tabs-function))
1083 (from-index (tab-bar--current-tab-index tabs))
1084 (to-number (cond ((< tab-number 0) (+ (length tabs) (1+ tab-number)))
1085 ((zerop tab-number) (1+ from-index))
1086 (t tab-number)))
1087 (to-index (1- (max 1 (min to-number (length tabs))))))
1088
1089 (unless (eq from-index to-index)
1090 (let* ((from-tab (tab-bar--tab))
1091 (to-tab (nth to-index tabs))
1092 (wc (alist-get 'wc to-tab))
1093 (ws (alist-get 'ws to-tab)))
1094
1095 ;; During the same session, use window-configuration to switch
1096 ;; tabs, because window-configurations are more reliable
1097 ;; (they keep references to live buffers) than window-states.
1098 ;; But after restoring tabs from a previously saved session,
1099 ;; its value of window-configuration is unreadable,
1100 ;; so restore its saved window-state.
1101 (cond
1102 ((and (window-configuration-p wc)
1103 ;; Check for such cases as cloning a frame with tabs.
1104 ;; When tabs were cloned to another frame, then fall back
1105 ;; to using `window-state-put' below.
1106 (eq (window-configuration-frame wc) (selected-frame)))
1107 (let ((wc-point (alist-get 'wc-point to-tab))
1108 (wc-bl (seq-filter #'buffer-live-p (alist-get 'wc-bl to-tab)))
1109 (wc-bbl (seq-filter #'buffer-live-p (alist-get 'wc-bbl to-tab)))
1110 (wc-history-back (alist-get 'wc-history-back to-tab))
1111 (wc-history-forward (alist-get 'wc-history-forward to-tab)))
1112
1113 (set-window-configuration wc)
1114
1115 ;; set-window-configuration does not restore the value of
1116 ;; point in the current buffer, so restore it separately.
1117 (when (and (markerp wc-point)
1118 (marker-buffer wc-point)
1119 ;; FIXME: After dired-revert, marker relocates to 1.
1120 ;; window-configuration restores point to global point
1121 ;; in this dired buffer, not to its window point,
1122 ;; but this is slightly better than 1.
1123 ;; Maybe better to save dired-filename in each window?
1124 (not (eq 1 (marker-position wc-point))))
1125 (goto-char wc-point))
1126
1127 (when wc-bl (set-frame-parameter nil 'buffer-list wc-bl))
1128 (when wc-bbl (set-frame-parameter nil 'buried-buffer-list wc-bbl))
1129
1130 (when tab-bar-history-mode
1131 (puthash (selected-frame)
1132 (and (window-configuration-p (alist-get 'wc (car wc-history-back)))
1133 wc-history-back)
1134 tab-bar-history-back)
1135 (puthash (selected-frame)
1136 (and (window-configuration-p (alist-get 'wc (car wc-history-forward)))
1137 wc-history-forward)
1138 tab-bar-history-forward))))
1139
1140 (ws
1141 (window-state-put ws nil 'safe)))
1142
1143 (when tab-bar-history-mode
1144 (setq tab-bar-history-omit t))
1145
1146 (when from-index
1147 (setf (nth from-index tabs) from-tab))
1148 (setf (nth to-index tabs) (tab-bar--current-tab-make (nth to-index tabs)))
1149
1150 (unless tab-bar-mode
1151 (message "Selected tab '%s'" (alist-get 'name to-tab))))
1152
1153 (force-mode-line-update))))
1154
1155(defun tab-bar-switch-to-next-tab (&optional arg)
1156 "Switch to ARGth next tab.
1157Interactively, ARG is the prefix numeric argument and defaults to 1."
1158 (interactive "p")
1159 (unless (integerp arg)
1160 (setq arg 1))
1161 (let* ((tabs (funcall tab-bar-tabs-function))
1162 (from-index (or (tab-bar--current-tab-index tabs) 0))
1163 (to-index (mod (+ from-index arg) (length tabs))))
1164 (tab-bar-select-tab (1+ to-index))))
1165
1166(defun tab-bar-switch-to-prev-tab (&optional arg)
1167 "Switch to ARGth previous tab.
1168Interactively, ARG is the prefix numeric argument and defaults to 1."
1169 (interactive "p")
1170 (unless (integerp arg)
1171 (setq arg 1))
1172 (tab-bar-switch-to-next-tab (- arg)))
1173
1174(defun tab-bar-switch-to-last-tab (&optional arg)
1175 "Switch to the last tab or ARGth tab from the end of the tab bar.
1176Interactively, ARG is the prefix numeric argument; it defaults to 1,
1177which means the last tab on the tab bar. For example, `C-u 2
1178<MODIFIER>-9' selects the tab before the last tab."
1179 (interactive "p")
1180 (tab-bar-select-tab (- (length (funcall tab-bar-tabs-function))
1181 (1- (abs (or arg 1))))))
1182
1183(defun tab-bar-switch-to-recent-tab (&optional arg)
1184 "Switch to ARGth most recently visited tab.
1185Interactively, ARG is the prefix numeric argument and defaults to 1."
1186 (interactive "p")
1187 (unless (integerp arg)
1188 (setq arg 1))
1189 (let ((tab-index (tab-bar--tab-index-recent arg)))
1190 (if tab-index
1191 (tab-bar-select-tab (1+ tab-index))
1192 (message "No more recent tabs"))))
1193
1194(defun tab-bar-switch-to-tab (name)
1195 "Switch to the tab by NAME.
1196Default values are tab names sorted by recency, so you can use \
1197\\<minibuffer-local-map>\\[next-history-element]
1198to get the name of the most recently visited tab, the second
1199most recent, and so on.
1200When the tab with that NAME doesn't exist, create a new tab
1201and rename it to NAME."
1202 (interactive
1203 (let* ((recent-tabs (mapcar (lambda (tab)
1204 (alist-get 'name tab))
1205 (tab-bar--tabs-recent))))
1206 (list (completing-read (format-prompt "Switch to tab by name"
1207 (car recent-tabs))
1208 recent-tabs nil nil nil nil recent-tabs))))
1209 (let ((tab-index (tab-bar--tab-index-by-name name)))
1210 (if tab-index
1211 (tab-bar-select-tab (1+ tab-index))
1212 (tab-bar-new-tab)
1213 (tab-bar-rename-tab name))))
1214
1215(defalias 'tab-bar-select-tab-by-name 'tab-bar-switch-to-tab)
1216
1217
1218(defun tab-bar-move-tab-to (to-number &optional from-number)
1219 "Move tab from FROM-NUMBER position to new position at TO-NUMBER.
1220FROM-NUMBER defaults to the current tab number.
1221FROM-NUMBER and TO-NUMBER count from 1.
1222Negative TO-NUMBER counts tabs from the end of the tab bar.
1223Argument addressing is absolute in contrast to `tab-bar-move-tab'
1224where argument addressing is relative."
1225 (interactive "P")
1226 (let* ((tabs (funcall tab-bar-tabs-function))
1227 (from-number (or from-number (1+ (tab-bar--current-tab-index tabs))))
1228 (from-tab (nth (1- from-number) tabs))
1229 (to-number (if to-number (prefix-numeric-value to-number) 1))
1230 (to-number (if (< to-number 0) (+ (length tabs) (1+ to-number)) to-number))
1231 (to-index (max 0 (min (1- to-number) (1- (length tabs))))))
1232 (setq tabs (delq from-tab tabs))
1233 (cl-pushnew from-tab (nthcdr to-index tabs))
1234 (tab-bar-tabs-set tabs)
1235 (force-mode-line-update)))
1236
1237(defun tab-bar-move-tab (&optional arg)
1238 "Move the current tab ARG positions to the right.
1239Interactively, ARG is the prefix numeric argument and defaults to 1.
1240If ARG is negative, move the current tab ARG positions to the left.
1241Argument addressing is relative in contrast to `tab-bar-move-tab-to',
1242where argument addressing is absolute."
1243 (interactive "p")
1244 (let* ((tabs (funcall tab-bar-tabs-function))
1245 (from-index (or (tab-bar--current-tab-index tabs) 0))
1246 (to-index (mod (+ from-index arg) (length tabs))))
1247 (tab-bar-move-tab-to (1+ to-index) (1+ from-index))))
1248
1249(defun tab-bar-move-tab-backward (&optional arg)
1250 "Move the current tab ARG positions to the left.
1251Interactively, ARG is the prefix numeric argument and defaults to 1.
1252Like `tab-bar-move-tab', but moves in the opposite direction."
1253 (interactive "p")
1254 (tab-bar-move-tab (- (or arg 1))))
1255
1256(defun tab-bar-move-tab-to-frame (arg &optional from-frame from-number to-frame to-number)
1257 "Move tab from FROM-NUMBER position to new position at TO-NUMBER.
1258FROM-NUMBER defaults to the current tab number.
1259FROM-NUMBER and TO-NUMBER count from 1.
1260FROM-FRAME specifies the source frame and defaults to the selected frame.
1261TO-FRAME specifies the target frame and defaults the next frame.
1262Interactively, ARG selects the ARGth next frame on the same terminal,
1263to which to move the tab; ARG defaults to 1."
1264 (interactive "P")
1265 (unless from-frame
1266 (setq from-frame (selected-frame)))
1267 (unless to-frame
1268 (dotimes (_ (prefix-numeric-value arg))
1269 (setq to-frame (next-frame to-frame))))
1270 (unless (eq from-frame to-frame)
1271 (let* ((from-tabs (funcall tab-bar-tabs-function from-frame))
1272 (from-number (or from-number (1+ (tab-bar--current-tab-index from-tabs))))
1273 (from-tab (nth (1- from-number) from-tabs))
1274 (to-tabs (funcall tab-bar-tabs-function to-frame))
1275 (to-index (max 0 (min (1- (or to-number 1)) (1- (length to-tabs))))))
1276 (cl-pushnew (assq-delete-all
1277 'wc (if (eq (car from-tab) 'current-tab)
1278 (tab-bar--tab from-frame)
1279 from-tab))
1280 (nthcdr to-index to-tabs))
1281 (with-selected-frame from-frame
1282 (let ((inhibit-message t) ; avoid message about deleted tab
1283 (tab-bar-close-last-tab-choice 'delete-frame)
1284 tab-bar-closed-tabs)
1285 (tab-bar-close-tab from-number)))
1286 (tab-bar-tabs-set to-tabs to-frame)
1287 (force-mode-line-update t))))
1288
1289(defun tab-bar-detach-tab (&optional from-number)
1290 "Move tab number FROM-NUMBER to a new frame.
1291FROM-NUMBER defaults to the current tab (which happens interactively)."
1292 (interactive (list (1+ (tab-bar--current-tab-index))))
1293 (let* ((tabs (funcall tab-bar-tabs-function))
1294 (tab-index (1- (or from-number (1+ (tab-bar--current-tab-index tabs)))))
1295 (tab-name (alist-get 'name (nth tab-index tabs)))
1296 ;; On some window managers, `make-frame' selects the new frame,
1297 ;; so previously selected frame is saved to `from-frame'.
1298 (from-frame (selected-frame))
1299 (new-frame (make-frame `((name . ,tab-name)))))
1300 (tab-bar-move-tab-to-frame nil from-frame from-number new-frame nil)
1301 (with-selected-frame new-frame
1302 (tab-bar-close-tab))))
1303
1304(defun tab-bar-move-window-to-tab ()
1305 "Move the selected window to a new tab.
1306This command removes the selected window from the configuration stored
1307on the current tab, and makes a new tab with that window in its
1308configuration."
1309 (interactive)
1310 (let ((tab-bar-new-tab-choice 'window))
1311 (tab-bar-new-tab))
1312 (tab-bar-switch-to-recent-tab)
1313 (delete-window)
1314 (tab-bar-switch-to-recent-tab))
1315
1316
1317(defcustom tab-bar-new-tab-to 'right
1318 "Where to create a new tab.
1319If `leftmost', create as the first tab.
1320If `left', create to the left of the current tab.
1321If `right', create to the right of the current tab.
1322If `rightmost', create as the last tab.
1323If the value is a function, it should return a number as a position
1324on the tab bar specifying where to add a new tab."
1325 :type '(choice (const :tag "Add as First" leftmost)
1326 (const :tag "Add to Left" left)
1327 (const :tag "Add to Right" right)
1328 (const :tag "Add as Last" rightmost)
1329 (function :tag "Function"))
1330 :group 'tab-bar
1331 :version "27.1")
1332
1333(defcustom tab-bar-tab-post-open-functions nil
1334 "List of functions to call after creating a new tab.
1335The current tab is supplied as an argument. Any modifications made
1336to the tab argument will be applied after all functions are called."
1337 :type '(repeat function)
1338 :group 'tab-bar
1339 :version "27.1")
1340
1341(defun tab-bar-new-tab-to (&optional tab-number)
1342 "Add a new tab at the absolute position TAB-NUMBER.
1343TAB-NUMBER counts from 1. If no TAB-NUMBER is specified, then add
1344a new tab at the position specified by `tab-bar-new-tab-to'.
1345Negative TAB-NUMBER counts tabs from the end of the tab bar,
1346and -1 means the new tab will become the last one.
1347Argument addressing is absolute in contrast to `tab-bar-new-tab',
1348where argument addressing is relative.
1349After the tab is created, the hooks in
1350`tab-bar-tab-post-open-functions' are run."
1351 (interactive "P")
1352 (let* ((tabs (funcall tab-bar-tabs-function))
1353 (from-index (tab-bar--current-tab-index tabs))
1354 (from-tab (tab-bar--tab)))
1355
1356 (when tab-bar-new-tab-choice
1357 ;; Handle the case when it's called in the active minibuffer.
1358 (when (minibuffer-selected-window)
1359 (select-window (minibuffer-selected-window)))
1360 (let ((ignore-window-parameters t))
1361 (delete-other-windows))
1362 (unless (eq tab-bar-new-tab-choice 'window)
1363 ;; Create a new window to get rid of old window parameters
1364 ;; (e.g. prev/next buffers) of old window.
1365 (split-window) (delete-window))
1366 (let ((buffer
1367 (if (functionp tab-bar-new-tab-choice)
1368 (funcall tab-bar-new-tab-choice)
1369 (if (stringp tab-bar-new-tab-choice)
1370 (or (get-buffer tab-bar-new-tab-choice)
1371 (find-file-noselect tab-bar-new-tab-choice))))))
1372 (when (buffer-live-p buffer)
1373 (switch-to-buffer buffer))))
1374
1375 (when from-index
1376 (setf (nth from-index tabs) from-tab))
1377
1378 (let* ((to-tab (tab-bar--current-tab-make
1379 (when (eq tab-bar-new-tab-group t)
1380 `((group . ,(alist-get 'group from-tab))))))
1381 (to-number (and tab-number (prefix-numeric-value tab-number)))
1382 (to-index (or (if to-number
1383 (if (< to-number 0)
1384 (+ (length tabs) (1+ to-number))
1385 (1- to-number)))
1386 (pcase tab-bar-new-tab-to
1387 ('leftmost 0)
1388 ('rightmost (length tabs))
1389 ('left (or from-index 1))
1390 ('right (1+ (or from-index 0)))
1391 ((pred functionp)
1392 (funcall tab-bar-new-tab-to))))))
1393 (setq to-index (max 0 (min (or to-index 0) (length tabs))))
1394 (cl-pushnew to-tab (nthcdr to-index tabs))
1395
1396 (when (eq to-index 0)
1397 ;; `pushnew' handles the head of tabs but not frame-parameter
1398 (tab-bar-tabs-set tabs))
1399
1400 (when tab-bar-history-mode
1401 (puthash (selected-frame) nil tab-bar-history-back)
1402 (puthash (selected-frame) nil tab-bar-history-forward)
1403 (setq tab-bar-history-omit t))
1404
1405 (run-hook-with-args 'tab-bar-tab-post-open-functions
1406 (nth to-index tabs)))
1407
1408 (when tab-bar-show
1409 (if (not tab-bar-mode)
1410 ;; Turn on `tab-bar-mode' since a tab was created.
1411 ;; Note: this also updates `tab-bar-lines'.
1412 (tab-bar-mode 1)
1413 (tab-bar--update-tab-bar-lines)))
1414
1415 (force-mode-line-update)
1416 (unless tab-bar-mode
1417 (message "Added new tab at %s" tab-bar-new-tab-to))))
1418
1419(defun tab-bar-new-tab (&optional arg from-number)
1420 "Create a new tab ARG positions to the right.
1421If a negative ARG, create a new tab ARG positions to the left.
1422If ARG is zero, create a new tab in place of the current tab.
1423If no ARG is specified, then add a new tab at the position
1424specified by `tab-bar-new-tab-to'.
1425Argument addressing is relative in contrast to `tab-bar-new-tab-to',
1426where argument addressing is absolute.
1427If FROM-NUMBER is a tab number, a new tab is created from that tab."
1428 (interactive "P")
1429 (when from-number
1430 (let ((inhibit-message t))
1431 (tab-bar-select-tab from-number)))
1432 (if arg
1433 (let* ((tabs (funcall tab-bar-tabs-function))
1434 (from-index (or (tab-bar--current-tab-index tabs) 0))
1435 (to-index (+ from-index (prefix-numeric-value arg))))
1436 (tab-bar-new-tab-to (1+ to-index)))
1437 (tab-bar-new-tab-to)))
1438
1439(defun tab-bar-duplicate-tab (&optional arg from-number)
1440 "Clone the current tab to ARG positions to the right.
1441ARG and FROM-NUMBER have the same meaning as in `tab-bar-new-tab'."
1442 (interactive "P")
1443 (let ((tab-bar-new-tab-choice nil)
1444 (tab-bar-new-tab-group t))
1445 (tab-bar-new-tab arg from-number)))
1446
1447
1448(defvar tab-bar-closed-tabs nil
1449 "A list of closed tabs to be able to undo their closing.")
1450
1451(defcustom tab-bar-close-tab-select 'recent
1452 "Which tab to make current after closing the specified tab.
1453If `left', select the adjacent left tab.
1454If `right', select the adjacent right tab.
1455If `recent', select the most recently visited tab."
1456 :type '(choice (const :tag "Select left tab" left)
1457 (const :tag "Select right tab" right)
1458 (const :tag "Select recent tab" recent))
1459 :group 'tab-bar
1460 :version "27.1")
1461
1462(defcustom tab-bar-close-last-tab-choice nil
1463 "What to do when the last tab is closed.
1464If nil, do nothing and show a message, like closing the last window or frame.
1465If `delete-frame', delete the containing frame, as a web browser would do.
1466If `tab-bar-mode-disable', disable `tab-bar-mode' so that tabs no longer show
1467in the frame.
1468If the value is a function, call that function with the tab to be closed
1469as an argument."
1470 :type '(choice (const :tag "Do nothing and show message" nil)
1471 (const :tag "Close the containing frame" delete-frame)
1472 (const :tag "Disable tab-bar-mode" tab-bar-mode-disable)
1473 (function :tag "Function"))
1474 :group 'tab-bar
1475 :version "27.1")
1476
1477(defcustom tab-bar-tab-prevent-close-functions nil
1478 "List of functions to call to determine whether to close a tab.
1479The tab to be closed and a boolean indicating whether or not it
1480is the only tab in the frame are supplied as arguments. If any
1481function returns a non-nil value, the tab will not be closed."
1482 :type '(repeat function)
1483 :group 'tab-bar
1484 :version "27.1")
1485
1486(defcustom tab-bar-tab-pre-close-functions nil
1487 "List of functions to call before closing a tab.
1488Each function is called with two arguments: the tab to be closed
1489and a boolean indicating whether or not it is the only tab on its frame."
1490 :type '(repeat function)
1491 :group 'tab-bar
1492 :version "27.1")
1493
1494(defun tab-bar-close-tab (&optional tab-number to-number)
1495 "Close the tab specified by its absolute position TAB-NUMBER.
1496If no TAB-NUMBER is specified, then close the current tab and switch
1497to the tab specified by `tab-bar-close-tab-select'.
1498Interactively, TAB-NUMBER is the prefix numeric argument, and defaults to 1.
1499TAB-NUMBER counts from 1.
1500Optional TO-NUMBER could be specified to override the value of
1501`tab-bar-close-tab-select' programmatically with a position
1502of an existing tab to select after closing the current tab.
1503TO-NUMBER counts from 1.
1504
1505The functions in `tab-bar-tab-prevent-close-functions' will be
1506run to determine whether or not to close the tab.
1507Just before the tab is closed, the functions in
1508`tab-bar-tab-pre-close-functions' will be run. The base behavior
1509for the last tab on a frame is determined by
1510`tab-bar-close-last-tab-choice'."
1511 (interactive "P")
1512 (let* ((tabs (funcall tab-bar-tabs-function))
1513 (current-index (tab-bar--current-tab-index tabs))
1514 (close-index (if (integerp tab-number) (1- tab-number) current-index))
1515 (last-tab-p (= 1 (length tabs)))
1516 (prevent-close (run-hook-with-args-until-success
1517 'tab-bar-tab-prevent-close-functions
1518 (nth close-index tabs)
1519 last-tab-p)))
1520
1521 (unless prevent-close
1522 (run-hook-with-args 'tab-bar-tab-pre-close-functions
1523 (nth close-index tabs)
1524 last-tab-p)
1525
1526 (if last-tab-p
1527 (pcase tab-bar-close-last-tab-choice
1528 ('nil
1529 (user-error "Attempt to delete the sole tab in a frame"))
1530 ('delete-frame
1531 (delete-frame))
1532 ('tab-bar-mode-disable
1533 (tab-bar-mode -1))
1534 ((pred functionp)
1535 ;; Give the handler function the full extent of the tab's
1536 ;; data, not just it's name and explicit-name flag.
1537 (funcall tab-bar-close-last-tab-choice (tab-bar--tab))))
1538
1539 ;; More than one tab still open
1540 (when (eq current-index close-index)
1541 ;; Select another tab before deleting the current tab
1542 (let ((to-index (or (if to-number (1- to-number))
1543 (pcase tab-bar-close-tab-select
1544 ('left (1- (if (< current-index 1) 2 current-index)))
1545 ('right (if (> (length tabs) (1+ current-index))
1546 (1+ current-index)
1547 (1- current-index)))
1548 ('recent (tab-bar--tab-index-recent 1 tabs))))))
1549 (setq to-index (max 0 (min (or to-index 0) (1- (length tabs)))))
1550 (let ((inhibit-message t)) ; avoid message about selected tab
1551 (tab-bar-select-tab (1+ to-index)))
1552 ;; Re-read tabs after selecting another tab
1553 (setq tabs (funcall tab-bar-tabs-function))))
1554
1555 (let ((close-tab (nth close-index tabs)))
1556 (push `((frame . ,(selected-frame))
1557 (index . ,close-index)
1558 (tab . ,(if (eq (car close-tab) 'current-tab)
1559 (tab-bar--tab)
1560 close-tab)))
1561 tab-bar-closed-tabs)
1562 (tab-bar-tabs-set (delq close-tab tabs)))
1563
1564 ;; Recalculate `tab-bar-lines' and update frames
1565 (tab-bar--update-tab-bar-lines)
1566
1567 (force-mode-line-update)
1568 (unless tab-bar-mode
1569 (message "Deleted tab and switched to %s" tab-bar-close-tab-select))))))
1570
1571(defun tab-bar-close-tab-by-name (name)
1572 "Close the tab given its NAME.
1573Interactively, prompt for NAME."
1574 (interactive
1575 (list (completing-read "Close tab by name: "
1576 (mapcar (lambda (tab)
1577 (alist-get 'name tab))
1578 (funcall tab-bar-tabs-function)))))
1579 (tab-bar-close-tab (1+ (tab-bar--tab-index-by-name name))))
1580
1581(defun tab-bar-close-other-tabs (&optional tab-number)
1582 "Close all tabs on the selected frame, except the tab TAB-NUMBER.
1583TAB-NUMBER counts from 1 and defaults to the current tab (which
1584happens interactively)."
1585 (interactive)
1586 (let* ((tabs (funcall tab-bar-tabs-function))
1587 (current-index (tab-bar--current-tab-index tabs))
1588 (keep-index (if (integerp tab-number)
1589 (1- (max 1 (min tab-number (length tabs))))
1590 current-index))
1591 (index 0))
1592
1593 (when (nth keep-index tabs)
1594 (unless (eq keep-index current-index)
1595 (tab-bar-select-tab (1+ keep-index))
1596 (setq tabs (funcall tab-bar-tabs-function)))
1597
1598 (dolist (tab tabs)
1599 (unless (or (eq index keep-index)
1600 (run-hook-with-args-until-success
1601 'tab-bar-tab-prevent-close-functions tab
1602 ;; `last-tab-p' logically can't ever be true
1603 ;; if we make it this far
1604 nil))
1605 (push `((frame . ,(selected-frame))
1606 (index . ,index)
1607 (tab . ,tab))
1608 tab-bar-closed-tabs)
1609 (run-hook-with-args 'tab-bar-tab-pre-close-functions tab nil)
1610 (setq tabs (delq tab tabs)))
1611 (setq index (1+ index)))
1612 (tab-bar-tabs-set tabs)
1613
1614 ;; Recalculate tab-bar-lines and update frames
1615 (tab-bar--update-tab-bar-lines)
1616
1617 (force-mode-line-update)
1618 (unless tab-bar-mode
1619 (message "Deleted all other tabs")))))
1620
1621(defun tab-bar-undo-close-tab ()
1622 "Restore the most recently closed tab."
1623 (interactive)
1624 ;; Pop out closed tabs that were on already deleted frames
1625 (while (and tab-bar-closed-tabs
1626 (not (frame-live-p (alist-get 'frame (car tab-bar-closed-tabs)))))
1627 (pop tab-bar-closed-tabs))
1628
1629 (if tab-bar-closed-tabs
1630 (let* ((closed (pop tab-bar-closed-tabs))
1631 (frame (alist-get 'frame closed))
1632 (index (alist-get 'index closed))
1633 (tab (alist-get 'tab closed)))
1634 (unless (eq frame (selected-frame))
1635 (select-frame-set-input-focus frame))
1636
1637 (let ((tabs (funcall tab-bar-tabs-function)))
1638 (setq index (max 0 (min index (length tabs))))
1639 (cl-pushnew tab (nthcdr index tabs))
1640 (when (eq index 0)
1641 ;; pushnew handles the head of tabs but not frame-parameter
1642 (tab-bar-tabs-set tabs))
1643 (tab-bar-select-tab (1+ index))))
1644
1645 (message "No more closed tabs to undo")))
1646
1647
1648(defun tab-bar-rename-tab (name &optional tab-number)
1649 "Give the tab specified by its absolute position TAB-NUMBER a new NAME.
1650If no TAB-NUMBER is specified, then rename the current tab.
1651Interactively, TAB-NUMBER is the prefix numeric argument, and defaults
1652to the current tab.
1653TAB-NUMBER counts from 1.
1654Interactively, prompt for the new NAME.
1655If NAME is the empty string, then use the automatic name
1656function `tab-bar-tab-name-function'."
1657 (interactive
1658 (let* ((tabs (funcall tab-bar-tabs-function))
1659 (tab-number (or current-prefix-arg (1+ (tab-bar--current-tab-index tabs))))
1660 (tab-name (alist-get 'name (nth (1- tab-number) tabs))))
1661 (list (read-from-minibuffer
1662 "New name for tab (leave blank for automatic naming): "
1663 nil nil nil nil tab-name)
1664 current-prefix-arg)))
1665 (let* ((tabs (funcall tab-bar-tabs-function))
1666 (tab-index (if (integerp tab-number)
1667 (1- (max 0 (min tab-number (length tabs))))
1668 (tab-bar--current-tab-index tabs)))
1669 (tab-to-rename (nth tab-index tabs))
1670 (tab-explicit-name (> (length name) 0))
1671 (tab-new-name (if tab-explicit-name
1672 name
1673 (funcall tab-bar-tab-name-function))))
1674 (setf (alist-get 'name tab-to-rename) tab-new-name
1675 (alist-get 'explicit-name tab-to-rename) tab-explicit-name)
1676
1677 (force-mode-line-update)
1678 (unless tab-bar-mode
1679 (message "Renamed tab to '%s'" tab-new-name))))
1680
1681(defun tab-bar-rename-tab-by-name (tab-name new-name)
1682 "Rename the tab named TAB-NAME to NEW-NAME.
1683Interactively, prompt for TAB-NAME and NEW-NAME.
1684If NEW-NAME is the empty string, then use the automatic name
1685function `tab-bar-tab-name-function'."
1686 (interactive
1687 (let ((tab-name (completing-read "Rename tab by name: "
1688 (mapcar (lambda (tab)
1689 (alist-get 'name tab))
1690 (funcall tab-bar-tabs-function)))))
1691 (list tab-name (read-from-minibuffer
1692 "New name for tab (leave blank for automatic naming): "
1693 nil nil nil nil tab-name))))
1694 (tab-bar-rename-tab new-name (1+ (tab-bar--tab-index-by-name tab-name))))
1695
1696
1697;;; Tab groups
1698
1699(defun tab-bar-move-tab-to-group (&optional tab)
1700 "Relocate TAB (by default, the current tab) closer to its group."
1701 (interactive)
1702 (let* ((tabs (funcall tab-bar-tabs-function))
1703 (tab (or tab (tab-bar--current-tab-find tabs)))
1704 (tab-index (tab-bar--tab-index tab))
1705 (group (alist-get 'group tab))
1706 ;; Beginning position of the same group
1707 (beg (seq-position tabs group
1708 (lambda (tb gr)
1709 (and (not (eq tb tab))
1710 (equal (alist-get 'group tb) gr)))))
1711 ;; Size of the same group
1712 (len (when beg
1713 (seq-position (nthcdr beg tabs) group
1714 (lambda (tb gr)
1715 (not (equal (alist-get 'group tb) gr))))))
1716 (pos (when beg
1717 (cond
1718 ;; Don't move tab when it's already inside group bounds
1719 ((and len (>= tab-index beg) (<= tab-index (+ beg len))) nil)
1720 ;; Move tab from the right to the group end
1721 ((and len (> tab-index (+ beg len))) (+ beg len 1))
1722 ;; Move tab from the left to the group beginning
1723 ((< tab-index beg) beg)))))
1724 (when pos
1725 (tab-bar-move-tab-to pos (1+ tab-index)))))
1726
1727(defcustom tab-bar-tab-post-change-group-functions nil
1728 "List of functions to call after changing a tab group.
1729The current tab is supplied as an argument."
1730 :type 'hook
1731 :options '(tab-bar-move-tab-to-group)
1732 :group 'tab-bar
1733 :version "28.1")
1734
1735(defun tab-bar-change-tab-group (group-name &optional tab-number)
1736 "Add the tab specified by its absolute position TAB-NUMBER to GROUP-NAME.
1737If no TAB-NUMBER is specified, then set the GROUP-NAME for the current tab.
1738Interactively, TAB-NUMBER is the prefix numeric argument, and the command
1739prompts for GROUP-NAME.
1740TAB-NUMBER counts from 1.
1741If GROUP-NAME is the empty string, then remove the tab from any group.
1742While using this command, you might also want to replace
1743`tab-bar-format-tabs' with `tab-bar-format-tabs-groups' in
1744`tab-bar-format' to group tabs on the tab bar."
1745 (interactive
1746 (let* ((tabs (funcall tab-bar-tabs-function))
1747 (tab-number (or current-prefix-arg
1748 (1+ (tab-bar--current-tab-index tabs))))
1749 (group-name (funcall tab-bar-tab-group-function
1750 (nth (1- tab-number) tabs))))
1751 (list (completing-read
1752 "Group name for tab (leave blank to remove group): "
1753 (delete-dups
1754 (delq nil (cons group-name
1755 (mapcar (lambda (tab)
1756 (funcall tab-bar-tab-group-function tab))
1757 (funcall tab-bar-tabs-function))))))
1758 current-prefix-arg)))
1759 (let* ((tabs (funcall tab-bar-tabs-function))
1760 (tab-index (if tab-number
1761 (1- (max 0 (min tab-number (length tabs))))
1762 (tab-bar--current-tab-index tabs)))
1763 (tab (nth tab-index tabs))
1764 (group (assq 'group tab))
1765 (group-new-name (and (> (length group-name) 0) group-name)))
1766 (if group
1767 (setcdr group group-new-name)
1768 (nconc tab `((group . ,group-new-name))))
1769
1770 (run-hook-with-args 'tab-bar-tab-post-change-group-functions tab)
1771
1772 (force-mode-line-update)
1773 (unless tab-bar-mode
1774 (message "Set tab group to '%s'" group-new-name))))
1775
1776(defun tab-bar-close-group-tabs (group-name)
1777 "Close all tabs that belong to GROUP-NAME on the selected frame.
1778Interactively, prompt for GROUP-NAME."
1779 (interactive
1780 (let ((group-name (funcall tab-bar-tab-group-function
1781 (tab-bar--current-tab-find))))
1782 (list (completing-read
1783 "Close all tabs with group name: "
1784 (delete-dups
1785 (delq nil (cons group-name
1786 (mapcar (lambda (tab)
1787 (funcall tab-bar-tab-group-function tab))
1788 (funcall tab-bar-tabs-function)))))))))
1789 (let* ((close-group (and (> (length group-name) 0) group-name))
1790 (tab-bar-tab-prevent-close-functions
1791 (cons (lambda (tab _last-tab-p)
1792 (not (equal (funcall tab-bar-tab-group-function tab)
1793 close-group)))
1794 tab-bar-tab-prevent-close-functions)))
1795 (tab-bar-close-other-tabs)
1796
1797 (when (equal (funcall tab-bar-tab-group-function
1798 (tab-bar--current-tab-find))
1799 close-group)
1800 (tab-bar-close-tab))))
1801
1802
1803;;; Tab history mode
1804
1805(defvar tab-bar-history-limit 10
1806 "The number of history elements to keep.")
1807
1808(defvar tab-bar-history-omit nil
1809 "When non-nil, omit window-configuration changes from the current command.")
1810
1811(defvar tab-bar-history-back (make-hash-table)
1812 "History of back changes in every tab per frame.")
1813
1814(defvar tab-bar-history-forward (make-hash-table)
1815 "History of forward changes in every tab per frame.")
1816
1817(defvar tab-bar-history-old nil
1818 "Window configuration before the current command.")
1819
1820(defvar tab-bar-history-pre-command nil
1821 "Command set to `this-command' by `pre-command-hook'.")
1822
1823(defvar tab-bar-history-done-command nil
1824 "Command handled by `window-configuration-change-hook'.")
1825
1826(defun tab-bar--history-pre-change ()
1827 ;; Reset before the command could set it
1828 (setq tab-bar-history-omit nil)
1829 (setq tab-bar-history-pre-command this-command)
1830 (when (zerop (minibuffer-depth))
1831 (setq tab-bar-history-old
1832 `((wc . ,(current-window-configuration))
1833 (wc-point . ,(point-marker))))))
1834
1835(defun tab-bar--history-change ()
1836 (when (and (not tab-bar-history-omit) tab-bar-history-old
1837 ;; Don't register changes performed by the same command
1838 ;; repeated in sequence, such as incremental window resizing.
1839 (not (eq tab-bar-history-done-command tab-bar-history-pre-command))
1840 (zerop (minibuffer-depth)))
1841 (puthash (selected-frame)
1842 (seq-take (cons tab-bar-history-old
1843 (gethash (selected-frame) tab-bar-history-back))
1844 tab-bar-history-limit)
1845 tab-bar-history-back)
1846 (setq tab-bar-history-old nil))
1847 (setq tab-bar-history-done-command tab-bar-history-pre-command))
1848
1849(defun tab-bar-history-back ()
1850 "Restore a previous window configuration used in the current tab.
1851This navigates back in the history of window configurations."
1852 (interactive)
1853 (setq tab-bar-history-omit t)
1854 (let* ((history (pop (gethash (selected-frame) tab-bar-history-back)))
1855 (wc (alist-get 'wc history))
1856 (wc-point (alist-get 'wc-point history)))
1857 (if (window-configuration-p wc)
1858 (progn
1859 (puthash (selected-frame)
1860 (cons tab-bar-history-old
1861 (gethash (selected-frame) tab-bar-history-forward))
1862 tab-bar-history-forward)
1863 (set-window-configuration wc)
1864 (when (and (markerp wc-point) (marker-buffer wc-point))
1865 (goto-char wc-point)))
1866 (message "No more tab back history"))))
1867
1868(defun tab-bar-history-forward ()
1869 "Cancel restoration of the previous window configuration.
1870This navigates forward in the history of window configurations."
1871 (interactive)
1872 (setq tab-bar-history-omit t)
1873 (let* ((history (pop (gethash (selected-frame) tab-bar-history-forward)))
1874 (wc (alist-get 'wc history))
1875 (wc-point (alist-get 'wc-point history)))
1876 (if (window-configuration-p wc)
1877 (progn
1878 (puthash (selected-frame)
1879 (cons tab-bar-history-old
1880 (gethash (selected-frame) tab-bar-history-back))
1881 tab-bar-history-back)
1882 (set-window-configuration wc)
1883 (when (and (markerp wc-point) (marker-buffer wc-point))
1884 (goto-char wc-point)))
1885 (message "No more tab forward history"))))
1886
1887(defvar-keymap tab-bar-history-mode-map
1888 "C-c <left>" #'tab-bar-history-back
1889 "C-c <right>" #'tab-bar-history-forward)
1890
1891(define-minor-mode tab-bar-history-mode
1892 "Toggle tab history mode for the tab bar.
1893Tab history mode remembers window configurations used in every tab,
1894and can restore them."
1895 :global t :group 'tab-bar
1896 (if tab-bar-history-mode
1897 (progn
1898 (when (and tab-bar-mode (not (get-text-property 0 'display tab-bar-back-button)))
1899 ;; This file is pre-loaded so only here we can use the right data-directory:
1900 (add-text-properties 0 (length tab-bar-back-button)
1901 `(display (image :type xpm
1902 :file "tabs/left-arrow.xpm"
1903 :margin ,tab-bar-button-margin
1904 :ascent center))
1905 tab-bar-back-button))
1906 (when (and tab-bar-mode (not (get-text-property 0 'display tab-bar-forward-button)))
1907 ;; This file is pre-loaded so only here we can use the right data-directory:
1908 (add-text-properties 0 (length tab-bar-forward-button)
1909 `(display (image :type xpm
1910 :file "tabs/right-arrow.xpm"
1911 :margin ,tab-bar-button-margin
1912 :ascent center))
1913 tab-bar-forward-button))
1914
1915 (add-hook 'pre-command-hook 'tab-bar--history-pre-change)
1916 (add-hook 'window-configuration-change-hook 'tab-bar--history-change))
1917 (remove-hook 'pre-command-hook 'tab-bar--history-pre-change)
1918 (remove-hook 'window-configuration-change-hook 'tab-bar--history-change)))
1919
1920
1921;;; Non-graphical access to frame-local tabs (named window configurations)
1922
1923(defun tab-switcher ()
1924 "Display a list of named window configurations.
1925The list is displayed in the buffer `*Tabs*'.
1926It's placed in the center of the frame to resemble a window list
1927displayed by a window switcher in some window managers on Alt+Tab.
1928
1929In this list of window configurations you can delete or select them.
1930Type ? after invocation to get help on commands available.
1931Type q to remove the list of window configurations from the display.
1932
1933The first column shows `D' for a window configuration you have
1934marked for deletion."
1935 (interactive)
1936 (let ((dir default-directory))
1937 (let ((tab-bar-new-tab-choice t)
1938 ;; Don't enable tab-bar-mode if it's disabled
1939 (tab-bar-show nil))
1940 (tab-bar-new-tab))
1941 (let ((switch-to-buffer-preserve-window-point nil))
1942 (switch-to-buffer (tab-switcher-noselect)))
1943 (setq default-directory dir))
1944 (message "Commands: d, x; RET; q to quit; ? for help."))
1945
1946(defun tab-switcher-noselect ()
1947 "Create and return a buffer with a list of window configurations.
1948The list is displayed in a buffer named `*Tabs*'.
1949
1950For more information, see the function `tab-switcher'."
1951 (let* ((tabs (seq-remove (lambda (tab)
1952 (eq (car tab) 'current-tab))
1953 (funcall tab-bar-tabs-function)))
1954 ;; Sort by recency
1955 (tabs (sort tabs (lambda (a b) (< (alist-get 'time b)
1956 (alist-get 'time a))))))
1957 (with-current-buffer (get-buffer-create
1958 (format " *Tabs*<%s>" (or (frame-parameter nil 'window-id)
1959 (frame-parameter nil 'name))))
1960 (setq buffer-read-only nil)
1961 (erase-buffer)
1962 (tab-switcher-mode)
1963 ;; Vertical alignment to the center of the frame
1964 (insert-char ?\n (/ (- (frame-height) (length tabs) 1) 2))
1965 ;; Horizontal alignment to the center of the frame
1966 (setq tab-switcher-column (- (/ (frame-width) 2) 15))
1967 (dolist (tab tabs)
1968 (insert (propertize
1969 (format "%s %s\n"
1970 (make-string tab-switcher-column ?\040)
1971 (propertize
1972 (alist-get 'name tab)
1973 'mouse-face 'highlight
1974 'help-echo "mouse-2: select this window configuration"))
1975 'tab tab)))
1976 (goto-char (point-min))
1977 (goto-char (or (next-single-property-change (point) 'tab) (point-min)))
1978 (when (> (length tabs) 1)
1979 (tab-switcher-next-line))
1980 (move-to-column tab-switcher-column)
1981 (set-buffer-modified-p nil)
1982 (setq buffer-read-only t)
1983 (current-buffer))))
1984
1985(defvar-local tab-switcher-column 3)
1986
1987(defvar tab-switcher-mode-map
1988 (let ((map (make-keymap)))
1989 (suppress-keymap map t)
1990 (define-key map "q" 'quit-window)
1991 (define-key map "\C-m" 'tab-switcher-select)
1992 (define-key map "d" 'tab-switcher-delete)
1993 (define-key map "k" 'tab-switcher-delete)
1994 (define-key map "\C-d" 'tab-switcher-delete-backwards)
1995 (define-key map "\C-k" 'tab-switcher-delete)
1996 (define-key map "x" 'tab-switcher-execute)
1997 (define-key map " " 'tab-switcher-next-line)
1998 (define-key map "n" 'tab-switcher-next-line)
1999 (define-key map "p" 'tab-switcher-prev-line)
2000 (define-key map "\177" 'tab-switcher-backup-unmark)
2001 (define-key map "?" 'describe-mode)
2002 (define-key map "u" 'tab-switcher-unmark)
2003 (define-key map [mouse-2] 'tab-switcher-mouse-select)
2004 (define-key map [follow-link] 'mouse-face)
2005 map)
2006 "Local keymap for `tab-switcher-mode' buffers.")
2007
2008(define-derived-mode tab-switcher-mode nil "Window Configurations"
2009 "Major mode for selecting a window configuration.
2010Each line describes one window configuration in Emacs.
2011Letters do not insert themselves; instead, they are commands.
2012\\<tab-switcher-mode-map>
2013\\[tab-switcher-mouse-select] -- select window configuration you click on.
2014\\[tab-switcher-select] -- select current line's window configuration.
2015\\[tab-switcher-delete] -- mark that window configuration to be deleted, and move down.
2016\\[tab-switcher-delete-backwards] -- mark that window configuration to be deleted, and move up.
2017\\[tab-switcher-execute] -- delete marked window configurations.
2018\\[tab-switcher-unmark] -- remove all kinds of marks from current line.
2019 With prefix argument, also move up one line.
2020\\[tab-switcher-backup-unmark] -- back up a line and remove marks."
2021 (setq truncate-lines t))
2022
2023(defun tab-switcher-current-tab (error-if-non-existent-p)
2024 "Return window configuration described by this line of the list."
2025 (let* ((where (save-excursion
2026 (beginning-of-line)
2027 (+ 2 (point) tab-switcher-column)))
2028 (tab (and (not (eobp)) (get-text-property where 'tab))))
2029 (or tab
2030 (if error-if-non-existent-p
2031 (user-error "No window configuration on this line")
2032 nil))))
2033
2034(defun tab-switcher-next-line (&optional arg)
2035 "Move to ARGth next line in the list of tabs.
2036Interactively, ARG is the prefix numeric argument and defaults to 1."
2037 (interactive "p")
2038 (forward-line arg)
2039 (beginning-of-line)
2040 (move-to-column tab-switcher-column))
2041
2042(defun tab-switcher-prev-line (&optional arg)
2043 "Move to ARGth previous line in the list of tabs.
2044Interactively, ARG is the prefix numeric argument and defaults to 1."
2045 (interactive "p")
2046 (forward-line (- arg))
2047 (beginning-of-line)
2048 (move-to-column tab-switcher-column))
2049
2050(defun tab-switcher-unmark (&optional backup)
2051 "Cancel requested operations on window configuration on this line and move down.
2052With prefix arg, move up instead."
2053 (interactive "P")
2054 (beginning-of-line)
2055 (move-to-column tab-switcher-column)
2056 (let* ((buffer-read-only nil))
2057 (delete-char 1)
2058 (insert " "))
2059 (forward-line (if backup -1 1))
2060 (move-to-column tab-switcher-column))
2061
2062(defun tab-switcher-backup-unmark ()
2063 "Move up one line and cancel requested operations on window configuration there."
2064 (interactive)
2065 (forward-line -1)
2066 (tab-switcher-unmark)
2067 (forward-line -1)
2068 (move-to-column tab-switcher-column))
2069
2070(defun tab-switcher-delete (&optional arg)
2071 "Mark window configuration on this line to be deleted by \\<tab-switcher-mode-map>\\[tab-switcher-execute] command.
2072Prefix arg says how many window configurations to delete.
2073Negative arg means delete backwards."
2074 (interactive "p")
2075 (let ((buffer-read-only nil))
2076 (if (or (null arg) (= arg 0))
2077 (setq arg 1))
2078 (while (> arg 0)
2079 (delete-char 1)
2080 (insert ?D)
2081 (forward-line 1)
2082 (setq arg (1- arg)))
2083 (while (< arg 0)
2084 (delete-char 1)
2085 (insert ?D)
2086 (forward-line -1)
2087 (setq arg (1+ arg)))
2088 (move-to-column tab-switcher-column)))
2089
2090(defun tab-switcher-delete-backwards (&optional arg)
2091 "Mark window configuration on this line to be deleted by \\<tab-switcher-mode-map>\\[tab-switcher-execute] command.
2092Then move up one line. Prefix arg means move that many lines."
2093 (interactive "p")
2094 (tab-switcher-delete (- (or arg 1))))
2095
2096(defun tab-switcher-delete-from-list (tab)
2097 "Delete the window configuration from the list of tabs."
2098 (push `((frame . ,(selected-frame))
2099 (index . ,(tab-bar--tab-index tab))
2100 (tab . ,tab))
2101 tab-bar-closed-tabs)
2102 (tab-bar-tabs-set (delq tab (funcall tab-bar-tabs-function))))
2103
2104(defun tab-switcher-execute ()
2105 "Delete window configurations marked with \\<tab-switcher-mode-map>\\[tab-switcher-delete] commands."
2106 (interactive)
2107 (save-excursion
2108 (goto-char (point-min))
2109 (let ((buffer-read-only nil))
2110 (while (re-search-forward
2111 (format "^%sD" (make-string tab-switcher-column ?\040))
2112 nil t)
2113 (forward-char -1)
2114 (let ((tab (tab-switcher-current-tab nil)))
2115 (when tab
2116 (tab-switcher-delete-from-list tab)
2117 (beginning-of-line)
2118 (delete-region (point) (progn (forward-line 1) (point))))))))
2119 (beginning-of-line)
2120 (move-to-column tab-switcher-column)
2121 (force-mode-line-update))
2122
2123(defun tab-switcher-select ()
2124 "Select this line's window configuration.
2125This command replaces all the existing windows in the selected frame
2126with those specified by the selected window configuration."
2127 (interactive)
2128 (let* ((to-tab (tab-switcher-current-tab t)))
2129 (kill-buffer (current-buffer))
2130 ;; Delete the current window configuration of tab list
2131 ;; without storing it in the undo list of closed tabs
2132 (let ((inhibit-message t) ; avoid message about deleted tab
2133 tab-bar-closed-tabs)
2134 (tab-bar-close-tab nil (1+ (tab-bar--tab-index to-tab))))))
2135
2136(defun tab-switcher-mouse-select (event)
2137 "Select the window configuration whose line you click on."
2138 (interactive "e")
2139 (set-buffer (window-buffer (posn-window (event-end event))))
2140 (goto-char (posn-point (event-end event)))
2141 (tab-switcher-select))
2142
2143
2144(defun tab-bar--reusable-frames (all-frames)
2145 (cond
2146 ((eq all-frames t) (frame-list))
2147 ((eq all-frames 'visible) (visible-frame-list))
2148 ((framep all-frames) (list all-frames))
2149 (t (list (selected-frame)))))
2150
2151(defun tab-bar-get-buffer-tab (buffer-or-name &optional all-frames ignore-current-tab)
2152 "Return the tab that owns the window whose buffer is BUFFER-OR-NAME.
2153BUFFER-OR-NAME may be a buffer or a buffer name, and defaults to
2154the current buffer.
2155
2156The optional argument ALL-FRAMES specifies the frames to consider:
2157
2158- t means consider all tabs on all existing frames.
2159
2160- `visible' means consider all tabs on all visible frames.
2161
2162- A frame means consider all tabs on that frame only.
2163
2164- Any other value of ALL-FRAMES means consider all tabs on the
2165selected frame and no others.
2166
2167When the optional argument IGNORE-CURRENT-TAB is non-nil,
2168don't take into account the buffers in the currently selected tab.
2169Otherwise, prefer buffers of the current tab."
2170 (let ((buffer (if buffer-or-name
2171 (get-buffer buffer-or-name)
2172 (current-buffer))))
2173 (when (bufferp buffer)
2174 (seq-some
2175 (lambda (frame)
2176 (seq-some
2177 (lambda (tab)
2178 (when (if (eq (car tab) 'current-tab)
2179 (get-buffer-window buffer frame)
2180 (let* ((state (alist-get 'ws tab))
2181 (buffers (when state
2182 (window-state-buffers state))))
2183 (or
2184 ;; non-writable window-state
2185 (memq buffer buffers)
2186 ;; writable window-state
2187 (member (buffer-name buffer) buffers))))
2188 (append tab `((index . ,(tab-bar--tab-index tab nil frame))
2189 (frame . ,frame)))))
2190 (let* ((tabs (funcall tab-bar-tabs-function frame))
2191 (current-tab (tab-bar--current-tab-find tabs)))
2192 (setq tabs (remq current-tab tabs))
2193 (if ignore-current-tab
2194 ;; Use tabs without current-tab.
2195 tabs
2196 ;; Make sure current-tab is at the beginning of tabs.
2197 (cons current-tab tabs)))))
2198 (tab-bar--reusable-frames all-frames)))))
2199
2200(defun display-buffer-in-tab (buffer alist)
2201 "Display BUFFER in a tab using display actions in ALIST.
2202ALIST is an association list of action symbols and values. See
2203Info node `(elisp) Buffer Display Action Alists' for details of
2204such alists.
2205
2206If ALIST contains a `tab-name' entry, it creates a new tab with that name and
2207displays BUFFER in a new tab. If a tab with this name already exists, it
2208switches to that tab before displaying BUFFER. The `tab-name' entry can be
2209a function, in which case it is called with two arguments: BUFFER and ALIST,
2210and should return the tab name. When a `tab-name' entry is omitted, create
2211a new tab without an explicit name.
2212
2213The ALIST entry `tab-group' (string or function) defines the tab group.
2214
2215If ALIST contains a `reusable-frames' entry, its value determines
2216which frames to search for a reusable tab:
2217 nil -- do not reuse any frames;
2218 a frame -- just that frame;
2219 `visible' -- all visible frames;
2220 0 -- all frames on the current terminal;
2221 t -- all frames;
2222 other non-nil values -- use the selected frame.
2223
2224If ALIST contains a non-nil `ignore-current-tab' entry, then the buffers
2225of the current tab are skipped when searching for a reusable tab.
2226Otherwise, prefer buffers of the current tab.
2227
2228This is an action function for buffer display, see Info
2229node `(elisp) Buffer Display Action Functions'. It should be
2230called only by `display-buffer' or a function directly or
2231indirectly called by the latter."
2232 (let* ((reusable-frames (alist-get 'reusable-frames alist))
2233 (ignore-current-tab (alist-get 'ignore-current-tab alist))
2234 (reusable-tab (when reusable-frames
2235 (tab-bar-get-buffer-tab buffer reusable-frames
2236 ignore-current-tab))))
2237 (if reusable-tab
2238 (let* ((frame (alist-get 'frame reusable-tab))
2239 (index (alist-get 'index reusable-tab)))
2240 (when frame
2241 (select-frame-set-input-focus frame))
2242 (when index
2243 (tab-bar-select-tab (1+ index)))
2244 (when (get-buffer-window buffer frame)
2245 (select-window (get-buffer-window buffer frame))))
2246 (let ((tab-name (alist-get 'tab-name alist)))
2247 (when (functionp tab-name)
2248 (setq tab-name (funcall tab-name buffer alist)))
2249 (if tab-name
2250 (let ((tab-index (tab-bar--tab-index-by-name tab-name)))
2251 (if tab-index
2252 (progn
2253 (tab-bar-select-tab (1+ tab-index))
2254 (when (get-buffer-window buffer)
2255 (select-window (get-buffer-window buffer))))
2256 (display-buffer-in-new-tab buffer alist)))
2257 (display-buffer-in-new-tab buffer alist))))))
2258
2259(defun display-buffer-in-new-tab (buffer alist)
2260 "Display BUFFER in a new tab using display actions in ALIST.
2261ALIST is an association list of action symbols and values. See
2262Info node `(elisp) Buffer Display Action Alists' for details of
2263such alists.
2264
2265Like `display-buffer-in-tab', but always creates a new tab unconditionally,
2266without checking if a suitable tab already exists.
2267
2268If ALIST contains a `tab-name' entry, it creates a new tab with that name
2269and displays BUFFER in a new tab. The `tab-name' entry can be a function,
2270in which case it is called with two arguments: BUFFER and ALIST, and should
2271return the tab name. When a `tab-name' entry is omitted, create a new tab
2272without an explicit name.
2273
2274The ALIST entry `tab-group' (string or function) defines the tab group.
2275
2276This is an action function for buffer display, see Info
2277node `(elisp) Buffer Display Action Functions'. It should be
2278called only by `display-buffer' or a function directly or
2279indirectly called by the latter."
2280 (let ((tab-bar-new-tab-choice t))
2281 (tab-bar-new-tab)
2282 (let ((tab-name (alist-get 'tab-name alist)))
2283 (when (functionp tab-name)
2284 (setq tab-name (funcall tab-name buffer alist)))
2285 (when tab-name
2286 (tab-bar-rename-tab tab-name)))
2287 (let ((tab-group (alist-get 'tab-group alist)))
2288 (when (functionp tab-group)
2289 (setq tab-group (funcall tab-group buffer alist)))
2290 (when tab-group
2291 (tab-bar-change-tab-group tab-group)))
2292 (window--display-buffer buffer (selected-window) 'tab alist)))
2293
2294(defun switch-to-buffer-other-tab (buffer-or-name &optional _norecord)
2295 "Switch to buffer BUFFER-OR-NAME in another tab.
2296Like \\[switch-to-buffer-other-frame] (which see), but creates a new tab.
2297Interactively, prompt for the buffer to switch to."
2298 (declare (advertised-calling-convention (buffer-or-name) "28.1"))
2299 (interactive
2300 (list (read-buffer-to-switch "Switch to buffer in other tab: ")))
2301 (display-buffer (window-normalize-buffer-to-switch-to buffer-or-name)
2302 '((display-buffer-in-tab)
2303 (inhibit-same-window . nil))))
2304
2305(defun find-file-other-tab (filename &optional wildcards)
2306 "Edit file FILENAME, in another tab.
2307Like \\[find-file-other-frame] (which see), but creates a new tab.
2308Interactively, prompt for FILENAME.
2309If WILDCARDS is non-nil, FILENAME can include widcards, and all matching
2310files will be visited."
2311 (interactive
2312 (find-file-read-args "Find file in other tab: "
2313 (confirm-nonexistent-file-or-buffer)))
2314 (let ((value (find-file-noselect filename nil nil wildcards)))
2315 (if (listp value)
2316 (progn
2317 (setq value (nreverse value))
2318 (switch-to-buffer-other-tab (car value))
2319 (mapc 'switch-to-buffer (cdr value))
2320 value)
2321 (switch-to-buffer-other-tab value))))
2322
2323(defun find-file-read-only-other-tab (filename &optional wildcards)
2324 "Edit file FILENAME, in another tab, but don't allow changes.
2325Like \\[find-file-other-frame] (which see), but creates a new tab.
2326Like \\[find-file-other-tab], but marks buffer as read-only.
2327Use \\[read-only-mode] to permit editing.
2328Interactively, prompt for FILENAME.
2329If WILDCARDS is non-nil, FILENAME can include widcards, and all matching
2330files will be visited."
2331 (interactive
2332 (find-file-read-args "Find file read-only in other tab: "
2333 (confirm-nonexistent-file-or-buffer)))
2334 (find-file--read-only (lambda (filename wildcards)
2335 (window-buffer
2336 (find-file-other-tab filename wildcards)))
2337 filename wildcards))
2338
2339(defun other-tab-prefix ()
2340 "Display the buffer of the next command in a new tab.
2341The next buffer is the buffer displayed by the next command invoked
2342immediately after this command (ignoring reading from the minibuffer).
2343Creates a new tab before displaying the buffer, or switches to the tab
2344that already contains that buffer.
2345When `switch-to-buffer-obey-display-actions' is non-nil,
2346`switch-to-buffer' commands are also supported."
2347 (interactive)
2348 (display-buffer-override-next-command
2349 (lambda (buffer alist)
2350 (cons (progn
2351 (display-buffer-in-tab
2352 buffer (append alist '((inhibit-same-window . nil))))
2353 (selected-window))
2354 'tab))
2355 nil "[other-tab]")
2356 (message "Display next command buffer in a new tab..."))
2357
2358
2359;;; Short aliases and keybindings
2360
2361(defalias 'tab-new 'tab-bar-new-tab)
2362(defalias 'tab-new-to 'tab-bar-new-tab-to)
2363(defalias 'tab-duplicate 'tab-bar-duplicate-tab)
2364(defalias 'tab-detach 'tab-bar-detach-tab)
2365(defalias 'tab-window-detach 'tab-bar-move-window-to-tab)
2366(defalias 'tab-close 'tab-bar-close-tab)
2367(defalias 'tab-close-other 'tab-bar-close-other-tabs)
2368(defalias 'tab-close-group 'tab-bar-close-group-tabs)
2369(defalias 'tab-undo 'tab-bar-undo-close-tab)
2370(defalias 'tab-select 'tab-bar-select-tab)
2371(defalias 'tab-switch 'tab-bar-switch-to-tab)
2372(defalias 'tab-next 'tab-bar-switch-to-next-tab)
2373(defalias 'tab-previous 'tab-bar-switch-to-prev-tab)
2374(defalias 'tab-last 'tab-bar-switch-to-last-tab)
2375(defalias 'tab-recent 'tab-bar-switch-to-recent-tab)
2376(defalias 'tab-move 'tab-bar-move-tab)
2377(defalias 'tab-move-to 'tab-bar-move-tab-to)
2378(defalias 'tab-rename 'tab-bar-rename-tab)
2379(defalias 'tab-group 'tab-bar-change-tab-group)
2380(defalias 'tab-list 'tab-switcher)
2381
2382(define-key tab-prefix-map "n" 'tab-duplicate)
2383(define-key tab-prefix-map "N" 'tab-new-to)
2384(define-key tab-prefix-map "2" 'tab-new)
2385(define-key tab-prefix-map "1" 'tab-close-other)
2386(define-key tab-prefix-map "0" 'tab-close)
2387(define-key tab-prefix-map "u" 'tab-undo)
2388(define-key tab-prefix-map "o" 'tab-next)
2389(define-key tab-prefix-map "O" 'tab-previous)
2390(define-key tab-prefix-map "m" 'tab-move)
2391(define-key tab-prefix-map "M" 'tab-move-to)
2392(define-key tab-prefix-map "G" 'tab-group)
2393(define-key tab-prefix-map "r" 'tab-rename)
2394(define-key tab-prefix-map "\r" 'tab-switch)
2395(define-key tab-prefix-map "b" 'switch-to-buffer-other-tab)
2396(define-key tab-prefix-map "f" 'find-file-other-tab)
2397(define-key tab-prefix-map "\C-f" 'find-file-other-tab)
2398(define-key tab-prefix-map "\C-r" 'find-file-read-only-other-tab)
2399(define-key tab-prefix-map "t" 'other-tab-prefix)
2400
2401(defvar tab-bar-switch-repeat-map
2402 (let ((map (make-sparse-keymap)))
2403 (define-key map "o" 'tab-next)
2404 (define-key map "O" 'tab-previous)
2405 map)
2406 "Keymap to repeat tab switch key sequences `C-x t o o O'.
2407Used in `repeat-mode'.")
2408(put 'tab-next 'repeat-map 'tab-bar-switch-repeat-map)
2409(put 'tab-previous 'repeat-map 'tab-bar-switch-repeat-map)
2410
2411(defvar tab-bar-move-repeat-map
2412 (let ((map (make-sparse-keymap)))
2413 (define-key map "m" 'tab-move)
2414 (define-key map "M" 'tab-bar-move-tab-backward)
2415 map)
2416 "Keymap to repeat tab move key sequences `C-x t m m M'.
2417Used in `repeat-mode'.")
2418(put 'tab-move 'repeat-map 'tab-bar-move-repeat-map)
2419(put 'tab-bar-move-tab-backward 'repeat-map 'tab-bar-move-repeat-map)
2420
2421
2422(provide 'tab-bar)
2423
2424;;; tab-bar.el ends here
© 2022 C. Duckworth. generated by cgit. comments, issues, and patches welcome at < git at acdw dot net >.