summaryrefslogtreecommitdiffstats
path: root/tests/unixInit.test
blob: 8370d6a1a2531fcf6eb2a7b7ce945c2b88a69136 (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
# The file tests the functions in the tclUnixInit.c file.
#
# 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) 1997 by 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: unixInit.test,v 1.17 2001/07/02 20:57:02 dgp Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

if {[info exists env(TCL_LIBRARY)]} {
    set oldlibrary $env(TCL_LIBRARY)
    unset env(TCL_LIBRARY)
}
catch {set oldlang $env(LANG)}
set env(LANG) C

# Some tests will fail if they are run on a machine that doesn't have
# this Tcl version installed (as opposed to built) on it.
if {[catch {
    set f [open "|[list $::tcltest::tcltest]" w+]
    exec kill -PIPE [pid $f]
    close $f
} msg]} {
    set ::tcltest::testConstraints(installedTcl) 0
} else {
    set ::tcltest::testConstraints(installedTcl) 1
}

test unixInit-1.1 {TclpInitPlatform: ignore SIGPIPE} {unixOnly installedTcl} {
    set x {}

    # Watch out for a race condition here.  If tcltest is too slow to start
    # then we'll kill it before it has a chance to set up its signal handler.
    
    set f [open "|[list $::tcltest::tcltest]" w+]
    puts $f "puts hi"
    flush $f
    gets $f
    exec kill -PIPE [pid $f]
    lappend x [catch {close $f}]

    set f [open "|[list $::tcltest::tcltest]" w+]
    puts $f "puts hi"
    flush $f
    gets $f
    exec kill [pid $f]
    lappend x [catch {close $f}]

    set x
} {0 1}

# This test is really a test of code in tclUnixChan.c, but the
# channels are set up as part of initialisation of the interpreter so
# the test seems to me to fit here as well as anywhere else.
test unixInit-1.2 {initialisation: channel type deduction} {unixOnly installedTcl} {
    set pipe1 [open |[list $::tcltest::tcltest] r+]
    puts $pipe1 {
	proc accept {channel host port} {
	    puts $channel {
		puts [fconfigure stdin -peername]
		flush stdout
		exit
	    }
	    flush $channel
	    close $channel
	    exit
	}
	set server [socket -server accept 0]
	puts stdout [fconfigure $server -sockname]
	flush stdout
	update
	vwait forever \
	    }
    flush $pipe1
    set port [lindex [gets $pipe1] 2]
    set sock [socket localhost $port]
    set pipe2 [open |[list $::tcltest::tcltest <@$sock] r]
    set result [gets $pipe2]
    close $pipe2
    close $pipe1
    catch {close $sock}
    set expected [list 127.0.0.1 localhost $port]
    if {[string equal $expected $result]} {
	subst "OK"
    } else {
	subst "Expected: $expected, Got $result"
    }
} {OK}

proc getlibpath "{program [list $::tcltest::tcltest]}" {
    set f [open "|$program" w+]
    fconfigure $f -buffering none
    puts $f {puts $tcl_libPath; exit}
    set path [gets $f]
    close $f
    return $path
}

# Some tests require the testgetdefenc command

set ::tcltest::testConstraints(testgetdefenc) \
	[expr {[info commands testgetdefenc] != {}}]

test unixInit-2.0 {TclpInitLibraryPath: setting tclDefaultEncodingDir} \
	{unixOnly testgetdefenc} {
    set origDir [testgetdefenc]
    testsetdefenc slappy
    set path [testgetdefenc]
    testsetdefenc $origDir
    set path
} {slappy}
test unixInit-2.1 {TclpInitLibraryPath: value of installLib, developLib} \
	{unixOnly installedTcl} {
    set path [getlibpath]

    set installLib lib/tcl[info tclversion]
    if {[string match {*[ab]*} [info patchlevel]]} {
	set developLib tcl[info patchlevel]/library
    } else {
        set developLib tcl[info tclversion]/library
    }
    set prefix [file dirname [file dirname $::tcltest::tcltest]]

    set x {}
    lappend x [string compare [lindex $path 0] $prefix/$installLib]
    lappend x [string compare [lindex $path 4] [file dirname $prefix]/$developLib]
    set x
} {0 0}
test unixInit-2.2 {TclpInitLibraryPath: TCL_LIBRARY} {unixOnly installedTcl} {
    # ((str != NULL) && (str[0] != '\0')) 

    set env(TCL_LIBRARY) sparkly
    set path [getlibpath]
    unset env(TCL_LIBRARY)

    lindex $path 0
} "sparkly"
test unixInit-2.3 {TclpInitLibraryPath: TCL_LIBRARY wrong version} \
	{unixOnly installedTcl} {
    # ((pathc > 0) && (strcasecmp(installLib + 4, pathv[pathc - 1]) != 0))

    set env(TCL_LIBRARY) /a/b/tcl1.7
    set path [getlibpath]
    unset env(TCL_LIBRARY)

    lrange $path 0 1
} [list /a/b/tcl1.7 /a/b/tcl[info tclversion]]
test unixInit-2.4 {TclpInitLibraryPath: TCL_LIBRARY: INTL} \
	{unixOnly installedTcl} {
    # Child process translates env variable from native encoding.

    set env(TCL_LIBRARY) "\xa7"
    set x [lindex [getlibpath] 0]
    unset env(TCL_LIBRARY)
    unset env(LANG)

    set x
} "\xa7"
test unixInit-2.5 {TclpInitLibraryPath: compiled-in library path} \
	{emptyTest unixOnly} {
    # cannot test
} {}
test unixInit-2.6 {TclpInitLibraryPath: executable relative} \
	{unixOnly installedTcl} {
    file delete -force /tmp/sparkly
    file mkdir /tmp/sparkly/bin
    file copy $::tcltest::tcltest /tmp/sparkly/bin/tcltest

    file mkdir /tmp/sparkly/lib/tcl[info tclversion]
    close [open /tmp/sparkly/lib/tcl[info tclversion]/init.tcl w]

    set x [lrange [getlibpath /tmp/sparkly/bin/tcltest] 0 1]
    file delete -force /tmp/sparkly
    set x
} [list /tmp/sparkly/lib/tcl[info tclversion] /tmp/lib/tcl[info tclversion]]
test unixInit-2.7 {TclpInitLibraryPath: compiled-in library path} \
	{emptyTest unixOnly} {
    # would need test command to get defaultLibDir and compare it to
    # [lindex $auto_path end]
} {}
test unixInit-2.8 {TclpInitLibraryPath: all absolute pathtype} {unixOnly} {
    file delete -force /tmp/sparkly
    file delete -force /tmp/library
    file mkdir /tmp/sparkly
    file copy $::tcltest::tcltest /tmp/sparkly/tcltest

    file mkdir /tmp/library/
    close [open /tmp/library/init.tcl w]

    set allAbsolute 1
    foreach dir [getlibpath /tmp/sparkly/tcltest] {
	set allAbsolute [expr {$allAbsolute \
		&& [string equal absolute [file pathtype $dir]]}]
    }
    file delete -force /tmp/sparkly
    file delete -force /tmp/library
    set allAbsolute
} 1
test unixInit-2.9 {TclpInitLibraryPath: paths relative to executable} {
	unixOnly} {
    # Checking for Bug 438014
    file delete -force /tmp/sparkly
    file delete -force /tmp/library
    file mkdir /tmp/sparkly
    file copy $::tcltest::tcltest /tmp/sparkly/tcltest

    file mkdir /tmp/library/
    close [open /tmp/library/init.tcl w]

    set x [lrange [getlibpath /tmp/sparkly/tcltest] 0 4]

    file delete -force /tmp/sparkly
    file delete -force /tmp/library
    set x
} [list /tmp/lib/tcl[info tclversion] /lib/tcl[info tclversion] \
	/tmp/library /library /tcl[info patchlevel]/library]
test unixInit-3.1 {TclpSetInitialEncodings} {unixOnly installedTcl} {
    set env(LANG) C

    set f [open "|[list $::tcltest::tcltest]" w+]
    fconfigure $f -buffering none
    puts $f {puts [encoding system]; exit}
    set enc [gets $f]
    close $f
    unset env(LANG)

    set enc
} {iso8859-1}
test unixInit-3.2 {TclpSetInitialEncodings} {unixOnly installedTcl} {
    set env(LANG) japanese
    catch {set oldlc_all $env(LC_ALL)}
    set env(LC_ALL) japanese

    set f [open "|[list $::tcltest::tcltest]" w+]
    fconfigure $f -buffering none
    puts $f {puts [encoding system]; exit}
    set enc [gets $f]
    close $f
    unset env(LANG)
    unset env(LC_ALL)
    catch {set env(LC_ALL) $oldlc_all}

    switch $tcl_platform(os) {
	HP-UX {set expectedEncoding shiftjis}
	default {set expectedEncoding euc-jp}
    }
    string compare $enc $expectedEncoding
} 0
    
test unixInit-4.1 {TclpSetVariables} {unixOnly} {
    # just make sure they exist

    set a [list $tcl_library $tcl_pkgPath $tcl_platform(os)]
    set a [list $tcl_platform(osVersion) $tcl_platform(machine)]
    set tcl_platform(platform)
} "unix"

test unixInit-5.1 {Tcl_Init} {emptyTest unixOnly} {
    # test initScript
} {}

test unixInit-6.1 {Tcl_SourceRCFile} {emptyTest unixOnly} {
} {}

# cleanup
if {[info exists oldlibrary]} {
    set env(TCL_LIBRARY) $oldlibrary
}
catch {unset env(LANG); set env(LANG) $oldlang}
::tcltest::cleanupTests
return