path: root/tests/env.test

# 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::*
}

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
    __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-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 master should unset child} -setup {
    setup1
    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 {
    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: