From 256c0bd90c3562915f4af7b84ea24c80a8c4ad61 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 19 Jul 2008 09:57:33 +0000 Subject: Rewrite to use tcltest2 and not generate non-ascii chars in results. Part of fix of [Bug 1513659] --- ChangeLog | 6 ++- tests/env.test | 113 +++++++++++++++++++++++++++++---------------------------- 2 files changed, 63 insertions(+), 56 deletions(-) diff --git a/ChangeLog b/ChangeLog index 5e9a4d5..b1ef5ef 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2008-07-19 Donal K. Fellows + + * tests/env.test: Rewrite so that non-ASCII characters are not used. + Part of fixing [Bug 1513659]. + 2008-07-18 Miguel Sofer * generic/tclBasic.c: Optimization: replace calls to @@ -13,7 +18,6 @@ * generic/tclOOMethod.c: * generic/tclProc.c: - 2008-07-18 Donal K. Fellows * generic/tclOO.c (TclNRNewObjectInstance, FinalizeAlloc): diff --git a/tests/env.test b/tests/env.test index e417db2..2d4dc8a 100644 --- a/tests/env.test +++ b/tests/env.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: env.test,v 1.28 2007/01/19 01:04:00 das Exp $ +# RCS: @(#) $Id: env.test,v 1.29 2008/07/19 09:57:37 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -27,37 +27,39 @@ testConstraint exec [llength [info commands exec]] # 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} { +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 - set return [child eval {set env(test)}] + child eval {set env(test)} +} -cleanup { interp delete child unset env(test) - set return -} {garbage} +} -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} { +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"} { +} +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} - set names [array names env] + expr {"test" in [array names env]} +} -cleanup { interp delete child - set ix [lsearch $names test] catch {unset env(test)} - expr {$ix >= 0} -} {1} +} -result {1} set printenvScript [makeFile { proc lrem {listname name} { @@ -68,6 +70,14 @@ set printenvScript [makeFile { } return $list } + proc mangle s { + regsub -all {\[|\\|\]} $s {\\&} s + regsub -all {[\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) == "windows"} { @@ -85,11 +95,10 @@ set printenvScript [makeFile { lrem names $name } foreach p $names { - puts "$p=$env($p)" + puts "[mangle $p]=[mangle $env($p)]" } exit } printenv] - # [exec] is required here to see the actual environment received # by child processes. proc getenv {} { @@ -103,9 +112,8 @@ proc getenv {} { # Save the current environment variables at the start of the test. +set env2 [array get env] foreach name [array names env] { - set env2($name) $env($name) - # Keep some environment variables that support operation of the # tcltest package. if {[string toupper $name] ni { @@ -121,18 +129,15 @@ foreach name [array names env] { test env-2.1 {adding environment variables} {exec} { getenv } {} - set env(NAME1) "test string" test env-2.2 {adding environment variables} {exec} { getenv } {NAME1=test string} - set env(NAME2) "more" test env-2.3 {adding environment variables} {exec} { getenv } {NAME1=test string NAME2=more} - set env(XYZZY) "garbage" test env-2.4 {adding environment variables} {exec} { getenv @@ -155,84 +160,84 @@ test env-4.1 {unsetting environment variables} {exec} { set result } {NAME1=test string XYZZY=garbage} - test env-4.2 {unsetting environment variables} {exec} { set result [getenv] unset env(XYZZY) set result } {XYZZY=garbage} - test env-4.3 {setting international environment variables} {exec} { set env(\ua7) \ub6 getenv -} "\ua7=\ub6" +} {\u00a7=\u00b6} test env-4.4 {changing international environment variables} {exec} { set env(\ua7) \ua7 getenv -} "\ua7=\ua7" +} {\u00a7=\u00a7} test env-4.5 {unsetting international environment variables} {exec} { set env(\ub6) \ua7 unset env(\ua7) set result [getenv] unset env(\ub6) set result -} "\ub6=\ua7" +} {\u00b6=\u00a7} -test env-5.0 {corner cases - set a value, it should exist} {} { +test env-5.0 {corner cases - set a value, it should exist} -body { set env(temp) a - set result [set env(temp)] + set env(temp) +} -cleanup { unset env(temp) - set result -} {a} -test env-5.1 {corner cases - remove one elem at a time} {} { +} -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. - - set x [array get env] foreach e [array names env] { unset env($e) } - set result [catch {array names env}] + array size env +} -cleanup { array set env $x - set result -} {0} -test env-5.2 {corner cases - unset the env array} {} { +} -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. - - interp create i - i eval { unset env } - i eval { set env(THIS_SHOULDNT_EXIST) a} - set result [info exists env(THIS_SHOULDNT_EXIST)] + i eval { + unset env + set env(THIS_SHOULDNT_EXIST) a + } + info exists env(THIS_SHOULDNT_EXIST) +} -cleanup { interp delete i - set result -} {0} -test env-5.3 {corner cases - unset the env in master should unset child} {} { +} -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. - - interp create i 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 - set result -} {a 1} -test env-5.4 {corner cases - unset the env array} {} { +} -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 - - interp create i 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 - set result -} {1 a 1} +} -result {1 a 1} test env-5.5 {corner cases - cannot have null entries on Windows} {win} { set env() a catch {set env()} @@ -251,9 +256,7 @@ test env-6.1 {corner cases - add lots of env variables} {} { foreach name [array names env] { unset env($name) } -foreach name [array names env2] { - set env($name) $env2($name) -} +array set env $env2 # cleanup removeFile $printenvScript -- cgit v0.12