diff options
| -rw-r--r-- | doc/Package.n | 57 | ||||
| -rw-r--r-- | doc/library.n | 7 | ||||
| -rw-r--r-- | doc/pkgMkIndex.n | 6 | ||||
| -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 | ||||
| -rw-r--r-- | tests/package.test | 71 |
8 files changed, 304 insertions, 42 deletions
diff --git a/doc/Package.n b/doc/Package.n new file mode 100644 index 0000000..4859c2f --- /dev/null +++ b/doc/Package.n @@ -0,0 +1,57 @@ +'\" +'\" Copyright (c) 1998-2000 by Scriptics Corporation. +'\" All rights reserved. +'\" +'\" RCS: @(#) $Id: Package.n,v 1.1 2000/02/01 01:14:00 ericm Exp $ +'\" +.so man.macros +.TH package::create n 8.3 Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +package::create \- Construct an appropriate \fBpackage ifneeded\fR +command for a given package specification +.SH SYNOPSIS +.nf +.VS 8.3.0 +\fB::package::create \fI-name packageName\fR \fI-version +packageVersion\fR ?\fI-load filespec\fR? ... ?\fI-source filespec\fR? ... + +.SH DESCRIPTION +.PP +\fB::package::create\fR is a utility procedure that is part of the standard +Tcl library. It is used to create an appropriate \fBpackage +ifneeded\fR command for a given package specification. It can be used +to construct a \fBpkgIndex.tcl\fR file for use with the \fBpackage\fI +mechanism. + +.SH OPTIONS +The parameters supported are: +.TP +\fB\-name\fR\0\fIpackageName\fR +This parameter specifies the name of the package. It is required. +.TP +\fB\-version\fR\0\fIpackageVersion\fR +This parameter specifies the version of the package. It is required. +.TP +\fB\-load\fR\0\fIfilespec\fR +This parameter specifies a binary library that must be loaded with the +\fBload\fR command. \fIfilespec\fR is a list with two elements. The +first element is the name of the file to load. The second, optional +element is a list of commands supplied by loading that file. If the +list of procedures is empty or omitted, \fB::package::create\fR will +set up the library for direct loading (see \fBpkg_mkIndex\fR). Any +number of \fB-load\fR parameters may be specified. +.TP +\fB\-source\fR\0\fIfilespec\fR +This parameter is similar to the \fB-load\fR parameter, except that it +specifies a Tcl library that must be loaded with the +\fBsource\fR command. Any number of \fB-source\fR parameters may be +specified. +.PP +At least one \fB-load\fR or \fB-source\fR paramter must be given. + + + +.SH KEYWORDS +auto-load, index, package, version diff --git a/doc/library.n b/doc/library.n index e958e63..1b1ee6d 100644 --- a/doc/library.n +++ b/doc/library.n @@ -5,7 +5,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: library.n,v 1.8 1999/06/29 00:25:23 welch Exp $ +'\" RCS: @(#) $Id: library.n,v 1.9 2000/02/01 01:14:01 ericm Exp $ .so man.macros .TH library n "8.0" Tcl "Tcl Built-In Commands" .BS @@ -139,7 +139,10 @@ as its first characters then it is assumed to be a procedure definition and the next word of the line is taken as the procedure's name. Procedure definitions that don't appear in this way (e.g. they -have spaces before the \fBproc\fR) will not be indexed. +have spaces before the \fBproc\fR) will not be indexed. If your +script contains "dangerous" code, such as global initialization +code or procedure names with special characters like \fB$\fR, +\fB*\fR, \fB[\fR or \fB]\fR, you are safer using auto_mkindex_old. .RE .TP \fBauto_reset\fR diff --git a/doc/pkgMkIndex.n b/doc/pkgMkIndex.n index cb77b8b..f816436 100644 --- a/doc/pkgMkIndex.n +++ b/doc/pkgMkIndex.n @@ -4,17 +4,17 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: pkgMkIndex.n,v 1.7 2000/01/27 19:20:05 ericm Exp $ +'\" RCS: @(#) $Id: pkgMkIndex.n,v 1.8 2000/02/01 01:14:01 ericm Exp $ '\" .so man.macros -.TH pkg_mkIndex n 8.0 Tcl "Tcl Built-In Commands" +.TH pkg_mkIndex n 8.3 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME pkg_mkIndex \- Build an index for automatic loading of packages .SH SYNOPSIS .nf -.VS 8.0.3 +.VS 8.3.0 \fBpkg_mkIndex ?\fI-lazy\fR? ?\fI-load pkgPat\fR? ?\fI-verbose\fR? \fIdir\fR ?\fIpattern pattern ...\fR? .VE .fi 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]] diff --git a/tests/package.test b/tests/package.test new file mode 100644 index 0000000..0262e31 --- /dev/null +++ b/tests/package.test @@ -0,0 +1,71 @@ +# This file contains tests for the ::package::* commands. +# Note that the tests are limited to Tcl scripts only, there are no shared +# libraries against which to test. +# +# Sourcing this file into Tcl runs the tests and generates output for +# errors. No output means no errors were found. +# +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. +# +# RCS: @(#) $Id: package.test,v 1.1 2000/02/01 01:14:02 ericm Exp $ + +if {[lsearch [namespace children] ::tcltest] == -1} { + package require tcltest + namespace import ::tcltest::* +} + +test package-1.1 {package::create gives error on insufficient args} { + catch {::package::create} +} 1 +test package-1.2 {package::create gives error on bad args} { + catch {::package::create -foo bar -bar baz -baz boo} +} 1 +test package-1.3 {package::create gives error on no value given} { + catch {::package::create -name foo -version 1.0 -source test.tcl -load} +} 1 +test package-1.4 {package::create gives error on no name given} { + catch {::package::create -version 1.0 -source test.tcl -load foo.so} +} 1 +test package-1.5 {package::create gives error on no version given} { + catch {::package::create -name foo -source test.tcl -load foo.so} +} 1 +test package-1.6 {package::create gives error on no source or load options} { + catch {::package::create -name foo -version 1.0 -version 2.0} +} 1 +test package-1.7 {package::create gives correct output for 1 direct source} { + ::package::create -name foo -version 1.0 -source test.tcl +} {package ifneeded foo 1.0 [list source [file join $dir test.tcl]]} +test package-1.8 {package::create gives correct output for 2 direct sources} { + ::package::create -name foo -version 1.0 -source test.tcl -source test2.tcl +} {package ifneeded foo 1.0 [list source [file join $dir test.tcl]]\n[list source [file join $dir test2.tcl]]} +test package-1.9 {package::create gives correct output for 1 direct load} { + ::package::create -name foo -version 1.0 -load test.so +} {package ifneeded foo 1.0 [list load [file join $dir test.so]]} +test package-1.10 {package::create gives correct output for 2 direct loads} { + ::package::create -name foo -version 1.0 -load test.so -load test2.so +} {package ifneeded foo 1.0 [list load [file join $dir test.so]]\n[list load [file join $dir test2.so]]} +test package-1.11 {package::create gives correct output for 1 lazy source} { + ::package::create -name foo -version 1.0 -source {test.tcl {foo bar}} +} {package ifneeded foo 1.0 [list tclPkgSetup $dir foo 1.0 {{test.tcl source {foo bar}}}]} +test package-1.12 {package::create gives correct output for 2 lazy sources} { + ::package::create -name foo -version 1.0 -source {test.tcl {foo bar}} \ + -source {test2.tcl {baz boo}} +} {package ifneeded foo 1.0 [list tclPkgSetup $dir foo 1.0 {{test.tcl source {foo bar}} {test2.tcl source {baz boo}}}]} +test package-1.13 {package::create gives correct output for 1 lazy load} { + ::package::create -name foo -version 1.0 -load {test.so {foo bar}} +} {package ifneeded foo 1.0 [list tclPkgSetup $dir foo 1.0 {{test.so load {foo bar}}}]} +test package-1.14 {package::create gives correct output for 2 lazy loads} { + ::package::create -name foo -version 1.0 -load {test.so {foo bar}} \ + -load {test2.so {baz boo}} +} {package ifneeded foo 1.0 [list tclPkgSetup $dir foo 1.0 {{test.so load {foo bar}} {test2.so load {baz boo}}}]} +test package-1.15 {package::create gives correct output for 1 each, direct} { + ::package::create -name foo -version 1.0 -source test.tcl -load test2.so +} {package ifneeded foo 1.0 [list load [file join $dir test2.so]]\n[list source [file join $dir test.tcl]]} +test package-1.16 {package::create gives correct output for 1 direct, 1 lazy} { + ::package::create -name foo -version 1.0 -source test.tcl \ + -source {test2.tcl {foo bar}} +} {package ifneeded foo 1.0 [list source [file join $dir test.tcl]]\n[list tclPkgSetup $dir foo 1.0 {{test2.tcl source {foo bar}}}]} + +::tcltest::cleanupTests +return |