home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / C / Applications / Tcl-Tk 8.0 / Pre-installed version / tcl8.0 / tests / env.test < prev    next >
Encoding:
Text File  |  1997-08-15  |  2.9 KB  |  128 lines  |  [TEXT/ALFA]
  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. #
  10. # See the file "license.terms" for information on usage and redistribution
  11. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  12. #
  13. # SCCS: @(#) env.test 1.13 97/08/05 11:40:30
  14.  
  15. if {[string compare test [info procs test]] == 1} then {source defs}
  16.  
  17. if {[info commands exec] == ""} {
  18.     puts "exec not implemented for this machine"
  19.     return
  20. }
  21.  
  22. if {$tcl_platform(os) == "Win32s"} {
  23.     puts "Cannot run multiple copies of tcl at the same time under Win32s"
  24.     return
  25. }
  26.    
  27. set f [open printenv w]
  28. puts $f {
  29.     proc lrem {listname name} {
  30.     upvar $listname list
  31.     set i [lsearch $list $name]
  32.     if {$i >= 0} {
  33.         set list [lreplace $list $i $i]
  34.     }
  35.     return $list
  36.     }
  37.     
  38.     set names [lsort [array names env]]
  39.     if {$tcl_platform(platform) == "windows"} {
  40.     lrem names HOME
  41.         lrem names COMSPEC
  42.     lrem names ComSpec
  43.     lrem names ""
  44.     }    
  45.     foreach name {TCL_LIBRARY PATH LD_LIBRARY_PATH} {
  46.     lrem names $name
  47.     }
  48.     foreach p $names {
  49.     puts "$p=$env($p)"
  50.     }
  51. }
  52. close $f
  53.     
  54. proc getenv {} {
  55.     global printenv tcltest
  56.     catch {exec $tcltest printenv} out
  57.     if {$out == "child process exited abnormally"} {
  58.     set out {}
  59.     }
  60.     return $out
  61. }
  62.  
  63. # Save the current environment variables at the start of the test.
  64.  
  65. foreach name [array names env] {
  66.     set env2($name) $env($name)
  67.     unset env($name)
  68. }
  69.  
  70. # Added the following lines so that child tcltest can actually find its
  71. # library if the initial tcltest is run from a non-standard place.
  72. # ('saved' env vars)
  73. foreach name {TCL_LIBRARY PATH LD_LIBRARY_PATH} {
  74.   if {[info exists env2($name)]} {
  75.      set env($name) $env2($name);
  76.   }
  77. }
  78.  
  79. test env-1.1 {adding environment variables} {
  80.     getenv
  81. } {}
  82.  
  83. set env(NAME1) "test string"
  84. test env-1.2 {adding environment variables} {
  85.     getenv
  86. } {NAME1=test string}
  87.  
  88. set env(NAME2) "more"
  89. test env-1.3 {adding environment variables} {
  90.     getenv
  91. } {NAME1=test string
  92. NAME2=more}
  93.  
  94. set env(XYZZY) "garbage"
  95. test env-1.4 {adding environment variables} {
  96.     getenv
  97. } {NAME1=test string
  98. NAME2=more
  99. XYZZY=garbage}
  100.  
  101. set env(NAME2) "new value"
  102. test env-2.1 {changing environment variables} {
  103.     getenv
  104. } {NAME1=test string
  105. NAME2=new value
  106. XYZZY=garbage}
  107.  
  108. unset env(NAME2)
  109. test env-3.1 {unsetting environment variables} {
  110.     getenv
  111. } {NAME1=test string
  112. XYZZY=garbage}
  113. unset env(NAME1)
  114. test env-3.2 {unsetting environment variables} {
  115.     getenv
  116. } {XYZZY=garbage}
  117.  
  118. # Restore the environment variables at the end of the test.
  119.  
  120. foreach name [array names env] {
  121.     unset env($name)
  122. }
  123. foreach name [array names env2] {
  124.     set env($name) $env2($name)
  125. }
  126.  
  127. file delete printenv
  128.