test/input-reply-queue.sgl

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

2 (sigil wm host) (sigil wm input)

3 (only (sigil wm runtime) host-send! wm-host-stopped? set-wm-host-motion-hook!))

4(define (check value message) (unless value (error message)))

5(define (now-ms) (inexact->exact (round (* 1000 (/ (current-jiffy) (jiffies-per-second))))))

6(define (await predicate)

7 (let loop ((n 0))

8 (unless (predicate)

9 (check (< n 600) "input reply queue timeout")

10 (sleep .005) (loop (+ n 1)))))

11(define fixture (c-library (getenv "SIGIL_WM_LIBRARY")))

12(define gate (c-function fixture "wm_test_gate" (list ffi/int) ffi/int))

13(define queued (c-function fixture "wm_test_queued" (list ffi/int) ffi/int))

14(define depth (c-function fixture "wm_test_depth" '() ffi/int))

15(define reply-stat (c-function fixture "wm_test_reply_stat" (list ffi/int) ffi/int))

16(define start-gate (c-function fixture "wm_test_start_gate" (list ffi/int) ffi/int))

17(define mode (or (getenv "WM_INPUT_MODE") "overflow"))

18(define kind (string->number (or (getenv "WM_INPUT_KIND") "30")))

19(when (equal? mode "starting") (start-gate kind))

20(define host (start-host!))

21(define ready? #f)

22(define completed '())

23(define observed '())

24(define saved #f)

25(define filled? #f)

26(define released? #f)

27(define start 0)

28(on-event! host (lambda (event)

29 (case (event-type event)

30 ((ready) (set! ready? #t))

31 ((input-completed) (set! completed (cons (event-ref event id:) completed))))))

32(define (hook event)

33 (set! observed (cons event observed))

34 (unless saved

35 (set! saved event)

36 (cond

37 ((equal? mode "starting")

38 (set! start (now-ms))

39 (go (sleep .075) (start-gate 0) (set! released? #t)))

40 ((equal? mode "shutdown")

41 (begin

42 (check (stop-host! host) "stop command refused")

43 (await (lambda () (not (host-running? host))))

44 (check (= (depth) 0) "shutdown command queue not empty")

45 (display "SHUTDOWN_REPLY queued=0 reply-kind=") (display kind) (newline)))

46 (else

47 (begin

48 (check (= (gate 1) 1) "native command gate failed")

49 (let loop () (when (set-seat-capabilities! host 3) (loop)))

50 (check (= (queued 0) 1024) "unexpected command queue capacity")

51 (check (= (queued 14) 1024) "unexpected queued command kinds")

52 (display "QUEUE_FULL capacity=1024 commands=14:1024 reply-kind=")

53 (display (input-event-kind event)) (newline)

54 (set! start (now-ms))

55 (set! filled? #t)

56 (go (sleep .075) (gate 0) (set! released? #t))))))

57 (drop))

58(set-key-hook! host hook)

59(set-button-hook! host hook)

60(when (= kind 32) (set-motion-hook! host hook 0 0 '(0 0 800 600)))

61(when (and (= kind 32) (equal? mode "starting")) (set-wm-host-motion-hook! host hook))

62(with-async

63 (go (run-host! host))

64 (await (lambda () ready?))

65 (set-key-hook! host hook)

66 (set-button-hook! host hook)

67 (check (configure-keyboard! host 1 "us" 25 600) "keyboard setup refused")

68 (when (= kind 32) (set-motion-hook! host hook 0 0 '(0 0 800 600)))

69 (sleep .05)

70 (let ((first (case kind

71 ((30) (emulate-key! host 1 30 #t))

72 ((31) (emulate-button! host 1 272 #t))

73 ((32) (emulate-motion! host 1 20 20)))))

74 (check first "input emulation refused")

75 (await (lambda () saved))

76 (cond

77 ((equal? mode "starting")

78 (await (lambda () (memv first completed)))

79 (check released? "startup reply did not yield to readiness")

80 (check (= (length observed) 2) "startup hook repeated or input lost")

81 (check (> (reply-stat 1) 0) "starting receiver never refused reply")

82 (check (< (reply-stat 0) 200) "startup reply spun without sleeping")

83 (check (= (reply-stat 2) 2) "startup reply dropped before readiness")

84 (display "INPUT_STARTING=PASS kind=") (display kind)

85 (display " elapsed-ms=") (display (- (now-ms) start)) (newline))

86 ((equal? mode "shutdown")

87 (await (lambda () (wm-host-stopped? host)))

88 (check (= (reply-stat 0) 1) "shutdown reply retried without a receiver")

89 (display "INPUT_SHUTDOWN=PASS kind=") (display kind) (newline))

90 ((equal? mode "probe")

91 (await (lambda () released?))

92 (let ((second (emulate-key! host 1 31 #t)))

93 (check second "following key refused")

94 (sleep 1.1)

95 (check (not (memv first completed)) "lost bound input unexpectedly completed")

96 (check (= (length observed) 1) "following bound key escaped lost decision")

97 (display "BOUND_LOST kind=") (display kind)

98 (display " retained-ms=") (display (- (now-ms) start))

99 (display " following-key-blocked=yes\n")

100 (check (host-send! host (list 11 (input-event-token saved) 0 (input-event-code saved) 0 0 0))

101 "recovery reply refused")

102 (await (lambda () (and (memv first completed) (memv second completed))))

103 (display "BOUND_RECOVERED=PASS explicit-reply\n")))

104 (else

105 (await (lambda () (memv first completed)))

106 (check filled? "input hook never filled queue")

107 (check released? "reply did not wait for queue space")

108 (let ((second (emulate-key! host 1 31 #t)))

109 (await (lambda () (memv second completed))))

110 (check (= (length observed) 2) "input hook repeated or following key blocked")

111 (check (> (reply-stat 1) 0) "reply never encountered backpressure")

112 (check (= (reply-stat 2) 2) "input reply silently lost")

113 (display "INPUT_REPLY_QUEUE=PASS kind=") (display kind)

114 (display " elapsed-ms=") (display (- (now-ms) start)) (newline)))

115 (unless (equal? mode "shutdown") (check (stop-host! host) "stop refused"))))

116(for-each (lambda (index) (check (= (host-statistic host index) 0) "native resources or events retained")) '(1 2 3 4))