test/lock-presentation.sgl

1(import (sigil async) (sigil io) (sigil ffi) (sigil process)

2 (sigil wm host) (sigil wm scene) (sigil wm model) (sigil wm repl))

3(define host (start-host! protocols: 1))

4(define output #f)

5(define state 0)

6(define generations '())

7(define fault (c-library "./build/output-present-fault.so"))

8(define withheld (c-function fault "wm_test_withheld_presents" '() ffi/uint))

9(on-event! host

10 (lambda (event)

11 (let ((id (event-ref event id:)))

12 (case (event-type event)

13 ((output-added)

14 (set! output id)

15 (configure-output! host id

16 (dict enabled: #t x: 0 y: 0 scale: 1 transform: 0 mode: -1 width: 640 height: 480 refresh: 60000)))

17 ((output-configured)

18 (let ((pixels (c-alloc 4096)))

19 (dynamic-wind

20 (lambda () #t)

21 (lambda ()

22 (let loop ((offset 0))

23 (when (< offset 4096)

24 (pointer-set! pixels ffi/uint32 offset #xff00cc44)

25 (loop (+ offset 4))))

26 (unless (present-pixels! host 1 pixels 32 32 128

27 (rect x: 0 y: 0 width: 640 height: 480) 1 stretch?: #t)

28 (error "normal scene copy refused")))

29 (lambda () (c-free pixels))))

30 (display "WAYLAND_SOCKET=") (display (host-socket host)) (newline) (flush-output-port))

31 ((lock-state)

32 (set! state id)

33 (set! generations (cons (list id (event-ref event generation:)) generations)))

34 ((command-rejected) (error "presentation test command refused" (event-raw event)))))))

35(with-async

36 (let ((repl (start-repl! host (getenv "SIGIL_WM_REPL") (interaction-environment))))

37 (run-host! host)

38 (stop-repl! repl)))

39(unless (and (> (withheld) 0) (equal? (reverse generations) '((1 1) (2 1) (0 1)))

40 (= (host-statistic host 1) 0) (= (host-statistic host 2) 0)

41 (= (host-statistic host 3) 0) (= (host-statistic host 4) 0)

42 (= (host-statistic host 5) 0))

43 (error "presentation ordering or native teardown failed" generations))

(display "LOCK_PRESENTATION=PASS no acknowledgement without presentation opaque fallback authenticated unlock native join\n")