summaryrefslogtreecommitdiffstats
path: root/library/init.tcl
diff options
context:
space:
mode:
authorsurles <surles>1998-07-24 13:52:42 (GMT)
committersurles <surles>1998-07-24 13:52:42 (GMT)
commit4841d985076d6542845ccfa54efaba134c5180c9 (patch)
tree6a11ceb1497eb94cdaf4e37bcaec5aa8f1b6a350 /library/init.tcl
parentaaf71b185279c46208cedda0caf510bc43baa437 (diff)
downloadtcl-4841d985076d6542845ccfa54efaba134c5180c9.zip
tcl-4841d985076d6542845ccfa54efaba134c5180c9.tar.gz
tcl-4841d985076d6542845ccfa54efaba134c5180c9.tar.bz2
Removed changed from version 1.9
Diffstat (limited to 'library/init.tcl')
-rw-r--r--library/init.tcl371
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