diff options
Diffstat (limited to 'lisp/tool-bar.el')
| -rw-r--r-- | lisp/tool-bar.el | 292 |
1 files changed, 274 insertions, 18 deletions
diff --git a/lisp/tool-bar.el b/lisp/tool-bar.el index 179b979ee2e..96b61c7b229 100644 --- a/lisp/tool-bar.el +++ b/lisp/tool-bar.el @@ -83,6 +83,14 @@ buffer-locally and add the items you want to it with `tool-bar-add-item', `tool-bar-add-item-from-menu' and related functions.") +(defvar secondary-tool-bar-map nil + "Optional secondary keymap for the tool bar. + +If non-nil, tool bar items defined within this map are displayed +in a line below the tool bar if the `tool-bar-position' frame +parameter is set to `top', and above the tool bar it is set to +`bottom'.") + (global-set-key [tool-bar] `(menu-item ,(purecopy "tool bar") ignore :filter tool-bar-make-keymap)) @@ -91,15 +99,21 @@ functions.") (defconst tool-bar-keymap-cache (make-hash-table :test #'equal)) -(defun tool-bar--cache-key () +(defsubst tool-bar--cache-key () (cons (frame-terminal) (sxhash-eq tool-bar-map))) +(defsubst tool-bar--secondary-cache-key () + (cons (frame-terminal) (sxhash-eq secondary-tool-bar-map))) + (defun tool-bar--flush-cache () "Remove all cached entries that refer to the current `tool-bar-map'." (let ((id (sxhash-eq tool-bar-map)) + (secondary-id (and secondary-tool-bar-map + (sxhash-eq secondary-tool-bar-map))) (entries nil)) (maphash (lambda (k _) - (when (equal (cdr k) id) + (when (or (equal (cdr k) id) + (equal (cdr k) secondary-id)) (push k entries))) tool-bar-keymap-cache) (dolist (k entries) @@ -107,14 +121,56 @@ functions.") (defun tool-bar-make-keymap (&optional _ignore) "Generate an actual keymap from `tool-bar-map'. +If `secondary-tool-bar-map' is non-nil, take it into account as well. Its main job is to figure out which images to use based on the display's color capability and based on the available image libraries." - (or (gethash (tool-bar--cache-key) tool-bar-keymap-cache) - (setf (gethash (tool-bar--cache-key) tool-bar-keymap-cache) - (tool-bar-make-keymap-1)))) - -(defun tool-bar-make-keymap-1 () - "Generate an actual keymap from `tool-bar-map', without caching." + (let* ((key (tool-bar--cache-key)) + (base-keymap + (or (gethash key tool-bar-keymap-cache) + (setf (gethash key tool-bar-keymap-cache) + (tool-bar-make-keymap-1)))) + (secondary-keymap + (and secondary-tool-bar-map + (or (gethash (tool-bar--secondary-cache-key) + tool-bar-keymap-cache) + (setf (gethash (tool-bar--secondary-cache-key) + tool-bar-keymap-cache) + (tool-bar-make-keymap-1 + secondary-tool-bar-map)))))) + (if secondary-keymap + (or (ignore-errors + (progn + ;; Determine the value of the `tool-bar-position' frame + ;; parameter. + (let ((position (frame-parameter nil 'tool-bar-position))) + (cond ((eq position 'top) + ;; Place `base-keymap' above `secondary-keymap'. + (append base-keymap (list (list (gensym) + 'menu-item + "" 'ignore + :wrap t)) + (cdr secondary-keymap))) + ((eq position 'bottom) + ;; Place `secondary-keymap' above `base-keymap'. + (append secondary-keymap (list (list (gensym) + 'menu-item + "" 'ignore + :wrap t)) + (cdr base-keymap))) + ;; If the tool bar position isn't known, don't + ;; display the secondary keymap at all. + (t base-keymap))))) + ;; If combining both keymaps fails, return the base + ;; keymap. + base-keymap) + base-keymap))) + +;; This function should return binds even if images can not be +;; displayed so the tool bar can still be displayed on terminals. +(defun tool-bar-make-keymap-1 (&optional map) + "Generate an actual keymap from `tool-bar-map', without caching. +MAP is either a keymap to use as a source for menu items, or nil, +in which case the value of `tool-bar-map' is used instead." (mapcar (lambda (bind) (let (image-exp plist) (when (and (eq (car-safe (cdr-safe bind)) 'menu-item) @@ -126,17 +182,16 @@ color capability and based on the available image libraries." (consp image-exp) (not (eq (car image-exp) 'image)) (fboundp (car image-exp))) - (if (not (display-images-p)) - (setq bind nil) - (let ((image (eval image-exp))) - (unless (and image (image-mask-p image)) - (setq image (append image '(:mask heuristic)))) - (setq bind (copy-sequence bind) - plist (nthcdr (if (consp (nth 4 bind)) 5 4) - bind)) - (plist-put plist :image image)))) + (let ((image (and (display-images-p) + (eval image-exp)))) + (unless (and image (image-mask-p image)) + (setq image (append image '(:mask heuristic)))) + (setq bind (copy-sequence bind) + plist (nthcdr (if (consp (nth 4 bind)) 5 4) + bind)) + (plist-put plist :image image))) bind)) - tool-bar-map)) + (or map tool-bar-map))) ;;;###autoload (defun tool-bar-add-item (icon def key &rest props) @@ -322,6 +377,207 @@ Customize `tool-bar-mode' if you want to show or hide the tool bar." (modify-all-frames-parameters (list (cons 'tool-bar-position val)))))) + + +;; Modifier bar mode. +;; This displays a small tool bar containing modifier keys +;; above or below the main tool bar itself. + +(defvar modifier-bar-modifier-list nil + "List of modifiers that are currently applied. +Each symbol in this list represents a modifier button that has +been pressed as part of decoding this key sequence.") + +(declare-function set-text-conversion-style "textconv.c") + +;; These functions are very similar to their counterparts in +;; simple.el, but allow combining multiple modifier buttons together. + +(defun tool-bar-apply-modifiers (event modifiers) + "Apply the specified list of MODIFIERS to EVENT. +MODIFIERS must be a list containing only the symbols `alt', +`super', `hyper', `shift', `control' and `meta'. +Return EVENT with the specified modifiers applied." + (dolist (modifier modifiers) + (cond + ((eq modifier 'alt) + (setq event (event-apply-modifier event 'alt 22 "A-"))) + ((eq modifier 'super) + (setq event (event-apply-modifier event 'super 23 "s-"))) + ((eq modifier 'hyper) + (setq event (event-apply-modifier event 'hyper 24 "H-"))) + ((eq modifier 'shift) + (setq event (event-apply-modifier event 'shift 25 "S-"))) + ((eq modifier 'control) + (setq event (event-apply-modifier event 'control 26 "C-"))) + ((eq modifier 'meta) + (setq event (event-apply-modifier event 'meta 27 "M-"))))) + event) + +(defvar overriding-text-conversion-style) + +(defun modifier-bar-button (init-modifier-list) + "Decode the key sequence associated with a modifier bar button. +INIT-MODIFIER-LIST is a list of one symbol describing the button +being pressed. + +Bind `modifier-bar-modifier-list' to INIT-MODIFIER-LIST. Read +events, adding each subsequent modifier bar event's associated +modifier to that list while updating the tool bar to disable +buttons that were pressed. Return any other event read with all +modifier keys read applied. + +Temporarily disable text conversion and display the on screen +keyboard while doing so." + ;; Save the previously used text conversion style. + (let ((old-text-conversion-style text-conversion-style) + ;; Clear the list of modifiers currently pressed. + (modifier-bar-modifier-list init-modifier-list)) + ;; Disable text conversion. + (when (fboundp 'set-text-conversion-style) + (set-text-conversion-style nil)) + (unwind-protect + (progn + ;; Display the on screen keyboard. + (frame-toggle-on-screen-keyboard nil nil) + ;; Update the tool bar to disable this modifier key. + (force-mode-line-update) + (let* ((modifiers init-modifier-list) event1 + (overriding-text-conversion-style nil) + (event (read-event))) + ;; Combine any more modifier key presses. + (while (eq event 'tool-bar) + (setq event1 (event-basic-type (read-event))) + ;; Reject unknown tool bar events. + (unless (memq event1 '(alt super hyper shift control meta)) + (user-error "Unknown tool-bar event %s" event1)) + ;; If `event' is the name of a modifier key, apply that + ;; modifier key as well. + (unless (memq event1 modifiers) + (push event1 modifiers) + ;; This list is used to check which tool bar buttons + ;; need to be enabled. + (push event1 modifier-bar-modifier-list)) + ;; Update the tool bar to disable the modifier button + ;; that was read. + (force-mode-line-update) + (redisplay) + ;; Read another event. + (setq event (read-event))) + ;; EVENT is a keyboard event to which the specified list of + ;; modifier keys should be applied. + (vector (tool-bar-apply-modifiers event modifiers)))) + ;; Re-enable text conversion if necessary. + (unless (or (not (fboundp 'set-text-conversion-style)) + (eq old-text-conversion-style text-conversion-style)) + (set-text-conversion-style old-text-conversion-style t)) + ;; Re-enable all modifier bar buttons which may have been + ;; disabled. + (force-mode-line-update)))) + +(defun tool-bar-event-apply-alt-modifier (_ignore-prompt) + "Like `event-apply-alt-modifier'. +However, take additional modifier tool bar items into account; +apply any extra modifiers bound to subsequent `tool-bar' events." + (modifier-bar-button '(alt))) + +(defun tool-bar-event-apply-super-modifier (_ignore-prompt) + "Like `event-apply-super-modifier'. +However, take additional modifier tool bar items into account; +apply any extra modifiers bound to subsequent `tool-bar' events." + (modifier-bar-button '(super))) + +(defun tool-bar-event-apply-hyper-modifier (_ignore-prompt) + "Like `event-apply-hyper-modifier'. +However, take additional modifier tool bar items into account; +apply any extra modifiers bound to subsequent `tool-bar' events." + (modifier-bar-button '(hyper))) + +(defun tool-bar-event-apply-shift-modifier (_ignore-prompt) + "Like `event-apply-shift-modifier'. +However, take additional modifier tool bar items into account; +apply any extra modifiers bound to subsequent `tool-bar' events." + (modifier-bar-button '(shift))) + +(defun tool-bar-event-apply-control-modifier (_ignore-prompt) + "Like `event-apply-control-modifier'. +However, take additional modifier tool bar items into account; +apply any extra modifiers bound to subsequent `tool-bar' events." + (modifier-bar-button '(control))) + +(defun tool-bar-event-apply-meta-modifier (_ignore-prompt) + "Like `event-apply-meta-modifier'. +However, take additional modifier tool bar items into account; +apply any extra modifiers bound to subsequent `tool-bar' events." + (modifier-bar-button '(meta))) + +(defun modifier-bar-available-p (modifier) + "Return whether the modifier button for MODIFIER should be enabled. +Return t if MODIFIER has not yet been selected as part of +decoding the current key sequence, nil otherwise." + (not (memq modifier modifier-bar-modifier-list))) + +(define-minor-mode modifier-bar-mode + "Toggle display of the modifier bar. + +When enabled, a small tool bar will be displayed next to the tool +bar containing items bound to +`tool-bar-event-apply-control-modifier' and its related commands, +which see." + :init-value nil + :global t + :group 'tool-bar + (if modifier-bar-mode + (progn + (setq secondary-tool-bar-map + ;; The commands specified in the menu items here are not + ;; used. Instead, Emacs relies on each of the tool bar + ;; events being specified in `input-decode-map'. + `(keymap (control menu-item "Control Key" + event-apply-control-modifier + :help "Add Control modifier to the following event" + :image ,(tool-bar--image-expression "ctrl") + :enable (modifier-bar-available-p 'control)) + (shift menu-item "Shift Key" + event-apply-shift-modifier + :help "Add Shift modifier to the following event" + :image ,(tool-bar--image-expression "shift") + :enable (modifier-bar-available-p 'shift)) + (meta menu-item "Meta Key" + event-apply-meta-modifier + :help "Add Meta modifier to the following event" + :image ,(tool-bar--image-expression "meta") + :enable (modifier-bar-available-p 'meta)) + (alt menu-item "Alt Key" + event-apply-alt-modifier + :help "Add Alt modifier to the following event" + :image ,(tool-bar--image-expression "alt") + :enable (modifier-bar-available-p 'alt)) + (super menu-item "Super Key" + event-apply-super-modifier + :help "Add Super modifier to the following event" + :image ,(tool-bar--image-expression "super") + :enable (modifier-bar-available-p 'super)) + (hyper menu-item "Hyper Key" + event-apply-hyper-modifier + :help "Add Hyper modifier to the following event" + :image ,(tool-bar--image-expression "hyper") + :enable (modifier-bar-available-p 'hyper)))) + (define-key input-decode-map [tool-bar control] + #'tool-bar-event-apply-control-modifier) + (define-key input-decode-map [tool-bar shift] + #'tool-bar-event-apply-shift-modifier) + (define-key input-decode-map [tool-bar meta] + #'tool-bar-event-apply-meta-modifier) + (define-key input-decode-map [tool-bar alt] + #'tool-bar-event-apply-alt-modifier) + (define-key input-decode-map [tool-bar super] + #'tool-bar-event-apply-super-modifier) + (define-key input-decode-map [tool-bar hyper] + #'tool-bar-event-apply-hyper-modifier)) + (setq secondary-tool-bar-map nil)) + ;; Update the mode line now. + (force-mode-line-update t)) (provide 'tool-bar) |