wayland.lisp (6171B)
1 (in-package #:net.entf.graphics/window/wayland) 2 3 (defclass wayland-backend (backend) 4 ((stop-requested? 5 :initform nil) 6 display 7 registry 8 compositor 9 xdg-wm-base 10 shm 11 (decoration-manager 12 :initform nil))) 13 14 (defun make-wayland-backend () 15 (make-instance 'wayland-backend)) 16 17 (defmethod queue-event ((backend wayland-backend) event-func) 18 (with-slots (display) 19 backend 20 (let ((callback (wl-display.sync display))) 21 (push (lambda (&rest event) 22 (declare (ignore event)) 23 (destroy-proxy callback) 24 (funcall event-func)) 25 (wl-proxy-hooks callback))))) 26 27 (defmethod handle-registry ((backend wayland-backend) event-type &rest event-data) 28 (with-slots (registry compositor xdg-wm-base shm decoration-manager) 29 backend 30 (ecase event-type 31 (:global 32 (format t "global: ~{~A ~}~%" event-data) 33 (a:when-let* ((interface (find-interface-named (second event-data))) 34 (interface-class (class-name interface))) 35 (labels ((bind (version) 36 (wl-registry.bind registry (first event-data) interface-class version))) 37 (format t "Interface found: ~A~%" interface-class) 38 (case interface-class 39 (wl-compositor 40 (setf compositor (bind 4))) 41 (xdg-wm-base 42 (setf xdg-wm-base (bind 2))) 43 (wl-shm 44 (setf shm (bind 1))) 45 (zxdg-decoration-manager-v1 46 (setf decoration-manager (bind 1)))))))))) 47 48 (defmethod start-event-loop ((backend wayland-backend) &key blocking?) 49 (declare (ignore blocking?)) 50 (with-slots (stop-requested? registry) 51 backend 52 (setf stop-requested? nil) 53 (with-open-display (display) 54 (setf (slot-value backend 'display) display) 55 (setf registry (wl-display.get-registry display)) 56 (push (a:curry 'handle-registry backend) (wl-proxy-hooks registry)) 57 (wl-display-roundtrip display) 58 (loop while (not stop-requested?) 59 do (wl-display-dispatch-event display)) 60 (format t "event loop shutdown~%")))) 61 62 (defmethod stop-event-loop ((backend wayland-backend)) 63 (with-slots (display stop-requested?) 64 backend 65 (queue-event backend (lambda () 66 (setf stop-requested? t))))) 67 68 (defclass wayland-shm-buffer () 69 ((width 70 :initarg :width) 71 (height 72 :initarg :height) 73 length 74 shm 75 mmap 76 buffer)) 77 78 (defmethod allocate-shm ((shm-buffer wayland-shm-buffer) wl-shm) 79 (with-slots (shm mmap buffer width height length) 80 shm-buffer 81 (let ((stride (* width 4))) 82 (setf length (* stride height)) 83 (setf shm (shm:open-shm* :direction :io)) 84 (shm:truncate-shm shm length) 85 (setf mmap (shm:mmap-shm shm length)) 86 (with-proxy (pool (wl-shm.create-pool wl-shm (shm:shm-fd shm) length)) 87 (setf buffer (wl-shm-pool.create-buffer pool 0 width height stride :xrgb8888)))))) 88 89 (defmethod free-shm-buffer ((shm-buffer wayland-shm-buffer)) 90 (with-slots (mmap shm length buffer) 91 shm-buffer 92 (shm:munmap mmap length) 93 (shm:close-shm shm) 94 (wl-buffer.destroy buffer))) 95 96 (defclass wayland-window (window) 97 ((backend 98 :initarg :backend) 99 (buffer 100 :initform nil) 101 surface 102 xdg-surface 103 xdg-toplevel 104 (xdg-decoration 105 :initform nil))) 106 107 (defmethod allocate-buffer ((window wayland-window)) 108 (with-slots (backend buffer) 109 window 110 (with-slots (shm) 111 backend 112 (when buffer 113 (free-shm-buffer buffer)) 114 (setf buffer (make-instance 'wayland-shm-buffer 115 :width (first (window-size window)) 116 :height (second (window-size window)))) 117 (allocate-shm buffer shm)))) 118 119 (defmethod make-window ((backend wayland-backend) 120 &key 121 (title "New Window") 122 (app-id (format nil "net.entf.graphics-~A" (+ (random 99) 100))) 123 (requested-size (list 300 300)) 124 &allow-other-keys) 125 (with-slots (compositor xdg-wm-base decoration-manager) 126 backend 127 (let ((window (make-instance 'wayland-window 128 :backend backend 129 :title title 130 :app-id app-id 131 :size requested-size))) 132 (with-slots (buffer surface xdg-surface xdg-toplevel xdg-decoration) 133 window 134 (setf surface (wl-compositor.create-surface compositor) 135 xdg-surface (xdg-wm-base.get-xdg-surface xdg-wm-base surface) 136 xdg-toplevel (xdg-surface.get-toplevel xdg-surface)) 137 (push (evlambda 138 (:configure 139 (serial) 140 (xdg-surface.ack-configure xdg-surface serial) 141 (let ((buffer (allocate-buffer window))) 142 (wl-surface.attach surface buffer 0 0) 143 (wl-surface.commit surface)))) 144 (wl-proxy-hooks xdg-surface)) 145 (push (evlambda 146 (:configure 147 (new-width new-height states) 148 (declare (ignore states)) 149 (if (or (zerop new-width) (zerop new-height)) 150 (setf (window-size window) requested-size) 151 (setf (window-size window) (list new-width new-height)))) 152 (:close 153 () 154 (when xdg-decoration 155 (zxdg-toplevel-decoration-v1.destroy xdg-decoration)) 156 (xdg-toplevel.destroy xdg-toplevel) 157 (xdg-surface.destroy xdg-surface) 158 (free-shm-buffer buffer))) 159 (wl-proxy-hooks xdg-toplevel)) 160 (xdg-toplevel.set-title xdg-toplevel title) 161 (xdg-toplevel.set-app-id xdg-toplevel app-id) 162 (when decoration-manager 163 (setf xdg-decoration (zxdg-decoration-manager-v1.get-toplevel-decoration 164 decoration-manager xdg-toplevel)) 165 (zxdg-toplevel-decoration-v1.set-mode xdg-decoration :server-side)) 166 (wl-surface.commit surface)) 167 window)))