diff options
| -rw-r--r-- | library/init.tcl | 371 |
1 files changed, 52 insertions, 319 deletions
diff --git a/library/init.tcl b/library/init.tcl index 6c1aff9..7da05a5 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.9 1998/07/24 13:50:06 surles Exp $ +# SCCS: @(#) init.tcl 1.8 98/07/20 16:24:45 # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. @@ -97,6 +97,11 @@ 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 @@ -119,7 +124,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 @@ -246,9 +251,9 @@ proc unknown args { # 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 - + proc auto_load {cmd {namespace {}}} { + global auto_index auto_oldpath auto_path env errorInfo errorCode + if {[string length $namespace] == 0} { set namespace [uplevel {namespace current}] } @@ -265,34 +270,6 @@ proc auto_load {cmd {namespace {}}} { 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 @@ -340,7 +317,15 @@ proc auto_load_index {} { } } } - return 1 + foreach name $nameList { + if {[info exists auto_index($name)]} { + uplevel #0 $auto_index($name) + if {[info commands $name] != ""} { + return 1 + } + } + } + return 0 } # auto_qualify -- @@ -357,8 +342,8 @@ proc auto_load_index {} { # 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] @@ -402,33 +387,6 @@ proc auto_qualify {cmd namespace} { } } -# 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 -- @@ -565,31 +523,13 @@ 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. +# 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. # # Arguments: # dir - Name of the directory in which to create an index. @@ -597,17 +537,11 @@ if {[interp issafe]} { # names of files within dir. If no additional # are given auto_mkindex will look for *.tcl. -tcl_nonsafe proc auto_mkindex {dir args} { +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" @@ -619,243 +553,42 @@ tcl_nonsafe proc auto_mkindex {dir args} { set args *.tcl } foreach file [eval glob $args] { - if {[catch {auto_mkindex_parser::mkindex $file} msg] == 0} { - append index $msg - } else { + 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} { 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 - } - } + 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 } - - 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 |