sl@0: # The file tests the functions in the tclUnixInit.c file.
sl@0: #
sl@0: # This file contains a collection of tests for one or more of the Tcl
sl@0: # built-in commands.  Sourcing this file into Tcl runs the tests and
sl@0: # generates output for errors.  No output means no errors were found.
sl@0: #
sl@0: # Copyright (c) 1997 by Sun Microsystems, Inc.
sl@0: # Copyright (c) 1998-1999 by Scriptics Corporation.
sl@0: #
sl@0: # See the file "license.terms" for information on usage and redistribution
sl@0: # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
sl@0: #
sl@0: # RCS: @(#) $Id: unixInit.test,v 1.30.2.12 2005/04/27 21:07:52 dgp Exp $
sl@0: 
sl@0: package require tcltest 2
sl@0: namespace import -force ::tcltest::*
sl@0: unset -nocomplain path
sl@0: if {[info exists env(TCL_LIBRARY)]} {
sl@0:     set oldlibrary $env(TCL_LIBRARY)
sl@0:     unset env(TCL_LIBRARY)
sl@0: }
sl@0: catch {set oldlang $env(LANG)}
sl@0: set env(LANG) C
sl@0: 
sl@0: test unixInit-1.1 {TclpInitPlatform: ignore SIGPIPE} {unixOnly stdio} {
sl@0:     set x {}
sl@0: 
sl@0:     # Watch out for a race condition here.  If tcltest is too slow to start
sl@0:     # then we'll kill it before it has a chance to set up its signal handler.
sl@0:     
sl@0:     set f [open "|[list [interpreter]]" w+]
sl@0:     puts $f "puts hi"
sl@0:     flush $f
sl@0:     gets $f
sl@0:     exec kill -PIPE [pid $f]
sl@0:     lappend x [catch {close $f}]
sl@0: 
sl@0:     set f [open "|[list [interpreter]]" w+]
sl@0:     puts $f "puts hi"
sl@0:     flush $f
sl@0:     gets $f
sl@0:     exec kill [pid $f]
sl@0:     lappend x [catch {close $f}]
sl@0: 
sl@0:     set x
sl@0: } {0 1}
sl@0: 
sl@0: # This test is really a test of code in tclUnixChan.c, but the
sl@0: # channels are set up as part of initialisation of the interpreter so
sl@0: # the test seems to me to fit here as well as anywhere else.
sl@0: test unixInit-1.2 {initialisation: standard channel type deduction} {unixOnly stdio} {
sl@0:     # pipe1 is a connection to a server that reports what port it
sl@0:     # starts on, and delivers a constant string to the first client to
sl@0:     # connect to that port before exiting.
sl@0:     set pipe1 [open "|[list [interpreter]]" r+]
sl@0:     puts $pipe1 {
sl@0: 	proc accept {channel host port} {
sl@0: 	    puts $channel {puts [fconfigure stdin -peername]; exit}
sl@0: 	    close $channel
sl@0: 	    exit
sl@0: 	}
sl@0: 	puts [fconfigure [socket -server accept 0] -sockname]
sl@0: 	vwait forever \
sl@0: 	    }
sl@0:     # Note the backslash above; this is important to make sure that the
sl@0:     # whole string is read before an [exit] can happen...
sl@0:     flush $pipe1
sl@0:     set port [lindex [gets $pipe1] 2]
sl@0:     set sock [socket localhost $port]
sl@0:     # pipe2 is a connection to a Tcl interpreter that takes its orders
sl@0:     # from the socket we hand it (i.e. the server we create above.)
sl@0:     # These orders will tell it to print out the details about the
sl@0:     # socket it is taking instructions from, hopefully identifying it
sl@0:     # as a socket.  Which is what this test is all about.
sl@0:     set pipe2 [open "|[list [interpreter] <@$sock]" r]
sl@0:     set result [gets $pipe2]
sl@0: 
sl@0:     # Clear any pending data; stops certain kinds of (non-important) errors
sl@0:     fconfigure $pipe1 -blocking 0; gets $pipe1
sl@0:     fconfigure $pipe2 -blocking 0; gets $pipe2
sl@0: 
sl@0:     # Close the pipes and the socket.
sl@0:     close $pipe2
sl@0:     close $pipe1
sl@0:     catch {close $sock}
sl@0: 
sl@0:     # Can't use normal comparison, as hostname varies due to some
sl@0:     # installations having a messed up /etc/hosts file.
sl@0:     if {
sl@0: 	[string equal 127.0.0.1 [lindex $result 0]] &&
sl@0: 	[string equal $port     [lindex $result 2]]
sl@0:     } then {
sl@0: 	subst "OK"
sl@0:     } else {
sl@0: 	subst "Expected: `[list 127.0.0.1 localhost $port]', Got `$result'"
sl@0:     }
sl@0: } {OK}
sl@0: 
sl@0: proc getlibpath [list [list program [interpreter]]] {
sl@0:     set f [open "|[list $program]" w+]
sl@0:     fconfigure $f -buffering none
sl@0:     puts $f {puts $tcl_libPath; exit}
sl@0:     set path [gets $f]
sl@0:     close $f
sl@0:     return $path
sl@0: }
sl@0: 
sl@0: # Some tests require the testgetdefenc command
sl@0: 
sl@0: testConstraint testgetdefenc [llength [info commands testgetdefenc]]
sl@0: 
sl@0: test unixInit-2.0 {TclpInitLibraryPath: setting tclDefaultEncodingDir} \
sl@0: 	{unixOnly testgetdefenc} {
sl@0:     set origDir [testgetdefenc]
sl@0:     testsetdefenc slappy
sl@0:     set path [testgetdefenc]
sl@0:     testsetdefenc $origDir
sl@0:     set path
sl@0: } {slappy}
sl@0: test unixInit-2.1 {TclpInitLibraryPath: value of installLib, developLib} \
sl@0: 	{unixOnly stdio} {
sl@0:     set path [getlibpath]
sl@0: 
sl@0:     set installLib lib/tcl[info tclversion]
sl@0:     set developLib tcl[info patchlevel]/library
sl@0:     set prefix [file dirname [file dirname [interpreter]]]
sl@0: 
sl@0:     set x {}
sl@0:     lappend x [string compare [lindex $path 0] $prefix/$installLib]
sl@0:     lappend x [string compare [lindex $path 4] [file dirname $prefix]/$developLib]
sl@0:     set x
sl@0: } {0 0}
sl@0: test unixInit-2.2 {TclpInitLibraryPath: TCL_LIBRARY} {unixOnly stdio} {
sl@0:     # ((str != NULL) && (str[0] != '\0')) 
sl@0: 
sl@0:     set env(TCL_LIBRARY) sparkly
sl@0:     set path [getlibpath]
sl@0:     unset env(TCL_LIBRARY)
sl@0: 
sl@0:     lindex $path 0
sl@0: } "sparkly"
sl@0: test unixInit-2.3 {TclpInitLibraryPath: TCL_LIBRARY wrong version} \
sl@0: 	{unixOnly stdio} {
sl@0:     # ((pathc > 0) && (strcasecmp(installLib + 4, pathv[pathc - 1]) != 0))
sl@0: 
sl@0:     set env(TCL_LIBRARY) /a/b/tcl1.7
sl@0:     set path [getlibpath]
sl@0:     unset env(TCL_LIBRARY)
sl@0: 
sl@0:     lrange $path 0 1
sl@0: } [list /a/b/tcl1.7 /a/b/tcl[info tclversion]]
sl@0: test unixInit-2.4 {TclpInitLibraryPath: TCL_LIBRARY: INTL} \
sl@0: 	{unixOnly stdio} {
sl@0:     # Child process translates env variable from native encoding.
sl@0: 
sl@0:     set env(TCL_LIBRARY) "\xa7"
sl@0:     set x [lindex [getlibpath] 0]
sl@0:     unset env(TCL_LIBRARY)
sl@0:     unset env(LANG)
sl@0: 
sl@0:     set x
sl@0: } "\xa7"
sl@0: test unixInit-2.5 {TclpInitLibraryPath: compiled-in library path} \
sl@0: 	{emptyTest unixOnly} {
sl@0:     # cannot test
sl@0: } {}
sl@0: test unixInit-2.6 {TclpInitLibraryPath: executable relative} \
sl@0: 	{unixOnly stdio} {
sl@0:     makeDirectory tmp
sl@0:     makeDirectory [file join tmp sparkly]
sl@0:     makeDirectory [file join tmp sparkly bin]
sl@0:     file copy [interpreter] [file join [temporaryDirectory] tmp sparkly \
sl@0: 	    bin tcltest]
sl@0:     makeDirectory [file join tmp sparkly lib]
sl@0:     makeDirectory [file join tmp sparkly lib tcl[info tclversion]]
sl@0:     makeFile {} [file join tmp sparkly lib tcl[info tclversion] init.tcl]
sl@0: 
sl@0:     set x [lrange [getlibpath [file join [temporaryDirectory] tmp sparkly \
sl@0: 	    bin tcltest]] 0 1]
sl@0:     removeFile [file join tmp sparkly lib tcl[info tclversion] init.tcl]
sl@0:     removeDirectory [file join tmp sparkly lib tcl[info tclversion]]
sl@0:     removeDirectory [file join tmp sparkly lib]
sl@0:     removeDirectory [file join tmp sparkly bin]
sl@0:     removeDirectory [file join tmp sparkly]
sl@0:     removeDirectory tmp
sl@0:     set x
sl@0: } [list [temporaryDirectory]/tmp/sparkly/lib/tcl[info tclversion] [temporaryDirectory]/tmp/lib/tcl[info tclversion]]
sl@0: test unixInit-2.7 {TclpInitLibraryPath: compiled-in library path} \
sl@0: 	{emptyTest unixOnly} {
sl@0:     # would need test command to get defaultLibDir and compare it to
sl@0:     # [lindex $auto_path end]
sl@0: } {}
sl@0: #
sl@0: # The following two tests write to the directory /tmp/sparkly instead
sl@0: # of to [temporaryDirectory].  This is because the failures tested by
sl@0: # these tests need paths near the "root" of the file system to present
sl@0: # themselves.
sl@0: #
sl@0: testConstraint noSparkly [expr {![file exists [file join /tmp sparkly]]}]
sl@0: testConstraint noTmpInstall [expr {![file exists \
sl@0: 				[file join /tmp lib tcl[info tclversion]]]}]
sl@0: test unixInit-2.8 {TclpInitLibraryPath: all absolute pathtype} {unix noSparkly noTmpInstall} {
sl@0:     # Checking for Bug 219416
sl@0:     # When a program that embeds the Tcl library, like tcltest, is
sl@0:     # installed near the "root" of the file system, there was a problem
sl@0:     # constructing directories relative to the executable.  When a 
sl@0:     # relative ".." went past the root, relative path names were created
sl@0:     # rather than absolute pathnames.  In some cases, accessing past the
sl@0:     # root caused memory access violations too.
sl@0:     #
sl@0:     # The bug is now fixed, but here we check for it by making sure that
sl@0:     # the directories constructed relative to the executable are all
sl@0:     # absolute pathnames, even when the executable is installed near
sl@0:     # the root of the filesystem.
sl@0:     #
sl@0:     # The only directory near the root we are likely to have write access
sl@0:     # to is /tmp.
sl@0:     file delete -force /tmp/sparkly
sl@0:     file delete -force /tmp/lib/tcl[info tclversion]
sl@0:     file mkdir /tmp/sparkly
sl@0:     file copy [interpreter] /tmp/sparkly/tcltest
sl@0: 
sl@0:     # Keep any existing /tmp/lib directory
sl@0:     set deletelib 1
sl@0:     if {[file exists /tmp/lib]} {
sl@0: 	if {[file isdirectory /tmp/lib]} {
sl@0: 	    set deletelib 0
sl@0: 	} else {
sl@0: 	    file delete -force /tmp/lib
sl@0: 	}
sl@0:     }
sl@0: 
sl@0:     # For a successful Tcl_Init, we need a [source]-able init.tcl in
sl@0:     # ../lib/tcl$version relative to the executable.
sl@0:     file mkdir /tmp/lib/tcl[info tclversion]
sl@0:     close [open /tmp/lib/tcl[info tclversion]/init.tcl w]
sl@0: 
sl@0:     # Check that all directories in the library path are absolute pathnames
sl@0:     set allAbsolute 1
sl@0:     foreach dir [getlibpath /tmp/sparkly/tcltest] {
sl@0: 	set allAbsolute [expr {$allAbsolute \
sl@0: 		&& [string equal absolute [file pathtype $dir]]}]
sl@0:     }
sl@0: 
sl@0:     # Clean up temporary installation
sl@0:     file delete -force /tmp/sparkly
sl@0:     file delete -force /tmp/lib/tcl[info tclversion]
sl@0:     if {$deletelib} {file delete -force /tmp/lib}
sl@0:     set allAbsolute
sl@0: } 1
sl@0: testConstraint noTmpBuild [expr {![file exists [file join /tmp library]]}]
sl@0: test unixInit-2.9 {TclpInitLibraryPath: paths relative to executable} {unix noSparkly noTmpBuild} {
sl@0:     # Checking for Bug 438014
sl@0:     file delete -force /tmp/sparkly
sl@0:     file delete -force /tmp/library
sl@0:     file mkdir /tmp/sparkly
sl@0:     file copy [interpreter] /tmp/sparkly/tcltest
sl@0: 
sl@0:     file mkdir /tmp/library/
sl@0:     close [open /tmp/library/init.tcl w]
sl@0: 
sl@0:     set x [lrange [getlibpath /tmp/sparkly/tcltest] 0 4]
sl@0: 
sl@0:     file delete -force /tmp/sparkly
sl@0:     file delete -force /tmp/library
sl@0:     set x
sl@0: } [list /tmp/lib/tcl[info tclversion] /lib/tcl[info tclversion] \
sl@0:         /tmp/library /library /tcl[info patchlevel]/library]
sl@0: 
sl@0: test unixInit-2.10 {TclpInitLibraryPath: executable relative} -constraints {
sl@0: 	unixOnly stdio
sl@0: } -setup {
sl@0:     set tmpDir [makeDirectory tmp]
sl@0:     set sparklyDir [makeDirectory sparkly $tmpDir]
sl@0:     set execPath [file join [makeDirectory bin $sparklyDir] tcltest]
sl@0:     file copy [interpreter] $execPath
sl@0:     set libDir [makeDirectory lib $sparklyDir]
sl@0:     set scriptDir [makeDirectory tcl[info tclversion] $libDir]
sl@0:     makeFile {} init.tcl $scriptDir
sl@0:     set saveDir [pwd]
sl@0:     cd $libDir
sl@0: } -body {
sl@0:     # Checking for Bug 832657
sl@0:     set x [lrange [getlibpath [file join .. bin tcltest]] 2 3]
sl@0:     foreach p $x {
sl@0:       lappend y [file normalize $p]
sl@0:     }
sl@0:     set y
sl@0: } -cleanup {
sl@0:     cd $saveDir
sl@0:     unset saveDir
sl@0:     removeFile init.tcl $scriptDir
sl@0:     unset scriptDir
sl@0:     removeDirectory tcl[info tclversion] $libDir
sl@0:     unset libDir
sl@0:     file delete $execPath
sl@0:     unset execPath
sl@0:     removeDirectory bin $sparklyDir
sl@0:     removeDirectory lib $sparklyDir
sl@0:     unset sparklyDir
sl@0:     removeDirectory sparkly $tmpDir
sl@0:     unset tmpDir
sl@0:     removeDirectory tmp
sl@0:     unset x p y
sl@0: } -result [list [file join [temporaryDirectory] tmp sparkly library] \
sl@0: 	[file join [temporaryDirectory] tmp library] ]
sl@0: 
sl@0: test unixInit-3.1 {TclpSetInitialEncodings} -constraints {
sl@0: 	unixOnly stdio
sl@0: } -body {
sl@0:     set env(LANG) C
sl@0: 
sl@0:     set f [open "|[list [interpreter]]" w+]
sl@0:     fconfigure $f -buffering none
sl@0:     puts $f {puts [encoding system]; exit}
sl@0:     set enc [gets $f]
sl@0:     close $f
sl@0:     unset env(LANG)
sl@0: 
sl@0:     set enc
sl@0: } -match regexp -result [expr {
sl@0: 	($tcl_platform(os) eq "Darwin") ? "^utf-8$" : "^iso8859-15?$"}]
sl@0: 
sl@0: test unixInit-3.2 {TclpSetInitialEncodings} {unixOnly stdio} {
sl@0:     set env(LANG) japanese
sl@0:     catch {set oldlc_all $env(LC_ALL)}
sl@0:     set env(LC_ALL) japanese
sl@0: 
sl@0:     set f [open "|[list [interpreter]]" w+]
sl@0:     fconfigure $f -buffering none
sl@0:     puts $f {puts [encoding system]; exit}
sl@0:     set enc [gets $f]
sl@0:     close $f
sl@0:     unset env(LANG)
sl@0:     unset env(LC_ALL)
sl@0:     catch {set env(LC_ALL) $oldlc_all}
sl@0: 
sl@0:     set validEncodings [list euc-jp]
sl@0:     if {[string match HP-UX $tcl_platform(os)]} {
sl@0: 	# Some older HP-UX systems need us to accept this as valid
sl@0: 	# Bug 453883 reports that newer HP-UX systems report euc-jp
sl@0: 	# like everybody else.
sl@0: 	lappend validEncodings shiftjis
sl@0:     }
sl@0:     expr {[lsearch -exact $validEncodings $enc] < 0}
sl@0: } 0
sl@0: 
sl@0: test unixInit-4.1 {TclpSetVariables} {unixOnly} {
sl@0:     # just make sure they exist
sl@0: 
sl@0:     set a [list $tcl_library $tcl_pkgPath $tcl_platform(os)]
sl@0:     set a [list $tcl_platform(osVersion) $tcl_platform(machine)]
sl@0:     set tcl_platform(platform)
sl@0: } "unix"
sl@0: 
sl@0: test unixInit-5.1 {Tcl_Init} {emptyTest unixOnly} {
sl@0:     # test initScript
sl@0: } {}
sl@0: 
sl@0: test unixInit-6.1 {Tcl_SourceRCFile} {emptyTest unixOnly} {
sl@0: } {}
sl@0: 
sl@0: test unixInit-7.1 {closed standard channel: Bug 772288} -constraints {
sl@0: 	unixOnly stdio
sl@0: } -body {
sl@0:     set tclsh [interpreter]
sl@0:     set crash [makeFile {puts [open /dev/null]} crash.tcl]
sl@0:     set crashtest [makeFile "
sl@0: 	close stdin
sl@0: 	[list exec $tclsh $crash]
sl@0:     " crashtest.tcl]
sl@0:     exec $tclsh $crashtest
sl@0: } -cleanup {
sl@0:     removeFile crash.tcl
sl@0:     removeFile crashtest.tcl
sl@0: } -returnCodes 0
sl@0: 
sl@0: # cleanup
sl@0: if {[info exists oldlibrary]} {
sl@0:     set env(TCL_LIBRARY) $oldlibrary
sl@0: }
sl@0: catch {unset env(LANG)}
sl@0: catch {set env(LANG) $oldlang}
sl@0: unset -nocomplain path
sl@0: ::tcltest::cleanupTests
sl@0: return