source: project/release/5/condition-utils/tags/2.1.0/tests/condition-utils-test.scm @ 35973

Last change on this file since 35973 was 35973, checked in by Kon Lovett, 16 months ago

rel 2.1.0

File size: 2.0 KB
Line 
1;;;; condition-utils-test.scm  -*- Scheme -*-
2;;;; Kon Lovett, Jul '18
3
4(import test)
5
6(test-begin "Condition Utils")
7
8;;;
9
10(import (chicken condition) (chicken port))
11
12(import condition-utils exn-condition)
13
14(define testc (make-exn-condition+ 'test "test" '(test) 'misc '(extra test 23)))
15(define testc? (make-condition-predicate exn misc extra))
16
17(test-assert "composite of exn test extra" (testc? testc))
18(test "test property of extra component of (exn test extra)" 23 ((condition-property-accessor 'extra 'test) testc))
19
20(define testc-extra-test (make-condition-property-accessor extra test))
21(define testc-extra-foo (make-condition-property-accessor extra foo 'foobar))
22
23(test 23 (testc-extra-test testc))
24(test 'foobar (testc-extra-foo testc))
25
26(test-assert (call-chain? (get-call-chain 1)))
27(test-assert (call-chain? (get-call-chain 0)))
28
29(define testcc)
30(let ((chn (get-call-chain 1)))
31  (set! testcc
32    (make-exn-condition+
33      'test "test" '(test)              ;std
34      chn                               ;+ 1
35      'misc '(extra test 23))) )        ;cnds
36(test-assert "composite of exn test extra (set!)" (testc? testcc))
37
38;C5 is a plist
39(define wr-exn-res "\nError: (test) test: test\n    +: misc:\n    +: extra: test 23\n")
40(test "may fail - order an issue" wr-exn-res
41  (with-output-to-string (lambda () (write-exn-condition testc))))
42
43(test-assert (exn-condition? testc))
44(test 'test (exn-location testc))
45(test "test" (exn-message testc))
46(test '(test) (exn-arguments testc))
47(test #f (exn-call-chain testc))
48
49(import standard-conditions)
50
51(import http-client-conditions)
52(import intarweb-conditions)
53
54(define thttpc (make-exn-condition+ 'test "test" '(test) 'http '(extra test 23)))
55(test-assert (http-condition? thttpc))
56
57;C5 is a plist
58(define irr-res '(location test message "test" arguments (test) test 23))
59(test irr-res (condition-irritants thttpc))
60
61(print)
62(print "Writing exn condition")
63(print " (expect an \"error\")")
64(print "---------------------")
65(write-exn-condition testcc)
66(print)
67
68;;;
69
70(test-end "Condition Utils")
71
72(test-exit)
Note: See TracBrowser for help on using the repository browser.