diff options
Diffstat (limited to 'tcl8.6/tests/env.test')
| -rw-r--r-- | tcl8.6/tests/env.test | 414 |
1 files changed, 414 insertions, 0 deletions
diff --git a/tcl8.6/tests/env.test b/tcl8.6/tests/env.test new file mode 100644 index 0000000..e6ce44d --- /dev/null +++ b/tcl8.6/tests/env.test @@ -0,0 +1,414 @@ +# 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::* +} + +package require tcltests + +# [exec] is required here to see the actual environment received by child +# processes. +proc getenv {} { + global printenvScript + catch {exec [interpreter] $printenvScript} out + if {$out eq "child process exited abnormally"} { + set out {} + } + return $out +} + + +proc envrestore {} { + # Restore the environment variables at the end of the test. + global env + variable env2 + + foreach name [array names env] { + unset env($name) + } + array set env $env2 + return +} + + +proc envprep {} { + # Save the current environment variables at the start of the test. + global env + variable keep + variable env2 + + 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 [string toupper $keep]} { + unset env($name) + } + } + return +} + + +proc encodingrestore {} { + variable sysenc + encoding system $sysenc + return +} + + +proc encodingswitch encoding { + variable sysenc + # Need to run [getenv] in known encoding, so save the current one here... + set sysenc [encoding system] + encoding system $encoding + return +} + + +proc setup1 {} { + global env + envprep + encodingswitch iso8859-1 +} + +proc setup2 {} { + global env + setup1 + set env(NAME1) {test string} + set env(NAME2) {new value} + set env(XYZZY) {garbage} +} + + +proc cleanup1 {} { + encodingrestore + envrestore +} + +variable keep { + 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 +} + +variable printenvScript [makeFile [string map [list @keep@ [list $keep]] { + encoding system iso8859-1 + 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) eq "windows"} { + lrem names HOME + lrem names COMSPEC + lrem names ComSpec + lrem names "" + } + foreach name @keep@ { + lrem names $name + } + foreach p $names { + puts [mangle $p]=[mangle $env($p)] + } + exit +}] printenv] + + +test env-1.1 {propagation of env values to child interpreters} -setup { + catch {interp delete child} + catch {unset env(test)} +} -body { + interp create child + set env(test) garbage + child eval {set env(test)} +} -cleanup { + interp delete child + unset env(test) +} -result {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} -setup { + catch {unset env(test)} +} -body { + set env(test) aaaaaaaaaaaaaaaa + append env(test) bbbbbbbbbbbbbb + unset env(test) +} + + +test env-1.3 {reflection of env by "array names"} -setup { + catch {interp delete child} + catch {unset env(test)} +} -body { + interp create child + child eval {set env(test) garbage} + expr {"test" in [array names env]} +} -cleanup { + interp delete child + catch {unset env(test)} +} -result 1 + + +test env-2.1 { + adding environment variables +} -constraints exec -setup setup1 -body { + getenv +} -cleanup cleanup1 -result {} + + +test env-2.2 { + adding environment variables +} -constraints exec -setup setup1 -body { + set env(NAME1) "test string" + getenv +} -cleanup cleanup1 -result {NAME1=test string} + + +test env-2.3 {adding environment variables} -constraints exec -setup { + setup1 + set env(NAME1) "test string" +} -body { + set env(NAME2) "more" + getenv +} -cleanup cleanup1 -result {NAME1=test string +NAME2=more} + + +test env-2.4 { + adding environment variables +} -constraints exec -setup { + setup1 + set env(NAME1) "test string" + set env(NAME2) "more" +} -body { + set env(XYZZY) "garbage" + getenv +} -cleanup { cleanup1 +} -result {NAME1=test string +NAME2=more +XYZZY=garbage} + + +test env-3.1 { + changing environment variables +} -constraints exec -setup setup2 -body { + set result [getenv] + unset env(NAME2) + set result +} -cleanup { + cleanup1 +} -result {NAME1=test string +NAME2=new value +XYZZY=garbage} + + +test env-4.1 { + unsetting environment variables +} -constraints exec -setup setup2 -body { + unset -nocomplain env(NAME2) + getenv +} -cleanup cleanup1 -result {NAME1=test string +XYZZY=garbage} + +# env-4.2 is deleted + +test env-4.3 { + setting international environment variables +} -constraints exec -setup setup1 -body { + set env(\ua7) \ub6 + getenv +} -cleanup cleanup1 -result {\u00a7=\u00b6} + + +test env-4.4 { + changing international environment variables +} -constraints exec -setup setup1 -body { + set env(\ua7) \ua7 + getenv +} -cleanup cleanup1 -result {\u00a7=\u00a7} + + +test env-4.5 { + unsetting international environment variables +} -constraints exec -setup { + setup1 + set env(\ua7) \ua7 +} -body { + set env(\ub6) \ua7 + unset env(\ua7) + getenv +} -cleanup cleanup1 -result {\u00b6=\u00a7} + +test env-5.0 { + corner cases - set a value, it should exist +} -setup setup1 -body { + set env(temp) a + set env(temp) +} -cleanup cleanup1 -result a + + +test env-5.1 { + corner cases - remove one elem at a time +} -setup setup1 -body { + # 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. + foreach e [array names env] { + unset env($e) + } + array size env +} -cleanup cleanup1 -result 0 + + +test env-5.2 {corner cases - unset the env array} -setup { + interp create i +} -body { + # Unsetting a variable in an interp detaches the C-level traces from the + # Tcl "env" variable. + i eval { + unset env + set env(THIS_SHOULDNT_EXIST) a + } + info exists env(THIS_SHOULDNT_EXIST) +} -cleanup { + interp delete i +} -result {0} + + +test env-5.3 {corner cases: unset the env in master should unset child} -setup { + setup1 + interp create i +} -body { + # Variables deleted in a master interp should be deleted in child interp + # too. + 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)}}] +} -cleanup { + cleanup1 + interp delete i +} -result {a 1} + + +test env-5.4 {corner cases - unset the env array} -setup { + setup1 + interp create i +} -body { + # The info exists command should be in synch with the env array. + # Know Bug: 1737 + 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)] +} -cleanup { + cleanup1 + interp delete i +} -result {1 a 1} + + +test env-5.5 { + corner cases - cannot have null entries on Windows +} -constraints win -body { + set env() a + catch {set env()} +} -cleanup cleanup1 -result 1 + +test env-6.1 {corner cases - add lots of env variables} -setup setup1 -body { + set size [array size env] + for {set i 0} {$i < 100} {incr i} { + set env(BOGUS$i) $i + } + expr {[array size env] - $size} +} -cleanup cleanup1 -result 100 + +test env-7.1 {[219226]: whole env array should not be unset by read} -body { + set n [array size env] + set s [array startsearch env] + while {[array anymore env $s]} { + array nextelement env $s + incr n -1 + } + array donesearch env $s + return $n +} -result 0 + +test env-7.2 { + [219226]: links to env elements should not be removed by read +} -setup setup1 -body { + apply {{} { + set ::env(test7_2) ok + upvar env(test7_2) elem + set ::env(PATH) + return $elem + }} +} -cleanup cleanup1 -result ok + +test env-7.3 { + [9b4702]: testing existence of env(some_thing) should not destroy trace +} -setup setup1 -body { + apply {{} { + catch {unset ::env(test7_3)} + proc foo args { + set ::env(test7_3) ok + } + trace add variable ::env(not_yet_existent) write foo + info exists ::env(not_yet_existent) + set ::env(not_yet_existent) "Now I'm here"; + return [info exists ::env(test7_3)] + }} +} -cleanup cleanup1 -result 1 + +test env-8.0 { + memory usage - valgrind does not report reachable memory +} -body { + set res [set env(__DUMMY__) {i'm with dummy}] + unset env(__DUMMY__) + return $res +} -result {i'm with dummy} + + + +# cleanup +rename getenv {} +rename envrestore {} +rename envprep {} +rename encodingrestore {} +rename encodingswitch {} + +removeFile $printenvScript +::tcltest::cleanupTests +return + +# Local Variables: +# mode: tcl +# End: |