1# Commands covered: none (tests environment variable implementation) 2# 3# This file contains a collection of tests for one or more of the Tcl built-in 4# commands. Sourcing this file into Tcl runs the tests and generates output 5# for errors. No output means no errors were found. 6# 7# Copyright © 1991-1993 The Regents of the University of California. 8# Copyright © 1994 Sun Microsystems, Inc. 9# Copyright © 1998-1999 Scriptics Corporation. 10# 11# See the file "license.terms" for information on usage and redistribution of 12# this file, and for a DISCLAIMER OF ALL WARRANTIES. 13 14if {"::tcltest" ni [namespace children]} { 15 package require tcltest 2.5 16 namespace import -force ::tcltest::* 17} 18 19loadTestedCommands 20catch [list package require -exact tcl::test [info patchlevel]] 21package require tcltests 22 23# [exec] is required here to see the actual environment received by child 24# processes. 25proc getenv {} { 26 global printenvScript 27 catch {exec [interpreter] $printenvScript} out 28 if {$out eq "child process exited abnormally"} { 29 set out {} 30 } 31 return $out 32} 33 34 35proc envrestore {} { 36 # Restore the environment variables at the end of the test. 37 global env 38 variable env2 39 40 foreach name [array names env] { 41 unset env($name) 42 } 43 array set env $env2 44 return 45} 46 47 48proc envprep {} { 49 # Save the current environment variables at the start of the test. 50 global env 51 variable keep 52 variable env2 53 54 set env2 [array get env] 55 foreach name [array names env] { 56 # Keep some environment variables that support operation of the tcltest 57 # package. 58 if {[string toupper $name] ni [string toupper $keep]} { 59 unset env($name) 60 } 61 } 62 return 63} 64 65 66proc encodingrestore {} { 67 variable sysenc 68 encoding system $sysenc 69 return 70} 71 72 73proc encodingswitch encoding { 74 variable sysenc 75 # Need to run [getenv] in known encoding, so save the current one here... 76 set sysenc [encoding system] 77 encoding system $encoding 78 return 79} 80 81 82proc setup1 {} { 83 global env 84 envprep 85 encodingswitch iso8859-1 86} 87 88proc setup2 {} { 89 global env 90 setup1 91 set env(NAME1) {test string} 92 set env(NAME2) {new value} 93 set env(XYZZY) {garbage} 94} 95 96 97proc cleanup1 {} { 98 encodingrestore 99 envrestore 100} 101 102variable keep { 103 TCL_LIBRARY PATH LD_LIBRARY_PATH LIBPATH PURE_PROG_NAME DISPLAY 104 SHLIB_PATH SYSTEMDRIVE SYSTEMROOT DYLD_LIBRARY_PATH DYLD_FRAMEWORK_PATH 105 DYLD_NEW_LOCAL_SHARED_REGIONS DYLD_NO_FIX_PREBINDING MSYSTEM 106 __CF_USER_TEXT_ENCODING SECURITYSESSIONID LANG WINDIR TERM 107 CommonProgramFiles CommonProgramFiles(x86) ProgramFiles 108 ProgramFiles(x86) CommonProgramW6432 ProgramW6432 109 WINECONFIGDIR WINEDATADIR WINEDLLDIR0 WINEHOMEDIR 110} 111 112variable printenvScript [makeFile [string map [list @keep@ [list $keep]] { 113 encoding system iso8859-1 114 proc lrem {listname name} { 115 upvar $listname list 116 set i [lsearch -nocase $list $name] 117 if {$i >= 0} { 118 set list [lreplace $list $i $i] 119 } 120 return $list 121 } 122 proc mangle s { 123 regsub -all {\[|\\|\]} $s {\\&} s 124 regsub -all "\[\u0000-\u001f\u007f-\uffff\]" $s {[manglechar {&}]} s 125 return [subst -novariables $s] 126 } 127 proc manglechar c { 128 return [format {\u%04x} [scan $c %c]] 129 } 130 131 set names [lsort [array names env]] 132 if {$tcl_platform(platform) eq "windows"} { 133 lrem names HOME 134 lrem names COMSPEC 135 lrem names ComSpec 136 lrem names "" 137 } 138 foreach name @keep@ { 139 lrem names $name 140 } 141 foreach p $names { 142 puts [mangle $p]=[mangle $env($p)] 143 } 144 exit 145}] printenv] 146 147 148test env-1.1 {propagation of env values to child interpreters} -setup { 149 catch {interp delete child} 150 catch {unset env(test)} 151} -body { 152 interp create child 153 set env(test) garbage 154 child eval {set env(test)} 155} -cleanup { 156 interp delete child 157 unset env(test) 158} -result {garbage} 159 160 161# This one crashed on Solaris under Tcl8.0, so we only want to make sure it 162# runs. 163test env-1.2 {lappend to env value} -setup { 164 catch {unset env(test)} 165} -body { 166 set env(test) aaaaaaaaaaaaaaaa 167 append env(test) bbbbbbbbbbbbbb 168 unset env(test) 169} 170 171 172test env-1.3 {reflection of env by "array names"} -setup { 173 catch {interp delete child} 174 catch {unset env(test)} 175} -body { 176 interp create child 177 child eval {set env(test) garbage} 178 expr {"test" in [array names env]} 179} -cleanup { 180 interp delete child 181 catch {unset env(test)} 182} -result 1 183 184 185test env-2.1 { 186 adding environment variables 187} -constraints exec -setup setup1 -body { 188 getenv 189} -cleanup cleanup1 -result {} 190 191 192test env-2.2 { 193 adding environment variables 194} -constraints exec -setup setup1 -body { 195 set env(NAME1) "test string" 196 getenv 197} -cleanup cleanup1 -result {NAME1=test string} 198 199 200test env-2.3 {adding environment variables} -constraints exec -setup { 201 setup1 202 set env(NAME1) "test string" 203} -body { 204 set env(NAME2) "more" 205 getenv 206} -cleanup cleanup1 -result {NAME1=test string 207NAME2=more} 208 209 210test env-2.4 { 211 adding environment variables 212} -constraints exec -setup { 213 setup1 214 set env(NAME1) "test string" 215 set env(NAME2) "more" 216} -body { 217 set env(XYZZY) "garbage" 218 getenv 219} -cleanup { cleanup1 220} -result {NAME1=test string 221NAME2=more 222XYZZY=garbage} 223 224test env-2.5 {different encoding (wide chars)} -constraints {win exec} -setup { 225 # be sure set of (unicode) environment occurs if single-byte encoding is used: 226 encodingswitch cp1252 227 # german (cp1252) and russian (cp1251) characters together encoded as utf-8: 228 set val 2d2dc3a4c3b6c3bcc39f2dd182d0b5d181d1822d2d 229 set env(XYZZY) [encoding convertfrom utf-8 [binary decode hex $val]] 230 # now switch to utf-8 (to see correct values from test): 231 encoding system utf-8 232} -body { 233 exec [interpreter] << [string map [list \$val $val] { 234 encoding system utf-8; fconfigure stdout -encoding utf-8 235 set test [encoding convertfrom utf-8 [binary decode hex $val]] 236 puts "[expr {$env(XYZZY) eq $test}] \ngot:\t\ 237 $env(XYZZY) ([binary encode hex [encoding convertto $env(XYZZY)]]) \nexp:\t\ 238 $test ([binary encode hex [encoding convertto $test]])" 239 }] 240} -cleanup { 241 encodingrestore 242 unset -nocomplain val f env(XYZZY) 243} -match glob -result {1 *} 244 245test env-3.1 { 246 changing environment variables 247} -constraints exec -setup setup2 -body { 248 set result [getenv] 249 unset env(NAME2) 250 set result 251} -cleanup { 252 cleanup1 253} -result {NAME1=test string 254NAME2=new value 255XYZZY=garbage} 256 257 258test env-4.1 { 259 unsetting environment variables 260} -constraints exec -setup setup2 -body { 261 unset -nocomplain env(NAME2) 262 getenv 263} -cleanup cleanup1 -result {NAME1=test string 264XYZZY=garbage} 265 266# env-4.2 is deleted 267 268test env-4.3 { 269 setting international environment variables 270} -constraints exec -setup setup1 -body { 271 set env(\ua7) \ub6 272 getenv 273} -cleanup cleanup1 -result {\u00a7=\u00b6} 274 275 276test env-4.4 { 277 changing international environment variables 278} -constraints exec -setup setup1 -body { 279 set env(\ua7) \ua7 280 getenv 281} -cleanup cleanup1 -result {\u00a7=\u00a7} 282 283 284test env-4.5 { 285 unsetting international environment variables 286} -constraints exec -setup { 287 setup1 288 set env(\ua7) \ua7 289} -body { 290 set env(\ub6) \ua7 291 unset env(\ua7) 292 getenv 293} -cleanup cleanup1 -result {\u00b6=\u00a7} 294 295test env-5.0 { 296 corner cases - set a value, it should exist 297} -setup setup1 -body { 298 set env(temp) a 299 set env(temp) 300} -cleanup cleanup1 -result a 301 302 303test env-5.1 { 304 corner cases - remove one elem at a time 305} -setup setup1 -body { 306 # When no environment variables exist, the env var will contain no 307 # entries. The "array names" call synchs up the C-level environ array with 308 # the Tcl level env array. Make sure an empty Tcl array is created. 309 foreach e [array names env] { 310 unset env($e) 311 } 312 array size env 313} -cleanup cleanup1 -result 0 314 315 316test env-5.2 {corner cases - unset the env array} -setup { 317 interp create i 318} -body { 319 # Unsetting a variable in an interp detaches the C-level traces from the 320 # Tcl "env" variable. 321 i eval { 322 unset env 323 set env(THIS_SHOULDNT_EXIST) a 324 } 325 info exists env(THIS_SHOULDNT_EXIST) 326} -cleanup { 327 interp delete i 328} -result {0} 329 330 331test env-5.3 {corner cases: unset the env in parent should unset child} -setup { 332 setup1 333 interp create i 334} -body { 335 # Variables deleted in a parent interp should be deleted in child interp 336 # too. 337 i eval {set env(THIS_SHOULD_EXIST) a} 338 set result [set env(THIS_SHOULD_EXIST)] 339 unset env(THIS_SHOULD_EXIST) 340 lappend result [i eval {catch {set env(THIS_SHOULD_EXIST)}}] 341} -cleanup { 342 cleanup1 343 interp delete i 344} -result {a 1} 345 346 347test env-5.4 {corner cases - unset the env array} -setup { 348 setup1 349 interp create i 350} -body { 351 # The info exists command should be in synch with the env array. 352 # Know Bug: 1737 353 i eval {set env(THIS_SHOULD_EXIST) a} 354 set result [info exists env(THIS_SHOULD_EXIST)] 355 lappend result [set env(THIS_SHOULD_EXIST)] 356 lappend result [info exists env(THIS_SHOULD_EXIST)] 357} -cleanup { 358 cleanup1 359 interp delete i 360} -result {1 a 1} 361 362 363test env-5.5 { 364 corner cases - cannot have null entries on Windows 365} -constraints win -body { 366 set env() a 367 catch {set env()} 368} -cleanup cleanup1 -result 1 369 370test env-6.1 {corner cases - add lots of env variables} -setup setup1 -body { 371 set size [array size env] 372 for {set i 0} {$i < 100} {incr i} { 373 set env(BOGUS$i) $i 374 } 375 expr {[array size env] - $size} 376} -cleanup cleanup1 -result 100 377 378test env-7.1 {[219226]: whole env array should not be unset by read} -body { 379 set n [array size env] 380 set s [array startsearch env] 381 while {[array anymore env $s]} { 382 array nextelement env $s 383 incr n -1 384 } 385 array donesearch env $s 386 return $n 387} -result 0 388 389test env-7.2 { 390 [219226]: links to env elements should not be removed by read 391} -setup setup1 -body { 392 apply {{} { 393 set ::env(test7_2) ok 394 upvar env(test7_2) elem 395 set ::env(PATH) 396 return $elem 397 }} 398} -cleanup cleanup1 -result ok 399 400test env-7.3 { 401 [9b4702]: testing existence of env(some_thing) should not destroy trace 402} -setup setup1 -body { 403 apply {{} { 404 catch {unset ::env(test7_3)} 405 proc foo args { 406 set ::env(test7_3) ok 407 } 408 trace add variable ::env(not_yet_existent) write foo 409 info exists ::env(not_yet_existent) 410 set ::env(not_yet_existent) "Now I'm here"; 411 return [info exists ::env(test7_3)] 412 }} 413} -cleanup cleanup1 -result 1 414 415test env-8.0 { 416 memory usage - valgrind does not report reachable memory 417} -body { 418 set res [set env(__DUMMY__) {i'm with dummy}] 419 unset env(__DUMMY__) 420 return $res 421} -result {i'm with dummy} 422 423 424 425# cleanup 426rename getenv {} 427rename envrestore {} 428rename envprep {} 429rename encodingrestore {} 430rename encodingswitch {} 431 432removeFile $printenvScript 433::tcltest::cleanupTests 434return 435 436# Local Variables: 437# mode: tcl 438# End: 439