Tcl Source Code

Check-in [26c40ac305]
Login

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:The only relyable way of changing environment variables to uppercase (e.g. env(ComSpec) to env(COMSPEC)) is unsetting the old one first. Long-standing bug, exposed by [219226].
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | core-8-5-branch
Files: files | file ages | folders
SHA1: 26c40ac3053dd42a700f85eba1bdb0a324352b80
User & Date: jan.nijtmans 2013-11-21 09:18:04
Context
2013-11-21
11:43
Add support for Windows 8.1: See [http://msdn.microsoft.com/en-us/library/windows/desktop/dn302074.a... check-in: c505b4ac53 user: jan.nijtmans tags: core-8-5-branch
09:24
The only relyable way of changing environment variables to uppercase (e.g. env(ComSpec) to env(COMSP... check-in: bd7d5c1f7c user: jan.nijtmans tags: trunk
09:18
The only relyable way of changing environment variables to uppercase (e.g. env(ComSpec) to env(COMSP... check-in: 26c40ac305 user: jan.nijtmans tags: core-8-5-branch
2013-11-20
16:04
Safer clean-up of environment variables: Do removal after insertions -> tcltest 2.3.7 check-in: e934186601 user: jan.nijtmans tags: core-8-5-branch
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to library/init.tcl.

73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
	    encoding dirs $Path
        }
    }

    # TIP #255 min and max functions
    namespace eval mathfunc {
	proc min {args} {
	    if {[llength $args] == 0} {
		return -code error \
		    "too few arguments to math function \"min\""
	    }
	    set val Inf
	    foreach arg $args {
		# This will handle forcing the numeric value without
		# ruining the internal type of a numeric object
		if {[catch {expr {double($arg)}} err]} {
		    return -code error $err
		}
		if {$arg < $val} { set val $arg }
	    }
	    return $val
	}
	proc max {args} {
	    if {[llength $args] == 0} {
		return -code error \
		    "too few arguments to math function \"max\""
	    }
	    set val -Inf
	    foreach arg $args {
		# This will handle forcing the numeric value without
		# ruining the internal type of a numeric object
		if {[catch {expr {double($arg)}} err]} {
		    return -code error $err
		}
		if {$arg > $val} { set val $arg }
	    }
	    return $val
	}
	namespace export min max
    }
}








|










|




|










|







73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
	    encoding dirs $Path
        }
    }

    # TIP #255 min and max functions
    namespace eval mathfunc {
	proc min {args} {
	    if {![llength $args]} {
		return -code error \
		    "too few arguments to math function \"min\""
	    }
	    set val Inf
	    foreach arg $args {
		# This will handle forcing the numeric value without
		# ruining the internal type of a numeric object
		if {[catch {expr {double($arg)}} err]} {
		    return -code error $err
		}
		if {$arg < $val} {set val $arg}
	    }
	    return $val
	}
	proc max {args} {
	    if {![llength $args]} {
		return -code error \
		    "too few arguments to math function \"max\""
	    }
	    set val -Inf
	    foreach arg $args {
		# This will handle forcing the numeric value without
		# ruining the internal type of a numeric object
		if {[catch {expr {double($arg)}} err]} {
		    return -code error $err
		}
		if {$arg > $val} {set val $arg}
	    }
	    return $val
	}
	namespace export min max
    }
}

126
127
128
129
130
131
132

