path: root/tests/unixInit.test

# 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