commit 25e295bcb3df3888109fa1dae32b464bec6c9db1 Author: Lukas Henkel <lh@entf.net> Date: Sat, 16 Dec 2023 08:49:44 +0100 Initial commit Diffstat:
| A | net.entf.graphics.asd | | | 26 | ++++++++++++++++++++++++++ |
| A | window/package.lisp | | | 5 | +++++ |
| A | window/protocol.lisp | | | 46 | ++++++++++++++++++++++++++++++++++++++++++++++ |
| A | window/wayland/package.lisp | | | 11 | +++++++++++ |
| A | window/wayland/protocols.lisp | | | 5 | +++++ |
| A | window/wayland/wayland-protocols/xdg-decoration-unstable-v1.xml | | | 156 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | window/wayland/wayland.lisp | | | 167 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
7 files changed, 416 insertions(+), 0 deletions(-)
diff --git a/net.entf.graphics.asd b/net.entf.graphics.asd @@ -0,0 +1,26 @@ +(defsystem "net.entf.graphics" + :depends-on ("net.entf.graphics/window")) + +(defsystem "net.entf.graphics/window" + :pathname #P"window/" + :depends-on ("net.entf.graphics/window/wayland") + :components ((:file "package"))) + +(defsystem "net.entf.graphics/window/protocol" + :pathname #P"window/" + :depends-on ("bordeaux-threads") + :components ((:file "protocol"))) + +(defsystem "net.entf.graphics/window/wayland" + :pathname #P"window/wayland/" + :depends-on ("net.entf.graphics/window/protocol" + "wayflan" + "alexandria" + "posix-shm") + :components ((:file "package") + (:file "protocols" + :depends-on ("package")) + (:file "wayland" + :depends-on ("package" "protocols")) + (:module "wayland-protocols" + :components ((:static-file "xdg-decoration-unstable-v1.xml"))))) diff --git a/window/package.lisp b/window/package.lisp @@ -0,0 +1,5 @@ +(uiop:define-package #:net.entf.graphics/window/all + (:use #:cl #:net.entf.graphics/window/wayland) + (:nicknames #:net.entf.graphics/window) + (:use-reexport #:net.entf.graphics/window/protocol)) +(in-package #:net.entf.graphics/window/all) diff --git a/window/protocol.lisp b/window/protocol.lisp @@ -0,0 +1,46 @@ +(uiop:define-package #:net.entf.graphics/window/protocol + (:use #:cl) + (:import-from #:bordeaux-threads) + (:export + #:backend + #:start-event-loop + #:stop-event-loop + #:window + #:window-title + #:window-app-id + #:window-size + #:make-window)) +(in-package #:net.entf.graphics/window/protocol) + +(defclass backend () + ((event-loop-thread + :accessor event-loop-thread))) + +(defgeneric start-event-loop (backend &key blocking?)) + +(defmethod start-event-loop :around ((backend backend) &key blocking?) + (if blocking? + (prog1 + (setf (event-loop-thread backend) (bt2:current-thread)) + (call-next-method backend :blocking? blocking?)) + (bt2:make-thread (lambda () + (start-event-loop backend :blocking? t)) + :name (format nil "net.entf.graphics/window event loop for ~A" backend)))) + +(defgeneric stop-event-loop (backend)) + +(defclass window () + ((title + :initarg :title + :accessor window-title) + (app-id + :initarg :app-id + :accessor window-app-id) + (size + :initarg :size + :accessor window-size))) + +(defgeneric make-window (backend &key title app-id size &allow-other-keys)) + +(defgeneric window-minimize (window)) +(defgeneric window-maximize (window)) diff --git a/window/wayland/package.lisp b/window/wayland/package.lisp @@ -0,0 +1,11 @@ +(defpackage #:net.entf.graphics/window/wayland/protocols + (:use #:cl #:wayflan-client.xdg-shell)) + +(defpackage #:net.entf.graphics/window/wayland + (:use #:cl #:net.entf.graphics/window/protocol + #:wayflan-client #:wayflan-client.xdg-shell + #:net.entf.graphics/window/wayland/protocols) + (:local-nicknames (#:a #:alexandria) + (#:shm #:posix-shm)) + (:export + #:make-wayland-backend)) diff --git a/window/wayland/protocols.lisp b/window/wayland/protocols.lisp @@ -0,0 +1,5 @@ +(in-package #:net.entf.graphics/window/wayland/protocols) + +(xyz.shunter.wayflan.client.scanner:wl-include + '("net.entf.graphics/window/wayland" "wayland-protocols" "xdg-decoration-unstable-v1.xml") + :export t) diff --git a/window/wayland/wayland-protocols/xdg-decoration-unstable-v1.xml b/window/wayland/wayland-protocols/xdg-decoration-unstable-v1.xml @@ -0,0 +1,156 @@ +<?xml version="1.0" encoding="UTF-8"?> +<protocol name="xdg_decoration_unstable_v1"> + <copyright> + Copyright © 2018 Simon Ser + + Permission is hereby granted, free of charge, to any person obtaining a + copy of this software and associated documentation files (the "Software"), + to deal in the Software without restriction, including without limitation + the rights to use, copy, modify, merge, publish, distribute, sublicense, + and/or sell copies of the Software, and to permit persons to whom the + Software is furnished to do so, subject to the following conditions: + + The above copyright notice and this permission notice (including the next + paragraph) shall be included in all copies or substantial portions of the + Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL + THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING + FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER + DEALINGS IN THE SOFTWARE. + </copyright> + + <interface name="zxdg_decoration_manager_v1" version="1"> + <description summary="window decoration manager"> + This interface allows a compositor to announce support for server-side + decorations. + + A window decoration is a set of window controls as deemed appropriate by + the party managing them, such as user interface components used to move, + resize and change a window's state. + + A client can use this protocol to request being decorated by a supporting + compositor. + + If compositor and client do not negotiate the use of a server-side + decoration using this protocol, clients continue to self-decorate as they + see fit. + + Warning! The protocol described in this file is experimental and + backward incompatible changes may be made. Backward compatible changes + may be added together with the corresponding interface version bump. + Backward incompatible changes are done by bumping the version number in + the protocol and interface names and resetting the interface version. + Once the protocol is to be declared stable, the 'z' prefix and the + version number in the protocol and interface names are removed and the + interface version number is reset. + </description> + + <request name="destroy" type="destructor"> + <description summary="destroy the decoration manager object"> + Destroy the decoration manager. This doesn't destroy objects created + with the manager. + </description> + </request> + + <request name="get_toplevel_decoration"> + <description summary="create a new toplevel decoration object"> + Create a new decoration object associated with the given toplevel. + + Creating an xdg_toplevel_decoration from an xdg_toplevel which has a + buffer attached or committed is a client error, and any attempts by a + client to attach or manipulate a buffer prior to the first + xdg_toplevel_decoration.configure event must also be treated as + errors. + </description> + <arg name="id" type="new_id" interface="zxdg_toplevel_decoration_v1"/> + <arg name="toplevel" type="object" interface="xdg_toplevel"/> + </request> + </interface> + + <interface name="zxdg_toplevel_decoration_v1" version="1"> + <description summary="decoration object for a toplevel surface"> + The decoration object allows the compositor to toggle server-side window + decorations for a toplevel surface. The client can request to switch to + another mode. + + The xdg_toplevel_decoration object must be destroyed before its + xdg_toplevel. + </description> + + <enum name="error"> + <entry name="unconfigured_buffer" value="0" + summary="xdg_toplevel has a buffer attached before configure"/> + <entry name="already_constructed" value="1" + summary="xdg_toplevel already has a decoration object"/> + <entry name="orphaned" value="2" + summary="xdg_toplevel destroyed before the decoration object"/> + </enum> + + <request name="destroy" type="destructor"> + <description summary="destroy the decoration object"> + Switch back to a mode without any server-side decorations at the next + commit. + </description> + </request> + + <enum name="mode"> + <description summary="window decoration modes"> + These values describe window decoration modes. + </description> + <entry name="client_side" value="1" + summary="no server-side window decoration"/> + <entry name="server_side" value="2" + summary="server-side window decoration"/> + </enum> + + <request name="set_mode"> + <description summary="set the decoration mode"> + Set the toplevel surface decoration mode. This informs the compositor + that the client prefers the provided decoration mode. + + After requesting a decoration mode, the compositor will respond by + emitting an xdg_surface.configure event. The client should then update + its content, drawing it without decorations if the received mode is + server-side decorations. The client must also acknowledge the configure + when committing the new content (see xdg_surface.ack_configure). + + The compositor can decide not to use the client's mode and enforce a + different mode instead. + + Clients whose decoration mode depend on the xdg_toplevel state may send + a set_mode request in response to an xdg_surface.configure event and wait + for the next xdg_surface.configure event to prevent unwanted state. + Such clients are responsible for preventing configure loops and must + make sure not to send multiple successive set_mode requests with the + same decoration mode. + </description> + <arg name="mode" type="uint" enum="mode" summary="the decoration mode"/> + </request> + + <request name="unset_mode"> + <description summary="unset the decoration mode"> + Unset the toplevel surface decoration mode. This informs the compositor + that the client doesn't prefer a particular decoration mode. + + This request has the same semantics as set_mode. + </description> + </request> + + <event name="configure"> + <description summary="notify a decoration mode change"> + The configure event configures the effective decoration mode. The + configured state should not be applied immediately. Clients must send an + ack_configure in response to this event. See xdg_surface.configure and + xdg_surface.ack_configure for details. + + A configure event can be sent at any time. The specified mode must be + obeyed by the client. + </description> + <arg name="mode" type="uint" enum="mode" summary="the decoration mode"/> + </event> + </interface> +</protocol> diff --git a/window/wayland/wayland.lisp b/window/wayland/wayland.lisp @@ -0,0 +1,167 @@ +(in-package #:net.entf.graphics/window/wayland) + +(defclass wayland-backend (backend) + ((stop-requested? + :initform nil) + display + registry + compositor + xdg-wm-base + shm + (decoration-manager + :initform nil))) + +(defun make-wayland-backend () + (make-instance 'wayland-backend)) + +(defmethod queue-event ((backend wayland-backend) event-func) + (with-slots (display) + backend + (let ((callback (wl-display.sync display))) + (push (lambda (&rest event) + (declare (ignore event)) + (destroy-proxy callback) + (funcall event-func)) + (wl-proxy-hooks callback))))) + +(defmethod handle-registry ((backend wayland-backend) event-type &rest event-data) + (with-slots (registry compositor xdg-wm-base shm decoration-manager) + backend + (ecase event-type + (:global + (format t "global: ~{~A ~}~%" event-data) + (a:when-let* ((interface (find-interface-named (second event-data))) + (interface-class (class-name interface))) + (labels ((bind (version) + (wl-registry.bind registry (first event-data) interface-class version))) + (format t "Interface found: ~A~%" interface-class) + (case interface-class + (wl-compositor + (setf compositor (bind 4))) + (xdg-wm-base + (setf xdg-wm-base (bind 2))) + (wl-shm + (setf shm (bind 1))) + (zxdg-decoration-manager-v1 + (setf decoration-manager (bind 1)))))))))) + +(defmethod start-event-loop ((backend wayland-backend) &key blocking?) + (declare (ignore blocking?)) + (with-slots (stop-requested? registry) + backend + (setf stop-requested? nil) + (with-open-display (display) + (setf (slot-value backend 'display) display) + (setf registry (wl-display.get-registry display)) + (push (a:curry 'handle-registry backend) (wl-proxy-hooks registry)) + (wl-display-roundtrip display) + (loop while (not stop-requested?) + do (wl-display-dispatch-event display)) + (format t "event loop shutdown~%")))) + +(defmethod stop-event-loop ((backend wayland-backend)) + (with-slots (display stop-requested?) + backend + (queue-event backend (lambda () + (setf stop-requested? t))))) + +(defclass wayland-shm-buffer () + ((width + :initarg :width) + (height + :initarg :height) + length + shm + mmap + buffer)) + +(defmethod allocate-shm ((shm-buffer wayland-shm-buffer) wl-shm) + (with-slots (shm mmap buffer width height length) + shm-buffer + (let ((stride (* width 4))) + (setf length (* stride height)) + (setf shm (shm:open-shm* :direction :io)) + (shm:truncate-shm shm length) + (setf mmap (shm:mmap-shm shm length)) + (with-proxy (pool (wl-shm.create-pool wl-shm (shm:shm-fd shm) length)) + (setf buffer (wl-shm-pool.create-buffer pool 0 width height stride :xrgb8888)))))) + +(defmethod free-shm-buffer ((shm-buffer wayland-shm-buffer)) + (with-slots (mmap shm length buffer) + shm-buffer + (shm:munmap mmap length) + (shm:close-shm shm) + (wl-buffer.destroy buffer))) + +(defclass wayland-window (window) + ((backend + :initarg :backend) + (buffer + :initform nil) + surface + xdg-surface + xdg-toplevel + (xdg-decoration + :initform nil))) + +(defmethod allocate-buffer ((window wayland-window)) + (with-slots (backend buffer) + window + (with-slots (shm) + backend + (when buffer + (free-shm-buffer buffer)) + (setf buffer (make-instance 'wayland-shm-buffer + :width (first (window-size window)) + :height (second (window-size window)))) + (allocate-shm buffer shm)))) + +(defmethod make-window ((backend wayland-backend) + &key + (title "New Window") + (app-id (format nil "net.entf.graphics-~A" (+ (random 99) 100))) + (requested-size (list 300 300)) + &allow-other-keys) + (with-slots (compositor xdg-wm-base decoration-manager) + backend + (let ((window (make-instance 'wayland-window + :backend backend + :title title + :app-id app-id + :size requested-size))) + (with-slots (buffer surface xdg-surface xdg-toplevel xdg-decoration) + window + (setf surface (wl-compositor.create-surface compositor) + xdg-surface (xdg-wm-base.get-xdg-surface xdg-wm-base surface) + xdg-toplevel (xdg-surface.get-toplevel xdg-surface)) + (push (evlambda + (:configure + (serial) + (xdg-surface.ack-configure xdg-surface serial) + (let ((buffer (allocate-buffer window))) + (wl-surface.attach surface buffer 0 0) + (wl-surface.commit surface)))) + (wl-proxy-hooks xdg-surface)) + (push (evlambda + (:configure + (new-width new-height states) + (declare (ignore states)) + (if (or (zerop new-width) (zerop new-height)) + (setf (window-size window) requested-size) + (setf (window-size window) (list new-width new-height)))) + (:close + () + (when xdg-decoration + (zxdg-toplevel-decoration-v1.destroy xdg-decoration)) + (xdg-toplevel.destroy xdg-toplevel) + (xdg-surface.destroy xdg-surface) + (free-shm-buffer buffer))) + (wl-proxy-hooks xdg-toplevel)) + (xdg-toplevel.set-title xdg-toplevel title) + (xdg-toplevel.set-app-id xdg-toplevel app-id) + (when decoration-manager + (setf xdg-decoration (zxdg-decoration-manager-v1.get-toplevel-decoration + decoration-manager xdg-toplevel)) + (zxdg-toplevel-decoration-v1.set-mode xdg-decoration :server-side)) + (wl-surface.commit surface)) + window)))