133
134
135
136
137
138
139
140
141
142
	    global env tcl_platform
	    foreach p [array names env] {
		set u [string toupper $p]
		if {$u ne $p} {
		    switch -- $u {
			COMSPEC -
			PATH {

			    if {![info exists env($u)]} {
				set env($u) $env($p)
			    }
			    trace add variable env($p) write \
				    [namespace code [list EnvTraceProc $p]]
			    trace add variable env($u) write \
				    [namespace code [list EnvTraceProc $p]]
			}
		    }
		}







>
|
|
<







126
127
128
129
130
131
132
133
134
135

136
137
138
139
140
141
142
	    global env tcl_platform
	    foreach p [array names env] {
		set u [string toupper $p]
		if {$u ne $p} {
		    switch -- $u {
			COMSPEC -
			PATH {
			    set temp $env($p)
			    unset env($p)
			    set env($u) $temp

			    trace add variable env($p) write \
				    [namespace code [list EnvTraceProc $p]]
			    trace add variable env($u) write \
				    [namespace code [list EnvTraceProc $p]]
			}
		    }
		}
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191

    proc clock args {
	namespace eval ::tcl::clock [list namespace ensemble create -command \
		[uplevel 1 [list namespace origin [lindex [info level 0] 0]]] \
		-subcommands {
		    add clicks format microseconds milliseconds scan seconds
		}]
	
	# Auto-loading stubs for 'clock.tcl'
	
	foreach cmd {add format scan} {
	    proc ::tcl::clock::$cmd args {
		variable TclLibDir
		source -encoding utf-8 [file join $TclLibDir clock.tcl]
		return [uplevel 1 [info level 0]]
	    }
	}







|

|







175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191

    proc clock args {
	namespace eval ::tcl::clock [list namespace ensemble create -command \
		[uplevel 1 [list namespace origin [lindex [info level 0] 0]]] \
		-subcommands {
		    add clicks format microseconds milliseconds scan seconds
		}]

	# Auto-loading stubs for 'clock.tcl'

	foreach cmd {add format scan} {
	    proc ::tcl::clock::$cmd args {
		variable TclLibDir
		source -encoding utf-8 [file join $TclLibDir clock.tcl]
		return [uplevel 1 [info level 0]]
	    }
	}
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
    set name $cmd
    if {![info exists auto_noload]} {
	#
	# Make sure we're not trying to load the same proc twice.
	#
	if {[info exists UnknownPending($name)]} {
	    return -code error "self-referential recursion\
		    in \"unknown\" for command \"$name\"";
	}
	set UnknownPending($name) pending;
	set ret [catch {
		auto_load $name [uplevel 1 {::namespace current}]
	} msg opts]
	unset UnknownPending($name);
	if {$ret != 0} {
	    dict append opts -errorinfo "\n    (autoloading \"$name\")"
	    return -options $opts $msg
	}
	if {![array size UnknownPending]} {
	    unset UnknownPending
	}







|

|



|







257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
    set name $cmd
    if {![info exists auto_noload]} {
	#
	# Make sure we're not trying to load the same proc twice.
	#
	if {[info exists UnknownPending($name)]} {
	    return -code error "self-referential recursion\
		    in \"unknown\" for command \"$name\""
	}
	set UnknownPending($name) pending
	set ret [catch {
		auto_load $name [uplevel 1 {::namespace current}]
	} msg opts]
	unset UnknownPending($name)
	if {$ret != 0} {
	    dict append opts -errorinfo "\n    (autoloading \"$name\")"
	    return -options $opts $msg
	}
	if {![array size UnknownPending]} {
	    unset UnknownPending
	}
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
	    } else {
		unset -nocomplain errorInfo
	    }
	    set code [catch {uplevel 1 $args} msg opts]
	    if {$code ==  1} {
		#
		# Compute stack trace contribution from the [uplevel].
		# Note the dependence on how Tcl_AddErrorInfo, etc. 
		# construct the stack trace.
		#
		set errInfo [dict get $opts -errorinfo]
		set errCode [dict get $opts -errorcode]
		set cinfo $args
		if {[string bytelength $cinfo] > 150} {
		    set cinfo [string range $cinfo 0 150]







|







286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
	    } else {
		unset -nocomplain errorInfo
	    }
	    set code [catch {uplevel 1 $args} msg opts]
	    if {$code ==  1} {
		#
		# Compute stack trace contribution from the [uplevel].
		# Note the dependence on how Tcl_AddErrorInfo, etc.
		# construct the stack trace.
		#
		set errInfo [dict get $opts -errorinfo]
		set errCode [dict get $opts -errorcode]
		set cinfo $args
		if {[string bytelength $cinfo] > 150} {
		    set cinfo [string range $cinfo 0 150]
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431

# auto_load --
# Checks a collection of library directories to see if a procedure
# is defined in one of them.  If so, it sources the appropriate
# library file to create the procedure.  Returns 1 if it successfully
# loaded the procedure, 0 otherwise.
#
# Arguments: 
# cmd -			Name of the command to find and load.
# namespace (optional)  The namespace where the command is being used - must be
#                       a canonical namespace as returned [namespace current]
#                       for instance. If not given, namespace current is used.

proc auto_load {cmd {namespace {}}} {
    global auto_index auto_path







|







417
418
419
420
421
422
423
424
425
426
427
428
429
430
431

# auto_load --
# Checks a collection of library directories to see if a procedure
# is defined in one of them.  If so, it sources the appropriate
# library file to create the procedure.  Returns 1 if it successfully
# loaded the procedure, 0 otherwise.
#
# Arguments:
# cmd -			Name of the command to find and load.
# namespace (optional)  The namespace where the command is being used - must be
#                       a canonical namespace as returned [namespace current]
#                       for instance. If not given, namespace current is used.

proc auto_load {cmd {namespace {}}} {
    global auto_index auto_path
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
	if {[info exists auto_index($name)]} {
	    namespace eval :: $auto_index($name)
	    # There's a couple of ways to look for a command of a given
	    # name.  One is to use
	    #    info commands $name
	    # Unfortunately, if the name has glob-magic chars in it like *
	    # or [], it may not match.  For our purposes here, a better
	    # route is to use 
	    #    namespace which -command $name
	    if {[namespace which -command $name] ne ""} {
		return 1
	    }
	}
    }
    if {![info exists auto_path]} {







|







441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
	if {[info exists auto_index($name)]} {
	    namespace eval :: $auto_index($name)
	    # There's a couple of ways to look for a command of a given
	    # name.  One is to use
	    #    info commands $name
	    # Unfortunately, if the name has glob-magic chars in it like *
	    # or [], it may not match.  For our purposes here, a better
	    # route is to use
	    #    namespace which -command $name
	    if {[namespace which -command $name] ne ""} {
		return 1
	    }
	}
    }
    if {![info exists auto_path]} {
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486

# auto_load_index --
# Loads the contents of tclIndex files on the auto_path directory
# list.  This is usually invoked within auto_load to load the index
# of available commands.  Returns 1 if the index is loaded, and 0 if
# the index is already loaded and up to date.
#
# Arguments: 
# None.

proc auto_load_index {} {
    variable ::tcl::auto_oldpath
    global auto_index auto_path

    if {[info exists auto_oldpath] && ($auto_oldpath eq $auto_path)} {







|







472
473
474
475
476
477
478
479
480
481
482
483
484
485
486

# auto_load_index --
# Loads the contents of tclIndex files on the auto_path directory
# list.  This is usually invoked within auto_load to load the index
# of available commands.  Returns 1 if the index is loaded, and 0 if
# the index is already loaded and up to date.
#
# Arguments:
# None.

proc auto_load_index {} {
    variable ::tcl::auto_oldpath
    global auto_index auto_path

    if {[info exists auto_oldpath] && ($auto_oldpath eq $auto_path)} {
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
    set n [regsub -all {::+} $cmd :: cmd]

    # Ignore namespace if the name starts with ::
    # Handle special case of only leading ::

    # Before each return case we give an example of which category it is
    # with the following form :
    # ( inputCmd, inputNameSpace) -> output

    if {[string match ::* $cmd]} {
	if {$n > 1} {
	    # ( ::foo::bar , * ) -> ::foo::bar
	    return [list $cmd]
	} else {
	    # ( ::global , * ) -> global
	    return [list [string range $cmd 2 end]]
	}
    }
    
    # Potentially returning 2 elements to try  :
    # (if the current namespace is not the global one)

    if {$n == 0} {
	if {$namespace eq "::"} {
	    # ( nocolons , :: ) -> nocolons
	    return [list $cmd]
	} else {
	    # ( nocolons , ::sub ) -> ::sub::nocolons nocolons
	    return [list ${namespace}::$cmd $cmd]
	}
    } elseif {$namespace eq "::"} {
	#  ( foo::bar , :: ) -> ::foo::bar
	return [list ::$cmd]
    } else {
	# ( foo::bar , ::sub ) -> ::sub::foo::bar ::foo::bar
	return [list ${namespace}::$cmd ::$cmd]
    }
}

# auto_import --
#
# Invoked during "namespace import" to make see if the imported commands







|



|


|



|





|


|



|


|







551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
    set n [regsub -all {::+} $cmd :: cmd]

    # Ignore namespace if the name starts with ::
    # Handle special case of only leading ::

    # Before each return case we give an example of which category it is
    # with the following form :
    # (inputCmd, inputNameSpace) -> output

    if {[string match ::* $cmd]} {
	if {$n > 1} {
	    # (::foo::bar , *) -> ::foo::bar
	    return [list $cmd]
	} else {
	    # (::global , *) -> global
	    return [list [string range $cmd 2 end]]
	}
    }

    # Potentially returning 2 elements to try  :
    # (if the current namespace is not the global one)

    if {$n == 0} {
	if {$namespace eq "::"} {
	    # (nocolons , ::) -> nocolons
	    return [list $cmd]
	} else {
	    # (nocolons , ::sub) -> ::sub::nocolons nocolons
	    return [list ${namespace}::$cmd $cmd]
	}
    } elseif {$namespace eq "::"} {
	#  (foo::bar , ::) -> ::foo::bar
	return [list ::$cmd]
    } else {
	# (foo::bar , ::sub) -> ::sub::foo::bar ::foo::bar
	return [list ${namespace}::$cmd ::$cmd]
    }
}

# auto_import --
#
# Invoked during "namespace import" to make see if the imported commands
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
            }
        }
    }
}

# auto_execok --
#
# Returns string that indicates name of program to execute if 
# name corresponds to a shell builtin or an executable in the
# Windows search path, or "" otherwise.  Builds an associative 
# array auto_execs that caches information about previous checks, 
# for speed.
#
# Arguments: 
# name -			Name of a command.

if {$tcl_platform(platform) eq "windows"} {
# Windows version.
#
# Note that info executable doesn't work under Windows, so we have to
# look for files with .exe, .com, or .bat extensions.  Also, the path







|

|
|


|







620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
            }
        }
    }
}

# auto_execok --
#
# Returns string that indicates name of program to execute if
# name corresponds to a shell builtin or an executable in the
# Windows search path, or "" otherwise.  Builds an associative
# array auto_execs that caches information about previous checks,
# for speed.
#
# Arguments:
# name -			Name of a command.

if {$tcl_platform(platform) eq "windows"} {
# Windows version.
#
# Note that info executable doesn't work under Windows, so we have to
# look for files with .exe, .com, or .bat extensions.  Also, the path
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
	    }
	}
	return ""
    }

    set path "[file dirname [info nameof]];.;"
    if {[info exists env(WINDIR)]} {
	set windir $env(WINDIR) 
    }
    if {[info exists windir]} {
	if {$tcl_platform(os) eq "Windows NT"} {
	    append path "$windir/system32;"
	}
	append path "$windir/system;$windir;"
    }

    foreach var {PATH Path path} {
	if {[info exists env($var)]} {
	    append path ";$env($var)"
	}
    }

    foreach ext $execExtensions {
	unset -nocomplain checked
	foreach dir [split $path {;}] {
	    # Skip already checked directories
	    if {[info exists checked($dir)] || ($dir eq {})} {
		continue
	    }
	    set checked($dir) {}
	    set file [file join $dir ${name}${ext}]
	    if {[file exists $file] && ![file isdirectory $file]} {
		return [set auto_execs($name) [list $file]]
	    }







|


















|







681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
	    }
	}
	return ""
    }

    set path "[file dirname [info nameof]];.;"
    if {[info exists env(WINDIR)]} {
	set windir $env(WINDIR)
    }
    if {[info exists windir]} {
	if {$tcl_platform(os) eq "Windows NT"} {
	    append path "$windir/system32;"
	}
	append path "$windir/system;$windir;"
    }

    foreach var {PATH Path path} {
	if {[info exists env($var)]} {
	    append path ";$env($var)"
	}
    }

    foreach ext $execExtensions {
	unset -nocomplain checked
	foreach dir [split $path {;}] {
	    # Skip already checked directories
	    if {[info exists checked($dir)] || ($dir eq "")} {
		continue
	    }
	    set checked($dir) {}
	    set file [file join $dir ${name}${ext}]
	    if {[file exists $file] && ![file isdirectory $file]} {
		return [set auto_execs($name) [list $file]]
	    }
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
}

# ::tcl::CopyDirectory --
#
# This procedure is called by Tcl's core when attempts to call the
# filesystem's copydirectory function fail.  The semantics of the call
# are that 'dest' does not yet exist, i.e. dest should become the exact
# image of src.  If dest does exist, we throw an error.  
# 
# Note that making changes to this procedure can change the results
# of running Tcl's tests.
#
# Arguments: 
# action -              "renaming" or "copying" 
# src -			source directory
# dest -		destination directory
proc tcl::CopyDirectory {action src dest} {
    set nsrc [file normalize $src]
    set ndest [file normalize $dest]

    if {$action eq "renaming"} {







|
|



|
|







749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
}

# ::tcl::CopyDirectory --
#
# This procedure is called by Tcl's core when attempts to call the
# filesystem's copydirectory function fail.  The semantics of the call
# are that 'dest' does not yet exist, i.e. dest should become the exact
# image of src.  If dest does exist, we throw an error.
#
# Note that making changes to this procedure can change the results
# of running Tcl's tests.
#
# Arguments:
# action -              "renaming" or "copying"
# src -			source directory
# dest -		destination directory
proc tcl::CopyDirectory {action src dest} {
    set nsrc [file normalize $src]
    set ndest [file normalize $dest]

    if {$action eq "renaming"} {
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
	}
	if {$action eq "copying"} {
	    # We used to throw an error here, but, looking more closely
	    # at the core copy code in tclFCmd.c, if the destination
	    # exists, then we should only call this function if -force
	    # is true, which means we just want to over-write.  So,
	    # the following code is now commented out.
	    # 
	    # return -code error "error $action \"$src\" to\
	    # \"$dest\": file already exists"
	} else {
	    # Depending on the platform, and on the current
	    # working directory, the directories '.', '..'
	    # can be returned in various combinations.  Anyway,
	    # if any other file is returned, we must signal an error.







|







783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
	}
	if {$action eq "copying"} {
	    # We used to throw an error here, but, looking more closely
	    # at the core copy code in tclFCmd.c, if the destination
	    # exists, then we should only call this function if -force
	    # is true, which means we just want to over-write.  So,
	    # the following code is now commented out.
	    #
	    # return -code error "error $action \"$src\" to\
	    # \"$dest\": file already exists"
	} else {
	    # Depending on the platform, and on the current
	    # working directory, the directories '.', '..'
	    # can be returned in various combinations.  Anyway,
	    # if any other file is returned, we must signal an error.
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
	    }
	}
	file mkdir $dest
    }
    # Have to be careful to capture both visible and hidden files.
    # We will also be more generous to the file system and not
    # assume the hidden and non-hidden lists are non-overlapping.
    # 
    # On Unix 'hidden' files begin with '.'.  On other platforms
    # or filesystems hidden files may have other interpretations.
    set filelist [concat [glob -nocomplain -directory $src *] \
      [glob -nocomplain -directory $src -types hidden *]]

    foreach s [lsort -unique $filelist] {
	if {[file tail $s] ni {. ..}} {
	    file copy -force -- $s [file join $dest [file tail $s]]
	}
    }
    return
}







|












816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
	    }
	}
	file mkdir $dest
    }
    # Have to be careful to capture both visible and hidden files.
    # We will also be more generous to the file system and not
    # assume the hidden and non-hidden lists are non-overlapping.
    #
    # On Unix 'hidden' files begin with '.'.  On other platforms
    # or filesystems hidden files may have other interpretations.
    set filelist [concat [glob -nocomplain -directory $src *] \
      [glob -nocomplain -directory $src -types hidden *]]

    foreach s [lsort -unique $filelist] {
	if {[file tail $s] ni {. ..}} {
	    file copy -force -- $s [file join $dest [file tail $s]]
	}
    }
    return
}

