Updated core w/ Micheals latest changes.

1 files changed, 319 insertions, 52 deletions

diff --git a/library/init.tcl b/library/init.tcl
index 8b6ca1a..6c1aff9 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.8 1998/07/20 16:24:45 welch Exp $ 
+# SCCS: %Z% $Id: init.tcl,v 1.9 1998/07/24 13:50:06 surles Exp $ 
 #
 # Copyright (c) 1991-1993 The Regents of the University of California.
 # Copyright (c) 1994-1996 Sun Microsystems, Inc.
@@ -97,11 +97,6 @@ if {[info commands tclLog] == ""} {
     }
 }
 
-# The procs defined in this file that have a leading space
-# are 'hidden' from auto_mkindex because they are not
-# auto-loadable.
-
-
 # unknown --
 # This procedure is called when a Tcl command is invoked that doesn't
 # exist in the interpreter.  It takes the following steps to make the
@@ -124,7 +119,7 @@ if {[info commands tclLog] == ""} {
 # args -	A list whose elements are the words of the original
 #		command, including the command name.
 
- proc unknown args {
+proc unknown args {
     global auto_noexec auto_noload env unknown_pending tcl_interactive
     global errorCode errorInfo
 
@@ -251,9 +246,9 @@ if {[info commands tclLog] == ""} {
 #                       a canonical namespace as returned [namespace current]
 #                       for instance. If not given, namespace current is used.
 
- proc auto_load {cmd {namespace {}}} {
-    global auto_index auto_oldpath auto_path env errorInfo errorCode
-
+proc auto_load {cmd {namespace {}}} {
+    global auto_index auto_oldpath auto_path
+    
     if {[string length $namespace] == 0} {
 	set namespace [uplevel {namespace current}]
     }
@@ -270,6 +265,34 @@ if {[info commands tclLog] == ""} {
     if {![info exists auto_path]} {
 	return 0
     }
+    
+    if {![auto_load_index]} {
+ 	return 0
+    }
+    
+    foreach name $nameList {
+ 	if {[info exists auto_index($name)]} {
+ 	    uplevel #0 $auto_index($name)
+ 	    if {[info commands $name] != ""} {
+ 		return 1
+ 	    }
+ 	}
+    }
+    return 0
+}
+
+# auto_load_index --
+# Loads the contents of tclIndex files on the auto_path directory
+# list.  This is usually invoked within auto_load to load the index
+# of available commands.  Returns 1 if the index is loaded, and 0 if
+# the index is already loaded and up to date.
+#
+# Arguments: 
+# None.
+
+proc auto_load_index {} {
+    global auto_index auto_oldpath auto_path errorInfo errorCode
+    
     if {[info exists auto_oldpath]} {
 	if {$auto_oldpath == $auto_path} {
 	    return 0
@@ -317,15 +340,7 @@ if {[info commands tclLog] == ""} {
 	    }
 	}
     }
-    foreach name $nameList {
-	if {[info exists auto_index($name)]} {
-	    uplevel #0 $auto_index($name)
-	    if {[info commands $name] != ""} {
-		return 1
-	    }
-	}
-    }
-    return 0
+    return 1
 }
 
 # auto_qualify --
@@ -342,8 +357,8 @@ if {[info commands tclLog] == ""} {
 #               a canonical namespace as returned by [namespace current]
 #               for instance.
 
- proc auto_qualify {cmd namespace} {
-
+proc auto_qualify {cmd namespace} {
+    
     # count separators and clean them up
     # (making sure that foo:::::bar will be treated as foo::bar)
     set n [regsub -all {::+} $cmd :: cmd]
@@ -387,6 +402,33 @@ if {[info commands tclLog] == ""} {
     }
 }
 
+# auto_import --
+# invoked during "namespace import" to make see if the imported commands
+# reside in an autoloaded library.  If so, the commands are loaded so
+# that they will be available for the import links.  If not, then this
+# procedure does nothing.
+#
+# Arguments -
+# pattern	The pattern of commands being imported (like "foo::*")
+#               a canonical namespace as returned by [namespace current]
+
+proc auto_import {pattern} {
+    global auto_index
+    
+    set ns [uplevel namespace current]
+    set patternList [auto_qualify $pattern $ns]
+    
+    auto_load_index
+    
+    foreach pattern $patternList {
+	foreach name [array names auto_index] {
+	    if {[string match $pattern $name] && "" == [info commands $name]} {
+		uplevel #0 $auto_index($name)
+	    }
+	}
+    }
+}
+
 if {[string compare $tcl_platform(platform) windows] == 0} {
 
 # auto_execok --
@@ -523,13 +565,31 @@ proc auto_reset {} {
     catch {unset auto_oldpath}
 }
 
+# ----------------------------------------------------------------------
+# auto_mkindex
+# ----------------------------------------------------------------------
+# The following procedures are used to generate the tclIndex file
+# from Tcl source files.  They use a special safe interpreter to
+# parse Tcl source files, writing out index entries as "proc"
+# commands are encountered.  This implementation won't work in a
+# safe interpreter, since a safe interpreter can't create the
+# special parser and mess with its commands.  If this is a safe
+# interpreter, we simply clip these procs out.
+
+if {[interp issafe]} {
+    proc auto_mkindex {dir args} {
+	error "can't generate index within safe interpreter"
+    }
+    proc tcl_nonsafe {args} {}
+} else {
+    proc tcl_nonsafe {args} {eval $args}
+}
+
 # auto_mkindex --
 # Regenerate a tclIndex file from Tcl source files.  Takes as argument
 # the name of the directory in which the tclIndex file is to be placed,
 # followed by any number of glob patterns to use in that directory to
-# locate all of the relevant files. It does not parse or source the file
-# so the generated index will not contain the appropriate namespace qualifiers
-# if you don't explicitly specify it.
+# locate all of the relevant files.
 #
 # Arguments: 
 # dir -			Name of the directory in which to create an index.
@@ -537,11 +597,17 @@ proc auto_reset {} {
 #			names of files within dir.  If no additional
 #			are given auto_mkindex will look for *.tcl.
 
-proc auto_mkindex {dir args} {
+tcl_nonsafe proc auto_mkindex {dir args} {
     global errorCode errorInfo
+    
+    if {[interp issafe]} {
+	error "can't generate index within safe interpreter"
+    }
+    
     set oldDir [pwd]
     cd $dir
     set dir [pwd]
+
     append index "# Tcl autoload index file, version 2.0\n"
     append index "# This file is generated by the \"auto_mkindex\" command\n"
     append index "# and sourced to set up indexing information for one or\n"
@@ -553,42 +619,243 @@ proc auto_mkindex {dir args} {
 	set args *.tcl
     }
     foreach file [eval glob $args] {
-	set f ""
-	set error [catch {
-	    set f [open $file]
-	    while {[gets $f line] >= 0} {
-		if {[regexp {^proc[ 	]+([^ 	]*)} $line match procName]} {
-		    set procName [lindex [auto_qualify $procName "::"] 0]
-		    append index "set [list auto_index($procName)]"
-		    append index " \[list source \[file join \$dir [list $file]\]\]\n"
-		}
-	    }
-	    close $f
-	} msg]
-	if {$error} {
+	if {[catch {auto_mkindex_parser::mkindex $file} msg] == 0} {
+	    append index $msg
+	} else {
 	    set code $errorCode
 	    set info $errorInfo
-	    catch {close $f}
 	    cd $oldDir
 	    error $msg $info $code
 	}
     }
-    set f ""
-    set error [catch {
-	set f [open tclIndex w]
-	puts $f $index nonewline
-	close $f
-	cd $oldDir
-    } msg]
-    if {$error} {
-	set code $errorCode
-	set info $errorInfo
-	catch {close $f}
-	cd $oldDir
-	error $msg $info $code
+    
+    set fid [open "tclIndex" w]
+    puts $fid $index nonewline
+    close $fid
+    cd $oldDir
+}
+
+#
+# Create a safe interpreter that can be used to parse Tcl source files
+# generate a tclIndex file for autoloading.  This interp contains
+# commands for things that need index entries.  Each time a command
+# is executed, it writes an entry out to the index file.
+#
+tcl_nonsafe namespace eval auto_mkindex_parser {
+    variable parser ""          ;# parser used to build index
+    variable index ""           ;# maintains index as it is built
+    variable scriptFile ""      ;# name of file being processed
+    variable contextStack ""    ;# stack of namespace scopes
+    variable imports ""         ;# keeps track of all imported cmds
+    
+    if {![interp issafe]} {
+	set parser [interp create -safe]
+	$parser hide info
+	$parser hide rename
+	$parser hide proc
+	$parser hide namespace
+	$parser hide eval
+	$parser hide puts
+	$parser invokehidden namespace delete ::
+	$parser invokehidden proc unknown {args} {}
+	
+	#
+	# We'll need access to the "namespace" command within the
+	# interp.  Put it back, but move it out of the way.
+	#
+	$parser expose namespace
+	$parser invokehidden rename namespace _%@namespace
+	$parser expose eval
+	$parser invokehidden rename eval _%@eval
+    }
+}
+
+# auto_mkindex_parser::mkindex --
+# Used by the "auto_mkindex" command to create a "tclIndex" file for
+# the given Tcl source file.  Executes the commands in the file, and
+# handles things like the "proc" command by adding an entry for the
+# index file.  Returns a string that represents the index file.
+#
+# Arguments: 
+# file -		Name of Tcl source file to be indexed.
+#
+tcl_nonsafe proc auto_mkindex_parser::mkindex {file} {
+    variable parser
+    variable index
+    variable scriptFile
+    variable contextStack
+    variable imports
+    
+    set scriptFile $file
+    
+    set fid [open $file]
+    set contents [read $fid]
+    close $fid
+    
+    #
+    # There is one problem with sourcing files into the safe
+    # interpreter:  references like "$x" will fail since code is not
+    # really being executed and variables do not really exist.
+    # Be careful to escape all naked "$" before evaluating.
+    #
+    regsub -all {([^\$])\$([^\$])} $contents {\1\\$\2} contents
+    
+    set index ""
+    set contextStack ""
+    set imports ""
+    
+    $parser eval $contents
+    
+    foreach name $imports {
+	catch {$parser eval [list _%@namespace forget $name]}
+    }
+    return $index
+}
+
+#
+# auto_mkindex_parser::command --
+# Registers a new command with the "auto_mkindex_parser" interpreter
+# that parses Tcl files.  These commands are fake versions of things
+# like the "proc" command.  When you execute them, they simply write
+# out an entry to a "tclIndex" file for auto-loading.
+#
+# This procedure allows extensions to register their own commands
+# with the auto_mkindex facility.  For example, a package like
+# [incr Tcl] might register a "class" command so that class definitions
+# could be added to a "tclIndex" file for auto-loading.
+#
+# Arguments:
+# name -		Name of command recognized in Tcl files.
+# arglist -		Argument list for command.
+# body -		Implementation of command to handle indexing.
+#
+tcl_nonsafe proc auto_mkindex_parser::command {name arglist body} {
+    variable parser
+    
+    set ns [namespace qualifiers $name]
+    set tail [namespace tail $name]
+    if {$ns == ""} {
+	set fakeName "[namespace current]::_%@fake_$tail"
+    } else {
+	set fakeName "_%@fake_$name"
+	regsub -all {::} $fakeName "_" fakeName
+	set fakeName "[namespace current]::$fakeName"
+    }
+    proc $fakeName $arglist $body
+    
+    #
+    # YUK!  Tcl won't let us alias fully qualified command names,
+    # so we can't handle names like "::itcl::class".  Instead,
+    # we have to build procs with the fully qualified names, and
+    # have the procs point to the aliases.
+    #
+    if {[regexp {::} $name]} {
+	set exportCmd [list _%@namespace export [namespace tail $name]]
+	$parser eval [list _%@namespace eval $ns $exportCmd]
+	set alias [namespace tail $fakeName]
+	$parser invokehidden proc $name {args} "_%@eval $alias \$args"
+	$parser alias $alias $fakeName
+    } else {
+	$parser alias $name $fakeName
+    }
+    return
+}
+
+# auto_mkindex_parser::fullname --
+# Used by commands like "proc" within the auto_mkindex parser.
+# Returns the qualified namespace name for the "name" argument.
+# If the "name" does not start with "::", elements are added from
+# the current namespace stack to produce a qualified name.  Then,
+# the name is examined to see whether or not it should really be
+# qualified.  If the name has more than the leading "::", it is
+# returned as a fully qualified name.  Otherwise, it is returned
+# as a simple name.  That way, the Tcl autoloader will recognize
+# it properly.
+#
+# Arguments:
+# name -		Name that is being added to index.
+#
+tcl_nonsafe proc auto_mkindex_parser::fullname {name} {
+    variable contextStack
+    
+    if {![string match ::* $name]} {
+	foreach ns $contextStack {
+	    set name "${ns}::$name"
+	    if {[string match ::* $name]} {
+		break
+	    }
+	}
     }
+    
+    if {[namespace qualifiers $name] == ""} {
+	return [namespace tail $name]
+    } elseif {![string match ::* $name]} {
+	return "::$name"
+    }
+    return $name
 }
 
+#
+# Now define all of the procedures for the auto_mkindex parser that
+# will build the "tclIndex" file...
+#
+
+#
+# AUTO MKINDEX:  proc name arglist body
+# Adds an entry to the auto index list for the given procedure name.
+#
+tcl_nonsafe auto_mkindex_parser::command proc {name args} {
+    variable index
+    variable scriptFile
+    append index "set [list auto_index([fullname $name])]"
+    append index " \[list source \[file join \$dir [list $scriptFile]\]\]\n"
+}
+
+#
+# AUTO MKINDEX:  namespace eval name command ?arg arg...?
+# Adds the namespace name onto the context stack and evaluates the
+# associated body of commands.
+#
+# AUTO MKINDEX:  namespace import ?-force? pattern ?pattern...?
+# Performs the "import" action in the parser interpreter.  This is
+# important for any commands contained in a namespace that affect
+# the index.  For example, a script may say "itcl::class ...",
+# or it may import "itcl::*" and then say "class ...".  This
+# procedure does the import operation, but keeps track of imported
+# patterns so we can remove the imports later.
+#
+tcl_nonsafe auto_mkindex_parser::command namespace {op args} {
+    switch -- $op {
+	eval {
+	    variable parser
+	    variable contextStack
+	    
+	    set name [lindex $args 0]
+	    set args [lrange $args 1 end]
+	    
+	    set contextStack [linsert $contextStack 0 $name]
+	    if {[llength $args] == 1} {
+		$parser eval [lindex $args 0]
+	    } else {
+		eval $parser eval $args
+	    }
+	    set contextStack [lrange $contextStack 1 end]
+	}
+	import {
+	    variable parser
+	    variable imports
+	    foreach pattern $args {
+		if {$pattern != "-force"} {
+		    lappend imports $pattern
+		}
+	    }
+	    catch {$parser eval "_%@namespace import $args"}
+	}
+    }
+}
+
+rename tcl_nonsafe ""
+
 # pkg_mkIndex --
 # This procedure creates a package index in a given directory.  The
 # package index consists of a "pkgIndex.tcl" file whose contents are