1# init.tcl -- 2# 3# Default system startup file for Tcl-based applications. Defines 4# "unknown" procedure and auto-load facilities. 5# 6# RCS: @(#) $Id: init.tcl,v 1.104.2.15 2010/08/04 17:02:39 dgp Exp $ 7# 8# Copyright (c) 1991-1993 The Regents of the University of California. 9# Copyright (c) 1994-1996 Sun Microsystems, Inc. 10# Copyright (c) 1998-1999 Scriptics Corporation. 11# Copyright (c) 2004 by Kevin B. Kenny. All rights reserved. 12# 13# See the file "license.terms" for information on usage and redistribution 14# of this file, and for a DISCLAIMER OF ALL WARRANTIES. 15# 16 17if {[info commands package] == ""} { 18 error "version mismatch: library\nscripts expect Tcl version 7.5b1 or later but the loaded version is\nonly [info patchlevel]" 19} 20package require -exact Tcl 8.5.9 21 22# Compute the auto path to use in this interpreter. 23# The values on the path come from several locations: 24# 25# The environment variable TCLLIBPATH 26# 27# tcl_library, which is the directory containing this init.tcl script. 28# [tclInit] (Tcl_Init()) searches around for the directory containing this 29# init.tcl and defines tcl_library to that location before sourcing it. 30# 31# The parent directory of tcl_library. Adding the parent 32# means that packages in peer directories will be found automatically. 33# 34# Also add the directory ../lib relative to the directory where the 35# executable is located. This is meant to find binary packages for the 36# same architecture as the current executable. 37# 38# tcl_pkgPath, which is set by the platform-specific initialization routines 39# On UNIX it is compiled in 40# On Windows, it is not used 41 42if {![info exists auto_path]} { 43 if {[info exists env(TCLLIBPATH)]} { 44 set auto_path $env(TCLLIBPATH) 45 } else { 46 set auto_path "" 47 } 48} 49namespace eval tcl { 50 variable Dir 51 foreach Dir [list $::tcl_library [file dirname $::tcl_library]] { 52 if {$Dir ni $::auto_path} { 53 lappend ::auto_path $Dir 54 } 55 } 56 set Dir [file join [file dirname [file dirname \ 57 [info nameofexecutable]]] lib] 58 if {$Dir ni $::auto_path} { 59 lappend ::auto_path $Dir 60 } 61 catch { 62 foreach Dir $::tcl_pkgPath { 63 if {$Dir ni $::auto_path} { 64 lappend ::auto_path $Dir 65 } 66 } 67 } 68 69 if {![interp issafe]} { 70 variable Path [encoding dirs] 71 set Dir [file join $::tcl_library encoding] 72 if {$Dir ni $Path} { 73 lappend Path $Dir 74 encoding dirs $Path 75 } 76 } 77 78 # TIP #255 min and max functions 79 namespace eval mathfunc { 80 proc min {args} { 81 if {[llength $args] == 0} { 82 return -code error \ 83 "too few arguments to math function \"min\"" 84 } 85 set val Inf 86 foreach arg $args { 87 # This will handle forcing the numeric value without 88 # ruining the internal type of a numeric object 89 if {[catch {expr {double($arg)}} err]} { 90 return -code error $err 91 } 92 if {$arg < $val} { set val $arg } 93 } 94 return $val 95 } 96 proc max {args} { 97 if {[llength $args] == 0} { 98 return -code error \ 99 "too few arguments to math function \"max\"" 100 } 101 set val -Inf 102 foreach arg $args { 103 # This will handle forcing the numeric value without 104 # ruining the internal type of a numeric object 105 if {[catch {expr {double($arg)}} err]} { 106 return -code error $err 107 } 108 if {$arg > $val} { set val $arg } 109 } 110 return $val 111 } 112 namespace export min max 113 } 114} 115 116# Windows specific end of initialization 117 118if {(![interp issafe]) && ($tcl_platform(platform) eq "windows")} { 119 namespace eval tcl { 120 proc EnvTraceProc {lo n1 n2 op} { 121 set x $::env($n2) 122 set ::env($lo) $x 123 set ::env([string toupper $lo]) $x 124 } 125 proc InitWinEnv {} { 126 global env tcl_platform 127 foreach p [array names env] { 128 set u [string toupper $p] 129 if {$u ne $p} { 130 switch -- $u { 131 COMSPEC - 132 PATH { 133 if {![info exists env($u)]} { 134 set env($u) $env($p) 135 } 136 trace add variable env($p) write \ 137 [namespace code [list EnvTraceProc $p]] 138 trace add variable env($u) write \ 139 [namespace code [list EnvTraceProc $p]] 140 } 141 } 142 } 143 } 144 if {![info exists env(COMSPEC)]} { 145 if {$tcl_platform(os) eq "Windows NT"} { 146 set env(COMSPEC) cmd.exe 147 } else { 148 set env(COMSPEC) command.com 149 } 150 } 151 } 152 InitWinEnv 153 } 154} 155 156# Setup the unknown package handler 157 158 159if {[interp issafe]} { 160 package unknown {::tcl::tm::UnknownHandler ::tclPkgUnknown} 161} else { 162 # Set up search for Tcl Modules (TIP #189). 163 # and setup platform specific unknown package handlers 164 if {$::tcl_platform(os) eq "Darwin" 165 && $::tcl_platform(platform) eq "unix"} { 166 package unknown {::tcl::tm::UnknownHandler \ 167 {::tcl::MacOSXPkgUnknown ::tclPkgUnknown}} 168 } else { 169 package unknown {::tcl::tm::UnknownHandler ::tclPkgUnknown} 170 } 171 172 # Set up the 'clock' ensemble 173 174 namespace eval ::tcl::clock [list variable TclLibDir $::tcl_library] 175 176 proc clock args { 177 namespace eval ::tcl::clock [list namespace ensemble create -command \ 178 [uplevel 1 [list namespace origin [lindex [info level 0] 0]]] \ 179 -subcommands { 180 add clicks format microseconds milliseconds scan seconds 181 }] 182 183 # Auto-loading stubs for 'clock.tcl' 184 185 foreach cmd {add format scan} { 186 proc ::tcl::clock::$cmd args { 187 variable TclLibDir 188 source -encoding utf-8 [file join $TclLibDir clock.tcl] 189 return [uplevel 1 [info level 0]] 190 } 191 } 192 193 return [uplevel 1 [info level 0]] 194 } 195} 196 197# Conditionalize for presence of exec. 198 199if {[namespace which -command exec] eq ""} { 200 201 # Some machines do not have exec. Also, on all 202 # platforms, safe interpreters do not have exec. 203 204 set auto_noexec 1 205} 206 207# Define a log command (which can be overwitten to log errors 208# differently, specially when stderr is not available) 209 210if {[namespace which -command tclLog] eq ""} { 211 proc tclLog {string} { 212 catch {puts stderr $string} 213 } 214} 215 216# unknown -- 217# This procedure is called when a Tcl command is invoked that doesn't 218# exist in the interpreter. It takes the following steps to make the 219# command available: 220# 221# 1. See if the command has the form "namespace inscope ns cmd" and 222# if so, concatenate its arguments onto the end and evaluate it. 223# 2. See if the autoload facility can locate the command in a 224# Tcl script file. If so, load it and execute it. 225# 3. If the command was invoked interactively at top-level: 226# (a) see if the command exists as an executable UNIX program. 227# If so, "exec" the command. 228# (b) see if the command requests csh-like history substitution 229# in one of the common forms !!, !<number>, or ^old^new. If 230# so, emulate csh's history substitution. 231# (c) see if the command is a unique abbreviation for another 232# command. If so, invoke the command. 233# 234# Arguments: 235# args - A list whose elements are the words of the original 236# command, including the command name. 237 238proc unknown args { 239 variable ::tcl::UnknownPending 240 global auto_noexec auto_noload env tcl_interactive 241 242 # If the command word has the form "namespace inscope ns cmd" 243 # then concatenate its arguments onto the end and evaluate it. 244 245 set cmd [lindex $args 0] 246 if {[regexp "^:*namespace\[ \t\n\]+inscope" $cmd] && [llength $cmd] == 4} { 247 #return -code error "You need an {*}" 248 set arglist [lrange $args 1 end] 249 set ret [catch {uplevel 1 ::$cmd $arglist} result opts] 250 dict unset opts -errorinfo 251 dict incr opts -level 252 return -options $opts $result 253 } 254 255 catch {set savedErrorInfo $::errorInfo} 256 catch {set savedErrorCode $::errorCode} 257 set name $cmd 258 if {![info exists auto_noload]} { 259 # 260 # Make sure we're not trying to load the same proc twice. 261 # 262 if {[info exists UnknownPending($name)]} { 263 return -code error "self-referential recursion\ 264 in \"unknown\" for command \"$name\""; 265 } 266 set UnknownPending($name) pending; 267 set ret [catch { 268 auto_load $name [uplevel 1 {::namespace current}] 269 } msg opts] 270 unset UnknownPending($name); 271 if {$ret != 0} { 272 dict append opts -errorinfo "\n (autoloading \"$name\")" 273 return -options $opts $msg 274 } 275 if {![array size UnknownPending]} { 276 unset UnknownPending 277 } 278 if {$msg} { 279 if {[info exists savedErrorCode]} { 280 set ::errorCode $savedErrorCode 281 } else { 282 unset -nocomplain ::errorCode 283 } 284 if {[info exists savedErrorInfo]} { 285 set ::errorInfo $savedErrorInfo 286 } else { 287 unset -nocomplain ::errorInfo 288 } 289 set code [catch {uplevel 1 $args} msg opts] 290 if {$code == 1} { 291 # 292 # Compute stack trace contribution from the [uplevel]. 293 # Note the dependence on how Tcl_AddErrorInfo, etc. 294 # construct the stack trace. 295 # 296 set errorInfo [dict get $opts -errorinfo] 297 set errorCode [dict get $opts -errorcode] 298 set cinfo $args 299 if {[string bytelength $cinfo] > 150} { 300 set cinfo [string range $cinfo 0 150] 301 while {[string bytelength $cinfo] > 150} { 302 set cinfo [string range $cinfo 0 end-1] 303 } 304 append cinfo ... 305 } 306 append cinfo "\"\n (\"uplevel\" body line 1)" 307 append cinfo "\n invoked from within" 308 append cinfo "\n\"uplevel 1 \$args\"" 309 # 310 # Try each possible form of the stack trace 311 # and trim the extra contribution from the matching case 312 # 313 set expect "$msg\n while executing\n\"$cinfo" 314 if {$errorInfo eq $expect} { 315 # 316 # The stack has only the eval from the expanded command 317 # Do not generate any stack trace here. 318 # 319 dict unset opts -errorinfo 320 dict incr opts -level 321 return -options $opts $msg 322 } 323 # 324 # Stack trace is nested, trim off just the contribution 325 # from the extra "eval" of $args due to the "catch" above. 326 # 327 set expect "\n invoked from within\n\"$cinfo" 328 set exlen [string length $expect] 329 set eilen [string length $errorInfo] 330 set i [expr {$eilen - $exlen - 1}] 331 set einfo [string range $errorInfo 0 $i] 332 # 333 # For now verify that $errorInfo consists of what we are about 334 # to return plus what we expected to trim off. 335 # 336 if {$errorInfo ne "$einfo$expect"} { 337 error "Tcl bug: unexpected stack trace in \"unknown\"" {} \ 338 [list CORE UNKNOWN BADTRACE $einfo $expect $errorInfo] 339 } 340 return -code error -errorcode $errorCode \ 341 -errorinfo $einfo $msg 342 } else { 343 dict incr opts -level 344 return -options $opts $msg 345 } 346 } 347 } 348 349 if {([info level] == 1) && ([info script] eq "") \ 350 && [info exists tcl_interactive] && $tcl_interactive} { 351 if {![info exists auto_noexec]} { 352 set new [auto_execok $name] 353 if {$new ne ""} { 354 set redir "" 355 if {[namespace which -command console] eq ""} { 356 set redir ">&@stdout <@stdin" 357 } 358 uplevel 1 [list ::catch \ 359 [concat exec $redir $new [lrange $args 1 end]] \ 360 ::tcl::UnknownResult ::tcl::UnknownOptions] 361 dict incr ::tcl::UnknownOptions -level 362 return -options $::tcl::UnknownOptions $::tcl::UnknownResult 363 } 364 } 365 if {$name eq "!!"} { 366 set newcmd [history event] 367 } elseif {[regexp {^!(.+)$} $name -> event]} { 368 set newcmd [history event $event] 369 } elseif {[regexp {^\^([^^]*)\^([^^]*)\^?$} $name -> old new]} { 370 set newcmd [history event -1] 371 catch {regsub -all -- $old $newcmd $new newcmd} 372 } 373 if {[info exists newcmd]} { 374 tclLog $newcmd 375 history change $newcmd 0 376 uplevel 1 [list ::catch $newcmd \ 377 ::tcl::UnknownResult ::tcl::UnknownOptions] 378 dict incr ::tcl::UnknownOptions -level 379 return -options $::tcl::UnknownOptions $::tcl::UnknownResult 380 } 381 382 set ret [catch {set candidates [info commands $name*]} msg] 383 if {$name eq "::"} { 384 set name "" 385 } 386 if {$ret != 0} { 387 dict append opts -errorinfo \ 388 "\n (expanding command prefix \"$name\" in unknown)" 389 return -options $opts $msg 390 } 391 # Filter out bogus matches when $name contained 392 # a glob-special char [Bug 946952] 393 if {$name eq ""} { 394 # Handle empty $name separately due to strangeness 395 # in [string first] (See RFE 1243354) 396 set cmds $candidates 397 } else { 398 set cmds [list] 399 foreach x $candidates { 400 if {[string first $name $x] == 0} { 401 lappend cmds $x 402 } 403 } 404 } 405 if {[llength $cmds] == 1} { 406 uplevel 1 [list ::catch [lreplace $args 0 0 [lindex $cmds 0]] \ 407 ::tcl::UnknownResult ::tcl::UnknownOptions] 408 dict incr ::tcl::UnknownOptions -level 409 return -options $::tcl::UnknownOptions $::tcl::UnknownResult 410 } 411 if {[llength $cmds]} { 412 return -code error "ambiguous command name \"$name\": [lsort $cmds]" 413 } 414 } 415 return -code error "invalid command name \"$name\"" 416} 417 418# auto_load -- 419# Checks a collection of library directories to see if a procedure 420# is defined in one of them. If so, it sources the appropriate 421# library file to create the procedure. Returns 1 if it successfully 422# loaded the procedure, 0 otherwise. 423# 424# Arguments: 425# cmd - Name of the command to find and load. 426# namespace (optional) The namespace where the command is being used - must be 427# a canonical namespace as returned [namespace current] 428# for instance. If not given, namespace current is used. 429 430proc auto_load {cmd {namespace {}}} { 431 global auto_index auto_path 432 433 if {$namespace eq ""} { 434 set namespace [uplevel 1 [list ::namespace current]] 435 } 436 set nameList [auto_qualify $cmd $namespace] 437 # workaround non canonical auto_index entries that might be around 438 # from older auto_mkindex versions 439 lappend nameList $cmd 440 foreach name $nameList { 441 if {[info exists auto_index($name)]} { 442 namespace eval :: $auto_index($name) 443 # There's a couple of ways to look for a command of a given 444 # name. One is to use 445 # info commands $name 446 # Unfortunately, if the name has glob-magic chars in it like * 447 # or [], it may not match. For our purposes here, a better 448 # route is to use 449 # namespace which -command $name 450 if {[namespace which -command $name] ne ""} { 451 return 1 452 } 453 } 454 } 455 if {![info exists auto_path]} { 456 return 0 457 } 458 459 if {![auto_load_index]} { 460 return 0 461 } 462 foreach name $nameList { 463 if {[info exists auto_index($name)]} { 464 namespace eval :: $auto_index($name) 465 if {[namespace which -command $name] ne ""} { 466 return 1 467 } 468 } 469 } 470 return 0 471} 472 473# auto_load_index -- 474# Loads the contents of tclIndex files on the auto_path directory 475# list. This is usually invoked within auto_load to load the index 476# of available commands. Returns 1 if the index is loaded, and 0 if 477# the index is already loaded and up to date. 478# 479# Arguments: 480# None. 481 482proc auto_load_index {} { 483 variable ::tcl::auto_oldpath 484 global auto_index auto_path 485 486 if {[info exists auto_oldpath] && ($auto_oldpath eq $auto_path)} { 487 return 0 488 } 489 set auto_oldpath $auto_path 490 491 # Check if we are a safe interpreter. In that case, we support only 492 # newer format tclIndex files. 493 494 set issafe [interp issafe] 495 for {set i [expr {[llength $auto_path] - 1}]} {$i >= 0} {incr i -1} { 496 set dir [lindex $auto_path $i] 497 set f "" 498 if {$issafe} { 499 catch {source [file join $dir tclIndex]} 500 } elseif {[catch {set f [open [file join $dir tclIndex]]}]} { 501 continue 502 } else { 503 set error [catch { 504 set id [gets $f] 505 if {$id eq "# Tcl autoload index file, version 2.0"} { 506 eval [read $f] 507 } elseif {$id eq "# Tcl autoload index file: each line identifies a Tcl"} { 508 while {[gets $f line] >= 0} { 509 if {([string index $line 0] eq "#") \ 510 || ([llength $line] != 2)} { 511 continue 512 } 513 set name [lindex $line 0] 514 set auto_index($name) \ 515 "source [file join $dir [lindex $line 1]]" 516 } 517 } else { 518 error "[file join $dir tclIndex] isn't a proper Tcl index file" 519 } 520 } msg opts] 521 if {$f ne ""} { 522 close $f 523 } 524 if {$error} { 525 return -options $opts $msg 526 } 527 } 528 } 529 return 1 530} 531 532# auto_qualify -- 533# 534# Compute a fully qualified names list for use in the auto_index array. 535# For historical reasons, commands in the global namespace do not have leading 536# :: in the index key. The list has two elements when the command name is 537# relative (no leading ::) and the namespace is not the global one. Otherwise 538# only one name is returned (and searched in the auto_index). 539# 540# Arguments - 541# cmd The command name. Can be any name accepted for command 542# invocations (Like "foo::::bar"). 543# namespace The namespace where the command is being used - must be 544# a canonical namespace as returned by [namespace current] 545# for instance. 546 547proc auto_qualify {cmd namespace} { 548 549 # count separators and clean them up 550 # (making sure that foo:::::bar will be treated as foo::bar) 551 set n [regsub -all {::+} $cmd :: cmd] 552 553 # Ignore namespace if the name starts with :: 554 # Handle special case of only leading :: 555 556 # Before each return case we give an example of which category it is 557 # with the following form : 558 # ( inputCmd, inputNameSpace) -> output 559 560 if {[string match ::* $cmd]} { 561 if {$n > 1} { 562 # ( ::foo::bar , * ) -> ::foo::bar 563 return [list $cmd] 564 } else { 565 # ( ::global , * ) -> global 566 return [list [string range $cmd 2 end]] 567 } 568 } 569 570 # Potentially returning 2 elements to try : 571 # (if the current namespace is not the global one) 572 573 if {$n == 0} { 574 if {$namespace eq "::"} { 575 # ( nocolons , :: ) -> nocolons 576 return [list $cmd] 577 } else { 578 # ( nocolons , ::sub ) -> ::sub::nocolons nocolons 579 return [list ${namespace}::$cmd $cmd] 580 } 581 } elseif {$namespace eq "::"} { 582 # ( foo::bar , :: ) -> ::foo::bar 583 return [list ::$cmd] 584 } else { 585 # ( foo::bar , ::sub ) -> ::sub::foo::bar ::foo::bar 586 return [list ${namespace}::$cmd ::$cmd] 587 } 588} 589 590# auto_import -- 591# 592# Invoked during "namespace import" to make see if the imported commands 593# reside in an autoloaded library. If so, the commands are loaded so 594# that they will be available for the import links. If not, then this 595# procedure does nothing. 596# 597# Arguments - 598# pattern The pattern of commands being imported (like "foo::*") 599# a canonical namespace as returned by [namespace current] 600 601proc auto_import {pattern} { 602 global auto_index 603 604 # If no namespace is specified, this will be an error case 605 606 if {![string match *::* $pattern]} { 607 return 608 } 609 610 set ns [uplevel 1 [list ::namespace current]] 611 set patternList [auto_qualify $pattern $ns] 612 613 auto_load_index 614 615 foreach pattern $patternList { 616 foreach name [array names auto_index $pattern] { 617 if {([namespace which -command $name] eq "") 618 && ([namespace qualifiers $pattern] eq [namespace qualifiers $name])} { 619 namespace eval :: $auto_index($name) 620 } 621 } 622 } 623} 624 625# auto_execok -- 626# 627# Returns string that indicates name of program to execute if 628# name corresponds to a shell builtin or an executable in the 629# Windows search path, or "" otherwise. Builds an associative 630# array auto_execs that caches information about previous checks, 631# for speed. 632# 633# Arguments: 634# name - Name of a command. 635 636if {$tcl_platform(platform) eq "windows"} { 637# Windows version. 638# 639# Note that info executable doesn't work under Windows, so we have to 640# look for files with .exe, .com, or .bat extensions. Also, the path 641# may be in the Path or PATH environment variables, and path 642# components are separated with semicolons, not colons as under Unix. 643# 644proc auto_execok name { 645 global auto_execs env tcl_platform 646 647 if {[info exists auto_execs($name)]} { 648 return $auto_execs($name) 649 } 650 set auto_execs($name) "" 651 652 set shellBuiltins [list cls copy date del erase dir echo mkdir \ 653 md rename ren rmdir rd time type ver vol] 654 if {$tcl_platform(os) eq "Windows NT"} { 655 # NT includes the 'start' built-in 656 lappend shellBuiltins "start" 657 } 658 if {[info exists env(PATHEXT)]} { 659 # Add an initial ; to have the {} extension check first. 660 set execExtensions [split ";$env(PATHEXT)" ";"] 661 } else { 662 set execExtensions [list {} .com .exe .bat .cmd] 663 } 664 665 if {$name in $shellBuiltins} { 666 # When this is command.com for some reason on Win2K, Tcl won't 667 # exec it unless the case is right, which this corrects. COMSPEC 668 # may not point to a real file, so do the check. 669 set cmd $env(COMSPEC) 670 if {[file exists $cmd]} { 671 set cmd [file attributes $cmd -shortname] 672 } 673 return [set auto_execs($name) [list $cmd /c $name]] 674 } 675 676 if {[llength [file split $name]] != 1} { 677 foreach ext $execExtensions { 678 set file ${name}${ext} 679 if {[file exists $file] && ![file isdirectory $file]} { 680 return [set auto_execs($name) [list $file]] 681 } 682 } 683 return "" 684 } 685 686 set path "[file dirname [info nameof]];.;" 687 if {[info exists env(WINDIR)]} { 688 set windir $env(WINDIR) 689 } 690 if {[info exists windir]} { 691 if {$tcl_platform(os) eq "Windows NT"} { 692 append path "$windir/system32;" 693 } 694 append path "$windir/system;$windir;" 695 } 696 697 foreach var {PATH Path path} { 698 if {[info exists env($var)]} { 699 append path ";$env($var)" 700 } 701 } 702 703 foreach dir [split $path {;}] { 704 # Skip already checked directories 705 if {[info exists checked($dir)] || ($dir eq {})} { continue } 706 set checked($dir) {} 707 foreach ext $execExtensions { 708 set file [file join $dir ${name}${ext}] 709 if {[file exists $file] && ![file isdirectory $file]} { 710 return [set auto_execs($name) [list $file]] 711 } 712 } 713 } 714 return "" 715} 716 717} else { 718# Unix version. 719# 720proc auto_execok name { 721 global auto_execs env 722 723 if {[info exists auto_execs($name)]} { 724 return $auto_execs($name) 725 } 726 set auto_execs($name) "" 727 if {[llength [file split $name]] != 1} { 728 if {[file executable $name] && ![file isdirectory $name]} { 729 set auto_execs($name) [list $name] 730 } 731 return $auto_execs($name) 732 } 733 foreach dir [split $env(PATH) :] { 734 if {$dir eq ""} { 735 set dir . 736 } 737 set file [file join $dir $name] 738 if {[file executable $file] && ![file isdirectory $file]} { 739 set auto_execs($name) [list $file] 740 return $auto_execs($name) 741 } 742 } 743 return "" 744} 745 746} 747 748# ::tcl::CopyDirectory -- 749# 750# This procedure is called by Tcl's core when attempts to call the 751# filesystem's copydirectory function fail. The semantics of the call 752# are that 'dest' does not yet exist, i.e. dest should become the exact 753# image of src. If dest does exist, we throw an error. 754# 755# Note that making changes to this procedure can change the results 756# of running Tcl's tests. 757# 758# Arguments: 759# action - "renaming" or "copying" 760# src - source directory 761# dest - destination directory 762proc tcl::CopyDirectory {action src dest} { 763 set nsrc [file normalize $src] 764 set ndest [file normalize $dest] 765 766 if {$action eq "renaming"} { 767 # Can't rename volumes. We could give a more precise 768 # error message here, but that would break the test suite. 769 if {$nsrc in [file volumes]} { 770 return -code error "error $action \"$src\" to\ 771 \"$dest\": trying to rename a volume or move a directory\ 772 into itself" 773 } 774 } 775 if {[file exists $dest]} { 776 if {$nsrc eq $ndest} { 777 return -code error "error $action \"$src\" to\ 778 \"$dest\": trying to rename a volume or move a directory\ 779 into itself" 780 } 781 if {$action eq "copying"} { 782 # We used to throw an error here, but, looking more closely 783 # at the core copy code in tclFCmd.c, if the destination 784 # exists, then we should only call this function if -force 785 # is true, which means we just want to over-write. So, 786 # the following code is now commented out. 787 # 788 # return -code error "error $action \"$src\" to\ 789 # \"$dest\": file already exists" 790 } else { 791 # Depending on the platform, and on the current 792 # working directory, the directories '.', '..' 793 # can be returned in various combinations. Anyway, 794 # if any other file is returned, we must signal an error. 795 set existing [glob -nocomplain -directory $dest * .*] 796 lappend existing {*}[glob -nocomplain -directory $dest \ 797 -type hidden * .*] 798 foreach s $existing { 799 if {([file tail $s] ne ".") && ([file tail $s] ne "..")} { 800 return -code error "error $action \"$src\" to\ 801 \"$dest\": file already exists" 802 } 803 } 804 } 805 } else { 806 if {[string first $nsrc $ndest] != -1} { 807 set srclen [expr {[llength [file split $nsrc]] -1}] 808 set ndest [lindex [file split $ndest] $srclen] 809 if {$ndest eq [file tail $nsrc]} { 810 return -code error "error $action \"$src\" to\ 811 \"$dest\": trying to rename a volume or move a directory\ 812 into itself" 813 } 814 } 815 file mkdir $dest 816 } 817 # Have to be careful to capture both visible and hidden files. 818 # We will also be more generous to the file system and not 819 # assume the hidden and non-hidden lists are non-overlapping. 820 # 821 # On Unix 'hidden' files begin with '.'. On other platforms 822 # or filesystems hidden files may have other interpretations. 823 set filelist [concat [glob -nocomplain -directory $src *] \ 824 [glob -nocomplain -directory $src -types hidden *]] 825 826 foreach s [lsort -unique $filelist] { 827 if {([file tail $s] ne ".") && ([file tail $s] ne "..")} { 828 file copy -force $s [file join $dest [file tail $s]] 829 } 830 } 831 return 832} 833