Split out TIP 478 tests into their own file.

1 files changed, 337 insertions, 0 deletions

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: