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