1 | # The file tests the functions in the tclUnixInit.c file. |
---|
2 | # |
---|
3 | # This file contains a collection of tests for one or more of the Tcl |
---|
4 | # built-in commands. Sourcing this file into Tcl runs the tests and |
---|
5 | # generates output for errors. No output means no errors were found. |
---|
6 | # |
---|
7 | # Copyright (c) 1997 by Sun Microsystems, Inc. |
---|
8 | # Copyright (c) 1998-1999 by Scriptics Corporation. |
---|
9 | # |
---|
10 | # See the file "license.terms" for information on usage and redistribution |
---|
11 | # of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
---|
12 | # |
---|
13 | # RCS: @(#) $Id: unixInit.test,v 1.50 2006/11/03 11:45:35 dkf Exp $ |
---|
14 | |
---|
15 | package require tcltest 2.2 |
---|
16 | namespace import -force ::tcltest::* |
---|
17 | unset -nocomplain path |
---|
18 | catch {set oldlang $env(LANG)} |
---|
19 | set env(LANG) C |
---|
20 | |
---|
21 | test unixInit-1.1 {TclpInitPlatform: ignore SIGPIPE} {unix stdio} { |
---|
22 | set x {} |
---|
23 | # Watch out for a race condition here. If tcltest is too slow to start |
---|
24 | # then we'll kill it before it has a chance to set up its signal handler. |
---|
25 | set f [open "|[list [interpreter]]" w+] |
---|
26 | puts $f "puts hi" |
---|
27 | flush $f |
---|
28 | gets $f |
---|
29 | exec kill -PIPE [pid $f] |
---|
30 | lappend x [catch {close $f}] |
---|
31 | set f [open "|[list [interpreter]]" w+] |
---|
32 | puts $f "puts hi" |
---|
33 | flush $f |
---|
34 | gets $f |
---|
35 | exec kill [pid $f] |
---|
36 | lappend x [catch {close $f}] |
---|
37 | set x |
---|
38 | } {0 1} |
---|
39 | # This test is really a test of code in tclUnixChan.c, but the |
---|
40 | # channels are set up as part of initialisation of the interpreter so |
---|
41 | # the test seems to me to fit here as well as anywhere else. |
---|
42 | test unixInit-1.2 {initialisation: standard channel type deduction} {unix stdio} { |
---|
43 | # pipe1 is a connection to a server that reports what port it |
---|
44 | # starts on, and delivers a constant string to the first client to |
---|
45 | # connect to that port before exiting. |
---|
46 | set pipe1 [open "|[list [interpreter]]" r+] |
---|
47 | puts $pipe1 { |
---|
48 | proc accept {channel host port} { |
---|
49 | puts $channel {puts [fconfigure stdin -peername]; exit} |
---|
50 | close $channel |
---|
51 | exit |
---|
52 | } |
---|
53 | puts [fconfigure [socket -server accept -myaddr 127.0.0.1 0] -sockname] |
---|
54 | vwait forever \ |
---|
55 | } |
---|
56 | # Note the backslash above; this is important to make sure that the |
---|
57 | # whole string is read before an [exit] can happen... |
---|
58 | flush $pipe1 |
---|
59 | set port [lindex [gets $pipe1] 2] |
---|
60 | set sock [socket localhost $port] |
---|
61 | # pipe2 is a connection to a Tcl interpreter that takes its orders |
---|
62 | # from the socket we hand it (i.e. the server we create above.) |
---|
63 | # These orders will tell it to print out the details about the |
---|
64 | # socket it is taking instructions from, hopefully identifying it |
---|
65 | # as a socket. Which is what this test is all about. |
---|
66 | set pipe2 [open "|[list [interpreter] <@$sock]" r] |
---|
67 | set result [gets $pipe2] |
---|
68 | # Clear any pending data; stops certain kinds of (non-important) errors |
---|
69 | fconfigure $pipe1 -blocking 0; gets $pipe1 |
---|
70 | fconfigure $pipe2 -blocking 0; gets $pipe2 |
---|
71 | # Close the pipes and the socket. |
---|
72 | close $pipe2 |
---|
73 | close $pipe1 |
---|
74 | catch {close $sock} |
---|
75 | # Can't use normal comparison, as hostname varies due to some |
---|
76 | # installations having a messed up /etc/hosts file. |
---|
77 | if { |
---|
78 | [string equal 127.0.0.1 [lindex $result 0]] && |
---|
79 | [string equal $port [lindex $result 2]] |
---|
80 | } then { |
---|
81 | subst "OK" |
---|
82 | } else { |
---|
83 | subst "Expected: `[list 127.0.0.1 localhost $port]', Got `$result'" |
---|
84 | } |
---|
85 | } {OK} |
---|
86 | |
---|
87 | # The unixInit-2.* tests were written to test the internal routine, |
---|
88 | # TclpInitLibraryPath. That routine no longer does the things it used |
---|
89 | # to do so those tests are obsolete. Skip them. |
---|
90 | |
---|
91 | skip [concat [skip] unixInit-2.*] |
---|
92 | |
---|
93 | test unixInit-2.0 {TclpInitLibraryPath: setting tclDefaultEncodingDir} { |
---|
94 | set origDir [testgetdefenc] |
---|
95 | testsetdefenc slappy |
---|
96 | set path [testgetdefenc] |
---|
97 | testsetdefenc $origDir |
---|
98 | set path |
---|
99 | } {slappy} |
---|
100 | test unixInit-2.1 {TclpInitLibraryPath: value of installLib, developLib} -setup { |
---|
101 | unset -nocomplain oldlibrary |
---|
102 | if {[info exists env(TCL_LIBRARY)]} { |
---|
103 | set oldlibrary $env(TCL_LIBRARY) |
---|
104 | unset env(TCL_LIBRARY) |
---|
105 | } |
---|
106 | } -body { |
---|
107 | set path [getlibpath] |
---|
108 | set installLib lib/tcl[info tclversion] |
---|
109 | set developLib tcl[info patchlevel]/library |
---|
110 | set prefix [file dirname [file dirname [interpreter]]] |
---|
111 | set x {} |
---|
112 | lappend x [string compare [lindex $path 0] $prefix/$installLib] |
---|
113 | lappend x [string compare [lindex $path 4] [file dirname $prefix]/$developLib] |
---|
114 | set x |
---|
115 | } -cleanup { |
---|
116 | if {[info exists oldlibrary]} { |
---|
117 | set env(TCL_LIBRARY) $oldlibrary |
---|
118 | unset oldlibrary |
---|
119 | } |
---|
120 | } -result {0 0} |
---|
121 | test unixInit-2.2 {TclpInitLibraryPath: TCL_LIBRARY} -setup { |
---|
122 | unset -nocomplain oldlibrary |
---|
123 | if {[info exists env(TCL_LIBRARY)]} { |
---|
124 | set oldlibrary $env(TCL_LIBRARY) |
---|
125 | } |
---|
126 | } -body { |
---|
127 | # ((str != NULL) && (str[0] != '\0')) |
---|
128 | set env(TCL_LIBRARY) sparkly |
---|
129 | set path [getlibpath] |
---|
130 | unset env(TCL_LIBRARY) |
---|
131 | lindex $path 0 |
---|
132 | } -cleanup { |
---|
133 | if {[info exists oldlibrary]} { |
---|
134 | set env(TCL_LIBRARY) $oldlibrary |
---|
135 | unset oldlibrary |
---|
136 | } |
---|
137 | } -result "sparkly" |
---|
138 | test unixInit-2.3 {TclpInitLibraryPath: TCL_LIBRARY wrong version} -setup { |
---|
139 | unset -nocomplain oldlibrary |
---|
140 | if {[info exists env(TCL_LIBRARY)]} { |
---|
141 | set oldlibrary $env(TCL_LIBRARY) |
---|
142 | } |
---|
143 | } -body { |
---|
144 | # ((pathc > 0) && (strcasecmp(installLib + 4, pathv[pathc - 1]) != 0)) |
---|
145 | set env(TCL_LIBRARY) /a/b/tcl1.7 |
---|
146 | set path [getlibpath] |
---|
147 | unset env(TCL_LIBRARY) |
---|
148 | lrange $path 0 1 |
---|
149 | } -cleanup { |
---|
150 | if {[info exists oldlibrary]} { |
---|
151 | set env(TCL_LIBRARY) $oldlibrary |
---|
152 | unset oldlibrary |
---|
153 | } |
---|
154 | } -result [list /a/b/tcl1.7 /a/b/tcl[info tclversion]] |
---|
155 | test unixInit-2.4 {TclpInitLibraryPath: TCL_LIBRARY: INTL} -setup { |
---|
156 | if {[info exists env(TCL_LIBRARY)]} { |
---|
157 | set oldlibrary $env(TCL_LIBRARY) |
---|
158 | } |
---|
159 | } -body { |
---|
160 | # Child process translates env variable from native encoding. |
---|
161 | set env(TCL_LIBRARY) "\xa7" |
---|
162 | set x [lindex [getlibpath] 0] |
---|
163 | unset env(TCL_LIBRARY) |
---|
164 | unset env(LANG) |
---|
165 | set x |
---|
166 | } -cleanup { |
---|
167 | if {[info exists oldlibrary]} { |
---|
168 | set env(TCL_LIBRARY) $oldlibrary |
---|
169 | unset oldlibrary |
---|
170 | } |
---|
171 | } -result "\xa7" |
---|
172 | test unixInit-2.5 {TclpInitLibraryPath: compiled-in library path} { |
---|
173 | # cannot test |
---|
174 | } {} |
---|
175 | test unixInit-2.6 {TclpInitLibraryPath: executable relative} -setup { |
---|
176 | unset -nocomplain oldlibrary |
---|
177 | if {[info exists env(TCL_LIBRARY)]} { |
---|
178 | set oldlibrary $env(TCL_LIBRARY) |
---|
179 | } |
---|
180 | set env(TCL_LIBRARY) [info library] |
---|
181 | makeDirectory tmp |
---|
182 | makeDirectory [file join tmp sparkly] |
---|
183 | makeDirectory [file join tmp sparkly bin] |
---|
184 | file copy [interpreter] [file join [temporaryDirectory] tmp sparkly \ |
---|
185 | bin tcltest] |
---|
186 | makeDirectory [file join tmp sparkly lib] |
---|
187 | makeDirectory [file join tmp sparkly lib tcl[info tclversion]] |
---|
188 | makeFile {} [file join tmp sparkly lib tcl[info tclversion] init.tcl] |
---|
189 | } -body { |
---|
190 | lrange [getlibpath [file join [temporaryDirectory] tmp sparkly \ |
---|
191 | bin tcltest]] 1 2 |
---|
192 | } -cleanup { |
---|
193 | removeFile [file join tmp sparkly lib tcl[info tclversion] init.tcl] |
---|
194 | removeDirectory [file join tmp sparkly lib tcl[info tclversion]] |
---|
195 | removeDirectory [file join tmp sparkly lib] |
---|
196 | removeDirectory [file join tmp sparkly bin] |
---|
197 | removeDirectory [file join tmp sparkly] |
---|
198 | removeDirectory tmp |
---|
199 | unset env(TCL_LIBRARY) |
---|
200 | if {[info exists oldlibrary]} { |
---|
201 | set env(TCL_LIBRARY) $oldlibrary |
---|
202 | unset oldlibrary |
---|
203 | } |
---|
204 | } -result [list [temporaryDirectory]/tmp/sparkly/lib/tcl[info tclversion] [temporaryDirectory]/tmp/lib/tcl[info tclversion]] |
---|
205 | test unixInit-2.7 {TclpInitLibraryPath: compiled-in library path} { |
---|
206 | # would need test command to get defaultLibDir and compare it to |
---|
207 | # [lindex $auto_path end] |
---|
208 | } {} |
---|
209 | # |
---|
210 | # The following two tests write to the directory /tmp/sparkly instead |
---|
211 | # of to [temporaryDirectory]. This is because the failures tested by |
---|
212 | # these tests need paths near the "root" of the file system to present |
---|
213 | # themselves. |
---|
214 | # |
---|
215 | test unixInit-2.8 {TclpInitLibraryPath: all absolute pathtype} -setup { |
---|
216 | unset -nocomplain oldlibrary |
---|
217 | if {[info exists env(TCL_LIBRARY)]} { |
---|
218 | set oldlibrary $env(TCL_LIBRARY) |
---|
219 | } |
---|
220 | set env(TCL_LIBRARY) [info library] |
---|
221 | # Checking for Bug 219416 |
---|
222 | # When a program that embeds the Tcl library, like tcltest, is |
---|
223 | # installed near the "root" of the file system, there was a problem |
---|
224 | # constructing directories relative to the executable. When a |
---|
225 | # relative ".." went past the root, relative path names were created |
---|
226 | # rather than absolute pathnames. In some cases, accessing past the |
---|
227 | # root caused memory access violations too. |
---|
228 | # |
---|
229 | # The bug is now fixed, but here we check for it by making sure that |
---|
230 | # the directories constructed relative to the executable are all |
---|
231 | # absolute pathnames, even when the executable is installed near |
---|
232 | # the root of the filesystem. |
---|
233 | # |
---|
234 | # The only directory near the root we are likely to have write access |
---|
235 | # to is /tmp. |
---|
236 | file delete -force /tmp/sparkly |
---|
237 | file delete -force /tmp/lib/tcl[info tclversion] |
---|
238 | file mkdir /tmp/sparkly |
---|
239 | file copy [interpreter] /tmp/sparkly/tcltest |
---|
240 | # Keep any existing /tmp/lib directory |
---|
241 | set deletelib 1 |
---|
242 | if {[file exists /tmp/lib]} { |
---|
243 | if {[file isdirectory /tmp/lib]} { |
---|
244 | set deletelib 0 |
---|
245 | } else { |
---|
246 | file delete -force /tmp/lib |
---|
247 | } |
---|
248 | } |
---|
249 | # For a successful Tcl_Init, we need a [source]-able init.tcl in |
---|
250 | # ../lib/tcl$version relative to the executable. |
---|
251 | file mkdir /tmp/lib/tcl[info tclversion] |
---|
252 | close [open /tmp/lib/tcl[info tclversion]/init.tcl w] |
---|
253 | } -body { |
---|
254 | # Check that all directories in the library path are absolute pathnames |
---|
255 | set allAbsolute 1 |
---|
256 | foreach dir [getlibpath /tmp/sparkly/tcltest] { |
---|
257 | set allAbsolute [expr {$allAbsolute \ |
---|
258 | && [string equal absolute [file pathtype $dir]]}] |
---|
259 | } |
---|
260 | set allAbsolute |
---|
261 | } -cleanup { |
---|
262 | # Clean up temporary installation |
---|
263 | file delete -force /tmp/sparkly |
---|
264 | file delete -force /tmp/lib/tcl[info tclversion] |
---|
265 | if {$deletelib} {file delete -force /tmp/lib} |
---|
266 | unset env(TCL_LIBRARY) |
---|
267 | if {[info exists oldlibrary]} { |
---|
268 | set env(TCL_LIBRARY) $oldlibrary |
---|
269 | unset oldlibrary |
---|
270 | } |
---|
271 | } -result 1 |
---|
272 | test unixInit-2.9 {TclpInitLibraryPath: paths relative to executable} -setup { |
---|
273 | # Checking for Bug 438014 |
---|
274 | unset -nocomplain oldlibrary |
---|
275 | if {[info exists env(TCL_LIBRARY)]} { |
---|
276 | set oldlibrary $env(TCL_LIBRARY) |
---|
277 | } |
---|
278 | set env(TCL_LIBRARY) [info library] |
---|
279 | file delete -force /tmp/sparkly |
---|
280 | file delete -force /tmp/library |
---|
281 | file mkdir /tmp/sparkly |
---|
282 | file copy [interpreter] /tmp/sparkly/tcltest |
---|
283 | file mkdir /tmp/library/ |
---|
284 | close [open /tmp/library/init.tcl w] |
---|
285 | } -body { |
---|
286 | lrange [getlibpath /tmp/sparkly/tcltest] 1 5 |
---|
287 | } -cleanup { |
---|
288 | file delete -force /tmp/sparkly |
---|
289 | file delete -force /tmp/library |
---|
290 | unset env(TCL_LIBRARY) |
---|
291 | if {[info exists oldlibrary]} { |
---|
292 | set env(TCL_LIBRARY) $oldlibrary |
---|
293 | unset oldlibrary |
---|
294 | } |
---|
295 | } -result [list /tmp/lib/tcl[info tclversion] /lib/tcl[info tclversion] \ |
---|
296 | /tmp/library /library /tcl[info patchlevel]/library] |
---|
297 | test unixInit-2.10 {TclpInitLibraryPath: executable relative} -setup { |
---|
298 | unset -nocomplain oldlibrary |
---|
299 | if {[info exists env(TCL_LIBRARY)]} { |
---|
300 | set oldlibrary $env(TCL_LIBRARY) |
---|
301 | } |
---|
302 | set env(TCL_LIBRARY) [info library] |
---|
303 | set tmpDir [makeDirectory tmp] |
---|
304 | set sparklyDir [makeDirectory sparkly $tmpDir] |
---|
305 | set execPath [file join [makeDirectory bin $sparklyDir] tcltest] |
---|
306 | file copy [interpreter] $execPath |
---|
307 | set libDir [makeDirectory lib $sparklyDir] |
---|
308 | set scriptDir [makeDirectory tcl[info tclversion] $libDir] |
---|
309 | makeFile {} init.tcl $scriptDir |
---|
310 | set saveDir [pwd] |
---|
311 | cd $libDir |
---|
312 | } -body { |
---|
313 | # Checking for Bug 832657 |
---|
314 | set x [lrange [getlibpath [file join .. bin tcltest]] 3 4] |
---|
315 | foreach p $x { |
---|
316 | lappend y [file normalize $p] |
---|
317 | } |
---|
318 | set y |
---|
319 | } -cleanup { |
---|
320 | cd $saveDir |
---|
321 | unset saveDir |
---|
322 | removeFile init.tcl $scriptDir |
---|
323 | unset scriptDir |
---|
324 | removeDirectory tcl[info tclversion] $libDir |
---|
325 | unset libDir |
---|
326 | file delete $execPath |
---|
327 | unset execPath |
---|
328 | removeDirectory bin $sparklyDir |
---|
329 | removeDirectory lib $sparklyDir |
---|
330 | unset sparklyDir |
---|
331 | removeDirectory sparkly $tmpDir |
---|
332 | unset tmpDir |
---|
333 | removeDirectory tmp |
---|
334 | unset x p y |
---|
335 | unset env(TCL_LIBRARY) |
---|
336 | if {[info exists oldlibrary]} { |
---|
337 | set env(TCL_LIBRARY) $oldlibrary |
---|
338 | unset oldlibrary |
---|
339 | } |
---|
340 | } -result [list [file join [temporaryDirectory] tmp sparkly library] \ |
---|
341 | [file join [temporaryDirectory] tmp library] ] |
---|
342 | |
---|
343 | test unixInit-3.1 {TclpSetInitialEncodings} -constraints { |
---|
344 | unix stdio |
---|
345 | } -body { |
---|
346 | set env(LANG) C |
---|
347 | set f [open "|[list [interpreter]]" w+] |
---|
348 | fconfigure $f -buffering none |
---|
349 | puts $f {puts [encoding system]; exit} |
---|
350 | set enc [gets $f] |
---|
351 | close $f |
---|
352 | unset env(LANG) |
---|
353 | set enc |
---|
354 | } -match regexp -result [expr { |
---|
355 | ($tcl_platform(os) eq "Darwin") ? "^utf-8$" : "^iso8859-15?$"}] |
---|
356 | test unixInit-3.2 {TclpSetInitialEncodings} {unix stdio} { |
---|
357 | set env(LANG) japanese |
---|
358 | catch {set oldlc_all $env(LC_ALL)} |
---|
359 | set env(LC_ALL) japanese |
---|
360 | set f [open "|[list [interpreter]]" w+] |
---|
361 | fconfigure $f -buffering none |
---|
362 | puts $f {puts [encoding system]; exit} |
---|
363 | set enc [gets $f] |
---|
364 | close $f |
---|
365 | unset env(LANG) |
---|
366 | unset env(LC_ALL) |
---|
367 | catch {set env(LC_ALL) $oldlc_all} |
---|
368 | set validEncodings [list euc-jp] |
---|
369 | if {[string match HP-UX $tcl_platform(os)]} { |
---|
370 | # Some older HP-UX systems need us to accept this as valid |
---|
371 | # Bug 453883 reports that newer HP-UX systems report euc-jp |
---|
372 | # like everybody else. |
---|
373 | lappend validEncodings shiftjis |
---|
374 | } |
---|
375 | expr {[lsearch -exact $validEncodings $enc] < 0} |
---|
376 | } 0 |
---|
377 | |
---|
378 | test unixInit-4.1 {TclpSetVariables} {unix} { |
---|
379 | # just make sure they exist |
---|
380 | set a [list $tcl_library $tcl_pkgPath $tcl_platform(os)] |
---|
381 | set a [list $tcl_platform(osVersion) $tcl_platform(machine)] |
---|
382 | set tcl_platform(platform) |
---|
383 | } "unix" |
---|
384 | |
---|
385 | test unixInit-5.1 {Tcl_Init} {emptyTest unix} { |
---|
386 | # test initScript |
---|
387 | } {} |
---|
388 | |
---|
389 | test unixInit-6.1 {Tcl_SourceRCFile} {emptyTest unix} { |
---|
390 | } {} |
---|
391 | |
---|
392 | test unixInit-7.1 {closed standard channel: Bug 772288} -constraints { |
---|
393 | unix stdio |
---|
394 | } -body { |
---|
395 | set tclsh [interpreter] |
---|
396 | set crash [makeFile {puts [open /dev/null]} crash.tcl] |
---|
397 | set crashtest [makeFile " |
---|
398 | close stdin |
---|
399 | [list exec $tclsh $crash] |
---|
400 | " crashtest.tcl] |
---|
401 | exec $tclsh $crashtest |
---|
402 | } -cleanup { |
---|
403 | removeFile crash.tcl |
---|
404 | removeFile crashtest.tcl |
---|
405 | } -returnCodes 0 |
---|
406 | |
---|
407 | # cleanup |
---|
408 | catch {unset env(LANG)} |
---|
409 | catch {set env(LANG) $oldlang} |
---|
410 | unset -nocomplain path |
---|
411 | ::tcltest::cleanupTests |
---|
412 | return |
---|
413 | |
---|