Changes to library/tcltest/tcltest.tcl.

2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513



2514
2515
2516
2517
2518
2519
2520

	# restore the environment to the state it was in before this package
	# was loaded

	set newEnv {}
	set changedEnv {}
	set removedEnv {}
	foreach index [array names ::env] {
	    if {[info exists originalEnv($index)]} {
		if {$::env($index) != $originalEnv($index)} {
		    lappend changedEnv $index
		    set ::env($index) $originalEnv($index)
		}
	    }
	}
	foreach index [array names ::env] {
	    if {![info exists originalEnv($index)]} {
		lappend newEnv $index
		unset ::env($index)
	    }
	}
	foreach index [array names originalEnv] {
	    if {![info exists ::env($index)]} {
		lappend removedEnv $index



		set ::env($index) $originalEnv($index)
	    }
	}
	if {[llength $newEnv] > 0} {
	    puts [outputChannel] \
		    "env array elements created:\t$newEnv"
	}







<
<
<
<
<
<
<
<









>
>
>







2490
2491
2492
2493
2494
2495
2496








2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515

	# restore the environment to the state it was in before this package
	# was loaded

	set newEnv {}
	set changedEnv {}
	set removedEnv {}








	foreach index [array names ::env] {
	    if {![info exists originalEnv($index)]} {
		lappend newEnv $index
		unset ::env($index)
	    }
	}
	foreach index [array names originalEnv] {
	    if {![info exists ::env($index)]} {
		lappend removedEnv $index
		set ::env($index) $originalEnv($index)
	    } elseif {$::env($index) ne $originalEnv($index)} {
		lappend changedEnv $index
		set ::env($index) $originalEnv($index)
	    }
	}
	if {[llength $newEnv] > 0} {
	    puts [outputChannel] \
		    "env array elements created:\t$newEnv"
	}