summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorescoffon <escoffon>1998-07-02 17:52:32 (GMT)
committerescoffon <escoffon>1998-07-02 17:52:32 (GMT)
commit3cf78441c1c46145263d592325d158274af575a6 (patch)
treede2d3fd3eed049994deadd429b6639c7617d7d5a
parentee77e83f0be4a17dede324b514b611c4db8b60ad (diff)
downloadtcl-3cf78441c1c46145263d592325d158274af575a6.zip
tcl-3cf78441c1c46145263d592325d158274af575a6.tar.gz
tcl-3cf78441c1c46145263d592325d158274af575a6.tar.bz2
Merged changes between child workspace "/home/escoffon/ws/tcl8.0" and
parent workspace "/ws/tcl8.0".
-rw-r--r--library/init.tcl434
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