701 lines
19 KiB
Plaintext
701 lines
19 KiB
Plaintext
|
# 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 Scriptics Corporation.
|
|||
|
|
# All rights reserved.
|
|||
|
|
|
|||
|
|
if {"::tcltest" ni [namespace children]} {
|
|||
|
|
package require tcltest 2.5
|
|||
|
|
namespace import -force ::tcltest::*
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
set fullPkgPath [makeDirectory pkg]
|
|||
|
|
|
|||
|
|
namespace eval pkgtest {
|
|||
|
|
# Namespace for procs we can discard
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
# pkgtest::parseArgs --
|
|||
|
|
#
|
|||
|
|
# Parse an argument list.
|
|||
|
|
#
|
|||
|
|
# Arguments:
|
|||
|
|
# <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
|
|||
|
|
# 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 {$a eq "-load"} {
|
|||
|
|
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 child interpreter, where we override "package ifneeded"
|
|||
|
|
|
|||
|
|
set child [interp create]
|
|||
|
|
if {[catch {
|
|||
|
|
$child eval {
|
|||
|
|
rename package package_original
|
|||
|
|
proc package { args } {
|
|||
|
|
if {[lindex $args 0] eq "ifneeded"} {
|
|||
|
|
set pkg [lindex $args 1]
|
|||
|
|
set ver [lindex $args 2]
|
|||
|
|
set ::PKGS($pkg:$ver) [lindex $args 3]
|
|||
|
|
} else {
|
|||
|
|
return [package_original {*}$args]
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
array set ::PKGS {}
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
set dir [file dirname $filePath]
|
|||
|
|
$child eval {set curdir [pwd]}
|
|||
|
|
$child eval [list cd $dir]
|
|||
|
|
$child eval [list set dir $dir]
|
|||
|
|
$child eval [list source [file tail $filePath]]
|
|||
|
|
$child 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} [$child eval {array get ::PKGS}] {
|
|||
|
|
set P($k) $v
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
set PKGS ""
|
|||
|
|
foreach k [lsort [array names P]] {
|
|||
|
|
lappend PKGS $k $P($k)
|
|||
|
|
}
|
|||
|
|
} err opts]} {
|
|||
|
|
set ei [dict get $opts -errorinfo]
|
|||
|
|
set ec [dict get $opts -errorcode]
|
|||
|
|
|
|||
|
|
catch {interp delete $child}
|
|||
|
|
|
|||
|
|
error $ei $ec
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
interp delete $child
|
|||
|
|
|
|||
|
|
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:
|
|||
|
|
# <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
|
|||
|
|
# 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 [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]
|
|||
|
|
pkg_mkIndex {*}$options $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:
|
|||
|
|
# <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
|
|||
|
|
# 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 [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 [createIndex {*}$args]
|
|||
|
|
return [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 {
|
|||
|
|
# This is a simple package, just to check basic functionality.
|
|||
|
|
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]]}}}"
|
|||
|
|
|
|||
|
|
test pkgMkIndex-2.4 {simple package - use -verbose} -body {
|
|||
|
|
pkgtest::runIndex -verbose $fullPkgPath simple.tcl
|
|||
|
|
} -result "0 {{simple:1.0 {[list source [file join $fullPkgPath simple.tcl]]}}}" \
|
|||
|
|
-errorOutput {successful sourcing of simple.tcl
|
|||
|
|
packages provided were {simple 1.0}
|
|||
|
|
processed simple.tcl
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
removeFile [file join pkg simple.tcl]
|
|||
|
|
|
|||
|
|
makeFile {
|
|||
|
|
# Contains global symbols, used to check that they don't have a leading ::
|
|||
|
|
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 {
|
|||
|
|
# This package is required by pkg1.
|
|||
|
|
# 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
|
|||
|
|
}
|
|||
|
|
proc pkg2::p2-1 { num } {
|
|||
|
|
return [expr {$num * 2}]
|
|||
|
|
}
|
|||
|
|
} [file join pkg pkg2_a.tcl]
|
|||
|
|
|
|||
|
|
makeFile {
|
|||
|
|
# This package is required by pkg1.
|
|||
|
|
# 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
|
|||
|
|
}
|
|||
|
|
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]]}}}"
|
|||
|
|
|
|||
|
|
# Add the direct1 directory to auto_path, so that the direct1 package can be
|
|||
|
|
# found.
|
|||
|
|
set direct1 [makeDirectory direct1]
|
|||
|
|
lappend auto_path $direct1
|
|||
|
|
makeFile {
|
|||
|
|
# This is referenced by pkgIndex.tcl as a -direct script.
|
|||
|
|
package provide direct1 1.0
|
|||
|
|
namespace eval direct1 {
|
|||
|
|
namespace export pd1 pd2
|
|||
|
|
}
|
|||
|
|
proc direct1::pd1 { stg } {
|
|||
|
|
return [string tolower $stg]
|
|||
|
|
}
|
|||
|
|
proc direct1::pd2 { stg } {
|
|||
|
|
return [string toupper $stg]
|
|||
|
|
}
|
|||
|
|
} [file join direct1 direct1.tcl]
|
|||
|
|
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.
|
|||
|
|
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 direct1 direct1.tcl]
|
|||
|
|
file delete [file join $direct1 pkgIndex.tcl]
|
|||
|
|
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).
|
|||
|
|
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 {
|
|||
|
|
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 {
|
|||
|
|
# 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 {
|
|||
|
|
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 {
|
|||
|
|
# 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 {
|
|||
|
|
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 {
|
|||
|
|
# 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 {
|
|||
|
|
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 {
|
|||
|
|
# 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 {
|
|||
|
|
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 {
|
|||
|
|
# 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 {
|
|||
|
|
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"
|
|||
|
|
testConstraint $dll [file exists $x]
|
|||
|
|
|
|||
|
|
if {[testConstraint $dll]} {
|
|||
|
|
makeFile {
|
|||
|
|
# This package provides pkga, which is also provided by a DLL.
|
|||
|
|
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]"
|
|||
|
|
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 {}}
|
|||
|
|
|
|||
|
|
if {[testConstraint $dll]} {
|
|||
|
|
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 tcl::Pkg::CompareExtension helper function
|
|||
|
|
test pkgMkIndex-14.1 {tcl::Pkg::CompareExtension} {unix} {
|
|||
|
|
tcl::Pkg::CompareExtension foo.so .so
|
|||
|
|
} 1
|
|||
|
|
test pkgMkIndex-14.2 {tcl::Pkg::CompareExtension} {unix} {
|
|||
|
|
tcl::Pkg::CompareExtension foo.so.bar .so
|
|||
|
|
} 0
|
|||
|
|
test pkgMkIndex-14.3 {tcl::Pkg::CompareExtension} {unix} {
|
|||
|
|
tcl::Pkg::CompareExtension foo.so.1 .so
|
|||
|
|
} 1
|
|||
|
|
test pkgMkIndex-14.4 {tcl::Pkg::CompareExtension} {unix} {
|
|||
|
|
tcl::Pkg::CompareExtension foo.so.1.2 .so
|
|||
|
|
} 1
|
|||
|
|
test pkgMkIndex-14.5 {tcl::Pkg::CompareExtension} {unix} {
|
|||
|
|
tcl::Pkg::CompareExtension foo .so
|
|||
|
|
} 0
|
|||
|
|
test pkgMkIndex-14.6 {tcl::Pkg::CompareExtension} {unix} {
|
|||
|
|
tcl::Pkg::CompareExtension foo.so.1.2.bar .so
|
|||
|
|
} 0
|
|||
|
|
|
|||
|
|
# cleanup
|
|||
|
|
|
|||
|
|
removeDirectory pkg
|
|||
|
|
|
|||
|
|
namespace delete pkgtest
|
|||
|
|
::tcltest::cleanupTests
|
|||
|
|
return
|
|||
|
|
|
|||
|
|
# Local Variables:
|
|||
|
|
# mode: tcl
|
|||
|
|
# fill-column: 78
|
|||
|
|
# End:
|