blob: 70dea8700bbb25de88ea6e6bf184968462584e94 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
|
# Commands covered: none
#
# This file contains a collection of tests for Tcl_AsyncCreate and related
# library procedures. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id$
if {[info commands testasync] == {}} {
puts "This application hasn't been compiled with the \"testasync\""
puts "command, so I can't test Tcl_AsyncCreate et al."
return
}
if {[string compare test [info procs test]] == 1} then {source defs}
proc async1 {result code} {
global aresult acode
set aresult $result
set acode $code
return "new result"
}
proc async2 {result code} {
global aresult acode
set aresult $result
set acode $code
return -code error "xyzzy"
}
proc async3 {result code} {
global aresult
set aresult "test pattern"
return -code $code $result
}
set handler1 [testasync create async1]
set handler2 [testasync create async2]
set handler3 [testasync create async3]
test async-1.1 {basic async handlers} {
set aresult xxx
set acode yyy
list [catch {testasync mark $handler1 "original" 0} msg] $msg \
$acode $aresult
} {0 {new result} 0 original}
test async-1.2 {basic async handlers} {
set aresult xxx
set acode yyy
list [catch {testasync mark $handler1 "original" 1} msg] $msg \
$acode $aresult
} {0 {new result} 1 original}
test async-1.3 {basic async handlers} {
set aresult xxx
set acode yyy
list [catch {testasync mark $handler2 "old" 0} msg] $msg \
$acode $aresult
} {1 xyzzy 0 old}
test async-1.4 {basic async handlers} {
set aresult xxx
set acode yyy
list [catch {testasync mark $handler2 "old" 3} msg] $msg \
$acode $aresult
} {1 xyzzy 3 old}
test async-1.5 {basic async handlers} {
set aresult xxx
list [catch {testasync mark $handler3 "foobar" 0} msg] $msg $aresult
} {0 foobar {test pattern}}
test async-1.6 {basic async handlers} {
set aresult xxx
list [catch {testasync mark $handler3 "foobar" 1} msg] $msg $aresult
} {1 foobar {test pattern}}
proc mult1 {result code} {
global x
lappend x mult1
return -code 7 mult1
}
set hm1 [testasync create mult1]
proc mult2 {result code} {
global x
lappend x mult2
return -code 9 mult2
}
set hm2 [testasync create mult2]
proc mult3 {result code} {
global x hm1 hm2
lappend x [catch {testasync mark $hm2 serial2 0}]
lappend x [catch {testasync mark $hm1 serial1 0}]
lappend x mult3
return -code 11 mult3
}
set hm3 [testasync create mult3]
test async-2.1 {multiple handlers} {
set x {}
list [catch {testasync mark $hm3 "foobar" 5} msg] $msg $x
} {9 mult2 {0 0 mult3 mult1 mult2}}
proc del1 {result code} {
global x hm1 hm2 hm3 hm4
lappend x [catch {testasync mark $hm3 serial2 0}]
lappend x [catch {testasync mark $hm1 serial1 0}]
lappend x [catch {testasync mark $hm4 serial1 0}]
testasync delete $hm1
testasync delete $hm2
testasync delete $hm3
lappend x del1
return -code 13 del1
}
proc del2 {result code} {
global x
lappend x del2
return -code 3 del2
}
testasync delete $handler1
testasync delete $hm2
testasync delete $hm3
set hm2 [testasync create del1]
set hm3 [testasync create mult2]
set hm4 [testasync create del2]
test async-3.1 {deleting handlers} {
set x {}
list [catch {testasync mark $hm2 "foobar" 5} msg] $msg $x
} {3 del2 {0 0 0 del1 del2}}
testasync delete
|
