Split out TIP 478 tests into their own file.

2 files changed, 337 insertions, 264 deletions

diff --git a/tests/oo.test b/tests/oo.test
index 1e694c1..7e0f12e 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -4845,270 +4845,6 @@ test oo-40.3 {TIP 500: private and unexport} -setup {
 } -cleanup {
     cls destroy
 } -result {{} {} foo {} foo {}}
-
-test oo-41.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 oo-41.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 oo-41.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 oo-41.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 oo-41.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 {::ActiveRecord called with arguments: 1 2 3}
-test oo-41.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 oo-42.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 oo-42.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 oo-42.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 oo-42.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 oo-42.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 oo-42.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 oo-43.1 {TIP 478: class initialisation} -setup {
-    oo::class create parent
-} -body {
-    oo::class create ::cls {
-	superclass parent
-	initialise {
-	    proc foobar {} {return ok}
-	}
-	method calls {} {
-	    list [catch foobar msg] $msg \
-		[namespace eval [info object namespace [self class]] foobar]
-	}
-    }
-    [cls new] calls
-} -cleanup {
-    parent destroy
-} -result {1 {invalid command name "foobar"} ok}
-
-test oo-44.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 $msg [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 {object "ONE" has no visible methods} 0 ONE ONE ONE ONE TWO TWO}
-
-test oo-45.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}
 
 cleanupTests
 return
diff --git a/tests/ooUtil.test b/tests/ooUtil.test
new file mode 100644
index 0000000..4e4dba1
--- /dev/null
+++ b/tests/ooUtil.test
@@ -0,0 +1,337 @@
+# 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 (c) 2014-2016 Andreas Kupries
+# Copyright (c) 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 TclOO 1.0.3
+package require tcltest 2
+if {"::tcltest" in [namespace children]} {
+    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 {::ActiveRecord 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-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-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 $msg [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 {object "ONE" has no visible methods} 0 ONE ONE ONE ONE TWO TWO}
+
+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}
+
+# 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: