# This file contains tests for the pkg_mkIndex command. # Note that the tests are limited to Tcl scripts only, there are no shared # libraries against which to test. # # Sourcing this file into Tcl runs the tests and generates output for # errors. No output means no errors were found. # # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # # RCS: @(#) $Id: pkgMkIndex.test,v 1.21 2002/07/04 00:32:54 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } set fullPkgPath [makeDirectory pkg] # Add the pkg1 directory to auto_path, so that its packages can be found. # packages in pkg1 are used to test indexing of packages in pkg. # Make sure that the path to pkg1 is absolute. lappend auto_path [file join $::tcltest::testsDirectory pkg1] namespace eval pkgtest { # Namespace for procs we can discard } # pkgtest::parseArgs -- # # Parse an argument list. # # Arguments: # (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 # patternN pattern to index # # Results: # Returns a three element list: # 0: the options # 1: the directory to index # 2: the patterns list proc pkgtest::parseArgs { args } { set options "" set argc [llength $args] for {set iarg 0} {$iarg < $argc} {incr iarg} { set a [lindex $args $iarg] if {[regexp {^-} $a]} { lappend options $a if {[string compare -load $a] == 0} { incr iarg lappend options [lindex $args $iarg] } } else { break } } set dirPath [lindex $args $iarg] incr iarg set patternList [lrange $args $iarg end] return [list $options $dirPath $patternList] } # pkgtest::parseIndex -- # # Loads a pkgIndex.tcl file, records all the calls to "package ifneeded". # # Arguments: # filePath path to the pkgIndex.tcl file. # # Results: # Returns a list, in "array set/get" format, where the keys are the package # name and version (in the form "$name:$version"), and the values the rest # of the command line. proc pkgtest::parseIndex { filePath } { # create a slave interpreter, where we override "package ifneeded" set slave [interp create] if {[catch { $slave eval { rename package package_original proc package { args } { if {[string compare [lindex $args 0] ifneeded] == 0} { set pkg [lindex $args 1] set ver [lindex $args 2] set ::PKGS($pkg:$ver) [lindex $args 3] } else { return [eval package_original $args] } } array set ::PKGS {} } set dir [file dirname $filePath] $slave eval {set curdir [pwd]} $slave eval [list cd $dir] $slave eval [list set dir $dir] $slave eval [list source [file tail $filePath]] $slave eval {cd $curdir} # Create the list in sorted order, so that we don't get spurious # errors because the order has changed. array set P {} foreach {k v} [$slave eval {array get ::PKGS}] { set P($k) $v } set PKGS "" foreach k [lsort [array names P]] { lappend PKGS $k $P($k) } } err]} { set ei $::errorInfo set ec $::errorCode catch {interp delete $slave} error $ei $ec } interp delete $slave return $PKGS } # 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. # # Arguments: # (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 # patternN pattern to index # # Results: # Returns a two element list: # 0: 1 if the procedure encountered an error, 0 otherwise. # 1: the error result if element 0 was 1 proc pkgtest::createIndex { args } { set parsed [eval parseArgs $args] set options [lindex $parsed 0] set dirPath [lindex $parsed 1] set patternList [lindex $parsed 2] file mkdir $dirPath if {[catch { file delete [file join $dirPath pkgIndex.tcl] eval pkg_mkIndex $options [list $dirPath] $patternList } err]} { return [list 1 $err] } return [list 0 {}] } # makePkgList -- # # Takes the output of a pkgtest::parseIndex call, filters it and returns a # cleaned up list of packages and their actions. # # Arguments: # inList output from a pkgtest::parseIndex. # # Results: # Returns a list of two element lists: # 0: the name:version # 1: a list describing the package. # For tclPkgSetup packages it consists of: # 0: the keyword tclPkgSetup # 1: the first file to source, with its exported procedures # 2: the second file ... # N: the N-1st file ... proc makePkgList { inList } { set pkgList "" foreach {k v} $inList { switch [lindex $v 0] { tclPkgSetup { set l tclPkgSetup foreach s [lindex $v 4] { lappend l $s } } source { set l $v } default { error "can't handle $k $v" } } lappend pkgList [list $k $l] } return $pkgList } # pkgtest::runIndex -- # # Runs pkg_mkIndex, parses the generated index file. # # Arguments: # (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 # patternN pattern to index # # Results: # 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. proc pkgtest::runCreatedIndex {rv args} { if {[lindex $rv 0] == 0} { set parsed [eval parseArgs $args] set dirPath [lindex $parsed 1] set idxFile [file join $dirPath pkgIndex.tcl] if {[catch { set result [list 0 [makePkgList [parseIndex $idxFile]]] } err]} { set result [list 1 $err] } file delete $idxFile } else { set result $rv } return $result } proc pkgtest::runIndex { args } { set rv [eval createIndex $args] return [eval [list runCreatedIndex $rv] $args] } # 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] } [list {1 {no files matched glob pattern "nomatch.tcl"}} [pwd]] makeFile { # simple.tcl -- # # Test package for pkg_mkIndex. This is a simple package, just to check # basic functionality. # # Copyright (c) 1998 by Scriptics Corporation. # All rights reserved. # # RCS: @(#) $Id: pkgMkIndex.test,v 1.21 2002/07/04 00:32:54 dgp Exp $ package provide simple 1.0 namespace eval simple { namespace export lower upper } proc simple::lower { stg } { return [string tolower $stg] } proc simple::upper { stg } { return [string toupper $stg] } } [file join pkg simple.tcl] test pkgMkIndex-2.1 {simple package} { pkgtest::runIndex -lazy $fullPkgPath simple.tcl } {0 {{simple:1.0 {tclPkgSetup {simple.tcl source {::simple::lower ::simple::upper}}}}}} test pkgMkIndex-2.2 {simple package - use -direct} { pkgtest::runIndex -direct $fullPkgPath simple.tcl } "0 {{simple:1.0 {[list source [file join $fullPkgPath simple.tcl]]}}}" test pkgMkIndex-2.3 {simple package - direct loading is default} { pkgtest::runIndex $fullPkgPath simple.tcl } "0 {{simple:1.0 {[list source [file join $fullPkgPath simple.tcl]]}}}" removeFile [file join pkg simple.tcl] makeFile { # global.tcl -- # # Test package for pkg_mkIndex. # Contains global symbols, used to check that they don't have a leading :: # # Copyright (c) 1998 by Scriptics Corporation. # All rights reserved. # # RCS: @(#) $Id: pkgMkIndex.test,v 1.21 2002/07/04 00:32:54 dgp Exp $ package provide global 1.0 proc global_lower { stg } { return [string tolower $stg] } proc global_upper { stg } { return [string toupper $stg] } } [file join pkg global.tcl] test pkgMkIndex-3.1 {simple package with global symbols} { pkgtest::runIndex -lazy $fullPkgPath global.tcl } {0 {{global:1.0 {tclPkgSetup {global.tcl source {global_lower global_upper}}}}}} removeFile [file join pkg global.tcl] makeFile { # pkg2_a.tcl -- # # Test package for pkg_mkIndex. This package is required by pkg1. # This package is split into two files, to test packages that are split # over multiple files. # # Copyright (c) 2998 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # SCCS: %Z% %M% %I% %E% %U% package provide pkg2 1.0 namespace eval pkg2 { namespace export p2-1 } proc pkg2::p2-1 { num } { return [expr $num * 2] } } [file join pkg pkg2_a.tcl] makeFile { # pkg2_b.tcl -- # # Test package for pkg_mkIndex. This package is required by pkg1. # This package is split into two files, to test packages that are split # over multiple files. # # Copyright (c) 2998 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # SCCS: %Z% %M% %I% %E% %U% package provide pkg2 1.0 namespace eval pkg2 { namespace export p2-2 } proc pkg2::p2-2 { num } { return [expr $num * 3] } } [file join pkg pkg2_b.tcl] test pkgMkIndex-4.1 {split package} { pkgtest::runIndex -lazy $fullPkgPath pkg2_a.tcl pkg2_b.tcl } {0 {{pkg2:1.0 {tclPkgSetup {pkg2_a.tcl source ::pkg2::p2-1} {pkg2_b.tcl source ::pkg2::p2-2}}}}} test pkgMkIndex-4.2 {split package - direct loading} { pkgtest::runIndex -direct $fullPkgPath pkg2_a.tcl pkg2_b.tcl } "0 {{pkg2:1.0 {[list source [file join $fullPkgPath pkg2_a.tcl]] [list source [file join $fullPkgPath pkg2_b.tcl]]}}}" # This will fail, with "direct1" procedures in the list of procedures # provided by std. # It may also fail, if tclblend is in the auto_path, with an additional # command "loadJava" which comes from the tclblend pkgIndex.tcl file. # Both failures are caused by Tcl code executed in pkgIndex.tcl. makeFile { # std.tcl -- # # Test package for pkg_mkIndex. # Does a package require of direct1, whose pkgIndex.tcl entry (in pkg1) # should be a -direct entry. # This tests that pkg_mkIndex can handle code that is sourced in pkgIndex.tcl # files. # # Copyright (c) 1998 by Scriptics Corporation. # All rights reserved. # # RCS: @(#) $Id: pkgMkIndex.test,v 1.21 2002/07/04 00:32:54 dgp Exp $ package require direct1 package provide std 1.0 namespace eval std { namespace export p1 p2 } proc std::p1 { stg } { return [string tolower $stg] } proc std::p2 { stg } { return [string toupper $stg] } } [file join pkg std.tcl] test pkgMkIndex-5.1 {requires -direct package} { pkgtest::runIndex -lazy $fullPkgPath std.tcl } {0 {{std:1.0 {tclPkgSetup {std.tcl source {::std::p1 ::std::p2}}}}}} removeFile [file join pkg std.tcl] makeFile { # pkg1.tcl -- # # Test package for pkg_mkIndex. 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). # # Copyright (c) 1998 by Scriptics Corporation. # All rights reserved. # # RCS: @(#) $Id: pkgMkIndex.test,v 1.21 2002/07/04 00:32:54 dgp Exp $ package require pkg3 1.0 package provide pkg1 1.0 namespace eval pkg1 { namespace export p1-1 p1-2 } proc pkg1::p1-1 { num } { return [pkg3::p3-1 $num] } proc pkg1::p1-2 { num } { return [pkg3::p3-2 $num] } } [file join pkg pkg1.tcl] makeFile { # pkg3.tcl -- # # Test package for pkg_mkIndex. # # Copyright (c) 1998 by Scriptics Corporation. # All rights reserved. # # RCS: @(#) $Id: pkgMkIndex.test,v 1.21 2002/07/04 00:32:54 dgp Exp $ package provide pkg3 1.0 namespace eval pkg3 { namespace export p3-1 p3-2 } proc pkg3::p3-1 { num } { return {[expr $num * 2]} } proc pkg3::p3-2 { num } { return {[expr $num * 3]} } } [file join pkg pkg3.tcl] test pkgMkIndex-6.1 {pkg1 requires pkg3} { pkgtest::runIndex -lazy $fullPkgPath pkg1.tcl pkg3.tcl } {0 {{pkg1:1.0 {tclPkgSetup {pkg1.tcl source {::pkg1::p1-1 ::pkg1::p1-2}}}} {pkg3:1.0 {tclPkgSetup {pkg3.tcl source {::pkg3::p3-1 ::pkg3::p3-2}}}}}} test pkgMkIndex-6.2 {pkg1 requires pkg3 - use -direct} { pkgtest::runIndex -direct $fullPkgPath pkg1.tcl pkg3.tcl } "0 {{pkg1:1.0 {[list source [file join $fullPkgPath pkg1.tcl]]}} {pkg3:1.0 {[list source [file join $fullPkgPath pkg3.tcl]]}}}" removeFile [file join pkg pkg1.tcl] makeFile { # pkg4.tcl -- # # Test package for pkg_mkIndex. This package requires pkg3, and it calls # a pkg3 proc in the code that is executed by the file # # Copyright (c) 1998 by Scriptics Corporation. # All rights reserved. # # RCS: @(#) $Id: pkgMkIndex.test,v 1.21 2002/07/04 00:32:54 dgp Exp $ package require pkg3 1.0 package provide pkg4 1.0 namespace eval pkg4 { namespace export p4-1 p4-2 variable m2 [pkg3::p3-1 10] } proc pkg4::p4-1 { num } { variable m2 return [expr {$m2 * $num}] } proc pkg4::p4-2 { num } { return [pkg3::p3-2 $num] } } [file join pkg pkg4.tcl] test pkgMkIndex-7.1 {pkg4 uses pkg3} { pkgtest::runIndex -lazy $fullPkgPath pkg4.tcl pkg3.tcl } {0 {{pkg3:1.0 {tclPkgSetup {pkg3.tcl source {::pkg3::p3-1 ::pkg3::p3-2}}}} {pkg4:1.0 {tclPkgSetup {pkg4.tcl source {::pkg4::p4-1 ::pkg4::p4-2}}}}}} test pkgMkIndex-7.2 {pkg4 uses pkg3 - use -direct} { pkgtest::runIndex -direct $fullPkgPath pkg4.tcl pkg3.tcl } "0 {{pkg3:1.0 {[list source [file join $fullPkgPath pkg3.tcl]]}} {pkg4:1.0 {[list source [file join $fullPkgPath pkg4.tcl]]}}}" removeFile [file join pkg pkg4.tcl] removeFile [file join pkg pkg3.tcl] makeFile { # pkg5.tcl -- # # Test package for pkg_mkIndex. This package requires pkg2, and it calls # a pkg2 proc in the code that is executed by the file. # Pkg2 is a split package. # # Copyright (c) 1998 by Scriptics Corporation. # All rights reserved. # # RCS: @(#) $Id: pkgMkIndex.test,v 1.21 2002/07/04 00:32:54 dgp Exp $ package require pkg2 1.0 package provide pkg5 1.0 namespace eval pkg5 { namespace export p5-1 p5-2 variable m2 [pkg2::p2-1 10] variable m3 [pkg2::p2-2 10] } proc pkg5::p5-1 { num } { variable m2 return [expr {$m2 * $num}] } proc pkg5::p5-2 { num } { variable m2 return [expr {$m2 * $num}] } } [file join pkg pkg5.tcl] test pkgMkIndex-8.1 {pkg5 uses pkg2} { pkgtest::runIndex -lazy $fullPkgPath pkg5.tcl pkg2_a.tcl pkg2_b.tcl } {0 {{pkg2:1.0 {tclPkgSetup {pkg2_a.tcl source ::pkg2::p2-1} {pkg2_b.tcl source ::pkg2::p2-2}}} {pkg5:1.0 {tclPkgSetup {pkg5.tcl source {::pkg5::p5-1 ::pkg5::p5-2}}}}}} test pkgMkIndex-8.2 {pkg5 uses pkg2 - use -direct} { pkgtest::runIndex -direct $fullPkgPath pkg5.tcl pkg2_a.tcl pkg2_b.tcl } "0 {{pkg2:1.0 {[list source [file join $fullPkgPath pkg2_a.tcl]] [list source [file join $fullPkgPath pkg2_b.tcl]]}} {pkg5:1.0 {[list source [file join $fullPkgPath pkg5.tcl]]}}}" removeFile [file join pkg pkg5.tcl] removeFile [file join pkg pkg2_a.tcl] removeFile [file join pkg pkg2_b.tcl] makeFile { # circ1.tcl -- # # Test package for pkg_mkIndex. 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. # # Copyright (c) 1998 by Scriptics Corporation. # All rights reserved. # # RCS: @(#) $Id: pkgMkIndex.test,v 1.21 2002/07/04 00:32:54 dgp Exp $ package require circ2 1.0 package provide circ1 1.0 namespace eval circ1 { namespace export c1-1 c1-2 c1-3 c1-4 } proc circ1::c1-1 { num } { return [circ2::c2-1 $num] } proc circ1::c1-2 { num } { return [circ2::c2-2 $num] } proc circ1::c1-3 {} { return 10 } proc circ1::c1-4 {} { return 20 } } [file join pkg circ1.tcl] makeFile { # circ2.tcl -- # # Test package for pkg_mkIndex. This package is required by circ1, and # requires circ3. Circ3, in turn, requires circ1 to give us a circularity. # # Copyright (c) 1998 by Scriptics Corporation. # All rights reserved. # # RCS: @(#) $Id: pkgMkIndex.test,v 1.21 2002/07/04 00:32:54 dgp Exp $ package require circ3 1.0 package provide circ2 1.0 namespace eval circ2 { namespace export c2-1 c2-2 } proc circ2::c2-1 { num } { return [expr $num * [circ3::c3-1]] } proc circ2::c2-2 { num } { return [expr $num * [circ3::c3-2]] } } [file join pkg circ2.tcl] makeFile { # circ3.tcl -- # # Test package for pkg_mkIndex. This package is required by circ2, and in # turn requires circ1. This closes the circularity. # # Copyright (c) 1998 by Scriptics Corporation. # All rights reserved. # # RCS: @(#) $Id: pkgMkIndex.test,v 1.21 2002/07/04 00:32:54 dgp Exp $ package require circ1 1.0 package provide circ3 1.0 namespace eval circ3 { namespace export c3-1 c3-4 } proc circ3::c3-1 {} { return [circ1::c1-3] } proc circ3::c3-2 {} { return [circ1::c1-4] } } [file join pkg circ3.tcl] test pkgMkIndex-9.1 {circular packages} { pkgtest::runIndex -lazy $fullPkgPath circ1.tcl circ2.tcl circ3.tcl } {0 {{circ1:1.0 {tclPkgSetup {circ1.tcl source {::circ1::c1-1 ::circ1::c1-2 ::circ1::c1-3 ::circ1::c1-4}}}} {circ2:1.0 {tclPkgSetup {circ2.tcl source {::circ2::c2-1 ::circ2::c2-2}}}} {circ3:1.0 {tclPkgSetup {circ3.tcl source ::circ3::c3-1}}}}} removeFile [file join pkg circ1.tcl] removeFile [file join pkg circ2.tcl] removeFile [file join pkg circ3.tcl] # Some tests require the existence of one of the DLLs in the dltest directory set x [file join [file dirname [info nameofexecutable]] dltest \ pkga[info sharedlibextension]] set dll "[file tail $x]Required" ::tcltest::testConstraint $dll [file exists $x] makeFile { # pkga.tcl -- # # Test package for pkg_mkIndex. This package provides Pkga, # which is also provided by a DLL. # # Copyright (c) 1998 by Scriptics Corporation. # All rights reserved. # # RCS: @(#) $Id: pkgMkIndex.test,v 1.21 2002/07/04 00:32:54 dgp Exp $ package provide Pkga 1.0 proc pkga_neq { x } { return [expr {! [pkgq_eq $x]}] } } [file join pkg pkga.tcl] file copy -force $x $fullPkgPath 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. 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. # # 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]]" exec [interpreter] << $script pkgtest::runCreatedIndex {0 {}} -lazy -load Pkg* -- $fullPkgPath pkga[info sharedlibextension] } {0 {}} file delete -force [file join $fullPkgPath [file tail $x]] removeFile [file join pkg pkga.tcl] # Tolerate "namespace import" at the global scope makeFile { package provide fubar 1.0 namespace eval ::fubar:: { # # export only public functions. # namespace export {[a-z]*} } proc ::fubar::foo {bar} { puts "$bar" return true } namespace import ::fubar::foo } [file join pkg import.tcl] test pkgMkIndex-11.1 {conflicting namespace imports} { pkgtest::runIndex -lazy $fullPkgPath import.tcl } {0 {{fubar:1.0 {tclPkgSetup {import.tcl source ::fubar::foo}}}}} 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) 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] test pkgMkIndex-12.1 {same name procs in different namespace} { pkgtest::runIndex -lazy $fullPkgPath samename.tcl } {0 {{football:1.0 {tclPkgSetup {samename.tcl source {::college::team ::pro::team}}}}}} removeFile [file join pkg samename.tcl] # Proc names with embedded spaces are properly listed (ie, correct number of # braces) in result makeFile { package provide spacename 1.0 proc {a b} {} {} proc {c d} {} {} } [file join pkg spacename.tcl] test pkgMkIndex-13.1 {proc names with embedded spaces} { pkgtest::runIndex -lazy $fullPkgPath spacename.tcl } {0 {{spacename:1.0 {tclPkgSetup {spacename.tcl source {{a b} {c d}}}}}}} removeFile [file join pkg spacename.tcl] # Test the pkg_compareExtension helper function test pkgMkIndex-14.1 {pkg_compareExtension} {unixOnly} { pkg_compareExtension foo.so .so } 1 test pkgMkIndex-14.2 {pkg_compareExtension} {unixOnly} { pkg_compareExtension foo.so.bar .so } 0 test pkgMkIndex-14.3 {pkg_compareExtension} {unixOnly} { pkg_compareExtension foo.so.1 .so } 1 test pkgMkIndex-14.4 {pkg_compareExtension} {unixOnly} { pkg_compareExtension foo.so.1.2 .so } 1 test pkgMkIndex-14.5 {pkg_compareExtension} {unixOnly} { pkg_compareExtension foo .so } 0 test pkgMkIndex-14.6 {pkg_compareExtension} {unixOnly} { pkg_compareExtension foo.so.1.2.bar .so } 0 # cleanup removeDirectory pkg namespace delete pkgtest ::tcltest::cleanupTests return