summaryrefslogtreecommitdiffstats
path: root/tests/source.test
blob: e79b21105b1bba36bc17019c19ac9503c6499c7f (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
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
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
# Commands covered:  source
#
# 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-2000 by Scriptics Corporation.
# Contributions from Don Porter, NIST, 2003.  (not subject to US copyright)
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

if {[catch {package require tcltest 2.1}]} {
    puts stderr "Skipping tests in [info script]. tcltest 2.1 required."
    return
}

namespace eval ::tcl::test::source {
    namespace import ::tcltest::*

test source-1.1 {source command} -setup {
    set x "old x value"
    set y "old y value"
    set z "old z value"
    set sourcefile [makeFile {
	set x 22
	set y 33
	set z 44
    } source.file]
} -body {
    source $sourcefile
    list $x $y $z
} -cleanup {
    removeFile source.file
} -result {22 33 44}
test source-1.2 {source command} -setup {
    set sourcefile [makeFile {list result} source.file]
} -body {
    source $sourcefile
} -cleanup {
    removeFile source.file
} -result result
test source-1.3 {source command} -setup {
    set sourcefile [makeFile {} source.file]
    set fd [open $sourcefile w]
    fconfigure $fd -translation lf
    puts $fd "list a b c \\"
    puts $fd "d e f"
    close $fd
} -body {
    source $sourcefile
} -cleanup {
    removeFile source.file
} -result {a b c d e f}

proc ListGlobMatch {expected actual} {
    if {[llength $expected] != [llength $actual]} {
        return 0
    }
    foreach e $expected a $actual {
        if {![string match $e $a]} {
            return 0
        }
    }
    return 1
}
customMatch listGlob [namespace which ListGlobMatch]

test source-2.3 {source error conditions} -setup {
    set sourcefile [makeFile {
	set x 146
	error "error in sourced file"
	set y $x
    } source.file]
} -body {
    list [catch {source $sourcefile} msg] $msg $::errorInfo
} -cleanup {
    removeFile source.file
} -match listGlob -result [list 1 {error in sourced file} \
	{error in sourced file
    while executing
"error "error in sourced file""
    (file "*source.file" line 3)
    invoked from within
"source $sourcefile"}]
test source-2.4 {source error conditions} -setup {
    set sourcefile [makeFile {break} source.file]
} -body {
    source $sourcefile
} -cleanup {
    removeFile source.file
} -returnCodes break
test source-2.5 {source error conditions} -setup {
    set sourcefile [makeFile {continue} source.file]
} -body {
    source $sourcefile
} -cleanup {
    removeFile source.file
} -returnCodes continue
test source-2.6 {source error conditions} -setup {
    set sourcefile [makeFile {} _non_existent_]
    removeFile _non_existent_
} -body {
    list [catch {source $sourcefile} msg] $msg $::errorCode
} -match listGlob -result [list 1 \
	{couldn't read file "*_non_existent_": no such file or directory} \
	{POSIX ENOENT {no such file or directory}}]
test source-2.7 {utf-8 with BOM} -setup {
    set sourcefile [makeFile {} source.file]
} -body {
    set out [open $sourcefile w]
    fconfigure $out -encoding utf-8
    puts $out "\ufffeset y new-y"
    close $out
    set y old-y
    source -encoding utf-8 $sourcefile
    return $y
} -cleanup {
    removeFile $sourcefile
} -result {new-y}

test source-3.1 {return in middle of source file} -setup {
    set sourcefile [makeFile {
	set x new-x
	return allDone
	set y new-y
    } source.file]
} -body {
    set x old-x
    set y old-y
    set z [source $sourcefile]
    list $x $y $z
} -cleanup {
    removeFile source.file
} -result {new-x old-y allDone}
test source-3.2 {return with special code etc.} -setup {
    set sourcefile [makeFile {
	set x new-x
	return -code break "Silly result"
	set y new-y
    } source.file]
} -body {
   source $sourcefile
} -cleanup {
    removeFile source.file
} -returnCodes break -result {Silly result}
test source-3.3 {return with special code etc.} -setup {
    set sourcefile [makeFile {
	set x new-x
	return -code error "Simulated error"
	set y new-y
    } source.file]
} -body {
    list [catch {source $sourcefile} msg] $msg $::errorInfo $::errorCode
} -cleanup {
    removeFile source.file
} -result {1 {Simulated error} {Simulated error
    while executing
"source $sourcefile"} NONE}
test source-3.4 {return with special code etc.} -setup {
    set sourcefile [makeFile {
	set x new-x
	return -code error -errorinfo "Simulated errorInfo stuff"
	set y new-y
    } source.file]
} -body {
    list [catch {source $sourcefile} msg] $msg $::errorInfo $::errorCode
} -cleanup {
    removeFile source.file
} -result {1 {} {Simulated errorInfo stuff
    invoked from within
"source $sourcefile"} NONE}
test source-3.5 {return with special code etc.} -setup {
    set sourcefile [makeFile {
	set x new-x
	return -code error -errorinfo "Simulated errorInfo stuff" \
		-errorcode {a b c}
	set y new-y
    } source.file]
} -body {
    list [catch {source $sourcefile} msg] $msg $::errorInfo $::errorCode
} -cleanup {
    removeFile source.file
} -result {1 {} {Simulated errorInfo stuff
    invoked from within
"source $sourcefile"} {a b c}}

test source-6.1 {source is binary ok} -setup {
    # Note [makeFile] writes in the system encoding.
    # [source] defaults to reading in the system encoding.
    set sourcefile [makeFile [list set x "a b\0c"] source.file]
} -body {
    set x {}
    source $sourcefile
    string length $x
} -cleanup {
    removeFile source.file
} -result 5
test source-6.2 {source skips everything after Ctrl-Z: Bug 2040} -setup {
    set sourcefile [makeFile "set x ab\32c" source.file]
} -body {
    set x {}
    source $sourcefile
    string length $x
} -cleanup {
    removeFile source.file
} -result 2

test source-7.1 {source -encoding test} -setup {
    set sourcefile [makeFile {} source.file]
    file delete $sourcefile
    set f [open $sourcefile w]
    fconfigure $f -encoding utf-8
    puts $f "set symbol(square-root) \u221A; set x correct"
    close $f
} -body {
    set x unset
    source -encoding utf-8 $sourcefile
    set x
} -cleanup {
    removeFile source.file
} -result correct
test source-7.2 {source -encoding test} -setup {
    # This tests for bad interactions between [source -encoding]
    # and use of the Control-Z character (\u001A) as a cross-platform
    # EOF character by [source].  Here we write out and the [source] a
    # file that contains the byte \x1A, although not the character \u001A in
    # the indicated encoding.
    set sourcefile [makeFile {} source.file]
    file delete $sourcefile
    set f [open $sourcefile w]
    fconfigure $f -encoding unicode
    puts $f "set symbol(square-root) \u221A; set x correct"
    close $f
} -body {
    set x unset
    source -encoding unicode $sourcefile
    set x
} -cleanup {
    removeFile source.file
} -result correct
test source-7.3 {source -encoding: syntax} -body {
    # Have to spell out the -encoding option
    source -e utf-8 no_file
} -returnCodes 1 -match glob -result {bad option*}
test source-7.4 {source -encoding: syntax} -setup {
    set sourcefile [makeFile {} source.file]
} -body {
    source -encoding no-such-encoding $sourcefile
} -cleanup {
    removeFile source.file
} -returnCodes 1 -match glob -result {unknown encoding*}
test source-7.5 {source -encoding: correct operation} -setup {
    set sourcefile [makeFile {} source.file]
    file delete $sourcefile
    set f [open $sourcefile w]
    fconfigure $f -encoding utf-8
    puts $f "proc \u20ac {} {return foo}"
    close $f
} -body {
    source -encoding utf-8 $sourcefile
    \u20ac
} -cleanup {
    removeFile source.file
    rename \u20ac {}
} -result foo
test source-7.6 {source -encoding: mismatch encoding error} -setup {
    set sourcefile [makeFile {} source.file]
    file delete $sourcefile
    set f [open $sourcefile w]
    fconfigure $f -encoding utf-8
    puts $f "proc \u20ac {} {return foo}"
    close $f
} -body {
    source -encoding ascii $sourcefile
    \u20ac
} -cleanup {
    removeFile source.file
} -returnCodes error -match glob -result {invalid command name*}

cleanupTests
}
namespace delete ::tcl::test::source
return