8.0.4 merge

6 files changed, 82 insertions, 77 deletions

diff --git a/library/auto.tcl b/library/auto.tcl
index 6f5e4e6..075a5d2 100644
--- a/library/auto.tcl
+++ b/library/auto.tcl
@@ -3,7 +3,7 @@
 # utility procs formerly in init.tcl dealing with auto execution
 # of commands and can be auto loaded themselves.
 #
-# RCS: @(#) $Id: auto.tcl,v 1.1.2.4 1998/11/11 04:08:24 stanton Exp $
+# RCS: @(#) $Id: auto.tcl,v 1.1.2.5 1998/12/02 20:08:05 welch Exp $
 #
 # Copyright (c) 1991-1993 The Regents of the University of California.
 # Copyright (c) 1994-1998 Sun Microsystems, Inc.
@@ -119,10 +119,6 @@ proc tcl_findLibrary {basename version patch initScript enVarName varName} {
 }
 
 
-# OPTIONAL SUPPORT PROCEDURES
-# In Tcl 8.1 all the code below here has been moved to other files to
-# reduce the size of init.tcl
-
 # ----------------------------------------------------------------------
 # auto_mkindex
 # ----------------------------------------------------------------------
@@ -134,9 +130,7 @@ proc tcl_findLibrary {basename version patch initScript enVarName varName} {
 # special parser and mess with its commands.  
 
 if {[interp issafe]} {
-    proc auto_mkindex {dir args} {
-        error "can't generate index within safe interpreter"
-    }
+    return	;# Stop sourcing the file here
 }
 
 # auto_mkindex --
diff --git a/library/init.tcl b/library/init.tcl
index 8e9d3f3..c069037 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.1.2.3 1998/11/11 04:08:24 stanton Exp $
+# RCS: @(#) $Id: init.tcl,v 1.1.2.4 1998/12/02 20:08:05 welch Exp $
 #
 # Copyright (c) 1991-1993 The Regents of the University of California.
 # Copyright (c) 1994-1996 Sun Microsystems, Inc.
@@ -95,7 +95,6 @@ if {(![interp issafe]) && ($tcl_platform(platform) == "windows")} {
     }
 }
 
-
 # Setup the unknown package handler
 
 package unknown tclPkgUnknown
diff --git a/library/ldAout.tcl b/library/ldAout.tcl
index 788f5cf..f316e0e 100644
--- a/library/ldAout.tcl
+++ b/library/ldAout.tcl
@@ -18,7 +18,7 @@
 #	its .o file placed before all others in the command; then
 #	"ld" is executed to bind the objects together.
 #
-# RCS: @(#) $Id: ldAout.tcl,v 1.1.2.1 1998/09/24 23:59:06 stanton Exp $
+# RCS: @(#) $Id: ldAout.tcl,v 1.1.2.2 1998/12/02 20:08:06 welch Exp $
 #
 # Copyright (c) 1995, by General Electric Company. All rights reserved.
 #
@@ -98,9 +98,9 @@ proc tclLdAout {{cc {}} {shlib_suffix {}} {shlib_cflags none}} {
     } elseif {![string compare $a -o]} {
       set minusO 1
     }
