Tcl Library Source Code

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

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

proc testsNeed {name args} {
    # This command ensures that a minimum version of package <name> is
    # used to run the tests in the calling testsuite. If the minimum
    # is not met by the active interpreter we forcibly bail out of the
    # testsuite calling the command. The command has to be called
    # immediately after loading the utilities.

    if {[catch {
	package require $name
    }]} {
	puts "    Aborting the tests found in \"[file tail [info script]]\""
	puts "    Requiring package $name, not found."

	return -code return
    }

    foreach version $args {
	if {[package vsatisfies [package present $name] $version]} {
	    puts "$::tcllib::testutils::tag [list $name] [package present $name]"
	    return
	}
    }

    if {[llength $args] > 1} {
	set args [linsert [join $args {, } end-1 or]
    }

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

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

# ### ### ### ######### ######### #########

    set use [expr {$acc ? "useKeep" : "use"}]
    uplevel 1 [linsert $args 0 $use $fname $pname]
}

proc support {script} {
    InitializeTclTest
    set ::tcllib::testutils::tag "-"
    if {[set code [catch {
	uplevel 1 $script
    } msg]]} {
	if {$code == 2} { return -code return }
	set prefix "SETUP Error (Support): "
	puts $prefix[join [split $::errorInfo \n] "\n$prefix"]

	return -code return
    }
    return
}

# ::Table called with arguments: foo bar
# ======

# # ## ### ##### ######## ############# ####################
## Singleton Metaclass
## http://wiki.tcl.tk/21595. v63, Donal Fellows

oo::class create oo::util::singleton {
   superclass oo::class
   variable object
   method create {name args} {
       if {![info exists object] ||
	   ![info object isa object $object]} {
         set object [next $name {*}$args]
      }
      return $object
   }
   method new args {
       if {![info exists object] ||
	   ![info object isa object $object]} {
         set object [next {*}$args]
      }
      return $object
   }
}

# ======

# -*- tcl -*-
# # ## ### ##### ######## ############# #####################

## Tests for the oo utilities facility
## Copyright (c) 2012 by ActiveState Tool Corp.
## BSD licensed.

# # ## ### ##### ######## ############# #####################

source [file join \
	[file dirname [file dirname [file join [pwd] [info script]]]] \
	devtools testutilities.tcl]

testsNeedTcl     8.5
testsNeedTcltest 2

support {
    testsNeed TclOO 0.6 1

    puts [package ifneeded TclOO [package present TclOO]]
}
testing {
    useLocal ooutil.tcl oo::util
}

# # ## ### ##### ######## ############# #####################

test ooutil-singleton-3609183-1 {bug 3609183} -setup {
    oo::class create example {
	self mixin oo::util::singleton
	method foo {} {self}
    }
} -body {
    set a [[example new] foo]
    set b [[example new] foo]
puts $a
puts $b
    string equal $a $b
} -cleanup {
    unset a b
    example destroy
} -result 1

test ooutil-singleton-3609183-2 {bug 3609183} -setup {
    oo::util::singleton create example {
	method foo {} {self}
    }
} -body {
    set a [[example new] foo]
    set b [[example new] foo]
puts $a
puts $b
    string equal $a $b
} -cleanup {
    unset a b
    example destroy
} -result 1

# # ## ### ##### ######## ############# #####################

testsuiteCleanup
return