+++ /dev/null
-# 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} -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}
-
-set printenvScript [makeFile {
- 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 {
- 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 eq "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)
- }
-}
-
-# Need to run 'getenv' in known encoding, so save the current one here...
-set sysenc [encoding system]
-
-test env-2.1 {adding environment variables} -setup {
- encoding system iso8859-1
-} -constraints {exec} -body {
- getenv
-} -cleanup {
- encoding system $sysenc
-} -result {}
-test env-2.2 {adding environment variables} -setup {
- encoding system iso8859-1
-} -constraints {exec} -body {
- set env(NAME1) "test string"
- getenv
-} -cleanup {
- encoding system $sysenc
-} -result {NAME1=test string}
-test env-2.3 {adding environment variables} -setup {
- encoding system iso8859-1
-} -constraints {exec} -body {
- set env(NAME2) "more"
- getenv
-} -cleanup {
- encoding system $sysenc
-} -result {NAME1=test string
-NAME2=more}
-test env-2.4 {adding environment variables} -setup {
- encoding system iso8859-1
-} -constraints {exec} -body {
- set env(XYZZY) "garbage"
- getenv
-} -cleanup {
- encoding system $sysenc
-} -result {NAME1=test string
-NAME2=more
-XYZZY=garbage}
-
-set env(NAME2) "new value"
-test env-3.1 {changing environment variables} -setup {
- encoding system iso8859-1
-} -constraints {exec} -body {
- set result [getenv]
- unset env(NAME2)
- set result
-} -cleanup {
- encoding system $sysenc
-} -result {NAME1=test string
-NAME2=new value
-XYZZY=garbage}
-
-test env-4.1 {unsetting environment variables: default} -setup {
- encoding system iso8859-1
-} -constraints {exec} -body {
- getenv
-} -cleanup {
- encoding system $sysenc
-} -result {NAME1=test string
-XYZZY=garbage}
-test env-4.2 {unsetting environment variables} -setup {
- encoding system iso8859-1
-} -constraints {exec} -body {
- unset env(NAME1)
- getenv
-} -cleanup {
- unset env(XYZZY)
- encoding system $sysenc
-} -result {XYZZY=garbage}
-test env-4.3 {setting international environment variables} -setup {
- encoding system iso8859-1
-} -constraints {exec} -body {
- set env(\ua7) \ub6
- getenv
-} -cleanup {
- encoding system $sysenc
-} -result {\u00a7=\u00b6}
-test env-4.4 {changing international environment variables} -setup {
- encoding system iso8859-1
-} -constraints {exec} -body {
- set env(\ua7) \ua7
- getenv
-} -cleanup {
- encoding system $sysenc
-} -result {\u00a7=\u00a7}
-test env-4.5 {unsetting international environment variables} -setup {
- encoding system iso8859-1
-} -body {
- set env(\ub6) \ua7
- unset env(\ua7)
- getenv
-} -constraints {exec} -cleanup {
- unset env(\ub6)
- encoding system $sysenc
-} -result {\u00b6=\u00a7}
-
-test env-5.0 {corner cases - set a value, it should exist} -body {
- set env(temp) a
- set env(temp)
-} -cleanup {
- unset env(temp)
-} -result {a}
-test env-5.1 {corner cases - remove one elem at a time} -setup {
- set x [array get env]
-} -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 {
- array set env $x
-} -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 {
- 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 {
- interp delete i
-} -result {a 1}
-test env-5.4 {corner cases - unset the env array} -setup {
- 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 {
- interp delete i
-} -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
-
-test env-7.1 {[219226]: whole env array should not be unset by read} {
- 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
-} 0
-test env-7.2 {[219226]: links to env elements should not be removed by read} {
- apply {{} {
- set ::env(test7_2) ok
- upvar env(test7_2) elem
- set ::env(PATH)
- try {
- return $elem
- } finally {
- unset ::env(test7_2)
- }
- }}
-} ok
-
-# 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:
OSDN Git Service
