Merged changes between child workspace "/home/escoffon/ws/tcl8.0" and

 parent workspace "/ws/tcl8.0".

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