home *** CD-ROM | disk | FTP | other *** search
/ PC World 2000 December / PCWorld_2000-12_cd.bin / Komunikace / Comanche / comanche.exe / lib / tcl8.0 / init.tcl < prev    next >
Text File  |  1999-02-24  |  47KB  |  1,536 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.25.2.1 1999/02/11 03:06:23 stanton 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.0
  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. # tcl_pkgPath, which is set by the platform-specific initialization routines
  34. #    On UNIX it is compiled in
  35. #    On Windows it comes from the registry
  36. #    On Macintosh it is "Tool Command Language" in the Extensions folder
  37.  
  38. if {![info exists auto_path]} {
  39.     if {[info exist env(TCLLIBPATH)]} {
  40.     set auto_path $env(TCLLIBPATH)
  41.     } else {
  42.     set auto_path ""
  43.     }
  44. }
  45. if {[string compare [info library] {}]} {
  46.     foreach __dir [list [info library] [file dirname [info library]]] {
  47.     if {[lsearch -exact $auto_path $__dir] < 0} {
  48.         lappend auto_path $__dir
  49.     }
  50.     }
  51. }
  52. if {[info exist tcl_pkgPath]} {
  53.     foreach __dir $tcl_pkgPath {
  54.     if {[lsearch -exact $auto_path $__dir] < 0} {
  55.         lappend auto_path $__dir
  56.     }
  57.     }
  58. }
  59. if {[info exists __dir]} {
  60.     unset __dir
  61. }
  62.  
  63. # Windows specific initialization to handle case isses with envars
  64.  
  65. if {(![interp issafe]) && ($tcl_platform(platform) == "windows")} {
  66.     namespace eval tcl {
  67.     proc envTraceProc {lo n1 n2 op} {
  68.         set x $::env($n2)
  69.         set ::env($lo) $x
  70.         set ::env([string toupper $lo]) $x
  71.     }
  72.     }
  73.     foreach p [array names env] {
  74.     set u [string toupper $p]
  75.     if {$u != $p} {
  76.         switch -- $u {
  77.         COMSPEC -
  78.         PATH {
  79.             if {![info exists env($u)]} {
  80.             set env($u) $env($p)
  81.             }
  82.             trace variable env($p) w [list tcl::envTraceProc $p]
  83.             trace variable env($u) w [list tcl::envTraceProc $p]
  84.         }
  85.         }
  86.     }
  87.     }
  88.     if {[info exists p]} {
  89.     unset p
  90.     }
  91.     if {[info exists u]} {
  92.     unset u
  93.     }
  94.     if {![info exists env(COMSPEC)]} {
  95.     if {$tcl_platform(os) == {Windows NT}} {
  96.         set env(COMSPEC) cmd.exe
  97.     } else {
  98.         set env(COMSPEC) command.com
  99.     }
  100.     }
  101. }
  102.  
  103. # Setup the unknown package handler
  104.  
  105. package unknown tclPkgUnknown
  106.  
  107. # Conditionalize for presence of exec.
  108.  
  109. if {[info commands exec] == ""} {
  110.  
  111.     # Some machines, such as the Macintosh, do not have exec. Also, on all
  112.     # platforms, safe interpreters do not have exec.
  113.  
  114.     set auto_noexec 1
  115. }
  116. set errorCode ""
  117. set errorInfo ""
  118.  
  119. # Define a log command (which can be overwitten to log errors
  120. # differently, specially when stderr is not available)
  121.  
  122. if {[info commands tclLog] == ""} {
  123.     proc tclLog {string} {
  124.     catch {puts stderr $string}
  125.     }
  126. }
  127.  
  128. # unknown --
  129. # This procedure is called when a Tcl command is invoked that doesn't
  130. # exist in the interpreter.  It takes the following steps to make the
  131. # command available:
  132. #
  133. #    1. See if the command has the form "namespace inscope ns cmd" and
  134. #       if so, concatenate its arguments onto the end and evaluate it.
  135. #    2. See if the autoload facility can locate the command in a
  136. #       Tcl script file.  If so, load it and execute it.
  137. #    3. If the command was invoked interactively at top-level:
  138. #        (a) see if the command exists as an executable UNIX program.
  139. #        If so, "exec" the command.
  140. #        (b) see if the command requests csh-like history substitution
  141. #        in one of the common forms !!, !<number>, or ^old^new.  If
  142. #        so, emulate csh's history substitution.
  143. #        (c) see if the command is a unique abbreviation for another
  144. #        command.  If so, invoke the command.
  145. #
  146. # Arguments:
  147. # args -    A list whose elements are the words of the original
  148. #        command, including the command name.
  149.  
  150. proc unknown args {
  151.     global auto_noexec auto_noload env unknown_pending tcl_interactive
  152.     global errorCode errorInfo
  153.  
  154.     # If the command word has the form "namespace inscope ns cmd"
  155.     # then concatenate its arguments onto the end and evaluate it.
  156.  
  157.     set cmd [lindex $args 0]
  158.     if {[regexp "^namespace\[ \t\n\]+inscope" $cmd] && [llength $cmd] == 4} {
  159.         set arglist [lrange $args 1 end]
  160.     set ret [catch {uplevel $cmd $arglist} result]
  161.         if {$ret == 0} {
  162.             return $result
  163.         } else {
  164.         return -code $ret -errorcode $errorCode $result
  165.         }
  166.     }
  167.  
  168.     # Save the values of errorCode and errorInfo variables, since they
  169.     # may get modified if caught errors occur below.  The variables will
  170.     # be restored just before re-executing the missing command.
  171.  
  172.     set savedErrorCode $errorCode
  173.     set savedErrorInfo $errorInfo
  174.     set name [lindex $args 0]
  175.     if {![info exists auto_noload]} {
  176.     #
  177.     # Make sure we're not trying to load the same proc twice.
  178.     #
  179.     if {[info exists unknown_pending($name)]} {
  180.         return -code error "self-referential recursion in \"unknown\" for command \"$name\"";
  181.     }
  182.     set unknown_pending($name) pending;
  183.     set ret [catch {auto_load $name [uplevel 1 {namespace current}]} msg]
  184.     unset unknown_pending($name);
  185.     if {$ret != 0} {
  186.         return -code $ret -errorcode $errorCode \
  187.         "error while autoloading \"$name\": $msg"
  188.     }
  189.     if {![array size unknown_pending]} {
  190.         unset unknown_pending
  191.     }
  192.     if {$msg} {
  193.         set errorCode $savedErrorCode
  194.         set errorInfo $savedErrorInfo
  195.         set code [catch {uplevel 1 $args} msg]
  196.         if {$code ==  1} {
  197.         #
  198.         # Strip the last five lines off the error stack (they're
  199.         # from the "uplevel" command).
  200.         #
  201.  
  202.         set new [split $errorInfo \n]
  203.         set new [join [lrange $new 0 [expr {[llength $new] - 6}]] \n]
  204.         return -code error -errorcode $errorCode \
  205.             -errorinfo $new $msg
  206.         } else {
  207.         return -code $code $msg
  208.         }
  209.     }
  210.     }
  211.  
  212.     if {([info level] == 1) && ([info script] == "") \
  213.         && [info exists tcl_interactive] && $tcl_interactive} {
  214.     if {![info exists auto_noexec]} {
  215.         set new [auto_execok $name]
  216.         if {$new != ""} {
  217.         set errorCode $savedErrorCode
  218.         set errorInfo $savedErrorInfo
  219.         set redir ""
  220.         if {[info commands console] == ""} {
  221.             set redir ">&@stdout <@stdin"
  222.         }
  223.         return [uplevel exec $redir $new [lrange $args 1 end]]
  224.         }
  225.     }
  226.     set errorCode $savedErrorCode
  227.     set errorInfo $savedErrorInfo
  228.     if {$name == "!!"} {
  229.         set newcmd [history event]
  230.     } elseif {[regexp {^!(.+)$} $name dummy event]} {
  231.         set newcmd [history event $event]
  232.     } elseif {[regexp {^\^([^^]*)\^([^^]*)\^?$} $name dummy old new]} {
  233.         set newcmd [history event -1]
  234.         catch {regsub -all -- $old $newcmd $new newcmd}
  235.     }
  236.     if {[info exists newcmd]} {
  237.         tclLog $newcmd
  238.         history change $newcmd 0
  239.         return [uplevel $newcmd]
  240.     }
  241.  
  242.     set ret [catch {set cmds [info commands $name*]} msg]
  243.     if {[string compare $name "::"] == 0} {
  244.         set name ""
  245.     }
  246.     if {$ret != 0} {
  247.         return -code $ret -errorcode $errorCode \
  248.         "error in unknown while checking if \"$name\" is a unique command abbreviation: $msg"
  249.     }
  250.     if {[llength $cmds] == 1} {
  251.         return [uplevel [lreplace $args 0 0 $cmds]]
  252.     }
  253.     if {[llength $cmds] != 0} {
  254.         if {$name == ""} {
  255.         return -code error "empty command name \"\""
  256.         } else {
  257.         return -code error \
  258.             "ambiguous command name \"$name\": [lsort $cmds]"
  259.         }
  260.     }
  261.     }
  262.     return -code error "invalid command name \"$name\""
  263. }
  264.  
  265. # auto_load --
  266. # Checks a collection of library directories to see if a procedure
  267. # is defined in one of them.  If so, it sources the appropriate
  268. # library file to create the procedure.  Returns 1 if it successfully
  269. # loaded the procedure, 0 otherwise.
  270. #
  271. # Arguments: 
  272. # cmd -            Name of the command to find and load.
  273. # namespace (optional)  The namespace where the command is being used - must be
  274. #                       a canonical namespace as returned [namespace current]
  275. #                       for instance. If not given, namespace current is used.
  276.  
  277. proc auto_load {cmd {namespace {}}} {
  278.     global auto_index auto_oldpath auto_path
  279.  
  280.     if {[string length $namespace] == 0} {
  281.     set namespace [uplevel {namespace current}]
  282.     }
  283.     set nameList [auto_qualify $cmd $namespace]
  284.     # workaround non canonical auto_index entries that might be around
  285.     # from older auto_mkindex versions
  286.     lappend nameList $cmd
  287.     foreach name $nameList {
  288.     if {[info exists auto_index($name)]} {
  289.         uplevel #0 $auto_index($name)
  290.         return [expr {[info commands $name] != ""}]
  291.     }
  292.     }
  293.     if {![info exists auto_path]} {
  294.     return 0
  295.     }
  296.  
  297.     if {![auto_load_index]} {
  298.     return 0
  299.     }
  300.  
  301.     foreach name $nameList {
  302.     if {[info exists auto_index($name)]} {
  303.         uplevel #0 $auto_index($name)
  304.         if {[info commands $name] != ""} {
  305.         return 1
  306.         }
  307.     }
  308.     }
  309.     return 0
  310. }
  311.  
  312. # auto_load_index --
  313. # Loads the contents of tclIndex files on the auto_path directory
  314. # list.  This is usually invoked within auto_load to load the index
  315. # of available commands.  Returns 1 if the index is loaded, and 0 if
  316. # the index is already loaded and up to date.
  317. #
  318. # Arguments: 
  319. # None.
  320.  
  321. proc auto_load_index {} {
  322.     global auto_index auto_oldpath auto_path errorInfo errorCode
  323.  
  324.     if {[info exists auto_oldpath]} {
  325.     if {$auto_oldpath == $auto_path} {
  326.         return 0
  327.     }
  328.     }
  329.     set auto_oldpath $auto_path
  330.  
  331.     # Check if we are a safe interpreter. In that case, we support only
  332.     # newer format tclIndex files.
  333.  
  334.     set issafe [interp issafe]
  335.     for {set i [expr {[llength $auto_path] - 1}]} {$i >= 0} {incr i -1} {
  336.     set dir [lindex $auto_path $i]
  337.     set f ""
  338.     if {$issafe} {
  339.         catch {source [file join $dir tclIndex]}
  340.     } elseif {[catch {set f [open [file join $dir tclIndex]]}]} {
  341.         continue
  342.     } else {
  343.         set error [catch {
  344.         set id [gets $f]
  345.         if {$id == "# Tcl autoload index file, version 2.0"} {
  346.             eval [read $f]
  347.         } elseif {$id == \
  348.             "# Tcl autoload index file: each line identifies a Tcl"} {
  349.             while {[gets $f line] >= 0} {
  350.             if {([string index $line 0] == "#")
  351.                 || ([llength $line] != 2)} {
  352.                 continue
  353.             }
  354.             set name [lindex $line 0]
  355.             set auto_index($name) \
  356.                 "source [file join $dir [lindex $line 1]]"
  357.             }
  358.         } else {
  359.             error \
  360.               "[file join $dir tclIndex] isn't a proper Tcl index file"
  361.         }
  362.         } msg]
  363.         if {$f != ""} {
  364.         close $f
  365.         }
  366.         if {$error} {
  367.         error $msg $errorInfo $errorCode
  368.         }
  369.     }
  370.     }
  371.     return 1
  372. }
  373.  
  374. # auto_qualify --
  375. # compute a fully qualified names list for use in the auto_index array.
  376. # For historical reasons, commands in the global namespace do not have leading
  377. # :: in the index key. The list has two elements when the command name is
  378. # relative (no leading ::) and the namespace is not the global one. Otherwise
  379. # only one name is returned (and searched in the auto_index).
  380. #
  381. # Arguments -
  382. # cmd        The command name. Can be any name accepted for command
  383. #               invocations (Like "foo::::bar").
  384. # namespace    The namespace where the command is being used - must be
  385. #               a canonical namespace as returned by [namespace current]
  386. #               for instance.
  387.  
  388. proc auto_qualify {cmd namespace} {
  389.  
  390.     # count separators and clean them up
  391.     # (making sure that foo:::::bar will be treated as foo::bar)
  392.     set n [regsub -all {::+} $cmd :: cmd]
  393.  
  394.     # Ignore namespace if the name starts with ::
  395.     # Handle special case of only leading ::
  396.  
  397.     # Before each return case we give an example of which category it is
  398.     # with the following form :
  399.     # ( inputCmd, inputNameSpace) -> output
  400.  
  401.     if {[regexp {^::(.*)$} $cmd x tail]} {
  402.     if {$n > 1} {
  403.         # ( ::foo::bar , * ) -> ::foo::bar
  404.         return [list $cmd]
  405.     } else {
  406.         # ( ::global , * ) -> global
  407.         return [list $tail]
  408.     }
  409.     }
  410.     
  411.     # Potentially returning 2 elements to try  :
  412.     # (if the current namespace is not the global one)
  413.  
  414.     if {$n == 0} {
  415.     if {[string compare $namespace ::] == 0} {
  416.         # ( nocolons , :: ) -> nocolons
  417.         return [list $cmd]
  418.     } else {
  419.         # ( nocolons , ::sub ) -> ::sub::nocolons nocolons
  420.         return [list ${namespace}::$cmd $cmd]
  421.     }
  422.     } else {
  423.     if {[string compare $namespace ::] == 0} {
  424.         #  ( foo::bar , :: ) -> ::foo::bar
  425.         return [list ::$cmd]
  426.     } else {
  427.         # ( foo::bar , ::sub ) -> ::sub::foo::bar ::foo::bar
  428.         return [list ${namespace}::$cmd ::$cmd]
  429.     }
  430.     }
  431. }
  432.  
  433. # auto_import --
  434. # invoked during "namespace import" to make see if the imported commands
  435. # reside in an autoloaded library.  If so, the commands are loaded so
  436. # that they will be available for the import links.  If not, then this
  437. # procedure does nothing.
  438. #
  439. # Arguments -
  440. # pattern    The pattern of commands being imported (like "foo::*")
  441. #               a canonical namespace as returned by [namespace current]
  442.  
  443. proc auto_import {pattern} {
  444.     global auto_index
  445.  
  446.     set ns [uplevel namespace current]
  447.     set patternList [auto_qualify $pattern $ns]
  448.  
  449.     auto_load_index
  450.  
  451.     foreach pattern $patternList {
  452.         foreach name [array names auto_index] {
  453.             if {[string match $pattern $name] && "" == [info commands $name]} {
  454.                 uplevel #0 $auto_index($name)
  455.             }
  456.         }
  457.     }
  458. }
  459.  
  460. if {[string compare $tcl_platform(platform) windows] == 0} {
  461.  
  462. # auto_execok --
  463. #
  464. # Returns string that indicates name of program to execute if 
  465. # name corresponds to a shell builtin or an executable in the
  466. # Windows search path, or "" otherwise.  Builds an associative 
  467. # array auto_execs that caches information about previous checks, 
  468. # for speed.
  469. #
  470. # Arguments: 
  471. # name -            Name of a command.
  472.  
  473. # Windows version.
  474. #
  475. # Note that info executable doesn't work under Windows, so we have to
  476. # look for files with .exe, .com, or .bat extensions.  Also, the path
  477. # may be in the Path or PATH environment variables, and path
  478. # components are separated with semicolons, not colons as under Unix.
  479. #
  480. proc auto_execok name {
  481.     global auto_execs env tcl_platform
  482.  
  483.     if {[info exists auto_execs($name)]} {
  484.     return $auto_execs($name)
  485.     }
  486.     set auto_execs($name) ""
  487.  
  488.     if {[lsearch -exact {cls copy date del erase dir echo mkdir md rename 
  489.         ren rmdir rd time type ver vol} $name] != -1} {
  490.     return [set auto_execs($name) [list $env(COMSPEC) /c $name]]
  491.     }
  492.  
  493.     if {[llength [file split $name]] != 1} {
  494.     foreach ext {{} .com .exe .bat} {
  495.         set file ${name}${ext}
  496.         if {[file exists $file] && ![file isdirectory $file]} {
  497.         return [set auto_execs($name) [list $file]]
  498.         }
  499.     }
  500.     return ""
  501.     }
  502.  
  503.     set path "[file dirname [info nameof]];.;"
  504.     if {[info exists env(WINDIR)]} {
  505.     set windir $env(WINDIR) 
  506.     }
  507.     if {[info exists windir]} {
  508.     if {$tcl_platform(os) == "Windows NT"} {
  509.         append path "$windir/system32;"
  510.     }
  511.     append path "$windir/system;$windir;"
  512.     }
  513.  
  514.     if {[info exists env(PATH)]} {
  515.     append path $env(PATH)
  516.     }
  517.  
  518.     foreach dir [split $path {;}] {
  519.     if {$dir == ""} {
  520.         set dir .
  521.     }
  522.     foreach ext {{} .com .exe .bat} {
  523.         set file [file join $dir ${name}${ext}]
  524.         if {[file exists $file] && ![file isdirectory $file]} {
  525.         return [set auto_execs($name) [list $file]]
  526.         }
  527.     }
  528.     }
  529.     return ""
  530. }
  531.  
  532. } else {
  533.  
  534. # auto_execok --
  535. #
  536. # Returns string that indicates name of program to execute if 
  537. # name corresponds to an executable in the path. Builds an associative 
  538. # array auto_execs that caches information about previous checks, 
  539. # for speed.
  540. #
  541. # Arguments: 
  542. # name -            Name of a command.
  543.  
  544. # Unix version.
  545. #
  546. proc auto_execok name {
  547.     global auto_execs env
  548.  
  549.     if {[info exists auto_execs($name)]} {
  550.     return $auto_execs($name)
  551.     }
  552.     set auto_execs($name) ""
  553.     if {[llength [file split $name]] != 1} {
  554.     if {[file executable $name] && ![file isdirectory $name]} {
  555.         set auto_execs($name) [list $name]
  556.     }
  557.     return $auto_execs($name)
  558.     }
  559.     foreach dir [split $env(PATH) :] {
  560.     if {$dir == ""} {
  561.         set dir .
  562.     }
  563.     set file [file join $dir $name]
  564.     if {[file executable $file] && ![file isdirectory $file]} {
  565.         set auto_execs($name) [list $file]
  566.         return $auto_execs($name)
  567.     }
  568.     }
  569.     return ""
  570. }
  571.  
  572. }
  573. # auto_reset --
  574. # Destroy all cached information for auto-loading and auto-execution,
  575. # so that the information gets recomputed the next time it's needed.
  576. # Also delete any procedures that are listed in the auto-load index
  577. # except those defined in this file.
  578. #
  579. # Arguments: 
  580. # None.
  581.  
  582. proc auto_reset {} {
  583.     global auto_execs auto_index auto_oldpath
  584.     foreach p [info procs] {
  585.     if {[info exists auto_index($p)] && ![string match auto_* $p]
  586.         && ([lsearch -exact {unknown pkg_mkIndex tclPkgSetup
  587.             tcl_findLibrary pkg_compareExtension
  588.             tclMacPkgSearch tclPkgUnknown} $p] < 0)} {
  589.         rename $p {}
  590.     }
  591.     }
  592.     catch {unset auto_execs}
  593.     catch {unset auto_index}
  594.     catch {unset auto_oldpath}
  595. }
  596.  
  597. # tcl_findLibrary
  598. #    This is a utility for extensions that searches for a library directory
  599. #    using a canonical searching algorithm. A side effect is to source
  600. #    the initialization script and set a global library variable.
  601. # Arguments:
  602. #     basename    Prefix of the directory name, (e.g., "tk")
  603. #    version        Version number of the package, (e.g., "8.0")
  604. #    patch        Patchlevel of the package, (e.g., "8.0.3")
  605. #    initScript    Initialization script to source (e.g., tk.tcl)
  606. #    enVarName    environment variable to honor (e.g., TK_LIBRARY)
  607. #    varName        Global variable to set when done (e.g., tk_library)
  608.  
  609. proc tcl_findLibrary {basename version patch initScript enVarName varName} {
  610.     upvar #0 $varName the_library
  611.     global env errorInfo
  612.  
  613.     set dirs {}
  614.     set errors {}
  615.  
  616.     # The C application may have hardwired a path, which we honor
  617.     
  618.     if {[info exist the_library] && [string compare $the_library {}]} {
  619.     lappend dirs $the_library
  620.     } else {
  621.  
  622.     # Do the canonical search
  623.  
  624.     # 1. From an environment variable, if it exists
  625.  
  626.         if {[info exists env($enVarName)]} {
  627.             lappend dirs $env($enVarName)
  628.         }
  629.  
  630.     # 2. Relative to the Tcl library
  631.  
  632.         lappend dirs [file join [file dirname [info library]] \
  633.         $basename$version]
  634.  
  635.     # 3. Various locations relative to the executable
  636.     # ../lib/foo1.0        (From bin directory in install hierarchy)
  637.     # ../../lib/foo1.0    (From bin/arch directory in install hierarchy)
  638.     # ../library        (From unix directory in build hierarchy)
  639.     # ../../library        (From unix/arch directory in build hierarchy)
  640.     # ../../foo1.0b1/library (From unix directory in parallel build hierarchy)
  641.     # ../../../foo1.0b1/library (From unix/arch directory in parallel build hierarchy)
  642.  
  643.         set parentDir [file dirname [file dirname [info nameofexecutable]]]
  644.         set grandParentDir [file dirname $parentDir]
  645.         lappend dirs [file join $parentDir lib $basename$version]
  646.         lappend dirs [file join $grandParentDir lib $basename$version]
  647.         lappend dirs [file join $parentDir library]
  648.         lappend dirs [file join $grandParentDir library]
  649.         if {![regexp {.*[ab][0-9]*} $patch ver]} {
  650.             set ver $version
  651.         }
  652.         lappend dirs [file join $grandParentDir $basename$ver library]
  653.         lappend dirs [file join [file dirname $grandParentDir] $basename$ver library]
  654.     }
  655.     foreach i $dirs {
  656.         set the_library $i
  657.         set file [file join $i $initScript]
  658.  
  659.     # source everything when in a safe interpreter because
  660.     # we have a source command, but no file exists command
  661.  
  662.         if {[interp issafe] || [file exists $file]} {
  663.             if {![catch {uplevel #0 [list source $file]} msg]} {
  664.                 return
  665.             } else {
  666.                 append errors "$file: $msg\n$errorInfo\n"
  667.             }
  668.         }
  669.     }
  670.     set msg "Can't find a usable $initScript in the following directories: \n"
  671.     append msg "    $dirs\n\n"
  672.     append msg "$errors\n\n"
  673.     append msg "This probably means that $basename wasn't installed properly.\n"
  674.     error $msg
  675. }
  676.  
  677.  
  678. # OPTIONAL SUPPORT PROCEDURES
  679. # In Tcl 8.1 all the code below here has been moved to other files to
  680. # reduce the size of init.tcl
  681.  
  682. # ----------------------------------------------------------------------
  683. # auto_mkindex
  684. # ----------------------------------------------------------------------
  685. # The following procedures are used to generate the tclIndex file
  686. # from Tcl source files.  They use a special safe interpreter to
  687. # parse Tcl source files, writing out index entries as "proc"
  688. # commands are encountered.  This implementation won't work in a
  689. # safe interpreter, since a safe interpreter can't create the
  690. # special parser and mess with its commands.  If this is a safe
  691. # interpreter, we simply clip these procs out.
  692.  
  693. if {! [interp issafe]} {
  694.  
  695.     # auto_mkindex --
  696.     # Regenerate a tclIndex file from Tcl source files.  Takes as argument
  697.     # the name of the directory in which the tclIndex file is to be placed,
  698.     # followed by any number of glob patterns to use in that directory to
  699.     # locate all of the relevant files.
  700.     #
  701.     # Arguments: 
  702.     # dir -        Name of the directory in which to create an index.
  703.     # args -    Any number of additional arguments giving the
  704.     #        names of files within dir.  If no additional
  705.     #        are given auto_mkindex will look for *.tcl.
  706.  
  707.     proc auto_mkindex {dir args} {
  708.     global errorCode errorInfo
  709.  
  710.     set oldDir [pwd]
  711.     cd $dir
  712.     set dir [pwd]
  713.  
  714.     append index "# Tcl autoload index file, version 2.0\n"
  715.     append index "# This file is generated by the \"auto_mkindex\" command\n"
  716.     append index "# and sourced to set up indexing information for one or\n"
  717.     append index "# more commands.  Typically each line is a command that\n"
  718.     append index "# sets an element in the auto_index array, where the\n"
  719.     append index "# element name is the name of a command and the value is\n"
  720.     append index "# a script that loads the command.\n\n"
  721.     if {$args == ""} {
  722.         set args *.tcl
  723.     }
  724.  
  725.     auto_mkindex_parser::init
  726.     foreach file [eval glob $args] {
  727.         if {[catch {auto_mkindex_parser::mkindex $file} msg] == 0} {
  728.         append index $msg
  729.         } else {
  730.         set code $errorCode
  731.         set info $errorInfo
  732.         cd $oldDir
  733.         error $msg $info $code
  734.         }
  735.     }
  736.     auto_mkindex_parser::cleanup
  737.  
  738.     set fid [open "tclIndex" w]
  739.     puts $fid $index nonewline
  740.     close $fid
  741.     cd $oldDir
  742.     }
  743.  
  744.     # Original version of auto_mkindex that just searches the source
  745.     # code for "proc" at the beginning of the line.
  746.  
  747.     proc auto_mkindex_old {dir args} {
  748.     global errorCode errorInfo
  749.     set oldDir [pwd]
  750.     cd $dir
  751.     set dir [pwd]
  752.     append index "# Tcl autoload index file, version 2.0\n"
  753.     append index "# This file is generated by the \"auto_mkindex\" command\n"
  754.     append index "# and sourced to set up indexing information for one or\n"
  755.     append index "# more commands.  Typically each line is a command that\n"
  756.     append index "# sets an element in the auto_index array, where the\n"
  757.     append index "# element name is the name of a command and the value is\n"
  758.     append index "# a script that loads the command.\n\n"
  759.     if {$args == ""} {
  760.         set args *.tcl
  761.     }
  762.     foreach file [eval glob $args] {
  763.         set f ""
  764.         set error [catch {
  765.         set f [open $file]
  766.         while {[gets $f line] >= 0} {
  767.             if {[regexp {^proc[     ]+([^     ]*)} $line match procName]} {
  768.             set procName [lindex [auto_qualify $procName "::"] 0]
  769.             append index "set [list auto_index($procName)]"
  770.             append index " \[list source \[file join \$dir [list $file]\]\]\n"
  771.             }
  772.         }
  773.         close $f
  774.         } msg]
  775.         if {$error} {
  776.         set code $errorCode
  777.         set info $errorInfo
  778.         catch {close $f}
  779.         cd $oldDir
  780.         error $msg $info $code
  781.         }
  782.     }
  783.     set f ""
  784.     set error [catch {
  785.         set f [open tclIndex w]
  786.         puts $f $index nonewline
  787.         close $f
  788.         cd $oldDir
  789.     } msg]
  790.     if {$error} {
  791.         set code $errorCode
  792.         set info $errorInfo
  793.         catch {close $f}
  794.         cd $oldDir
  795.         error $msg $info $code
  796.     }
  797.     }
  798.  
  799.     # Create a safe interpreter that can be used to parse Tcl source files
  800.     # generate a tclIndex file for autoloading.  This interp contains
  801.     # commands for things that need index entries.  Each time a command
  802.     # is executed, it writes an entry out to the index file.
  803.  
  804.     namespace eval auto_mkindex_parser {
  805.     variable parser ""          ;# parser used to build index
  806.     variable index ""           ;# maintains index as it is built
  807.     variable scriptFile ""      ;# name of file being processed
  808.     variable contextStack ""    ;# stack of namespace scopes
  809.     variable imports ""         ;# keeps track of all imported cmds
  810.     variable initCommands ""    ;# list of commands that create aliases
  811.  
  812.     proc init {} {
  813.         variable parser
  814.         variable initCommands
  815.         
  816.         if {![interp issafe]} {
  817.         set parser [interp create -safe]
  818.         $parser hide info
  819.         $parser hide rename
  820.         $parser hide proc
  821.         $parser hide namespace
  822.         $parser hide eval
  823.         $parser hide puts
  824.         $parser invokehidden namespace delete ::
  825.         $parser invokehidden proc unknown {args} {}
  826.  
  827.         #
  828.         # We'll need access to the "namespace" command within the
  829.         # interp.  Put it back, but move it out of the way.
  830.         #
  831.         $parser expose namespace
  832.         $parser invokehidden rename namespace _%@namespace
  833.         $parser expose eval
  834.         $parser invokehidden rename eval _%@eval
  835.  
  836.         # Install all the registered psuedo-command implementations
  837.  
  838.         foreach cmd $initCommands {
  839.             eval $cmd
  840.         }
  841.         }
  842.     }
  843.     proc cleanup {} {
  844.         variable parser
  845.         interp delete $parser
  846.         unset parser
  847.     }
  848.     }
  849.  
  850.     # auto_mkindex_parser::mkindex --
  851.     # Used by the "auto_mkindex" command to create a "tclIndex" file for
  852.     # the given Tcl source file.  Executes the commands in the file, and
  853.     # handles things like the "proc" command by adding an entry for the
  854.     # index file.  Returns a string that represents the index file.
  855.     #
  856.     # Arguments: 
  857.     # file -        Name of Tcl source file to be indexed.
  858.  
  859.     proc auto_mkindex_parser::mkindex {file} {
  860.     variable parser
  861.     variable index
  862.     variable scriptFile
  863.     variable contextStack
  864.     variable imports
  865.  
  866.     set scriptFile $file
  867.  
  868.     set fid [open $file]
  869.     set contents [read $fid]
  870.     close $fid
  871.  
  872.     # There is one problem with sourcing files into the safe
  873.     # interpreter:  references like "$x" will fail since code is not
  874.     # really being executed and variables do not really exist.
  875.     # Be careful to escape all naked "$" before evaluating.
  876.  
  877.     regsub -all {([^\$])\$([^\$])} $contents {\1\\$\2} contents
  878.  
  879.     set index ""
  880.     set contextStack ""
  881.     set imports ""
  882.  
  883.     $parser eval $contents
  884.  
  885.     foreach name $imports {
  886.         catch {$parser eval [list _%@namespace forget $name]}
  887.     }
  888.     return $index
  889.     }
  890.  
  891.     # auto_mkindex_parser::hook command
  892.     # Registers a Tcl command to evaluate when initializing the
  893.     # slave interpreter used by the mkindex parser.
  894.     # The command is evaluated in the master interpreter, and can
  895.     # use the variable auto_mkindex_parser::parser to get to the slave
  896.  
  897.     proc auto_mkindex_parser::hook {cmd} {
  898.     variable initCommands
  899.  
  900.     lappend initCommands $cmd
  901.     }
  902.  
  903.     # auto_mkindex_parser::slavehook command
  904.     # Registers a Tcl command to evaluate when initializing the
  905.     # slave interpreter used by the mkindex parser.
  906.     # The command is evaluated in the slave interpreter.
  907.  
  908.     proc auto_mkindex_parser::slavehook {cmd} {
  909.     variable initCommands
  910.  
  911.     lappend initCommands [list \$parser eval $cmd]
  912.     }
  913.  
  914.     # auto_mkindex_parser::command --
  915.     # Registers a new command with the "auto_mkindex_parser" interpreter
  916.     # that parses Tcl files.  These commands are fake versions of things
  917.     # like the "proc" command.  When you execute them, they simply write
  918.     # out an entry to a "tclIndex" file for auto-loading.
  919.     #
  920.     # This procedure allows extensions to register their own commands
  921.     # with the auto_mkindex facility.  For example, a package like
  922.     # [incr Tcl] might register a "class" command so that class definitions
  923.     # could be added to a "tclIndex" file for auto-loading.
  924.     #
  925.     # Arguments:
  926.     # name -        Name of command recognized in Tcl files.
  927.     # arglist -        Argument list for command.
  928.     # body -        Implementation of command to handle indexing.
  929.  
  930.     proc auto_mkindex_parser::command {name arglist body} {
  931.     hook [list auto_mkindex_parser::commandInit $name $arglist $body]
  932.     }
  933.  
  934.     # auto_mkindex_parser::commandInit --
  935.     # This does the actual work set up by auto_mkindex_parser::command
  936.     # This is called when the interpreter used by the parser is created.
  937.  
  938.     proc auto_mkindex_parser::commandInit {name arglist body} {
  939.     variable parser
  940.  
  941.     set ns [namespace qualifiers $name]
  942.     set tail [namespace tail $name]
  943.     if {$ns == ""} {
  944.         set fakeName "[namespace current]::_%@fake_$tail"
  945.     } else {
  946.         set fakeName "_%@fake_$name"
  947.         regsub -all {::} $fakeName "_" fakeName
  948.         set fakeName "[namespace current]::$fakeName"
  949.     }
  950.     proc $fakeName $arglist $body
  951.  
  952.     #
  953.     # YUK!  Tcl won't let us alias fully qualified command names,
  954.     # so we can't handle names like "::itcl::class".  Instead,
  955.     # we have to build procs with the fully qualified names, and
  956.     # have the procs point to the aliases.
  957.     #
  958.     if {[regexp {::} $name]} {
  959.         set exportCmd [list _%@namespace export [namespace tail $name]]
  960.         $parser eval [list _%@namespace eval $ns $exportCmd]
  961.         set alias [namespace tail $fakeName]
  962.         $parser invokehidden proc $name {args} [list _%@eval $alias \$args]
  963.         $parser alias $alias $fakeName
  964.     } else {
  965.         $parser alias $name $fakeName
  966.     }
  967.     return
  968.     }
  969.  
  970.     # auto_mkindex_parser::fullname --
  971.     # Used by commands like "proc" within the auto_mkindex parser.
  972.     # Returns the qualified namespace name for the "name" argument.
  973.     # If the "name" does not start with "::", elements are added from
  974.     # the current namespace stack to produce a qualified name.  Then,
  975.     # the name is examined to see whether or not it should really be
  976.     # qualified.  If the name has more than the leading "::", it is
  977.     # returned as a fully qualified name.  Otherwise, it is returned
  978.     # as a simple name.  That way, the Tcl autoloader will recognize
  979.     # it properly.
  980.     #
  981.     # Arguments:
  982.     # name -        Name that is being added to index.
  983.  
  984.     proc auto_mkindex_parser::fullname {name} {
  985.     variable contextStack
  986.  
  987.     if {![string match ::* $name]} {
  988.         foreach ns $contextStack {
  989.         set name "${ns}::$name"
  990.         if {[string match ::* $name]} {
  991.             break
  992.         }
  993.         }
  994.     }
  995.  
  996.     if {[namespace qualifiers $name] == ""} {
  997.         return [namespace tail $name]
  998.     } elseif {![string match ::* $name]} {
  999.         return "::$name"
  1000.     }
  1001.     return $name
  1002.     }
  1003.  
  1004.     # Register all of the procedures for the auto_mkindex parser that
  1005.     # will build the "tclIndex" file.
  1006.  
  1007.     # AUTO MKINDEX:  proc name arglist body
  1008.     # Adds an entry to the auto index list for the given procedure name.
  1009.  
  1010.     auto_mkindex_parser::command proc {name args} {
  1011.     variable index
  1012.     variable scriptFile
  1013.     append index [list set auto_index([fullname $name])] \
  1014.         " \[list source \[file join \$dir [list $scriptFile]\]\]\n"
  1015.     }
  1016.  
  1017.     # Conditionally add support for Tcl byte code files.  There are some
  1018.     # tricky details here.  First, we need to get the tbcload library
  1019.     # initialized in the current interpreter.  We cannot load tbcload into the
  1020.     # slave until we have done so because it needs access to the tcl_patchLevel
  1021.     # variable.  Second, because the package index file may defer loading the
  1022.     # library until we invoke a command, we need to explicitly invoke auto_load
  1023.     # to force it to be loaded.  This should be a noop if the package has
  1024.     # already been loaded
  1025.  
  1026.     auto_mkindex_parser::hook {
  1027.     if {![catch {package require tbcload}]} {
  1028.         if {[info commands tbcload::bcproc] == ""} {
  1029.         auto_load tbcload::bcproc
  1030.         }
  1031.         load {} tbcload $auto_mkindex_parser::parser
  1032.  
  1033.         # AUTO MKINDEX:  tbcload::bcproc name arglist body
  1034.         # Adds an entry to the auto index list for the given pre-compiled
  1035.         # procedure name.  
  1036.  
  1037.         auto_mkindex_parser::commandInit tbcload::bcproc {name args} {
  1038.         variable index
  1039.         variable scriptFile
  1040.         append index [list set auto_index([fullname $name])] \
  1041.             " \[list source \[file join \$dir [list $scriptFile]\]\]\n"
  1042.         }
  1043.     }
  1044.     }
  1045.  
  1046.     # AUTO MKINDEX:  namespace eval name command ?arg arg...?
  1047.     # Adds the namespace name onto the context stack and evaluates the
  1048.     # associated body of commands.
  1049.     #
  1050.     # AUTO MKINDEX:  namespace import ?-force? pattern ?pattern...?
  1051.     # Performs the "import" action in the parser interpreter.  This is
  1052.     # important for any commands contained in a namespace that affect
  1053.     # the index.  For example, a script may say "itcl::class ...",
  1054.     # or it may import "itcl::*" and then say "class ...".  This
  1055.     # procedure does the import operation, but keeps track of imported
  1056.     # patterns so we can remove the imports later.
  1057.  
  1058.     auto_mkindex_parser::command namespace {op args} {
  1059.     switch -- $op {
  1060.         eval {
  1061.         variable parser
  1062.         variable contextStack
  1063.  
  1064.         set name [lindex $args 0]
  1065.         set args [lrange $args 1 end]
  1066.  
  1067.         set contextStack [linsert $contextStack 0 $name]
  1068.         $parser eval [list _%@namespace eval $name] $args
  1069.         set contextStack [lrange $contextStack 1 end]
  1070.         }
  1071.         import {
  1072.         variable parser
  1073.         variable imports
  1074.         foreach pattern $args {
  1075.             if {$pattern != "-force"} {
  1076.             lappend imports $pattern
  1077.             }
  1078.         }
  1079.         catch {$parser eval [list _%@namespace import] $args}
  1080.         }
  1081.     }
  1082.     }
  1083.  
  1084. # Close of the if ![interp issafe] block
  1085. }
  1086.  
  1087. # pkg_compareExtension --
  1088. #
  1089. #  Used internally by pkg_mkIndex to compare the extension of a file to
  1090. #  a given extension. On Windows, it uses a case-insensitive comparison.
  1091. #
  1092. # Arguments:
  1093. #  fileName    name of a file whose extension is compared
  1094. #  ext        (optional) The extension to compare against; you must
  1095. #        provide the starting dot.
  1096. #        Defaults to [info sharedlibextension]
  1097. #
  1098. # Results:
  1099. #  Returns 1 if the extension matches, 0 otherwise
  1100.  
  1101. proc pkg_compareExtension { fileName {ext {}} } {
  1102.     global tcl_platform
  1103.     if {[string length $ext] == 0} {
  1104.     set ext [info sharedlibextension]
  1105.     }
  1106.     if {[string compare $tcl_platform(platform) "windows"] == 0} {
  1107.     return [expr {[string compare \
  1108.         [string tolower [file extension $fileName]] \
  1109.         [string tolower $ext]] == 0}]
  1110.     } else {
  1111.     return [expr {[string compare [file extension $fileName] $ext] == 0}]
  1112.     }
  1113. }
  1114.  
  1115. # pkg_mkIndex --
  1116. # This procedure creates a package index in a given directory.  The
  1117. # package index consists of a "pkgIndex.tcl" file whose contents are
  1118. # a Tcl script that sets up package information with "package require"
  1119. # commands.  The commands describe all of the packages defined by the
  1120. # files given as arguments.
  1121. #
  1122. # Arguments:
  1123. # -direct        (optional) If this flag is present, the generated
  1124. #            code in pkgMkIndex.tcl will cause the package to be
  1125. #            loaded when "package require" is executed, rather
  1126. #            than lazily when the first reference to an exported
  1127. #            procedure in the package is made.
  1128. # -verbose        (optional) Verbose output; the name of each file that
  1129. #            was successfully rocessed is printed out. Additionally,
  1130. #            if processing of a file failed a message is printed.
  1131. # -load pat        (optional) Preload any packages whose names match
  1132. #            the pattern.  Used to handle DLLs that depend on
  1133. #            other packages during their Init procedure.
  1134. # dir -            Name of the directory in which to create the index.
  1135. # args -        Any number of additional arguments, each giving
  1136. #            a glob pattern that matches the names of one or
  1137. #            more shared libraries or Tcl script files in
  1138. #            dir.
  1139.  
  1140. proc pkg_mkIndex {args} {
  1141.     global errorCode errorInfo
  1142.     set usage {"pkg_mkIndex ?-direct? ?-verbose? ?-load pattern? ?--? dir ?pattern ...?"};
  1143.  
  1144.     set argCount [llength $args]
  1145.     if {$argCount < 1} {
  1146.     return -code error "wrong # args: should be\n$usage"
  1147.     }
  1148.  
  1149.     set more ""
  1150.     set direct 0
  1151.     set doVerbose 0
  1152.     set loadPat ""
  1153.     for {set idx 0} {$idx < $argCount} {incr idx} {
  1154.     set flag [lindex $args $idx]
  1155.     switch -glob -- $flag {
  1156.         -- {
  1157.         # done with the flags
  1158.         incr idx
  1159.         break
  1160.         }
  1161.         -verbose {
  1162.         set doVerbose 1
  1163.         }
  1164.         -direct {
  1165.         set direct 1
  1166.         append more " -direct"
  1167.         }
  1168.         -load {
  1169.         incr idx
  1170.         set loadPat [lindex $args $idx]
  1171.         append more " -load $loadPat"
  1172.         }
  1173.         -* {
  1174.         return -code error "unknown flag $flag: should be\n$usage"
  1175.         }
  1176.         default {
  1177.         # done with the flags
  1178.         break
  1179.         }
  1180.     }
  1181.     }
  1182.  
  1183.     set dir [lindex $args $idx]
  1184.     set patternList [lrange $args [expr {$idx + 1}] end]
  1185.     if {[llength $patternList] == 0} {
  1186.     set patternList [list "*.tcl" "*[info sharedlibextension]"]
  1187.     }
  1188.  
  1189.     append index "# Tcl package index file, version 1.1\n"
  1190.     append index "# This file is generated by the \"pkg_mkIndex$more\" command\n"
  1191.     append index "# and sourced either when an application starts up or\n"
  1192.     append index "# by a \"package unknown\" script.  It invokes the\n"
  1193.     append index "# \"package ifneeded\" command to set up package-related\n"
  1194.     append index "# information so that packages will be loaded automatically\n"
  1195.     append index "# in response to \"package require\" commands.  When this\n"
  1196.     append index "# script is sourced, the variable \$dir must contain the\n"
  1197.     append index "# full path name of this file's directory.\n"
  1198.     set oldDir [pwd]
  1199.     cd $dir
  1200.  
  1201.     if {[catch {eval glob $patternList} fileList]} {
  1202.     global errorCode errorInfo
  1203.     cd $oldDir
  1204.     return -code error -errorcode $errorCode -errorinfo $errorInfo $fileList
  1205.     }
  1206.     foreach file $fileList {
  1207.     # For each file, figure out what commands and packages it provides.
  1208.     # To do this, create a child interpreter, load the file into the
  1209.     # interpreter, and get a list of the new commands and packages
  1210.     # that are defined.
  1211.  
  1212.     if {[string compare $file "pkgIndex.tcl"] == 0} {
  1213.         continue
  1214.     }
  1215.  
  1216.     # Changed back to the original directory before initializing the
  1217.     # slave in case TCL_LIBRARY is a relative path (e.g. in the test
  1218.     # suite). 
  1219.  
  1220.     cd $oldDir
  1221.     set c [interp create]
  1222.  
  1223.     # Load into the child any packages currently loaded in the parent
  1224.     # interpreter that match the -load pattern.
  1225.  
  1226.     foreach pkg [info loaded] {
  1227.         if {! [string match $loadPat [lindex $pkg 1]]} {
  1228.         continue
  1229.         }
  1230.         if {[lindex $pkg 1] == "Tk"} {
  1231.         $c eval {set argv {-geometry +0+0}}
  1232.         }
  1233.         if {[catch {
  1234.         load [lindex $pkg 0] [lindex $pkg 1] $c
  1235.         } err]} {
  1236.         if {$doVerbose} {
  1237.             tclLog "warning: load [lindex $pkg 0] [lindex $pkg 1]\nfailed with: $err"
  1238.         }
  1239.         } else {
  1240.         if {$doVerbose} {
  1241.             tclLog "loaded [lindex $pkg 0] [lindex $pkg 1]"
  1242.         }
  1243.         }
  1244.     }
  1245.     cd $dir
  1246.  
  1247.     $c eval {
  1248.         # Stub out the package command so packages can
  1249.         # require other packages.
  1250.  
  1251.         rename package __package_orig
  1252.         proc package {what args} {
  1253.         switch -- $what {
  1254.             require { return ; # ignore transitive requires }
  1255.             default { eval __package_orig {$what} $args }
  1256.         }
  1257.         }
  1258.         proc tclPkgUnknown args {}
  1259.         package unknown tclPkgUnknown
  1260.  
  1261.         # Stub out the unknown command so package can call
  1262.         # into each other during their initialilzation.
  1263.  
  1264.         proc unknown {args} {}
  1265.  
  1266.         # Stub out the auto_import mechanism
  1267.  
  1268.         proc auto_import {args} {}
  1269.  
  1270.         # reserve the ::tcl namespace for support procs
  1271.         # and temporary variables.  This might make it awkward
  1272.         # to generate a pkgIndex.tcl file for the ::tcl namespace.
  1273.  
  1274.         namespace eval ::tcl {
  1275.         variable file        ;# Current file being processed
  1276.         variable direct        ;# -direct flag value
  1277.         variable x        ;# Loop variable
  1278.         variable debug        ;# For debugging
  1279.         variable type        ;# "load" or "source", for -direct
  1280.         variable namespaces    ;# Existing namespaces (e.g., ::tcl)
  1281.         variable packages    ;# Existing packages (e.g., Tcl)
  1282.         variable origCmds    ;# Existing commands
  1283.         variable newCmds    ;# Newly created commands
  1284.         variable newPkgs {}    ;# Newly created packages
  1285.         }
  1286.     }
  1287.  
  1288.     $c eval [list set ::tcl::file $file]
  1289.     $c eval [list set ::tcl::direct $direct]
  1290.     if {[catch {
  1291.         $c eval {
  1292.         set ::tcl::debug "loading or sourcing"
  1293.  
  1294.         # we need to track command defined by each package even in
  1295.         # the -direct case, because they are needed internally by
  1296.         # the "partial pkgIndex.tcl" step above.
  1297.  
  1298.         proc ::tcl::GetAllNamespaces {{root ::}} {
  1299.             set list $root
  1300.             foreach ns [namespace children $root] {
  1301.             eval lappend list [::tcl::GetAllNamespaces $ns]
  1302.             }
  1303.             return $list
  1304.         }
  1305.  
  1306.         # initialize the list of existing namespaces, packages, commands
  1307.  
  1308.         foreach ::tcl::x [::tcl::GetAllNamespaces] {
  1309.             set ::tcl::namespaces($::tcl::x) 1
  1310.         }
  1311.         foreach ::tcl::x [package names] {
  1312.             set ::tcl::packages($::tcl::x) 1
  1313.         }
  1314.         set ::tcl::origCmds [info commands]
  1315.  
  1316.         # Try to load the file if it has the shared library
  1317.         # extension, otherwise source it.  It's important not to
  1318.         # try to load files that aren't shared libraries, because
  1319.         # on some systems (like SunOS) the loader will abort the
  1320.         # whole application when it gets an error.
  1321.  
  1322.         if {[pkg_compareExtension $::tcl::file [info sharedlibextension]]} {
  1323.             # The "file join ." command below is necessary.
  1324.             # Without it, if the file name has no \'s and we're
  1325.             # on UNIX, the load command will invoke the
  1326.             # LD_LIBRARY_PATH search mechanism, which could cause
  1327.             # the wrong file to be used.
  1328.  
  1329.             set ::tcl::debug loading
  1330.             load [file join . $::tcl::file]
  1331.             set ::tcl::type load
  1332.         } else {
  1333.             set ::tcl::debug sourcing
  1334.             source $::tcl::file
  1335.             set ::tcl::type source
  1336.         }
  1337.  
  1338.         # See what new namespaces appeared, and import commands
  1339.         # from them.  Only exported commands go into the index.
  1340.  
  1341.         foreach ::tcl::x [::tcl::GetAllNamespaces] {
  1342.             if {! [info exists ::tcl::namespaces($::tcl::x)]} {
  1343.             namespace import ${::tcl::x}::*
  1344.             }
  1345.         }
  1346.  
  1347.         # Figure out what commands appeared
  1348.  
  1349.         foreach ::tcl::x [info commands] {
  1350.             set ::tcl::newCmds($::tcl::x) 1
  1351.         }
  1352.         foreach ::tcl::x $::tcl::origCmds {
  1353.             catch {unset ::tcl::newCmds($::tcl::x)}
  1354.         }
  1355.         foreach ::tcl::x [array names ::tcl::newCmds] {
  1356.             # reverse engineer which namespace a command comes from
  1357.             
  1358.             set ::tcl::abs [namespace origin $::tcl::x]
  1359.  
  1360.             # special case so that global names have no leading
  1361.             # ::, this is required by the unknown command
  1362.  
  1363.             set ::tcl::abs [auto_qualify $::tcl::abs ::]
  1364.  
  1365.             if {[string compare $::tcl::x $::tcl::abs] != 0} {
  1366.             # Name changed during qualification
  1367.  
  1368.             set ::tcl::newCmds($::tcl::abs) 1
  1369.             unset ::tcl::newCmds($::tcl::x)
  1370.             }
  1371.         }
  1372.  
  1373.         # Look through the packages that appeared, and if there is
  1374.         # a version provided, then record it
  1375.  
  1376.         foreach ::tcl::x [package names] {
  1377.             if {([string compare [package provide $::tcl::x] ""] != 0) \
  1378.                 && ![info exists ::tcl::packages($::tcl::x)]} {
  1379.             lappend ::tcl::newPkgs \
  1380.                 [list $::tcl::x [package provide $::tcl::x]]
  1381.             }
  1382.         }
  1383.         }
  1384.     } msg] == 1} {
  1385.         set what [$c eval set ::tcl::debug]
  1386.         if {$doVerbose} {
  1387.         tclLog "warning: error while $what $file: $msg"
  1388.         }
  1389.     } else {
  1390.         set type [$c eval set ::tcl::type]
  1391.         set cmds [lsort [$c eval array names ::tcl::newCmds]]
  1392.         set pkgs [$c eval set ::tcl::newPkgs]
  1393.         if {[llength $pkgs] > 1} {
  1394.         tclLog "warning: \"$file\" provides more than one package ($pkgs)"
  1395.         }
  1396.         foreach pkg $pkgs {
  1397.         # cmds is empty/not used in the direct case
  1398.         lappend files($pkg) [list $file $type $cmds]
  1399.         }
  1400.  
  1401.         if {$doVerbose} {
  1402.         tclLog "processed $file"
  1403.         }
  1404.     }
  1405.     interp delete $c
  1406.     }
  1407.  
  1408.     foreach pkg [lsort [array names files]] {
  1409.     append index "\npackage ifneeded $pkg "
  1410.     if {$direct} {
  1411.         set cmdList {}
  1412.         foreach elem $files($pkg) {
  1413.         set file [lindex $elem 0]
  1414.         set type [lindex $elem 1]
  1415.         lappend cmdList "\[list $type \[file join \$dir\
  1416.             [list $file]\]\]"
  1417.         }
  1418.         append index [join $cmdList "\\n"]
  1419.     } else {
  1420.         append index "\[list tclPkgSetup \$dir [lrange $pkg 0 0]\
  1421.             [lrange $pkg 1 1] [list $files($pkg)]\]"
  1422.     }
  1423.     }
  1424.     set f [open pkgIndex.tcl w]
  1425.     puts $f $index
  1426.     close $f
  1427.     cd $oldDir
  1428. }
  1429.  
  1430. # tclPkgSetup --
  1431. # This is a utility procedure use by pkgIndex.tcl files.  It is invoked
  1432. # as part of a "package ifneeded" script.  It calls "package provide"
  1433. # to indicate that a package is available, then sets entries in the
  1434. # auto_index array so that the package's files will be auto-loaded when
  1435. # the commands are used.
  1436. #
  1437. # Arguments:
  1438. # dir -            Directory containing all the files for this package.
  1439. # pkg -            Name of the package (no version number).
  1440. # version -        Version number for the package, such as 2.1.3.
  1441. # files -        List of files that constitute the package.  Each
  1442. #            element is a sub-list with three elements.  The first
  1443. #            is the name of a file relative to $dir, the second is
  1444. #            "load" or "source", indicating whether the file is a
  1445. #            loadable binary or a script to source, and the third
  1446. #            is a list of commands defined by this file.
  1447.  
  1448. proc tclPkgSetup {dir pkg version files} {
  1449.     global auto_index
  1450.  
  1451.     package provide $pkg $version
  1452.     foreach fileInfo $files {
  1453.     set f [lindex $fileInfo 0]
  1454.     set type [lindex $fileInfo 1]
  1455.     foreach cmd [lindex $fileInfo 2] {
  1456.         if {$type == "load"} {
  1457.         set auto_index($cmd) [list load [file join $dir $f] $pkg]
  1458.         } else {
  1459.         set auto_index($cmd) [list $type [file join $dir $f]]
  1460.         } 
  1461.     }
  1462.     }
  1463. }
  1464.  
  1465. # tclMacPkgSearch --
  1466. # The procedure is used on the Macintosh to search a given directory for files
  1467. # with a TEXT resource named "pkgIndex".  If it exists it is sourced in to the
  1468. # interpreter to setup the package database.
  1469.  
  1470. proc tclMacPkgSearch {dir} {
  1471.     foreach x [glob -nocomplain [file join $dir *.shlb]] {
  1472.     if {[file isfile $x]} {
  1473.         set res [resource open $x]
  1474.         foreach y [resource list TEXT $res] {
  1475.         if {$y == "pkgIndex"} {source -rsrc pkgIndex}
  1476.         }
  1477.         catch {resource close $res}
  1478.     }
  1479.     }
  1480. }
  1481.  
  1482. # tclPkgUnknown --
  1483. # This procedure provides the default for the "package unknown" function.
  1484. # It is invoked when a package that's needed can't be found.  It scans
  1485. # the auto_path directories and their immediate children looking for
  1486. # pkgIndex.tcl files and sources any such files that are found to setup
  1487. # the package database.  (On the Macintosh we also search for pkgIndex
  1488. # TEXT resources in all files.)
  1489. #
  1490. # Arguments:
  1491. # name -        Name of desired package.  Not used.
  1492. # version -        Version of desired package.  Not used.
  1493. # exact -        Either "-exact" or omitted.  Not used.
  1494.  
  1495. proc tclPkgUnknown {name version {exact {}}} {
  1496.     global auto_path tcl_platform env
  1497.  
  1498.     if {![info exists auto_path]} {
  1499.     return
  1500.     }
  1501.     for {set i [expr {[llength $auto_path] - 1}]} {$i >= 0} {incr i -1} {
  1502.     # we can't use glob in safe interps, so enclose the following
  1503.     # in a catch statement
  1504.     catch {
  1505.         foreach file [glob -nocomplain [file join [lindex $auto_path $i] \
  1506.             * pkgIndex.tcl]] {
  1507.         set dir [file dirname $file]
  1508.         if {[catch {source $file} msg]} {
  1509.             tclLog "error reading package index file $file: $msg"
  1510.         }
  1511.         }
  1512.         }
  1513.     set dir [lindex $auto_path $i]
  1514.     set file [file join $dir pkgIndex.tcl]
  1515.     # safe interps usually don't have "file readable", nor stderr channel
  1516.     if {[interp issafe] || [file readable $file]} {
  1517.         if {[catch {source $file} msg] && ![interp issafe]}  {
  1518.         tclLog "error reading package index file $file: $msg"
  1519.         }
  1520.     }
  1521.     # On the Macintosh we also look in the resource fork 
  1522.     # of shared libraries
  1523.     # We can't use tclMacPkgSearch in safe interps because it uses glob
  1524.     if {(![interp issafe]) && ($tcl_platform(platform) == "macintosh")} {
  1525.         set dir [lindex $auto_path $i]
  1526.         tclMacPkgSearch $dir
  1527.         foreach x [glob -nocomplain [file join $dir *]] {
  1528.         if {[file isdirectory $x]} {
  1529.             set dir $x
  1530.             tclMacPkgSearch $dir
  1531.         }
  1532.         }
  1533.     }
  1534.     }
  1535. }
  1536.