diff options
Diffstat (limited to 'library/package.tcl')
| -rw-r--r-- | library/package.tcl | 418 |
1 files changed, 331 insertions, 87 deletions
diff --git a/library/package.tcl b/library/package.tcl index 68c5053..9ab8231 100644 --- a/library/package.tcl +++ b/library/package.tcl @@ -20,6 +20,24 @@ # 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). +# -verbose (optional) Verbose output; the name of each file that +# was successfully rocessed is printed out. Additionally, +# if processing of a file failed a message is printed +# out; a file failure may not indicate that the indexing +# has failed, since pkg_mkIndex stores the list of failed +# files and tries again. The second time the processing +# may succeed, for example if a required package has been +# indexed by a previous pass. # 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 @@ -28,22 +46,57 @@ proc pkg_mkIndex {args} { global errorCode errorInfo - set first [lindex $args 0] - set direct [string match "-d*" $first] - set more "" - if {$direct} { - set args [lrange $args 1 end] - set more " -direct" + set usage {"pkg_mkIndex ?-nopkgrequire? ?-direct? ?-verbose? dir ?pattern ...?"}; + + set argCount [llength $args] + if {$argCount < 1} { + return -code error "wrong # args: should be\n$usage" } - if {[llength $args] == 0} { - return -code error "wrong # args: should be\ - \"pkg_mkIndex ?-direct? dir ?pattern ...?\""; + + set more "" + set direct 0 + set noPkgRequire 0 + set doVerbose 0 + for {set idx 0} {$idx < $argCount} {incr idx} { + set flag [lindex $args $idx] + switch -glob -- $flag { + -- { + # done with the flags + incr idx + break + } + + -verbose { + set doVerbose 1 + } + + -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 0] - set patternList [lrange $args 1 end] + + 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" @@ -55,121 +108,312 @@ proc pkg_mkIndex {args} { append index "# full path name of this file's directory.\n" set oldDir [pwd] cd $dir + + # 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. + foreach file [eval glob $patternList] { - # 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 toProcess($file) 1 + } - set c [interp create] + while {[array size toProcess] > 0} { + set processed 0 - # If Tk is loaded in the parent interpreter, load it into the - # child also, in case the extension depends on it. + 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. - foreach pkg [info loaded] { - if {[lindex $pkg 1] == "Tk"} { - $c eval {set argv {-geometry +0+0}} - load [lindex $pkg 0] Tk $c - break + 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] - $c eval [list set __direct $direct] - 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 [list $what] $args } + + # We also call package ifneeded for all packages that have been + # identified so far. This way, each pass will have loaded the + # equivalent of the pkgIndex.tcl file that we are constructing, + # and packages whose processing failed in previous passes may + # be processed successfully now + + foreach pkg [array names files] { + $c eval "package ifneeded $pkg\ + \[list tclPkgSetup $dir \ + [lrange $pkg 0 0] [lrange $pkg 1 1]\ + [list $files($pkg)]\]" + } + if {$noPkgRequire == 1} { + $c eval { + 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 } - if {!$__direct} { - proc __pkgGetAllNamespaces {{root {}}} { - set list $root - foreach ns [namespace children $root] { - eval lappend list [__pkgGetAllNamespaces $ns] + } 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 } } - return $list } - set __origCmds [info commands] } - package unknown __dummy + } - set dir "" ;# in case file is pkgIndex.tcl + $c eval [list set __file $file] + $c eval [list set __direct $direct] + if {[catch { + $c eval { + set __doingWhat "loading or sourcing" - # 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. + # 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 - if {[string compare [file extension $__file] \ - [info sharedlibextension]] == 0} { + 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 - # 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. + foreach __p [package names] { + set __localIgnorePkgs($__p) 1 + } + foreach __ns [__pkgGetAllNamespaces] { + set __localIgnoreNs($__ns) 1 + + # if the namespace is already in the __ignoreNs + # array, its commands have already been imported + + if {[info exists ::__ignoreNs($__ns)] == 0} { + namespace import ${__ns}::* + } + } + foreach __cmd [info commands] { + set __localIgnoreCmds($__cmd) 1 + } + + # load the files that make up the package - if {[catch {load [file join . $__file]} __msg]} { - tclLog "warning: error while loading $__file: $__msg" + 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 + } + } } - set __type load - } else { - if {[catch {source $__file} __msg]} { - tclLog "warning: error while sourcing $__file: $__msg" + + # 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 __type source - } - # Using __ variable names to avoid potential namespaces - # clash, even here in post processing because the - # loaded package could have set up traces,... - if {!$__direct} { + + # 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 ::__ignoreCmds [info commands] + + 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 $__origCmds { + 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} { + + # special case so that global names have no leading + # ::, this is required by the unknown command + + set __absolute [auto_qualify $__absolute ::] + + if {[string compare $__i $__absolute] != 0} { set __cmds($__absolute) 1 unset __cmds($__i) } } - } - set __pkgs {} - foreach __i [package names] { - if {([string compare [package provide $__i] ""] != 0) - && ([string compare $__i Tcl] != 0) - && ([string compare $__i Tk] != 0)} { + + 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] + if {$doVerbose} { + tclLog "warning: error while $what $file: $msg\nthis file will be retried in the next pass" + } + } 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) + + if {$doVerbose} { + tclLog "processed $file" + } } - } msg]} { - tclLog "error while loading or sourcing $file: $msg" - } - 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)" + interp delete $c } - foreach pkg $pkgs { - # cmds is empty/not used in the direct case - lappend files($pkg) [list $file $type $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 " if {$direct} { |