test/session.sgl — sigil-wm

1(import (sigil async) (sigil channels) (sigil ffi)

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

3(define ready (make-channel 1))

4(define raised-from-body? #f)

5(define caught? #f)

6(define cleaned? #f)

7(guard (exception (#t (set! caught? #t)))

8 (call-with-host-session

9 (lambda () (start-host!))

10 (lambda (host)

11 (on-event! host

12 (lambda (event)

13 (case (event-type event)

14 ((output-added)

15 (configure-output! host (event-ref event id:)

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

17 ((output-configured) (channel-send ready #t)))))

18 (with-async

19 (go (run-host! host))

20 (go

21 (channel-receive ready)

22 (let ((storage (c-alloc 1024)))

23 (let loop ((offset 0))

24 (when (< offset 1024)

25 (pointer-set! storage ffi/uint32 offset #xff00cc44)

26 (loop (+ offset 4))))

27 (unless (present-pixels! host 1 storage 16 16 64

28 (rect x: 4 y: 4 width: 16 height: 16) 1)

29 (error "session fixture pixel copy was refused"))

30 (c-free storage))

31 (sleep 0.1)

32 (set! raised-from-body? #t)

33 (error "expected asynchronous session unwind"))))

34 (lambda (host)

35 (unless (and (= (host-statistic host 1) 0) (= (host-statistic host 4) 0))

36 (error "exceptional shutdown retained native storage"))

37 (set! cleaned? #t))))

38(unless (and raised-from-body? caught? cleaned?)

39 (error "session did not stop/join before exceptional cleanup"))

40(display "SESSION_UNWIND=PASS asynchronous exception joined owner released copied pixels\n")