sl@0: # Commands covered:  none (tests environment variable implementation)
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) 1991-1993 The Regents of the University of California.
sl@0: # Copyright (c) 1994 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: env.test,v 1.17.2.5 2007/01/19 01:05:50 das Exp $
sl@0: 
sl@0: package require tcltest 2
sl@0: namespace import -force ::tcltest::*
sl@0: 
sl@0: #
sl@0: # These tests will run on any platform (and indeed crashed
sl@0: # on the Mac).  So put them before you test for the existance
sl@0: # of exec.
sl@0: #
sl@0: test env-1.1 {propagation of env values to child interpreters} {
sl@0:     catch {interp delete child}
sl@0:     catch {unset env(test)}
sl@0:     interp create child
sl@0:     set env(test) garbage
sl@0:     set return [child eval {set env(test)}]
sl@0:     interp delete child
sl@0:     unset env(test)
sl@0:     set return
sl@0: } {garbage}
sl@0: #
sl@0: # This one crashed on Solaris under Tcl8.0, so we only
sl@0: # want to make sure it runs.
sl@0: #
sl@0: test env-1.2 {lappend to env value} {
sl@0:     catch {unset env(test)}
sl@0:     set env(test) aaaaaaaaaaaaaaaa
sl@0:     append env(test) bbbbbbbbbbbbbb
sl@0:     unset env(test)
sl@0: } {}
sl@0: test env-1.3 {reflection of env by "array names"} {
sl@0:     catch {interp delete child}
sl@0:     catch {unset env(test)}
sl@0:     interp create child
sl@0:     child eval {set env(test) garbage}
sl@0:     set names [array names env]
sl@0:     interp delete child
sl@0:     set ix [lsearch $names test]
sl@0:     catch {unset env(test)}
sl@0:     expr {$ix >= 0}
sl@0: } {1}
sl@0: 
sl@0: 
sl@0: # Some tests require the "exec" command.
sl@0: # Skip them if exec is not defined.
sl@0: testConstraint exec [llength [info commands exec]]
sl@0: 
sl@0: set printenvScript [makeFile {
sl@0:     proc lrem {listname name} {
sl@0: 	upvar $listname list
sl@0: 	set i [lsearch $list $name]
sl@0: 	if {$i >= 0} {
sl@0: 	    set list [lreplace $list $i $i]
sl@0: 	}
sl@0: 	return $list
sl@0:     }
sl@0: 	
sl@0:     set names [lsort [array names env]]
sl@0:     if {$tcl_platform(platform) == "windows"} {
sl@0: 	lrem names HOME
sl@0:         lrem names COMSPEC
sl@0: 	lrem names ComSpec
sl@0: 	lrem names ""
sl@0:     }	
sl@0:     foreach name {
sl@0: 	TCL_LIBRARY PATH LD_LIBRARY_PATH LIBPATH PURE_PROG_NAME DISPLAY
sl@0: 	SHLIB_PATH SYSTEMDRIVE SYSTEMROOT DYLD_LIBRARY_PATH DYLD_FRAMEWORK_PATH
sl@0: 	DYLD_NEW_LOCAL_SHARED_REGIONS DYLD_NO_FIX_PREBINDING
sl@0: 	__CF_USER_TEXT_ENCODING SECURITYSESSIONID
sl@0:     } {
sl@0: 	lrem names $name
sl@0:     }
sl@0:     foreach p $names {
sl@0: 	puts "$p=$env($p)"
sl@0:     }
sl@0:     exit
sl@0: } printenv]
sl@0: 	
sl@0: # [exec] is required here to see the actual environment received
sl@0: # by child processes.
sl@0: proc getenv {} {
sl@0:     global printenvScript tcltest
sl@0:     catch {exec [interpreter] $printenvScript} out
sl@0:     if {$out == "child process exited abnormally"} {
sl@0: 	set out {}
sl@0:     }
sl@0:     return $out
sl@0: }
sl@0: 
sl@0: # Save the current environment variables at the start of the test.
sl@0: 
sl@0: foreach name [array names env] {
sl@0:     set env2([string toupper $name]) $env($name)
sl@0:     unset env($name)
sl@0: }
sl@0: 
sl@0: # Added the following lines so that child tcltest can actually find its
sl@0: # library if the initial tcltest is run from a non-standard place.
sl@0: # ('saved' env vars)
sl@0: foreach name {
sl@0: 	TCL_LIBRARY PATH LD_LIBRARY_PATH LIBPATH DISPLAY SHLIB_PATH
sl@0: 	SYSTEMDRIVE SYSTEMROOT DYLD_LIBRARY_PATH DYLD_FRAMEWORK_PATH
sl@0: 	DYLD_NEW_LOCAL_SHARED_REGIONS DYLD_NO_FIX_PREBINDING
sl@0: 	SECURITYSESSIONID} {
sl@0:     if {[info exists env2($name)]} {
sl@0: 	set env($name) $env2($name);
sl@0:     }
sl@0: }
sl@0: 
sl@0: test env-2.1 {adding environment variables} {exec} {
sl@0:     getenv
sl@0: } {}
sl@0: 
sl@0: set env(NAME1) "test string"
sl@0: test env-2.2 {adding environment variables} {exec} {
sl@0:     getenv
sl@0: } {NAME1=test string}
sl@0: 
sl@0: set env(NAME2) "more"
sl@0: test env-2.3 {adding environment variables} {exec} {
sl@0:     getenv
sl@0: } {NAME1=test string
sl@0: NAME2=more}
sl@0: 
sl@0: set env(XYZZY) "garbage"
sl@0: test env-2.4 {adding environment variables} {exec} {
sl@0:     getenv
sl@0: } {NAME1=test string
sl@0: NAME2=more
sl@0: XYZZY=garbage}
sl@0: 
sl@0: set env(NAME2) "new value"
sl@0: test env-3.1 {changing environment variables} {exec} {
sl@0:     set result [getenv]
sl@0:     unset env(NAME2)
sl@0:     set result
sl@0: } {NAME1=test string
sl@0: NAME2=new value
sl@0: XYZZY=garbage}
sl@0: 
sl@0: test env-4.1 {unsetting environment variables} {exec} {
sl@0:     set result [getenv]
sl@0:     unset env(NAME1)
sl@0:     set result
sl@0: } {NAME1=test string
sl@0: XYZZY=garbage}
sl@0: 
sl@0: test env-4.2 {unsetting environment variables} {exec} {
sl@0:     set result [getenv]
sl@0:     unset env(XYZZY)
sl@0:     set result
sl@0: } {XYZZY=garbage}
sl@0: 
sl@0: test env-4.3 {setting international environment variables} {exec} {
sl@0:     set env(\ua7) \ub6
sl@0:     getenv
sl@0: } "\ua7=\ub6"
sl@0: test env-4.4 {changing international environment variables} {exec} {
sl@0:     set env(\ua7) \ua7
sl@0:     getenv
sl@0: } "\ua7=\ua7"
sl@0: test env-4.5 {unsetting international environment variables} {exec} {
sl@0:     set env(\ub6) \ua7
sl@0:     unset env(\ua7)
sl@0:     set result [getenv]
sl@0:     unset env(\ub6)
sl@0:     set result
sl@0: } "\ub6=\ua7"
sl@0: 
sl@0: test env-5.0 {corner cases - set a value, it should exist} {} {
sl@0:     set env(temp) a
sl@0:     set result [set env(temp)]
sl@0:     unset env(temp)
sl@0:     set result
sl@0: } {a}
sl@0: test env-5.1 {corner cases - remove one elem at a time} {} {
sl@0:     # When no environment variables exist, the env var will
sl@0:     # contain no entries.  The "array names" call synchs up
sl@0:     # the C-level environ array with the Tcl level env array.
sl@0:     # Make sure an empty Tcl array is created.
sl@0: 
sl@0:     set x [array get env]
sl@0:     foreach e [array names env] {
sl@0: 	unset env($e)
sl@0:     }
sl@0:     set result [catch {array names env}]
sl@0:     array set env $x
sl@0:     set result
sl@0: } {0}
sl@0: test env-5.2 {corner cases - unset the env array} {} {
sl@0:     # Unsetting a variable in an interp detaches the C-level
sl@0:     # traces from the Tcl "env" variable.
sl@0: 
sl@0:     interp create i 
sl@0:     i eval { unset env }
sl@0:     i eval { set env(THIS_SHOULDNT_EXIST) a}
sl@0:     set result [info exists env(THIS_SHOULDNT_EXIST)]
sl@0:     interp delete i
sl@0:     set result
sl@0: } {0}
sl@0: test env-5.3 {corner cases - unset the env in master should unset child} {} {
sl@0:     # Variables deleted in a master interp should be deleted in
sl@0:     # child interp too.
sl@0: 
sl@0:     interp create i 
sl@0:     i eval { set env(THIS_SHOULD_EXIST) a}
sl@0:     set result [set env(THIS_SHOULD_EXIST)]
sl@0:     unset env(THIS_SHOULD_EXIST)
sl@0:     lappend result [i eval {catch {set env(THIS_SHOULD_EXIST)}}]
sl@0:     interp delete i
sl@0:     set result
sl@0: } {a 1}
sl@0: test env-5.4 {corner cases - unset the env array} {} {
sl@0:     # The info exists command should be in synch with the env array.
sl@0:     # Know Bug: 1737
sl@0: 
sl@0:     interp create i 
sl@0:     i eval { set env(THIS_SHOULD_EXIST) a}
sl@0:     set     result [info exists env(THIS_SHOULD_EXIST)]
sl@0:     lappend result [set env(THIS_SHOULD_EXIST)]
sl@0:     lappend result [info exists env(THIS_SHOULD_EXIST)]
sl@0:     interp delete i
sl@0:     set result
sl@0: } {1 a 1}
sl@0: test env-5.5 {corner cases - cannot have null entries on Windows} {pcOnly} {
sl@0:     set env() a
sl@0:     catch {set env()}
sl@0: } {1}
sl@0: 
sl@0: test env-6.1 {corner cases - add lots of env variables} {} {
sl@0:     set size [array size env]
sl@0:     for {set i 0} {$i < 100} {incr i} {
sl@0: 	set env(BOGUS$i) $i
sl@0:     }
sl@0:     expr {[array size env] - $size}
sl@0: } 100
sl@0: 
sl@0: # Restore the environment variables at the end of the test.
sl@0: 
sl@0: foreach name [array names env] {
sl@0:     unset env($name)
sl@0: }
sl@0: foreach name [array names env2] {
sl@0:     set env($name) $env2($name)
sl@0: }
sl@0: 
sl@0: # cleanup
sl@0: removeFile $printenvScript
sl@0: ::tcltest::cleanupTests
sl@0: return