# 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: @(#) env.test,v 1.5 2003/01/21 19:40:14 hunt 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 } {
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($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} {
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}
# 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