# 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.1.1.1 2007/07/10 15:04:24 duncan Exp $ package require tcltest 2 namespace import -force ::tcltest::* unset -nocomplain path if {[info exists env(TCL_LIBRARY)]} { set oldlibrary $env(TCL_LIBRARY) unset env(TCL_LIBRARY) } catch {set oldlang $env(LANG)} set env(LANG) C test unixInit-1.1 {TclpInitPlatform: ignore SIGPIPE} {unixOnly 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} {unixOnly 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 [fconfigure stdin -peername]; exit} close $channel exit } puts [fconfigure [socket -server accept 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 fconfigure $pipe1 -blocking 0; gets $pipe1 fconfigure $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 { [string equal 127.0.0.1 [lindex $result 0]] && [string equal $port [lindex $result 2]] } then { subst "OK" } else { subst "Expected: `[list 127.0.0.1 localhost $port]', Got `$result'" } } {OK} proc getlibpath [list [list program [interpreter]]] { set f [open "|[list $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 testConstraint testgetdefenc [llength [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 stdio} { set path [getlibpath] set installLib lib/tcl[info tclversion] set developLib tcl[info patchlevel]/library set prefix [file dirname [file dirname [interpreter]]] 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 stdio} { # ((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 stdio} { # ((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 stdio} { # 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 stdio} { makeDirectory tmp makeDirectory [file join tmp sparkly] makeDirectory [file join tmp sparkly bin] file copy [interpreter] [file join [temporaryDirectory] tmp sparkly \ bin tcltest] makeDirectory [file join tmp sparkly lib] makeDirectory [file join tmp sparkly lib tcl[info tclversion]] makeFile {} [file join tmp sparkly lib tcl[info tclversion] init.tcl] set x [lrange [getlibpath [file join [temporaryDirectory] tmp sparkly \ bin tcltest]] 0 1] removeFile [file join tmp sparkly lib tcl[info tclversion] init.tcl] removeDirectory [file join tmp sparkly lib tcl[info tclversion]] removeDirectory [file join tmp sparkly lib] removeDirectory [file join tmp sparkly bin] removeDirectory [file join tmp sparkly] removeDirectory tmp set x } [list [temporaryDirectory]/tmp/sparkly/lib/tcl[info tclversion] [temporaryDirectory]/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] } {} # # The following two tests write to the directory /tmp/sparkly instead # of to [temporaryDirectory]. This is because the failures tested by # these tests need paths near the "root" of the file system to present # themselves. # testConstraint noSparkly [expr {![file exists [file join /tmp sparkly]]}] testConstraint noTmpInstall [expr {![file exists \ [file join /tmp lib tcl[info tclversion]]]}] test unixInit-2.8 {TclpInitLibraryPath: all absolute pathtype} {unix noSparkly noTmpInstall} { # Checking for Bug 219416 # When a program that embeds the Tcl library, like tcltest, is # installed near the "root" of the file system, there was a problem # constructing directories relative to the executable. When a # relative ".." went past the root, relative path names were created # rather than absolute pathnames. In some cases, accessing past the # root caused memory access violations too. # # The bug is now fixed, but here we check for it by making sure that # the directories constructed relative to the executable are all # absolute pathnames, even when the executable is installed near # the root of the filesystem. # # The only directory near the root we are likely to have write access # to is /tmp. file delete -force /tmp/sparkly file delete -force /tmp/lib/tcl[info tclversion] file mkdir /tmp/sparkly file copy [interpreter] /tmp/sparkly/tcltest # Keep any existing /tmp/lib directory set deletelib 1 if {[file exists /tmp/lib]} { if {[file isdirectory /tmp/lib]} { set deletelib 0 } else { file delete -force /tmp/lib } } # For a successful Tcl_Init, we need a [source]-able init.tcl in # ../lib/tcl$version relative to the executable. file mkdir /tmp/lib/tcl[info tclversion] close [open /tmp/lib/tcl[info tclversion]/init.tcl w] # Check that all directories in the library path are absolute pathnames set allAbsolute 1 foreach dir [getlibpath /tmp/sparkly/tcltest] { set allAbsolute [expr {$allAbsolute \ && [string equal absolute [file pathtype $dir]]}] } # Clean up temporary installation file delete -force /tmp/sparkly file delete -force /tmp/lib/tcl[info tclversion] if {$deletelib} {file delete -force /tmp/lib} set allAbsolute } 1 testConstraint noTmpBuild [expr {![file exists [file join /tmp library]]}] test unixInit-2.9 {TclpInitLibraryPath: paths relative to executable} {unix noSparkly noTmpBuild} { # Checking for Bug 438014 file delete -force /tmp/sparkly file delete -force /tmp/library file mkdir /tmp/sparkly file copy [interpreter] /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-2.10 {TclpInitLibraryPath: executable relative} -constraints { unixOnly stdio } -setup { set tmpDir [makeDirectory tmp] set sparklyDir [makeDirectory sparkly $tmpDir] set execPath [file join [makeDirectory bin $sparklyDir] tcltest] file copy [interpreter] $execPath set libDir [makeDirectory lib $sparklyDir] set scriptDir [makeDirectory tcl[info tclversion] $libDir] makeFile {} init.tcl $scriptDir set saveDir [pwd] cd $libDir } -body { # Checking for Bug 832657 set x [lrange [getlibpath [file join .. bin tcltest]] 2 3] foreach p $x { lappend y [file normalize $p] } set y } -cleanup { cd $saveDir unset saveDir removeFile init.tcl $scriptDir unset scriptDir removeDirectory tcl[info tclversion] $libDir unset libDir file delete $execPath unset execPath removeDirectory bin $sparklyDir removeDirectory lib $sparklyDir unset sparklyDir removeDirectory sparkly $tmpDir unset tmpDir removeDirectory tmp unset x p y } -result [list [file join [temporaryDirectory] tmp sparkly library] \ [file join [temporaryDirectory] tmp library] ] test unixInit-3.1 {TclpSetInitialEncodings} -constraints { unixOnly stdio } -body { set env(LANG) C set f [open "|[list [interpreter]]" w+] fconfigure $f -buffering none puts $f {puts [encoding system]; exit} set enc [gets $f] close $f unset env(LANG) set enc } -match regexp -result [expr { ($tcl_platform(os) eq "Darwin") ? "^utf-8$" : "^iso8859-15?$"}] test unixInit-3.2 {TclpSetInitialEncodings} {unixOnly stdio} { set env(LANG) japanese catch {set oldlc_all $env(LC_ALL)} set env(LC_ALL) japanese set f [open "|[list [interpreter]]" 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} 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 {[lsearch -exact $validEncodings $enc] < 0} } 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} { } {} test unixInit-7.1 {closed standard channel: Bug 772288} -constraints { unixOnly 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 if {[info exists oldlibrary]} { set env(TCL_LIBRARY) $oldlibrary } catch {unset env(LANG)} catch {set env(LANG) $oldlang} unset -nocomplain path ::tcltest::cleanupTests return