# Commands covered:  none (tests environment variable implementation)

#

# 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) 1991-1993 The Regents of the University of California.

# Copyright (c) 1994 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: env.test,v 1.17.2.5 2007/01/19 01:05:50 das Exp $

package require tcltest 2

namespace import -force ::tcltest::*

#

# These tests will run on any platform (and indeed crashed

# on the Mac).  So put them before you test for the existance

# of exec.

#

test env-1.1 {propagation of env values to child interpreters} {

    catch {interp delete child}

    catch {unset env(test)}

    interp create child

    set env(test) garbage

    set return [child eval {set env(test)}]

    interp delete child

    unset env(test)

    set return

} {garbage}

#

# This one crashed on Solaris under Tcl8.0, so we only

# want to make sure it runs.

#

test env-1.2 {lappend to env value} {

    catch {unset env(test)}

    set env(test) aaaaaaaaaaaaaaaa

    append env(test) bbbbbbbbbbbbbb

    unset env(test)

} {}

test env-1.3 {reflection of env by "array names"} {

    catch {interp delete child}

    catch {unset env(test)}

    interp create child

    child eval {set env(test) garbage}

    set names [array names env]

    interp delete child

    set ix [lsearch $names test]

    catch {unset env(test)}

    expr {$ix >= 0}

} {1}

# Some tests require the "exec" command.

# Skip them if exec is not defined.

testConstraint exec [llength [info commands exec]]

set printenvScript [makeFile {

    proc lrem {listname name} {

	upvar $listname list

	set i [lsearch $list $name]

	if {$i >= 0} {

	    set list [lreplace $list $i $i]

	}

	return $list

    }

    set names [lsort [array names env]]

    if {$tcl_platform(platform) == "windows"} {

	lrem names HOME

        lrem names COMSPEC

	lrem names ComSpec

	lrem names ""

    }	

    foreach name {

	TCL_LIBRARY PATH LD_LIBRARY_PATH LIBPATH PURE_PROG_NAME DISPLAY

	SHLIB_PATH SYSTEMDRIVE SYSTEMROOT DYLD_LIBRARY_PATH DYLD_FRAMEWORK_PATH

	DYLD_NEW_LOCAL_SHARED_REGIONS DYLD_NO_FIX_PREBINDING

	__CF_USER_TEXT_ENCODING SECURITYSESSIONID

    } {

	lrem names $name

    }

    foreach p $names {

	puts "$p=$env($p)"

    }

    exit

} printenv]

# [exec] is required here to see the actual environment received

# by child processes.

proc getenv {} {

    global printenvScript tcltest

    catch {exec [interpreter] $printenvScript} out

    if {$out == "child process exited abnormally"} {

	set out {}

    }

    return $out

}

# Save the current environment variables at the start of the test.

foreach name [array names env] {

    set env2([string toupper $name]) $env($name)

    unset env($name)

}

# Added the following lines so that child tcltest can actually find its

# library if the initial tcltest is run from a non-standard place.

# ('saved' env vars)

foreach name {

	TCL_LIBRARY PATH LD_LIBRARY_PATH LIBPATH DISPLAY SHLIB_PATH

	SYSTEMDRIVE SYSTEMROOT DYLD_LIBRARY_PATH DYLD_FRAMEWORK_PATH

	DYLD_NEW_LOCAL_SHARED_REGIONS DYLD_NO_FIX_PREBINDING

	SECURITYSESSIONID} {

    if {[info exists env2($name)]} {

	set env($name) $env2($name);

    }

}

test env-2.1 {adding environment variables} {exec} {

    getenv

} {}

set env(NAME1) "test string"

test env-2.2 {adding environment variables} {exec} {

    getenv

} {NAME1=test string}

set env(NAME2) "more"

test env-2.3 {adding environment variables} {exec} {

    getenv

} {NAME1=test string

NAME2=more}

set env(XYZZY) "garbage"

test env-2.4 {adding environment variables} {exec} {

    getenv

} {NAME1=test string

NAME2=more

XYZZY=garbage}

set env(NAME2) "new value"

test env-3.1 {changing environment variables} {exec} {

    set result [getenv]

    unset env(NAME2)

    set result

} {NAME1=test string

NAME2=new value

XYZZY=garbage}

test env-4.1 {unsetting environment variables} {exec} {

    set result [getenv]

    unset env(NAME1)

    set result

} {NAME1=test string

XYZZY=garbage}

test env-4.2 {unsetting environment variables} {exec} {

    set result [getenv]

    unset env(XYZZY)

    set result

} {XYZZY=garbage}

test env-4.3 {setting international environment variables} {exec} {

    set env(\ua7) \ub6

    getenv

} "\ua7=\ub6"

test env-4.4 {changing international environment variables} {exec} {

    set env(\ua7) \ua7

    getenv

} "\ua7=\ua7"

test env-4.5 {unsetting international environment variables} {exec} {

    set env(\ub6) \ua7

    unset env(\ua7)

    set result [getenv]

    unset env(\ub6)

    set result

} "\ub6=\ua7"

test env-5.0 {corner cases - set a value, it should exist} {} {

    set env(temp) a

    set result [set env(temp)]

    unset env(temp)

    set result

} {a}

test env-5.1 {corner cases - remove one elem at a time} {} {

    # When no environment variables exist, the env var will

    # contain no entries.  The "array names" call synchs up

    # the C-level environ array with the Tcl level env array.

    # Make sure an empty Tcl array is created.

    set x [array get env]

    foreach e [array names env] {

	unset env($e)

    }

    set result [catch {array names env}]

    array set env $x

    set result

} {0}

test env-5.2 {corner cases - unset the env array} {} {

    # Unsetting a variable in an interp detaches the C-level

    # traces from the Tcl "env" variable.

    interp create i 

    i eval { unset env }

    i eval { set env(THIS_SHOULDNT_EXIST) a}

    set result [info exists env(THIS_SHOULDNT_EXIST)]

    interp delete i

    set result

} {0}

test env-5.3 {corner cases - unset the env in master should unset child} {} {

    # Variables deleted in a master interp should be deleted in

    # child interp too.

    interp create i 

    i eval { set env(THIS_SHOULD_EXIST) a}

    set result [set env(THIS_SHOULD_EXIST)]

    unset env(THIS_SHOULD_EXIST)

    lappend result [i eval {catch {set env(THIS_SHOULD_EXIST)}}]

    interp delete i

    set result

} {a 1}

test env-5.4 {corner cases - unset the env array} {} {

    # The info exists command should be in synch with the env array.

    # Know Bug: 1737

    interp create i 

    i eval { set env(THIS_SHOULD_EXIST) a}

    set     result [info exists env(THIS_SHOULD_EXIST)]

    lappend result [set env(THIS_SHOULD_EXIST)]

    lappend result [info exists env(THIS_SHOULD_EXIST)]

    interp delete i

    set result

} {1 a 1}

test env-5.5 {corner cases - cannot have null entries on Windows} {pcOnly} {

    set env() a

    catch {set env()}

} {1}

test env-6.1 {corner cases - add lots of env variables} {} {

    set size [array size env]

    for {set i 0} {$i < 100} {incr i} {

	set env(BOGUS$i) $i

    }

    expr {[array size env] - $size}

} 100

# Restore the environment variables at the end of the test.

foreach name [array names env] {

    unset env($name)

}

foreach name [array names env2] {

    set env($name) $env2($name)

}

# cleanup

removeFile $printenvScript

::tcltest::cleanupTests

return