diff options
Diffstat (limited to 'library')
| -rw-r--r-- | library/auto.tcl | 24 | ||||
| -rw-r--r-- | library/init.tcl | 10 | ||||
| -rw-r--r-- | library/package.tcl | 170 | ||||
| -rw-r--r-- | library/tclIndex | 1 |
4 files changed, 168 insertions, 37 deletions
diff --git a/library/auto.tcl b/library/auto.tcl index 07b3116..9575f7b 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.5 2000/01/28 16:38:34 ericm Exp $ +# RCS: @(#) $Id: auto.tcl,v 1.6 2000/02/01 01:14:01 ericm Exp $ # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1998 Sun Microsystems, Inc. @@ -318,13 +318,13 @@ proc auto_mkindex_parser::mkindex {file} { # 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 -expanded -all { - ([^\\](?:(?:\\\\)*)) # match any even number of backslashes ... - \$ # ... followed by an unescaped dollar sign ... - ([^\$]) # ... followed by anything but another dollar sign - } $contents {\1\\$\2} contents; # add one backslash for the dollar sign - + # To avoid this, we replace all $ with \0 (literally, the null char) + # later, when getting proc names we will have to reverse this replacement, + # 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 index "" set contextStack "" set imports "" @@ -466,10 +466,14 @@ proc auto_mkindex_parser::fullname {name} { } if {[string equal [namespace qualifiers $name] ""]} { - return [namespace tail $name] + set name [namespace tail $name] } elseif {![string match ::* $name]} { - return "::$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 } diff --git a/library/init.tcl b/library/init.tcl index c5fff21..ecc926f 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.37 2000/01/29 00:12:46 ericm Exp $ +# RCS: @(#) $Id: init.tcl,v 1.38 2000/02/01 01:14:01 ericm Exp $ # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. @@ -312,10 +312,10 @@ proc auto_load {cmd {namespace {}}} { # name. One is to use # info commands $name # Unfortunately, if the name has glob-magic chars in it like * - # or [], it may not match. Since we really want an exact match, - # a better route is to use - # lsearch -exact [info commands] $name - if {[lsearch -exact [info commands] $name] != -1 } { + # or [], it may not match. For our purposes here, a better + # route is to use + # namespace which -command $name + if { ![string equal [namespace which -command $name] ""] } { return 1 } } diff --git a/library/package.tcl b/library/package.tcl index c9506a8..c1f8415 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.9 2000/01/28 19:32:05 ericm Exp $ +# RCS: @(#) $Id: package.tcl,v 1.10 2000/02/01 01:14:01 ericm Exp $ # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1998 Sun Microsystems, Inc. @@ -12,6 +12,10 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # +# Create the package namespace +namespace eval ::package { +} + # pkg_compareExtension -- # # Used internally by pkg_mkIndex to compare the extension of a file to @@ -116,15 +120,6 @@ proc pkg_mkIndex {args} { set patternList [list "*.tcl" "*[info sharedlibextension]"] } - append index "# Tcl package index file, version 1.1\n" - append index "# This file is generated by the \"pkg_mkIndex$more\" command\n" - append index "# and sourced either when an application starts up or\n" - append index "# by a \"package unknown\" script. It invokes the\n" - append index "# \"package ifneeded\" command to set up package-related\n" - append index "# information so that packages will be loaded automatically\n" - append index "# in response to \"package require\" commands. When this\n" - append index "# script is sourced, the variable \$dir must contain the\n" - append index "# full path name of this file's directory.\n" set oldDir [pwd] cd $dir @@ -350,22 +345,33 @@ proc pkg_mkIndex {args} { } } + append index "# Tcl package index file, version 1.1\n" + append index "# This file is generated by the \"pkg_mkIndex$more\" command\n" + append index "# and sourced either when an application starts up or\n" + append index "# by a \"package unknown\" script. It invokes the\n" + append index "# \"package ifneeded\" command to set up package-related\n" + append index "# information so that packages will be loaded automatically\n" + append index "# in response to \"package require\" commands. When this\n" + append index "# script is sourced, the variable \$dir must contain the\n" + append index "# full path name of this file's directory.\n" + foreach pkg [lsort [array names files]] { - append index "\npackage ifneeded $pkg " - if {$direct} { - set cmdList {} - foreach elem $files($pkg) { - set file [lindex $elem 0] - set type [lindex $elem 1] - lappend cmdList "\[list $type \[file join \$dir\ - [list $file]\]\]" + set cmd {} + foreach {name version} $pkg { + break + } + lappend cmd ::package::create -name $name -version $version + foreach spec $files($pkg) { + foreach {file type procs} $spec { + if { $direct } { + set procs {} + } + lappend cmd "-$type" [list $file $procs] } - append index [join $cmdList "\\n"] - } else { - append index "\[list tclPkgSetup \$dir [lrange $pkg 0 0]\ - [lrange $pkg 1 1] [list $files($pkg)]\]" } + append index "\n[eval $cmd]" } + set f [open pkgIndex.tcl w] puts $f $index close $f @@ -481,3 +487,123 @@ proc tclPkgUnknown {name version {exact {}}} { } } } + +# ::package::create -- +# +# Given a package specification generate a "package ifneeded" statement +# for the package, suitable for inclusion in a pkgIndex.tcl file. +# +# Arguments: +# args arguments used by the create function: +# -name packageName +# -version packageVersion +# -load {filename ?{procs}?} +# ... +# -source {filename ?{procs}?} +# ... +# +# Any number of -load and -source parameters may be +# specified, so long as there is at least one -load or +# -source parameter. If the procs component of a +# module specifier is left off, that module will be +# set up for direct loading; otherwise, it will be +# set up for lazy loading. If both -source and -load +# are specified, the -load'ed files will be loaded +# first, followed by the -source'd files. +# +# Results: +# An appropriate "package ifneeded" statement for the package. + +proc ::package::create {args} { + append err(usage) "::package::create " + append err(usage) "-name packageName -version packageVersion" + append err(usage) "?-load {filename ?{procs}?}? ... " + append err(usage) "?-source {filename ?{procs}?}? ..." + + set err(wrongNumArgs) "wrong # args: should be \"$err(usage)\"" + set err(valueMissing) "value for \"%s\" missing: should be \"$err(usage)\"" + set err(unknownOpt) "unknown option \"%s\": should be \"$err(usage)\"" + set err(noLoadOrSource) "at least one of -load and -source must be given" + + # process arguments + set len [llength $args] + if { $len < 6 } { + error $err(wrongNumArgs) + } + + # Initialize parameters + set opts(-name) {} + set opts(-version) {} + set opts(-source) {} + set opts(-load) {} + + # process parameters + for {set i 0} {$i < $len} {incr i} { + set flag [lindex $args $i] + incr i + switch -glob -- $flag { + "-name" - + "-version" { + if { $i >= $len } { + error [format $err(valueMissing) $flag] + } + set opts($flag) [lindex $args $i] + } + "-source" - + "-load" { + if { $i >= $len } { + error [format $err(valueMissing) $flag] + } + lappend opts($flag) [lindex $args $i] + } + default { + error [format $err(unknownOpt) [lindex $args $i]] + } + } + } + + # Validate the parameters + if { [llength $opts(-name)] == 0 } { + error [format $err(valueMissing) "-name"] + } + if { [llength $opts(-version)] == 0 } { + error [format $err(valueMissing) "-version"] + } + + if { [llength $opts(-source)] == 0 && [llength $opts(-load)] == 0 } { + error $err(noLoadOrSource) + } + + # OK, now everything is good. Generate the package ifneeded statment. + set cmdline "package ifneeded $opts(-name) $opts(-version) " + + set cmdList {} + set lazyFileList {} + + # Handle -load and -source specs + foreach key {load source} { + foreach filespec $opts(-$key) { + foreach {filename proclist} {{} {}} { + break + } + foreach {filename proclist} $filespec { + break + } + + if { [llength $proclist] == 0 } { + set cmd "\[list $key \[file join \$dir [list $filename]\]\]" + lappend cmdList $cmd + } else { + lappend lazyFileList [list $filename $key $proclist] + } + } + } + + if { [llength $lazyFileList] > 0 } { + lappend cmdList "\[list tclPkgSetup \$dir $opts(-name)\ + $opts(-version) [list $lazyFileList]\]" + } + append cmdline [join $cmdList "\\n"] + return $cmdline +} + diff --git a/library/tclIndex b/library/tclIndex index 35c7cf6..92500b2 100644 --- a/library/tclIndex +++ b/library/tclIndex @@ -33,6 +33,7 @@ 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(::package::create) [list source [file join $dir package.tcl]] set auto_index(parray) [list source [file join $dir parray.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]] |