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