1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
|
#!/usr/bin/env jolt
;; A Wayland compositor for wayland-bar, written in jolt on raw wlroots.
;;
;; It replaces the nested sway: one wlroots X11 output of the requested size,
;; layer-shell and xdg-shell surfaces drawn by the wlroots scene graph, pointer
;; and keyboard forwarded to them. Because it owns the scene, it knows where
;; every popup is, so it shapes its own X11 window (strip + popups) through
;; XShape directly — no screenshots, no polling.
;;
;; usage: wayland-bar-compositor --size WxH --strip X,Y,W,H --title TITLE -- CMD [ARGS...]
;;
;; Struct offsets come from offsets.edn, generated from the installed wlroots
;; headers by ./build. Single-threaded: every wlroots callback arrives on this
;; thread from inside wl_event_loop_dispatch.
(require '[jolt.ffi :as ffi]
'[babashka.fs :as fs]
'[babashka.process :as p]
'[clojure.edn :as edn]
'[clojure.string :as str])
(def here (str (fs/parent (fs/canonicalize *file*))))
(def debug? (some? (System/getenv "WBC_DEBUG")))
(defn debug [& parts]
(when debug?
(binding [*out* *err*] (apply println "wbc:" parts))))
(defn die [& msg]
(binding [*out* *err*] (apply println "wayland-bar-compositor:" msg))
(System/exit 1))
;; --- arguments ---------------------------------------------------------------
(defn parse-args [args]
(loop [[a b & more :as args] args opts {}]
(cond
(empty? args) opts
(= a "--") (assoc opts :command (vec (rest args)))
(= a "--size") (let [[w h] (map parse-long (str/split b #"x"))] (recur more (assoc opts :width w :height h)))
(= a "--strip") (recur more (assoc opts :strip (mapv parse-long (str/split b #","))))
(= a "--title") (recur more (assoc opts :title b))
(str/starts-with? a "--") (die "unknown argument" a)
;; jolt may consume a "--" itself, so the first non-option starts the command.
:else (assoc opts :command (vec args)))))
(def opts (parse-args *command-line-args*))
(let [{:keys [width height strip title command]} opts]
(when-not (and width height strip title (seq command))
(die "usage: --size WxH --strip X,Y,W,H --title TITLE -- CMD [ARGS...]")))
;; --- layout facts --------------------------------------------------------------
(def layout
(let [f (str here "/offsets.edn")]
(when-not (fs/exists? f) (die "missing" f "- run" (str here "/build")))
(edn/read-string (slurp f))))
(defn off [k]
(or (get layout k) (die "offsets.edn has no" k)))
;; --- libraries -----------------------------------------------------------------
(ffi/load-library "libc.so.6")
(ffi/load-library "libwayland-server.so.0")
(ffi/load-library "libxkbcommon.so.0")
(ffi/load-library "libwlroots-0.20.so")
(ffi/load-library "libX11.so.6")
(ffi/load-library "libXext.so.6")
(ffi/defcfn clock-gettime "clock_gettime" [:int :pointer] :int)
(ffi/defcfn wl-display-create "wl_display_create" [] :pointer)
(ffi/defcfn wl-display-get-event-loop "wl_display_get_event_loop" [:pointer] :pointer)
(ffi/defcfn wl-display-add-socket-auto "wl_display_add_socket_auto" [:pointer] :string)
(ffi/defcfn wl-display-flush-clients "wl_display_flush_clients" [:pointer] :void)
(ffi/defcfn wl-display-destroy-clients "wl_display_destroy_clients" [:pointer] :void)
(ffi/defcfn wl-event-loop-dispatch "wl_event_loop_dispatch" [:pointer :int] :int)
(ffi/defcfn wl-list-insert "wl_list_insert" [:pointer :pointer] :void)
(ffi/defcfn wl-list-remove "wl_list_remove" [:pointer] :void)
(ffi/defcfn xkb-context-new "xkb_context_new" [:int] :pointer)
(ffi/defcfn xkb-keymap-new-from-names "xkb_keymap_new_from_names" [:pointer :pointer :int] :pointer)
(ffi/defcfn xkb-keymap-unref "xkb_keymap_unref" [:pointer] :void)
(ffi/defcfn xkb-context-unref "xkb_context_unref" [:pointer] :void)
(ffi/defcfn backend-autocreate "wlr_backend_autocreate" [:pointer :pointer] :pointer)
(ffi/defcfn backend-start "wlr_backend_start" [:pointer] :bool)
(ffi/defcfn renderer-autocreate "wlr_renderer_autocreate" [:pointer] :pointer)
(ffi/defcfn renderer-init-wl-display "wlr_renderer_init_wl_display" [:pointer :pointer] :bool)
(ffi/defcfn allocator-autocreate "wlr_allocator_autocreate" [:pointer :pointer] :pointer)
(ffi/defcfn compositor-create "wlr_compositor_create" [:pointer :uint32 :pointer] :pointer)
(ffi/defcfn subcompositor-create "wlr_subcompositor_create" [:pointer] :pointer)
(ffi/defcfn data-device-manager-create "wlr_data_device_manager_create" [:pointer] :pointer)
(ffi/defcfn primary-selection-manager-create "wlr_primary_selection_v1_device_manager_create" [:pointer] :pointer)
(ffi/defcfn data-control-manager-create "wlr_data_control_manager_v1_create" [:pointer] :pointer)
(ffi/defcfn xdg-output-manager-create "wlr_xdg_output_manager_v1_create" [:pointer :pointer] :pointer)
(ffi/defcfn screencopy-manager-create "wlr_screencopy_manager_v1_create" [:pointer] :pointer)
(ffi/defcfn viewporter-create "wlr_viewporter_create" [:pointer] :pointer)
(ffi/defcfn fractional-scale-manager-create "wlr_fractional_scale_manager_v1_create" [:pointer :uint32] :pointer)
(ffi/defcfn single-pixel-buffer-manager-create "wlr_single_pixel_buffer_manager_v1_create" [:pointer] :pointer)
(ffi/defcfn presentation-create "wlr_presentation_create" [:pointer :pointer :uint32] :pointer)
(ffi/defcfn xdg-activation-create "wlr_xdg_activation_v1_create" [:pointer] :pointer)
(ffi/defcfn output-layout-create "wlr_output_layout_create" [:pointer] :pointer)
(ffi/defcfn output-layout-add-auto "wlr_output_layout_add_auto" [:pointer :pointer] :pointer)
(ffi/defcfn output-init-render "wlr_output_init_render" [:pointer :pointer :pointer] :bool)
(ffi/defcfn output-state-init "wlr_output_state_init" [:pointer] :void)
(ffi/defcfn output-state-finish "wlr_output_state_finish" [:pointer] :void)
(ffi/defcfn output-state-set-enabled "wlr_output_state_set_enabled" [:pointer :bool] :void)
(ffi/defcfn output-state-set-custom-mode "wlr_output_state_set_custom_mode" [:pointer :int32 :int32 :int32] :void)
(ffi/defcfn output-commit-state "wlr_output_commit_state" [:pointer :pointer] :bool)
(ffi/defcfn x11-output-set-title "wlr_x11_output_set_title" [:pointer :string] :void)
(ffi/defcfn output-is-x11 "wlr_output_is_x11" [:pointer] :bool)
(ffi/defcfn scene-create "wlr_scene_create" [] :pointer)
(ffi/defcfn scene-attach-output-layout "wlr_scene_attach_output_layout" [:pointer :pointer] :pointer)
(ffi/defcfn scene-output-create "wlr_scene_output_create" [:pointer :pointer] :pointer)
(ffi/defcfn scene-output-layout-add-output "wlr_scene_output_layout_add_output" [:pointer :pointer :pointer] :void)
(ffi/defcfn scene-output-needs-frame "wlr_scene_output_needs_frame" [:pointer] :bool)
(ffi/defcfn scene-output-build-state "wlr_scene_output_build_state" [:pointer :pointer :pointer] :bool)
(ffi/defcfn buffer-begin-data-ptr-access "wlr_buffer_begin_data_ptr_access" [:pointer :uint32 :pointer :pointer :pointer] :bool)
(ffi/defcfn buffer-end-data-ptr-access "wlr_buffer_end_data_ptr_access" [:pointer] :void)
(ffi/defcfn scene-output-send-frame-done "wlr_scene_output_send_frame_done" [:pointer :pointer] :void)
(ffi/defcfn scene-tree-create "wlr_scene_tree_create" [:pointer] :pointer)
(ffi/defcfn scene-node-at "wlr_scene_node_at" [:pointer :double :double :pointer :pointer] :pointer)
(ffi/defcfn scene-node-coords "wlr_scene_node_coords" [:pointer :pointer :pointer] :bool)
(ffi/defcfn scene-buffer-from-node "wlr_scene_buffer_from_node" [:pointer] :pointer)
(ffi/defcfn scene-surface-try-from-buffer "wlr_scene_surface_try_from_buffer" [:pointer] :pointer)
(ffi/defcfn scene-xdg-surface-create "wlr_scene_xdg_surface_create" [:pointer :pointer] :pointer)
(ffi/defcfn scene-layer-surface-create "wlr_scene_layer_surface_v1_create" [:pointer :pointer] :pointer)
(ffi/defcfn scene-layer-surface-configure "wlr_scene_layer_surface_v1_configure" [:pointer :pointer :pointer] :void)
(ffi/defcfn xdg-shell-create "wlr_xdg_shell_create" [:pointer :uint32] :pointer)
(ffi/defcfn xdg-surface-try-from-wlr-surface "wlr_xdg_surface_try_from_wlr_surface" [:pointer] :pointer)
(ffi/defcfn xdg-surface-schedule-configure "wlr_xdg_surface_schedule_configure" [:pointer] :uint32)
(ffi/defcfn xdg-toplevel-set-size "wlr_xdg_toplevel_set_size" [:pointer :int32 :int32] :uint32)
(ffi/defcfn xdg-popup-unconstrain-from-box "wlr_xdg_popup_unconstrain_from_box" [:pointer :pointer] :void)
(ffi/defcfn layer-shell-create "wlr_layer_shell_v1_create" [:pointer :uint32] :pointer)
(ffi/defcfn layer-surface-try-from-wlr-surface "wlr_layer_surface_v1_try_from_wlr_surface" [:pointer] :pointer)
(ffi/defcfn cursor-create "wlr_cursor_create" [] :pointer)
(ffi/defcfn cursor-attach-output-layout "wlr_cursor_attach_output_layout" [:pointer :pointer] :void)
(ffi/defcfn cursor-attach-input-device "wlr_cursor_attach_input_device" [:pointer :pointer] :void)
(ffi/defcfn cursor-move "wlr_cursor_move" [:pointer :pointer :double :double] :void)
(ffi/defcfn cursor-warp-absolute "wlr_cursor_warp_absolute" [:pointer :pointer :double :double] :void)
(ffi/defcfn cursor-set-xcursor "wlr_cursor_set_xcursor" [:pointer :pointer :string] :void)
(ffi/defcfn cursor-set-surface "wlr_cursor_set_surface" [:pointer :pointer :int32 :int32] :void)
(ffi/defcfn xcursor-manager-create "wlr_xcursor_manager_create" [:pointer :uint32] :pointer)
(ffi/defcfn seat-create "wlr_seat_create" [:pointer :string] :pointer)
(ffi/defcfn seat-set-capabilities "wlr_seat_set_capabilities" [:pointer :uint32] :void)
(ffi/defcfn seat-set-keyboard "wlr_seat_set_keyboard" [:pointer :pointer] :void)
(ffi/defcfn seat-set-selection "wlr_seat_set_selection" [:pointer :pointer :uint32] :void)
(ffi/defcfn seat-set-primary-selection "wlr_seat_set_primary_selection" [:pointer :pointer :uint32] :void)
(ffi/defcfn seat-pointer-notify-enter "wlr_seat_pointer_notify_enter" [:pointer :pointer :double :double] :void)
(ffi/defcfn seat-pointer-notify-motion "wlr_seat_pointer_notify_motion" [:pointer :uint32 :double :double] :void)
(ffi/defcfn seat-pointer-notify-button "wlr_seat_pointer_notify_button" [:pointer :uint32 :uint32 :int] :uint32)
(ffi/defcfn seat-pointer-notify-axis "wlr_seat_pointer_notify_axis" [:pointer :uint32 :int :double :int32 :int :int] :void)
(ffi/defcfn seat-pointer-notify-frame "wlr_seat_pointer_notify_frame" [:pointer] :void)
(ffi/defcfn seat-pointer-clear-focus "wlr_seat_pointer_clear_focus" [:pointer] :void)
(ffi/defcfn seat-keyboard-notify-enter "wlr_seat_keyboard_notify_enter" [:pointer :pointer :pointer :size_t :pointer] :void)
(ffi/defcfn seat-keyboard-notify-key "wlr_seat_keyboard_notify_key" [:pointer :uint32 :uint32 :uint32] :void)
(ffi/defcfn seat-keyboard-notify-modifiers "wlr_seat_keyboard_notify_modifiers" [:pointer :pointer] :void)
(ffi/defcfn keyboard-from-input-device "wlr_keyboard_from_input_device" [:pointer] :pointer)
(ffi/defcfn keyboard-set-keymap "wlr_keyboard_set_keymap" [:pointer :pointer] :bool)
(ffi/defcfn keyboard-set-repeat-info "wlr_keyboard_set_repeat_info" [:pointer :int32 :int32] :void)
(ffi/load-library "libXi.so.6")
(ffi/defcfn wl-event-loop-add-fd "wl_event_loop_add_fd" [:pointer :int :uint32 :pointer :pointer] :pointer)
(ffi/defcfn xdg-popup-destroy "wlr_xdg_popup_destroy" [:pointer] :void)
(ffi/defcfn x-query-extension "XQueryExtension" [:pointer :string :pointer :pointer :pointer] :int)
(ffi/defcfn xi-query-version "XIQueryVersion" [:pointer :pointer :pointer] :int)
(ffi/defcfn xi-select-events "XISelectEvents" [:pointer :long :pointer :int] :int)
(ffi/defcfn x-pending "XPending" [:pointer] :int)
(ffi/defcfn x-next-event "XNextEvent" [:pointer :pointer] :int)
(ffi/defcfn x-get-event-data "XGetEventData" [:pointer :pointer] :int)
(ffi/defcfn x-free-event-data "XFreeEventData" [:pointer :pointer] :void)
(ffi/defcfn x-query-pointer "XQueryPointer"
[:pointer :long :pointer :pointer :pointer :pointer :pointer :pointer :pointer] :int)
(ffi/defcfn x-default-root-window "XDefaultRootWindow" [:pointer] :long)
(ffi/defcfn x-connection-number "XConnectionNumber" [:pointer] :int)
(ffi/defcfn x-open-display "XOpenDisplay" [:pointer] :pointer)
(ffi/defcfn x-flush "XFlush" [:pointer] :int)
(ffi/defcfn x-shape-combine-rectangles "XShapeCombineRectangles"
[:pointer :long :int :int :int :pointer :int :int :int] :void)
;; --- memory helpers ---------------------------------------------------------------
(def arena (ffi/global-arena))
(defn ptr [p k] (ffi/read p :pointer (off k)))
(defn i32 [p k] (ffi/read p :int (off k)))
(defn u32 [p k] (ffi/read p :uint32 (off k)))
(defn f64 [p k] (ffi/read p :double (off k)))
(defn flag [p k] (not (zero? (ffi/read p :uint8 (off k)))))
(defn field [p k] (+ p (off k)))
;; Scratch buffers reused by every callback; this compositor is single-threaded.
(def out-a (ffi/alloc arena 8))
(def out-b (ffi/alloc arena 8))
(def box-buf (ffi/alloc arena (off :wlr_box/sizeof)))
(def usable-buf (ffi/alloc arena (off :wlr_box/sizeof)))
(def timespec (ffi/alloc arena (off :timespec/sizeof)))
(defn write-box! [buf x y w h]
(ffi/write buf :int x (off :wlr_box/x))
(ffi/write buf :int y (off :wlr_box/y))
(ffi/write buf :int w (off :wlr_box/width))
(ffi/write buf :int h (off :wlr_box/height))
buf)
;; --- signals ----------------------------------------------------------------------
;; wl_signal_add is a static inline in C. Every listener here shares ONE native
;; callback, which looks the listener's address up in `handlers`; listeners come
;; from a free list, so surfaces that come and go don't leak callbacks.
(def handlers (atom {}))
(def free-listeners (atom ()))
(defn- dispatch [listener data]
(when-let [f (get @handlers listener)]
(try (f data)
(catch Throwable e
(binding [*out* *err*] (println "wayland-bar-compositor: handler failed:" e))))))
(def notify (ffi/callback arena dispatch [:pointer :pointer] :void))
(defn listen!
"Hook f onto the wl_signal at address `signal`. Answers the listener."
[signal f]
(let [listener (or (let [[l] @free-listeners] (when l (swap! free-listeners rest) l))
(ffi/alloc arena (off :wl_listener/sizeof)))]
(ffi/write listener :pointer notify (off :wl_listener/notify))
(swap! handlers assoc listener f)
;; wl_list_insert(signal->listener_list.prev, &listener->link)
(wl-list-insert (ffi/read signal :pointer 0) (field listener :wl_listener/link))
listener))
(defn unlisten! [& listeners]
(doseq [l listeners]
(wl-list-remove (field l :wl_listener/link))
(swap! handlers dissoc l)
(swap! free-listeners conj l)))
;; --- the server -----------------------------------------------------------------
(def width (:width opts))
(def height (:height opts))
(def display (wl-display-create))
(def event-loop (wl-display-get-event-loop display))
(def backend (backend-autocreate event-loop 0))
(when (zero? backend) (die "no wlroots backend; is DISPLAY set and WLR_BACKENDS=x11?"))
(def renderer (renderer-autocreate backend))
(when (zero? renderer) (die "no renderer"))
(renderer-init-wl-display renderer display)
(def allocator (allocator-autocreate backend renderer))
(when (zero? allocator) (die "no allocator"))
(compositor-create display 5 renderer)
(subcompositor-create display)
(data-device-manager-create display)
(primary-selection-manager-create display)
(data-control-manager-create display)
(viewporter-create display)
(fractional-scale-manager-create display 1)
(single-pixel-buffer-manager-create display)
(screencopy-manager-create display)
(xdg-activation-create display)
(presentation-create display backend 2)
(def output-layout (output-layout-create display))
(xdg-output-manager-create display output-layout)
(def scene (scene-create))
(def scene-layout (scene-attach-output-layout scene output-layout))
(def root (field scene :wlr_scene/tree))
;; Layer-shell layers, bottom to top; popups float above everything.
(def layer-trees (vec (repeatedly 4 #(scene-tree-create root))))
(def toplevel-tree (scene-tree-create root))
(def popup-tree (scene-tree-create root))
(def output (atom nil)) ; the one wlr_output
(def layer-surfaces (atom {})) ; wlr_layer_surface_v1 -> scene layer surface
(def popups (atom {})) ; wlr_xdg_popup -> scene tree
;; --- X11 window shape --------------------------------------------------------------
(def x-display (x-open-display 0))
(when (zero? x-display) (die "cannot open the X display"))
(def x-window (atom nil))
(def shown-rects (atom nil))
(def max-rects 1024)
(def rect-buf (ffi/alloc arena (* 8 max-rects))) ; XRectangle { short x, y; ushort w, h }
(defn find-x-window
"wlroots owns the X11 window; we gave it a unique title, so look it up."
[]
(let [out (:out (p/sh "xwininfo" "-name" (:title opts)))]
(some->> (re-find #"Window id: (0x[0-9a-f]+)" out) second (#(Long/parseLong (subs % 2) 16)))))
(defn popup-rects
"Layout-space boxes of every mapped popup: its geometry, without shadows."
[]
(for [[popup tree] @popups
:let [base (ptr popup :wlr_xdg_popup/base)
surface (ptr base :wlr_xdg_surface/surface)]
:when (flag surface :wlr_surface/mapped)
:let [_ (scene-node-coords (field tree :wlr_scene_tree/node) out-a out-b)
geo (field base :wlr_xdg_surface/geometry)
w (i32 geo :wlr_box/width)
h (i32 geo :wlr_box/height)]
:when (and (pos? w) (pos? h))]
[(ffi/read out-a :int) (ffi/read out-b :int) w h]))
;; Popups have rounded corners; their geometry box would show the black output
;; behind the corners. So read the frame about to be shown and trace each
;; corner row inward to the first painted pixel. Pixman frames are plain
;; memory, and only corner rows are scanned, only when the popups change.
(def data-out (ffi/alloc arena 8))
(def format-out (ffi/alloc arena 4))
(def stride-out (ffi/alloc arena 8))
(def rgb32-formats #{0x34325258 0x34325241 0x34324258 0x34324241}) ; XRGB/ARGB/XBGR/ABGR8888
;; Transparent margins and faint shadows composite onto the black output as
;; black or near-black; a popup's own background is well above this.
(def paint-threshold 10)
(defn- painted? [px]
(or (> (bit-and (bit-shift-right px 16) 0xff) paint-threshold)
(> (bit-and (bit-shift-right px 8) 0xff) paint-threshold)
(> (bit-and px 0xff) paint-threshold)))
(defn- row-span
"[left right) of the painted part of row y within [x, x+w); nil if none.
The row is copied out in one call rather than read pixel by pixel."
[data stride x y w]
(let [row (ffi/read-array (+ data (* y stride)) :uint32 w (* 4 x))
left (loop [i 0] (cond (= i w) nil (painted? (aget row i)) i :else (recur (inc i))))]
(when left
(let [right (loop [i (dec w)] (if (painted? (aget row i)) (inc i) (recur (dec i))))]
[(+ x left) (+ x right)]))))
(defn outline-rects
"XShape rects for popup box [x y w h], following what the popup actually
painted: rounded corners, and any transparent margin its geometry includes.
Consecutive rows with the same span merge into one rect."
[data stride [x y w h]]
(let [rows (for [row (range y (+ y h))
:let [[l r] (row-span data stride x row w)]
:when l]
[l row (- r l) 1])]
(->> rows
(reduce (fn [acc [rx ry rw rh :as rect]]
(let [[px py pw ph] (peek acc)]
(if (and px (= px rx) (= pw rw) (= (+ py ph) ry))
(conj (pop acc) [px py pw (+ ph rh)])
(conj acc rect))))
[]))))
(defn- frame-outlines
"Outline rects for every popup box, read from `buffer`; nil if unreadable."
[buffer boxes]
(when (and (pos? buffer)
(buffer-begin-data-ptr-access buffer (off :enum/buffer-data-ptr-access-read)
data-out format-out stride-out))
(try
(when (rgb32-formats (ffi/read format-out :uint32))
(let [data (ffi/read data-out :pointer)
stride (ffi/read stride-out :size_t)]
(vec (mapcat (fn [[x y w h]]
;; clamp to the output so a scan never leaves the buffer
(let [x (max 0 x) y (max 0 y)
w (min w (- width x)) h (min h (- height y))]
(when (and (pos? w) (pos? h))
(outline-rects data stride [x y w h]))))
boxes))))
(finally (buffer-end-data-ptr-access buffer)))))
(def shown-boxes (atom nil))
(def popups-dirty (atom false)) ; a popup committed since its outline was traced
(defn update-shape!
"Shape the window to the strip plus the popups' outlines. `buffer` is the
frame about to be shown, or nil when nothing was rendered."
[buffer]
(when-not @x-window
(reset! x-window (find-x-window)))
(when-let [win @x-window]
(let [boxes (vec (popup-rects))
retrace? (and (seq boxes) (or (not= boxes @shown-boxes) (and buffer @popups-dirty)))
outlines (when retrace?
;; tracing needs a rendered frame; without one, wait for it
(when buffer
(reset! popups-dirty false)
(or (frame-outlines buffer boxes) boxes)))
rects (cond
(empty? boxes) [(:strip opts)]
outlines (vec (take max-rects (cons (:strip opts) outlines)))
:else nil)]
(when (and rects (not= rects @shown-rects))
(reset! shown-boxes boxes)
(debug "shape" (count rects) "rects" (take 4 rects))
(doseq [[i [x y w h]] (map-indexed vector rects)]
(ffi/write rect-buf :short (short x) (* 8 i))
(ffi/write rect-buf :short (short y) (+ 2 (* 8 i)))
(ffi/write rect-buf :short (unchecked-short w) (+ 4 (* 8 i)))
(ffi/write rect-buf :short (unchecked-short h) (+ 6 (* 8 i))))
;; ShapeBounding = 0, ShapeInput = 2; ShapeSet = 0; Unsorted = 0
(x-shape-combine-rectangles x-display win 0 0 0 rect-buf (count rects) 0 0)
(x-shape-combine-rectangles x-display win 2 0 0 rect-buf (count rects) 0 0)
(x-flush x-display)
(reset! shown-rects rects)))))
;; --- outputs ------------------------------------------------------------------------
(defn with-output-state [f]
(let [state (ffi/alloc arena (off :wlr_output_state/sizeof))]
(output-state-init state)
(try (f state) (finally (output-state-finish state)))))
(def child (atom nil))
(def frame-state (ffi/alloc arena (off :wlr_output_state/sizeof))) ; reused every frame
(defn arrange-layers! []
(write-box! box-buf 0 0 width height)
(write-box! usable-buf 0 0 width height)
(doseq [[_ scene-ls] @layer-surfaces]
(scene-layer-surface-configure scene-ls box-buf usable-buf)))
(listen! (field backend :wlr_backend/events.new_output)
(fn [wlr-output]
(if @output
(println "wayland-bar-compositor: ignoring extra output")
(do
(reset! output wlr-output)
(output-init-render wlr-output allocator renderer)
(with-output-state
(fn [state]
(output-state-set-enabled state true)
(output-state-set-custom-mode state width height 0)
(output-commit-state wlr-output state)))
(when (output-is-x11 wlr-output)
(x11-output-set-title wlr-output (:title opts)))
(let [scene-output (scene-output-create scene wlr-output)]
(scene-output-layout-add-output scene-layout (output-layout-add-auto output-layout wlr-output) scene-output)
(listen! (field wlr-output :wlr_output/events.frame)
(fn [_]
;; wlr_scene_output_commit, split open so the frame can be read
;; for popup outlines between rendering and showing it.
(if (scene-output-needs-frame scene-output)
(do
(output-state-init frame-state)
(try
(when (scene-output-build-state scene-output frame-state 0)
(update-shape! (when (pos? (bit-and (u32 frame-state :wlr_output_state/committed)
(off :enum/output-state-buffer)))
(ptr frame-state :wlr_output_state/buffer)))
(output-commit-state wlr-output frame-state))
(finally (output-state-finish frame-state))))
(update-shape! nil))
(clock-gettime 1 timespec) ; CLOCK_MONOTONIC
(scene-output-send-frame-done scene-output timespec)))
(listen! (field wlr-output :wlr_output/events.request_state)
(fn [event]
(output-commit-state wlr-output (ptr event :wlr_output_event_request_state/state)))))))))
;; --- layer shell -----------------------------------------------------------------
(def layer-shell (layer-shell-create display 4))
(declare add-popup!)
(listen! (field layer-shell :wlr_layer_shell_v1/events.new_surface)
(fn [ls]
(when (zero? (ptr ls :wlr_layer_surface_v1/output))
(ffi/write ls :pointer (or @output 0) (off :wlr_layer_surface_v1/output)))
(let [layer (min 3 (max 0 (i32 ls :wlr_layer_surface_v1/current.layer)))
scene-ls (scene-layer-surface-create (nth layer-trees layer) ls)
surface (ptr ls :wlr_layer_surface_v1/surface)]
;; popups find their parent's scene tree through data
(ffi/write ls :pointer (ptr scene-ls :wlr_scene_layer_surface_v1/tree) (off :wlr_layer_surface_v1/data))
(swap! layer-surfaces assoc ls scene-ls)
(let [commit (listen! (field surface :wlr_surface/events.commit)
(fn [_] (when (flag ls :wlr_layer_surface_v1/initialized) (arrange-layers!))))
;; xdg-shell announces a layer surface's popup before it has a
;; parent; this signal comes once the parent is set.
new-popup (listen! (field ls :wlr_layer_surface_v1/events.new_popup) add-popup!)
destroy (atom nil)]
(reset! destroy
(listen! (field ls :wlr_layer_surface_v1/events.destroy)
(fn [_]
(swap! layer-surfaces dissoc ls)
(unlisten! commit new-popup @destroy))))))))
;; --- xdg shell -------------------------------------------------------------------
(def xdg-shell (xdg-shell-create display 6))
(listen! (field xdg-shell :wlr_xdg_shell/events.new_toplevel)
(fn [toplevel]
(let [base (ptr toplevel :wlr_xdg_toplevel/base)
tree (scene-xdg-surface-create toplevel-tree base)
surface (ptr base :wlr_xdg_surface/surface)]
(ffi/write base :pointer tree (off :wlr_xdg_surface/data))
(let [commit (listen! (field surface :wlr_surface/events.commit)
(fn [_] (when (flag base :wlr_xdg_surface/initial_commit)
(xdg-toplevel-set-size toplevel 0 0))))
destroy (atom nil)]
(reset! destroy
(listen! (field toplevel :wlr_xdg_toplevel/events.destroy)
(fn [_] (unlisten! commit @destroy))))))))
(defn parent-tree
"The scene tree a popup's parent surface draws into: an xdg surface's or a
layer surface's, both kept in their data field."
[parent-surface]
(let [xdg (xdg-surface-try-from-wlr-surface parent-surface)]
(if (pos? xdg)
(ptr xdg :wlr_xdg_surface/data)
(let [ls (layer-surface-try-from-wlr-surface parent-surface)]
(when (pos? ls) (ptr ls :wlr_layer_surface_v1/data))))))
(defn add-popup!
"Put a popup whose parent is set into the scene, under its parent's tree."
[popup]
(let [base (ptr popup :wlr_xdg_popup/base)
surface (ptr base :wlr_xdg_surface/surface)
parent (parent-tree (ptr popup :wlr_xdg_popup/parent))]
(debug "add popup" popup "parent tree" parent)
(if-not parent
(println "wayland-bar-compositor: popup with no known parent")
(let [tree (scene-xdg-surface-create parent base)]
(ffi/write base :pointer tree (off :wlr_xdg_surface/data))
(swap! popups assoc popup tree)
(let [commit (listen! (field surface :wlr_surface/events.commit)
(fn [_]
;; new content may change the outline (a client's
;; first buffer is often blank), so retrace it
(reset! popups-dirty true)
(when (flag base :wlr_xdg_surface/initial_commit)
;; keep the popup inside the output, in parent-relative space
(scene-node-coords (field parent :wlr_scene_tree/node) out-a out-b)
(xdg-popup-unconstrain-from-box
popup (write-box! box-buf (- (ffi/read out-a :int)) (- (ffi/read out-b :int)) width height))
(xdg-surface-schedule-configure base))))
destroy (atom nil)]
(reset! destroy
(listen! (field popup :wlr_xdg_popup/events.destroy)
(fn [_]
(swap! popups dissoc popup)
(unlisten! commit @destroy)))))))))
;; A layer surface's popup arrives here with no parent yet and again, parented,
;; on the layer surface's own new_popup; only take the parented ones here.
(listen! (field xdg-shell :wlr_xdg_shell/events.new_popup)
(fn [popup]
(when (pos? (ptr popup :wlr_xdg_popup/parent))
(add-popup! popup))))
;; --- clicks on X11 apps close popups --------------------------------------------
;; A click on an X11 window never reaches Wayland, so popups' own grabs can't
;; see it. XInput2 raw button presses on the root window report every click
;; without grabbing anything; if the pointer is outside what our window shows,
;; close the open popups. Layouts below checked against the X11/XI2 headers.
(def generic-event 35)
(def xi-raw-button-press 15)
(def xi-opcode
(let [opcode (ffi/alloc arena 4) event (ffi/alloc arena 4) error (ffi/alloc arena 4)]
(when (pos? (x-query-extension x-display "XInputExtension" opcode event error))
(ffi/read opcode :int))))
(if-not xi-opcode
(println "wayland-bar-compositor: no XInput2; clicks on X11 apps won't close popups")
(let [major (ffi/alloc arena 4) minor (ffi/alloc arena 4)
mask (ffi/alloc arena 5) ; XIMaskLen(XI_LASTEVENT)
event-mask (ffi/alloc arena 16)] ; XIEventMask { deviceid; mask_len; mask* }
(ffi/write major :int 2)
(ffi/write minor :int 0)
(xi-query-version x-display major minor) ; required before XI2 selection
(ffi/write mask :uint8 (bit-shift-left 1 (mod xi-raw-button-press 8)) (quot xi-raw-button-press 8))
(ffi/write event-mask :int 1 0) ; XIAllMasterDevices
(ffi/write event-mask :int 5 4)
(ffi/write event-mask :pointer mask 8)
(xi-select-events x-display (x-default-root-window x-display) event-mask 1)
(x-flush x-display)))
(def x-event (ffi/alloc arena 192)) ; sizeof(XEvent)
(def query-bufs (vec (repeatedly 7 #(ffi/alloc arena 8))))
(defn pointer-in-window?
"Whether the pointer is over a part of our window that is shown."
[]
(let [[root child root-x root-y win-x win-y buttons] query-bufs]
(x-query-pointer x-display @x-window root child root-x root-y win-x win-y buttons)
(let [x (ffi/read win-x :int) y (ffi/read win-y :int)]
(some (fn [[rx ry rw rh]] (and (<= rx x) (< x (+ rx rw)) (<= ry y) (< y (+ ry rh))))
@shown-rects))))
(defn dismiss-popups!
"Destroy the top-level popups; wlroots takes their child popups with them."
[]
(let [roots (doall (for [[popup _] @popups
:when (zero? (xdg-surface-try-from-wlr-surface (ptr popup :wlr_xdg_popup/parent)))]
popup))]
(debug "click outside on X11: closing" (count roots) "popup(s)")
(doseq [popup roots] (xdg-popup-destroy popup))))
(defn drain-x-events! []
(while (pos? (x-pending x-display))
(x-next-event x-display x-event)
(when (and xi-opcode
(= (ffi/read x-event :int 0) generic-event) ; cookie.type
(= (ffi/read x-event :int 32) xi-opcode) ; cookie.extension
(pos? (x-get-event-data x-display x-event)))
(let [evtype (ffi/read x-event :int 36)] ; cookie.evtype
(x-free-event-data x-display x-event)
(when (and (= evtype xi-raw-button-press) (seq @popups) @x-window (not (pointer-in-window?)))
(dismiss-popups!))))))
(def x-fd-ready
(ffi/callback arena
(fn [_fd _mask _data]
(try (drain-x-events!)
(catch Throwable e
(binding [*out* *err*] (println "wayland-bar-compositor: X event handling failed:" e))))
0)
[:int :uint32 :pointer] :int))
(when xi-opcode
(wl-event-loop-add-fd event-loop (x-connection-number x-display) 1 x-fd-ready 0)) ; WL_EVENT_READABLE
;; --- seat and input ----------------------------------------------------------------
(def seat (seat-create display "seat0"))
(def cursor (cursor-create))
(cursor-attach-output-layout cursor output-layout)
(def cursor-manager (xcursor-manager-create 0 24))
(def keyboards (atom #{}))
(defn surface-at
"[surface sx sy] under layout point (lx, ly), or nil."
[lx ly]
(let [node (scene-node-at (field root :wlr_scene_tree/node) lx ly out-a out-b)]
(when (and (pos? node) (= (i32 node :wlr_scene_node/type) (off :enum/scene-node-buffer)))
(let [scene-surface (scene-surface-try-from-buffer (scene-buffer-from-node node))]
(when (pos? scene-surface)
[(ptr scene-surface :wlr_scene_surface/surface) (ffi/read out-a :double) (ffi/read out-b :double)])))))
(defn focus-keyboard! [surface]
(when-let [kb (first @keyboards)]
(seat-keyboard-notify-enter seat surface (field kb :wlr_keyboard/keycodes)
(ffi/read kb :size_t (off :wlr_keyboard/num_keycodes))
(field kb :wlr_keyboard/modifiers))))
(defn pointer-motion! [time]
(debug "motion" (f64 cursor :wlr_cursor/x) (f64 cursor :wlr_cursor/y))
(if-let [[surface sx sy] (surface-at (f64 cursor :wlr_cursor/x) (f64 cursor :wlr_cursor/y))]
(do (seat-pointer-notify-enter seat surface sx sy)
(seat-pointer-notify-motion seat time sx sy))
(do (cursor-set-xcursor cursor cursor-manager "default")
(seat-pointer-clear-focus seat))))
(listen! (field cursor :wlr_cursor/events.motion)
(fn [e]
(cursor-move cursor (field (ptr e :wlr_pointer_motion_event/pointer) :wlr_pointer/base)
(f64 e :wlr_pointer_motion_event/delta_x) (f64 e :wlr_pointer_motion_event/delta_y))
(pointer-motion! (u32 e :wlr_pointer_motion_event/time_msec))))
(listen! (field cursor :wlr_cursor/events.motion_absolute)
(fn [e]
(cursor-warp-absolute cursor (field (ptr e :wlr_pointer_motion_absolute_event/pointer) :wlr_pointer/base)
(f64 e :wlr_pointer_motion_absolute_event/x) (f64 e :wlr_pointer_motion_absolute_event/y))
(pointer-motion! (u32 e :wlr_pointer_motion_absolute_event/time_msec))))
(listen! (field cursor :wlr_cursor/events.button)
(fn [e]
(seat-pointer-notify-button seat (u32 e :wlr_pointer_button_event/time_msec)
(u32 e :wlr_pointer_button_event/button) (i32 e :wlr_pointer_button_event/state))
(debug "button" (u32 e :wlr_pointer_button_event/button) "state" (i32 e :wlr_pointer_button_event/state)
"at" (f64 cursor :wlr_cursor/x) (f64 cursor :wlr_cursor/y)
"surface" (first (surface-at (f64 cursor :wlr_cursor/x) (f64 cursor :wlr_cursor/y))))
(when (= (i32 e :wlr_pointer_button_event/state) (off :enum/button-pressed))
(when-let [[surface] (surface-at (f64 cursor :wlr_cursor/x) (f64 cursor :wlr_cursor/y))]
(focus-keyboard! surface)))))
(listen! (field cursor :wlr_cursor/events.axis)
(fn [e]
(seat-pointer-notify-axis seat (u32 e :wlr_pointer_axis_event/time_msec)
(i32 e :wlr_pointer_axis_event/orientation) (f64 e :wlr_pointer_axis_event/delta)
(i32 e :wlr_pointer_axis_event/delta_discrete) (i32 e :wlr_pointer_axis_event/source)
(i32 e :wlr_pointer_axis_event/relative_direction))))
(listen! (field cursor :wlr_cursor/events.frame)
(fn [_] (seat-pointer-notify-frame seat)))
(listen! (field seat :wlr_seat/events.request_set_cursor)
(fn [e]
(when (= (ptr e :wlr_seat_pointer_request_set_cursor_event/seat_client)
(ptr seat :wlr_seat/pointer_state.focused_client))
(cursor-set-surface cursor (ptr e :wlr_seat_pointer_request_set_cursor_event/surface)
(i32 e :wlr_seat_pointer_request_set_cursor_event/hotspot_x)
(i32 e :wlr_seat_pointer_request_set_cursor_event/hotspot_y)))))
(listen! (field seat :wlr_seat/events.request_set_selection)
(fn [e] (seat-set-selection seat (ptr e :wlr_seat_request_set_selection_event/source)
(u32 e :wlr_seat_request_set_selection_event/serial))))
(listen! (field seat :wlr_seat/events.request_set_primary_selection)
(fn [e] (seat-set-primary-selection seat (ptr e :wlr_seat_request_set_primary_selection_event/source)
(u32 e :wlr_seat_request_set_primary_selection_event/serial))))
(defn update-capabilities! []
(seat-set-capabilities seat (bit-or (off :enum/seat-capability-pointer)
(if (seq @keyboards) (off :enum/seat-capability-keyboard) 0))))
(defn add-keyboard! [device]
(let [kb (keyboard-from-input-device device)
context (xkb-context-new 0)
keymap (xkb-keymap-new-from-names context 0 0)]
(keyboard-set-keymap kb keymap)
(xkb-keymap-unref keymap)
(xkb-context-unref context)
(keyboard-set-repeat-info kb 25 600)
(let [modifiers (listen! (field kb :wlr_keyboard/events.modifiers)
(fn [_]
(seat-set-keyboard seat kb)
(seat-keyboard-notify-modifiers seat (field kb :wlr_keyboard/modifiers))))
key (listen! (field kb :wlr_keyboard/events.key)
(fn [e]
(seat-set-keyboard seat kb)
(seat-keyboard-notify-key seat (u32 e :wlr_keyboard_key_event/time_msec)
(u32 e :wlr_keyboard_key_event/keycode)
(u32 e :wlr_keyboard_key_event/state))))
destroy (atom nil)]
(reset! destroy
(listen! (field device :wlr_input_device/events.destroy)
(fn [_]
(swap! keyboards disj kb)
(unlisten! modifiers key @destroy)
(update-capabilities!)))))
(seat-set-keyboard seat kb)
(swap! keyboards conj kb)))
(listen! (field backend :wlr_backend/events.new_input)
(fn [device]
(let [type (i32 device :wlr_input_device/type)]
(debug "new input device type" type)
(cond
(= type (off :enum/input-device-keyboard)) (add-keyboard! device)
(= type (off :enum/input-device-pointer)) (cursor-attach-input-device cursor device)))
(update-capabilities!)))
;; --- run -----------------------------------------------------------------------------
(def socket (wl-display-add-socket-auto display))
(when-not socket (die "cannot create a wayland socket"))
(when-not (backend-start backend) (die "backend failed to start"))
(println "wayland-bar-compositor: WAYLAND_DISPLAY" socket)
(reset! child (p/process (:command opts) {:extra-env {"WAYLAND_DISPLAY" socket}
:out :inherit :err :inherit}))
(.addShutdownHook (Runtime/getRuntime)
(Thread. (fn [] (when @child (p/destroy @child)))))
(while (p/alive? @child)
(wl-event-loop-dispatch event-loop 250)
;; Xlib may have read events into its queue during our own X calls, where
;; the fd never becomes readable again; drain them here too.
(drain-x-events!)
(wl-display-flush-clients display))
(println "wayland-bar-compositor:" (first (:command opts)) "exited")
(wl-display-destroy-clients display)
(System/exit 0)
|