# Copyright © 1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
unset -nocomplain path
catch {set oldlang $env(LANG)}
set env(LANG) C
test unixInit-1.1 {TclpInitPlatform: ignore SIGPIPE} {unix stdio} {
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 [interpreter]]" w+]
puts $f "puts hi"
flush $f
gets $f
exec kill -PIPE [pid $f]
lappend x [catch {close $f}]
set f [open "|[list [interpreter]]" 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: standard channel type deduction} {unix stdio} {
# pipe1 is a connection to a server that reports what port it starts on,
# and delivers a constant string to the first client to connect to that
# port before exiting.
set pipe1 [open "|[list [interpreter]]" r+]
puts $pipe1 {
proc accept {channel host port} {
puts $channel {puts [chan configure stdin -peername]; exit}
close $channel
exit
}
puts [chan configure [socket -server accept -myaddr 127.0.0.1 0] -sockname]
vwait forever \
}
# Note the backslash above; this is important to make sure that the whole
# string is read before an [exit] can happen...
flush $pipe1
set port [lindex [gets $pipe1] 2]
set sock [socket localhost $port]
# pipe2 is a connection to a Tcl interpreter that takes its orders from
# the socket we hand it (i.e. the server we create above.) These orders
# will tell it to print out the details about the socket it is taking
# instructions from, hopefully identifying it as a socket. Which is what
# this test is all about.
set pipe2 [open "|[list [interpreter] <@$sock]" r]
set result [gets $pipe2]
# Clear any pending data; stops certain kinds of (non-important) errors
chan configure $pipe1 -blocking 0; gets $pipe1
chan configure $pipe2 -blocking 0; gets $pipe2
# Close the pipes and the socket.
close $pipe2
close $pipe1
catch {close $sock}
# Can't use normal comparison, as hostname varies due to some
# installations having a messed up /etc/hosts file.
if {
"127.0.0.1" eq [lindex $result 0] && $port == [lindex $result 2]
} then {
subst "OK"
} else {
subst "Expected: `[list 127.0.0.1 localhost $port]', Got `$result'"
}
} {OK}
test unixInit-3.1 {TclpSetInitialEncodings} -constraints {
unix stdio
} -body {
set env(LANG) C
set f [open "|[list [interpreter]]" w+]
chan configure $f -buffering none
puts $f {puts [encoding system]; exit}
set enc [gets $f]
close $f
set enc
} -cleanup {
unset -nocomplain env(LANG)
} -match regexp -result {^(iso8859-15?|utf-8)$}
test unixInit-3.2 {TclpSetInitialEncodings} -setup {
catch {set oldlc_all $env(LC_ALL)}
catch {set oldtcl_library $env(TCL_LIBRARY)}
unset -nocomplain env(TCL_LIBRARY)
} -constraints {unix stdio knownBug} -body {
set env(LANG) japanese
set env(LC_ALL) japanese
set f [open "|[list [interpreter]]" w+]
chan configure $f -buffering none
puts $f {puts [encoding system]; exit}
set enc [gets $f]
close $f
set validEncodings [list euc-jp]
if {[string match HP-UX $tcl_platform(os)]} {
# Some older HP-UX systems need us to accept this as valid Bug 453883
# reports that newer HP-UX systems report euc-jp like everybody else.
lappend validEncodings shiftjis
}
expr {$enc ni $validEncodings}
} -cleanup {
unset -nocomplain env(LANG) env(LC_ALL)
catch {set env(LC_ALL) $oldlc_all}
catch {set env(TCL_LIBRARY) $oldtcl_library}
} -result 0
test unixInit-4.1 {TclpSetVariables} {unix} {
# 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 unix} {
# test initScript
} {}
test unixInit-6.1 {Tcl_SourceRCFile} {emptyTest unix} {
} {}
test unixInit-7.1 {closed standard channel: Bug 772288} -constraints {
unix stdio
} -body {
set tclsh [interpreter]
set crash [makeFile {puts [open /dev/null]} crash.tcl]
set crashtest [makeFile "
close stdin
[list exec $tclsh $crash]
" crashtest.tcl]
exec $tclsh $crashtest
} -cleanup {
removeFile crash.tcl
removeFile crashtest.tcl
} -returnCodes 0
# cleanup
unset -nocomplain env(LANG)
catch {set env(LANG) $oldlang}
unset -nocomplain path
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# fill-column: 78
# End: