diff options
Diffstat (limited to 'library/init.tcl')
| -rw-r--r-- | library/init.tcl | 434 |
1 files changed, 343 insertions, 91 deletions
diff --git a/library/init.tcl b/library/init.tcl index 76cec74..397ed41 100644 --- a/library/init.tcl +++ b/library/init.tcl @@ -3,7 +3,7 @@ # Default system startup file for Tcl-based applications. Defines # "unknown" procedure and auto-load facilities. # -# SCCS: %Z% $Id: init.tcl,v 1.2 1998/06/27 18:11:24 welch Exp $ +# SCCS: %Z% $Id: init.tcl,v 1.3 1998/07/02 17:52:32 escoffon Exp $ # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. @@ -581,20 +581,72 @@ proc auto_mkindex {dir args} { # files given as arguments. # # Arguments: +# -direct (optional) If this flag is present, the generated +# code in pkgMkIndex.tcl will cause the package to be +# loaded when "package require" is executed, rather +# than lazily when the first reference to an exported +# procedure in the package is made. +# -nopkgrequire (optional) If this flag is present, "package require" +# commands are ignored. This flag is useful in some +# situations, for example when there is a circularity +# in package requires (package a requires package b, +# which in turns requires package a). # dir - Name of the directory in which to create the index. # args - Any number of additional arguments, each giving # a glob pattern that matches the names of one or # more shared libraries or Tcl script files in # dir. -proc pkg_mkIndex {dir args} { +proc pkg_mkIndex {args} { global errorCode errorInfo - if {[llength $args] == 0} { - return -code error "wrong # args: should be\ - \"pkg_mkIndex dir pattern ?pattern ...?\""; + set usage {"pkg_mkIndex ?-nopkgrequire? ?-direct? dir ?pattern ...?"}; + + set argCount [llength $args] + if {$argCount < 1} { + return -code error "wrong # args: should be\n$usage" } - append index "# Tcl package index file, version 1.0\n" - append index "# This file is generated by the \"pkg_mkIndex\" command\n" + + set more "" + set direct 0 + set noPkgRequire 0 + for {set idx 0} {$idx < $argCount} {incr idx} { + set flag [lindex $args $idx] + switch -glob -- $flag { + -- { + # done with the flags + incr idx + break + } + + -direct { + set direct 1 + append more " -direct" + } + + -nopkgrequire { + set noPkgRequire 1 + append more " -nopkgrequire" + } + + -* { + return -code error "unknown flag $flag: should be\n$usage" + } + + default { + # done with the flags + break + } + } + } + + set dir [lindex $args $idx] + set patternList [lrange $args [expr $idx + 1] end] + if {[llength $patternList] == 0} { + set patternList [list "*.tcl" "*[info sharedlibextension]"] + } + + append index "# Tcl package index file, version 1.1\n" + append index "# This file is generated by the \"pkg_mkIndex$more\" command\n" append index "# and sourced either when an application starts up or\n" append index "# by a \"package unknown\" script. It invokes the\n" append index "# \"package ifneeded\" command to set up package-related\n" @@ -604,107 +656,307 @@ proc pkg_mkIndex {dir args} { append index "# full path name of this file's directory.\n" set oldDir [pwd] cd $dir - foreach file [eval glob $args] { - # For each file, figure out what commands and packages it provides. - # To do this, create a child interpreter, load the file into the - # interpreter, and get a list of the new commands and packages - # that are defined. Define an empty "package unknown" script so - # that there are no recursive package inclusions. - set c [interp create] + # In order to support building of index files from scratch, we make + # repeated passes on the files to index, until either all have been + # indexed, or we can no longer make any headway. - # If Tk is loaded in the parent interpreter, load it into the - # child also, in case the extension depends on it. + foreach file [eval glob $patternList] { + set toProcess($file) 1 + } - foreach pkg [info loaded] { - if {[lindex $pkg 1] == "Tk"} { - $c eval {set argv {-geometry +0+0}} - load [lindex $pkg 0] Tk $c - break + while {[array size toProcess] > 0} { + set processed 0 + + foreach file [array names toProcess] { + # For each file, figure out what commands and packages it provides. + # To do this, create a child interpreter, load the file into the + # interpreter, and get a list of the new commands and packages + # that are defined. The interpeter uses a special version of + # tclPkgSetup to force loading of required packages at require + # time rather than lazily, so that we can keep track of commands + # and packages that are defined indirectly rather than from the + # file itself. + + set c [interp create] + + # Load into the child all packages currently loaded in the parent + # interpreter, in case the extension depends on some of them. + + foreach pkg [info loaded] { + if {[lindex $pkg 1] == "Tk"} { + $c eval {set argv {-geometry +0+0}} + } + load [lindex $pkg 0] [lindex $pkg 1] $c } - } - $c eval [list set file $file] - if {[catch { - $c eval { - proc dummy args {} - rename package package-orig - proc package {what args} { - switch -- $what { - require { return ; # ignore transitive requires } - default { eval package-orig {$what} $args } + + + + + + + + + + + + + + + + + + + + + } + proc __dummy args {} + package unknown __dummy } - proc pkgGetAllNamespaces {{root {}}} { - set list $root - foreach ns [namespace children $root] { - eval lappend list [pkgGetAllNamespaces $ns] - } - return $list - } - package unknown dummy - set origCmds [info commands] - set dir "" ;# in case file is pkgIndex.tcl - set pkgs "" - - # Try to load the file if it has the shared library extension, - # otherwise source it. It's important not to try to load - # files that aren't shared libraries, because on some systems - # (like SunOS) the loader will abort the whole application - # when it gets an error. - - if {[string compare [file extension $file] \ - [info sharedlibextension]] == 0} { - - # The "file join ." command below is necessary. Without - # it, if the file name has no \'s and we're on UNIX, the - # load command will invoke the LD_LIBRARY_PATH search - # mechanism, which could cause the wrong file to be used. - - load [file join . $file] - set type load - } else { - source $file - set type source - } - foreach ns [pkgGetAllNamespaces] { - namespace import ${ns}::* - } - foreach i [info commands] { - set cmds($i) 1 + } else { + $c eval { + rename package __package_orig + proc package {what args} { + switch -- $what { + require { + eval __package_orig require $args + + # a package that was required needs to be + # placed in the list of packages to ignore. + # tclPkgSetup is unable to do it, so do it + # here. + + set ::__ignorePkgs([lindex $args 0]) 1 + } + + provide { + # if package provide is called at level 1 and + # with two arguments, then this package is + # being provided by one of the files we are + # indexing, and therefore we need to add it + # to the list of packages to write out. + # We need to do this check because otherwise + # packages that are spread over multiple + # files are indexed only by their first file + # loaded. + # Note that packages that this cannot catch + # packages that are implemented by a + # combination of TCL files and DLLs + + if {([info level] == 1) \ + && ([llength $args] == 2)} { + lappend ::__providedPkgs [lindex $args 0] + } + + eval __package_orig provide $args + } + + default { eval __package_orig {$what} $args } + } + } } - foreach i $origCmds { - catch {unset cmds($i)} + } - } - foreach i [array names cmds] { - # reverse engineer which namespace a command comes from - set absolute [namespace origin $i] - if {[string compare ::$i $absolute] != 0} { - set cmds($absolute) 1 - unset cmds($i) + $c eval [list set __file $file] + $c eval [list set __direct $direct] + if {[catch { + $c eval { + set __doingWhat "loading or sourcing" + + # override the tclPkgSetup procedure (which is called by + # package ifneeded statements from pkgIndex.tcl) to force + # loads of packages, and also keep track of + # packages/namespaces/commands that the load generated + + proc tclPkgSetup {dir pkg version files} { + # remember the current set of packages and commands, + # so that we can add any that were defined by the + # package files to the list of packages and commands + # to ignore + + foreach __p [package names] { + set __localIgnorePkgs($__p) 1 + } + foreach __ns [__pkgGetAllNamespaces] { + set __localIgnoreNs($__ns) 1 + } + foreach __cmd [info commands] { + set __localIgnoreCmds($__cmd) 1 + } + + # load the files that make up the package + + package provide $pkg $version + foreach __fileInfo $files { + set __f [lindex $__fileInfo 0] + set __type [lindex $__fileInfo 1] + if {$__type == "load"} { + load [file join $dir $__f] $pkg + } else { + source [file join $dir $__f] + } + } + + # packages and commands that were defined by these + # files are to be ignored. + + foreach __p [package names] { + if {[info exists __localIgnorePkgs($__p)] == 0} { + set ::__ignorePkgs($__p) 1 + } + } + foreach __ns [__pkgGetAllNamespaces] { + if {([info exists __localIgnoreNs($__ns)] == 0) \ + && ([info exists ::__ignoreNs($__ns)] == 0)} { + namespace import ${__ns}::* + set ::__ignoreNs($__ns) 1 + } + } + foreach __cmd [info commands] { + if {[info exists __localIgnoreCmds($__cmd)] == 0} { + lappend ::__ignoreCmds $__cmd + } + } } - } - foreach i [package names] { - if {([string compare [package provide $i] ""] != 0) - && ([string compare $i Tcl] != 0) - && ([string compare $i Tk] != 0)} { - lappend pkgs [list $i [package provide $i]] + + # we need to track command defined by each package even in + # the -direct case, because they are needed internally by + # the "partial pkgIndex.tcl" step above. + + proc __pkgGetAllNamespaces {{root {}}} { + set __list $root + foreach __ns [namespace children $root] { + eval lappend __list [__pkgGetAllNamespaces $__ns] + } + return $__list + } + set ::__ignoreCmds [info commands] + + # initialize the list of packages to ignore; these are + # packages that are present before the script/dll is loaded + + set ::__ignorePkgs(Tcl) 1 + set ::__ignorePkgs(Tk) 1 + foreach __pkg [package names] { + set ::__ignorePkgs($__pkg) 1 + } + + # before marking the original commands, import all the + # namespaces that may have been loaded from the parent; + # these namespaces and their commands are to be ignored + + foreach __ns [__pkgGetAllNamespaces] { + set ::__ignoreNs($__ns) 1 + namespace import ${__ns}::* } + + set dir "" ;# in case file is pkgIndex.tcl + + # Try to load the file if it has the shared library + # extension, otherwise source it. It's important not to + # try to load files that aren't shared libraries, because + # on some systems (like SunOS) the loader will abort the + # whole application when it gets an error. + + set __pkgs {} + set __providedPkgs {} + if {[string compare [file extension $__file] \ + [info sharedlibextension]] == 0} { + + # The "file join ." command below is necessary. + # Without it, if the file name has no \'s and we're + # on UNIX, the load command will invoke the + # LD_LIBRARY_PATH search mechanism, which could cause + # the wrong file to be used. + + set __doingWhat loading + load [file join . $__file] + set __type load + } else { + set __doingWhat sourcing + source $__file + set __type source + } + + # Using __ variable names to avoid potential namespaces + # clash, even here in post processing because the + # loaded package could have set up traces,... + + foreach __ns [__pkgGetAllNamespaces] { + if {[info exists ::__ignoreNs($__ns)] == 0} { + namespace import ${__ns}::* + } + } + foreach __i [info commands] { + set __cmds($__i) 1 + } + foreach __i $::__ignoreCmds { + catch {unset __cmds($__i)} + } + foreach __i [array names __cmds] { + # reverse engineer which namespace a command comes from + set __absolute [namespace origin $__i] + if {[string compare $__i $__absolute] != 0} { + set __cmds($__absolute) 1 + unset __cmds($__i) + } + } + + foreach __i $::__providedPkgs { + lappend __pkgs [list $__i [package provide $__i]] + set __ignorePkgs($__i) 1 + } + foreach __i [package names] { + if {([string compare [package provide $__i] ""] != 0) \ + && ([info exists ::__ignorePkgs($__i)] == 0)} { + lappend __pkgs [list $__i [package provide $__i]] + } + } + } + } msg] == 1} { + set what [$c eval set __doingWhat] + tclLog "warning: error while $what $file: $msg" + } else { + set type [$c eval set __type] + set cmds [lsort [$c eval array names __cmds]] + set pkgs [$c eval set __pkgs] + if {[llength $pkgs] > 1} { + tclLog "warning: \"$file\" provides more than one package ($pkgs)" + } + foreach pkg $pkgs { + # cmds is empty/not used in the direct case + lappend files($pkg) [list $file $type $cmds] } + + incr processed + unset toProcess($file) } - } msg]} { + tclLog "error while loading or sourcing $file: $msg" } - foreach pkg [$c eval set pkgs] { - lappend files($pkg) [list $file [$c eval set type] \ - [lsort [$c eval array names cmds]]] + + if {$processed == 0} { + tclLog "this iteration could not process any files: giving up here" + break } - interp delete $c } + foreach pkg [lsort [array names files]] { - append index "\npackage ifneeded $pkg\ - \[list tclPkgSetup \$dir [lrange $pkg 0 0] [lrange $pkg 1 1]\ - [list $files($pkg)]\]" + append index "\npackage ifneeded $pkg " + if {$direct} { + set cmdList {} + foreach elem $files($pkg) { + set file [lindex $elem 0] + set type [lindex $elem 1] + lappend cmdList "\[list $type \[file join \$dir\ + [list $file]\]\]" + } + append index [join $cmdList "\\n"] + } else { + append index "\[list tclPkgSetup \$dir [lrange $pkg 0 0]\ + [lrange $pkg 1 1] [list $files($pkg)]\]" + } } set f [open pkgIndex.tcl w] puts $f $index |