Artifact Content

Not logged in

Artifact 056dfd89d0b390e607350012eff36bfe62606e5f3efa3a849a6de6f4534a4c55:


# -*- tcl -*- Copyright (c) 2006-2012 Andreas Kupries
# # ## ### ##### ######## ############# #####################
## Testsuite Utilities. Started in tcllib, snarfed for kettle.

namespace eval ::kt {
    namespace export {[a-z]*}
    namespace ensemble create
}

# # ## ### ##### ######## ############# #####################
## API. Use of files relative to the test directory.

proc ::kt::in {path script} {
    # change context to a different test suite
    variable ::tcltest::testsDirectory
    set saved $testsDirectory
    set testsDirectory [file normalize [file join $testsDirectory $path]]
    try {
	uplevel 1 $script
    } finally {
	set testsDirectory $saved
    }
}

proc ::kt::source {path} {
    variable ::tcltest::testsDirectory
    uplevel 1 [list ::source [file normalize [file join $testsDirectory $path]]]
}

proc ::kt::find {pattern} {
    return [lsort -dict [glob -nocomplain -directory $::tcltest::testsDirectory $pattern]]
}

proc ::kt::source* {pattern} {
    foreach f [find $pattern] {
	uplevel 1 [list ::source $f]
    }
    return
}

# # ## ### ##### ######## ############# #####################
## Use of packages. Support, and under test.

proc ::kt::check {name version} {
    if {[package vsatisfies [package provide $name] $version]} {
	puts "SYSTEM - $name [package present $name]"
	return
    }

    puts "    Aborting the tests found in \"[file tail [info script]]\""
    puts "    Requiring at least $name $version, have [package present $name]."

    # This causes a 'return' in the calling scope.
    return -code return
}

proc ::kt::require {type name args} {
    variable tag
    try {
	package require $name {*}$args
    } on error {e o} {
	puts "    Aborting the tests found in \"[file tail [info script]]\""
	puts "    Required package $name not found: $e"
	return -code return
    }

    puts "SYSTEM [dict get $tag $type] $name [package present $name]"
    return
}

proc ::kt::local {type name args} {
    variable tag
    # Specialized package require. It is forced to search (via
    # forget), and its search is restricted to the local installation,
    # via a custom unknown handler temporarily replacing the regular
    # functionality.

    set saved [package unknown]
    try {
	package unknown ::kt::PU
	package forget  $name
	package require $name {*}$args
    } on error {e o} {
	puts "    Aborting the tests found in \"[file tail [info script]]\""
	puts "    Required local package $name not found: $e"
	puts "    |[join [split [dict get $o -errorinfo] \n] "\n    |"]"
	return -code return
    } finally {
	package unknown $saved
    }

    puts "LOCAL  [dict get $tag $type] $name [package present $name]"
    return
}

proc ::kt::local* {type name args} {
    variable tag
    # Specialized package require. Its search is restricted to the
    # local installation, via a custom unknown handler temporarily
    # replacing the regular functionality.

    set saved [package unknown]
    try {
	package unknown ::kt::PU
	package require $name {*}$args
    } on error {e o} {
	puts "    Aborting the tests found in \"[file tail [info script]]\""
	puts "    Required local package $name not found: $e"
	puts "    |[join [split [dict get $o -errorinfo] \n] "\n    |"]"
	return -code return
    } finally {
	package unknown $saved
    }

    puts "LOCAL  [dict get $tag $type] $name [package present $name]"
    return
}

proc ::kt::semi-local* {type name args} {
    variable tag
    # Specialized package require. It searches the local installation
    # first, via a custom unknown handler temporarily replacing the
    # regular functionality. If that fails the regular set of packages
    # is checked too.

    set saved [package unknown]
    try {
	package unknown ::kt::PU
	package require $name {*}$args
	puts "LOCAL  [dict get $tag $type] $name [package present $name]"
    } on error {e o} {
	package unknown $saved
	try {
	    package require $name {*}$args
	    puts "SYSTEM [dict get $tag $type] $name [package present $name]"
	} on error {e o} {
	    puts "    Aborting the tests found in \"[file tail [info script]]\""
	    puts "    Required semi-local package $name not found: $e"
	    puts "    |[join [split [dict get $o -errorinfo] \n] "\n    |"]"
	    return -code return
	}
    } finally {
	package unknown $saved
    }
    return
}

