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