diff options
Diffstat (limited to 'tests')
| -rw-r--r-- | tests/autoMkindex.test | 285 | ||||
| -rw-r--r-- | tests/package.test | 1262 | ||||
| -rw-r--r-- | tests/pkg.test | 1222 | ||||
| -rw-r--r-- | tests/pkgMkIndex.test | 113 |
4 files changed, 1427 insertions, 1455 deletions
diff --git a/tests/autoMkindex.test b/tests/autoMkindex.test index 56e1ffb..2b15377 100644 --- a/tests/autoMkindex.test +++ b/tests/autoMkindex.test @@ -1,17 +1,17 @@ # Commands covered: auto_mkindex auto_import # -# This file contains tests related to autoloading and generating -# the autoloading index. +# This file contains tests related to autoloading and generating the +# autoloading index. # # Copyright (c) 1998 Lucent Technologies, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# See the file "license.terms" for information on usage and redistribution of +# this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: autoMkindex.test,v 1.15 2004/05/25 17:44:29 dgp Exp $ +# RCS: @(#) $Id: autoMkindex.test,v 1.16 2011/01/06 10:20:39 dkf Exp $ -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } @@ -19,10 +19,10 @@ if {[lsearch [namespace children] ::tcltest] == -1} { makeFile {# Test file for: # auto_mkindex # -# This file provides example cases for testing the Tcl autoloading -# facility. Things are much more complicated with namespaces and classes. -# The "auto_mkindex" facility can no longer be built on top of a simple -# regular expression parser. It must recognize constructs like this: +# This file provides example cases for testing the Tcl autoloading facility. +# Things are much more complicated with namespaces and classes. The +# "auto_mkindex" facility can no longer be built on top of a simple regular +# expression parser. It must recognize constructs like this: # # namespace eval foo { # proc test {x y} { ... } @@ -31,23 +31,23 @@ makeFile {# Test file for: # } # } # -# Note that procedures and itcl class definitions can be nested inside -# of namespaces. +# Note that procedures and itcl class definitions can be nested inside of +# namespaces. # # Copyright (c) 1993-1998 Lucent Technologies, Inc. # This shouldn't cause any problems namespace import -force blt::* -# Should be able to handle "proc" definitions, even if they are -# preceded by white space. +# Should be able to handle "proc" definitions, even if they are preceded by +# white space. proc normal {x y} {return [expr $x+$y]} proc indented {x y} {return [expr $x+$y]} # -# Should be able to handle proc declarations within namespaces, -# even if they have explicit namespace paths. +# Should be able to handle proc declarations within namespaces, even if they +# have explicit namespace paths. # namespace eval buried { proc inside {args} {return "inside: $args"} @@ -69,8 +69,8 @@ namespace eval buried { } } -# With proper hooks, we should be able to support other commands -# that create procedures +# With proper hooks, we should be able to support other commands that create +# procedures proc buried::myproc {name body args} { ::proc $name $body $args @@ -90,17 +90,15 @@ namespace eval ::buried { } {::buried::my proc} mycmd6 args {return "another"} -# A correctly functioning [auto_import] won't choke when a child -# namespace [namespace import]s from its parent. +# A correctly functioning [auto_import] won't choke when a child namespace +# [namespace import]s from its parent. # namespace eval ::parent::child { namespace import ::parent::* } proc ::parent::child::test {} {} - } autoMkindex.tcl - # Save initial state of auto_mkindex_parser auto_load auto_mkindex @@ -120,21 +118,19 @@ set result "" set origDir [pwd] cd $::tcltest::temporaryDirectory - + test autoMkindex-1.1 {remove any existing tclIndex file} { file delete tclIndex file exists tclIndex } {0} - test autoMkindex-1.2 {build tclIndex based on a test file} { auto_mkindex . autoMkindex.tcl file exists tclIndex } {1} - set element "{source [file join . autoMkindex.tcl]}" - -test autoMkindex-1.3 {examine tclIndex} { +test autoMkindex-1.3 {examine tclIndex} -setup { file delete tclIndex +} -body { auto_mkindex . autoMkindex.tcl namespace eval tcl_autoMkindex_tmp { set dir "." @@ -145,33 +141,35 @@ test autoMkindex-1.3 {examine tclIndex} { lappend ::result [list $elem $auto_index($elem)] } } + return $result +} -cleanup { namespace delete tcl_autoMkindex_tmp - set ::result -} "{::buried::explicit $element} {::buried::inside $element} {{::buried::my proc} $element} {::buried::mycmd1 $element} {::buried::mycmd4 $element} {::buried::myproc $element} {::buried::pub_one $element} {::buried::pub_two $element} {::buried::relative $element} {::buried::under::neath $element} {::buried::within $element} {::parent::child::test $element} {indented $element} {normal $element} {top $element}" - +} -result "{::buried::explicit $element} {::buried::inside $element} {{::buried::my proc} $element} {::buried::mycmd1 $element} {::buried::mycmd4 $element} {::buried::myproc $element} {::buried::pub_one $element} {::buried::pub_two $element} {::buried::relative $element} {::buried::under::neath $element} {::buried::within $element} {::parent::child::test $element} {indented $element} {normal $element} {top $element}" -test autoMkindex-2.1 {commands on the autoload path can be imported} { +test autoMkindex-2.1 {commands on the autoload path can be imported} -setup { file delete tclIndex + interp create slave +} -body { auto_mkindex . autoMkindex.tcl - set interp [interp create] - set final [$interp eval { + slave eval { namespace eval blt {} set auto_path [linsert $auto_path 0 .] set info [list [catch {namespace import buried::*} result] $result] foreach name [lsort [info commands pub_*]] { lappend info $name [namespace origin $name] } - set info - }] - interp delete $interp - set final -} "0 {} pub_one ::buried::pub_one pub_two ::buried::pub_two" + return $info + } +} -cleanup { + interp delete slave +} -result "0 {} pub_one ::buried::pub_one pub_two ::buried::pub_two" # Test auto_mkindex hooks # Slave hook executes interesting code in the interp used to watch code. - -test autoMkindex-3.1 {slaveHook} { +test autoMkindex-3.1 {slaveHook} -setup { + file delete tclIndex +} -body { auto_mkindex_parser::slavehook { _%@namespace eval ::blt { proc foo {} {} @@ -179,26 +177,23 @@ test autoMkindex-3.1 {slaveHook} { } } auto_mkindex_parser::slavehook { _%@namespace import -force ::blt::* } - file delete tclIndex auto_mkindex . autoMkindex.tcl - + file exists tclIndex +} -cleanup { # Reset initCommands to avoid trashing other tests - AutoMkindexTestReset - file exists tclIndex -} 1 - -# The auto_mkindex_parser::command is used to register commands -# that create new commands. - -test autoMkindex-3.2 {auto_mkindex_parser::command} { +} -result 1 +# The auto_mkindex_parser::command is used to register commands that create +# new commands. +test autoMkindex-3.2 {auto_mkindex_parser::command} -setup { + file delete tclIndex +} -body { auto_mkindex_parser::command buried::myproc {name args} { variable index variable scriptFile append index [list set auto_index([fullname $name])] \ " \[list source \[file join \$dir [list $scriptFile]\]\]\n" } - file delete tclIndex auto_mkindex . autoMkindex.tcl namespace eval tcl_autoMkindex_tmp { set dir "." @@ -208,17 +203,16 @@ test autoMkindex-3.2 {auto_mkindex_parser::command} { foreach elem [lsort [array names auto_index]] { lappend ::result [list $elem $auto_index($elem)] } + return $::result } +} -cleanup { namespace delete tcl_autoMkindex_tmp - # Reset initCommands to avoid trashing other tests - AutoMkindexTestReset - set ::result -} "{::buried::explicit $element} {::buried::inside $element} {{::buried::my proc} $element} {::buried::mycmd1 $element} {::buried::mycmd2 $element} {::buried::mycmd4 $element} {::buried::myproc $element} {::buried::pub_one $element} {::buried::pub_two $element} {::buried::relative $element} {::buried::under::neath $element} {::buried::within $element} {::parent::child::test $element} {indented $element} {mycmd3 $element} {normal $element} {top $element}" - - -test autoMkindex-3.3 {auto_mkindex_parser::command} {knownBug} { +} -result "{::buried::explicit $element} {::buried::inside $element} {{::buried::my proc} $element} {::buried::mycmd1 $element} {::buried::mycmd2 $element} {::buried::mycmd4 $element} {::buried::myproc $element} {::buried::pub_one $element} {::buried::pub_two $element} {::buried::relative $element} {::buried::under::neath $element} {::buried::within $element} {::parent::child::test $element} {indented $element} {mycmd3 $element} {normal $element} {top $element}" +test autoMkindex-3.3 {auto_mkindex_parser::command} -setup { + file delete tclIndex +} -constraints {knownBug} -body { auto_mkindex_parser::command {buried::my proc} {name args} { variable index variable scriptFile @@ -226,7 +220,6 @@ test autoMkindex-3.3 {auto_mkindex_parser::command} {knownBug} { append index [list set auto_index([fullname $name])] \ " \[list source \[file join \$dir [list $scriptFile]\]\]\n" } - file delete tclIndex auto_mkindex . autoMkindex.tcl namespace eval tcl_autoMkindex_tmp { set dir "." @@ -237,109 +230,93 @@ test autoMkindex-3.3 {auto_mkindex_parser::command} {knownBug} { lappend ::result [list $elem $auto_index($elem)] } } + list [lsearch -inline $::result *mycmd4*] \ + [lsearch -inline $::result *mycmd5*] \ + [lsearch -inline $::result *mycmd6*] +} -cleanup { namespace delete tcl_autoMkindex_tmp - # Reset initCommands to avoid trashing other tests - AutoMkindexTestReset - proc lvalue {list pattern} { - set ix [lsearch $list $pattern] - if {$ix >= 0} { - return [lindex $list $ix] - } else { - return {} - } - } - list [lvalue $::result *mycmd4*] [lvalue $::result *mycmd5*] [lvalue $::result *mycmd6*] -} "{::buried::mycmd4 $element} {::buried::mycmd5 $element} {mycmd6 $element}" - - -makeDirectory pkg -makeFile { -package provide football 1.0 - -namespace eval ::pro:: { - # - # export only public functions. - # - namespace export {[a-z]*} -} -namespace eval ::college:: { - # - # export only public functions. - # - namespace export {[a-z]*} -} - -proc ::pro::team {} { - puts "go packers!" - return true -} +} -result "{::buried::mycmd4 $element} {::buried::mycmd5 $element} {mycmd6 $element}" -proc ::college::team {} { - puts "go badgers!" - return true -} - -} [file join pkg samename.tcl] - - -test autoMkindex-4.1 {platform indenpendant source commands} { +test autoMkindex-4.1 {platform independent source commands} -setup { file delete tclIndex + makeDirectory pkg + makeFile { + package provide football 1.0 + namespace eval ::pro:: { + # + # export only public functions. + # + namespace export {[a-z]*} + } + namespace eval ::college:: { + # + # export only public functions. + # + namespace export {[a-z]*} + } + proc ::pro::team {} { + puts "go packers!" + return true + } + proc ::college::team {} { + puts "go badgers!" + return true + } + } [file join pkg samename.tcl] +} -body { auto_mkindex . pkg/samename.tcl set f [open tclIndex r] - set dat [split [string trim [read $f]] "\n"] - set len [llength $dat] - set result [lsort [lrange $dat [expr {$len-2}] [expr {$len-1}]]] - close $f - set result -} {{set auto_index(::college::team) [list source [file join $dir pkg samename.tcl]]} {set auto_index(::pro::team) [list source [file join $dir pkg samename.tcl]]}} - -removeFile [file join pkg samename.tcl] - -makeFile { -set dollar1 "this string contains an unescaped dollar sign -> \\$foo" -set dollar2 "this string contains an escaped dollar sign -> \$foo \\\$foo" -set bracket1 "this contains an unescaped bracket [NoSuchProc]" -set bracket2 "this contains an escaped bracket \[NoSuchProc\]" -set bracket3 "this contains nested unescaped brackets [[NoSuchProc]]" -proc testProc {} {} -} [file join pkg magicchar.tcl] - -test autoMkindex-5.1 {escape magic tcl chars in general code} { + lsort [lrange [split [string trim [read $f]] "\n"] end-1 end] +} -cleanup { + catch {close $f} + removeFile [file join pkg samename.tcl] + removeDirectory pkg +} -result {{set auto_index(::college::team) [list source [file join $dir pkg samename.tcl]]} {set auto_index(::pro::team) [list source [file join $dir pkg samename.tcl]]}} + +test autoMkindex-5.1 {escape magic tcl chars in general code} -setup { file delete tclIndex + makeDirectory pkg + makeFile { + set dollar1 "this string contains an unescaped dollar sign -> \\$foo" + set dollar2 \ + "this string contains an escaped dollar sign -> \$foo \\\$foo" + set bracket1 "this contains an unescaped bracket [NoSuchProc]" + set bracket2 "this contains an escaped bracket \[NoSuchProc\]" + set bracket3 \ + "this contains nested unescaped brackets [[NoSuchProc]]" + proc testProc {} {} + } [file join pkg magicchar.tcl] set result {} - if { ![catch {auto_mkindex . pkg/magicchar.tcl}] } { - set f [open tclIndex r] - set dat [split [string trim [read $f]] "\n"] - set result [lindex $dat end] - close $f - } - set result -} {set auto_index(testProc) [list source [file join $dir pkg magicchar.tcl]]} - -removeFile [file join pkg magicchar.tcl] - -makeFile { -proc {[magic mojo proc]} {} {} -} [file join pkg magicchar2.tcl] - -test autoMkindex-5.2 {correctly locate auto loaded procs with []} { +} -body { + auto_mkindex . pkg/magicchar.tcl + set f [open tclIndex r] + lindex [split [string trim [read $f]] "\n"] end +} -cleanup { + catch {close $f} + removeFile [file join pkg magicchar.tcl] + removeDirectory pkg +} -result {set auto_index(testProc) [list source [file join $dir pkg magicchar.tcl]]} +test autoMkindex-5.2 {correctly locate auto loaded procs with []} -setup { file delete tclIndex + makeDirectory pkg + makeFile { + proc {[magic mojo proc]} {} {} + } [file join pkg magicchar2.tcl] set result {} - if { ![catch {auto_mkindex . pkg/magicchar2.tcl}] } { - # Make a slave interp to test the autoloading - set c [interp create] - $c eval {lappend auto_path [pwd]} - set result [$c eval {catch {{[magic mojo proc]}}}] - interp delete $c - } - set result -} 0 - -removeFile [file join pkg magicchar2.tcl] -removeDirectory pkg - + interp create slave +} -body { + auto_mkindex . pkg/magicchar2.tcl + # Make a slave interp to test the autoloading + slave eval {lappend auto_path [pwd]} + slave eval {catch {{[magic mojo proc]}}} +} -cleanup { + interp delete slave + removeFile [file join pkg magicchar2.tcl] + removeDirectory pkg +} -result 0 + # Clean up. unset result @@ -357,3 +334,9 @@ if {[file exists tclIndex]} { cd $origDir ::tcltest::cleanupTests +return + +# Local Variables: +# mode: tcl +# fill-column: 78 +# End: diff --git a/tests/package.test b/tests/package.test index eb24e99..4179a47 100644 --- a/tests/package.test +++ b/tests/package.test @@ -1,38 +1,55 @@ -# This file contains tests for the ::package::* commands. +# This file contains tests for the package and ::pkg::* 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. +# Sourcing this file into Tcl runs the tests and generates output for errors. +# No output means no errors were found. # +# Copyright (c) 1995-1996 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. -# All rights reserved. +# Copyright (c) 2011 Donal K. Fellows # -# RCS: @(#) $Id: package.test,v 1.3 2000/04/10 17:19:02 ericm Exp $ +# See the file "license.terms" for information on usage and redistribution of +# this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: package.test,v 1.4 2011/01/06 10:20:39 dkf Exp $ -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2 namespace import -force ::tcltest::* } -test package-1.1 {pkg::create gives error on insufficient args} { - catch {::pkg::create} -} 1 -test package-1.2 {pkg::create gives error on bad args} { - catch {::pkg::create -foo bar -bar baz -baz boo} -} 1 -test package-1.3 {pkg::create gives error on no value given} { - catch {::pkg::create -name foo -version 1.0 -source test.tcl -load} -} 1 -test package-1.4 {pkg::create gives error on no name given} { - catch {::pkg::create -version 1.0 -source test.tcl -load foo.so} -} 1 -test package-1.5 {pkg::create gives error on no version given} { - catch {::pkg::create -name foo -source test.tcl -load foo.so} -} 1 -test package-1.6 {pkg::create gives error on no source or load options} { - catch {::pkg::create -name foo -version 1.0 -version 2.0} -} 1 +# Do all this in a slave interp to avoid garbaging the package list +set i [interp create] +interp eval $i [list set argv $argv] +interp eval $i [list package require tcltest 2] +interp eval $i [list namespace import -force ::tcltest::*] +interp eval $i { + +package forget {*}[package names] +set oldPkgUnknown [package unknown] +package unknown {} +set oldPath $auto_path +set auto_path "" + +test package-1.1 {pkg::create gives error on insufficient args} -body { + ::pkg::create +} -returnCodes error -match glob -result {wrong # args: should be "*"} +test package-1.2 {pkg::create gives error on bad args} -body { + ::pkg::create -foo bar -bar baz -baz boo +} -returnCodes error -match glob -result {unknown option "bar": *} +test package-1.3 {pkg::create gives error on no value given} -body { + ::pkg::create -name foo -version 1.0 -source test.tcl -load +} -returnCodes error -match glob -result {value for "-load" missing: *} +test package-1.4 {pkg::create gives error on no name given} -body { + ::pkg::create -version 1.0 -source test.tcl -load foo.so +} -returnCodes error -match glob -result {value for "-name" missing: *} +test package-1.5 {pkg::create gives error on no version given} -body { + ::pkg::create -name foo -source test.tcl -load foo.so +} -returnCodes error -match glob -result {value for "-version" missing: *} +test package-1.6 {pkg::create gives error on no source or load options} -body { + ::pkg::create -name foo -version 1.0 -version 2.0 +} -returnCodes error -result {at least one of -load and -source must be given} test package-1.7 {pkg::create gives correct output for 1 direct source} { ::pkg::create -name foo -version 1.0 -source test.tcl } {package ifneeded foo 1.0 [list source [file join $dir test.tcl]]} @@ -67,5 +84,1200 @@ test package-1.16 {pkg::create gives correct output for 1 direct, 1 lazy} { -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}}}]} +test package-2.1 {Tcl_PkgProvide procedure} { + package forget t + package provide t 2.3 +} {} +test package-2.2 {Tcl_PkgProvide procedure} -returnCodes error -setup { + package forget t +} -body { + package provide t 2.3 + package provide t 2.2 +} -result {conflicting versions provided for package "t": 2.3, then 2.2} +test package-2.3 {Tcl_PkgProvide procedure} -returnCodes error -setup { + package forget t +} -body { + package provide t 2.3 + package provide t 2.4 +} -result {conflicting versions provided for package "t": 2.3, then 2.4} +test package-2.4 {Tcl_PkgProvide procedure} -returnCodes error -setup { + package forget t +} -body { + package provide t 2.3 + package provide t 3.3 +} -result {conflicting versions provided for package "t": 2.3, then 3.3} +test package-2.5 {Tcl_PkgProvide procedure} -setup { + package forget t +} -body { + package provide t 2.3 + package provide t 2.3 +} -result {} +test package-2.6 {Tcl_PkgProvide procedure} { + package forget t + package provide t 2.3a1 +} {} + +set n 0 +foreach v { + 2.3k1 2a3a2 2ab3 2.a4 2.b4 2b.4 2a.4 2ba4 2a4b1 + 2b4a1 2b3b2 +} { + test package-2.7.$n {Tcl_PkgProvide procedure} -setup { + package forget t + } -returnCodes error -body " + package provide t $v + " -result "expected version number but got \"$v\"" + incr n +} + +test package-3.1 {Tcl_PkgRequire procedure, picking best version} -setup { + package forget t + set x xxx +} -body { + foreach i {1.4 3.4 2.3 2.4 2.2} { + package ifneeded t $i "set x $i; package provide t $i" + } + package require t + return $x +} -result {3.4} +test package-3.2 {Tcl_PkgRequire procedure, picking best version} -setup { + package forget t + set x xxx +} -body { + foreach i {1.4 3.4 2.3 2.4 2.2 3.5 3.2} { + package ifneeded t $i "set x $i; package provide t $i" + } + package require t + return $x +} -result {3.5} +test package-3.3 {Tcl_PkgRequire procedure, picking best version} -setup { + package forget t + set x xxx +} -body { + foreach i {3.5 2.1 2.3} { + package ifneeded t $i "set x $i; package provide t $i" + } + package require t 2.2 + return $x +} -result {2.3} +test package-3.4 {Tcl_PkgRequire procedure, picking best version} -setup { + package forget t + set x xxx +} -body { + foreach i {1.4 3.4 2.3 2.4 2.2} { + package ifneeded t $i "set x $i; package provide t $i" + } + package require -exact t 2.3 + return $x +} -result {2.3} +test package-3.5 {Tcl_PkgRequire procedure, picking best version} -setup { + package forget t + set x xxx +} -body { + foreach i {1.4 3.4 2.3 2.4 2.2} { + package ifneeded t $i "set x $i; package provide t $i" + } + package require t 2.1 + return $x +} -result {2.4} +test package-3.6 {Tcl_PkgRequire procedure, can't find suitable version} -setup { + package forget t +} -returnCodes error -body { + package unknown {} + foreach i {1.4 3.4 2.3 2.4 2.2} { + package ifneeded t $i "set x $i" + } + package require t 2.5 +} -result {can't find package t 2.5} +test package-3.7 {Tcl_PkgRequire procedure, can't find suitable version} -setup { + package forget t +} -returnCodes error -body { + package unknown {} + foreach i {1.4 3.4 2.3 2.4 2.2} { + package ifneeded t $i "set x $i" + } + package require t 4.1 +} -result {can't find package t 4.1} +test package-3.8 {Tcl_PkgRequire procedure, can't find suitable version} -setup { + package forget t +} -returnCodes error -body { + package unknown {} + foreach i {1.4 3.4 2.3 2.4 2.2} { + package ifneeded t $i "set x $i" + } + package require -exact t 1.3 +} -result {can't find package t exactly 1.3} +test package-3.9 {Tcl_PkgRequire procedure, can't find suitable version} -setup { + package forget t +} -returnCodes error -body { + package unknown {} + package require t +} -result {can't find package t} +test package-3.10 {Tcl_PkgRequire procedure, error in ifneeded script} -setup { + package forget t +} -body { + package ifneeded t 2.1 {package provide t 2.1; error "ifneeded test"} + list [catch {package require t 2.1} msg] $msg $::errorInfo +} -match glob -result {1 {ifneeded test} {ifneeded test + while executing +"error "ifneeded test"" + ("package ifneeded*" script) + invoked from within +"package require t 2.1"}} +test package-3.11 {Tcl_PkgRequire procedure, ifneeded script doesn't provide package} -setup { + package forget t + set x xxx +} -body { + package ifneeded t 2.1 "set x invoked" + list [catch {package require t 2.1} msg] $msg $x +} -match glob -result {1 * invoked} +test package-3.12 {Tcl_PkgRequire procedure, self-deleting script} -setup { + package forget t + set x xxx +} -body { + package ifneeded t 1.2 "package forget t; set x 1.2; package provide t 1.2" + package require t 1.2 + return $x +} -result {1.2} +test package-3.13 {Tcl_PkgRequire procedure, "package unknown" support} -setup { + package forget t + set x xxx +} -body { + proc pkgUnknown args { + # args = name requirement + # requirement = v-v (for exact version) + global x + set x $args + package provide [lindex $args 0] [lindex [split [lindex $args 1] -] 0] + } + foreach i {1.4 3.4 2.3 2.4 2.2} { + package ifneeded t $i "set x $i" + } + package unknown pkgUnknown + package require -exact t 1.5 + return $x +} -cleanup { + package unknown {} +} -result {t 1.5-1.5} +test package-3.14 {Tcl_PkgRequire procedure, "package unknown" support} -setup { + package forget t + set x xxx +} -body { + proc pkgUnknown args { + package ifneeded t 1.2 "set x loaded; package provide t 1.2" + } + package unknown pkgUnknown + list [package require t] $x +} -cleanup { + package unknown {} +} -result {1.2 loaded} +test package-3.15 {Tcl_PkgRequire procedure, "package unknown" support} -setup { + package forget {a b} + package unknown pkgUnknown + set x xxx +} -body { + proc pkgUnknown args { + global x + set x $args + package provide [lindex $args 0] 2.0 + } + package require {a b} + return $x +} -cleanup { + package unknown {} +} -result {{a b} 0-} +test package-3.16 {Tcl_PkgRequire procedure, "package unknown" error} -setup { + package forget t +} -body { + proc pkgUnknown args { + error "testing package unknown" + } + package unknown pkgUnknown + list [catch {package require t} msg] $msg $::errorInfo +} -cleanup { + package unknown {} +} -result {1 {testing package unknown} {testing package unknown + while executing +"error "testing package unknown"" + (procedure "pkgUnknown" line 2) + invoked from within +"pkgUnknown t 0-" + ("package unknown" script) + invoked from within +"package require t"}} +test package-3.17 {Tcl_PkgRequire procedure, "package unknown" doesn't load package} -setup { + package forget t + set x xxx +} -body { + proc pkgUnknown args { + global x + set x $args + } + foreach i {1.4 3.4 2.3 2.4 2.2} { + package ifneeded t $i "set x $i" + } + package unknown pkgUnknown + list [catch {package require -exact t 1.5} msg] $msg $x +} -cleanup { + package unknown {} +} -result {1 {can't find package t exactly 1.5} {t 1.5-1.5}} +test package-3.18 {Tcl_PkgRequire procedure, version checks} -setup { + package forget t +} -body { + package provide t 2.3 + package require t +} -result {2.3} +test package-3.19 {Tcl_PkgRequire procedure, version checks} -setup { + package forget t +} -body { + package provide t 2.3 + package require t 2.1 +} -result {2.3} +test package-3.20 {Tcl_PkgRequire procedure, version checks} -setup { + package forget t +} -body { + package provide t 2.3 + package require t 2.3 +} -result {2.3} +test package-3.21 {Tcl_PkgRequire procedure, version checks} -setup { + package forget t +} -returnCodes error -body { + package provide t 2.3 + package require t 2.4 +} -result {version conflict for package "t": have 2.3, need 2.4} +test package-3.22 {Tcl_PkgRequire procedure, version checks} -setup { + package forget t +} -returnCodes error -body { + package provide t 2.3 + package require t 1.2 +} -result {version conflict for package "t": have 2.3, need 1.2} +test package-3.23 {Tcl_PkgRequire procedure, version checks} -setup { + package forget t +} -body { + package provide t 2.3 + package require -exact t 2.3 +} -result {2.3} +test package-3.24 {Tcl_PkgRequire procedure, version checks} -setup { + package forget t +} -returnCodes error -body { + package provide t 2.3 + package require -exact t 2.2 +} -result {version conflict for package "t": have 2.3, need exactly 2.2} +test package-3.25 {Tcl_PkgRequire procedure, error in ifneeded script} -setup { + package forget t +} -body { + package ifneeded t 2.1 {package provide t 2.1; error "ifneeded test" EI} + list [catch {package require t 2.1} msg] $msg $::errorInfo +} -match glob -result {1 {ifneeded test} {EI + ("package ifneeded*" script) + invoked from within +"package require t 2.1"}} +test package-3.26 {Tcl_PkgRequire procedure, error in ifneeded script} -setup { + package forget t +} -body { + package ifneeded t 2.1 {package provide t 2.1; foreach x 1 {error "ifneeded test" EI}} + list [catch {package require t 2.1} msg] $msg $::errorInfo +} -match glob -result {1 {ifneeded test} {EI + ("foreach" body line 1) + invoked from within +"foreach x 1 {error "ifneeded test" EI}" + ("package ifneeded*" script) + invoked from within +"package require t 2.1"}} +test package-3.27 {Tcl_PkgRequire: circular dependency} -setup { + package forget foo +} -body { + package ifneeded foo 1 {package require foo 1} + package require foo 1 +} -cleanup { + package forget foo +} -returnCodes error -match glob -result {circular package dependency:*} +test package-3.28 {Tcl_PkgRequire: circular dependency} -setup { + package forget foo +} -body { + package ifneeded foo 1 {package require foo 2} + package require foo 1 +} -cleanup { + package forget foo +} -returnCodes error -match glob -result {circular package dependency:*} +test package-3.29 {Tcl_PkgRequire: circular dependency} -setup { + package forget foo + package forget bar +} -body { + package ifneeded foo 1 {package require bar 1; package provide foo 1} + package ifneeded bar 1 {package require foo 1; package provide bar 1} + package require foo 1 +} -cleanup { + package forget foo + package forget bar +} -returnCodes error -match glob -result {circular package dependency:*} +test package-3.30 {Tcl_PkgRequire: circular dependency} -setup { + package forget foo + package forget bar +} -body { + package ifneeded foo 1 {package require bar 1; package provide foo 1} + package ifneeded foo 2 {package provide foo 2} + package ifneeded bar 1 {package require foo 2; package provide bar 1} + package require foo 1 +} -cleanup { + package forget foo + package forget bar +} -returnCodes error -match glob -result {circular package dependency:*} +test package-3.31 {Tcl_PkgRequire: consistent return values (1162286)} -setup { + package forget foo +} -body { + package ifneeded foo 1 {package provide foo 1; error foo} + package require foo 1 +} -cleanup { + package forget foo +} -returnCodes error -match glob -result foo +test package-3.32 {Tcl_PkgRequire: consistent return values (1162286)} -setup { + package forget foo +} -body { + package ifneeded foo 1 {package provide foo 1; error foo} + catch {package require foo 1} + package provide foo +} -cleanup { + package forget foo +} -result {} +test package-3.33 {Tcl_PkgRequire: consistent return values (1162286)} -setup { + package forget foo +} -body { + package ifneeded foo 1 {package provide foo 2} + package require foo 1 +} -cleanup { + package forget foo +} -returnCodes error -match glob -result {attempt to provide package * failed:*} +test package-3.34 {Tcl_PkgRequire: consistent return values (1162286)} -setup { + package forget foo +} -body { + package ifneeded foo 1 {package provide foo 1.1} + package require foo 1 +} -cleanup { + package forget foo +} -returnCodes error -match glob -result {attempt to provide package * failed:*} +test package-3.34.1 {Tcl_PkgRequire: consistent return values (1162286)} -setup { + package forget foo +} -body { + package ifneeded foo 1.1 {package provide foo 1} + package require foo 1 +} -cleanup { + package forget foo +} -returnCodes error -match glob -result {attempt to provide package * failed:*} +test package-3.34.2 {Tcl_PkgRequire: consistent return values (1162286)} -setup { + package forget foo +} -body { + package ifneeded foo 1.1 {package provide foo 1} + package require foo 1.1 +} -cleanup { + package forget foo +} -returnCodes error -match glob -result {attempt to provide package * failed:*} +test package-3.35 {Tcl_PkgRequire: consistent return values (1162286)} -setup { + package forget foo +} -body { + package ifneeded foo 1 {} + package require foo 1 +} -cleanup { + package forget foo +} -returnCodes error -match glob -result {attempt to provide package * failed:*} +test package-3.35.1 {Tcl_PkgRequire: consistent return values (1162286)} -setup { + package forget foo +} -body { + package ifneeded foo 1 {break} + package require foo 1 +} -cleanup { + package forget foo +} -returnCodes error -match glob \ +-result {attempt to provide package * failed: bad return code:*} +test package-3.36 {Tcl_PkgRequire: consistent return values (1162286)} -setup { + package forget foo +} -body { + package ifneeded foo 1 {continue} + package require foo 1 +} -cleanup { + package forget foo +} -returnCodes error -match glob \ +-result {attempt to provide package * failed: bad return code:*} +test package-3.37 {Tcl_PkgRequire: consistent return values (1162286)} -setup { + package forget foo +} -body { + package ifneeded foo 1 {return} + package require foo 1 +} -cleanup { + package forget foo +} -returnCodes error -match glob \ +-result {attempt to provide package * failed: bad return code:*} +test package-3.38 {Tcl_PkgRequire: consistent return values (1162286)} -setup { + package forget foo +} -body { + package ifneeded foo 1 {return -level 0 -code 10} + package require foo 1 +} -cleanup { + package forget foo +} -returnCodes error -match glob \ +-result {attempt to provide package * failed: bad return code:*} +test package-3.39 {Tcl_PkgRequire: consistent return values (1162286)} -setup { + package forget foo + set saveUnknown [package unknown] + package unknown {package provide foo 2 ;#} +} -body { + package require foo 1 +} -cleanup { + package forget foo + package unknown $saveUnknown +} -returnCodes error -match glob -result * +test package-3.40 {Tcl_PkgRequire: consistent return values (1162286)} -setup { + package forget foo + set saveUnknown [package unknown] + package unknown {break ;#} +} -body { + package require foo 1 +} -cleanup { + package forget foo + package unknown $saveUnknown +} -returnCodes error -match glob -result {bad return code:*} +test package-3.41 {Tcl_PkgRequire: consistent return values (1162286)} -setup { + package forget foo + set saveUnknown [package unknown] + package unknown {continue ;#} +} -body { + package require foo 1 +} -cleanup { + package forget foo + package unknown $saveUnknown +} -returnCodes error -match glob -result {bad return code:*} +test package-3.42 {Tcl_PkgRequire: consistent return values (1162286)} -setup { + package forget foo + set saveUnknown [package unknown] + package unknown {return ;#} +} -body { + package require foo 1 +} -cleanup { + package forget foo + package unknown $saveUnknown +} -returnCodes error -match glob -result {bad return code:*} +test package-3.43 {Tcl_PkgRequire: consistent return values (1162286)} -setup { + package forget foo + set saveUnknown [package unknown] + package unknown {return -level 0 -code 10 ;#} +} -body { + package require foo 1 +} -cleanup { + package forget foo + package unknown $saveUnknown +} -returnCodes error -match glob -result {bad return code:*} +test package-3.44 {Tcl_PkgRequire: exact version matching (1578344)} -setup { + package provide demo 1.2.3 +} -body { + package require -exact demo 1.2 +} -returnCodes error -cleanup { + package forget demo +} -result {version conflict for package "demo": have 1.2.3, need exactly 1.2} +test package-3.50 {Tcl_PkgRequire procedure, picking best stable version} -setup { + package forget t + set x xxx +} -body { + foreach i {1.4 3.4 4.0a1 2.3 2.4 2.2} { + package ifneeded t $i "set x $i; package provide t $i" + } + package require t + return $x +} -result {3.4} +test package-3.51 {Tcl_PkgRequire procedure, picking best stable version} -setup { + package forget t + set x xxx +} -body { + foreach i {1.2b1 1.2 1.3a2 1.3} { + package ifneeded t $i "set x $i; package provide t $i" + } + package require t + return $x +} -result {1.3} +test package-3.52 {Tcl_PkgRequire procedure, picking best stable version} -setup { + package forget t + set x xxx +} -body { + foreach i {1.2b1 1.2 1.3 1.3a2} { + package ifneeded t $i "set x $i; package provide t $i" + } + package require t + return $x +} -result {1.3} + +test package-4.1 {Tcl_PackageCmd procedure} -returnCodes error -body { + package +} -result {wrong # args: should be "package option ?arg ...?"} +test package-4.2 {Tcl_PackageCmd procedure, "forget" option} { + package forget {*}[package names] + package names +} {} +test package-4.3 {Tcl_PackageCmd procedure, "forget" option} { + package forget {*}[package names] + package forget foo +} {} +test package-4.4 {Tcl_PackageCmd procedure, "forget" option} -setup { + package forget {*}[package names] + set result {} +} -body { + package ifneeded t 1.1 {first script} + package ifneeded t 2.3 {second script} + package ifneeded x 1.4 {x's script} + lappend result [lsort [package names]] [package versions t] + package forget t + lappend result [lsort [package names]] [package versions t] +} -result {{t x} {1.1 2.3} x {}} +test package-4.5 {Tcl_PackageCmd procedure, "forget" option} -setup { + package forget {*}[package names] +} -body { + package ifneeded a 1.1 {first script} + package ifneeded b 2.3 {second script} + package ifneeded c 1.4 {third script} + package forget + set result [list [lsort [package names]]] + package forget a c + lappend result [lsort [package names]] +} -result {{a b c} b} +test package-4.5.1 {Tcl_PackageCmd procedure, "forget" option} -body { + # Test for Bug 415273 + package ifneeded a 1 "I should have been forgotten" + package forget no-such-package a + package ifneeded a 1 +} -cleanup { + package forget a +} -result {} +test package-4.6 {Tcl_PackageCmd procedure, "ifneeded" option} -body { + package ifneeded a +} -returnCodes error -result {wrong # args: should be "package ifneeded package version ?script?"} +test package-4.7 {Tcl_PackageCmd procedure, "ifneeded" option} -body { + package ifneeded a b c d +} -returnCodes error -result {wrong # args: should be "package ifneeded package version ?script?"} +test package-4.8 {Tcl_PackageCmd procedure, "ifneeded" option} -body { + package ifneeded t xyz +} -returnCodes error -result {expected version number but got "xyz"} +test package-4.9 {Tcl_PackageCmd procedure, "ifneeded" option} { + package forget {*}[package names] + list [package ifneeded foo 1.1] [package names] +} {{} {}} +test package-4.10 {Tcl_PackageCmd procedure, "ifneeded" option} -setup { + package forget t +} -body { + package ifneeded t 1.4 "script for t 1.4" + list [package names] [package ifneeded t 1.4] [package versions t] +} -result {t {script for t 1.4} 1.4} +test package-4.11 {Tcl_PackageCmd procedure, "ifneeded" option} -setup { + package forget t +} -body { + package ifneeded t 1.4 "script for t 1.4" + list [package ifneeded t 1.5] [package names] [package versions t] +} -result {{} t 1.4} +test package-4.12 {Tcl_PackageCmd procedure, "ifneeded" option} -setup { + package forget t +} -body { + package ifneeded t 1.4 "script for t 1.4" + package ifneeded t 1.4 "second script for t 1.4" + list [package ifneeded t 1.4] [package names] [package versions t] +} -result {{second script for t 1.4} t 1.4} +test package-4.13 {Tcl_PackageCmd procedure, "ifneeded" option} -setup { + package forget t +} -body { + package ifneeded t 1.4 "script for t 1.4" + package ifneeded t 1.2 "second script" + package ifneeded t 3.1 "last script" + list [package ifneeded t 1.2] [package versions t] +} -result {{second script} {1.4 1.2 3.1}} +test package-4.14 {Tcl_PackageCmd procedure, "names" option} -body { + package names a +} -returnCodes error -result {wrong # args: should be "package names"} +test package-4.15 {Tcl_PackageCmd procedure, "names" option} { + package forget {*}[package names] + package names +} {} +test package-4.16 {Tcl_PackageCmd procedure, "names" option} -setup { + package forget {*}[package names] +} -body { + package ifneeded x 1.2 {dummy} + package provide x 1.3 + package provide y 2.4 + catch {package require z 47.16} + lsort [package names] +} -result {x y} +test package-4.17 {Tcl_PackageCmd procedure, "provide" option} -body { + package provide +} -returnCodes error -result {wrong # args: should be "package provide package ?version?"} +test package-4.18 {Tcl_PackageCmd procedure, "provide" option} -body { + package provide a b c +} -returnCodes error -result {wrong # args: should be "package provide package ?version?"} +test package-4.19 {Tcl_PackageCmd procedure, "provide" option} -setup { + package forget t +} -body { + package provide t +} -result {} +test package-4.20 {Tcl_PackageCmd procedure, "provide" option} -setup { + package forget t +} -body { + package provide t 2.3 + package provide t +} -result {2.3} +test package-4.21 {Tcl_PackageCmd procedure, "provide" option} -setup { + package forget t +} -returnCodes error -body { + package provide t a.b +} -result {expected version number but got "a.b"} +test package-4.22 {Tcl_PackageCmd procedure, "require" option} -returnCodes error -body { + package require +} -result {wrong # args: should be "package require ?-exact? package ?requirement ...?"} +test package-4.24 {Tcl_PackageCmd procedure, "require" option} -body { + package require -exact a b c + # Exact syntax: -exact name version + # name ?requirement ...? +} -returnCodes error -result {wrong # args: should be "package require ?-exact? package ?requirement ...?"} +test package-4.26 {Tcl_PackageCmd procedure, "require" option} -body { + package require x a.b +} -returnCodes error -result {expected version number but got "a.b"} +test package-4.27 {Tcl_PackageCmd procedure, "require" option} -body { + package require -exact x a.b +} -returnCodes error -result {expected version number but got "a.b"} +test package-4.28 {Tcl_PackageCmd procedure, "require" option} -body { + package require -exact x +} -returnCodes error -result {wrong # args: should be "package require ?-exact? package ?requirement ...?"} +test package-4.29 {Tcl_PackageCmd procedure, "require" option} -body { + package require -exact +} -returnCodes error -result {wrong # args: should be "package require ?-exact? package ?requirement ...?"} +test package-4.30 {Tcl_PackageCmd procedure, "require" option} -setup { + package forget t +} -body { + package provide t 2.3 + package require t 2.1 +} -result {2.3} +test package-4.31 {Tcl_PackageCmd procedure, "require" option} -setup { + package forget t +} -body { + package require t +} -returnCodes error -result {can't find package t} +test package-4.32 {Tcl_PackageCmd procedure, "require" option} -setup { + package forget t +} -body { + package ifneeded t 2.3 "error {synthetic error}" + package require t 2.3 +} -returnCodes error -result {synthetic error} +test package-4.33 {Tcl_PackageCmd procedure, "unknown" option} -body { + package unknown a b +} -returnCodes error -result {wrong # args: should be "package unknown ?command?"} +test package-4.34 {Tcl_PackageCmd procedure, "unknown" option} { + package unknown "test script" + package unknown +} {test script} +test package-4.35 {Tcl_PackageCmd procedure, "unknown" option} { + package unknown "test script" + package unknown {} + package unknown +} {} +test package-4.36 {Tcl_PackageCmd procedure, "vcompare" option} -body { + package vcompare a +} -returnCodes error -result {wrong # args: should be "package vcompare version1 version2"} +test package-4.37 {Tcl_PackageCmd procedure, "vcompare" option} -body { + package vcompare a b c +} -returnCodes error -result {wrong # args: should be "package vcompare version1 version2"} +test package-4.38 {Tcl_PackageCmd procedure, "vcompare" option} -body { + package vcompare x.y 3.4 +} -returnCodes error -result {expected version number but got "x.y"} +test package-4.39 {Tcl_PackageCmd procedure, "vcompare" option} -body { + package vcompare 2.1 a.b +} -returnCodes error -result {expected version number but got "a.b"} +test package-4.40 {Tcl_PackageCmd procedure, "vcompare" option} { + package vc 2.1 2.3 +} {-1} +test package-4.41 {Tcl_PackageCmd procedure, "vcompare" option} { + package vc 2.2.4 2.2.4 +} {0} +test package-4.42 {Tcl_PackageCmd procedure, "versions" option} -body { + package versions +} -returnCodes error -result {wrong # args: should be "package versions package"} +test package-4.43 {Tcl_PackageCmd procedure, "versions" option} -body { + package versions a b +} -returnCodes error -result {wrong # args: should be "package versions package"} +test package-4.44 {Tcl_PackageCmd procedure, "versions" option} -body { + package forget t + package versions t +} -result {} +test package-4.45 {Tcl_PackageCmd procedure, "versions" option} -setup { + package forget t +} -body { + package provide t 2.3 + package versions t +} -result {} +test package-4.46 {Tcl_PackageCmd procedure, "versions" option} -setup { + package forget t +} -body { + package ifneeded t 2.3 x + package ifneeded t 2.4 y + package versions t +} -result {2.3 2.4} +test package-4.47 {Tcl_PackageCmd procedure, "vsatisfies" option} -body { + package vsatisfies a +} -returnCodes error -result {wrong # args: should be "package vsatisfies version ?requirement ...?"} +test package-4.49 {Tcl_PackageCmd procedure, "vsatisfies" option} -body { + package vsatisfies x.y 3.4 +} -returnCodes error -result {expected version number but got "x.y"} +test package-4.50 {Tcl_PackageCmd procedure, "vsatisfies" option} -body { + package vcompare 2.1 a.b +} -returnCodes error -result {expected version number but got "a.b"} +test package-4.51 {Tcl_PackageCmd procedure, "vsatisfies" option} { + package vs 2.3 2.1 +} {1} +test package-4.52 {Tcl_PackageCmd procedure, "vsatisfies" option} { + package vs 2.3 1.2 +} {0} +test package-4.53 {Tcl_PackageCmd procedure, "versions" option} -body { + package foo +} -returnCodes error -result {bad option "foo": must be forget, ifneeded, names, prefer, present, provide, require, unknown, vcompare, versions, or vsatisfies} +test package-4.54 {Tcl_PackageCmd procedure, "vsatisfies" option} -body { + package vsatisfies 2.1 2.1-3.2-4.5 +} -returnCodes error -result {expected versionMin-versionMax but got "2.1-3.2-4.5"} +test package-4.55 {Tcl_PackageCmd procedure, "vsatisfies" option} -body { + package vsatisfies 2.1 3.2-x.y +} -returnCodes error -result {expected version number but got "x.y"} +test package-4.56 {Tcl_PackageCmd procedure, "vsatisfies" option} -body { + package vsatisfies 2.1 x.y-3.2 +} -returnCodes error -result {expected version number but got "x.y"} + +# No tests for FindPackage; can't think up anything detectable errors. + +test package-5.1 {TclFreePackageInfo procedure} { + interp create slave + slave eval { + package ifneeded t 2.3 x + package ifneeded t 2.4 y + package ifneeded x 3.1 z + package provide q 4.3 + package unknown "will this get freed?" + } + interp delete slave +} {} +test package-5.2 {TclFreePackageInfo procedure} -body { + interp create foo + foo eval { + package ifneeded t 2.3 x + package ifneeded t 2.4 y + package ifneeded x 3.1 z + package provide q 4.3 + } + foo alias z kill + proc kill {} { + interp delete foo + } + foo eval package require x 3.1 +} -returnCodes error -match glob -result * + +test package-6.1 {CheckVersion procedure} { + package vcompare 1 2.1 +} -1 +test package-6.2 {CheckVersion procedure} -body { + package vcompare .1 2.1 +} -returnCodes error -result {expected version number but got ".1"} +test package-6.3 {CheckVersion procedure} -body { + package vcompare 111.2a.3 2.1 +} -returnCodes error -result {expected version number but got "111.2a.3"} +test package-6.4 {CheckVersion procedure} -body { + package vcompare 1.2.3. 2.1 +} -returnCodes error -result {expected version number but got "1.2.3."} +test package-6.5 {CheckVersion procedure} -body { + package vcompare 1.2..3 2.1 +} -returnCodes error -result {expected version number but got "1.2..3"} + +test package-7.1 {ComparePkgVersions procedure} { + package vcompare 1.23 1.22 +} {1} +test package-7.2 {ComparePkgVersions procedure} { + package vcompare 1.22.1.2.3 1.22.1.2.3 +} {0} +test package-7.3 {ComparePkgVersions procedure} { + package vcompare 1.21 1.22 +} {-1} +test package-7.4 {ComparePkgVersions procedure} { + package vcompare 1.21 1.21.2 +} {-1} +test package-7.5 {ComparePkgVersions procedure} { + package vcompare 1.21.1 1.21 +} {1} +test package-7.6 {ComparePkgVersions procedure} { + package vsatisfies 1.21.1 1.21 +} {1} +test package-7.7 {ComparePkgVersions procedure} { + package vsatisfies 2.22.3 1.21 +} {0} +test package-7.8 {ComparePkgVersions procedure} { + package vsatisfies 1 1 +} {1} +test package-7.9 {ComparePkgVersions procedure} { + package vsatisfies 2 1 +} {0} + +test package-8.1 {Tcl_PkgPresent procedure, any version} -setup { + package forget t +} -body { + package provide t 2.4 + package present t +} -result {2.4} +test package-8.2 {Tcl_PkgPresent procedure, correct version} -setup { + package forget t +} -body { + package provide t 2.4 + package present t 2.4 +} -result {2.4} +test package-8.3 {Tcl_PkgPresent procedure, satisfying version} -setup { + package forget t +} -body { + package provide t 2.4 + package present t 2.0 +} -result {2.4} +test package-8.4 {Tcl_PkgPresent procedure, not satisfying version} -setup { + package forget t +} -returnCodes error -body { + package provide t 2.4 + package present t 2.6 +} -result {version conflict for package "t": have 2.4, need 2.6} +test package-8.5 {Tcl_PkgPresent procedure, not satisfying version} -setup { + package forget t +} -returnCodes error -body { + package provide t 2.4 + package present t 1.0 +} -result {version conflict for package "t": have 2.4, need 1.0} +test package-8.6 {Tcl_PkgPresent procedure, exact version} -setup { + package forget t +} -body { + package provide t 2.4 + package present -exact t 2.4 +} -result {2.4} +test package-8.7 {Tcl_PkgPresent procedure, not exact version} -setup { + package forget t +} -returnCodes error -body { + package provide t 2.4 + package present -exact t 2.3 +} -result {version conflict for package "t": have 2.4, need exactly 2.3} +test package-8.8 {Tcl_PkgPresent procedure, unknown package} -body { + package forget t + package present t +} -returnCodes error -result {package t is not present} +test package-8.9 {Tcl_PkgPresent procedure, unknown package} -body { + package forget t + package present t 2.4 +} -returnCodes error -result {package t 2.4 is not present} +test package-8.10 {Tcl_PkgPresent procedure, unknown package} -body { + package forget t + package present -exact t 2.4 +} -returnCodes error -result {package t 2.4 is not present} +test package-8.11 {Tcl_PackageCmd procedure, "present" option} -body { + package present +} -returnCodes error -result {wrong # args: should be "package present ?-exact? package ?requirement ...?"} +test package-8.12 {Tcl_PackageCmd procedure, "present" option} -body { + package present a b c +} -returnCodes error -result {expected version number but got "b"} +test package-8.13 {Tcl_PackageCmd procedure, "present" option} -body { + package present -exact a b c +} -returnCodes error -result {wrong # args: should be "package present ?-exact? package ?requirement ...?"} +test package-8.14 {Tcl_PackageCmd procedure, "present" option} -body { + package present -bs a b +} -returnCodes error -result {expected version number but got "a"} +test package-8.15 {Tcl_PackageCmd procedure, "present" option} -body { + package present x a.b +} -returnCodes error -result {expected version number but got "a.b"} +test package-8.16 {Tcl_PackageCmd procedure, "present" option} -body { + package present -exact x a.b +} -returnCodes error -result {expected version number but got "a.b"} +test package-8.17 {Tcl_PackageCmd procedure, "present" option} -body { + package present -exact x +} -returnCodes error -result {wrong # args: should be "package present ?-exact? package ?requirement ...?"} +test package-8.18 {Tcl_PackageCmd procedure, "present" option} -body { + package present -exact +} -returnCodes error -result {wrong # args: should be "package present ?-exact? package ?requirement ...?"} + +set n 0 +foreach {r p vs vc} { + 8.5a0 8.5a5 1 -1 + 8.5a0 8.5b1 1 -1 + 8.5a0 8.5.1 1 -1 + 8.5a0 8.6a0 1 -1 + 8.5a0 8.6b0 1 -1 + 8.5a0 8.6.0 1 -1 + 8.5a6 8.5a5 0 1 + 8.5a6 8.5b1 1 -1 + 8.5a6 8.5.1 1 -1 + 8.5a6 8.6a0 1 -1 + 8.5a6 8.6b0 1 -1 + 8.5a6 8.6.0 1 -1 + 8.5b0 8.5a5 0 1 + 8.5b0 8.5b1 1 -1 + 8.5b0 8.5.1 1 -1 + 8.5b0 8.6a0 1 -1 + 8.5b0 8.6b0 1 -1 + 8.5b0 8.6.0 1 -1 + 8.5b2 8.5a5 0 1 + 8.5b2 8.5b1 0 1 + 8.5b2 8.5.1 1 -1 + 8.5b2 8.6a0 1 -1 + 8.5b2 8.6b0 1 -1 + 8.5b2 8.6.0 1 -1 + 8.5 8.5a5 1 1 + 8.5 8.5b1 1 1 + 8.5 8.5.1 1 -1 + 8.5 8.6a0 1 -1 + 8.5 8.6b0 1 -1 + 8.5 8.6.0 1 -1 + 8.5.0 8.5a5 0 1 + 8.5.0 8.5b1 0 1 + 8.5.0 8.5.1 1 -1 + 8.5.0 8.6a0 1 -1 + 8.5.0 8.6b0 1 -1 + 8.5.0 8.6.0 1 -1 + 10 8 0 1 + 8 10 0 -1 + 0.0.1.2 0.1.2 1 -1 +} { + test package-9.$n {package vsatisfies} { + package vsatisfies $p $r + } $vs + test package-10.$n {package vcompare} { + package vcompare $r $p + } $vc + incr n +} + +test package-11.0 {package vcompare at 32bit boundary} { + package vcompare [expr {1<<31}] [expr {(1<<31)-1}] +} 1 + +# Note: It is correct that the result of the very first test, i.e. "5.0 5.0a0" +# is 1, i.e. that version 5.0a0 satisfies a 5.0 requirement. + +# The requirement "5.0" internally translates first to "5.0-6", and then to +# its final form of "5.0a0-6a0". These translations are explicitly specified +# by the TIP (Search for "padded/extended internally with 'a0'"). This was +# done intentionally for exactly the tested case, that an alpha package can +# satisfy a requirement for the regular package. An example would be a package +# FOO requiring Tcl 8.X for its operation. It can be used with Tcl 8.Xa0. +# Without our translation that would not be possible. + +set n 0 +foreach {required provided satisfied} { + 5.0 5.0a0 1 + 5.0a0 5.0 1 + + 8.5a0- 8.5a5 1 + 8.5a0- 8.5b1 1 + 8.5a0- 8.5.1 1 + 8.5a0- 8.6a0 1 + 8.5a0- 8.6b0 1 + 8.5a0- 8.6.0 1 + 8.5a6- 8.5a5 0 + 8.5a6- 8.5b1 1 + 8.5a6- 8.5.1 1 + 8.5a6- 8.6a0 1 + 8.5a6- 8.6b0 1 + 8.5a6- 8.6.0 1 + 8.5b0- 8.5a5 0 + 8.5b0- 8.5b1 1 + 8.5b0- 8.5.1 1 + 8.5b0- 8.6a0 1 + 8.5b0- 8.6b0 1 + 8.5b0- 8.6.0 1 + 8.5b2- 8.5a5 0 + 8.5b2- 8.5b1 0 + 8.5b2- 8.5.1 1 + 8.5b2- 8.6a0 1 + 8.5b2- 8.6b0 1 + 8.5b2- 8.6.0 1 + 8.5- 8.5a5 1 + 8.5- 8.5b1 1 + 8.5- 8.5.1 1 + 8.5- 8.6a0 1 + 8.5- 8.6b0 1 + 8.5- 8.6.0 1 + 8.5.0- 8.5a5 0 + 8.5.0- 8.5b1 0 + 8.5.0- 8.5.1 1 + 8.5.0- 8.6a0 1 + 8.5.0- 8.6b0 1 + 8.5.0- 8.6.0 1 + 8.5a0-7 8.5a5 0 + 8.5a0-7 8.5b1 0 + 8.5a0-7 8.5.1 0 + 8.5a0-7 8.6a0 0 + 8.5a0-7 8.6b0 0 + 8.5a0-7 8.6.0 0 + 8.5a6-7 8.5a5 0 + 8.5a6-7 8.5b1 0 + 8.5a6-7 8.5.1 0 + 8.5a6-7 8.6a0 0 + 8.5a6-7 8.6b0 0 + 8.5a6-7 8.6.0 0 + 8.5b0-7 8.5a5 0 + 8.5b0-7 8.5b1 0 + 8.5b0-7 8.5.1 0 + 8.5b0-7 8.6a0 0 + 8.5b0-7 8.6b0 0 + 8.5b0-7 8.6.0 0 + 8.5b2-7 8.5a5 0 + 8.5b2-7 8.5b1 0 + 8.5b2-7 8.5.1 0 + 8.5b2-7 8.6a0 0 + 8.5b2-7 8.6b0 0 + 8.5b2-7 8.6.0 0 + 8.5-7 8.5a5 0 + 8.5-7 8.5b1 0 + 8.5-7 8.5.1 0 + 8.5-7 8.6a0 0 + 8.5-7 8.6b0 0 + 8.5-7 8.6.0 0 + 8.5.0-7 8.5a5 0 + 8.5.0-7 8.5b1 0 + 8.5.0-7 8.5.1 0 + 8.5.0-7 8.6a0 0 + 8.5.0-7 8.6b0 0 + 8.5.0-7 8.6.0 0 + 8.5a0-8.6.1 8.5a5 1 + 8.5a0-8.6.1 8.5b1 1 + 8.5a0-8.6.1 8.5.1 1 + 8.5a0-8.6.1 8.6a0 1 + 8.5a0-8.6.1 8.6b0 1 + 8.5a0-8.6.1 8.6.0 1 + 8.5a6-8.6.1 8.5a5 0 + 8.5a6-8.6.1 8.5b1 1 + 8.5a6-8.6.1 8.5.1 1 + 8.5a6-8.6.1 8.6a0 1 + 8.5a6-8.6.1 8.6b0 1 + 8.5a6-8.6.1 8.6.0 1 + 8.5b0-8.6.1 8.5a5 0 + 8.5b0-8.6.1 8.5b1 1 + 8.5b0-8.6.1 8.5.1 1 + 8.5b0-8.6.1 8.6a0 1 + 8.5b0-8.6.1 8.6b0 1 + 8.5b0-8.6.1 8.6.0 1 + 8.5b2-8.6.1 8.5a5 0 + 8.5b2-8.6.1 8.5b1 0 + 8.5b2-8.6.1 8.5.1 1 + 8.5b2-8.6.1 8.6a0 1 + 8.5b2-8.6.1 8.6b0 1 + 8.5b2-8.6.1 8.6.0 1 + 8.5-8.6.1 8.5a5 1 + 8.5-8.6.1 8.5b1 1 + 8.5-8.6.1 8.5.1 1 + 8.5-8.6.1 8.6a0 1 + 8.5-8.6.1 8.6b0 1 + 8.5-8.6.1 8.6.0 1 + 8.5.0-8.6.1 8.5a5 0 + 8.5.0-8.6.1 8.5b1 0 + 8.5.0-8.6.1 8.5.1 1 + 8.5.0-8.6.1 8.6a0 1 + 8.5.0-8.6.1 8.6b0 1 + 8.5.0-8.6.1 8.6.0 1 + 8.5a0-8.5a0 8.5a0 1 + 8.5a0-8.5a0 8.5b1 0 + 8.5a0-8.5a0 8.4 0 + 8.5b0-8.5b0 8.5a5 0 + 8.5b0-8.5b0 8.5b0 1 + 8.5b0-8.5b0 8.5.1 0 + 8.5-8.5 8.5a5 0 + 8.5-8.5 8.5b1 0 + 8.5-8.5 8.5 1 + 8.5-8.5 8.5.1 0 + 8.5.0-8.5.0 8.5a5 0 + 8.5.0-8.5.0 8.5b1 0 + 8.5.0-8.5.0 8.5.0 1 + 8.5.0-8.5.0 8.5.1 0 + 8.5.0-8.5.0 8.6a0 0 + 8.5.0-8.5.0 8.6b0 0 + 8.5.0-8.5.0 8.6.0 0 + 8.2 9 0 + 8.2- 9 1 + 8.2-8.5 9 0 + 8.2-9.1 9 1 + + 8.5-8.5 8.5b1 0 + 8.5a0-8.5 8.5b1 0 + 8.5a0-8.5.1 8.5b1 1 + + 8.5-8.5 8.5 1 + 8.5.0-8.5.0 8.5 1 + 8.5a0-8.5.0 8.5 0 +} { + test package-11.$n "package vsatisfies $provided $required" { + package vsatisfies $provided $required + } $satisfied + incr n +} + +test package-12.0 "package vsatisfies multiple" { + # yes no + package vsatisfies 8.4 8.4 7.3 +} 1 +test package-12.1 "package vsatisfies multiple" { + # no yes + package vsatisfies 8.4 7.3 8.4 +} 1 +test package-12.2 "package vsatisfies multiple" { + # yes yes + package vsatisfies 8.4.2 8.4 8.4.1 +} 1 +test package-12.3 "package vsatisfies multiple" { + # no no + package vsatisfies 8.4 7.3 6.1 +} 0 + +proc prefer {args} { + set ip [interp create] + try { + lappend res [$ip eval {package prefer}] + foreach mode $args { + lappend res [$ip eval [list package prefer $mode]] + } + return $res + } finally { + interp delete $ip + } +} + +test package-13.0 {package prefer defaults} { + prefer +} stable +test package-13.1 {package prefer defaults} -body { + set ::env(TCL_PKG_PREFER_LATEST) stable ;# value not relevant! + prefer +} -cleanup { + unset -nocomplain ::env(TCL_PKG_PREFER_LATEST) +} -result latest + +test package-14.0 {wrong\#args} -returnCodes error -body { + package prefer foo bar +} -result {wrong # args: should be "package prefer ?latest|stable?"} +test package-14.1 {bogus argument} -returnCodes error -body { + package prefer foo +} -result {bad preference "foo": must be latest or stable} + +test package-15.0 {set, keep} {package prefer stable} stable +test package-15.1 {set stable, keep} {prefer stable} {stable stable} +test package-15.2 {set latest, change} {prefer latest} {stable latest} +test package-15.3 {set latest, keep} { + prefer latest latest +} {stable latest latest} +test package-15.4 {set stable, rejected} { + prefer latest stable +} {stable latest latest} + +rename prefer {} + +set auto_path $oldPath +package unknown $oldPkgUnknown + +cleanupTests +} + +# cleanup +interp delete $i ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# fill-column: 78 +# End: diff --git a/tests/pkg.test b/tests/pkg.test deleted file mode 100644 index 4f92d4c..0000000 --- a/tests/pkg.test +++ /dev/null @@ -1,1222 +0,0 @@ -# -*- tcl -*- -# Commands covered: pkg -# -# This file contains a collection of tests for one or more of the Tcl -# built-in commands. Sourcing this file into Tcl runs the tests and -# generates output for errors. No output means no errors were found. -# -# Copyright (c) 1995-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: pkg.test,v 1.31 2008/07/19 22:50:39 nijtmans Exp $ - -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 - namespace import -force ::tcltest::* -} - -# Do all this in a slave interp to avoid garbaging the -# package list -set i [interp create] -interp eval $i [list set argv $argv] -interp eval $i [list package require tcltest 2] -interp eval $i [list namespace import -force ::tcltest::*] -interp eval $i { - -package forget {*}[package names] -set oldPkgUnknown [package unknown] -package unknown {} -set oldPath $auto_path -set auto_path "" - -test pkg-1.1 {Tcl_PkgProvide procedure} { - package forget t - package provide t 2.3 -} {} -test pkg-1.2 {Tcl_PkgProvide procedure} { - package forget t - package provide t 2.3 - list [catch {package provide t 2.2} msg] $msg -} {1 {conflicting versions provided for package "t": 2.3, then 2.2}} -test pkg-1.3 {Tcl_PkgProvide procedure} { - package forget t - package provide t 2.3 - list [catch {package provide t 2.4} msg] $msg -} {1 {conflicting versions provided for package "t": 2.3, then 2.4}} -test pkg-1.4 {Tcl_PkgProvide procedure} { - package forget t - package provide t 2.3 - list [catch {package provide t 3.3} msg] $msg -} {1 {conflicting versions provided for package "t": 2.3, then 3.3}} -test pkg-1.5 {Tcl_PkgProvide procedure} { - package forget t - package provide t 2.3 - package provide t 2.3 -} {} - -test pkg-1.6 {Tcl_PkgProvide procedure} { - package forget t - package provide t 2.3a1 -} {} - -set n 0 -foreach v { - 2.3k1 2a3a2 2ab3 2.a4 2.b4 2b.4 2a.4 2ba4 2a4b1 - 2b4a1 2b3b2 -} { - test pkg-1.7.$n {Tcl_PkgProvide procedure} { - package forget t - list [catch {package provide t $v} msg] $msg - } [list 1 "expected version number but got \"$v\""] - incr n -} - -test pkg-2.1 {Tcl_PkgRequire procedure, picking best version} { - package forget t - foreach i {1.4 3.4 2.3 2.4 2.2} { - package ifneeded t $i "set x $i; package provide t $i" - } - set x xxx - package require t - set x -} {3.4} -test pkg-2.2 {Tcl_PkgRequire procedure, picking best version} { - package forget t - foreach i {1.4 3.4 2.3 2.4 2.2 3.5 3.2} { - package ifneeded t $i "set x $i; package provide t $i" - } - set x xxx - package require t - set x -} {3.5} -test pkg-2.3 {Tcl_PkgRequire procedure, picking best version} { - package forget t - foreach i {3.5 2.1 2.3} { - package ifneeded t $i "set x $i; package provide t $i" - } - set x xxx - package require t 2.2 - set x -} {2.3} -test pkg-2.4 {Tcl_PkgRequire procedure, picking best version} { - package forget t - foreach i {1.4 3.4 2.3 2.4 2.2} { - package ifneeded t $i "set x $i; package provide t $i" - } - set x xxx - package require -exact t 2.3 - set x -} {2.3} -test pkg-2.5 {Tcl_PkgRequire procedure, picking best version} { - package forget t - foreach i {1.4 3.4 2.3 2.4 2.2} { - package ifneeded t $i "set x $i; package provide t $i" - } - set x xxx - package require t 2.1 - set x -} {2.4} -test pkg-2.6 {Tcl_PkgRequire procedure, can't find suitable version} { - package forget t - package unknown {} - foreach i {1.4 3.4 2.3 2.4 2.2} { - package ifneeded t $i "set x $i" - } - list [catch {package require t 2.5} msg] $msg -} {1 {can't find package t 2.5}} -test pkg-2.7 {Tcl_PkgRequire procedure, can't find suitable version} { - package forget t - package unknown {} - foreach i {1.4 3.4 2.3 2.4 2.2} { - package ifneeded t $i "set x $i" - } - list [catch {package require t 4.1} msg] $msg -} {1 {can't find package t 4.1}} -test pkg-2.8 {Tcl_PkgRequire procedure, can't find suitable version} { - package forget t - package unknown {} - foreach i {1.4 3.4 2.3 2.4 2.2} { - package ifneeded t $i "set x $i" - } - list [catch {package require -exact t 1.3} msg] $msg -} {1 {can't find package t exactly 1.3}} -test pkg-2.9 {Tcl_PkgRequire procedure, can't find suitable version} { - package forget t - package unknown {} - list [catch {package require t} msg] $msg -} {1 {can't find package t}} -test pkg-2.10 {Tcl_PkgRequire procedure, error in ifneeded script} -body { - package forget t - package ifneeded t 2.1 {package provide t 2.1; error "ifneeded test"} - list [catch {package require t 2.1} msg] $msg $::errorInfo -} -match glob -result {1 {ifneeded test} {ifneeded test - while executing -"error "ifneeded test"" - ("package ifneeded*" script) - invoked from within -"package require t 2.1"}} -test pkg-2.11 {Tcl_PkgRequire procedure, ifneeded script doesn't provide package} -body { - package forget t - package ifneeded t 2.1 "set x invoked" - set x xxx - list [catch {package require t 2.1} msg] $msg $x -} -match glob -result {1 * invoked} -test pkg-2.12 {Tcl_PkgRequire procedure, self-deleting script} { - package forget t - package ifneeded t 1.2 "package forget t; set x 1.2; package provide t 1.2" - set x xxx - package require t 1.2 - set x -} {1.2} -test pkg-2.13 {Tcl_PkgRequire procedure, "package unknown" support} { - proc pkgUnknown args { - # args = name requirement - # requirement = v-v (for exact version) - global x - set x $args - package provide [lindex $args 0] [lindex [split [lindex $args 1] -] 0] - } - package forget t - foreach i {1.4 3.4 2.3 2.4 2.2} { - package ifneeded t $i "set x $i" - } - package unknown pkgUnknown - set x xxx - package require -exact t 1.5 - package unknown {} - set x -} {t 1.5-1.5} -test pkg-2.14 {Tcl_PkgRequire procedure, "package unknown" support} { - proc pkgUnknown args { - package ifneeded t 1.2 "set x loaded; package provide t 1.2" - } - package forget t - package unknown pkgUnknown - set x xxx - set result [list [package require t] $x] - package unknown {} - set result -} {1.2 loaded} -test pkg-2.15 {Tcl_PkgRequire procedure, "package unknown" support} { - proc pkgUnknown args { - global x - set x $args - package provide [lindex $args 0] 2.0 - } - package forget {a b} - package unknown pkgUnknown - set x xxx - package require {a b} - package unknown {} - set x -} {{a b} 0-} -test pkg-2.16 {Tcl_PkgRequire procedure, "package unknown" error} { - proc pkgUnknown args { - error "testing package unknown" - } - package forget t - package unknown pkgUnknown - set result [list [catch {package require t} msg] $msg $::errorInfo] - package unknown {} - set result -} {1 {testing package unknown} {testing package unknown - while executing -"error "testing package unknown"" - (procedure "pkgUnknown" line 2) - invoked from within -"pkgUnknown t 0-" - ("package unknown" script) - invoked from within -"package require t"}} -test pkg-2.17 {Tcl_PkgRequire procedure, "package unknown" doesn't load package} { - proc pkgUnknown args { - global x - set x $args - } - package forget t - foreach i {1.4 3.4 2.3 2.4 2.2} { - package ifneeded t $i "set x $i" - } - package unknown pkgUnknown - set x xxx - set result [list [catch {package require -exact t 1.5} msg] $msg $x] - package unknown {} - set result -} {1 {can't find package t exactly 1.5} {t 1.5-1.5}} -test pkg-2.18 {Tcl_PkgRequire procedure, version checks} { - package forget t - package provide t 2.3 - package require t -} {2.3} -test pkg-2.19 {Tcl_PkgRequire procedure, version checks} { - package forget t - package provide t 2.3 - package require t 2.1 -} {2.3} -test pkg-2.20 {Tcl_PkgRequire procedure, version checks} { - package forget t - package provide t 2.3 - package require t 2.3 -} {2.3} -test pkg-2.21 {Tcl_PkgRequire procedure, version checks} { - package forget t - package provide t 2.3 - list [catch {package require t 2.4} msg] $msg -} {1 {version conflict for package "t": have 2.3, need 2.4}} -test pkg-2.22 {Tcl_PkgRequire procedure, version checks} { - package forget t - package provide t 2.3 - list [catch {package require t 1.2} msg] $msg -} {1 {version conflict for package "t": have 2.3, need 1.2}} -test pkg-2.23 {Tcl_PkgRequire procedure, version checks} { - package forget t - package provide t 2.3 - package require -exact t 2.3 -} {2.3} -test pkg-2.24 {Tcl_PkgRequire procedure, version checks} { - package forget t - package provide t 2.3 - list [catch {package require -exact t 2.2} msg] $msg -} {1 {version conflict for package "t": have 2.3, need exactly 2.2}} -test pkg-2.25 {Tcl_PkgRequire procedure, error in ifneeded script} -body { - package forget t - package ifneeded t 2.1 {package provide t 2.1; error "ifneeded test" EI} - list [catch {package require t 2.1} msg] $msg $::errorInfo -} -match glob -result {1 {ifneeded test} {EI - ("package ifneeded*" script) - invoked from within -"package require t 2.1"}} -test pkg-2.26 {Tcl_PkgRequire procedure, error in ifneeded script} -body { - package forget t - package ifneeded t 2.1 {package provide t 2.1; foreach x 1 {error "ifneeded test" EI}} - list [catch {package require t 2.1} msg] $msg $::errorInfo -} -match glob -result {1 {ifneeded test} {EI - ("foreach" body line 1) - invoked from within -"foreach x 1 {error "ifneeded test" EI}" - ("package ifneeded*" script) - invoked from within -"package require t 2.1"}} -test pkg-2.27 {Tcl_PkgRequire: circular dependency} -setup { - package forget foo -} -body { - package ifneeded foo 1 {package require foo 1} - package require foo 1 -} -cleanup { - package forget foo -} -returnCodes error -match glob -result {circular package dependency:*} -test pkg-2.28 {Tcl_PkgRequire: circular dependency} -setup { - package forget foo -} -body { - package ifneeded foo 1 {package require foo 2} - package require foo 1 -} -cleanup { - package forget foo -} -returnCodes error -match glob -result {circular package dependency:*} -test pkg-2.29 {Tcl_PkgRequire: circular dependency} -setup { - package forget foo - package forget bar -} -body { - package ifneeded foo 1 {package require bar 1; package provide foo 1} - package ifneeded bar 1 {package require foo 1; package provide bar 1} - package require foo 1 -} -cleanup { - package forget foo - package forget bar -} -returnCodes error -match glob -result {circular package dependency:*} -test pkg-2.30 {Tcl_PkgRequire: circular dependency} -setup { - package forget foo - package forget bar -} -body { - package ifneeded foo 1 {package require bar 1; package provide foo 1} - package ifneeded foo 2 {package provide foo 2} - package ifneeded bar 1 {package require foo 2; package provide bar 1} - package require foo 1 -} -cleanup { - package forget foo - package forget bar -} -returnCodes error -match glob -result {circular package dependency:*} -test pkg-2.31 {Tcl_PkgRequire: consistent return values (1162286)} -setup { - package forget foo -} -body { - package ifneeded foo 1 {package provide foo 1; error foo} - package require foo 1 -} -cleanup { - package forget foo -} -returnCodes error -match glob -result foo -test pkg-2.32 {Tcl_PkgRequire: consistent return values (1162286)} -setup { - package forget foo -} -body { - package ifneeded foo 1 {package provide foo 1; error foo} - catch {package require foo 1} - package provide foo -} -cleanup { - package forget foo -} -result {} -test pkg-2.33 {Tcl_PkgRequire: consistent return values (1162286)} -setup { - package forget foo -} -body { - package ifneeded foo 1 {package provide foo 2} - package require foo 1 -} -cleanup { - package forget foo -} -returnCodes error -match glob -result {attempt to provide package * failed:*} -test pkg-2.34 {Tcl_PkgRequire: consistent return values (1162286)} -setup { - package forget foo -} -body { - package ifneeded foo 1 {package provide foo 1.1} - package require foo 1 -} -cleanup { - package forget foo -} -returnCodes error -match glob -result {attempt to provide package * failed:*} -test pkg-2.34.1 {Tcl_PkgRequire: consistent return values (1162286)} -setup { - package forget foo -} -body { - package ifneeded foo 1.1 {package provide foo 1} - package require foo 1 -} -cleanup { - package forget foo -} -returnCodes error -match glob -result {attempt to provide package * failed:*} -test pkg-2.34.2 {Tcl_PkgRequire: consistent return values (1162286)} -setup { - package forget foo -} -body { - package ifneeded foo 1.1 {package provide foo 1} - package require foo 1.1 -} -cleanup { - package forget foo -} -returnCodes error -match glob -result {attempt to provide package * failed:*} -test pkg-2.35 {Tcl_PkgRequire: consistent return values (1162286)} -setup { - package forget foo -} -body { - package ifneeded foo 1 {} - package require foo 1 -} -cleanup { - package forget foo -} -returnCodes error -match glob -result {attempt to provide package * failed:*} -test pkg-2.35.1 {Tcl_PkgRequire: consistent return values (1162286)} -setup { - package forget foo -} -body { - package ifneeded foo 1 {break} - package require foo 1 -} -cleanup { - package forget foo -} -returnCodes error -match glob \ --result {attempt to provide package * failed: bad return code:*} -test pkg-2.36 {Tcl_PkgRequire: consistent return values (1162286)} -setup { - package forget foo -} -body { - package ifneeded foo 1 {continue} - package require foo 1 -} -cleanup { - package forget foo -} -returnCodes error -match glob \ --result {attempt to provide package * failed: bad return code:*} -test pkg-2.37 {Tcl_PkgRequire: consistent return values (1162286)} -setup { - package forget foo -} -body { - package ifneeded foo 1 {return} - package require foo 1 -} -cleanup { - package forget foo -} -returnCodes error -match glob \ --result {attempt to provide package * failed: bad return code:*} -test pkg-2.38 {Tcl_PkgRequire: consistent return values (1162286)} -setup { - package forget foo -} -body { - package ifneeded foo 1 {return -level 0 -code 10} - package require foo 1 -} -cleanup { - package forget foo -} -returnCodes error -match glob \ --result {attempt to provide package * failed: bad return code:*} -test pkg-2.39 {Tcl_PkgRequire: consistent return values (1162286)} -setup { - package forget foo - set saveUnknown [package unknown] - package unknown {package provide foo 2 ;#} -} -body { - package require foo 1 -} -cleanup { - package forget foo - package unknown $saveUnknown -} -returnCodes error -match glob -result * -test pkg-2.40 {Tcl_PkgRequire: consistent return values (1162286)} -setup { - package forget foo - set saveUnknown [package unknown] - package unknown {break ;#} -} -body { - package require foo 1 -} -cleanup { - package forget foo - package unknown $saveUnknown -} -returnCodes error -match glob -result {bad return code:*} -test pkg-2.41 {Tcl_PkgRequire: consistent return values (1162286)} -setup { - package forget foo - set saveUnknown [package unknown] - package unknown {continue ;#} -} -body { - package require foo 1 -} -cleanup { - package forget foo - package unknown $saveUnknown -} -returnCodes error -match glob -result {bad return code:*} -test pkg-2.42 {Tcl_PkgRequire: consistent return values (1162286)} -setup { - package forget foo - set saveUnknown [package unknown] - package unknown {return ;#} -} -body { - package require foo 1 -} -cleanup { - package forget foo - package unknown $saveUnknown -} -returnCodes error -match glob -result {bad return code:*} -test pkg-2.43 {Tcl_PkgRequire: consistent return values (1162286)} -setup { - package forget foo - set saveUnknown [package unknown] - package unknown {return -level 0 -code 10 ;#} -} -body { - package require foo 1 -} -cleanup { - package forget foo - package unknown $saveUnknown -} -returnCodes error -match glob -result {bad return code:*} -test pkg-2.44 {Tcl_PkgRequire: exact version matching (1578344)} -setup { - package provide demo 1.2.3 -} -body { - package require -exact demo 1.2 -} -cleanup { - package forget demo -} -returnCodes error -result {version conflict for package "demo": have 1.2.3, need exactly 1.2} - - -test pkg-2.50 {Tcl_PkgRequire procedure, picking best stable version} { - package forget t - foreach i {1.4 3.4 4.0a1 2.3 2.4 2.2} { - package ifneeded t $i "set x $i; package provide t $i" - } - set x xxx - package require t - set x -} {3.4} - -test pkg-2.51 {Tcl_PkgRequire procedure, picking best stable version} { - package forget t - foreach i {1.2b1 1.2 1.3a2 1.3} { - package ifneeded t $i "set x $i; package provide t $i" - } - set x xxx - package require t - set x -} {1.3} - -test pkg-2.52 {Tcl_PkgRequire procedure, picking best stable version} { - package forget t - foreach i {1.2b1 1.2 1.3 1.3a2} { - package ifneeded t $i "set x $i; package provide t $i" - } - set x xxx - package require t - set x -} {1.3} - - - -test pkg-3.1 {Tcl_PackageCmd procedure} { - list [catch {package} msg] $msg -} {1 {wrong # args: should be "package option ?arg ...?"}} -test pkg-3.2 {Tcl_PackageCmd procedure, "forget" option} { - foreach i [package names] { - package forget $i - } - package names -} {} -test pkg-3.3 {Tcl_PackageCmd procedure, "forget" option} { - foreach i [package names] { - package forget $i - } - package forget foo -} {} -test pkg-3.4 {Tcl_PackageCmd procedure, "forget" option} { - foreach i [package names] { - package forget $i - } - package ifneeded t 1.1 {first script} - package ifneeded t 2.3 {second script} - package ifneeded x 1.4 {x's script} - set result {} - lappend result [lsort [package names]] [package versions t] - package forget t - lappend result [lsort [package names]] [package versions t] -} {{t x} {1.1 2.3} x {}} -test pkg-3.5 {Tcl_PackageCmd procedure, "forget" option} { - foreach i [package names] { - package forget $i - } - package ifneeded a 1.1 {first script} - package ifneeded b 2.3 {second script} - package ifneeded c 1.4 {third script} - package forget - set result [list [lsort [package names]]] - package forget a c - lappend result [lsort [package names]] -} {{a b c} b} -test pkg-3.5.1 {Tcl_PackageCmd procedure, "forget" option} { - # Test for Bug 415273 - package ifneeded a 1 "I should have been forgotten" - package forget no-such-package a - set x [package ifneeded a 1] - package forget a - set x -} {} -test pkg-3.6 {Tcl_PackageCmd procedure, "ifneeded" option} { - list [catch {package ifneeded a} msg] $msg -} {1 {wrong # args: should be "package ifneeded package version ?script?"}} -test pkg-3.7 {Tcl_PackageCmd procedure, "ifneeded" option} { - list [catch {package ifneeded a b c d} msg] $msg -} {1 {wrong # args: should be "package ifneeded package version ?script?"}} -test pkg-3.8 {Tcl_PackageCmd procedure, "ifneeded" option} { - list [catch {package ifneeded t xyz} msg] $msg -} {1 {expected version number but got "xyz"}} -test pkg-3.9 {Tcl_PackageCmd procedure, "ifneeded" option} { - foreach i [package names] { - package forget $i - } - list [package ifneeded foo 1.1] [package names] -} {{} {}} -test pkg-3.10 {Tcl_PackageCmd procedure, "ifneeded" option} { - package forget t - package ifneeded t 1.4 "script for t 1.4" - list [package names] [package ifneeded t 1.4] [package versions t] -} {t {script for t 1.4} 1.4} -test pkg-3.11 {Tcl_PackageCmd procedure, "ifneeded" option} { - package forget t - package ifneeded t 1.4 "script for t 1.4" - list [package ifneeded t 1.5] [package names] [package versions t] -} {{} t 1.4} -test pkg-3.12 {Tcl_PackageCmd procedure, "ifneeded" option} { - package forget t - package ifneeded t 1.4 "script for t 1.4" - package ifneeded t 1.4 "second script for t 1.4" - list [package ifneeded t 1.4] [package names] [package versions t] -} {{second script for t 1.4} t 1.4} -test pkg-3.13 {Tcl_PackageCmd procedure, "ifneeded" option} { - package forget t - package ifneeded t 1.4 "script for t 1.4" - package ifneeded t 1.2 "second script" - package ifneeded t 3.1 "last script" - list [package ifneeded t 1.2] [package versions t] -} {{second script} {1.4 1.2 3.1}} -test pkg-3.14 {Tcl_PackageCmd procedure, "names" option} { - list [catch {package names a} msg] $msg -} {1 {wrong # args: should be "package names"}} -test pkg-3.15 {Tcl_PackageCmd procedure, "names" option} { - foreach i [package names] { - package forget $i - } - package names -} {} -test pkg-3.16 {Tcl_PackageCmd procedure, "names" option} { - foreach i [package names] { - package forget $i - } - package ifneeded x 1.2 {dummy} - package provide x 1.3 - package provide y 2.4 - catch {package require z 47.16} - lsort [package names] -} {x y} -test pkg-3.17 {Tcl_PackageCmd procedure, "provide" option} { - list [catch {package provide} msg] $msg -} {1 {wrong # args: should be "package provide package ?version?"}} -test pkg-3.18 {Tcl_PackageCmd procedure, "provide" option} { - list [catch {package provide a b c} msg] $msg -} {1 {wrong # args: should be "package provide package ?version?"}} -test pkg-3.19 {Tcl_PackageCmd procedure, "provide" option} { - package forget t - package provide t -} {} -test pkg-3.20 {Tcl_PackageCmd procedure, "provide" option} { - package forget t - package provide t 2.3 - package provide t -} {2.3} -test pkg-3.21 {Tcl_PackageCmd procedure, "provide" option} { - package forget t - list [catch {package provide t a.b} msg] $msg -} {1 {expected version number but got "a.b"}} -test pkg-3.22 {Tcl_PackageCmd procedure, "require" option} { - list [catch {package require} msg] $msg -} {1 {wrong # args: should be "package require ?-exact? package ?requirement ...?"}} - -test pkg-3.24 {Tcl_PackageCmd procedure, "require" option} { - list [catch {package require -exact a b c} msg] $msg - # Exact syntax: -exact name version - # name ?requirement ...? -} {1 {wrong # args: should be "package require ?-exact? package ?requirement ...?"}} - -test pkg-3.26 {Tcl_PackageCmd procedure, "require" option} { - list [catch {package require x a.b} msg] $msg -} {1 {expected version number but got "a.b"}} -test pkg-3.27 {Tcl_PackageCmd procedure, "require" option} { - list [catch {package require -exact x a.b} msg] $msg -} {1 {expected version number but got "a.b"}} -test pkg-3.28 {Tcl_PackageCmd procedure, "require" option} { - list [catch {package require -exact x} msg] $msg -} {1 {wrong # args: should be "package require ?-exact? package ?requirement ...?"}} -test pkg-3.29 {Tcl_PackageCmd procedure, "require" option} { - list [catch {package require -exact} msg] $msg -} {1 {wrong # args: should be "package require ?-exact? package ?requirement ...?"}} -test pkg-3.30 {Tcl_PackageCmd procedure, "require" option} { - package forget t - package provide t 2.3 - package require t 2.1 -} {2.3} -test pkg-3.31 {Tcl_PackageCmd procedure, "require" option} { - package forget t - list [catch {package require t} msg] $msg -} {1 {can't find package t}} -test pkg-3.32 {Tcl_PackageCmd procedure, "require" option} { - package forget t - package ifneeded t 2.3 "error {synthetic error}" - list [catch {package require t 2.3} msg] $msg -} {1 {synthetic error}} -test pkg-3.33 {Tcl_PackageCmd procedure, "unknown" option} { - list [catch {package unknown a b} msg] $msg -} {1 {wrong # args: should be "package unknown ?command?"}} -test pkg-3.34 {Tcl_PackageCmd procedure, "unknown" option} { - package unknown "test script" - package unknown -} {test script} -test pkg-3.35 {Tcl_PackageCmd procedure, "unknown" option} { - package unknown "test script" - package unknown {} - package unknown -} {} -test pkg-3.36 {Tcl_PackageCmd procedure, "vcompare" option} { - list [catch {package vcompare a} msg] $msg -} {1 {wrong # args: should be "package vcompare version1 version2"}} -test pkg-3.37 {Tcl_PackageCmd procedure, "vcompare" option} { - list [catch {package vcompare a b c} msg] $msg -} {1 {wrong # args: should be "package vcompare version1 version2"}} -test pkg-3.38 {Tcl_PackageCmd procedure, "vcompare" option} { - list [catch {package vcompare x.y 3.4} msg] $msg -} {1 {expected version number but got "x.y"}} -test pkg-3.39 {Tcl_PackageCmd procedure, "vcompare" option} { - list [catch {package vcompare 2.1 a.b} msg] $msg -} {1 {expected version number but got "a.b"}} -test pkg-3.40 {Tcl_PackageCmd procedure, "vcompare" option} { - package vc 2.1 2.3 -} {-1} -test pkg-3.41 {Tcl_PackageCmd procedure, "vcompare" option} { - package vc 2.2.4 2.2.4 -} {0} -test pkg-3.42 {Tcl_PackageCmd procedure, "versions" option} { - list [catch {package versions} msg] $msg -} {1 {wrong # args: should be "package versions package"}} -test pkg-3.43 {Tcl_PackageCmd procedure, "versions" option} { - list [catch {package versions a b} msg] $msg -} {1 {wrong # args: should be "package versions package"}} -test pkg-3.44 {Tcl_PackageCmd procedure, "versions" option} { - package forget t - package versions t -} {} -test pkg-3.45 {Tcl_PackageCmd procedure, "versions" option} { - package forget t - package provide t 2.3 - package versions t -} {} -test pkg-3.46 {Tcl_PackageCmd procedure, "versions" option} { - package forget t - package ifneeded t 2.3 x - package ifneeded t 2.4 y - package versions t -} {2.3 2.4} -test pkg-3.47 {Tcl_PackageCmd procedure, "vsatisfies" option} { - list [catch {package vsatisfies a} msg] $msg -} {1 {wrong # args: should be "package vsatisfies version ?requirement ...?"}} - -test pkg-3.49 {Tcl_PackageCmd procedure, "vsatisfies" option} { - list [catch {package vsatisfies x.y 3.4} msg] $msg -} {1 {expected version number but got "x.y"}} -test pkg-3.50 {Tcl_PackageCmd procedure, "vsatisfies" option} { - list [catch {package vcompare 2.1 a.b} msg] $msg -} {1 {expected version number but got "a.b"}} -test pkg-3.51 {Tcl_PackageCmd procedure, "vsatisfies" option} { - package vs 2.3 2.1 -} {1} -test pkg-3.52 {Tcl_PackageCmd procedure, "vsatisfies" option} { - package vs 2.3 1.2 -} {0} -test pkg-3.53 {Tcl_PackageCmd procedure, "versions" option} { - list [catch {package foo} msg] $msg -} {1 {bad option "foo": must be forget, ifneeded, names, prefer, present, provide, require, unknown, vcompare, versions, or vsatisfies}} - -test pkg-3.54 {Tcl_PackageCmd procedure, "vsatisfies" option} { - list [catch {package vsatisfies 2.1 2.1-3.2-4.5} msg] $msg -} {1 {expected versionMin-versionMax but got "2.1-3.2-4.5"}} - -test pkg-3.55 {Tcl_PackageCmd procedure, "vsatisfies" option} { - list [catch {package vsatisfies 2.1 3.2-x.y} msg] $msg -} {1 {expected version number but got "x.y"}} - -test pkg-3.56 {Tcl_PackageCmd procedure, "vsatisfies" option} { - list [catch {package vsatisfies 2.1 x.y-3.2} msg] $msg -} {1 {expected version number but got "x.y"}} - - -# No tests for FindPackage; can't think up anything detectable -# errors. - -test pkg-4.1 {TclFreePackageInfo procedure} { - interp create foo - foo eval { - package ifneeded t 2.3 x - package ifneeded t 2.4 y - package ifneeded x 3.1 z - package provide q 4.3 - package unknown "will this get freed?" - } - interp delete foo -} {} -test pkg-4.2 {TclFreePackageInfo procedure} -body { - interp create foo - foo eval { - package ifneeded t 2.3 x - package ifneeded t 2.4 y - package ifneeded x 3.1 z - package provide q 4.3 - } - foo alias z kill - proc kill {} { - interp delete foo - } - foo eval package require x 3.1 -} -returnCodes error -match glob -result * - -test pkg-5.1 {CheckVersion procedure} { - list [catch {package vcompare 1 2.1} msg] $msg -} {0 -1} -test pkg-5.2 {CheckVersion procedure} { - list [catch {package vcompare .1 2.1} msg] $msg -} {1 {expected version number but got ".1"}} -test pkg-5.3 {CheckVersion procedure} { - list [catch {package vcompare 111.2a.3 2.1} msg] $msg -} {1 {expected version number but got "111.2a.3"}} -test pkg-5.4 {CheckVersion procedure} { - list [catch {package vcompare 1.2.3. 2.1} msg] $msg -} {1 {expected version number but got "1.2.3."}} -test pkg-5.5 {CheckVersion procedure} { - list [catch {package vcompare 1.2..3 2.1} msg] $msg -} {1 {expected version number but got "1.2..3"}} - -test pkg-6.1 {ComparePkgVersions procedure} { - package vcompare 1.23 1.22 -} {1} -test pkg-6.2 {ComparePkgVersions procedure} { - package vcompare 1.22.1.2.3 1.22.1.2.3 -} {0} -test pkg-6.3 {ComparePkgVersions procedure} { - package vcompare 1.21 1.22 -} {-1} -test pkg-6.4 {ComparePkgVersions procedure} { - package vcompare 1.21 1.21.2 -} {-1} -test pkg-6.5 {ComparePkgVersions procedure} { - package vcompare 1.21.1 1.21 -} {1} -test pkg-6.6 {ComparePkgVersions procedure} { - package vsatisfies 1.21.1 1.21 -} {1} -test pkg-6.7 {ComparePkgVersions procedure} { - package vsatisfies 2.22.3 1.21 -} {0} -test pkg-6.8 {ComparePkgVersions procedure} { - package vsatisfies 1 1 -} {1} -test pkg-6.9 {ComparePkgVersions procedure} { - package vsatisfies 2 1 -} {0} - -test pkg-7.1 {Tcl_PkgPresent procedure, any version} { - package forget t - package provide t 2.4 - package present t -} {2.4} -test pkg-7.2 {Tcl_PkgPresent procedure, correct version} { - package forget t - package provide t 2.4 - package present t 2.4 -} {2.4} -test pkg-7.3 {Tcl_PkgPresent procedure, satisfying version} { - package forget t - package provide t 2.4 - package present t 2.0 -} {2.4} -test pkg-7.4 {Tcl_PkgPresent procedure, not satisfying version} { - package forget t - package provide t 2.4 - list [catch {package present t 2.6} msg] $msg -} {1 {version conflict for package "t": have 2.4, need 2.6}} -test pkg-7.5 {Tcl_PkgPresent procedure, not satisfying version} { - package forget t - package provide t 2.4 - list [catch {package present t 1.0} msg] $msg -} {1 {version conflict for package "t": have 2.4, need 1.0}} -test pkg-7.6 {Tcl_PkgPresent procedure, exact version} { - package forget t - package provide t 2.4 - package present -exact t 2.4 -} {2.4} -test pkg-7.7 {Tcl_PkgPresent procedure, not exact version} { - package forget t - package provide t 2.4 - list [catch {package present -exact t 2.3} msg] $msg -} {1 {version conflict for package "t": have 2.4, need exactly 2.3}} -test pkg-7.8 {Tcl_PkgPresent procedure, unknown package} { - package forget t - list [catch {package present t} msg] $msg -} {1 {package t is not present}} -test pkg-7.9 {Tcl_PkgPresent procedure, unknown package} { - package forget t - list [catch {package present t 2.4} msg] $msg -} {1 {package t 2.4 is not present}} -test pkg-7.10 {Tcl_PkgPresent procedure, unknown package} { - package forget t - list [catch {package present -exact t 2.4} msg] $msg -} {1 {package t 2.4 is not present}} -test pkg-7.11 {Tcl_PackageCmd procedure, "present" option} { - list [catch {package present} msg] $msg -} {1 {wrong # args: should be "package present ?-exact? package ?requirement ...?"}} -test pkg-7.12 {Tcl_PackageCmd procedure, "present" option} { - list [catch {package present a b c} msg] $msg -} {1 {expected version number but got "b"}} -test pkg-7.13 {Tcl_PackageCmd procedure, "present" option} { - list [catch {package present -exact a b c} msg] $msg -} {1 {wrong # args: should be "package present ?-exact? package ?requirement ...?"}} -test pkg-7.14 {Tcl_PackageCmd procedure, "present" option} { - list [catch {package present -bs a b} msg] $msg -} {1 {expected version number but got "a"}} -test pkg-7.15 {Tcl_PackageCmd procedure, "present" option} { - list [catch {package present x a.b} msg] $msg -} {1 {expected version number but got "a.b"}} -test pkg-7.16 {Tcl_PackageCmd procedure, "present" option} { - list [catch {package present -exact x a.b} msg] $msg -} {1 {expected version number but got "a.b"}} -test pkg-7.17 {Tcl_PackageCmd procedure, "present" option} { - list [catch {package present -exact x} msg] $msg -} {1 {wrong # args: should be "package present ?-exact? package ?requirement ...?"}} -test pkg-7.18 {Tcl_PackageCmd procedure, "present" option} { - list [catch {package present -exact} msg] $msg -} {1 {wrong # args: should be "package present ?-exact? package ?requirement ...?"}} - - - - -set n 0 -foreach {r p vs vc} { - 8.5a0 8.5a5 1 -1 - 8.5a0 8.5b1 1 -1 - 8.5a0 8.5.1 1 -1 - 8.5a0 8.6a0 1 -1 - 8.5a0 8.6b0 1 -1 - 8.5a0 8.6.0 1 -1 - 8.5a6 8.5a5 0 1 - 8.5a6 8.5b1 1 -1 - 8.5a6 8.5.1 1 -1 - 8.5a6 8.6a0 1 -1 - 8.5a6 8.6b0 1 -1 - 8.5a6 8.6.0 1 -1 - 8.5b0 8.5a5 0 1 - 8.5b0 8.5b1 1 -1 - 8.5b0 8.5.1 1 -1 - 8.5b0 8.6a0 1 -1 - 8.5b0 8.6b0 1 -1 - 8.5b0 8.6.0 1 -1 - 8.5b2 8.5a5 0 1 - 8.5b2 8.5b1 0 1 - 8.5b2 8.5.1 1 -1 - 8.5b2 8.6a0 1 -1 - 8.5b2 8.6b0 1 -1 - 8.5b2 8.6.0 1 -1 - 8.5 8.5a5 1 1 - 8.5 8.5b1 1 1 - 8.5 8.5.1 1 -1 - 8.5 8.6a0 1 -1 - 8.5 8.6b0 1 -1 - 8.5 8.6.0 1 -1 - 8.5.0 8.5a5 0 1 - 8.5.0 8.5b1 0 1 - 8.5.0 8.5.1 1 -1 - 8.5.0 8.6a0 1 -1 - 8.5.0 8.6b0 1 -1 - 8.5.0 8.6.0 1 -1 - 10 8 0 1 - 8 10 0 -1 - 0.0.1.2 0.1.2 1 -1 -} { - test package-vsatisfies-1.$n {package vsatisfies} { - package vsatisfies $p $r - } $vs - - test package-vcompare-1.$n {package vcompare} { - package vcompare $r $p - } $vc - - incr n -} - -test package-vcompare-2.0 {package vcompare at 32bit boundary} { - package vcompare [expr {1<<31}] [expr {(1<<31)-1}] -} 1 - -# Note: It is correct that the result of the very first test, -# i.e. "5.0 5.0a0" is 1, i.e. that version 5.0a0 satisfies a 5.0 -# requirement. - -# The requirement "5.0" internally translates first to "5.0-6", and -# then to its final form of "5.0a0-6a0". These translations are -# explicitly specified by the TIP (Search for "padded/extended -# internally with 'a0'"). This was done intentionally for exactly the -# tested case, that an alpha package can satisfy a requirement for the -# regular package. An example would be a package FOO requiring Tcl 8.X -# for its operation. It can be used with Tcl 8.Xa0. Without our -# translation that would not be possible. - -set n 0 -foreach {required provided satisfied} { - 5.0 5.0a0 1 - 5.0a0 5.0 1 - - 8.5a0- 8.5a5 1 - 8.5a0- 8.5b1 1 - 8.5a0- 8.5.1 1 - 8.5a0- 8.6a0 1 - 8.5a0- 8.6b0 1 - 8.5a0- 8.6.0 1 - 8.5a6- 8.5a5 0 - 8.5a6- 8.5b1 1 - 8.5a6- 8.5.1 1 - 8.5a6- 8.6a0 1 - 8.5a6- 8.6b0 1 - 8.5a6- 8.6.0 1 - 8.5b0- 8.5a5 0 - 8.5b0- 8.5b1 1 - 8.5b0- 8.5.1 1 - 8.5b0- 8.6a0 1 - 8.5b0- 8.6b0 1 - 8.5b0- 8.6.0 1 - 8.5b2- 8.5a5 0 - 8.5b2- 8.5b1 0 - 8.5b2- 8.5.1 1 - 8.5b2- 8.6a0 1 - 8.5b2- 8.6b0 1 - 8.5b2- 8.6.0 1 - 8.5- 8.5a5 1 - 8.5- 8.5b1 1 - 8.5- 8.5.1 1 - 8.5- 8.6a0 1 - 8.5- 8.6b0 1 - 8.5- 8.6.0 1 - 8.5.0- 8.5a5 0 - 8.5.0- 8.5b1 0 - 8.5.0- 8.5.1 1 - 8.5.0- 8.6a0 1 - 8.5.0- 8.6b0 1 - 8.5.0- 8.6.0 1 - 8.5a0-7 8.5a5 0 - 8.5a0-7 8.5b1 0 - 8.5a0-7 8.5.1 0 - 8.5a0-7 8.6a0 0 - 8.5a0-7 8.6b0 0 - 8.5a0-7 8.6.0 0 - 8.5a6-7 8.5a5 0 - 8.5a6-7 8.5b1 0 - 8.5a6-7 8.5.1 0 - 8.5a6-7 8.6a0 0 - 8.5a6-7 8.6b0 0 - 8.5a6-7 8.6.0 0 - 8.5b0-7 8.5a5 0 - 8.5b0-7 8.5b1 0 - 8.5b0-7 8.5.1 0 - 8.5b0-7 8.6a0 0 - 8.5b0-7 8.6b0 0 - 8.5b0-7 8.6.0 0 - 8.5b2-7 8.5a5 0 - 8.5b2-7 8.5b1 0 - 8.5b2-7 8.5.1 0 - 8.5b2-7 8.6a0 0 - 8.5b2-7 8.6b0 0 - 8.5b2-7 8.6.0 0 - 8.5-7 8.5a5 0 - 8.5-7 8.5b1 0 - 8.5-7 8.5.1 0 - 8.5-7 8.6a0 0 - 8.5-7 8.6b0 0 - 8.5-7 8.6.0 0 - 8.5.0-7 8.5a5 0 - 8.5.0-7 8.5b1 0 - 8.5.0-7 8.5.1 0 - 8.5.0-7 8.6a0 0 - 8.5.0-7 8.6b0 0 - 8.5.0-7 8.6.0 0 - 8.5a0-8.6.1 8.5a5 1 - 8.5a0-8.6.1 8.5b1 1 - 8.5a0-8.6.1 8.5.1 1 - 8.5a0-8.6.1 8.6a0 1 - 8.5a0-8.6.1 8.6b0 1 - 8.5a0-8.6.1 8.6.0 1 - 8.5a6-8.6.1 8.5a5 0 - 8.5a6-8.6.1 8.5b1 1 - 8.5a6-8.6.1 8.5.1 1 - 8.5a6-8.6.1 8.6a0 1 - 8.5a6-8.6.1 8.6b0 1 - 8.5a6-8.6.1 8.6.0 1 - 8.5b0-8.6.1 8.5a5 0 - 8.5b0-8.6.1 8.5b1 1 - 8.5b0-8.6.1 8.5.1 1 - 8.5b0-8.6.1 8.6a0 1 - 8.5b0-8.6.1 8.6b0 1 - 8.5b0-8.6.1 8.6.0 1 - 8.5b2-8.6.1 8.5a5 0 - 8.5b2-8.6.1 8.5b1 0 - 8.5b2-8.6.1 8.5.1 1 - 8.5b2-8.6.1 8.6a0 1 - 8.5b2-8.6.1 8.6b0 1 - 8.5b2-8.6.1 8.6.0 1 - 8.5-8.6.1 8.5a5 1 - 8.5-8.6.1 8.5b1 1 - 8.5-8.6.1 8.5.1 1 - 8.5-8.6.1 8.6a0 1 - 8.5-8.6.1 8.6b0 1 - 8.5-8.6.1 8.6.0 1 - 8.5.0-8.6.1 8.5a5 0 - 8.5.0-8.6.1 8.5b1 0 - 8.5.0-8.6.1 8.5.1 1 - 8.5.0-8.6.1 8.6a0 1 - 8.5.0-8.6.1 8.6b0 1 - 8.5.0-8.6.1 8.6.0 1 - 8.5a0-8.5a0 8.5a0 1 - 8.5a0-8.5a0 8.5b1 0 - 8.5a0-8.5a0 8.4 0 - 8.5b0-8.5b0 8.5a5 0 - 8.5b0-8.5b0 8.5b0 1 - 8.5b0-8.5b0 8.5.1 0 - 8.5-8.5 8.5a5 0 - 8.5-8.5 8.5b1 0 - 8.5-8.5 8.5 1 - 8.5-8.5 8.5.1 0 - 8.5.0-8.5.0 8.5a5 0 - 8.5.0-8.5.0 8.5b1 0 - 8.5.0-8.5.0 8.5.0 1 - 8.5.0-8.5.0 8.5.1 0 - 8.5.0-8.5.0 8.6a0 0 - 8.5.0-8.5.0 8.6b0 0 - 8.5.0-8.5.0 8.6.0 0 - 8.2 9 0 - 8.2- 9 1 - 8.2-8.5 9 0 - 8.2-9.1 9 1 - - 8.5-8.5 8.5b1 0 - 8.5a0-8.5 8.5b1 0 - 8.5a0-8.5.1 8.5b1 1 - - 8.5-8.5 8.5 1 - 8.5.0-8.5.0 8.5 1 - 8.5a0-8.5.0 8.5 0 - -} { - test package-vsatisfies-2.$n "package vsatisfies $provided $required" { - package vsatisfies $provided $required - } $satisfied - incr n -} - -test package-vsatisfies-3.0 "package vsatisfies multiple" { - # yes no - package vsatisfies 8.4 8.4 7.3 -} 1 - -test package-vsatisfies-3.1 "package vsatisfies multiple" { - # no yes - package vsatisfies 8.4 7.3 8.4 -} 1 - -test package-vsatisfies-3.2 "package vsatisfies multiple" { - # yes yes - package vsatisfies 8.4.2 8.4 8.4.1 -} 1 - -test package-vsatisfies-3.3 "package vsatisfies multiple" { - # no no - package vsatisfies 8.4 7.3 6.1 -} 0 - - -proc prefer {args} { - set ip [interp create] - lappend res [$ip eval {package prefer}] - foreach mode $args { - lappend res [$ip eval [list package prefer $mode]] - } - interp delete $ip - return $res -} - -test package-prefer-1.0 {default} { - prefer -} stable - -test package-prefer-1.1 {default} { - set ::env(TCL_PKG_PREFER_LATEST) stable ; # value not relevant! - set res [prefer] - unset ::env(TCL_PKG_PREFER_LATEST) - set res -} latest - -test package-prefer-2.0 {wrong\#args} { - catch {package prefer foo bar} msg - set msg -} {wrong # args: should be "package prefer ?latest|stable?"} - -test package-prefer-2.1 {bogus argument} { - catch {package prefer foo} msg - set msg -} {bad preference "foo": must be latest or stable} - -test package-prefer-3.0 {set, keep} { - package prefer stable -} stable - -test package-prefer-3.1 {set stable, keep} { - prefer stable -} {stable stable} - -test package-prefer-3.2 {set latest, change} { - prefer latest -} {stable latest} - -test package-prefer-3.3 {set latest, keep} { - prefer latest latest -} {stable latest latest} - -test package-prefer-3.4 {set stable, rejected} { - prefer latest stable -} {stable latest latest} - -rename prefer {} - - -set auto_path $oldPath -package unknown $oldPkgUnknown -concat - -cleanupTests -} - -# cleanup -interp delete $i -::tcltest::cleanupTests -return diff --git a/tests/pkgMkIndex.test b/tests/pkgMkIndex.test index 0db6533..33c76d5 100644 --- a/tests/pkgMkIndex.test +++ b/tests/pkgMkIndex.test @@ -2,13 +2,13 @@ # 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. +# 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: pkgMkIndex.test,v 1.29 2006/11/03 00:34:53 hobbs Exp $ +# RCS: @(#) $Id: pkgMkIndex.test,v 1.30 2011/01/06 10:20:39 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -17,7 +17,6 @@ if {[lsearch [namespace children] ::tcltest] == -1} { set fullPkgPath [makeDirectory pkg] - namespace eval pkgtest { # Namespace for procs we can discard } @@ -27,8 +26,8 @@ namespace eval pkgtest { # Parse an argument list. # # Arguments: -# <flags> (optional) arguments starting with a dash are collected -# as options to pkg_mkIndex and passed to pkg_mkIndex. +# <flags> (optional) arguments starting with a dash are collected as +# options to pkg_mkIndex and passed to pkg_mkIndex. # dirPath the directory to index # pattern0 pattern to index # ... pattern to index @@ -130,13 +129,13 @@ proc pkgtest::parseIndex { filePath } { # pkgtest::createIndex -- # -# Runs pkg_mkIndex for the given directory and set of patterns. -# This procedure deletes any pkgIndex.tcl file in the target directory, -# then runs pkg_mkIndex. +# Runs pkg_mkIndex for the given directory and set of patterns. This +# procedure deletes any pkgIndex.tcl file in the target directory, then runs +# pkg_mkIndex. # # Arguments: -# <flags> (optional) arguments starting with a dash are collected -# as options to pkg_mkIndex and passed to pkg_mkIndex. +# <flags> (optional) arguments starting with a dash are collected as +# options to pkg_mkIndex and passed to pkg_mkIndex. # dirPath the directory to index # pattern0 pattern to index # ... pattern to index @@ -194,11 +193,9 @@ proc makePkgList { inList } { lappend l $s } } - source { set l $v } - default { error "can't handle $k $v" } @@ -215,8 +212,8 @@ proc makePkgList { inList } { # Runs pkg_mkIndex, parses the generated index file. # # Arguments: -# <flags> (optional) arguments starting with a dash are collected -# as options to pkg_mkIndex and passed to pkg_mkIndex. +# <flags> (optional) arguments starting with a dash are collected as +# options to pkg_mkIndex and passed to pkg_mkIndex. # dirPath the directory to index # pattern0 pattern to index # ... pattern to index @@ -226,8 +223,7 @@ proc makePkgList { inList } { # Returns a two element list: # 0: 1 if the procedure encountered an error, 0 otherwise. # 1: if no error, this is the parsed generated index file, in the format -# returned by pkgtest::parseIndex. -# If error, this is the error result. +# returned by pkgtest::parseIndex. If error, this is the error result. proc pkgtest::runCreatedIndex {rv args} { if {[lindex $rv 0] == 0} { @@ -251,9 +247,9 @@ proc pkgtest::runIndex { args } { set rv [createIndex {*}$args] return [runCreatedIndex $rv {*}$args] } - -# If there is no match to the patterns, make sure the directory hasn't -# changed on us + +# If there is no match to the patterns, make sure the directory hasn't changed +# on us test pkgMkIndex-1.1 {nothing matches pattern - current dir is the same} { list [pkgtest::runIndex -lazy $fullPkgPath nomatch.tcl] [pwd] @@ -314,8 +310,8 @@ removeFile [file join pkg global.tcl] makeFile { # This package is required by pkg1. -# This package is split into two files, to test packages that are split -# over multiple files. +# This package is split into two files, to test packages that are split over +# multiple files. package provide pkg2 1.0 namespace eval pkg2 { namespace export p2-1 @@ -327,8 +323,8 @@ proc pkg2::p2-1 { num } { makeFile { # This package is required by pkg1. -# This package is split into two files, to test packages that are split -# over multiple files. +# This package is split into two files, to test packages that are split over +# multiple files. package provide pkg2 1.0 namespace eval pkg2 { namespace export p2-2 @@ -347,8 +343,8 @@ test pkgMkIndex-4.2 {split package - direct loading} { } "0 {{pkg2:1.0 {[list source [file join $fullPkgPath pkg2_a.tcl]] [list source [file join $fullPkgPath pkg2_b.tcl]]}}}" -# Add the direct1 directory to auto_path, so that the direct1 package -# can be found. +# Add the direct1 directory to auto_path, so that the direct1 package can be +# found. set direct1 [makeDirectory direct1] lappend auto_path $direct1 makeFile { @@ -367,9 +363,9 @@ proc direct1::pd2 { stg } { pkg_mkIndex -direct $direct1 direct1.tcl makeFile { -# Does a package require of direct1, whose pkgIndex.tcl entry -# is created above with option -direct. This tests that pkg_mkIndex -# can handle code that is sourced in pkgIndex.tcl files. +# Does a package require of direct1, whose pkgIndex.tcl entry is created +# above with option -direct. This tests that pkg_mkIndex can handle code +# that is sourced in pkgIndex.tcl files. package require direct1 package provide std 1.0 namespace eval std { @@ -393,9 +389,9 @@ removeDirectory direct1 removeFile [file join pkg std.tcl] makeFile { -# This package requires pkg3, but it does -# not use any of pkg3's procs in the code that is executed by the file -# (i.e. references to pkg3's procs are in the proc bodies only). +# This package requires pkg3, but it does not use any of pkg3's procs in the +# code that is executed by the file (i.e. references to pkg3's procs are in +# the proc bodies only). package require pkg3 1.0 package provide pkg1 1.0 namespace eval pkg1 { @@ -433,8 +429,8 @@ test pkgMkIndex-6.2 {pkg1 requires pkg3 - use -direct} { removeFile [file join pkg pkg1.tcl] makeFile { -# This package requires pkg3, and it calls -# a pkg3 proc in the code that is executed by the file +# This package requires pkg3, and it calls a pkg3 proc in the code that is +# executed by the file package require pkg3 1.0 package provide pkg4 1.0 namespace eval pkg4 { @@ -462,9 +458,8 @@ removeFile [file join pkg pkg4.tcl] removeFile [file join pkg pkg3.tcl] makeFile { -# This package requires pkg2, and it calls -# a pkg2 proc in the code that is executed by the file. -# Pkg2 is a split package. +# This package requires pkg2, and it calls a pkg2 proc in the code that is +# executed by the file. Pkg2 is a split package. package require pkg2 1.0 package provide pkg5 1.0 namespace eval pkg5 { @@ -496,9 +491,9 @@ removeFile [file join pkg pkg2_a.tcl] removeFile [file join pkg pkg2_b.tcl] makeFile { -# This package requires circ2, and circ2 -# requires circ3, which in turn requires circ1. -# In case of cirularities, pkg_mkIndex should give up when it gets stuck. +# This package requires circ2, and circ2 requires circ3, which in turn +# requires circ1. In case of cirularities, pkg_mkIndex should give up when +# it gets stuck. package require circ2 1.0 package provide circ1 1.0 namespace eval circ1 { @@ -519,8 +514,8 @@ proc circ1::c1-4 {} { } [file join pkg circ1.tcl] makeFile { -# This package is required by circ1, and -# requires circ3. Circ3, in turn, requires circ1 to give us a circularity. +# This package is required by circ1, and requires circ3. Circ3, in turn, +# requires circ1 to give us a circularity. package require circ3 1.0 package provide circ2 1.0 namespace eval circ2 { @@ -535,8 +530,8 @@ proc circ2::c2-2 { num } { } [file join pkg circ2.tcl] makeFile { -# This package is required by circ2, and in -# turn requires circ1. This closes the circularity. +# This package is required by circ2, and in turn requires circ1. This closes +# the circularity. package require circ1 1.0 package provide circ3 1.0 namespace eval circ3 { @@ -577,22 +572,23 @@ proc pkga_neq { x } { testConstraint exec [llength [info commands ::exec]] test pkgMkIndex-10.1 {package in DLL and script} [list exec $dll] { - # Do all [load]ing of shared libraries in another process, so - # we can delete the file and not get stuck because we're holding - # a reference to it. + # Do all [load]ing of shared libraries in another process, so we can + # delete the file and not get stuck because we're holding a reference to + # it. set cmd [list pkg_mkIndex -lazy $fullPkgPath [file tail $x] pkga.tcl] exec [interpreter] << $cmd pkgtest::runCreatedIndex {0 {}} -lazy $fullPkgPath pkga[info sharedlibextension] pkga.tcl } "0 {{Pkga:1.0 {tclPkgSetup {pkga[info sharedlibextension] load {pkga_eq pkga_quote}} {pkga.tcl source pkga_neq}}}}" test pkgMkIndex-10.2 {package in DLL hidden by -load} [list exec $dll] { - # Do all [load]ing of shared libraries in another process, so - # we can delete the file and not get stuck because we're holding - # a reference to it. + # Do all [load]ing of shared libraries in another process, so we can + # delete the file and not get stuck because we're holding a reference to + # it. # # This test depends on context from prior test, so repeat it. - set script "[list pkg_mkIndex -lazy $fullPkgPath [file tail $x] pkga.tcl]\n" - append script \ - "[list pkg_mkIndex -lazy -load Pkg* $fullPkgPath [file tail $x]]" + set script \ + "[list pkg_mkIndex -lazy $fullPkgPath [file tail $x] pkga.tcl]" + append script \n \ + "[list pkg_mkIndex -lazy -load Pkg* $fullPkgPath [file tail $x]]" exec [interpreter] << $script pkgtest::runCreatedIndex {0 {}} -lazy -load Pkg* -- $fullPkgPath pkga[info sharedlibextension] } {0 {}} @@ -625,9 +621,8 @@ test pkgMkIndex-11.1 {conflicting namespace imports} { removeFile [file join pkg import.tcl] -# Verify that the auto load list generated is correct even when there -# is a proc name conflict between two namespaces (ie, ::foo::baz and -# ::bar::baz) +# Verify that the auto load list generated is correct even when there is a +# proc name conflict between two namespaces (ie, ::foo::baz and ::bar::baz) makeFile { package provide football 1.0 @@ -692,7 +687,7 @@ test pkgMkIndex-14.5 {tcl::Pkg::CompareExtension} {unix} { test pkgMkIndex-14.6 {tcl::Pkg::CompareExtension} {unix} { tcl::Pkg::CompareExtension foo.so.1.2.bar .so } 0 - + # cleanup removeDirectory pkg @@ -701,3 +696,7 @@ namespace delete pkgtest ::tcltest::cleanupTests return +# Local Variables: +# mode: tcl +# fill-column: 78 +# End: |