test/pointer-geometry.sgl

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

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

3(define host (start-host!))

4(define windows '())

5(define last-plan #f)

6(define applied-plan #f)

7(define initial-tiled 15)

8(define popups '())

9(define pointer-position #f)

10(define (configure-fixture-output! id mode width height refresh)

11 (configure-output! host id

12 (dict enabled: #t x: 0 y: 0 scale: 1 transform: 0 mode: mode

13 width: (if (> width 0) width 960)

14 height: (if (> height 0) height 640) refresh: refresh)))

15(define (test-plan! width tiled deadline)

16 (set! last-plan

17 (submit-plan! host

18 (make-scene-plan

19 (map (lambda (id)

20 (placement window: id box: (rect x: 100 y: 80 width: width height: 400)

21 activated?: #t tiled: tiled clip?: (> tiled 0))) windows)

22 (and (pair? windows) (car windows)) deadline))))

23(on-event! host

24 (lambda (event)

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

26 (case (event-type event)

27 ((ready)

28 (configure-keyboard! host 1 "us" 25 600)

29 (set-seat-capabilities! host 3)

30 (set-pointer-route! host #t))

31 ((output-added)

32 (configure-fixture-output! id (event-ref event preferred-mode:)

33 (event-ref event width:) (event-ref event height:)

34 (if (event-ref event nested?:) 0 60000)))

35 ((output-state-request)

36 (configure-fixture-output! id -1 (event-ref event width:) (event-ref event height:) 0))

37 ((output-configured)

38 (unless (and (event-ref event enabled?:) (event-ref event powered?:))

39 (error "nested geometry output was not enabled and powered"))

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

41 ((window-initial) (configure-window! host id 480 400))

42 ((pointer-state)

43 (set! pointer-position

44 (cons (/ (event-ref event x-milli:) 1000) (/ (event-ref event y-milli:) 1000))))

45 ((popup-request)

46 (set! popups (cons id (filter (lambda (popup) (not (= popup id))) popups)))

47 (configure-popup! host id

48 (rect x: (inexact->exact (round (- (car pointer-position) 120)))

49 y: (inexact->exact (round (- (cdr pointer-position) 100)))

50 width: 120 height: 80)))

51 ((popup-destroyed)

52 (set! popups (filter (lambda (popup) (not (= popup id))) popups)))

53 ((window-mapped)

54 (set! windows (append windows (list id)))

55 (test-plan! 480 initial-tiled 200))

56 ((window-unmapped window-destroyed)

57 (when (memv id windows)

58 (set! windows (filter (lambda (window) (not (= window id))) windows))

59 (test-plan! 480 initial-tiled 200)))

60 ((transaction-applied) (set! applied-plan id))))))

61(with-async

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

63 (run-host! host)

64 (stop-repl! repl)))

65(unless (and (= (host-statistic host 1) 0) (= (host-statistic host 2) 0)

66 (= (host-statistic host 3) 0) (= (host-statistic host 7) 0))

67 (error "pointer geometry fixture retained native resources"))

68(display "POINTER_GEOMETRY_HOST=PASS\n")