# 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.30.2.12 2005/04/27 21:07:52 dgp 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