proc ::kt::PU {name args} {
    global   auto_path
    variable localprefix

    set saved $auto_path
    set auto_path [list $localprefix/lib]

    # Direct call into package scan, ignore modules.
    tclPkgUnknown __ignored__

    set auto_path $saved
    return
}

namespace eval ::kt {
    variable tag {
	support -
	testing %
    }
}

# # ## ### ##### ######## ############# #####################
## General utilities

# - dictsort -
#
#  Sort a dictionary by its keys. I.e. reorder the contents of the
#  dictionary so that in its list representation the keys are found in
#  ascending alphabetical order. In other words, this command creates
#  a canonical list representation of the input dictionary, suitable
#  for direct comparison.
#
# Arguments:
#	dict:	The dictionary to sort.
#
# Result:
#	The canonical representation of the dictionary.

proc ::kt::dictsort {dict} {
    array set a $dict
    set out [list]
    foreach key [lsort -dict [array names a]] {
	lappend out $key $a($key)
    }
    return $out
}

# # ## ### ##### ######## ############# #####################
## Tcltest extensions ...
#
## We can assume to have tcltest 2, or higher
## (We assume Tcl 8.5 or higher)

## Standard constraints.

::tcltest::testConstraint tcl8.5plus [expr {[package vsatisfies [package provide Tcl] 8.5]}]
::tcltest::testConstraint tcl8.6plus [expr {[package vsatisfies [package provide Tcl] 8.6]}]

## Commands generating the proper wrong#args message from a command
## syntax description. Core version dependent.

if {[package vsatisfies [package provide Tcl] 8.6]} {
    # 8.6+
    proc ::tcltest::wrongNumArgs {functionName argList missingIndex} {
	if {[lindex $argList end] eq "args"} {
	    set argList [lreplace $argList end end ?arg ...?]
	}
	if {$argList != {}} {set argList " $argList"}
	set msg "wrong # args: should be \"$functionName$argList\""
	return $msg
    }

    proc ::tcltest::tooManyArgs {functionName argList} {
	# create a different message for functions with no args
	if {[llength $argList]} {
	    if {[lindex $argList end] eq "args"} {
		set argList [lreplace $argList end end ?arg ...?]
	    }
	    set msg "wrong # args: should be \"$functionName $argList\""
	} else {
	    set msg "wrong # args: should be \"$functionName\""
	}
	return $msg
    }
} else {
    # 8.5
    proc ::tcltest::wrongNumArgs {functionName argList missingIndex} {
	if {[lindex $argList end] eq "args"} {
	    set argList [lreplace $argList end end ?argument ...?]
	}
	if {$argList != {}} {set argList " $argList"}
	set msg "wrong # args: should be \"$functionName$argList\""
	return $msg
    }

    proc ::tcltest::tooManyArgs {functionName argList} {
	# create a different message for functions with no args
	if {[llength $argList]} {
	    if {[lindex $argList end] eq "args"} {
		set argList [lreplace $argList end end ...]
	    }
	    set msg "wrong # args: should be \"$functionName $argList\""
	} else {
	    set msg "wrong # args: should be \"$functionName\""
	}
	return $msg
    }
}

## Creation of transient binary files.
## Easy access to the temp directory.

proc ::tcltest::makeBinaryFile {data f} {
    set path [makeFile {} $f]
    set ch   [open $path w]
    fconfigure $ch -translation binary
    puts -nonewline $ch $data
    close $ch
    return $path
}

proc ::tcltest::tempPath {path} {
    variable temporaryDirectory
    return [file join $temporaryDirectory $path]
}

namespace eval ::tcltest {
    namespace export wrongNumArgs tooManyArgs
    namespace export makeBinaryFile tempPath
}

# ### ### ### ######### ######### #########
return