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: |
26c40ac3053dd42a700f85eba1bdb0a3 |
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
Changes to library/init.tcl.
︙ | ︙ | |||
73 74 75 76 77 78 79 | encoding dirs $Path } } # TIP #255 min and max functions namespace eval mathfunc { proc min {args} { | | | | | | 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 | global env tcl_platform foreach p [array names env] { set u [string toupper $p] if {$u ne $p} { switch -- $u { COMSPEC - PATH { | > | | < | 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 | 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 }] | | | | 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 | 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\ | | | | | 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 | } else { unset -nocomplain errorInfo } set code [catch {uplevel 1 $args} msg opts] if {$code == 1} { # # Compute stack trace contribution from the [uplevel]. | | | 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 | # 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. # | | | 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 | 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 | | | 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 | # 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. # | | | 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 | 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 : | | | | | | | | | | 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 | } } } } # auto_execok -- # | | | | | | 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 | } } return "" } set path "[file dirname [info nameof]];.;" if {[info exists env(WINDIR)]} { | | | | 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 | } # ::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 | | | | | | 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 | } 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. | | | 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 | } } 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. | | | 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 | # restore the environment to the state it was in before this package # was loaded set newEnv {} set changedEnv {} set removedEnv {} | < < < < < < < < > > > | 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" } |
︙ | ︙ |