435 lines
10 KiB
Plaintext
435 lines
10 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 {"::tcltest" ni [namespace children]} {
|
|||
|
|
package require tcltest 2.5
|
|||
|
|
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 MSYSTEM
|
|||
|
|
__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-2.5 {different encoding (wide chars)} -constraints {win exec} -setup {
|
|||
|
|
# be sure set of (unicode) environment occurs if single-byte encoding is used:
|
|||
|
|
encodingswitch cp1252
|
|||
|
|
# german (cp1252) and russian (cp1251) characters together encoded as utf-8:
|
|||
|
|
set val 2d2dc3a4c3b6c3bcc39f2dd182d0b5d181d1822d2d
|
|||
|
|
set env(XYZZY) [encoding convertfrom utf-8 [binary decode hex $val]]
|
|||
|
|
# now switch to utf-8 (to see correct values from test):
|
|||
|
|
encoding system utf-8
|
|||
|
|
} -body {
|
|||
|
|
exec [interpreter] << [string map [list \$val $val] {
|
|||
|
|
encoding system utf-8; fconfigure stdout -encoding utf-8
|
|||
|
|
set test [encoding convertfrom utf-8 [binary decode hex $val]]
|
|||
|
|
puts "[expr {$env(XYZZY) eq $test}] \ngot:\t\
|
|||
|
|
$env(XYZZY) ([binary encode hex [encoding convertto $env(XYZZY)]]) \nexp:\t\
|
|||
|
|
$test ([binary encode hex [encoding convertto $test]])"
|
|||
|
|
}]
|
|||
|
|
} -cleanup {
|
|||
|
|
encodingrestore
|
|||
|
|
unset -nocomplain val f env(XYZZY)
|
|||
|
|
} -match glob -result {1 *}
|
|||
|
|
|
|||
|
|
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 parent should unset child} -setup {
|
|||
|
|
setup1
|
|||
|
|
interp create i
|
|||
|
|
} -body {
|
|||
|
|
# Variables deleted in a parent 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:
|