270 lines
7.3 KiB
Plaintext
270 lines
7.3 KiB
Plaintext
# 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.
|
|
|
|
if {[lsearch [namespace children] ::tcltest] == -1} {
|
|
package require tcltest 2
|
|
namespace import -force ::tcltest::*
|
|
}
|
|
|
|
# Some tests require the "exec" command.
|
|
# Skip them if exec is not defined.
|
|
testConstraint exec [llength [info commands exec]]
|
|
|
|
#
|
|
# 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}
|
|
|
|
set printenvScript [makeFile {
|
|
proc lrem {listname name} {
|
|
upvar $listname list
|
|
set i [lsearch -nocase $list $name]
|
|
if {$i >= 0} {
|
|
set list [lreplace $list $i $i]
|
|
}
|
|
return $list
|
|
}
|
|
proc mangle s {
|
|
regsub -all {\[|\\|\]} $s {\\&} s
|
|
regsub -all {[\u0000-\u001f\u007f-\uffff]} $s {[manglechar &]} s
|
|
return [subst -novariables $s]
|
|
}
|
|
proc manglechar c {
|
|
return [format {\u%04x} [scan $c %c]]
|
|
}
|
|
|
|
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 LANG WINDIR TERM
|
|
CommonProgramFiles ProgramFiles CommonProgramW6432 ProgramW6432
|
|
} {
|
|
lrem names $name
|
|
}
|
|
foreach p $names {
|
|
puts "[mangle $p]=[mangle $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.
|
|
|
|
set env2 [array get env]
|
|
foreach name [array names env] {
|
|
# Keep some environment variables that support operation of the tcltest
|
|
# package.
|
|
if {[string toupper $name] ni {
|
|
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 LANG WINDIR TERM
|
|
CONNOMPROGRAMFILES PROGRAMFILES COMMONPROGRAMW6432 PROGRAMW6432
|
|
}} {
|
|
unset env($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
|
|
} {\u00a7=\u00b6}
|
|
test env-4.4 {changing international environment variables} {exec} {
|
|
set env(\ua7) \ua7
|
|
getenv
|
|
} {\u00a7=\u00a7}
|
|
test env-4.5 {unsetting international environment variables} {exec} {
|
|
set env(\ub6) \ua7
|
|
unset env(\ua7)
|
|
set result [getenv]
|
|
unset env(\ub6)
|
|
set result
|
|
} {\u00b6=\u00a7}
|
|
|
|
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} {win} {
|
|
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)
|
|
}
|
|
array set env $env2
|
|
|
|
# cleanup
|
|
removeFile $printenvScript
|
|
::tcltest::cleanupTests
|
|
return
|
|
|
|
# Local Variables:
|
|
# mode: tcl
|
|
# End:
|