diff options
Diffstat (limited to 'tests/ooUtil.test')
| -rw-r--r-- | tests/ooUtil.test | 586 |
1 files changed, 0 insertions, 586 deletions
diff --git a/tests/ooUtil.test b/tests/ooUtil.test deleted file mode 100644 index 9e1de8f..0000000 --- a/tests/ooUtil.test +++ /dev/null @@ -1,586 +0,0 @@ -# This file contains a collection of tests for functionality originally -# sourced from the ooutil package in Tcllib. Sourcing this file into Tcl runs -# the tests and generates output for errors. No output means no errors were -# found. -# -# Copyright © 2014-2016 Andreas Kupries -# Copyright © 2018 Donal K. Fellows -# -# See the file "license.terms" for information on usage and redistribution of -# this file, and for a DISCLAIMER OF ALL WARRANTIES. - -package require tcl::oo 1.3.0 -if {"::tcltest" ni [namespace children]} { - package require tcltest 2.5 - namespace import -force ::tcltest::* -} - -test ooUtil-1.1 {TIP 478: classmethod} -setup { - oo::class create parent -} -body { - oo::class create ActiveRecord { - superclass parent - classmethod find args { - return "[self] called with arguments: $args" - } - } - oo::class create Table { - superclass ActiveRecord - } - Table find foo bar -} -cleanup { - parent destroy -} -result {::Table called with arguments: foo bar} -test ooUtil-1.2 {TIP 478: classmethod in namespace} -setup { - namespace eval ::testns {} -} -body { - namespace eval ::testns { - oo::class create ActiveRecord { - classmethod find args { - return "[self] called with arguments: $args" - } - } - oo::class create Table { - superclass ActiveRecord - } - } - testns::Table find foo bar -} -cleanup { - namespace delete ::testns -} -result {::testns::Table called with arguments: foo bar} -test ooUtil-1.3 {TIP 478: classmethod must not interfere with constructor signatures} -setup { - oo::class create parent -} -body { - oo::class create TestClass { - superclass oo::class parent - self method create {name ignore body} { - next $name $body - } - } - TestClass create okay {} {} -} -cleanup { - parent destroy -} -result {::okay} -test ooUtil-1.4 {TIP 478: classmethod with several inheritance levels} -setup { - oo::class create parent -} -body { - oo::class create ActiveRecord { - superclass parent - classmethod find args { - return "[self] called with arguments: $args" - } - } - oo::class create Table { - superclass ActiveRecord - } - oo::class create SubTable { - superclass Table - } - SubTable find foo bar -} -cleanup { - parent destroy -} -result {::SubTable called with arguments: foo bar} -test ooUtil-1.5 {TIP 478: classmethod and instances} -setup { - oo::class create parent -} -body { - oo::class create ActiveRecord { - superclass parent - classmethod find args { - return "[self] called with arguments: $args" - } - } - oo::class create Table { - superclass ActiveRecord - } - set t [Table new] - $t find 1 2 3 -} -cleanup { - parent destroy -} -result {::Table called with arguments: 1 2 3} -test ooUtil-1.6 {TIP 478: classmethod and instances} -setup { - oo::class create parent -} -body { - oo::class create ActiveRecord { - superclass parent - classmethod find args { - return "[self] called with arguments: $args" - } - } - oo::class create Table { - superclass ActiveRecord - unexport find - } - set t [Table new] - $t find 1 2 3 -} -returnCodes error -cleanup { - parent destroy -} -match glob -result {unknown method "find": must be *} -test ooUtil-1.7 {} -setup { - oo::class create parent -} -body { - oo::class create Foo { - superclass parent - classmethod bar {} { - puts "This is in the class; self is [self]" - my meee - } - classmethod meee {} { - puts "This is meee" - } - } - oo::class create Grill { - superclass Foo - classmethod meee {} { - puts "This is meee 2" - } - } - list [Foo bar] [Grill bar] [[Foo new] bar] [[Grill new] bar] -} -cleanup { - parent destroy -} -result {{} {} {} {}} -output "This is in the class; self is ::Foo\nThis is meee\nThis is in the class; self is ::Grill\nThis is meee 2\nThis is in the class; self is ::Foo\nThis is meee\nThis is in the class; self is ::Grill\nThis is meee 2\n" -# Two tests to confirm that we correctly initialise the scripted part of TclOO -# in child interpreters. This is slightly tricky at the implementation level -# because we cannot count on either [source] or [open] being available. -test ooUtil-1.8 {TIP 478: classmethod in child interp} -setup { - set childinterp [interp create] -} -body { - $childinterp eval { - oo::class create ActiveRecord { - classmethod find args { - return "[self] called with arguments: $args" - } - } - oo::class create Table { - superclass ActiveRecord - } - # This is confirming that this is not the parent interpreter - list [Table find foo bar] [info globals childinterp] - } -} -cleanup { - interp delete $childinterp -} -result {{::Table called with arguments: foo bar} {}} -test ooUtil-1.9 {TIP 478: classmethod in safe child interp} -setup { - set safeinterp [interp create -safe] -} -body { - $safeinterp eval { - oo::class create ActiveRecord { - classmethod find args { - return "[self] called with arguments: $args" - } - } - oo::class create Table { - superclass ActiveRecord - } - # This is confirming that this is a (basic) safe interpreter - list [Table find foo bar] [info commands source] - } -} -cleanup { - interp delete $safeinterp -} -result {{::Table called with arguments: foo bar} {}} - -test ooUtil-2.1 {TIP 478: callback generation} -setup { - oo::class create parent -} -body { - oo::class create c { - superclass parent - method CallMe {} { return ok,[self] } - method makeCall {} { - return [callback CallMe] - } - } - c create ::context - set cb [context makeCall] - {*}$cb -} -cleanup { - parent destroy -} -result {ok,::context} -test ooUtil-2.2 {TIP 478: callback generation} -setup { - oo::class create parent -} -body { - oo::class create c { - superclass parent - method CallMe {a b c} { return ok,[self],$a,$b,$c } - method makeCall {b} { - return [callback CallMe 123 $b] - } - } - c create ::context - set cb [context makeCall "a b c"] - {*}$cb PQR -} -cleanup { - parent destroy -} -result {ok,::context,123,a b c,PQR} -test ooUtil-2.3 {TIP 478: callback generation, alternate name} -setup { - oo::class create parent -} -body { - oo::class create c { - superclass parent - method CallMe {} { return ok,[self] } - method makeCall {} { - return [mymethod CallMe] - } - } - c create ::context - set cb [context makeCall] - {*}$cb -} -cleanup { - parent destroy -} -result {ok,::context} -test ooUtil-2.4 {TIP 478: callback generation, alternate name} -setup { - oo::class create parent -} -body { - oo::class create c { - superclass parent - method CallMe {a b c} { return ok,[self],$a,$b,$c } - method makeCall {b} { - return [mymethod CallMe 123 $b] - } - } - c create ::context - set cb [context makeCall "a b c"] - {*}$cb PQR -} -cleanup { - parent destroy -} -result {ok,::context,123,a b c,PQR} -test ooUtil-2.5 {TIP 478: callbacks and method lifetime} -setup { - oo::class create parent -} -body { - oo::class create c { - superclass parent - method makeCall {b} { - return [callback CallMe 123 $b] - } - } - c create ::context - set cb [context makeCall "a b c"] - set result [list [catch {{*}$cb PQR} msg] $msg] - oo::objdefine context { - method CallMe {a b c} { return ok,[self],$a,$b,$c } - } - lappend result [{*}$cb PQR] -} -cleanup { - parent destroy -} -result {1 {unknown method "CallMe": must be <cloned>, destroy, eval, makeCall, unknown, variable or varname} {ok,::context,123,a b c,PQR}} -test ooUtil-2.6 {TIP 478: callback use case} -setup { - oo::class create parent - unset -nocomplain x -} -body { - oo::class create c { - superclass parent - variable count - constructor {var} { - set count 0 - upvar 1 $var v - trace add variable v write [callback TraceCallback] - } - method count {} {return $count} - method TraceCallback {name1 name2 op} { - incr count - } - } - set o [c new x] - for {set x 0} {$x < 5} {incr x} {} - $o count -} -cleanup { - unset -nocomplain x - parent destroy -} -result 6 - -test ooUtil-3.1 {TIP 478: class initialisation} -setup { - oo::class create parent - catch {rename ::foobar-3.1 {}} -} -body { - oo::class create ::cls { - superclass parent - initialise { - proc foobar-3.1 {} {return ok} - } - method calls {} { - list [catch foobar-3.1 msg] $msg \ - [namespace eval [info object namespace [self class]] foobar-3.1] - } - } - [cls new] calls -} -cleanup { - parent destroy -} -result {1 {invalid command name "foobar-3.1"} ok} -test ooUtil-3.2 {TIP 478: class variables} -setup { - oo::class create parent - catch {rename ::foobar-3.1 {}} -} -body { - oo::class create ::cls { - superclass parent - initialise { - variable x 123 - } - method call {} { - classvariable x - incr x - } - } - cls create a - cls create b - cls create c - list [a call] [b call] [c call] [a call] [b call] [c call] -} -cleanup { - parent destroy -} -result {124 125 126 127 128 129} -test ooUtil-3.3 {TIP 478: class initialisation} -setup { - oo::class create parent - catch {rename ::foobar-3.3 {}} -} -body { - oo::class create ::cls { - superclass parent - initialize { - proc foobar-3.3 {} {return ok} - } - method calls {} { - list [catch foobar-3.3 msg] $msg \ - [namespace eval [info object namespace [self class]] foobar-3.3] - } - } - [cls new] calls -} -cleanup { - parent destroy -} -result {1 {invalid command name "foobar-3.3"} ok} -test ooUtil-3.4 {TIP 478: class initialisation} -setup { - oo::class create parent - catch {rename ::appendToResultVar {}} - proc ::appendToResultVar args { - lappend ::result {*}$args - } - set result {} -} -body { - trace add execution oo::define::initialise enter appendToResultVar - oo::class create ::cls { - superclass parent - initialize {proc xyzzy {} {}} - } - return $result -} -cleanup { - catch { - trace remove execution oo::define::initialise enter appendToResultVar - } - rename ::appendToResultVar {} - parent destroy -} -result {{initialize {proc xyzzy {} {}}} enter} -test ooUtil-3.5 {TIP 478: class initialisation} -body { - oo::define oo::object { - ::list [::namespace which initialise] [::namespace which initialize] \ - [::namespace origin initialise] [::namespace origin initialize] - } -} -result {::oo::define::initialise ::oo::define::initialize ::oo::define::initialise ::oo::define::initialise} - -test ooUtil-4.1 {TIP 478: singleton} -setup { - oo::class create parent -} -body { - oo::singleton create xyz { - superclass parent - } - set x [xyz new] - set y [xyz new] - set z [xyz new] - set code [catch {$x destroy} msg] - set p [xyz new] - lappend code [catch {rename $x ""}] - set q [xyz new] - string map [list $x ONE $q TWO] [list {*}$code $x $y $z $p $q [xyz new]] -} -cleanup { - parent destroy -} -result {1 0 ONE ONE ONE ONE TWO TWO} -test ooUtil-4.2 {TIP 478: singleton errors} -setup { - oo::class create parent -} -body { - oo::singleton create xyz { - superclass parent - } - [xyz new] destroy -} -returnCodes error -cleanup { - parent destroy -} -result {may not destroy a singleton object} -test ooUtil-4.3 {TIP 478: singleton errors} -setup { - oo::class create parent -} -body { - oo::singleton create xyz { - superclass parent - } - oo::copy [xyz new] -} -returnCodes error -cleanup { - parent destroy -} -result {may not clone a singleton object} - - -test ooUtil-5.1 {TIP 478: abstract} -setup { - oo::class create parent -} -body { - oo::abstract create xyz { - superclass parent - method foo {} {return 123} - } - oo::class create pqr { - superclass xyz - method bar {} {return 456} - } - set codes [list [catch {xyz new}] [catch {xyz create x}] [catch {xyz createWithNamespace x y}]] - set x [pqr new] - set y [pqr create ::y] - lappend codes [$x foo] [$x bar] $y -} -cleanup { - parent destroy -} -result {1 1 1 123 456 ::y} - -test ooUtil-6.1 {TIP 478: classvariable} -setup { - oo::class create parent -} -body { - oo::class create xyz { - superclass parent - initialise { - variable x 1 y 2 - } - method a {} { - classvariable x - incr x - } - method b {} { - classvariable y - incr y - } - method c {} { - classvariable x y - list $x $y - } - } - set p [xyz new] - set q [xyz new] - set result [list [$p c] [$q c]] - $p a - $q b - lappend result [[xyz new] c] -} -cleanup { - parent destroy -} -result {{1 2} {1 2} {2 3}} -test ooUtil-6.2 {TIP 478: classvariable error case} -setup { - oo::class create parent -} -body { - oo::class create xyz { - superclass parent - method a {} { - classvariable x(1) - incr x(1) - } - } - set p [xyz new] - set q [xyz new] - list [$p a] [$q a] -} -returnCodes error -cleanup { - parent destroy -} -result {bad variable name "x(1)": can't create a scalar variable that looks like an array element} -test ooUtil-6.3 {TIP 478: classvariable error case} -setup { - oo::class create parent -} -body { - oo::class create xyz { - superclass parent - method a {} { - classvariable ::x - incr x - } - } - set p [xyz new] - set q [xyz new] - list [$p a] [$q a] -} -returnCodes error -cleanup { - parent destroy -} -result {bad variable name "::x": can't create a local variable with a namespace separator in it} - -test ooUtil-7.1 {TIP 478: link calling pattern} -setup { - oo::class create parent -} -body { - oo::class create cls { - superclass parent - method foo {} {return "in foo of [self]"} - method Bar {} {return "in bar of [self]"} - method Grill {} {return "in grill of [self]"} - export eval - constructor {} { - link foo - link {bar Bar} {grill Grill} - } - } - cls create o - o eval {list [foo] [bar] [grill]} -} -cleanup { - parent destroy -} -result {{in foo of ::o} {in bar of ::o} {in grill of ::o}} -test ooUtil-7.2 {TIP 478: link removed when [my] disappears} -setup { - oo::class create parent -} -body { - oo::class create cls { - superclass parent - method foo {} {return "in foo of [self]"} - constructor {cmd} { - link [list ::$cmd foo] - } - } - cls create o pqr - list [o foo] [pqr] [rename [info object namespace o]::my {}] [catch pqr msg] $msg -} -cleanup { - parent destroy -} -result {{in foo of ::o} {in foo of ::o} {} 1 {invalid command name "pqr"}} - -# Tests a very weird combination of things (with a key problem locus in -# MixinClassDelegates) that TIP 567 fixes -test ooUtil-8.1 {TIP 567: call oo::define twice from metaclass constructor} -setup { - oo::class create parent -} -body { - ::oo::class create A { - superclass parent - } - ::oo::class create B { - superclass ::oo::class parent - constructor {{definitionScript ""}} { - next $definitionScript - next {superclass ::A} - } - } - B create C { - superclass A - } - C create instance -} -cleanup { - parent destroy -} -result ::instance - -# Tests that verify issues detected with the tcllib version of the code -test ooUtil-tcllib-ticket-b3577ed586 {test scoping of delegation in oo::class.Delegate } -setup { - oo::class create animal {} - namespace eval ::ooutiltest { - oo::class create pet { superclass animal } - } -} -body { - namespace eval ::ooutiltest { - oo::class create dog { superclass pet } - } -} -cleanup { - namespace delete ooutiltest - rename animal {} -} -result {::ooutiltest::dog} -test ooUtil-tcllib-ticket-fe7a0e0a3a {classmethod must not interfere with constructor signatures} -setup { - oo::class create TestClass { - superclass oo::class - self method create {name ignore body} { - next $name $body - } - } -} -body { - TestClass create okay {} {} -} -cleanup { - rename TestClass {} -} -result {::okay} - -cleanupTests -return - -# Local Variables: -# fill-column: 78 -# mode: tcl -# End: |