Fixed pkg_mkIndex tcl to deal with failed loads.

1 files changed, 27 insertions, 5 deletions

diff --git a/library/init.tcl b/library/init.tcl
index 8b0f5e5..65d903e 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.
 #
-# RCS: @(#) $Id: init.tcl,v 1.21 1998/11/11 02:39:29 welch Exp $
+# RCS: @(#) $Id: init.tcl,v 1.22 1998/11/12 05:54:02 welch Exp $
 #
 # Copyright (c) 1991-1993 The Regents of the University of California.
 # Copyright (c) 1994-1996 Sun Microsystems, Inc.
@@ -1096,6 +1096,9 @@ proc pkg_compareExtension { fileName {ext {}} } {
 # -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.
+# -load pat		(optional) Preload any packages whose names match
+#			the pattern.  Used to handle DLLs that depend on
+#			other packages during their Init procedure.
 # 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
@@ -1104,7 +1107,7 @@ proc pkg_compareExtension { fileName {ext {}} } {
 
 proc pkg_mkIndex {args} {
     global errorCode errorInfo
-    set usage {"pkg_mkIndex ?-direct? ?-verbose? dir ?pattern ...?"};
+    set usage {"pkg_mkIndex ?-direct? ?-verbose? ?-load pattern? ?--? dir ?pattern ...?"};
 
     set argCount [llength $args]
     if {$argCount < 1} {
@@ -1114,6 +1117,7 @@ proc pkg_mkIndex {args} {
     set more ""
     set direct 0
     set doVerbose 0
+    set loadPat ""
     for {set idx 0} {$idx < $argCount} {incr idx} {
 	set flag [lindex $args $idx]
 	switch -glob -- $flag {
@@ -1129,6 +1133,11 @@ proc pkg_mkIndex {args} {
 		set direct 1
 		append more " -direct"
 	    }
+	    -load {
+		incr idx
+		set loadPat [lindex $args $idx]
+		append more " -load $loadPat"
+	    }
 	    -* {
 		return -code error "unknown flag $flag: should be\n$usage"
 	    }
@@ -1179,14 +1188,27 @@ proc pkg_mkIndex {args} {
 	cd $oldDir
 	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.
+	# Load into the child any packages currently loaded in the parent
+	# interpreter that match the -load pattern.
 
 	foreach pkg [info loaded] {
+	    if {! [string match $loadPat [lindex $pkg 1]]} {
+		continue
+	    }
 	    if {[lindex $pkg 1] == "Tk"} {
 		$c eval {set argv {-geometry +0+0}}
 	    }
-	    load [lindex $pkg 0] [lindex $pkg 1] $c
+	    if {[catch {
+		load [lindex $pkg 0] [lindex $pkg 1] $c
+	    } err]} {
+		if {$doVerbose} {
+		    tclLog "warning: load [lindex $pkg 0] [lindex $pkg 1]\nfailed with: $err"
+		}
+	    } else {
+		if {$doVerbose} {
+		    tclLog "loaded [lindex $pkg 0] [lindex $pkg 1]"
+		}
+	    }
 	}
 	cd $dir