blob: 223acbbef99cef384df8f71fec1f773cd2b2a035 (
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
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
|
# -*- tcl -*- Commands covered: interpreter cloning ...
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# Copyright (c) 2002 by ActiveState Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: clone.test,v 1.1.2.1 2002/11/26 19:49:00 andreas_kupries Exp $
# Prevent execution of these tests when running in the cloned interpreter !!
if {[info exists __clone__]} return
memory validate on
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
proc foo {} {
# Have a compiled local variable.
set dummy 22
}
test clone-1.1 {simple creation and destruction} {
# This test checks that the basic creation of a clone, and its
# destruction do not crash. The continued execution of the regular
# testsuite in the main interpreter immediately after this test
# also checks that the desctruction of hte clone did not disrupt
# the original.
testclone create
testclone destroy
set a 0
} {0}
test clone-1.2 {linked variables} {
# Check that variables linked between namespaces are cloned
# correctly (need fixup similar to commands imported into
# namespaces), and that their values are ok. This essentially
# tests sharing of contents, and the inter-var references.
set a ""
namespace eval ::__foo__ {variable xx 1}
namespace eval ::__bar__ {upvar ::__foo__::xx xx}
append a m[set ::__foo__::xx][set ::__bar__::xx]
testclone create
append a -c[testclone eval {set ::__foo__::xx}][testclone eval {set ::__bar__::xx}]
append a m[set ::__foo__::xx][set ::__bar__::xx]
testclone destroy
append a -m[set ::__foo__::xx][set ::__bar__::xx]
namespace delete ::__foo__
namespace delete ::__bar__
set a
} {m11-c11m11-m11}
test clone-1.3 {cloned variables} {
# Check that variables linked between namespaces are cloned
# correctly (need fixup similar to commands imported into
# namespaces). Tests sharing of contents.
set a ""
append a "m[set tcl_patchLevel]"
testclone create
append a -c[testclone eval {set tcl_patchLevel}]
append a m[set tcl_patchLevel]
testclone destroy
append a -m[set tcl_patchLevel]
set a
} {m8.3.4-c8.3.4m8.3.4-m8.3.4}
test clone-1.4 {cloned variables, arrays} {
# Check that variables linked between namespaces are cloned
# correctly (need fixup similar to commands imported into
# namespaces). Tests that sharing of arrays is ok.
array set x {x _}
set a ""
append a "m[array get x]"
testclone create
append a -c[testclone eval {array get x}]
append a m[array get x]
testclone destroy
append a -m[array get x]
set a
} {mx _-cx _mx _-mx _}
proc act_Setup { } {
global dest
global beep
set beep 11
}
test clone-1.5 {eval proc} {
# This test checks that the basic creation of a clone, and its
# destruction do not crash. The continued execution of the regular
# testsuite in the main interpreter immediately after this test
# also checks that the desctruction of hte clone did not disrupt
# the original.
testclone create
set res [testclone eval {act_Setup}]
testclone destroy
set res
} {11}
test clone-2.0 {sub testsuite} {
# Now we run the entire testsuite in the cloned interpreter.
# This should stress test the data structures, especially
# the execution of shared bytecode.
puts ___
puts "___ Running the entire testsuite inside of the cloned interpreter"
puts ___
puts ___
testclone create
testclone eval {set __clone__ 1}
set res [testclone eval [list source [file join $tcltest::testsDirectory all.tcl]]]
testclone destroy
set res
} {}
#exit
puts ___
puts "___ Proceeding to run the entire testsuite in the main interpreter."
puts ___
puts ___
# cleanup
::tcltest::cleanupTests
return
|
