home *** CD-ROM | disk | FTP | other *** search
/ Chip 2007 November / CPNL0711.ISO / beeld / teken / scribus-1.3.3.9-win32-install.exe / tcl / tcl8.4 / init.tcl < prev    next >
Text File  |  2004-05-03  |  23KB  |  739 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.2.3 2004/05/03 14:28:59 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. #
  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.         set ellipsis ""
  224.         while {[string bytelength $cinfo] > 150} {
  225.             set cinfo [string range $cinfo 0 end-1]
  226.             set ellipsis "..."
  227.         }
  228.         append cinfo $ellipsis "\"\n    (\"uplevel\" body line 1)"
  229.         append cinfo "\n    invoked from within"
  230.         append cinfo "\n\"uplevel 1 \$args\""
  231.         #
  232.         # Try each possible form of the stack trace
  233.         # and trim the extra contribution from the matching case
  234.         #
  235.         set expect "$msg\n    while executing\n\"$cinfo"
  236.         if {$errorInfo eq $expect} {
  237.             #
  238.             # The stack has only the eval from the expanded command
  239.             # Do not generate any stack trace here.
  240.             #
  241.             return -code error -errorcode $errorCode $msg
  242.         }
  243.         #
  244.         # Stack trace is nested, trim off just the contribution
  245.         # from the extra "eval" of $args due to the "catch" above.
  246.         #
  247.         set expect "\n    invoked from within\n\"$cinfo"
  248.         set exlen [string length $expect]
  249.         set eilen [string length $errorInfo]
  250.         set i [expr {$eilen - $exlen - 1}]
  251.         set einfo [string range $errorInfo 0 $i]
  252.         #
  253.         # For now verify that $errorInfo consists of what we are about
  254.         # to return plus what we expected to trim off.
  255.         #
  256.         if {$errorInfo ne "$einfo$expect"} {
  257.             error "Tcl bug: unexpected stack trace in \"unknown\"" {} \
  258.             [list CORE UNKNOWN BADTRACE $expect $errorInfo]
  259.         }
  260.         return -code error -errorcode $errorCode \
  261.             -errorinfo $einfo $msg
  262.         } else {
  263.         return -code $code $msg
  264.         }
  265.     }
  266.     }
  267.  
  268.     if {([info level] == 1) && [string equal [info script] ""] \
  269.         && [info exists tcl_interactive] && $tcl_interactive} {
  270.     if {![info exists auto_noexec]} {
  271.         set new [auto_execok $name]
  272.         if {$new != ""} {
  273.         set errorCode $savedErrorCode
  274.         set errorInfo $savedErrorInfo
  275.         set redir ""
  276.         if {[string equal [info commands console] ""]} {
  277.             set redir ">&@stdout <@stdin"
  278.         }
  279.         return [uplevel 1 exec $redir $new [lrange $args 1 end]]
  280.         }
  281.     }
  282.     set errorCode $savedErrorCode
  283.     set errorInfo $savedErrorInfo
  284.     if {[string equal $name "!!"]} {
  285.         set newcmd [history event]
  286.     } elseif {[regexp {^!(.+)$} $name dummy event]} {
  287.         set newcmd [history event $event]
  288.     } elseif {[regexp {^\^([^^]*)\^([^^]*)\^?$} $name dummy old new]} {
  289.         set newcmd [history event -1]
  290.         catch {regsub -all -- $old $newcmd $new newcmd}
  291.     }
  292.     if {[info exists newcmd]} {
  293.         tclLog $newcmd
  294.         history change $newcmd 0
  295.         return [uplevel 1 $newcmd]
  296.     }
  297.  
  298.     set ret [catch {set candidates [info commands $name*]} msg]
  299.     if {[string equal $name "::"]} {
  300.         set name ""
  301.     }
  302.     if {$ret != 0} {
  303.         return -code $ret -errorcode $errorCode \
  304.         "error in unknown while checking if \"$name\" is\
  305.         a unique command abbreviation:\n$msg"
  306.     }
  307.     # Filter out bogus matches when $name contained
  308.     # a glob-special char [Bug 946952]
  309.     set cmds [list]
  310.     foreach x $candidates {
  311.         if {[string range $x 0 [expr [string length $name]-1]] eq $name} {
  312.         lappend cmds $x
  313.         }
  314.     }
  315.     if {[llength $cmds] == 1} {
  316.         return [uplevel 1 [lreplace $args 0 0 $cmds]]
  317.     }
  318.     if {[llength $cmds]} {
  319.         if {[string equal $name ""]} {
  320.         return -code error "empty command name \"\""
  321.         } else {
  322.         return -code error \
  323.             "ambiguous command name \"$name\": [lsort $cmds]"
  324.         }
  325.     }
  326.     }
  327.     return -code error "invalid command name \"$name\""
  328. }
  329.  
  330. # auto_load --
  331. # Checks a collection of library directories to see if a procedure
  332. # is defined in one of them.  If so, it sources the appropriate
  333. # library file to create the procedure.  Returns 1 if it successfully
  334. # loaded the procedure, 0 otherwise.
  335. #
  336. # Arguments: 
  337. # cmd -            Name of the command to find and load.
  338. # namespace (optional)  The namespace where the command is being used - must be
  339. #                       a canonical namespace as returned [namespace current]
  340. #                       for instance. If not given, namespace current is used.
  341.  
  342. proc auto_load {cmd {namespace {}}} {
  343.     global auto_index auto_oldpath auto_path
  344.  
  345.     if {[string length $namespace] == 0} {
  346.     set namespace [uplevel 1 [list ::namespace current]]
  347.     }
  348.     set nameList [auto_qualify $cmd $namespace]
  349.     # workaround non canonical auto_index entries that might be around
  350.     # from older auto_mkindex versions
  351.     lappend nameList $cmd
  352.     foreach name $nameList {
  353.     if {[info exists auto_index($name)]} {
  354.         namespace eval :: $auto_index($name)
  355.         # There's a couple of ways to look for a command of a given
  356.         # name.  One is to use
  357.         #    info commands $name
  358.         # Unfortunately, if the name has glob-magic chars in it like *
  359.         # or [], it may not match.  For our purposes here, a better
  360.         # route is to use 
  361.         #    namespace which -command $name
  362.         if {[namespace which -command $name] ne ""} {
  363.         return 1
  364.         }
  365.     }
  366.     }
  367.     if {![info exists auto_path]} {
  368.     return 0
  369.     }
  370.  
  371.     if {![auto_load_index]} {
  372.     return 0
  373.     }
  374.     foreach name $nameList {
  375.     if {[info exists auto_index($name)]} {
  376.         namespace eval :: $auto_index($name)
  377.         if {[namespace which -command $name] ne ""} {
  378.         return 1
  379.         }
  380.     }
  381.     }
  382.     return 0
  383. }
  384.  
  385. # auto_load_index --
  386. # Loads the contents of tclIndex files on the auto_path directory
  387. # list.  This is usually invoked within auto_load to load the index
  388. # of available commands.  Returns 1 if the index is loaded, and 0 if
  389. # the index is already loaded and up to date.
  390. #
  391. # Arguments: 
  392. # None.
  393.  
  394. proc auto_load_index {} {
  395.     global auto_index auto_oldpath auto_path errorInfo errorCode
  396.  
  397.     if {[info exists auto_oldpath] && \
  398.         [string equal $auto_oldpath $auto_path]} {
  399.     return 0
  400.     }
  401.     set auto_oldpath $auto_path
  402.  
  403.     # Check if we are a safe interpreter. In that case, we support only
  404.     # newer format tclIndex files.
  405.  
  406.     set issafe [interp issafe]
  407.     for {set i [expr {[llength $auto_path] - 1}]} {$i >= 0} {incr i -1} {
  408.     set dir [lindex $auto_path $i]
  409.     set f ""
  410.     if {$issafe} {
  411.         catch {source [file join $dir tclIndex]}
  412.     } elseif {[catch {set f [open [file join $dir tclIndex]]}]} {
  413.         continue
  414.     } else {
  415.         set error [catch {
  416.         set id [gets $f]
  417.         if {[string equal $id \
  418.             "# Tcl autoload index file, version 2.0"]} {
  419.             eval [read $f]
  420.         } elseif {[string equal $id "# Tcl autoload index file: each line identifies a Tcl"]} {
  421.             while {[gets $f line] >= 0} {
  422.             if {[string equal [string index $line 0] "#"] \
  423.                 || ([llength $line] != 2)} {
  424.                 continue
  425.             }
  426.             set name [lindex $line 0]
  427.             set auto_index($name) \
  428.                 "source [file join $dir [lindex $line 1]]"
  429.             }
  430.         } else {
  431.             error "[file join $dir tclIndex] isn't a proper Tcl index file"
  432.         }
  433.         } msg]
  434.         if {$f != ""} {
  435.         close $f
  436.         }
  437.         if {$error} {
  438.         error $msg $errorInfo $errorCode
  439.         }
  440.     }
  441.     }
  442.     return 1
  443. }
  444.  
  445. # auto_qualify --
  446. #
  447. # Compute a fully qualified names list for use in the auto_index array.
  448. # For historical reasons, commands in the global namespace do not have leading
  449. # :: in the index key. The list has two elements when the command name is
  450. # relative (no leading ::) and the namespace is not the global one. Otherwise
  451. # only one name is returned (and searched in the auto_index).
  452. #
  453. # Arguments -
  454. # cmd        The command name. Can be any name accepted for command
  455. #               invocations (Like "foo::::bar").
  456. # namespace    The namespace where the command is being used - must be
  457. #               a canonical namespace as returned by [namespace current]
  458. #               for instance.
  459.  
  460. proc auto_qualify {cmd namespace} {
  461.  
  462.     # count separators and clean them up
  463.     # (making sure that foo:::::bar will be treated as foo::bar)
  464.     set n [regsub -all {::+} $cmd :: cmd]
  465.  
  466.     # Ignore namespace if the name starts with ::
  467.     # Handle special case of only leading ::
  468.  
  469.     # Before each return case we give an example of which category it is
  470.     # with the following form :
  471.     # ( inputCmd, inputNameSpace) -> output
  472.  
  473.     if {[regexp {^::(.*)$} $cmd x tail]} {
  474.     if {$n > 1} {
  475.         # ( ::foo::bar , * ) -> ::foo::bar
  476.         return [list $cmd]
  477.     } else {
  478.         # ( ::global , * ) -> global
  479.         return [list $tail]
  480.     }
  481.     }
  482.     
  483.     # Potentially returning 2 elements to try  :
  484.     # (if the current namespace is not the global one)
  485.  
  486.     if {$n == 0} {
  487.     if {[string equal $namespace ::]} {
  488.         # ( nocolons , :: ) -> nocolons
  489.         return [list $cmd]
  490.     } else {
  491.         # ( nocolons , ::sub ) -> ::sub::nocolons nocolons
  492.         return [list ${namespace}::$cmd $cmd]
  493.     }
  494.     } elseif {[string equal $namespace ::]} {
  495.     #  ( foo::bar , :: ) -> ::foo::bar
  496.     return [list ::$cmd]
  497.     } else {
  498.     # ( foo::bar , ::sub ) -> ::sub::foo::bar ::foo::bar
  499.     return [list ${namespace}::$cmd ::$cmd]
  500.     }
  501. }
  502.  
  503. # auto_import --
  504. #
  505. # Invoked during "namespace import" to make see if the imported commands
  506. # reside in an autoloaded library.  If so, the commands are loaded so
  507. # that they will be available for the import links.  If not, then this
  508. # procedure does nothing.
  509. #
  510. # Arguments -
  511. # pattern    The pattern of commands being imported (like "foo::*")
  512. #               a canonical namespace as returned by [namespace current]
  513.  
  514. proc auto_import {pattern} {
  515.     global auto_index
  516.  
  517.     # If no namespace is specified, this will be an error case
  518.  
  519.     if {![string match *::* $pattern]} {
  520.     return
  521.     }
  522.  
  523.     set ns [uplevel 1 [list ::namespace current]]
  524.     set patternList [auto_qualify $pattern $ns]
  525.  
  526.     auto_load_index
  527.  
  528.     foreach pattern $patternList {
  529.         foreach name [array names auto_index $pattern] {
  530.             if {([namespace which -command $name] eq "")
  531.             && ([namespace qualifiers $pattern] eq [namespace qualifiers $name])} {
  532.                 namespace eval :: $auto_index($name)
  533.             }
  534.         }
  535.     }
  536. }
  537.  
  538. # auto_execok --
  539. #
  540. # Returns string that indicates name of program to execute if 
  541. # name corresponds to a shell builtin or an executable in the
  542. # Windows search path, or "" otherwise.  Builds an associative 
  543. # array auto_execs that caches information about previous checks, 
  544. # for speed.
  545. #
  546. # Arguments: 
  547. # name -            Name of a command.
  548.  
  549. if {[string equal windows $tcl_platform(platform)]} {
  550. # Windows version.
  551. #
  552. # Note that info executable doesn't work under Windows, so we have to
  553. # look for files with .exe, .com, or .bat extensions.  Also, the path
  554. # may be in the Path or PATH environment variables, and path
  555. # components are separated with semicolons, not colons as under Unix.
  556. #
  557. proc auto_execok name {
  558.     global auto_execs env tcl_platform
  559.  
  560.     if {[info exists auto_execs($name)]} {
  561.     return $auto_execs($name)
  562.     }
  563.     set auto_execs($name) ""
  564.  
  565.     set shellBuiltins [list cls copy date del erase dir echo mkdir \
  566.         md rename ren rmdir rd time type ver vol]
  567.     if {[string equal $tcl_platform(os) "Windows NT"]} {
  568.     # NT includes the 'start' built-in
  569.     lappend shellBuiltins "start"
  570.     }
  571.     if {[info exists env(PATHEXT)]} {
  572.     # Add an initial ; to have the {} extension check first.
  573.     set execExtensions [split ";$env(PATHEXT)" ";"]
  574.     } else {
  575.     set execExtensions [list {} .com .exe .bat]
  576.     }
  577.  
  578.     if {[lsearch -exact $shellBuiltins $name] != -1} {
  579.     # When this is command.com for some reason on Win2K, Tcl won't
  580.     # exec it unless the case is right, which this corrects.  COMSPEC
  581.     # may not point to a real file, so do the check.
  582.     set cmd $env(COMSPEC)
  583.     if {[file exists $cmd]} {
  584.         set cmd [file attributes $cmd -shortname]
  585.     }
  586.     return [set auto_execs($name) [list $cmd /c $name]]
  587.     }
  588.  
  589.     if {[llength [file split $name]] != 1} {
  590.     foreach ext $execExtensions {
  591.         set file ${name}${ext}
  592.         if {[file exists $file] && ![file isdirectory $file]} {
  593.         return [set auto_execs($name) [list $file]]
  594.         }
  595.     }
  596.     return ""
  597.     }
  598.  
  599.     set path "[file dirname [info nameof]];.;"
  600.     if {[info exists env(WINDIR)]} {
  601.     set windir $env(WINDIR) 
  602.     }
  603.     if {[info exists windir]} {
  604.     if {[string equal $tcl_platform(os) "Windows NT"]} {
  605.         append path "$windir/system32;"
  606.     }
  607.     append path "$windir/system;$windir;"
  608.     }
  609.  
  610.     foreach var {PATH Path path} {
  611.     if {[info exists env($var)]} {
  612.         append path ";$env($var)"
  613.     }
  614.     }
  615.  
  616.     foreach dir [split $path {;}] {
  617.     # Skip already checked directories
  618.     if {[info exists checked($dir)] || [string equal {} $dir]} { continue }
  619.     set checked($dir) {}
  620.     foreach ext $execExtensions {
  621.         set file [file join $dir ${name}${ext}]
  622.         if {[file exists $file] && ![file isdirectory $file]} {
  623.         return [set auto_execs($name) [list $file]]
  624.         }
  625.     }
  626.     }
  627.     return ""
  628. }
  629.  
  630. } else {
  631. # Unix version.
  632. #
  633. proc auto_execok name {
  634.     global auto_execs env
  635.  
  636.     if {[info exists auto_execs($name)]} {
  637.     return $auto_execs($name)
  638.     }
  639.     set auto_execs($name) ""
  640.     if {[llength [file split $name]] != 1} {
  641.     if {[file executable $name] && ![file isdirectory $name]} {
  642.         set auto_execs($name) [list $name]
  643.     }
  644.     return $auto_execs($name)
  645.     }
  646.     foreach dir [split $env(PATH) :] {
  647.     if {[string equal $dir ""]} {
  648.         set dir .
  649.     }
  650.     set file [file join $dir $name]
  651.     if {[file executable $file] && ![file isdirectory $file]} {
  652.         set auto_execs($name) [list $file]
  653.         return $auto_execs($name)
  654.     }
  655.     }
  656.     return ""
  657. }
  658.  
  659. }
  660.  
  661. # ::tcl::CopyDirectory --
  662. #
  663. # This procedure is called by Tcl's core when attempts to call the
  664. # filesystem's copydirectory function fail.  The semantics of the call
  665. # are that 'dest' does not yet exist, i.e. dest should become the exact
  666. # image of src.  If dest does exist, we throw an error.  
  667. # 
  668. # Note that making changes to this procedure can change the results
  669. # of running Tcl's tests.
  670. #
  671. # Arguments: 
  672. # action -              "renaming" or "copying" 
  673. # src -            source directory
  674. # dest -        destination directory
  675. proc tcl::CopyDirectory {action src dest} {
  676.     set nsrc [file normalize $src]
  677.     set ndest [file normalize $dest]
  678.     if {[string equal $action "renaming"]} {
  679.     # Can't rename volumes.  We could give a more precise
  680.     # error message here, but that would break the test suite.
  681.     if {[lsearch -exact [file volumes] $nsrc] != -1} {
  682.         return -code error "error $action \"$src\" to\
  683.           \"$dest\": trying to rename a volume or move a directory\
  684.           into itself"
  685.     }
  686.     }
  687.     if {[file exists $dest]} {
  688.     if {$nsrc == $ndest} {
  689.         return -code error "error $action \"$src\" to\
  690.           \"$dest\": trying to rename a volume or move a directory\
  691.           into itself"
  692.     }
  693.     if {[string equal $action "copying"]} {
  694.         return -code error "error $action \"$src\" to\
  695.           \"$dest\": file already exists"
  696.     } else {
  697.         # Depending on the platform, and on the current
  698.         # working directory, the directories '.', '..'
  699.         # can be returned in various combinations.  Anyway,
  700.         # if any other file is returned, we must signal an error.
  701.         set existing [glob -nocomplain -directory $dest * .*]
  702.         eval [list lappend existing] \
  703.           [glob -nocomplain -directory $dest -type hidden * .*]
  704.         foreach s $existing {
  705.         if {([file tail $s] != ".") && ([file tail $s] != "..")} {
  706.             return -code error "error $action \"$src\" to\
  707.               \"$dest\": file already exists"
  708.         }
  709.         }
  710.     }
  711.     } else {
  712.     if {[string first $nsrc $ndest] != -1} {
  713.         set srclen [expr {[llength [file split $nsrc]] -1}]
  714.         set ndest [lindex [file split $ndest] $srclen]
  715.         if {$ndest == [file tail $nsrc]} {
  716.         return -code error "error $action \"$src\" to\
  717.           \"$dest\": trying to rename a volume or move a directory\
  718.           into itself"
  719.         }
  720.     }
  721.     file mkdir $dest
  722.     }
  723.     # Have to be careful to capture both visible and hidden files.
  724.     # We will also be more generous to the file system and not
  725.     # assume the hidden and non-hidden lists are non-overlapping.
  726.     # 
  727.     # On Unix 'hidden' files begin with '.'.  On other platforms
  728.     # or filesystems hidden files may have other interpretations.
  729.     set filelist [concat [glob -nocomplain -directory $src *] \
  730.       [glob -nocomplain -directory $src -types hidden *]]
  731.     
  732.     foreach s [lsort -unique $filelist] {
  733.     if {([file tail $s] != ".") && ([file tail $s] != "..")} {
  734.         file copy $s [file join $dest [file tail $s]]
  735.     }
  736.     }
  737.     return
  738. }
  739.