1# Commands covered: none (tests environment variable implementation) 2# 3# This file contains a collection of tests for one or more of the Tcl 4# built-in commands. Sourcing this file into Tcl runs the tests and 5# generates output for errors. No output means no errors were found. 6# 7# Copyright (c) 1991-1993 The Regents of the University of California. 8# Copyright (c) 1994 Sun Microsystems, Inc. 9# Copyright (c) 1998-1999 by Scriptics Corporation. 10# 11# See the file "license.terms" for information on usage and redistribution 12# of this file, and for a DISCLAIMER OF ALL WARRANTIES. 13# 14# RCS: @(#) $Id: env.test,v 1.17.2.5 2007/01/19 01:05:50 das Exp $ 15 16package require tcltest 2 17namespace import -force ::tcltest::* 18 19# 20# These tests will run on any platform (and indeed crashed 21# on the Mac). So put them before you test for the existance 22# of exec. 23# 24test env-1.1 {propagation of env values to child interpreters} { 25 catch {interp delete child} 26 catch {unset env(test)} 27 interp create child 28 set env(test) garbage 29 set return [child eval {set env(test)}] 30 interp delete child 31 unset env(test) 32 set return 33} {garbage} 34# 35# This one crashed on Solaris under Tcl8.0, so we only 36# want to make sure it runs. 37# 38test env-1.2 {lappend to env value} { 39 catch {unset env(test)} 40 set env(test) aaaaaaaaaaaaaaaa 41 append env(test) bbbbbbbbbbbbbb 42 unset env(test) 43} {} 44test env-1.3 {reflection of env by "array names"} { 45 catch {interp delete child} 46 catch {unset env(test)} 47 interp create child 48 child eval {set env(test) garbage} 49 set names [array names env] 50 interp delete child 51 set ix [lsearch $names test] 52 catch {unset env(test)} 53 expr {$ix >= 0} 54} {1} 55 56 57# Some tests require the "exec" command. 58# Skip them if exec is not defined. 59testConstraint exec [llength [info commands exec]] 60 61set printenvScript [makeFile { 62 proc lrem {listname name} { 63 upvar $listname list 64 set i [lsearch $list $name] 65 if {$i >= 0} { 66 set list [lreplace $list $i $i] 67 } 68 return $list 69 } 70 71 set names [lsort [array names env]] 72 if {$tcl_platform(platform) == "windows"} { 73 lrem names HOME 74 lrem names COMSPEC 75 lrem names ComSpec 76 lrem names "" 77 } 78 foreach name { 79 TCL_LIBRARY PATH LD_LIBRARY_PATH LIBPATH PURE_PROG_NAME DISPLAY 80 SHLIB_PATH SYSTEMDRIVE SYSTEMROOT DYLD_LIBRARY_PATH DYLD_FRAMEWORK_PATH 81 DYLD_NEW_LOCAL_SHARED_REGIONS DYLD_NO_FIX_PREBINDING 82 __CF_USER_TEXT_ENCODING SECURITYSESSIONID 83 } { 84 lrem names $name 85 } 86 foreach p $names { 87 puts "$p=$env($p)" 88 } 89 exit 90} printenv] 91 92# [exec] is required here to see the actual environment received 93# by child processes. 94proc getenv {} { 95 global printenvScript tcltest 96 catch {exec [interpreter] $printenvScript} out 97 if {$out == "child process exited abnormally"} { 98 set out {} 99 } 100 return $out 101} 102 103# Save the current environment variables at the start of the test. 104 105foreach name [array names env] { 106 set env2([string toupper $name]) $env($name) 107 unset env($name) 108} 109 110# Added the following lines so that child tcltest can actually find its 111# library if the initial tcltest is run from a non-standard place. 112# ('saved' env vars) 113foreach name { 114 TCL_LIBRARY PATH LD_LIBRARY_PATH LIBPATH DISPLAY SHLIB_PATH 115 SYSTEMDRIVE SYSTEMROOT DYLD_LIBRARY_PATH DYLD_FRAMEWORK_PATH 116 DYLD_NEW_LOCAL_SHARED_REGIONS DYLD_NO_FIX_PREBINDING 117 SECURITYSESSIONID} { 118 if {[info exists env2($name)]} { 119 set env($name) $env2($name); 120 } 121} 122 123test env-2.1 {adding environment variables} {exec} { 124 getenv 125} {} 126 127set env(NAME1) "test string" 128test env-2.2 {adding environment variables} {exec} { 129 getenv 130} {NAME1=test string} 131 132set env(NAME2) "more" 133test env-2.3 {adding environment variables} {exec} { 134 getenv 135} {NAME1=test string 136NAME2=more} 137 138set env(XYZZY) "garbage" 139test env-2.4 {adding environment variables} {exec} { 140 getenv 141} {NAME1=test string 142NAME2=more 143XYZZY=garbage} 144 145set env(NAME2) "new value" 146test env-3.1 {changing environment variables} {exec} { 147 set result [getenv] 148 unset env(NAME2) 149 set result 150} {NAME1=test string 151NAME2=new value 152XYZZY=garbage} 153 154test env-4.1 {unsetting environment variables} {exec} { 155 set result [getenv] 156 unset env(NAME1) 157 set result 158} {NAME1=test string 159XYZZY=garbage} 160 161test env-4.2 {unsetting environment variables} {exec} { 162 set result [getenv] 163 unset env(XYZZY) 164 set result 165} {XYZZY=garbage} 166 167test env-4.3 {setting international environment variables} {exec} { 168 set env(\ua7) \ub6 169 getenv 170} "\ua7=\ub6" 171test env-4.4 {changing international environment variables} {exec} { 172 set env(\ua7) \ua7 173 getenv 174} "\ua7=\ua7" 175test env-4.5 {unsetting international environment variables} {exec} { 176 set env(\ub6) \ua7 177 unset env(\ua7) 178 set result [getenv] 179 unset env(\ub6) 180 set result 181} "\ub6=\ua7" 182 183test env-5.0 {corner cases - set a value, it should exist} {} { 184 set env(temp) a 185 set result [set env(temp)] 186 unset env(temp) 187 set result 188} {a} 189test env-5.1 {corner cases - remove one elem at a time} {} { 190 # When no environment variables exist, the env var will 191 # contain no entries. The "array names" call synchs up 192 # the C-level environ array with the Tcl level env array. 193 # Make sure an empty Tcl array is created. 194 195 set x [array get env] 196 foreach e [array names env] { 197 unset env($e) 198 } 199 set result [catch {array names env}] 200 array set env $x 201 set result 202} {0} 203test env-5.2 {corner cases - unset the env array} {} { 204 # Unsetting a variable in an interp detaches the C-level 205 # traces from the Tcl "env" variable. 206 207 interp create i 208 i eval { unset env } 209 i eval { set env(THIS_SHOULDNT_EXIST) a} 210 set result [info exists env(THIS_SHOULDNT_EXIST)] 211 interp delete i 212 set result 213} {0} 214test env-5.3 {corner cases - unset the env in master should unset child} {} { 215 # Variables deleted in a master interp should be deleted in 216 # child interp too. 217 218 interp create i 219 i eval { set env(THIS_SHOULD_EXIST) a} 220 set result [set env(THIS_SHOULD_EXIST)] 221 unset env(THIS_SHOULD_EXIST) 222 lappend result [i eval {catch {set env(THIS_SHOULD_EXIST)}}] 223 interp delete i 224 set result 225} {a 1} 226test env-5.4 {corner cases - unset the env array} {} { 227 # The info exists command should be in synch with the env array. 228 # Know Bug: 1737 229 230 interp create i 231 i eval { set env(THIS_SHOULD_EXIST) a} 232 set result [info exists env(THIS_SHOULD_EXIST)] 233 lappend result [set env(THIS_SHOULD_EXIST)] 234 lappend result [info exists env(THIS_SHOULD_EXIST)] 235 interp delete i 236 set result 237} {1 a 1} 238test env-5.5 {corner cases - cannot have null entries on Windows} {pcOnly} { 239 set env() a 240 catch {set env()} 241} {1} 242 243test env-6.1 {corner cases - add lots of env variables} {} { 244 set size [array size env] 245 for {set i 0} {$i < 100} {incr i} { 246 set env(BOGUS$i) $i 247 } 248 expr {[array size env] - $size} 249} 100 250 251# Restore the environment variables at the end of the test. 252 253foreach name [array names env] { 254 unset env($name) 255} 256foreach name [array names env2] { 257 set env($name) $env2($name) 258} 259 260# cleanup 261removeFile $printenvScript 262::tcltest::cleanupTests 263return 264