diff options
Diffstat (limited to 'library/auto.tcl')
| -rw-r--r-- | library/auto.tcl | 183 |
1 files changed, 116 insertions, 67 deletions
diff --git a/library/auto.tcl b/library/auto.tcl index 2ad40eb..ec680de 100644 --- a/library/auto.tcl +++ b/library/auto.tcl @@ -3,8 +3,6 @@ # utility procs formerly in init.tcl dealing with auto execution # of commands and can be auto loaded themselves. # -# RCS: @(#) $Id: auto.tcl,v 1.8 2001/08/27 02:14:08 dgp Exp $ -# # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1998 Sun Microsystems, Inc. # @@ -16,25 +14,28 @@ # # Destroy all cached information for auto-loading and auto-execution, # so that the information gets recomputed the next time it's needed. -# Also delete any procedures that are listed in the auto-load index -# except those defined in this file. +# Also delete any commands that are listed in the auto-load index. # -# Arguments: +# Arguments: # None. proc auto_reset {} { - global auto_execs auto_index auto_oldpath - foreach p [info procs] { - if {[info exists auto_index($p)] && ![string match auto_* $p] - && ([lsearch -exact {unknown pkg_mkIndex tclPkgSetup - tcl_findLibrary pkg_compareExtension - tclMacPkgSearch tclPkgUnknown} $p] < 0)} { - rename $p {} + global auto_execs auto_index auto_path + if {[array exists auto_index]} { + foreach cmdName [array names auto_index] { + set fqcn [namespace which $cmdName] + if {$fqcn eq ""} {continue} + rename $fqcn {} + } + } + unset -nocomplain auto_execs auto_index ::tcl::auto_oldpath + if {[catch {llength $auto_path}]} { + set auto_path [list [info library]] + } else { + if {[info library] ni $auto_path} { + lappend auto_path [info library] } } - catch {unset auto_execs} - catch {unset auto_index} - catch {unset auto_oldpath} } # tcl_findLibrary -- @@ -53,34 +54,56 @@ proc auto_reset {} { proc tcl_findLibrary {basename version patch initScript enVarName varName} { upvar #0 $varName the_library - global env errorInfo + global auto_path env tcl_platform set dirs {} set errors {} # The C application may have hardwired a path, which we honor - - if {[info exists the_library] && [string compare $the_library {}]} { + + if {[info exists the_library] && $the_library ne ""} { lappend dirs $the_library } else { # Do the canonical search - # 1. From an environment variable, if it exists + # 1. From an environment variable, if it exists. + # Placing this first gives the end-user ultimate control + # to work-around any bugs, or to customize. if {[info exists env($enVarName)]} { lappend dirs $env($enVarName) } - # 2. Relative to the Tcl library + # 2. In the package script directory registered within + # the configuration of the package itself. - lappend dirs [file join [file dirname [info library]] \ - $basename$version] + if {[catch { + ::${basename}::pkgconfig get scriptdir,runtime + } value] == 0} { + lappend dirs $value + } + + # 3. Relative to auto_path directories. This checks relative to the + # Tcl library as well as allowing loading of libraries added to the + # auto_path that is not relative to the core library or binary paths. + foreach d $auto_path { + lappend dirs [file join $d $basename$version] + if {$tcl_platform(platform) eq "unix" + && $tcl_platform(os) eq "Darwin"} { + # 4. On MacOSX, check the Resources/Scripts subdir too + lappend dirs [file join $d $basename$version Resources Scripts] + } + } # 3. Various locations relative to the executable # ../lib/foo1.0 (From bin directory in install hierarchy) # ../../lib/foo1.0 (From bin/arch directory in install hierarchy) # ../library (From unix directory in build hierarchy) + # + # Remaining locations are out of date (when relevant, they ought + # to be covered by the $::auto_path seach above) and disabled. + # # ../../library (From unix/arch directory in build hierarchy) # ../../foo1.0.1/library # (From unix directory in parallel build hierarchy) @@ -92,11 +115,30 @@ proc tcl_findLibrary {basename version patch initScript enVarName varName} { lappend dirs [file join $parentDir lib $basename$version] lappend dirs [file join $grandParentDir lib $basename$version] lappend dirs [file join $parentDir library] - lappend dirs [file join $grandParentDir library] - lappend dirs [file join $grandParentDir $basename$patch library] - lappend dirs [file join [file dirname $grandParentDir] \ - $basename$patch library] + if {0} { + lappend dirs [file join $grandParentDir library] + lappend dirs [file join $grandParentDir $basename$patch library] + lappend dirs [file join [file dirname $grandParentDir] \ + $basename$patch library] + } + } + # uniquify $dirs in order + array set seen {} + foreach i $dirs { + # Take note that the [file normalize] below has been noted to + # cause difficulties for the freewrap utility. See Bug 1072136. + # Until freewrap resolves the matter, one might work around the + # problem by disabling that branch. + if {[interp issafe]} { + set norm $i + } else { + set norm [file normalize $i] + } + if {[info exists seen($norm)]} { continue } + set seen($norm) "" + lappend uniqdirs $i } + set dirs $uniqdirs foreach i $dirs { set the_library $i set file [file join $i $initScript] @@ -105,13 +147,15 @@ proc tcl_findLibrary {basename version patch initScript enVarName varName} { # we have a source command, but no file exists command if {[interp issafe] || [file exists $file]} { - if {![catch {uplevel #0 [list source $file]} msg]} { + if {![catch {uplevel #0 [list source $file]} msg opts]} { return } else { - append errors "$file: $msg\n$errorInfo\n" + append errors "$file: $msg\n" + append errors [dict get $opts -errorinfo]\n } } } + unset -nocomplain the_library set msg "Can't find a usable $initScript in the following directories: \n" append msg " $dirs\n\n" append msg "$errors\n\n" @@ -128,7 +172,7 @@ proc tcl_findLibrary {basename version patch initScript enVarName varName} { # 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. +# special parser and mess with its commands. if {[interp issafe]} { return ;# Stop sourcing the file here @@ -140,15 +184,13 @@ if {[interp issafe]} { # followed by any number of glob patterns to use in that directory to # locate all of the relevant files. # -# Arguments: +# Arguments: # dir - Name of the directory in which to create an index. # args - Any number of additional arguments giving the # names of files within dir. If no additional # are given auto_mkindex will look for *.tcl. proc auto_mkindex {dir args} { - global errorCode errorInfo - if {[interp issafe]} { error "can't generate index within safe interpreter" } @@ -164,19 +206,17 @@ proc auto_mkindex {dir args} { append index "# sets an element in the auto_index array, where the\n" append index "# element name is the name of a command and the value is\n" append index "# a script that loads the command.\n\n" - if {$args == ""} { + if {[llength $args] == 0} { set args *.tcl } auto_mkindex_parser::init - foreach file [eval glob $args] { - if {[catch {auto_mkindex_parser::mkindex $file} msg] == 0} { + foreach file [glob -- {*}$args] { + if {[catch {auto_mkindex_parser::mkindex $file} msg opts] == 0} { append index $msg } else { - set code $errorCode - set info $errorInfo cd $oldDir - error $msg $info $code + return -options $opts $msg } } auto_mkindex_parser::cleanup @@ -191,7 +231,6 @@ proc auto_mkindex {dir args} { # code for "proc" at the beginning of the line. proc auto_mkindex_old {dir args} { - global errorCode errorInfo set oldDir [pwd] cd $dir set dir [pwd] @@ -202,10 +241,10 @@ proc auto_mkindex_old {dir args} { append index "# sets an element in the auto_index array, where the\n" append index "# element name is the name of a command and the value is\n" append index "# a script that loads the command.\n\n" - if {[string equal $args ""]} { + if {[llength $args] == 0} { set args *.tcl } - foreach file [eval glob $args] { + foreach file [glob -- {*}$args] { set f "" set error [catch { set f [open $file] @@ -217,13 +256,11 @@ proc auto_mkindex_old {dir args} { } } close $f - } msg] + } msg opts] if {$error} { - set code $errorCode - set info $errorInfo catch {close $f} cd $oldDir - error $msg $info $code + return -options $opts $msg } } set f "" @@ -232,13 +269,12 @@ proc auto_mkindex_old {dir args} { puts -nonewline $f $index close $f cd $oldDir - } msg] + } msg opts] if {$error} { - set code $errorCode - set info $errorInfo catch {close $f} cd $oldDir error $msg $info $code + return -options $opts $msg } } @@ -253,7 +289,10 @@ namespace eval auto_mkindex_parser { variable scriptFile "" ;# name of file being processed variable contextStack "" ;# stack of namespace scopes variable imports "" ;# keeps track of all imported cmds - variable initCommands "" ;# list of commands that create aliases + variable initCommands ;# list of commands that create aliases + if {![info exists initCommands]} { + set initCommands [list] + } proc init {} { variable parser @@ -299,7 +338,7 @@ namespace eval auto_mkindex_parser { # handles things like the "proc" command by adding an entry for the # index file. Returns a string that represents the index file. # -# Arguments: +# Arguments: # file Name of Tcl source file to be indexed. proc auto_mkindex_parser::mkindex {file} { @@ -323,8 +362,8 @@ proc auto_mkindex_parser::mkindex {file} { # in case there were any $ in the proc name. This will cause a problem # if somebody actually tries to have a \0 in their proc name. Too bad # for them. - regsub -all {\$} $contents "\0" contents - + set contents [string map [list \$ \0] $contents] + set index "" set contextStack "" set imports "" @@ -401,12 +440,10 @@ proc auto_mkindex_parser::commandInit {name arglist body} { set ns [namespace qualifiers $name] set tail [namespace tail $name] - if {[string equal $ns ""]} { - set fakeName "[namespace current]::_%@fake_$tail" + if {$ns eq ""} { + set fakeName [namespace current]::_%@fake_$tail } else { - set fakeName "_%@fake_$name" - regsub -all {::} $fakeName "_" fakeName - set fakeName "[namespace current]::$fakeName" + set fakeName [namespace current]::[string map {:: _} _%@fake_$name] } proc $fakeName $arglist $body @@ -415,10 +452,10 @@ proc auto_mkindex_parser::commandInit {name arglist body} { # we have to build procs with the fully qualified names, and # have the procs point to the aliases. - if {[regexp {::} $name]} { + if {[string match *::* $name]} { set exportCmd [list _%@namespace export [namespace tail $name]] $parser eval [list _%@namespace eval $ns $exportCmd] - + # The following proc definition does not work if you # want to tolerate space or something else diabolical # in the procedure name, (i.e., space in $alias) @@ -465,16 +502,19 @@ proc auto_mkindex_parser::fullname {name} { } } - if {[string equal [namespace qualifiers $name] ""]} { + if {[namespace qualifiers $name] eq ""} { set name [namespace tail $name] } elseif {![string match ::* $name]} { set name "::$name" } - + # Earlier, mkindex replaced all $'s with \0. Now, we have to reverse # that replacement. - regsub -all "\0" $name "\$" name - return $name + return [string map [list \0 \$] $name] +} + +if {[llength $::auto_mkindex_parser::initCommands]} { + return } # Register all of the procedures for the auto_mkindex parser that @@ -488,7 +528,7 @@ auto_mkindex_parser::command proc {name args} { variable scriptFile # Do some fancy reformatting on the "source" call to handle platform # differences with respect to pathnames. Use format just so that the - # command is a little easier to read (otherwise it'd be full of + # command is a little easier to read (otherwise it'd be full of # backslashed dollar signs, etc. append index [list set auto_index([fullname $name])] \ [format { [list source [file join $dir %s]]} \ @@ -506,14 +546,14 @@ auto_mkindex_parser::command proc {name args} { auto_mkindex_parser::hook { if {![catch {package require tbcload}]} { - if {[llength [info commands tbcload::bcproc]] == 0} { + if {[namespace which -command tbcload::bcproc] eq ""} { auto_load tbcload::bcproc } load {} tbcload $auto_mkindex_parser::parser # AUTO MKINDEX: tbcload::bcproc name arglist body # Adds an entry to the auto index list for the given pre-compiled - # procedure name. + # procedure name. auto_mkindex_parser::commandInit tbcload::bcproc {name args} { variable index @@ -557,12 +597,21 @@ auto_mkindex_parser::command namespace {op args} { variable parser variable imports foreach pattern $args { - if {[string compare $pattern "-force"]} { + if {$pattern ne "-force"} { lappend imports $pattern } } catch {$parser eval "_%@namespace import $args"} } + ensemble { + variable parser + variable contextStack + if {[lindex $args 0] eq "create"} { + set name ::[join [lreverse $contextStack] ::] + # create artifical proc to force an entry in the tclIndex + $parser eval [list ::proc $name {} {}] + } + } } } |