diff options
Diffstat (limited to 'third_party/exwm/exwm-systemtray.el')
| -rw-r--r-- | third_party/exwm/exwm-systemtray.el | 276 |
1 files changed, 195 insertions, 81 deletions
diff --git a/third_party/exwm/exwm-systemtray.el b/third_party/exwm/exwm-systemtray.el index 43b3e1eaef..9e57dae4eb 100644 --- a/third_party/exwm/exwm-systemtray.el +++ b/third_party/exwm/exwm-systemtray.el @@ -1,7 +1,7 @@ ;;; exwm-systemtray.el --- System Tray Module for -*- lexical-binding: t -*- ;;; EXWM -;; Copyright (C) 2016-2021 Free Software Foundation, Inc. +;; Copyright (C) 2016-2024 Free Software Foundation, Inc. ;; Author: Chris Feng <chris.w.feng@gmail.com> @@ -30,6 +30,7 @@ ;;; Code: +(require 'xcb-ewmh) (require 'xcb-icccm) (require 'xcb-xembed) (require 'xcb-systemtray) @@ -37,6 +38,8 @@ (require 'exwm-core) (require 'exwm-workspace) +(declare-function exwm-workspace--workarea "exwm-workspace.el" (frame)) + (defclass exwm-systemtray--icon () ((width :initarg :width) (height :initarg :height) @@ -46,7 +49,7 @@ (defclass xcb:systemtray:-ClientMessage (xcb:icccm:--ClientMessage xcb:ClientMessage) ((format :initform 32) - (type :initform xcb:Atom:MANAGER) + (type :initform 'xcb:Atom:MANAGER) (time :initarg :time :type xcb:TIMESTAMP) ;new slot (selection :initarg :selection :type xcb:ATOM) ;new slot (owner :initarg :owner :type xcb:WINDOW)) ;new slot @@ -54,7 +57,6 @@ (defgroup exwm-systemtray nil "System tray." - :version "25.3" :group 'exwm) (defcustom exwm-systemtray-height nil @@ -67,44 +69,49 @@ You shall use the default value if using auto-hide minibuffer." "Gap between icons." :type 'integer) +(defvar exwm-systemtray--connection nil "The X connection.") + (defvar exwm-systemtray--embedder-window nil "The embedder window.") +(defvar exwm-systemtray--embedder-window-depth nil + "The embedder window's depth.") -(defcustom exwm-systemtray-background-color nil +(defcustom exwm-systemtray-background-color 'workspace-background "Background color of systemtray. - -This should be a color, or nil for transparent background." - :type '(choice (const :tag "Transparent" nil) - (color)) +This should be a color, the symbol `workspace-background' for the background +color of current workspace frame, or the symbol `transparent' for transparent +background. + +Transparent background is not yet supported when Emacs uses 32-bit depth +visual, as reported by `x-display-planes'. The X resource \"Emacs.visualClass: +TrueColor-24\" can be used to force Emacs to use 24-bit depth." + :type '(choice (const :tag "Transparent" transparent) + (const :tag "Frame background" workspace-background) + (color :tag "Color")) :initialize #'custom-initialize-default :set (lambda (symbol value) + (when (and (eq value 'transparent) + (not (exwm-systemtray--transparency-supported-p))) + (display-warning 'exwm-systemtray + "Transparent background is not supported yet when \ +using 32-bit depth. Using `workspace-background' instead.") + (setq value 'workspace-background)) (set-default symbol value) - ;; Change the background color for embedder. - (when (and exwm--connection + (when (and exwm-systemtray--connection exwm-systemtray--embedder-window) - (let ((background-pixel (exwm--color->pixel value))) - (xcb:+request exwm--connection - (make-instance 'xcb:ChangeWindowAttributes - :window exwm-systemtray--embedder-window - :value-mask (logior xcb:CW:BackPixmap - (if background-pixel - xcb:CW:BackPixel 0)) - :background-pixmap - xcb:BackPixmap:ParentRelative - :background-pixel background-pixel)) - ;; Unmap & map to take effect immediately. - (xcb:+request exwm--connection - (make-instance 'xcb:UnmapWindow - :window exwm-systemtray--embedder-window)) - (xcb:+request exwm--connection - (make-instance 'xcb:MapWindow - :window exwm-systemtray--embedder-window)) - (xcb:flush exwm--connection))))) + ;; Change the background color for embedder. + (exwm-systemtray--set-background-color) + ;; Unmap & map to take effect immediately. + (xcb:+request exwm-systemtray--connection + (make-instance 'xcb:UnmapWindow + :window exwm-systemtray--embedder-window)) + (xcb:+request exwm-systemtray--connection + (make-instance 'xcb:MapWindow + :window exwm-systemtray--embedder-window)) + (xcb:flush exwm-systemtray--connection)))) ;; GTK icons require at least 16 pixels to show normally. (defconst exwm-systemtray--icon-min-size 16 "Minimum icon size.") -(defvar exwm-systemtray--connection nil "The X connection.") - (defvar exwm-systemtray--list nil "The icon list.") (defvar exwm-systemtray--selection-owner-window nil @@ -113,7 +120,7 @@ This should be a color, or nil for transparent background." (defvar xcb:Atom:_NET_SYSTEM_TRAY_S0) (defun exwm-systemtray--embed (icon) - "Embed an icon." + "Embed an ICON." (exwm--log "Try to embed #x%x" icon) (let ((info (xcb:+request-unchecked+reply exwm-systemtray--connection (make-instance 'xcb:xembed:get-_XEMBED_INFO @@ -202,7 +209,7 @@ This should be a color, or nil for transparent background." (exwm-systemtray--refresh)))) (defun exwm-systemtray--unembed (icon) - "Unembed an icon." + "Unembed an ICON." (exwm--log "Unembed #x%x" icon) (xcb:+request exwm-systemtray--connection (make-instance 'xcb:UnmapWindow :window icon)) @@ -234,14 +241,13 @@ This should be a color, or nil for transparent background." (setq x (+ x (slot-value (cdr pair) 'width) exwm-systemtray-icon-gap)) (setq map t))) - (let ((workarea (elt exwm-workspace--workareas - exwm-workspace-current-index))) + (let ((workarea (exwm-workspace--workarea exwm-workspace-current-index))) (xcb:+request exwm-systemtray--connection (make-instance 'xcb:ConfigureWindow :window exwm-systemtray--embedder-window :value-mask (logior xcb:ConfigWindow:X xcb:ConfigWindow:Width) - :x (- (aref workarea 2) x) + :x (- (slot-value workarea 'width) x) :width x))) (when map (xcb:+request exwm-systemtray--connection @@ -249,8 +255,83 @@ This should be a color, or nil for transparent background." :window exwm-systemtray--embedder-window)))) (xcb:flush exwm-systemtray--connection)) +(defun exwm-systemtray--refresh-background-color (&optional remap) + "Refresh background color after theme change or workspace switch. +If REMAP is not nil, map and unmap the embedder window so that the background is +redrawn." + ;; Only `workspace-background' is dependent on current theme and workspace. + (when (eq 'workspace-background exwm-systemtray-background-color) + (exwm-systemtray--set-background-color) + (when remap + (xcb:+request exwm-systemtray--connection + (make-instance 'xcb:UnmapWindow + :window exwm-systemtray--embedder-window)) + (xcb:+request exwm-systemtray--connection + (make-instance 'xcb:MapWindow + :window exwm-systemtray--embedder-window)) + (xcb:flush exwm-systemtray--connection)))) + +(defun exwm-systemtray--set-background-color () + "Change the background color of the embedder. +The color is set according to `exwm-systemtray-background-color'. + +Note that this function does not change the current contents of the embedder +window; unmap & map are necessary for the background color to take effect." + (when (and exwm-systemtray--connection + exwm-systemtray--embedder-window) + (let* ((color (cl-case exwm-systemtray-background-color + ((transparent nil) ; nil means transparent as well + (if (exwm-systemtray--transparency-supported-p) + nil + (message "%s" "[EXWM] system tray does not support \ +`transparent' background; using `workspace-background' instead") + (face-background 'default exwm-workspace--current))) + (workspace-background + (face-background 'default exwm-workspace--current)) + (t exwm-systemtray-background-color))) + (background-pixel (exwm--color->pixel color))) + (xcb:+request exwm-systemtray--connection + (make-instance 'xcb:ChangeWindowAttributes + :window exwm-systemtray--embedder-window + ;; Either-or. A `background-pixel' of nil + ;; means simulate transparency. We use + ;; `xcb:CW:BackPixmap' together with + ;; `xcb:BackPixmap:ParentRelative' do that, + ;; but this only works when the parent + ;; window's visual (Emacs') has the same + ;; visual depth. + :value-mask (if background-pixel + xcb:CW:BackPixel + xcb:CW:BackPixmap) + ;; Due to the :value-mask above, + ;; :background-pixmap only takes effect when + ;; `transparent' is requested and supported + ;; (visual depth of Emacs and of system tray + ;; are equal). Setting + ;; `xcb:BackPixmap:ParentRelative' when + ;; that's not the case would produce an + ;; `xcb:Match' error. + :background-pixmap xcb:BackPixmap:ParentRelative + :background-pixel background-pixel))))) + +(defun exwm-systemtray--transparency-supported-p () + "Check whether transparent background is supported. +EXWM system tray supports transparency when the visual depth of the system tray +window matches that of Emacs. The visual depth of the system tray window is the +default visual depth of the display. + +Sections \"Visual and background pixmap handling\" and +\"_NET_SYSTEM_TRAY_VISUAL\" of the System Tray Protocol Specification +\(https://specifications.freedesktop.org/systemtray-spec/systemtray-spec-latest.html#visuals) +indicate how to support actual transparency." + (let ((planes (x-display-planes))) + (if exwm-systemtray--embedder-window-depth + (= planes exwm-systemtray--embedder-window-depth) + (<= planes 24)))) + (defun exwm-systemtray--on-DestroyNotify (data _synthetic) - "Unembed icons on DestroyNotify." + "Unembed icons on DestroyNotify. +Argument DATA contains the raw event data." (exwm--log) (let ((obj (make-instance 'xcb:DestroyNotify))) (xcb:unmarshal obj data) @@ -259,7 +340,8 @@ This should be a color, or nil for transparent background." (exwm-systemtray--unembed window))))) (defun exwm-systemtray--on-ReparentNotify (data _synthetic) - "Unembed icons on ReparentNotify." + "Unembed icons on ReparentNotify. +Argument DATA contains the raw event data." (exwm--log) (let ((obj (make-instance 'xcb:ReparentNotify))) (xcb:unmarshal obj data) @@ -269,7 +351,8 @@ This should be a color, or nil for transparent background." (exwm-systemtray--unembed window))))) (defun exwm-systemtray--on-ResizeRequest (data _synthetic) - "Resize the tray icon on ResizeRequest." + "Resize the tray icon on ResizeRequest. +Argument DATA contains the raw event data." (exwm--log) (let ((obj (make-instance 'xcb:ResizeRequest)) attr) @@ -297,7 +380,8 @@ This should be a color, or nil for transparent background." (exwm-systemtray--refresh))))) (defun exwm-systemtray--on-PropertyNotify (data _synthetic) - "Map/Unmap the tray icon on PropertyNotify." + "Map/Unmap the tray icon on PropertyNotify. +Argument DATA contains the raw event data." (exwm--log) (let ((obj (make-instance 'xcb:PropertyNotify)) attr info visible) @@ -322,7 +406,8 @@ This should be a color, or nil for transparent background." (exwm-systemtray--refresh)))))) (defun exwm-systemtray--on-ClientMessage (data _synthetic) - "Handle client messages." + "Handle client messages. +Argument DATA contains the raw event data." (let ((obj (make-instance 'xcb:ClientMessage)) opcode data32) (xcb:unmarshal obj data) @@ -341,7 +426,8 @@ This should be a color, or nil for transparent background." (exwm--log "Unknown opcode message: %s" obj))))))) (defun exwm-systemtray--on-KeyPress (data _synthetic) - "Forward all KeyPress events to Emacs frame." + "Forward all KeyPress events to Emacs frame. +Argument DATA contains the raw event data." (exwm--log) ;; This function is only executed when there's no autohide minibuffer, ;; a workspace frame has the input focus and the pointer is over a @@ -370,13 +456,18 @@ This should be a color, or nil for transparent background." (frame-parameter exwm-workspace--current 'window-id)) :x 0 - :y (- (elt (elt exwm-workspace--workareas - exwm-workspace-current-index) - 3) + :y (- (slot-value (exwm-workspace--workarea + exwm-workspace-current-index) + 'height) exwm-workspace--frame-y-offset exwm-systemtray-height)))) + (exwm-systemtray--refresh-background-color) (exwm-systemtray--refresh)) +(defun exwm-systemtray--on-theme-change (_theme) + "Refresh system tray upon theme change." + (exwm-systemtray--refresh-background-color 'remap)) + (defun exwm-systemtray--refresh-all () "Reposition/Refresh the system tray." (exwm--log) @@ -386,9 +477,9 @@ This should be a color, or nil for transparent background." (make-instance 'xcb:ConfigureWindow :window exwm-systemtray--embedder-window :value-mask xcb:ConfigWindow:Y - :y (- (elt (elt exwm-workspace--workareas - exwm-workspace-current-index) - 3) + :y (- (slot-value (exwm-workspace--workarea + exwm-workspace-current-index) + 'height) exwm-workspace--frame-y-offset exwm-systemtray-height)))) (exwm-systemtray--refresh)) @@ -402,7 +493,8 @@ This should be a color, or nil for transparent background." (cl-assert (not exwm-systemtray--embedder-window)) (unless exwm-systemtray-height (setq exwm-systemtray-height (max exwm-systemtray--icon-min-size - (line-pixel-height)))) + (with-selected-window (minibuffer-window) + (line-pixel-height))))) ;; Create a new connection. (setq exwm-systemtray--connection (xcb:connect)) (set-process-query-on-exit-flag (slot-value exwm-systemtray--connection @@ -469,8 +561,7 @@ This should be a color, or nil for transparent background." :data xcb:systemtray:ORIENTATION:HORZ))) ;; Create the embedder. (let ((id (xcb:generate-id exwm-systemtray--connection)) - (background-pixel (exwm--color->pixel exwm-systemtray-background-color)) - frame parent depth y) + frame parent embedder-depth embedder-visual embedder-colormap y) (setq exwm-systemtray--embedder-window id) (if (exwm-workspace--minibuffer-own-frame-p) (setq frame exwm-workspace--minibuffer @@ -482,20 +573,26 @@ This should be a color, or nil for transparent background." (exwm-workspace--update-offsets) (setq frame exwm-workspace--current ;; Bottom aligned. - y (- (elt (elt exwm-workspace--workareas - exwm-workspace-current-index) - 3) + y (- (slot-value (exwm-workspace--workarea + exwm-workspace-current-index) + 'height) exwm-workspace--frame-y-offset exwm-systemtray-height))) - (setq parent (string-to-number (frame-parameter frame 'window-id)) - depth (slot-value (xcb:+request-unchecked+reply - exwm-systemtray--connection - (make-instance 'xcb:GetGeometry - :drawable parent)) - 'depth)) + (setq parent (string-to-number (frame-parameter frame 'window-id))) + ;; Use default depth, visual and colormap (from root window), instead of + ;; Emacs frame's. See Section "Visual and background pixmap handling" in + ;; "System Tray Protocol Specification 0.3". + (let* ((vdc (exwm--get-visual-depth-colormap exwm-systemtray--connection + exwm--root))) + (setq embedder-visual (car vdc)) + (setq embedder-depth (cadr vdc)) + (setq embedder-colormap (caddr vdc))) + ;; Note down the embedder window's depth. It will be used to check whether + ;; we can use xcb:BackPixmap:ParentRelative to emulate transparency. + (setq exwm-systemtray--embedder-window-depth embedder-depth) (xcb:+request exwm-systemtray--connection (make-instance 'xcb:CreateWindow - :depth depth + :depth embedder-depth :wid id :parent parent :x 0 @@ -504,19 +601,29 @@ This should be a color, or nil for transparent background." :height exwm-systemtray-height :border-width 0 :class xcb:WindowClass:InputOutput - :visual 0 - :value-mask (logior xcb:CW:BackPixmap - (if background-pixel - xcb:CW:BackPixel 0) + :visual embedder-visual + :colormap embedder-colormap + :value-mask (logior xcb:CW:BorderPixel + xcb:CW:Colormap xcb:CW:EventMask) - :background-pixmap xcb:BackPixmap:ParentRelative - :background-pixel background-pixel + :border-pixel 0 :event-mask xcb:EventMask:SubstructureNotify)) + (exwm-systemtray--set-background-color) ;; Set _NET_WM_NAME. (xcb:+request exwm-systemtray--connection (make-instance 'xcb:ewmh:set-_NET_WM_NAME :window id - :data "EXWM: exwm-systemtray--embedder-window"))) + :data "EXWM: exwm-systemtray--embedder-window")) + ;; Set _NET_WM_WINDOW_TYPE. + (xcb:+request exwm-systemtray--connection + (make-instance 'xcb:ewmh:set-_NET_WM_WINDOW_TYPE + :window id + :data (vector xcb:Atom:_NET_WM_WINDOW_TYPE_DOCK))) + ;; Set _NET_SYSTEM_TRAY_VISUAL. + (xcb:+request exwm-systemtray--connection + (make-instance 'xcb:xembed:set-_NET_SYSTEM_TRAY_VISUAL + :window exwm-systemtray--selection-owner-window + :data embedder-visual))) (xcb:flush exwm-systemtray--connection) ;; Attach event listeners. (xcb:+event exwm-systemtray--connection 'xcb:DestroyNotify @@ -536,6 +643,9 @@ This should be a color, or nil for transparent background." (add-hook 'exwm-workspace-switch-hook #'exwm-systemtray--on-workspace-switch) (add-hook 'exwm-workspace--update-workareas-hook #'exwm-systemtray--refresh-all) + ;; Add hook to update background colors. + (add-hook 'enable-theme-functions #'exwm-systemtray--on-theme-change) + (add-hook 'disable-theme-functions #'exwm-systemtray--on-theme-change) (add-hook 'menu-bar-mode-hook #'exwm-systemtray--refresh-all) (add-hook 'tool-bar-mode-hook #'exwm-systemtray--refresh-all) (when (boundp 'exwm-randr-refresh-hook) @@ -548,27 +658,31 @@ This should be a color, or nil for transparent background." "Exit the systemtray module." (exwm--log) (when exwm-systemtray--connection - ;; Hide & reparent out the embedder before disconnection to prevent - ;; embedded icons from being reparented to an Emacs frame (which is the - ;; parent of the embedder). - (xcb:+request exwm-systemtray--connection - (make-instance 'xcb:UnmapWindow - :window exwm-systemtray--embedder-window)) - (xcb:+request exwm-systemtray--connection - (make-instance 'xcb:ReparentWindow - :window exwm-systemtray--embedder-window - :parent exwm--root - :x 0 - :y 0)) - (xcb:disconnect exwm-systemtray--connection) + (when (slot-value exwm-systemtray--connection 'connected) + ;; Hide & reparent out the embedder before disconnection to prevent + ;; embedded icons from being reparented to an Emacs frame (which is the + ;; parent of the embedder). + (xcb:+request exwm-systemtray--connection + (make-instance 'xcb:UnmapWindow + :window exwm-systemtray--embedder-window)) + (xcb:+request exwm-systemtray--connection + (make-instance 'xcb:ReparentWindow + :window exwm-systemtray--embedder-window + :parent exwm--root + :x 0 + :y 0)) + (xcb:disconnect exwm-systemtray--connection)) (setq exwm-systemtray--connection nil exwm-systemtray--list nil exwm-systemtray--selection-owner-window nil - exwm-systemtray--embedder-window nil) + exwm-systemtray--embedder-window nil + exwm-systemtray--embedder-window-depth nil) (remove-hook 'exwm-workspace-switch-hook #'exwm-systemtray--on-workspace-switch) (remove-hook 'exwm-workspace--update-workareas-hook #'exwm-systemtray--refresh-all) + (remove-hook 'enable-theme-functions #'exwm-systemtray--on-theme-change) + (remove-hook 'disable-theme-functions #'exwm-systemtray--on-theme-change) (remove-hook 'menu-bar-mode-hook #'exwm-systemtray--refresh-all) (remove-hook 'tool-bar-mode-hook #'exwm-systemtray--refresh-all) (when (boundp 'exwm-randr-refresh-hook) |