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
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
|
# Commands covered: none
#
# This file contains tests for the procedures in tclStringObj.c
# that implement the Tcl type manager for the string type.
#
# Sourcing this file into Tcl runs the tests and generates output for
# errors. No output means no errors were found.
#
# Copyright (c) 1995-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: stringObj.test,v 1.3 1999/04/16 00:47:35 stanton Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
source [file join [pwd] [file dirname [info script]] defs.tcl]
}
if {[info commands testobj] == {}} {
puts "This application hasn't been compiled with the \"testobj\""
puts "command, so I can't test the Tcl type and object support."
::tcltest::cleanupTests
return
}
test stringObj-1.1 {string type registration} {
set t [testobj types]
set first [string first "string" $t]
set result [expr {$first != -1}]
} {1}
test stringObj-2.1 {Tcl_NewStringObj} {
set result ""
lappend result [testobj freeallvars]
lappend result [teststringobj set 1 abcd]
lappend result [testobj type 1]
lappend result [testobj refcount 1]
} {{} abcd string 2}
test stringObj-3.1 {Tcl_SetStringObj, existing "empty string" object} {
set result ""
lappend result [testobj freeallvars]
lappend result [testobj newobj 1]
lappend result [teststringobj set 1 xyz] ;# makes existing obj a string
lappend result [testobj type 1]
lappend result [testobj refcount 1]
} {{} {} xyz string 2}
test stringObj-3.2 {Tcl_SetStringObj, existing non-"empty string" object} {
set result ""
lappend result [testobj freeallvars]
lappend result [testintobj set 1 512]
lappend result [teststringobj set 1 foo] ;# makes existing obj a string
lappend result [testobj type 1]
lappend result [testobj refcount 1]
} {{} 512 foo string 2}
test stringObj-4.1 {Tcl_SetObjLength procedure, string gets shorter} {
testobj freeallvars
teststringobj set 1 test
teststringobj setlength 1 3
list [teststringobj length 1] [teststringobj length2 1] \
[teststringobj get 1]
} {3 4 tes}
test stringObj-4.2 {Tcl_SetObjLength procedure, string gets longer} {
testobj freeallvars
teststringobj set 1 abcdef
teststringobj setlength 1 10
list [teststringobj length 1] [teststringobj length2 1]
} {10 10}
test stringObj-4.3 {Tcl_SetObjLength procedure, string gets longer} {
testobj freeallvars
teststringobj set 1 abcdef
teststringobj append 1 xyzq -1
list [teststringobj length 1] [teststringobj length2 1] \
[teststringobj get 1]
} {10 20 abcdefxyzq}
test stringObj-4.4 {Tcl_SetObjLength procedure, "expty string", length 0} {
testobj freeallvars
testobj newobj 1
teststringobj setlength 1 0
list [teststringobj length2 1] [teststringobj get 1]
} {0 {}}
test stringObj-5.1 {Tcl_AppendToObj procedure, type conversion} {
testobj freeallvars
testintobj set2 1 43
teststringobj append 1 xyz -1
teststringobj get 1
} {43xyz}
test stringObj-5.2 {Tcl_AppendToObj procedure, length calculation} {
testobj freeallvars
teststringobj set 1 {x y }
teststringobj append 1 bbCCddEE 4
teststringobj append 1 123 -1
teststringobj get 1
} {x y bbCC123}
test stringObj-5.3 {Tcl_AppendToObj procedure, reallocating space} {
testobj freeallvars
teststringobj set 1 xyz
teststringobj setlength 1 15
teststringobj setlength 1 2
set result {}
teststringobj append 1 1234567890123 -1
lappend result [teststringobj length 1] [teststringobj length2 1]
teststringobj setlength 1 10
teststringobj append 1 abcdef -1
lappend result [teststringobj length 1] [teststringobj length2 1] \
[teststringobj get 1]
} {15 15 16 32 xy12345678abcdef}
test stringObj-6.1 {Tcl_AppendStringsToObj procedure, type conversion} {
testobj freeallvars
teststringobj set2 1 [list a b]
teststringobj appendstrings 1 xyz { 1234 } foo
teststringobj get 1
} {a bxyz 1234 foo}
test stringObj-6.2 {Tcl_AppendStringsToObj procedure, counting space} {
testobj freeallvars
teststringobj set 1 abc
teststringobj appendstrings 1
list [teststringobj length 1] [teststringobj get 1]
} {3 abc}
test stringObj-6.3 {Tcl_AppendStringsToObj procedure, counting space} {
testobj freeallvars
teststringobj set 1 abc
teststringobj appendstrings 1 {} {} {} {}
list [teststringobj length 1] [teststringobj get 1]
} {3 abc}
test stringObj-6.4 {Tcl_AppendStringsToObj procedure, counting space} {
testobj freeallvars
teststringobj set 1 abc
teststringobj appendstrings 1 { 123 } abcdefg
list [teststringobj length 1] [teststringobj get 1]
} {15 {abc 123 abcdefg}}
test stringObj-6.5 {Tcl_AppendStringsToObj procedure, don't double space if initial string empty} {
testobj freeallvars
testobj newobj 1
teststringobj appendstrings 1 123 abcdefg
list [teststringobj length 1] [teststringobj length2 1] [teststringobj get 1]
} {10 10 123abcdefg}
test stringObj-6.6 {Tcl_AppendStringsToObj procedure, space reallocation} {
testobj freeallvars
teststringobj set 1 abc
teststringobj setlength 1 10
teststringobj setlength 1 2
teststringobj appendstrings 1 34567890
list [teststringobj length 1] [teststringobj length2 1] \
[teststringobj get 1]
} {10 10 ab34567890}
test stringObj-6.7 {Tcl_AppendStringsToObj procedure, space reallocation} {
testobj freeallvars
teststringobj set 1 abc
teststringobj setlength 1 10
teststringobj setlength 1 2
teststringobj appendstrings 1 34567890x
list [teststringobj length 1] [teststringobj length2 1] \
[teststringobj get 1]
} {11 22 ab34567890x}
test stringObj-6.8 {Tcl_AppendStringsToObj procedure, object totally empty} {
testobj freeallvars
testobj newobj 1
teststringobj appendstrings 1 {}
list [teststringobj length2 1] [teststringobj get 1]
} {0 {}}
test stringObj-7.1 {ConvertToStringType procedure} {
testobj freeallvars
teststringobj set2 1 [list a b]
teststringobj append 1 x -1
list [teststringobj length 1] [teststringobj length2 1] \
[teststringobj get 1]
} {4 8 {a bx}}
test stringObj-7.2 {ConvertToStringType procedure, null object} {
testobj freeallvars
testobj newobj 1
teststringobj appendstrings 1 {}
list [teststringobj length 1] [teststringobj length2 1] \
[teststringobj get 1]
} {0 0 {}}
test stringObj-8.1 {DupStringInternalRep procedure} {
testobj freeallvars
teststringobj set 1 {}
teststringobj append 1 abcde -1
testobj duplicate 1 2
list [teststringobj length 1] [teststringobj length2 1] \
[teststringobj length 2] [teststringobj length2 2] \
[teststringobj get 2]
} {5 10 5 5 abcde}
testobj freeallvars
# cleanup
::tcltest::cleanupTests
return
|