-    if [regexp {^-[lL]} $a] {
+    if {[regexp {^-[lL]} $a]} {
 	lappend libraries $a
-	if [regexp {^-L} $a] {
+	if {[regexp {^-L} $a]} {
 	    lappend libdirs [string range $a 2 end]
 	}
     } elseif {$seenDotO} {
@@ -116,10 +116,10 @@ proc tclLdAout {{cc {}} {shlib_suffix {}} {shlib_cflags none}} {
 
   set libs {}
   foreach lib $libraries {
-      if [regexp {^-l} $lib] {
+      if {[regexp {^-l} $lib]} {
 	  set lname [string range $lib 2 end]
 	  foreach dir $libdirs {
-	      if [file exists [file join $dir lib${lname}_G0.a]] {
+	      if {[file exists [file join $dir lib${lname}_G0.a]]} {
 		  set lname ${lname}_G0
 		  break
 	      }
@@ -137,22 +137,22 @@ proc tclLdAout {{cc {}} {shlib_suffix {}} {shlib_cflags none}} {
     error "-o option must be supplied to link a Tcl load module"
   }
   set m [file tail $outputFile]
-  if [regexp {\.a$} $outputFile] {
+  if {[regexp {\.a$} $outputFile]} {
     set shlib_suffix .a
   } else {
     set shlib_suffix ""
   }
-  if [regexp {\..*$} $outputFile match] {
-    set l [expr [string length $m] - [string length $match]]
+  if {[regexp {\..*$} $outputFile match]} {
+    set l [expr {[string length $m] - [string length $match]}]
   } else {
     error "Output file does not appear to have a suffix"
   }
-  set modName [string tolower [string range $m 0 [expr $l-1]]]
-  if [regexp {^lib} $modName] {
+  set modName [string tolower [string range $m 0 [expr {$l-1}]]]
+  if {[regexp {^lib} $modName]} {
     set modName [string range $modName 3 end]
   }
-  if [regexp {[0-9\.]*(_g0)?$} $modName match] {
-    set modName [string range $modName 0 [expr [string length $modName]-[string length $match]-1]]
+  if {[regexp {[0-9\.]*(_g0)?$} $modName match]} {
+    set modName [string range $modName 0 [expr {[string length $modName]-[string length $match]-1}]]
   }
   set modName "[string toupper [string index $modName 0]][string range $modName 1 end]"
   
@@ -160,7 +160,7 @@ proc tclLdAout {{cc {}} {shlib_suffix {}} {shlib_cflags none}} {
 
   set f [open $nmCommand r]
   while {[gets $f l] >= 0} {
-    if [regexp {T[ 	]*_?([A-Z][a-z0-9_]*_(Safe)?Init(__FP10Tcl_Interp)?)$} $l trash symbol] {
+    if {[regexp {T[ 	]*_?([A-Z][a-z0-9_]*_(Safe)?Init(__FP10Tcl_Interp)?)$} $l trash symbol]} {
       if {![regexp {_?([A-Z][a-z0-9_]*_(Safe)?Init)} $symbol trash s]} {
 	set s $symbol
       }
@@ -219,10 +219,10 @@ proc tclLdAout {{cc {}} {shlib_suffix {}} {shlib_cflags none}} {
     set ldCommand "ar cr $outputFile"
     regsub { -o} $tail {} tail
   } else {
-  set ldCommand ld
-  foreach item $head {
-    lappend ldCommand $item
-  }
+    set ldCommand ld
+    foreach item $head {
+      lappend ldCommand $item
+    }
   }
   lappend ldCommand tcl$modName.o
   foreach item $tail {
diff --git a/library/package.tcl b/library/package.tcl
index e44c0b2..437aa6a 100644
--- a/library/package.tcl
+++ b/library/package.tcl
@@ -3,7 +3,7 @@
 # utility procs formerly in init.tcl which can be loaded on demand
 # for package management.
 #
-# RCS: @(#) $Id: package.tcl,v 1.1.2.4 1998/11/11 04:08:25 stanton Exp $
+# RCS: @(#) $Id: package.tcl,v 1.1.2.5 1998/12/02 20:08:06 welch Exp $
 #
 # Copyright (c) 1991-1993 The Regents of the University of California.
 # Copyright (c) 1994-1998 Sun Microsystems, Inc.
@@ -27,20 +27,16 @@
 # Results:
 #  Returns 1 if the extension matches, 0 otherwise
 
-if {$::tcl_platform(platform) == "windows"} {
-    proc pkg_compareExtension { fileName {ext {}} } {
-	if {[string compare $ext {}] == 0} {
-	    set ext [info sharedlibextension]
-	}
+proc pkg_compareExtension { fileName {ext {}} } {
+    global tcl_platform
+    if {[string length $ext] == 0} {
+	set ext [info sharedlibextension]
+    }
+    if {[string compare $tcl_platform(platform) "windows"] == 0} {
 	return [expr {[string compare \
 		[string tolower [file extension $fileName]] \
 		[string tolower $ext]] == 0}]
-    }
-} else {
-    proc pkg_compareExtension { fileName {ext {}} } {
-	if {[string compare $ext {}] == 0} {
-	    set ext [info sharedlibextension]
-	}
+    } else {
 	return [expr {[string compare [file extension $fileName] $ext] == 0}]
     }
 }
@@ -61,6 +57,9 @@ if {$::tcl_platform(platform) == "windows"} {
 # -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
@@ -69,7 +68,7 @@ if {$::tcl_platform(platform) == "windows"} {
 
 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} {
@@ -79,6 +78,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 {
@@ -94,6 +94,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"
 	    }
@@ -144,14 +149,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
 
@@ -198,6 +216,15 @@ proc pkg_mkIndex {args} {
 
 	$c eval [list set ::tcl::file $file]
 	$c eval [list set ::tcl::direct $direct]
+
+	# Download needed procedures into the slave because we've
+	# just deleted the unknown procedure.  This doesn't handle
+	# procedures with default arguments.
+
+	foreach p {pkg_compareExtension} {
+	    $c eval [list proc $p [info args $p] [info body $p]]
+	}
+
 	if {[catch {
 	    $c eval {
 		set ::tcl::debug "loading or sourcing"
@@ -312,8 +339,8 @@ proc pkg_mkIndex {args} {
 	    if {$doVerbose} {
 		tclLog "processed $file"
 	    }
+	    interp delete $c
 	}
-	interp delete $c
     }
 
     foreach pkg [lsort [array names files]] {
@@ -444,5 +471,3 @@ proc tclPkgUnknown {name version {exact {}}} {
 	}
     }
 }
-
-
diff --git a/library/safe.tcl b/library/safe.tcl
index 0ee3a92..76d4d29 100644
--- a/library/safe.tcl
+++ b/library/safe.tcl
@@ -12,7 +12,7 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: safe.tcl,v 1.1.2.2 1998/09/24 23:59:07 stanton Exp $
+# RCS: @(#) $Id: safe.tcl,v 1.1.2.3 1998/12/02 20:08:06 welch Exp $
 
 #
 # The implementation is based on namespaces. These naming conventions
@@ -32,12 +32,6 @@ namespace eval ::safe {
 	    interpAddToAccessPath interpFindInAccessPath \
 	    setLogCmd ;
 
-# Proto/dummy declarations for auto_mkIndex
-proc ::safe::interpCreate {} {}
-proc ::safe::interpInit {} {}
-proc ::safe::interpConfigure {} {}
-
-
     ####
     #
     # Setup the arguments parsing
diff --git a/library/tclIndex b/library/tclIndex
index 33701bf..35c7cf6 100644
--- a/library/tclIndex
+++ b/library/tclIndex
@@ -6,6 +6,18 @@
 # element name is the name of a command and the value is
 # a script that loads the command.
 
+set auto_index(auto_reset) [list source [file join $dir auto.tcl]]
+set auto_index(tcl_findLibrary) [list source [file join $dir auto.tcl]]
+set auto_index(auto_mkindex) [list source [file join $dir auto.tcl]]
+set auto_index(auto_mkindex_old) [list source [file join $dir auto.tcl]]
+set auto_index(::auto_mkindex_parser::init) [list source [file join $dir auto.tcl]]
+set auto_index(::auto_mkindex_parser::cleanup) [list source [file join $dir auto.tcl]]
+set auto_index(::auto_mkindex_parser::mkindex) [list source [file join $dir auto.tcl]]
+set auto_index(::auto_mkindex_parser::hook) [list source [file join $dir auto.tcl]]
+set auto_index(::auto_mkindex_parser::slavehook) [list source [file join $dir auto.tcl]]
+set auto_index(::auto_mkindex_parser::command) [list source [file join $dir auto.tcl]]
+set auto_index(::auto_mkindex_parser::commandInit) [list source [file join $dir auto.tcl]]
+set auto_index(::auto_mkindex_parser::fullname) [list source [file join $dir auto.tcl]]
 set auto_index(history) [list source [file join $dir history.tcl]]
 set auto_index(::tcl::HistAdd) [list source [file join $dir history.tcl]]
 set auto_index(::tcl::HistKeep) [list source [file join $dir history.tcl]]
@@ -15,16 +27,13 @@ set auto_index(::tcl::HistRedo) [list source [file join $dir history.tcl]]
 set auto_index(::tcl::HistIndex) [list source [file join $dir history.tcl]]
 set auto_index(::tcl::HistEvent) [list source [file join $dir history.tcl]]
 set auto_index(::tcl::HistChange) [list source [file join $dir history.tcl]]
-set auto_index(unknown) [list source [file join $dir init.tcl]]
-set auto_index(auto_load) [list source [file join $dir init.tcl]]
-set auto_index(auto_load_index) [list source [file join $dir init.tcl]]
-set auto_index(auto_qualify) [list source [file join $dir init.tcl]]
-set auto_index(auto_import) [list source [file join $dir init.tcl]]
 set auto_index(tclLdAout) [list source [file join $dir ldAout.tcl]]
+set auto_index(pkg_compareExtension) [list source [file join $dir package.tcl]]
+set auto_index(pkg_mkIndex) [list source [file join $dir package.tcl]]
+set auto_index(tclPkgSetup) [list source [file join $dir package.tcl]]
+set auto_index(tclMacPkgSearch) [list source [file join $dir package.tcl]]
+set auto_index(tclPkgUnknown) [list source [file join $dir package.tcl]]
 set auto_index(parray) [list source [file join $dir parray.tcl]]
-set auto_index(::safe::interpCreate) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::interpInit) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::interpConfigure) [list source [file join $dir safe.tcl]]
 set auto_index(::safe::InterpStatics) [list source [file join $dir safe.tcl]]
 set auto_index(::safe::InterpNested) [list source [file join $dir safe.tcl]]
 set auto_index(::safe::interpCreate) [list source [file join $dir safe.tcl]]
@@ -70,19 +79,3 @@ set auto_index(tcl_wordBreakBefore) [list source [file join $dir word.tcl]]
 set auto_index(tcl_endOfWord) [list source [file join $dir word.tcl]]
 set auto_index(tcl_startOfNextWord) [list source [file join $dir word.tcl]]
 set auto_index(tcl_startOfPreviousWord) [list source [file join $dir word.tcl]]
-set auto_index(auto_reset) [list source [file join $dir auto.tcl]]
-set auto_index(tcl_findLibrary) [list source [file join $dir auto.tcl]]
-set auto_index(auto_mkindex) [list source [file join $dir auto.tcl]]
-set auto_index(auto_mkindex_old) [list source [file join $dir auto.tcl]]
-set auto_index(::auto_mkindex_parser::init) [list source [file join $dir auto.tcl]]
-set auto_index(::auto_mkindex_parser::cleanup) [list source [file join $dir auto.tcl]]
-set auto_index(::auto_mkindex_parser::mkindex) [list source [file join $dir auto.tcl]]
-set auto_index(::auto_mkindex_parser::hook) [list source [file join $dir auto.tcl]]
-set auto_index(::auto_mkindex_parser::slavehook) [list source [file join $dir auto.tcl]]
-set auto_index(::auto_mkindex_parser::command) [list source [file join $dir auto.tcl]]
-set auto_index(::auto_mkindex_parser::commandInit) [list source [file join $dir auto.tcl]]
-set auto_index(::auto_mkindex_parser::fullname) [list source [file join $dir auto.tcl]]
-set auto_index(pkg_mkIndex) [list source [file join $dir package.tcl]]
-set auto_index(tclPkgSetup) [list source [file join $dir package.tcl]]
-set auto_index(tclMacPkgSearch) [list source [file join $dir package.tcl]]
-set auto_index(tclPkgUnknown) [list source [file join $dir package.tcl]]