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