test/hotplug.sgl — sigil-wm

1(import (sigil async) (sigil ffi) (sigil wm scene) (sigil wm model)

2 (sigil wm host))

4(define host (start-host!))

5(define original-id #f)

6(define original-name #f)

7(define replacement-id #f)

8(define stage 'initial)

9(define admission #f)

10(define admission-results 0)

12(on-event! host

13 (lambda (event)

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

15 (case (event-type event)

16 ((output-name)

17 (let ((output (car (dict-ref (host-snapshot host) outputs:))))

18 (case stage

19 ((initial)

20 (set! original-id id)

21 (set! original-name (dict-ref output name:)))

22 ((creating)

23 (set! replacement-id id)

24 (unless (equal? original-name (dict-ref output name:))

25 (error "replacement connector name changed"))))

26 (configure-output! host id

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

28 mode: -1 width: 640 height: 480 refresh: 60000))))

29 ((output-configured)

30 (case stage

31 ((initial)

32 (let ((storage (c-alloc 4)))

33 (pointer-set! storage ffi/uint32 0 #xffffffff)

34 (unless (present-pixels! host 700 storage 1 1 4

35 (rect x: 0 y: 0 width: 1 height: 1) 1 output: id

36 bounds: (rect x: 0 y: 0 width: 640 height: 480))

37 (error "scoped hotplug image not queued"))

38 (c-free storage))

39 (set! stage 'admitting)

40 (set! admission (set-default-layer-output! host id)))

41 ((creating)

42 (unless (and replacement-id (not (= replacement-id original-id))

43 (= (length (dict-ref (host-snapshot host) outputs:)) 1))

44 (error "hotplug reused a stale native object"))

45 (set! stage 'clearing)

46 (set! admission (set-default-layer-output! host #f)))))

47 ((layer-output-result)

48 (unless (= id admission) (error "layer output result token mismatch"))

49 (set! admission-results (+ admission-results 1))

50 (case stage

51 ((admitting)

52 (unless (and (= (host-statistic host 5) 1) (> (host-statistic host 4) 0))

53 (error "scoped hotplug image not owned"))

54 (unless (event-ref event accepted?:) (error "live layer output refused"))

55 (set! stage 'removing)

56 (remove-headless-output! host original-id))

57 ((refusing)

58 (when (event-ref event accepted?:) (error "retired layer output accepted"))

59 (set! stage 'creating)

60 (add-headless-output! host 640 480 name: original-name))

61 ((clearing)

62 (unless (and (event-ref event accepted?:) (= (event-ref event output:) 0))

63 (error "explicit layer cache clear refused"))

64 (set! stage 'done)

65 (stop-host! host))))

66 ((command-rejected) (error "unexpected hotplug command rejection" (event-raw event)))

67 ((output-removed)

68 (unless (and (= id original-id) (eq? stage 'removing))

69 (error "unexpected output removal"))

70 (unless (null? (dict-ref (host-snapshot host) outputs:))

71 (error "removed output remains in snapshot"))

72 (unless (and (= (host-statistic host 5) 0) (= (host-statistic host 4) 0))

73 (error "removed output retained scoped pixels"))

74 (set! stage 'refusing)

75 (set! admission (set-default-layer-output! host original-id)))))))

77(with-async (run-host! host))

78(unless (and (eq? stage 'done) (= admission-results 3) (= (host-statistic host 2) 0) (= (host-statistic host 3) 0))

79 (error "hotplug cycle incomplete" stage))

80(display "HOTPLUG=PASS real removal fresh ID retained connector name scoped pixels retired\n")