summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2006-10-21 01:11:51 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2006-10-21 01:11:51 (GMT)
commit03e4fa2ab0e4fedb8c930a2bbb9611eb4e3b445f (patch)
treed66ad5f9a908bea4353dc6aa88e27fe0e9f7625c
parent582793d3f29718a4ea0272d4b19aa2cb6d9dc04c (diff)
downloadtcl-03e4fa2ab0e4fedb8c930a2bbb9611eb4e3b445f.zip
tcl-03e4fa2ab0e4fedb8c930a2bbb9611eb4e3b445f.tar.gz
tcl-03e4fa2ab0e4fedb8c930a2bbb9611eb4e3b445f.tar.bz2
Fix problems identified by AKu, and finish moving [oo::copy] to where it belongs
Diffstat
-rw-r--r--generic/tcl.h4
-rw-r--r--generic/tclInt.h22
-rw-r--r--generic/tclOO.c93
-rw-r--r--generic/tclOOCall.c6
-rw-r--r--generic/tclOODefineCmds.c147
-rw-r--r--tests/oo.test2486
6 files changed, 1385 insertions, 1373 deletions
diff --git a/generic/tcl.h b/generic/tcl.h
index 9593f29..6ad6118 100644
--- a/generic/tcl.h
+++ b/generic/tcl.h
@@ -13,7 +13,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tcl.h,v 1.210.2.6 2006/10/19 21:06:25 dkf Exp $
+ * RCS: @(#) $Id: tcl.h,v 1.210.2.7 2006/10/21 01:11:51 dkf Exp $
*/
#ifndef _TCL
@@ -2421,7 +2421,7 @@ typedef struct {
* without breaking binary compatability.
*/
-#define TCL_OO_METHOD_VERSION_CURRENT 1
+#define TCL_OO_METADATA_VERSION_CURRENT 1
#ifndef TCL_NO_DEPRECATED
/*
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 2d12657..619c83c 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -12,7 +12,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclInt.h,v 1.267.2.11 2006/09/25 22:30:06 dkf Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.267.2.12 2006/10/21 01:11:51 dkf Exp $
*/
#ifndef _TCLINT
@@ -112,7 +112,7 @@ typedef int ptrdiff_t;
#define NO_WIDE_TYPE
#endif
-struct Foundation; // Forward decl for OO support
+struct Foundation; /* Forward decl for OO support. */
/*
* The following procedures allow namespaces to be customized to support
@@ -1524,7 +1524,16 @@ typedef struct Interp {
* NULL), takes precedence over a posix error
* code returned by a channel operation. */
- struct Foundation *ooFoundation; // OO support
+ /*
+ * TIP #257 - Object Orientation Programming Infrastructure.
+ */
+
+ struct Foundation *ooFoundation;
+ /* Pointer to the structure that manages the
+ * core of the object-orientation support.
+ * The actual definition of this structure is
+ * in tclOO.h, so this is just an opaque
+ * pointer if that file isn't #included. */
/*
* Statistical information about the bytecode compiler and interpreter's
@@ -2529,9 +2538,6 @@ MODULE_SCOPE int TclOODefineObjCmd(ClientData clientData,
MODULE_SCOPE int TclOODefineConstructorObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const *objv);
-MODULE_SCOPE int TclOODefineCopyObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const *objv);
MODULE_SCOPE int TclOODefineDestructorObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const *objv);
@@ -3096,9 +3102,11 @@ MODULE_SCOPE void TclBNInitBignumFromWideUInt(mp_int* bignum,
#define TclIsNaN(d) ((d) != (d))
#endif
-// MOVE ME TO tclInt.decls
+// vvvvvvvvvvvvvvvvvvvvvv MOVE TO TCLINT.DECLS vvvvvvvvvvvvvvvvvvvvvv
void TclSetNsPath(Namespace *nsPtr, int pathLength,
Tcl_Namespace *pathAry[]);
+Tcl_Object TclOOGetDefineCmdContext(Tcl_Interp *interp);
+// ^^^^^^^^^^^^^^^^^^^^^^ MOVE TO TCLINT.DECLS ^^^^^^^^^^^^^^^^^^^^^^
#include "tclPort.h"
#include "tclIntDecls.h"
diff --git a/generic/tclOO.c b/generic/tclOO.c
index 18fb337..cdc2ab9 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -8,7 +8,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclOO.c,v 1.1.2.62 2006/10/19 21:06:25 dkf Exp $
+ * RCS: @(#) $Id: tclOO.c,v 1.1.2.63 2006/10/21 01:11:51 dkf Exp $
*/
#include "tclInt.h"
@@ -24,7 +24,6 @@ static const struct {
int flag;
} defineCmds[] = {
{"constructor", TclOODefineConstructorObjCmd, 0},
- {"copy", TclOODefineCopyObjCmd, 0},
{"destructor", TclOODefineDestructorObjCmd, 0},
{"export", TclOODefineExportObjCmd, 0},
{"self.export", TclOODefineExportObjCmd, 1},
@@ -76,6 +75,9 @@ static void ObjectDeletedTrace(ClientData clientData,
const char *newName, int flags);
static void ReleaseClassContents(Tcl_Interp *interp,Object *oPtr);
+static int CopyObjectCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const *objv);
static int PublicObjectCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const *objv);
@@ -192,6 +194,7 @@ TclOOInit(
NULL);
Tcl_CreateObjCommand(interp, "::oo::define", TclOODefineObjCmd, NULL,
NULL);
+ Tcl_CreateObjCommand(interp, "::oo::copy", CopyObjectCmd, NULL, NULL);
Tcl_DStringInit(&buffer);
for (i=0 ; defineCmds[i].name ; i++) {
Tcl_DStringAppend(&buffer, "::oo::define::", 14);
@@ -1029,11 +1032,12 @@ Tcl_NewObjectInstance(
/*
* Is a class, so attach a class structure. Note that the AllocClass
* function splices the structure into the object, so we don't have
- * to.
+ * to. Once that's done, we need to repatch the object to have the
+ * right class since AllocClass interferes with that.
*/
AllocClass(interp, oPtr);
- oPtr->selfCls = (Class *) cls; // Repatch
+ oPtr->selfCls = (Class *) cls;
}
if (objc >= 0) {
@@ -2872,13 +2876,13 @@ SelfObjCmd(
contextPtr->callChain[contextPtr->filterLength].mPtr;
Tcl_Obj *cmdName;
- // TODO: should indicate who has the filter registration, not the
- // first non-filter after the filter!
+ /* TODO: should indicate who has the filter registration, not the
+ * first non-filter after the filter! */
TclNewObj(cmdName);
Tcl_GetCommandFullName(interp, contextPtr->oPtr->command,
cmdName);
Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), cmdName);
- // TODO: Add what type of filter this is
+ /* TODO: Add what type of filter this is */
Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
mPtr->namePtr);
return TCL_OK;
@@ -3004,6 +3008,81 @@ SelfObjCmd(
/*
* ----------------------------------------------------------------------
*
+ * CopyObjectCmd --
+ *
+ * Implementation of the [oo::copy] command, which clones an object (but
+ * not its namespace). Note that no constructors are called during this
+ * process.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+CopyObjectCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Tcl_Object oPtr, o2Ptr;
+
+ if (objc < 2 || objc > 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "sourceName ?targetName?");
+ return TCL_ERROR;
+ }
+
+ oPtr = Tcl_GetObjectFromObj(interp, objv[1]);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Create a cloned object of the correct class. Note that constructors are
+ * not called. Also note that we must resolve the object name ourselves
+ * because we do not want to create the object in the current namespace,
+ * but rather in the context of the namespace of the caller of the overall
+ * [oo::define] command.
+ */
+
+ if (objc == 2) {
+ o2Ptr = Tcl_CopyObjectInstance(interp, oPtr, NULL);
+ } else {
+ char *name;
+ Tcl_DString buffer;
+
+ name = TclGetString(objv[2]);
+ Tcl_DStringInit(&buffer);
+ if (name[0]!=':' || name[1]!=':') {
+ Interp *iPtr = (Interp *) interp;
+
+ if (iPtr->varFramePtr != NULL) {
+ Tcl_DStringAppend(&buffer,
+ iPtr->varFramePtr->nsPtr->fullName, -1);
+ }
+ Tcl_DStringAppend(&buffer, "::", 2);
+ Tcl_DStringAppend(&buffer, name, -1);
+ name = Tcl_DStringValue(&buffer);
+ }
+ o2Ptr = Tcl_CopyObjectInstance(interp, oPtr, name);
+ Tcl_DStringFree(&buffer);
+ }
+
+ if (o2Ptr == NULL) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Return the name of the cloned object.
+ */
+
+ Tcl_GetCommandFullName(interp, Tcl_GetObjectCommand(o2Ptr),
+ Tcl_GetObjResult(interp));
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
* Tcl_GetObjectFromObj --
*
* Utility function to get an object from a Tcl_Obj containing its name.
diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c
index 0361e43..2a085f1 100644
--- a/generic/tclOOCall.c
+++ b/generic/tclOOCall.c
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclOOCall.c,v 1.1.2.2 2006/10/11 02:01:16 dgp Exp $
+ * RCS: @(#) $Id: tclOOCall.c,v 1.1.2.3 2006/10/21 01:11:51 dkf Exp $
*/
#include "tclInt.h"
@@ -331,7 +331,7 @@ AddClassMethodNames(
Class *mixinPtr;
int i;
- // TODO: Beware of infinite loops!
+ /* TODO: Beware of infinite loops! */
FOREACH(mixinPtr, clsPtr->mixins) {
AddClassMethodNames(mixinPtr, publicOnly, namesPtr);
}
@@ -621,7 +621,7 @@ AddSimpleChainToCallContext(
contextPtr, doneFilters, flags);
}
FOREACH(superPtr, oPtr->selfCls->classHierarchy) {
- int j=i;// HACK: save index so we can nest FOREACHes
+ int j=i; /* HACK: save index so can nest FOREACHes. */
FOREACH(mixinPtr, superPtr->mixins) {
AddSimpleClassChainToCallContext(mixinPtr, methodNameObj,
contextPtr, doneFilters, flags);
diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c
index 39efe18..f6a4324 100644
--- a/generic/tclOODefineCmds.c
+++ b/generic/tclOODefineCmds.c
@@ -9,13 +9,11 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclOODefineCmds.c,v 1.1.2.26 2006/10/15 23:14:29 dkf Exp $
+ * RCS: @(#) $Id: tclOODefineCmds.c,v 1.1.2.27 2006/10/21 01:11:52 dkf Exp $
*/
#include "tclInt.h"
#include "tclOO.h"
-
-static Object * GetDefineCmdContext(Tcl_Interp *interp);
int
TclOODefineObjCmd(
@@ -130,8 +128,8 @@ TclOODefineObjCmd(
return result;
}
-static Object *
-GetDefineCmdContext(
+Tcl_Object
+TclOOGetDefineCmdContext(
Tcl_Interp *interp)
{
Interp *iPtr = (Interp *) interp;
@@ -142,7 +140,7 @@ GetDefineCmdContext(
" the context of the ::oo::define command", NULL);
return NULL;
}
- return (Object *) iPtr->framePtr->ooContextPtr;
+ return (Tcl_Object) iPtr->framePtr->ooContextPtr;
}
int
@@ -166,7 +164,7 @@ TclOODefineConstructorObjCmd(
* modify.
*/
- oPtr = GetDefineCmdContext(interp);
+ oPtr = (Object *) TclOOGetDefineCmdContext(interp);
if (oPtr == NULL) {
return TCL_ERROR;
}
@@ -213,70 +211,6 @@ TclOODefineConstructorObjCmd(
}
int
-TclOODefineCopyObjCmd(
- ClientData clientData,
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const *objv)
-{
- Tcl_Object oPtr, o2Ptr;
-
- if (objc > 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "?targetName?");
- return TCL_ERROR;
- }
-
- oPtr = (Tcl_Object) GetDefineCmdContext(interp);
- if (oPtr == NULL) {
- return TCL_ERROR;
- }
-
- /*
- * Create a cloned object of the correct class. Note that constructors are
- * not called. Also note that we must resolve the object name ourselves
- * because we do not want to create the object in the current namespace,
- * but rather in the context of the namespace of the caller of the overall
- * [oo::define] command.
- */
-
- if (objc == 1) {
- o2Ptr = Tcl_CopyObjectInstance(interp, oPtr, NULL);
- } else {
- char *name;
- Tcl_DString buffer;
-
- name = TclGetString(objv[1]);
- Tcl_DStringInit(&buffer);
- if (name[0]!=':' || name[1]!=':') {
- Interp *iPtr = (Interp *) interp;
- CallFrame *callerFramePtr = iPtr->varFramePtr->callerVarPtr;
-
- if (callerFramePtr != NULL) {
- Tcl_DStringAppend(&buffer,
- callerFramePtr->nsPtr->fullName, -1);
- }
- Tcl_DStringAppend(&buffer, "::", 2);
- Tcl_DStringAppend(&buffer, name, -1);
- name = Tcl_DStringValue(&buffer);
- }
- o2Ptr = Tcl_CopyObjectInstance(interp, oPtr, name);
- Tcl_DStringFree(&buffer);
- }
-
- if (o2Ptr == NULL) {
- return TCL_ERROR;
- }
-
- /*
- * Return the name of the cloned object.
- */
-
- Tcl_GetCommandFullName(interp, Tcl_GetObjectCommand(o2Ptr),
- Tcl_GetObjResult(interp));
- return TCL_OK;
-}
-
-int
TclOODefineDestructorObjCmd(
ClientData clientData,
Tcl_Interp *interp,
@@ -292,7 +226,7 @@ TclOODefineDestructorObjCmd(
return TCL_ERROR;
}
- oPtr = GetDefineCmdContext(interp);
+ oPtr = (Object *) TclOOGetDefineCmdContext(interp);
if (oPtr == NULL) {
return TCL_ERROR;
}
@@ -357,7 +291,7 @@ TclOODefineExportObjCmd(
return TCL_ERROR;
}
- oPtr = GetDefineCmdContext(interp);
+ oPtr = (Object *) TclOOGetDefineCmdContext(interp);
if (oPtr == NULL) {
return TCL_ERROR;
}
@@ -401,7 +335,7 @@ TclOODefineFilterObjCmd(
Object *oPtr;
int i;
- oPtr = GetDefineCmdContext(interp);
+ oPtr = (Object *) TclOOGetDefineCmdContext(interp);
if (oPtr == NULL) {
return TCL_ERROR;
}
@@ -417,12 +351,18 @@ TclOODefineFilterObjCmd(
}
if (objc == 1) {
- // deleting filters
+ /*
+ * No list of filters was supplied, so we're deleting filters.
+ */
+
ckfree((char *) oPtr->classPtr->filters.list);
oPtr->classPtr->filters.list = NULL;
oPtr->classPtr->filters.num = 0;
} else {
- // creating filters
+ /*
+ * We've got a list of filters, so we're creating filters.
+ */
+
Tcl_Obj **filters;
if (oPtr->classPtr->filters.num == 0) {
@@ -439,7 +379,11 @@ TclOODefineFilterObjCmd(
oPtr->classPtr->filters.list = filters;
oPtr->classPtr->filters.num = objc-1;
}
- // may be many objects affected
+
+ /*
+ * There may be many objects affected, so bump the global epoch.
+ */
+
((Interp *)interp)->ooFoundation->epoch++;
} else {
if (oPtr->filters.num) {
@@ -450,12 +394,18 @@ TclOODefineFilterObjCmd(
}
}
if (objc == 1) {
- // deleting filters
+ /*
+ * No list of filters was supplied, so we're deleting filters.
+ */
+
ckfree((char *) oPtr->filters.list);
oPtr->filters.list = NULL;
oPtr->filters.num = 0;
} else {
- // creating filters
+ /*
+ * We've got a list of filters, so we're creating filters.
+ */
+
Tcl_Obj **filters;
if (oPtr->filters.num == 0) {
@@ -471,7 +421,7 @@ TclOODefineFilterObjCmd(
oPtr->filters.list = filters;
oPtr->filters.num = objc-1;
}
- oPtr->epoch++; // per-object
+ oPtr->epoch++; /* Only this object can be affected. */
}
return TCL_OK;
}
@@ -494,7 +444,7 @@ TclOODefineForwardObjCmd(
return TCL_ERROR;
}
- oPtr = GetDefineCmdContext(interp);
+ oPtr = (Object *) TclOOGetDefineCmdContext(interp);
if (oPtr == NULL) {
return TCL_ERROR;
}
@@ -536,7 +486,7 @@ TclOODefineMethodObjCmd(
return TCL_ERROR;
}
- oPtr = GetDefineCmdContext(interp);
+ oPtr = (Object *) TclOOGetDefineCmdContext(interp);
if (oPtr == NULL) {
return TCL_ERROR;
}
@@ -593,7 +543,7 @@ TclOODefineMixinObjCmd(
Tcl_Obj *const *objv)
{
int isSelfMixin = (clientData != NULL);
- Object *oPtr = GetDefineCmdContext(interp);
+ Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
Class *mixinPtr;
int i;
@@ -694,31 +644,6 @@ TclOODefineMixinObjCmd(
return TCL_OK;
}
-#ifdef SUPPORT_OO_PARAMETERS
-// Not sure whether we want to retain this in the core oo system since it is
-// easy to add "after market".
-int
-TclOODefineParameterObjCmd(
- ClientData clientData,
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const *objv)
-{
- Object *oPtr = GetDefineCmdContext(interp);
-
- if (oPtr == NULL) {
- return TCL_ERROR;
- }
-
- /*
- * Must nail down the semantics of this!
- */
-
- Tcl_AppendResult(interp, "TODO: not yet finished", NULL);
- return TCL_ERROR;
-}
-#endif
-
int
TclOODefineSelfClassObjCmd(
ClientData clientData,
@@ -733,7 +658,7 @@ TclOODefineSelfClassObjCmd(
* Parse the context to get the object to operate on.
*/
- oPtr = GetDefineCmdContext(interp);
+ oPtr = (Object *) TclOOGetDefineCmdContext(interp);
if (oPtr == NULL) {
return TCL_ERROR;
}
@@ -818,7 +743,7 @@ TclOODefineSuperclassObjCmd(
* Get the class to operate on.
*/
- oPtr = GetDefineCmdContext(interp);
+ oPtr = (Object *) TclOOGetDefineCmdContext(interp);
if (oPtr == NULL) {
return TCL_ERROR;
}
@@ -911,7 +836,7 @@ TclOODefineUnexportObjCmd(
return TCL_ERROR;
}
- oPtr = GetDefineCmdContext(interp);
+ oPtr = (Object *) TclOOGetDefineCmdContext(interp);
if (oPtr == NULL) {
return TCL_ERROR;
}
diff --git a/tests/oo.test b/tests/oo.test
index 10b95d0..5d4a655 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -1,1243 +1,1243 @@
-# This file contains a collection of tests for Tcl's built-in object system.
-# Sourcing this file into Tcl runs the tests and generates output for errors.
-# No output means no errors were found.
-#
-# Copyright (c) 2006 Donal K. Fellows
-#
-# See the file "license.terms" for information on usage and redistribution of
-# this file, and for a DISCLAIMER OF ALL WARRANTIES.
-#
-# RCS: @(#) $Id: oo.test,v 1.1.2.38 2006/10/19 21:04:00 dkf Exp $
-
-if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest 2
- namespace import -force ::tcltest::*
-}
-
-testConstraint memory [llength [info commands memory]]
-
-test oo-0.1 {basic test of OO's ability to clean up its initial state} {
- interp create t
- interp delete t
-} {}
-test oo-0.2 {basic test of OO's ability to clean up its initial state} {
- interp eval [interp create] { namespace delete :: }
-} {}
-test oo-0.3 {basic test of OO's ability to clean up its initial state} -setup {
- proc getbytes {} {
- set lines [split [memory info] "\n"]
- lindex $lines 3 3
- }
-} -constraints memory -body {
- set end [getbytes]
- for {set i 0} {$i < 5} {incr i} {
- [oo::object new] destroy
- set tmp $end
- set end [getbytes]
- }
- set leakedBytes [expr {$end - $tmp}]
-} -cleanup {
- rename getbytes {}
-} -result 0
-test oo-0.4 {basic test of OO's ability to clean up its initial state} -setup {
- proc getbytes {} {
- set lines [split [memory info] "\n"]
- lindex $lines 3 3
- }
-} -constraints memory -body {
- set end [getbytes]
- for {set i 0} {$i < 5} {incr i} {
- oo::class create foo
- foo new
- foo destroy
- set tmp $end
- set end [getbytes]
- }
- set leakedBytes [expr {$end - $tmp}]
-} -cleanup {
- rename getbytes {}
-} -result 0
-
-test oo-1.1 {basic test of OO functionality: no classes} {
- set result {}
- lappend result [oo::object create foo]
- lappend result [oo::define foo {
- method bar args {
- global result
- lappend result {expand}$args
- return [llength $args]
- }
- }]
- lappend result [foo bar a b c]
- lappend result [foo destroy] [info commands foo]
-} {::foo {} a b c 3 {} {}}
-test oo-1.2 {basic test of OO functionality: no classes} -body {
- oo::define oo::object method missingArgs
-} -returnCodes 1 -result "wrong # args: should be \"oo::define oo::object method name args body\""
-test oo-1.3 {basic test of OO functionality: no classes} {
- catch {oo::define oo::object method missingArgs}
- set errorInfo
-} "wrong # args: should be \"oo::define oo::object method name args body\"
- while executing
-\"oo::define oo::object method missingArgs\""
-test oo-1.4 {basic test of OO functionality} -body {
- oo::object create {}
-} -returnCodes 1 -result {object name must not be empty}
-test oo-1.5 {basic test of OO functionality} -body {
- oo::object doesnotexist
-} -returnCodes 1 -result {unknown method "doesnotexist": must be create, destroy or new}
-test oo-1.6 {basic test of OO functionality} -setup {
- oo::object create aninstance
-} -body {
- oo::define aninstance unexport destroy
- aninstance doesnotexist
-} -cleanup {
- rename aninstance {}
-} -returnCodes 1 -result {object "::aninstance" has no visible methods}
-
-test oo-2.1 {basic test of OO functionality: constructor} -setup {
- # This is a bit complex because it needs to run in a sub-interp as
- # we're modifying the root object class's constructor
- interp create subinterp
-} -body {
- subinterp eval {
- oo::define oo::object constructor {} {
- lappend ::result [info level 0]
- }
- lappend result 1
- lappend result 2 [oo::object create foo]
- }
-} -cleanup {
- interp delete subinterp
-} -result {1 {oo::object create foo} 2 ::foo}
-test oo-2.2 {basic test of OO functionality: constructor} {
- oo::class create testClass {
- constructor {} {
- global result
- lappend result "[self]->construct"
- }
- method bar {} {
- global result
- lappend result "[self]->bar"
- }
- }
- set result {}
- [testClass create foo] bar
- testClass destroy
- return $result
-} {::foo->construct ::foo->bar}
-
-test oo-3.1 {basic test of OO functionality: destructor} -setup {
- # This is a bit complex because it needs to run in a sub-interp as
- # we're modifying the root object class's constructor
- interp create subinterp
-} -body {
- subinterp eval {
- oo::define oo::object destructor {
- lappend ::result died
- }
- lappend result 1 [oo::object create foo]
- lappend result 2 [rename foo {}]
- oo::define oo::object destructor {}
- return $result
- }
-} -cleanup {
- interp delete subinterp
-} -result {1 ::foo died 2 {}}
-test oo-3.2 {basic test of OO functionality: destructor} -setup {
- # This is a bit complex because it needs to run in a sub-interp as
- # we're modifying the root object class's constructor
- interp create subinterp
-} -body {
- subinterp eval {
- oo::define oo::object destructor {
- lappend ::result died
- }
- lappend result 1 [oo::object create foo]
- lappend result 2 [rename foo {}]
- }
-} -cleanup {
- interp delete subinterp
-} -result {1 ::foo died 2 {}}
-
-test oo-4.1 {basic test of OO functionality: export} {
- set o [oo::object new]
- set result {}
- oo::define $o method Foo {} {lappend ::result Foo; return}
- lappend result [catch {$o Foo} msg] $msg
- oo::define $o export Foo
- lappend result [$o Foo] [$o destroy]
-} {1 {unknown method "Foo": must be destroy} Foo {} {}}
-test oo-4.2 {basic test of OO functionality: unexport} {
- set o [oo::object new]
- set result {}
- oo::define $o method foo {} {lappend ::result foo; return}
- lappend result [$o foo]
- oo::define $o unexport foo
- lappend result [catch {$o foo} msg] $msg [$o destroy]
-} {foo {} 1 {unknown method "foo": must be destroy} {}}
-
-test oo-5.1 {OO: manipulation of classes as objects} -setup {
- set obj [oo::object new]
-} -body {
- oo::define oo::object self.method foo {} { return "in object" }
- catch {$obj foo} result
- list [catch {$obj foo} result] $result [oo::object foo]
-} -cleanup {
- oo::define oo::object self.method foo {} {}
- $obj destroy
-} -result {1 {unknown method "foo": must be destroy} {in object}}
-
-test oo-6.1 {OO: forward} {
- oo::object create foo
- oo::define foo {
- forward a lappend
- forward b lappend result
- }
- set result {}
- foo a result 1
- foo b 2
- foo destroy
- return $result
-} {1 2}
-
-test oo-7.1 {OO: inheritance 101} -setup {
- oo::class create superClass
- oo::class create subClass
- subClass create instance
-} -body {
- oo::define superClass method doit x {lappend ::result $x}
- oo::define subClass superclass superClass
- set result [list [catch {subClass doit bad} msg] $msg]
- instance doit ok
- return $result
-} -cleanup {
- subClass destroy
- superClass destroy
-} -result {1 {unknown method "doit": must be create, destroy or new} ok}
-test oo-7.2 {OO: inheritance 101} -setup {
- oo::class create superClass
- oo::class create subClass
- subClass create instance
-} -body {
- oo::define superClass method doit x {lappend ::result |$x|}
- oo::define subClass superclass superClass
- oo::define instance method doit x {lappend ::result =$x=; next [incr x]}
- set result {}
- instance doit 1
- return $result
-} -cleanup {
- subClass destroy
- superClass destroy
-} -result {=1= |2|}
-test oo-7.3 {OO: inheritance 101} -setup {
- oo::class create superClass
- oo::class create subClass
- subClass create instance
-} -body {
- oo::define superClass method doit x {lappend ::result |$x|}
- oo::define subClass {
- superclass superClass
- method doit x {lappend ::result -$x-; next [incr x]}
- }
- oo::define instance method doit x {lappend ::result =$x=; next [incr x]}
- set result {}
- instance doit 1
- return $result
-} -cleanup {
- subClass destroy
- superClass destroy
-} -result {=1= -2- |3|}
-test oo-7.4 {OO: inheritance from oo::class} -body {
- oo::class create meta
- oo::define meta {
- superclass oo::class
- self.unexport create new
- self.method make {x {definitions {}}} {
- if {![string match ::* $x]} {
- set ns [uplevel 1 {::namespace current}]
- set x ${ns}::$x
- }
- set o [my create $x]
- lappend ::result "made $o"
- oo::define $o $definitions
- return $o
- }
- }
- set result [list [catch {meta create foo} msg] $msg]
- lappend result [meta make classinstance {
- lappend ::result "in definition script in [namespace current]"
- }]
- lappend result [classinstance create instance]
-} -cleanup {
- catch {classinstance destroy}
- catch {meta destroy}
-} -result {1 {unknown method "create": must be destroy or make} {made ::classinstance} {in definition script in ::oo::define} ::classinstance ::instance}
-test oo-7.5 {OO: inheritance from oo::class in the secondary chain} -body {
- oo::class create other
- oo::class create meta
- oo::define meta {
- superclass other oo::class
- self.unexport create new
- self.method make {x {definitions {}}} {
- if {![string match ::* $x]} {
- set ns [uplevel 1 {::namespace current}]
- set x ${ns}::$x
- }
- set o [my create $x]
- lappend ::result "made $o"
- oo::define $o $definitions
- return $o
- }
- }
- set result [list [catch {meta create foo} msg] $msg]
- lappend result [meta make classinstance {
- lappend ::result "in definition script in [namespace current]"
- }]
- lappend result [classinstance create instance]
-} -cleanup {
- catch {classinstance destroy}
- catch {meta destroy}
- catch {other destroy}
-} -result {1 {unknown method "create": must be destroy or make} {made ::classinstance} {in definition script in ::oo::define} ::classinstance ::instance}
-test oo-7.6 {OO: inheritance 101 - overridden methods should be oblivious} -setup {
- oo::class create Aclass
- oo::class create Bclass
- Bclass create Binstance
-} -body {
- oo::define Aclass {
- method incr {var step} {
- upvar 1 $var v
- ::incr v $step
- }
- }
- oo::define Bclass {
- superclass Aclass
- method incr {var {step 1}} {
- global result
- lappend result $var $step
- set r [next $var $step]
- lappend result returning:$r
- return $r
- }
- }
- set result {}
- set x 10
- lappend result x=$x
- lappend result [Binstance incr x]
- lappend result x=$x
-} -result {x=10 x 1 returning:11 11 x=11} -cleanup {
- Aclass destroy
-}
-test oo-7.7 {OO: inheritance and errorInfo} -setup {
- oo::class create A
- oo::class create B
- B create c
-} -body {
- oo::define A method foo {} {error foo!}
- oo::define B {
- superclass A
- method foo {} { next }
- }
- oo::define c method foo {} { next }
- catch {c ?} msg
- set result [list $msg]
- catch {c foo} msg
- lappend result $msg $errorInfo
-} -cleanup {
- A destroy
-} -result {{unknown method "?": must be destroy or foo} foo! {foo!
- while executing
-"error foo!"
- (class "::A" method "foo" line 1)
- invoked from within
-"next "
- (class "::B" method "foo" line 1)
- invoked from within
-"next "
- (object "::c" method "foo" line 1)
- invoked from within
-"c foo"}}
-
-test oo-8.1 {OO: global must work in methods} {
- oo::object create foo
- oo::define foo method bar x {global result; lappend result $x}
- set result {}
- foo bar this
- foo bar is
- lappend result a
- foo bar test
- foo destroy
- return $result
-} {this is a test}
-
-test oo-9.1 {OO: multiple inheritance} -setup {
- oo::class create A
- oo::class create B
- oo::class create C
- oo::class create D
- D create foo
-} -body {
- oo::define A method test {} {lappend ::result A; return ok}
- oo::define B {
- superclass A
- method test {} {lappend ::result B; next}
- }
- oo::define C {
- superclass A
- method test {} {lappend ::result C; next}
- }
- oo::define D {
- superclass B C
- method test {} {lappend ::result D; next}
- }
- set result {}
- lappend result [foo test]
-} -cleanup {
- D destroy
- C destroy
- B destroy
- A destroy
-} -result {D B C A ok}
-test oo-9.2 {OO: multiple inheritance} -setup {
- oo::class create A
- oo::class create B
- oo::class create C
- oo::class create D
- D create foo
-} -body {
- oo::define A method test {} {lappend ::result A; return ok}
- oo::define B {
- superclass A
- method test {} {lappend ::result B; next}
- }
- oo::define C {
- superclass A
- method test {} {lappend ::result C; next}
- }
- oo::define D {
- superclass B C
- method test {} {lappend ::result D; next}
- }
- set result {}
- lappend result [foo test]
-} -cleanup {
- A destroy
-} -result {D B C A ok}
-
-test oo-10.1 {OO: recursive invoke and modify} -setup {
- [oo::class create C] create O
-} -cleanup {
- C destroy
-} -body {
- oo::define C method foo x {
- lappend ::result $x
- if {$x} {
- [self object] foo [incr x -1]
- }
- }
- oo::define O method foo x {
- lappend ::result -$x-
- if {$x == 1} {
- # delete the method
- oo::define O method foo {} {}
- }
- next $x
- }
- set result {}
- O foo 2
- return $result
-} -result {-2- 2 -1- 1 0}
-
-test oo-11.1 {OO: cleanup} {
- oo::object create foo
- set result [list [catch {oo::object create foo} msg] $msg]
- lappend result [foo destroy] [oo::object create foo] [foo destroy]
-} {1 {can't create object "foo": command already exists with that name} {} ::foo {}}
-test oo-11.2 {OO: cleanup} {
- oo::class create bar
- bar create foo
- set result [list [catch {bar create foo} msg] $msg]
- lappend result [bar destroy] [oo::object create foo] [foo destroy]
-} {1 {can't create object "foo": command already exists with that name} {} ::foo {}}
-test oo-11.3 {OO: cleanup} {
- oo::class create bar0
- oo::class create bar
- oo::define bar superclass bar0
- bar create foo
- set result [list [catch {bar create foo} msg] $msg]
- lappend result [bar0 destroy] [oo::object create foo] [foo destroy]
-} {1 {can't create object "foo": command already exists with that name} {} ::foo {}}
-test oo-11.4 {OO: cleanup} {
- oo::class create bar0
- oo::class create bar1
- oo::define bar1 superclass bar0
- oo::class create bar2
- oo::define bar2 {
- superclass bar0
- destructor {lappend ::result destroyed}
- }
- oo::class create bar
- oo::define bar superclass bar1 bar2
- bar create foo
- set result [list [catch {bar create foo} msg] $msg]
- lappend result [bar0 destroy] [oo::object create foo] [foo destroy] \
- [oo::object create bar2] [bar2 destroy]
-} {1 {can't create object "foo": command already exists with that name} destroyed {} ::foo {} ::bar2 {}}
-
-test oo-12.1 {OO: filters} {
- oo::class create Aclass
- Aclass create Aobject
- oo::define Aclass {
- method concatenate args {
- global result
- lappend result {expand}$args
- join $args {}
- }
- method logFilter args {
- global result
- lappend result "calling [self object]->[self method] $args"
- set r [next {expand}$args]
- lappend result "result=$r"
- return $r
- }
- }
- oo::define Aobject filter logFilter
- set result {}
- lappend result [Aobject concatenate 1 2 3 4 5]
- Aclass destroy
- return $result
-} {{calling ::Aobject->logFilter 1 2 3 4 5} 1 2 3 4 5 result=12345 12345}
-test oo-12.2 {OO: filters} -setup {
- oo::class create Aclass
- Aclass create Aobject
-} -body {
- oo::define Aclass {
- method concatenate args {
- global result
- lappend result {expand}$args
- join $args {}
- }
- method logFilter args {
- global result
- lappend result "calling [self object]->[self method] $args"
- set r [next {expand}$args]
- lappend result "result=$r"
- return $r
- }
- }
- oo::define Aobject filter logFilter
- set result {}
- lappend result [Aobject concatenate 1 2 3 4 5] [Aobject destroy]
-} -cleanup {
- Aclass destroy
-} -result {{calling ::Aobject->logFilter 1 2 3 4 5} 1 2 3 4 5 result=12345 {calling ::Aobject->logFilter } result= 12345 {}}
-test oo-12.3 {OO: filters} -setup {
- oo::class create Aclass
- Aclass create Aobject
-} -body {
- oo::define Aclass {
- method concatenate args {
- global result
- lappend result {expand}$args
- join $args {}
- }
- method logFilter args {
- global result
- lappend result "calling [self object]->[self method] $args"
- set r [next {expand}$args]
- lappend result "result=$r"
- return $r
- }
- filter logFilter
- }
- set result {}
- lappend result [Aobject concatenate 1 2 3 4 5] [Aobject destroy]
-} -cleanup {
- Aclass destroy
-} -result {{calling ::Aobject->logFilter 1 2 3 4 5} 1 2 3 4 5 result=12345 {calling ::Aobject->logFilter } result= 12345 {}}
-test oo-12.4 {OO: filters} -setup {
- oo::class create Aclass
- Aclass create Aobject
-} -body {
- oo::define Aclass {
- method foo {} { return foo }
- method Bar {} { return 1 }
- method boo {} { if {[my Bar]} { next } { error forbidden } }
- filter boo
- }
- Aobject foo
-} -cleanup {
- Aclass destroy
-} -result foo
-test oo-12.5 {OO: filters} -setup {
- oo::class create Aclass
- Aclass create Aobject
-} -body {
- oo::define Aclass {
- method foo {} { return foo }
- method Bar {} { return [my Bar2] }
- method Bar2 {} { return 1 }
- method boo {} { if {[my Bar]} { next } { error forbidden } }
- filter boo
- }
- Aobject foo
-} -cleanup {
- Aclass destroy
-} -result foo
-test oo-12.6 {OO: filters} -setup {
- oo::class create Aclass
- Aclass create Aobject
-} -body {
- oo::define Aclass {
- method foo {} { return foo }
- method Bar {} { return [my Bar2] }
- method Bar2 {} { return [my Bar3] }
- method Bar3 {} { return 1 }
- method boo {} { if {[my Bar]} { next } { error forbidden } }
- filter boo
- }
- Aobject foo
-} -cleanup {
- Aclass destroy
-} -result foo
-test oo-12.7 {OO: filters} -setup {
- oo::class create Aclass
- Aclass create Aobject
-} -body {
- oo::define Aclass {
- method outerfoo {} { return [my InnerFoo] }
- method InnerFoo {} { return foo }
- method Bar {} { return [my Bar2] }
- method Bar2 {} { return [my Bar3] }
- method Bar3 {} { return 1 }
- method boo {} {
- lappend ::log [self target]
- if {[my Bar]} { next } else { error forbidden }
- }
- filter boo
- }
- set log {}
- list [Aobject outerfoo] $log
-} -cleanup {
- Aclass destroy
-} -result {foo {{::Aclass outerfoo} {::Aclass InnerFoo}}}
-
-test oo-13.1 {OO: changing an object's class} {
- oo::class create Aclass
- oo::define Aclass {method bar {} {lappend ::result "in A [self object]"}}
- oo::class create Bclass
- oo::define Bclass {method bar {} {lappend ::result "in B [self object]"}}
- set result [Aclass create foo]
- foo bar
- oo::define foo self.class Bclass
- foo bar
- Aclass destroy
- lappend result [info command foo]
- Bclass destroy
- return $result
-} {::foo {in A ::foo} {in B ::foo} foo}
-test oo-13.2 {OO: changing an object's class} -body {
- oo::object create foo
- oo::define foo self.class oo::class
-} -cleanup {
- foo destroy
-} -returnCodes 1 -result {may not change a non-class object into a class object}
-test oo-13.3 {OO: changing an object's class} -body {
- oo::class create foo
- oo::define foo self.class oo::object
-} -cleanup {
- foo destroy
-} -returnCodes 1 -result {may not change a class object into a non-class object}
-# todo: changing a class subtype (metaclass) to another class subtype
-
-test oo-14.1 {OO: mixins} {
- oo::class create Aclass
- oo::define Aclass method bar {} {lappend ::result "[self object] in bar"}
- oo::class create Bclass
- oo::define Bclass method boo {} {lappend ::result "[self object] in boo"}
- oo::define [Aclass create fooTest] mixin Bclass
- oo::define [Aclass create fooTest2] mixin Bclass
- set result [list [catch {fooTest ?} msg] $msg]
- fooTest bar
- fooTest boo
- fooTest2 bar
- fooTest2 boo
- oo::define fooTest2 mixin
- lappend result [Bclass destroy] [info command fooTest*] [Aclass destroy]
-} {1 {unknown method "?": must be bar, boo or destroy} {::fooTest in bar} {::fooTest in boo} {::fooTest2 in bar} {::fooTest2 in boo} {} fooTest2 {}}
-test oo-14.2 {OO: mixins} {
- oo::class create Aclass {
- method bar {} {return "[self object] in bar"}
- }
- oo::class create Bclass {
- method boo {} {return "[self object] in boo"}
- }
- oo::define Aclass mixin Bclass
- Aclass create fooTest
- set result [list [catch {fooTest ?} msg] $msg]
- lappend result [catch {fooTest bar} msg] $msg
- lappend result [catch {fooTest boo} msg] $msg
- lappend result [Bclass destroy] [info commands Aclass]
-} {1 {unknown method "?": must be bar, boo or destroy} 0 {::fooTest in bar} 0 {::fooTest in boo} {} {}}
-
-test oo-15.1 {OO: object cloning} {
- oo::class create Aclass
- oo::define Aclass method test {} {lappend ::result [self object]->test}
- Aclass create Ainstance
- set result {}
- Ainstance test
- oo::define Ainstance copy Binstance
- Binstance test
- Ainstance test
- Ainstance destroy
- namespace eval foo {
- oo::define Binstance copy Cinstance
- Cinstance test
- }
- Aclass destroy
- namespace delete foo
- lappend result [info commands Binstance]
-} {::Ainstance->test ::Binstance->test ::Ainstance->test ::foo::Cinstance->test {}}
-test oo-15.2 {OO: object cloning} {
- oo::object create foo
- oo::define foo {
- method m x {lappend ::result [self object] >$x<}
- forward f ::lappend ::result fwd
- }
- set result {}
- foo m 1
- foo f 2
- lappend result [oo::define foo copy bar]
- foo m 3
- foo f 4
- bar m 5
- bar f 6
- lappend result [foo destroy]
- bar m 7
- bar f 8
- lappend result [bar destroy]
-} {::foo >1< fwd 2 ::bar ::foo >3< fwd 4 ::bar >5< fwd 6 {} ::bar >7< fwd 8 {}}
-catch {foo destroy}
-catch {bar destroy}
-test oo-15.3 {OO: class cloning} {
- oo::class create foo {
- method testme {} {lappend ::result [self class]->[self object]}
- }
- set result {}
- foo create baseline
- baseline testme
- oo::define foo copy bar
- baseline testme
- bar create tester
- tester testme
- foo destroy
- tester testme
- bar destroy
- return $result
-} {::foo->::baseline ::foo->::baseline ::bar->::tester ::bar->::tester}
-
-test oo-16.1 {OO: object introspection} -body {
- info object
-} -returnCodes 1 -result "wrong \# args: should be \"info object objName subcommand ?arg ...?\""
-test oo-16.2 {OO: object introspection} -body {
- info object NOTANOBJECT class
-} -returnCodes 1 -result {NOTANOBJECT does not refer to an object}
-test oo-16.3 {OO: object introspection} -body {
- info object oo::object gorp
-} -returnCodes 1 -result {bad subcommand "gorp": must be class, definition, filters, forward, isa, methods, mixins, or vars}
-test oo-16.4 {OO: object introspection} -setup {
- oo::class create meta { superclass oo::class }
-} -body {
- list [info object oo::object class] \
- [info object oo::class class] \
- [info object oo::object isa class] \
- [info object oo::object isa metaclass] \
- [info object meta isa metaclass] \
- [info object oo::object isa object] \
- [info object oo::define isa object]
-} -cleanup {
- meta destroy
-} -result {::oo::class ::oo::class 1 0 1 1 0}
-test oo-16.5 {OO: object introspection} {info object oo::object methods} {}
-test oo-16.6 {OO: object introspection} {
- oo::object create foo
- set result [list [info object foo methods]]
- oo::define foo method bar {} {...}
- lappend result [info object foo methods] [foo destroy]
-} {{} bar {}}
-test oo-16.7 {OO: object introspection} -setup {
- oo::object create foo
-} -body {
- oo::define foo method bar {a {b c} args} {the body}
- set result [info object foo methods]
- lappend result [info object foo definition bar]
-} -cleanup {
- foo destroy
-} -result {bar {{a {b c} args} {the body}}}
-test oo-16.8 {OO: object introspection} {
- oo::object create foo
- oo::class create bar
- oo::define foo mixin bar
- set result [list [info object foo mixins] \
- [info object foo isa mixin bar] \
- [info object foo isa mixin oo::class]]
- foo destroy
- bar destroy
- return $result
-} {::bar 1 0}
-test oo-16.9 {OO: object introspection} {
- oo::class create Ac
- oo::class create Bc; oo::define Bc superclass Ac
- oo::class create Cc; oo::define Cc superclass Bc
- Cc create D
- list [info object D isa typeof oo::class] \
- [info object D isa typeof Ac] [Ac destroy]
-} {0 1 {}}
-test oo-16.10 {OO: object introspection} -setup {
- oo::object create foo
-} -body {
- oo::define foo export eval
- foo eval {variable c 3 a 1 b 2 ddd 4 e}
- lsort [info object foo vars ?]
-} -cleanup {
- foo destroy
-} -result {a b c}
-
-test oo-17.1 {OO: class introspection} -body {
- info class
-} -returnCodes 1 -result "wrong \# args: should be \"info class className subcommand ?arg ...?\""
-test oo-17.2 {OO: class introspection} -body {
- info class NOTANOBJECT gorp
-} -returnCodes 1 -result {NOTANOBJECT does not refer to an object}
-test oo-17.3 {OO: class introspection} -setup {
- oo::object create foo
-} -body {
- info class foo gorp
-} -returnCodes 1 -cleanup {
- foo destroy
-} -result {"foo" is not a class}
-test oo-17.4 {OO: class introspection} -body {
- info class oo::object gorp
-} -returnCodes 1 -result {bad subcommand "gorp": must be constructor, definition, destructor, filters, forward, instances, methods, mixins, subclasses, or superclasses}
-test oo-17.5 {OO: class introspection} -setup {
- oo::class create testClass
-} -body {
- testClass create foo
- testClass create bar
- testClass create spong
- lsort [info class testClass instances]
-} -cleanup {
- testClass destroy
-} -result {::bar ::foo ::spong}
-test oo-17.6 {OO: object introspection} -setup {
- oo::class create foo
-} -body {
- oo::define foo method bar {a {b c} args} {the body}
- set result [info class foo methods]
- lappend result [info class foo definition bar]
-} -cleanup {
- foo destroy
-} -result {bar {{a {b c} args} {the body}}}
-test oo-17.7 {OO: object introspection} {
- info class oo::class superclasses
-} ::oo::object
-test oo-17.8 {OO: object introspection} -setup {
- oo::class create testClass
- oo::class create superClass1
- oo::class create superClass2
-} -body {
- oo::define testClass superclass superClass1 superClass2
- list [info class testClass superclasses] \
- [lsort [info class oo::object subclass ::superClass?]]
-} -cleanup {
- testClass destroy
- superClass1 destroy
- superClass2 destroy
-} -result {{::superClass1 ::superClass2} {::superClass1 ::superClass2}}
-
-test oo-18.1 {OO: define command support} {
- list [catch {oo::define oo::object {error foo}} msg] $msg $errorInfo
-} {1 foo {foo
- while executing
-"error foo"
- (in definition script for object "oo::object" line 1)
- invoked from within
-"oo::define oo::object {error foo}"}}
-test oo-18.2 {OO: define command support} {
- list [catch {oo::define oo::object error foo} msg] $msg $errorInfo
-} {1 foo {foo
- while executing
-"oo::define oo::object error foo"}}
-test oo-18.3 {OO: define command support} {
- list [catch {oo::class create foo {error bar}} msg] $msg $errorInfo
-} {1 bar {bar
- while executing
-"error bar"
- (in definition script for object "::foo" line 1)
- invoked from within
-"oo::class create foo {error bar}"}}
-test oo-18.4 {OO: more error traces from the guts} -setup {
- oo::object create obj
-} -body {
- oo::define obj method bar {} {my eval {error foo}}
- list [catch {obj bar} msg] $msg $errorInfo
-} -cleanup {
- obj destroy
-} -result {1 foo {foo
- while executing
-"error foo"
- (in "my eval" script line 1)
- invoked from within
-"my eval {error foo}"
- (object "::obj" method "bar" line 1)
- invoked from within
-"obj bar"}}
-test oo-18.5 {OO: more error traces from the guts} -setup {
- [oo::class create cls] create obj
- set errorInfo {}
-} -body {
- oo::define cls {
- method eval script {next $script}
- export eval
- }
- oo::define obj method bar {} {my eval {error foo}}
- set result {}
- lappend result [catch {obj bar} msg] $msg $errorInfo
- lappend result [catch {obj eval {error bar}} msg] $msg $errorInfo
-} -cleanup {
- cls destroy
-} -result {1 foo {foo
- while executing
-"error foo"
- (in "my eval" script line 1)
- invoked from within
-"next $script"
- (class "::cls" method "eval" line 1)
- invoked from within
-"my eval {error foo}"
- (object "::obj" method "bar" line 1)
- invoked from within
-"obj bar"} 1 bar {bar
- while executing
-"error bar"
- (in "::obj eval" script line 1)
- invoked from within
-"next $script"
- (class "::cls" method "eval" line 1)
- invoked from within
-"obj eval {error bar}"}}
-
-test oo-19.1 {OO: varname method} -setup {
- oo::object create inst
- oo::define inst export eval
- set result {}
-} -body {
- inst eval {trace add variable x write foo}
- set ns [inst eval namespace current]
- proc foo args {
- global ns result
- set context [uplevel 1 namespace current]
- lappend result $args [expr {
- $ns eq $context ? "ok" : [list $ns ne $context]
- }] [expr {
- "${ns}::x" eq [uplevel 1 my varname x] ? "ok" : [list ${ns}::x ne [uplevel 1 my varname x]]
- }]
- }
- lappend result [inst eval set x 0]
-} -cleanup {
- inst destroy
- rename foo {}
-} -result {{x {} write} ok ok 0}
-
-test oo-20.1 {OO: variable method} -body {
- oo::class create testClass {
- constructor {} {
- my variable ok
- set ok {}
- }
- }
- lsort [info object [testClass new] vars]
-} -cleanup {
- catch {testClass destroy}
-} -result ok
-test oo-20.2 {OO: variable method} -body {
- oo::class create testClass {
- constructor {} {
- my variable a b c
- set a [set b [set c {}]]
- }
- }
- lsort [info object [testClass new] vars]
-} -cleanup {
- catch {testClass destroy}
-} -result {a b c}
-test oo-20.3 {OO: variable method} -body {
- oo::class create testClass {
- export varname
- method bar {} {
- my variable a(b)
- }
- }
- testClass create foo
- array set [foo varname a] {b c}
- foo bar
-} -returnCodes 1 -cleanup {
- catch {testClass destroy}
-} -result {can't define "a(b)": name refers to an element in an array}
-test oo-20.4 {OO: variable method} -body {
- oo::class create testClass {
- export varname
- method bar {} {
- my variable a(b)
- }
- }
- testClass create foo
- set [foo varname a] b
- foo bar
-} -returnCodes 1 -cleanup {
- catch {testClass destroy}
-} -result {can't define "a(b)": name refers to an element in an array}
-test oo-20.5 {OO: variable method} -body {
- oo::class create testClass {
- method bar {} {
- my variable a::b
- }
- }
- testClass create foo
- foo bar
-} -returnCodes 1 -cleanup {
- catch {testClass destroy}
-} -result {variable name "a::b" illegal: must not contain namespace separator}
-test oo-20.6 {OO: variable method} -setup {
- oo::class create testClass {
- self.export eval
- export varname
- }
-} -body {
- testClass eval variable a 0
- oo::define [testClass create foo] method bar {other} {
- $other variable a
- set a 3
- }
- oo::define [testClass create boo] export variable
- set [foo varname a] 1
- set [boo varname a] 2
- foo bar boo
- list [testClass eval set a] [set [foo varname a]] [set [boo varname a]]
-} -cleanup {
- testClass destroy
-} -result {0 1 3}
-test oo-20.7 {OO: variable method} -setup {
- oo::class create cls
-} -body {
- oo::define cls {
- method a {} {
- my variable {b c} d
- lappend c $d
- }
- method e {} {
- my variable b d
- return [list $b $d]
- }
- method f {x y} {
- my variable b d
- set b $x
- set d $y
- }
- }
- cls create obj
- obj f p q
- obj a
- obj a
- obj e
-} -cleanup {
- cls destroy
-} -result {{p q q} q}
-test oo-20.8 {OO: variable method} -setup {
- oo::class create cls
-} -body {
- oo::define cls {
- constructor {} {
- namespace eval foo {
- variable bar 1
- }
- }
- method ns {} {self namespace}
- method a {} {
- my variable {foo::bar c} d
- lappend c $d
- }
- method e {} {
- my variable {foo::bar b} d
- return [list $b $d]
- }
- method f {x} {
- my variable d
- set d $x
- }
- }
- cls create obj
- obj f p
- obj a
- obj a
- list [obj e] [set [obj ns]::foo::bar]
-} -cleanup {
- cls destroy
-} -result {{{1 p p} p} {1 p p}}
-test oo-20.9 {OO: variable method} -setup {
- oo::object create obj
-} -body {
- oo::define obj {
- method a {} {
- my variable {a ::b}
- }
- }
- obj a
-} -cleanup {
- obj destroy
-} -returnCodes 1 -result {variable name "::b" illegal: must not contain namespace separator}
-
-test oo-21.1 {OO: inheritance ordering} -setup {
- oo::class create A
-} -body {
- oo::define A method m {} {lappend ::result A}
- oo::class create B {
- superclass A
- method m {} {lappend ::result B;next}
- }
- oo::class create C {
- superclass A
- method m {} {lappend ::result C;next}
- }
- oo::class create D {
- superclass B C
- method m {} {lappend ::result D;next}
- }
- D create o
- oo::define o method m {} {lappend ::result o;next}
- set result {}
- o m
- return $result
-} -cleanup {
- A destroy
-} -result {o D B C A}
-test oo-21.2 {OO: inheritance ordering} -setup {
- oo::class create A
-} -body {
- oo::define A method m {} {lappend ::result A}
- oo::class create B {
- superclass A
- method m {} {lappend ::result B;next}
- }
- oo::class create C {
- superclass A
- method m {} {lappend ::result C;next}
- }
- oo::class create D {
- superclass B C
- method m {} {lappend ::result D;next}
- }
- oo::class create Emix {
- superclass C
- method m {} {lappend ::result Emix;next}
- }
- oo::class create Fmix {
- superclass Emix
- method m {} {lappend ::result Fmix;next}
- }
- D create o
- oo::define o method m {} {lappend ::result o;next}
- oo::define o mixin Fmix
- set result {}
- o m
- return $result
-} -cleanup {
- A destroy
-} -result {Fmix Emix o D B C A}
-test oo-21.3 {OO: inheritance ordering} -setup {
- oo::class create A
-} -body {
- oo::define A method m {} {lappend ::result A}
- oo::class create B {
- superclass A
- method m {} {lappend ::result B;next}
- method f {} {lappend ::result B-filt;next}
- }
- oo::class create C {
- superclass A
- method m {} {lappend ::result C;next}
- }
- oo::class create D {
- superclass B C
- method m {} {lappend ::result D;next}
- }
- oo::class create Emix {
- superclass C
- method m {} {lappend ::result Emix;next}
- method f {} {lappend ::result Emix-filt;next}
- }
- oo::class create Fmix {
- superclass Emix
- method m {} {lappend ::result Fmix;next}
- }
- D create o
- oo::define o {
- method m {} {lappend ::result o;next}
- mixin Fmix
- filter f
- }
- set result {}
- o m
- return $result
-} -cleanup {
- A destroy
-} -result {Emix-filt B-filt Fmix Emix o D B C A}
-test oo-21.4 {OO: inheritance ordering} -setup {
- oo::class create A
-} -body {
- oo::define A method m {} {lappend ::result A}
- oo::class create B {
- superclass A
- method m {} {lappend ::result B;next}
- method f {} {lappend ::result B-filt;next}
- method g {} {lappend ::result B-cfilt;next}
- }
- oo::class create C {
- superclass A
- method m {} {lappend ::result C;next}
- }
- oo::class create D {
- superclass B C
- method m {} {lappend ::result D;next}
- method g {} {lappend ::result D-cfilt;next}
- filter g
- }
- oo::class create Emix {
- superclass C
- method m {} {lappend ::result Emix;next}
- method f {} {lappend ::result Emix-filt;next}
- }
- oo::class create Fmix {
- superclass Emix
- method m {} {lappend ::result Fmix;next}
- }
- D create o
- oo::define o {
- method m {} {lappend ::result o;next}
- mixin Fmix
- filter f
- }
- set result {}
- o m
- return $result
-} -cleanup {
- A destroy
-} -result {Emix-filt B-filt D-cfilt B-cfilt Fmix Emix o D B C A}
-
-cleanupTests
-return
-
-# Local Variables:
-# mode: tcl
-# End:
+# This file contains a collection of tests for Tcl's built-in object system.
+# Sourcing this file into Tcl runs the tests and generates output for errors.
+# No output means no errors were found.
+#
+# Copyright (c) 2006 Donal K. Fellows
+#
+# See the file "license.terms" for information on usage and redistribution of
+# this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: oo.test,v 1.1.2.39 2006/10/21 01:11:52 dkf Exp $
+
+if {[lsearch [namespace children] ::tcltest] == -1} {
+ package require tcltest 2
+ namespace import -force ::tcltest::*
+}
+
+testConstraint memory [llength [info commands memory]]
+
+test oo-0.1 {basic test of OO's ability to clean up its initial state} {
+ interp create t
+ interp delete t
+} {}
+test oo-0.2 {basic test of OO's ability to clean up its initial state} {
+ interp eval [interp create] { namespace delete :: }
+} {}
+test oo-0.3 {basic test of OO's ability to clean up its initial state} -setup {
+ proc getbytes {} {
+ set lines [split [memory info] "\n"]
+ lindex $lines 3 3
+ }
+} -constraints memory -body {
+ set end [getbytes]
+ for {set i 0} {$i < 5} {incr i} {
+ [oo::object new] destroy
+ set tmp $end
+ set end [getbytes]
+ }
+ set leakedBytes [expr {$end - $tmp}]
+} -cleanup {
+ rename getbytes {}
+} -result 0
+test oo-0.4 {basic test of OO's ability to clean up its initial state} -setup {
+ proc getbytes {} {
+ set lines [split [memory info] "\n"]
+ lindex $lines 3 3
+ }
+} -constraints memory -body {
+ set end [getbytes]
+ for {set i 0} {$i < 5} {incr i} {
+ oo::class create foo
+ foo new
+ foo destroy
+ set tmp $end
+ set end [getbytes]
+ }
+ set leakedBytes [expr {$end - $tmp}]
+} -cleanup {
+ rename getbytes {}
+} -result 0
+
+test oo-1.1 {basic test of OO functionality: no classes} {
+ set result {}
+ lappend result [oo::object create foo]
+ lappend result [oo::define foo {
+ method bar args {
+ global result
+ lappend result {expand}$args
+ return [llength $args]
+ }
+ }]
+ lappend result [foo bar a b c]
+ lappend result [foo destroy] [info commands foo]
+} {::foo {} a b c 3 {} {}}
+test oo-1.2 {basic test of OO functionality: no classes} -body {
+ oo::define oo::object method missingArgs
+} -returnCodes 1 -result "wrong # args: should be \"oo::define oo::object method name args body\""
+test oo-1.3 {basic test of OO functionality: no classes} {
+ catch {oo::define oo::object method missingArgs}
+ set errorInfo
+} "wrong # args: should be \"oo::define oo::object method name args body\"
+ while executing
+\"oo::define oo::object method missingArgs\""
+test oo-1.4 {basic test of OO functionality} -body {
+ oo::object create {}
+} -returnCodes 1 -result {object name must not be empty}
+test oo-1.5 {basic test of OO functionality} -body {
+ oo::object doesnotexist
+} -returnCodes 1 -result {unknown method "doesnotexist": must be create, destroy or new}
+test oo-1.6 {basic test of OO functionality} -setup {
+ oo::object create aninstance
+} -body {
+ oo::define aninstance unexport destroy
+ aninstance doesnotexist
+} -cleanup {
+ rename aninstance {}
+} -returnCodes 1 -result {object "::aninstance" has no visible methods}
+
+test oo-2.1 {basic test of OO functionality: constructor} -setup {
+ # This is a bit complex because it needs to run in a sub-interp as
+ # we're modifying the root object class's constructor
+ interp create subinterp
+} -body {
+ subinterp eval {
+ oo::define oo::object constructor {} {
+ lappend ::result [info level 0]
+ }
+ lappend result 1
+ lappend result 2 [oo::object create foo]
+ }
+} -cleanup {
+ interp delete subinterp
+} -result {1 {oo::object create foo} 2 ::foo}
+test oo-2.2 {basic test of OO functionality: constructor} {
+ oo::class create testClass {
+ constructor {} {
+ global result
+ lappend result "[self]->construct"
+ }
+ method bar {} {
+ global result
+ lappend result "[self]->bar"
+ }
+ }
+ set result {}
+ [testClass create foo] bar
+ testClass destroy
+ return $result
+} {::foo->construct ::foo->bar}
+
+test oo-3.1 {basic test of OO functionality: destructor} -setup {
+ # This is a bit complex because it needs to run in a sub-interp as
+ # we're modifying the root object class's constructor
+ interp create subinterp
+} -body {
+ subinterp eval {
+ oo::define oo::object destructor {
+ lappend ::result died
+ }
+ lappend result 1 [oo::object create foo]
+ lappend result 2 [rename foo {}]
+ oo::define oo::object destructor {}
+ return $result
+ }
+} -cleanup {
+ interp delete subinterp
+} -result {1 ::foo died 2 {}}
+test oo-3.2 {basic test of OO functionality: destructor} -setup {
+ # This is a bit complex because it needs to run in a sub-interp as
+ # we're modifying the root object class's constructor
+ interp create subinterp
+} -body {
+ subinterp eval {
+ oo::define oo::object destructor {
+ lappend ::result died
+ }
+ lappend result 1 [oo::object create foo]
+ lappend result 2 [rename foo {}]
+ }
+} -cleanup {
+ interp delete subinterp
+} -result {1 ::foo died 2 {}}
+
+test oo-4.1 {basic test of OO functionality: export} {
+ set o [oo::object new]
+ set result {}
+ oo::define $o method Foo {} {lappend ::result Foo; return}
+ lappend result [catch {$o Foo} msg] $msg
+ oo::define $o export Foo
+ lappend result [$o Foo] [$o destroy]
+} {1 {unknown method "Foo": must be destroy} Foo {} {}}
+test oo-4.2 {basic test of OO functionality: unexport} {
+ set o [oo::object new]
+ set result {}
+ oo::define $o method foo {} {lappend ::result foo; return}
+ lappend result [$o foo]
+ oo::define $o unexport foo
+ lappend result [catch {$o foo} msg] $msg [$o destroy]
+} {foo {} 1 {unknown method "foo": must be destroy} {}}
+
+test oo-5.1 {OO: manipulation of classes as objects} -setup {
+ set obj [oo::object new]
+} -body {
+ oo::define oo::object self.method foo {} { return "in object" }
+ catch {$obj foo} result
+ list [catch {$obj foo} result] $result [oo::object foo]
+} -cleanup {
+ oo::define oo::object self.method foo {} {}
+ $obj destroy
+} -result {1 {unknown method "foo": must be destroy} {in object}}
+
+test oo-6.1 {OO: forward} {
+ oo::object create foo
+ oo::define foo {
+ forward a lappend
+ forward b lappend result
+ }
+ set result {}
+ foo a result 1
+ foo b 2
+ foo destroy
+ return $result
+} {1 2}
+
+test oo-7.1 {OO: inheritance 101} -setup {
+ oo::class create superClass
+ oo::class create subClass
+ subClass create instance
+} -body {
+ oo::define superClass method doit x {lappend ::result $x}
+ oo::define subClass superclass superClass
+ set result [list [catch {subClass doit bad} msg] $msg]
+ instance doit ok
+ return $result
+} -cleanup {
+ subClass destroy
+ superClass destroy
+} -result {1 {unknown method "doit": must be create, destroy or new} ok}
+test oo-7.2 {OO: inheritance 101} -setup {
+ oo::class create superClass
+ oo::class create subClass
+ subClass create instance
+} -body {
+ oo::define superClass method doit x {lappend ::result |$x|}
+ oo::define subClass superclass superClass
+ oo::define instance method doit x {lappend ::result =$x=; next [incr x]}
+ set result {}
+ instance doit 1
+ return $result
+} -cleanup {
+ subClass destroy
+ superClass destroy
+} -result {=1= |2|}
+test oo-7.3 {OO: inheritance 101} -setup {
+ oo::class create superClass
+ oo::class create subClass
+ subClass create instance
+} -body {
+ oo::define superClass method doit x {lappend ::result |$x|}
+ oo::define subClass {
+ superclass superClass
+ method doit x {lappend ::result -$x-; next [incr x]}
+ }
+ oo::define instance method doit x {lappend ::result =$x=; next [incr x]}
+ set result {}
+ instance doit 1
+ return $result
+} -cleanup {
+ subClass destroy
+ superClass destroy
+} -result {=1= -2- |3|}
+test oo-7.4 {OO: inheritance from oo::class} -body {
+ oo::class create meta
+ oo::define meta {
+ superclass oo::class
+ self.unexport create new
+ self.method make {x {definitions {}}} {
+ if {![string match ::* $x]} {
+ set ns [uplevel 1 {::namespace current}]
+ set x ${ns}::$x
+ }
+ set o [my create $x]
+ lappend ::result "made $o"
+ oo::define $o $definitions
+ return $o
+ }
+ }
+ set result [list [catch {meta create foo} msg] $msg]
+ lappend result [meta make classinstance {
+ lappend ::result "in definition script in [namespace current]"
+ }]
+ lappend result [classinstance create instance]
+} -cleanup {
+ catch {classinstance destroy}
+ catch {meta destroy}
+} -result {1 {unknown method "create": must be destroy or make} {made ::classinstance} {in definition script in ::oo::define} ::classinstance ::instance}
+test oo-7.5 {OO: inheritance from oo::class in the secondary chain} -body {
+ oo::class create other
+ oo::class create meta
+ oo::define meta {
+ superclass other oo::class
+ self.unexport create new
+ self.method make {x {definitions {}}} {
+ if {![string match ::* $x]} {
+ set ns [uplevel 1 {::namespace current}]
+ set x ${ns}::$x
+ }
+ set o [my create $x]
+ lappend ::result "made $o"
+ oo::define $o $definitions
+ return $o
+ }
+ }
+ set result [list [catch {meta create foo} msg] $msg]
+ lappend result [meta make classinstance {
+ lappend ::result "in definition script in [namespace current]"
+ }]
+ lappend result [classinstance create instance]
+} -cleanup {
+ catch {classinstance destroy}
+ catch {meta destroy}
+ catch {other destroy}
+} -result {1 {unknown method "create": must be destroy or make} {made ::classinstance} {in definition script in ::oo::define} ::classinstance ::instance}
+test oo-7.6 {OO: inheritance 101 - overridden methods should be oblivious} -setup {
+ oo::class create Aclass
+ oo::class create Bclass
+ Bclass create Binstance
+} -body {
+ oo::define Aclass {
+ method incr {var step} {
+ upvar 1 $var v
+ ::incr v $step
+ }
+ }
+ oo::define Bclass {
+ superclass Aclass
+ method incr {var {step 1}} {
+ global result
+ lappend result $var $step
+ set r [next $var $step]
+ lappend result returning:$r
+ return $r
+ }
+ }
+ set result {}
+ set x 10
+ lappend result x=$x
+ lappend result [Binstance incr x]
+ lappend result x=$x
+} -result {x=10 x 1 returning:11 11 x=11} -cleanup {
+ Aclass destroy
+}
+test oo-7.7 {OO: inheritance and errorInfo} -setup {
+ oo::class create A
+ oo::class create B
+ B create c
+} -body {
+ oo::define A method foo {} {error foo!}
+ oo::define B {
+ superclass A
+ method foo {} { next }
+ }
+ oo::define c method foo {} { next }
+ catch {c ?} msg
+ set result [list $msg]
+ catch {c foo} msg
+ lappend result $msg $errorInfo
+} -cleanup {
+ A destroy
+} -result {{unknown method "?": must be destroy or foo} foo! {foo!
+ while executing
+"error foo!"
+ (class "::A" method "foo" line 1)
+ invoked from within
+"next "
+ (class "::B" method "foo" line 1)
+ invoked from within
+"next "
+ (object "::c" method "foo" line 1)
+ invoked from within
+"c foo"}}
+
+test oo-8.1 {OO: global must work in methods} {
+ oo::object create foo
+ oo::define foo method bar x {global result; lappend result $x}
+ set result {}
+ foo bar this
+ foo bar is
+ lappend result a
+ foo bar test
+ foo destroy
+ return $result
+} {this is a test}
+
+test oo-9.1 {OO: multiple inheritance} -setup {
+ oo::class create A
+ oo::class create B
+ oo::class create C
+ oo::class create D
+ D create foo
+} -body {
+ oo::define A method test {} {lappend ::result A; return ok}
+ oo::define B {
+ superclass A
+ method test {} {lappend ::result B; next}
+ }
+ oo::define C {
+ superclass A
+ method test {} {lappend ::result C; next}
+ }
+ oo::define D {
+ superclass B C
+ method test {} {lappend ::result D; next}
+ }
+ set result {}
+ lappend result [foo test]
+} -cleanup {
+ D destroy
+ C destroy
+ B destroy
+ A destroy
+} -result {D B C A ok}
+test oo-9.2 {OO: multiple inheritance} -setup {
+ oo::class create A
+ oo::class create B
+ oo::class create C
+ oo::class create D
+ D create foo
+} -body {
+ oo::define A method test {} {lappend ::result A; return ok}
+ oo::define B {
+ superclass A
+ method test {} {lappend ::result B; next}
+ }
+ oo::define C {
+ superclass A
+ method test {} {lappend ::result C; next}
+ }
+ oo::define D {
+ superclass B C
+ method test {} {lappend ::result D; next}
+ }
+ set result {}
+ lappend result [foo test]
+} -cleanup {
+ A destroy
+} -result {D B C A ok}
+
+test oo-10.1 {OO: recursive invoke and modify} -setup {
+ [oo::class create C] create O
+} -cleanup {
+ C destroy
+} -body {
+ oo::define C method foo x {
+ lappend ::result $x
+ if {$x} {
+ [self object] foo [incr x -1]
+ }
+ }
+ oo::define O method foo x {
+ lappend ::result -$x-
+ if {$x == 1} {
+ # delete the method
+ oo::define O method foo {} {}
+ }
+ next $x
+ }
+ set result {}
+ O foo 2
+ return $result
+} -result {-2- 2 -1- 1 0}
+
+test oo-11.1 {OO: cleanup} {
+ oo::object create foo
+ set result [list [catch {oo::object create foo} msg] $msg]
+ lappend result [foo destroy] [oo::object create foo] [foo destroy]
+} {1 {can't create object "foo": command already exists with that name} {} ::foo {}}
+test oo-11.2 {OO: cleanup} {
+ oo::class create bar
+ bar create foo
+ set result [list [catch {bar create foo} msg] $msg]
+ lappend result [bar destroy] [oo::object create foo] [foo destroy]
+} {1 {can't create object "foo": command already exists with that name} {} ::foo {}}
+test oo-11.3 {OO: cleanup} {
+ oo::class create bar0
+ oo::class create bar
+ oo::define bar superclass bar0
+ bar create foo
+ set result [list [catch {bar create foo} msg] $msg]
+ lappend result [bar0 destroy] [oo::object create foo] [foo destroy]
+} {1 {can't create object "foo": command already exists with that name} {} ::foo {}}
+test oo-11.4 {OO: cleanup} {
+ oo::class create bar0
+ oo::class create bar1
+ oo::define bar1 superclass bar0
+ oo::class create bar2
+ oo::define bar2 {
+ superclass bar0
+ destructor {lappend ::result destroyed}
+ }
+ oo::class create bar
+ oo::define bar superclass bar1 bar2
+ bar create foo
+ set result [list [catch {bar create foo} msg] $msg]
+ lappend result [bar0 destroy] [oo::object create foo] [foo destroy] \
+ [oo::object create bar2] [bar2 destroy]
+} {1 {can't create object "foo": command already exists with that name} destroyed {} ::foo {} ::bar2 {}}
+
+test oo-12.1 {OO: filters} {
+ oo::class create Aclass
+ Aclass create Aobject
+ oo::define Aclass {
+ method concatenate args {
+ global result
+ lappend result {expand}$args
+ join $args {}
+ }
+ method logFilter args {
+ global result
+ lappend result "calling [self object]->[self method] $args"
+ set r [next {expand}$args]
+ lappend result "result=$r"
+ return $r
+ }
+ }
+ oo::define Aobject filter logFilter
+ set result {}
+ lappend result [Aobject concatenate 1 2 3 4 5]
+ Aclass destroy
+ return $result
+} {{calling ::Aobject->logFilter 1 2 3 4 5} 1 2 3 4 5 result=12345 12345}
+test oo-12.2 {OO: filters} -setup {
+ oo::class create Aclass
+ Aclass create Aobject
+} -body {
+ oo::define Aclass {
+ method concatenate args {
+ global result
+ lappend result {expand}$args
+ join $args {}
+ }
+ method logFilter args {
+ global result
+ lappend result "calling [self object]->[self method] $args"
+ set r [next {expand}$args]
+ lappend result "result=$r"
+ return $r
+ }
+ }
+ oo::define Aobject filter logFilter
+ set result {}
+ lappend result [Aobject concatenate 1 2 3 4 5] [Aobject destroy]
+} -cleanup {
+ Aclass destroy
+} -result {{calling ::Aobject->logFilter 1 2 3 4 5} 1 2 3 4 5 result=12345 {calling ::Aobject->logFilter } result= 12345 {}}
+test oo-12.3 {OO: filters} -setup {
+ oo::class create Aclass
+ Aclass create Aobject
+} -body {
+ oo::define Aclass {
+ method concatenate args {
+ global result
+ lappend result {expand}$args
+ join $args {}
+ }
+ method logFilter args {
+ global result
+ lappend result "calling [self object]->[self method] $args"
+ set r [next {expand}$args]
+ lappend result "result=$r"
+ return $r
+ }
+ filter logFilter
+ }
+ set result {}
+ lappend result [Aobject concatenate 1 2 3 4 5] [Aobject destroy]
+} -cleanup {
+ Aclass destroy
+} -result {{calling ::Aobject->logFilter 1 2 3 4 5} 1 2 3 4 5 result=12345 {calling ::Aobject->logFilter } result= 12345 {}}
+test oo-12.4 {OO: filters} -setup {
+ oo::class create Aclass
+ Aclass create Aobject
+} -body {
+ oo::define Aclass {
+ method foo {} { return foo }
+ method Bar {} { return 1 }
+ method boo {} { if {[my Bar]} { next } { error forbidden } }
+ filter boo
+ }
+ Aobject foo
+} -cleanup {
+ Aclass destroy
+} -result foo
+test oo-12.5 {OO: filters} -setup {
+ oo::class create Aclass
+ Aclass create Aobject
+} -body {
+ oo::define Aclass {
+ method foo {} { return foo }
+ method Bar {} { return [my Bar2] }
+ method Bar2 {} { return 1 }
+ method boo {} { if {[my Bar]} { next } { error forbidden } }
+ filter boo
+ }
+ Aobject foo
+} -cleanup {
+ Aclass destroy
+} -result foo
+test oo-12.6 {OO: filters} -setup {
+ oo::class create Aclass
+ Aclass create Aobject
+} -body {
+ oo::define Aclass {
+ method foo {} { return foo }
+ method Bar {} { return [my Bar2] }
+ method Bar2 {} { return [my Bar3] }
+ method Bar3 {} { return 1 }
+ method boo {} { if {[my Bar]} { next } { error forbidden } }
+ filter boo
+ }
+ Aobject foo
+} -cleanup {
+ Aclass destroy
+} -result foo
+test oo-12.7 {OO: filters} -setup {
+ oo::class create Aclass
+ Aclass create Aobject
+} -body {
+ oo::define Aclass {
+ method outerfoo {} { return [my InnerFoo] }
+ method InnerFoo {} { return foo }
+ method Bar {} { return [my Bar2] }
+ method Bar2 {} { return [my Bar3] }
+ method Bar3 {} { return 1 }
+ method boo {} {
+ lappend ::log [self target]
+ if {[my Bar]} { next } else { error forbidden }
+ }
+ filter boo
+ }
+ set log {}
+ list [Aobject outerfoo] $log
+} -cleanup {
+ Aclass destroy
+} -result {foo {{::Aclass outerfoo} {::Aclass InnerFoo}}}
+
+test oo-13.1 {OO: changing an object's class} {
+ oo::class create Aclass
+ oo::define Aclass {method bar {} {lappend ::result "in A [self object]"}}
+ oo::class create Bclass
+ oo::define Bclass {method bar {} {lappend ::result "in B [self object]"}}
+ set result [Aclass create foo]
+ foo bar
+ oo::define foo self.class Bclass
+ foo bar
+ Aclass destroy
+ lappend result [info command foo]
+ Bclass destroy
+ return $result
+} {::foo {in A ::foo} {in B ::foo} foo}
+test oo-13.2 {OO: changing an object's class} -body {
+ oo::object create foo
+ oo::define foo self.class oo::class
+} -cleanup {
+ foo destroy
+} -returnCodes 1 -result {may not change a non-class object into a class object}
+test oo-13.3 {OO: changing an object's class} -body {
+ oo::class create foo
+ oo::define foo self.class oo::object
+} -cleanup {
+ foo destroy
+} -returnCodes 1 -result {may not change a class object into a non-class object}
+# todo: changing a class subtype (metaclass) to another class subtype
+
+test oo-14.1 {OO: mixins} {
+ oo::class create Aclass
+ oo::define Aclass method bar {} {lappend ::result "[self object] in bar"}
+ oo::class create Bclass
+ oo::define Bclass method boo {} {lappend ::result "[self object] in boo"}
+ oo::define [Aclass create fooTest] mixin Bclass
+ oo::define [Aclass create fooTest2] mixin Bclass
+ set result [list [catch {fooTest ?} msg] $msg]
+ fooTest bar
+ fooTest boo
+ fooTest2 bar
+ fooTest2 boo
+ oo::define fooTest2 mixin
+ lappend result [Bclass destroy] [info command fooTest*] [Aclass destroy]
+} {1 {unknown method "?": must be bar, boo or destroy} {::fooTest in bar} {::fooTest in boo} {::fooTest2 in bar} {::fooTest2 in boo} {} fooTest2 {}}
+test oo-14.2 {OO: mixins} {
+ oo::class create Aclass {
+ method bar {} {return "[self object] in bar"}
+ }
+ oo::class create Bclass {
+ method boo {} {return "[self object] in boo"}
+ }
+ oo::define Aclass mixin Bclass
+ Aclass create fooTest
+ set result [list [catch {fooTest ?} msg] $msg]
+ lappend result [catch {fooTest bar} msg] $msg
+ lappend result [catch {fooTest boo} msg] $msg
+ lappend result [Bclass destroy] [info commands Aclass]
+} {1 {unknown method "?": must be bar, boo or destroy} 0 {::fooTest in bar} 0 {::fooTest in boo} {} {}}
+
+test oo-15.1 {OO: object cloning} {
+ oo::class create Aclass
+ oo::define Aclass method test {} {lappend ::result [self object]->test}
+ Aclass create Ainstance
+ set result {}
+ Ainstance test
+ oo::copy Ainstance Binstance
+ Binstance test
+ Ainstance test
+ Ainstance destroy
+ namespace eval foo {
+ oo::copy Binstance Cinstance
+ Cinstance test
+ }
+ Aclass destroy
+ namespace delete foo
+ lappend result [info commands Binstance]
+} {::Ainstance->test ::Binstance->test ::Ainstance->test ::foo::Cinstance->test {}}
+test oo-15.2 {OO: object cloning} {
+ oo::object create foo
+ oo::define foo {
+ method m x {lappend ::result [self object] >$x<}
+ forward f ::lappend ::result fwd
+ }
+ set result {}
+ foo m 1
+ foo f 2
+ lappend result [oo::copy foo bar]
+ foo m 3
+ foo f 4
+ bar m 5
+ bar f 6
+ lappend result [foo destroy]
+ bar m 7
+ bar f 8
+ lappend result [bar destroy]
+} {::foo >1< fwd 2 ::bar ::foo >3< fwd 4 ::bar >5< fwd 6 {} ::bar >7< fwd 8 {}}
+catch {foo destroy}
+catch {bar destroy}
+test oo-15.3 {OO: class cloning} {
+ oo::class create foo {
+ method testme {} {lappend ::result [self class]->[self object]}
+ }
+ set result {}
+ foo create baseline
+ baseline testme
+ oo::copy foo bar
+ baseline testme
+ bar create tester
+ tester testme
+ foo destroy
+ tester testme
+ bar destroy
+ return $result
+} {::foo->::baseline ::foo->::baseline ::bar->::tester ::bar->::tester}
+
+test oo-16.1 {OO: object introspection} -body {
+ info object
+} -returnCodes 1 -result "wrong \# args: should be \"info object objName subcommand ?arg ...?\""
+test oo-16.2 {OO: object introspection} -body {
+ info object NOTANOBJECT class
+} -returnCodes 1 -result {NOTANOBJECT does not refer to an object}
+test oo-16.3 {OO: object introspection} -body {
+ info object oo::object gorp
+} -returnCodes 1 -result {bad subcommand "gorp": must be class, definition, filters, forward, isa, methods, mixins, or vars}
+test oo-16.4 {OO: object introspection} -setup {
+ oo::class create meta { superclass oo::class }
+} -body {
+ list [info object oo::object class] \
+ [info object oo::class class] \
+ [info object oo::object isa class] \
+ [info object oo::object isa metaclass] \
+ [info object meta isa metaclass] \
+ [info object oo::object isa object] \
+ [info object oo::define isa object]
+} -cleanup {
+ meta destroy
+} -result {::oo::class ::oo::class 1 0 1 1 0}
+test oo-16.5 {OO: object introspection} {info object oo::object methods} {}
+test oo-16.6 {OO: object introspection} {
+ oo::object create foo
+ set result [list [info object foo methods]]
+ oo::define foo method bar {} {...}
+ lappend result [info object foo methods] [foo destroy]
+} {{} bar {}}
+test oo-16.7 {OO: object introspection} -setup {
+ oo::object create foo
+} -body {
+ oo::define foo method bar {a {b c} args} {the body}
+ set result [info object foo methods]
+ lappend result [info object foo definition bar]
+} -cleanup {
+ foo destroy
+} -result {bar {{a {b c} args} {the body}}}
+test oo-16.8 {OO: object introspection} {
+ oo::object create foo
+ oo::class create bar
+ oo::define foo mixin bar
+ set result [list [info object foo mixins] \
+ [info object foo isa mixin bar] \
+ [info object foo isa mixin oo::class]]
+ foo destroy
+ bar destroy
+ return $result
+} {::bar 1 0}
+test oo-16.9 {OO: object introspection} {
+ oo::class create Ac
+ oo::class create Bc; oo::define Bc superclass Ac
+ oo::class create Cc; oo::define Cc superclass Bc
+ Cc create D
+ list [info object D isa typeof oo::class] \
+ [info object D isa typeof Ac] [Ac destroy]
+} {0 1 {}}
+test oo-16.10 {OO: object introspection} -setup {
+ oo::object create foo
+} -body {
+ oo::define foo export eval
+ foo eval {variable c 3 a 1 b 2 ddd 4 e}
+ lsort [info object foo vars ?]
+} -cleanup {
+ foo destroy
+} -result {a b c}
+
+test oo-17.1 {OO: class introspection} -body {
+ info class
+} -returnCodes 1 -result "wrong \# args: should be \"info class className subcommand ?arg ...?\""
+test oo-17.2 {OO: class introspection} -body {
+ info class NOTANOBJECT gorp
+} -returnCodes 1 -result {NOTANOBJECT does not refer to an object}
+test oo-17.3 {OO: class introspection} -setup {
+ oo::object create foo
+} -body {
+ info class foo gorp
+} -returnCodes 1 -cleanup {
+ foo destroy
+} -result {"foo" is not a class}
+test oo-17.4 {OO: class introspection} -body {
+ info class oo::object gorp
+} -returnCodes 1 -result {bad subcommand "gorp": must be constructor, definition, destructor, filters, forward, instances, methods, mixins, subclasses, or superclasses}
+test oo-17.5 {OO: class introspection} -setup {
+ oo::class create testClass
+} -body {
+ testClass create foo
+ testClass create bar
+ testClass create spong
+ lsort [info class testClass instances]
+} -cleanup {
+ testClass destroy
+} -result {::bar ::foo ::spong}
+test oo-17.6 {OO: object introspection} -setup {
+ oo::class create foo
+} -body {
+ oo::define foo method bar {a {b c} args} {the body}
+ set result [info class foo methods]
+ lappend result [info class foo definition bar]
+} -cleanup {
+ foo destroy
+} -result {bar {{a {b c} args} {the body}}}
+test oo-17.7 {OO: object introspection} {
+ info class oo::class superclasses
+} ::oo::object
+test oo-17.8 {OO: object introspection} -setup {
+ oo::class create testClass
+ oo::class create superClass1
+ oo::class create superClass2
+} -body {
+ oo::define testClass superclass superClass1 superClass2
+ list [info class testClass superclasses] \
+ [lsort [info class oo::object subclass ::superClass?]]
+} -cleanup {
+ testClass destroy
+ superClass1 destroy
+ superClass2 destroy
+} -result {{::superClass1 ::superClass2} {::superClass1 ::superClass2}}
+
+test oo-18.1 {OO: define command support} {
+ list [catch {oo::define oo::object {error foo}} msg] $msg $errorInfo
+} {1 foo {foo
+ while executing
+"error foo"
+ (in definition script for object "oo::object" line 1)
+ invoked from within
+"oo::define oo::object {error foo}"}}
+test oo-18.2 {OO: define command support} {
+ list [catch {oo::define oo::object error foo} msg] $msg $errorInfo
+} {1 foo {foo
+ while executing
+"oo::define oo::object error foo"}}
+test oo-18.3 {OO: define command support} {
+ list [catch {oo::class create foo {error bar}} msg] $msg $errorInfo
+} {1 bar {bar
+ while executing
+"error bar"
+ (in definition script for object "::foo" line 1)
+ invoked from within
+"oo::class create foo {error bar}"}}
+test oo-18.4 {OO: more error traces from the guts} -setup {
+ oo::object create obj
+} -body {
+ oo::define obj method bar {} {my eval {error foo}}
+ list [catch {obj bar} msg] $msg $errorInfo
+} -cleanup {
+ obj destroy
+} -result {1 foo {foo
+ while executing
+"error foo"
+ (in "my eval" script line 1)
+ invoked from within
+"my eval {error foo}"
+ (object "::obj" method "bar" line 1)
+ invoked from within
+"obj bar"}}
+test oo-18.5 {OO: more error traces from the guts} -setup {
+ [oo::class create cls] create obj
+ set errorInfo {}
+} -body {
+ oo::define cls {
+ method eval script {next $script}
+ export eval
+ }
+ oo::define obj method bar {} {my eval {error foo}}
+ set result {}
+ lappend result [catch {obj bar} msg] $msg $errorInfo
+ lappend result [catch {obj eval {error bar}} msg] $msg $errorInfo
+} -cleanup {
+ cls destroy
+} -result {1 foo {foo
+ while executing
+"error foo"
+ (in "my eval" script line 1)
+ invoked from within
+"next $script"
+ (class "::cls" method "eval" line 1)
+ invoked from within
+"my eval {error foo}"
+ (object "::obj" method "bar" line 1)
+ invoked from within
+"obj bar"} 1 bar {bar
+ while executing
+"error bar"
+ (in "::obj eval" script line 1)
+ invoked from within
+"next $script"
+ (class "::cls" method "eval" line 1)
+ invoked from within
+"obj eval {error bar}"}}
+
+test oo-19.1 {OO: varname method} -setup {
+ oo::object create inst
+ oo::define inst export eval
+ set result {}
+} -body {
+ inst eval {trace add variable x write foo}
+ set ns [inst eval namespace current]
+ proc foo args {
+ global ns result
+ set context [uplevel 1 namespace current]
+ lappend result $args [expr {
+ $ns eq $context ? "ok" : [list $ns ne $context]
+ }] [expr {
+ "${ns}::x" eq [uplevel 1 my varname x] ? "ok" : [list ${ns}::x ne [uplevel 1 my varname x]]
+ }]
+ }
+ lappend result [inst eval set x 0]
+} -cleanup {
+ inst destroy
+ rename foo {}
+} -result {{x {} write} ok ok 0}
+
+test oo-20.1 {OO: variable method} -body {
+ oo::class create testClass {
+ constructor {} {
+ my variable ok
+ set ok {}
+ }
+ }
+ lsort [info object [testClass new] vars]
+} -cleanup {
+ catch {testClass destroy}
+} -result ok
+test oo-20.2 {OO: variable method} -body {
+ oo::class create testClass {
+ constructor {} {
+ my variable a b c
+ set a [set b [set c {}]]
+ }
+ }
+ lsort [info object [testClass new] vars]
+} -cleanup {
+ catch {testClass destroy}
+} -result {a b c}
+test oo-20.3 {OO: variable method} -body {
+ oo::class create testClass {
+ export varname
+ method bar {} {
+ my variable a(b)
+ }
+ }
+ testClass create foo
+ array set [foo varname a] {b c}
+ foo bar
+} -returnCodes 1 -cleanup {
+ catch {testClass destroy}
+} -result {can't define "a(b)": name refers to an element in an array}
+test oo-20.4 {OO: variable method} -body {
+ oo::class create testClass {
+ export varname
+ method bar {} {
+ my variable a(b)
+ }
+ }
+ testClass create foo
+ set [foo varname a] b
+ foo bar
+} -returnCodes 1 -cleanup {
+ catch {testClass destroy}
+} -result {can't define "a(b)": name refers to an element in an array}
+test oo-20.5 {OO: variable method} -body {
+ oo::class create testClass {
+ method bar {} {
+ my variable a::b
+ }
+ }
+ testClass create foo
+ foo bar
+} -returnCodes 1 -cleanup {
+ catch {testClass destroy}
+} -result {variable name "a::b" illegal: must not contain namespace separator}
+test oo-20.6 {OO: variable method} -setup {
+ oo::class create testClass {
+ self.export eval
+ export varname
+ }
+} -body {
+ testClass eval variable a 0
+ oo::define [testClass create foo] method bar {other} {
+ $other variable a
+ set a 3
+ }
+ oo::define [testClass create boo] export variable
+ set [foo varname a] 1
+ set [boo varname a] 2
+ foo bar boo
+ list [testClass eval set a] [set [foo varname a]] [set [boo varname a]]
+} -cleanup {
+ testClass destroy
+} -result {0 1 3}
+test oo-20.7 {OO: variable method} -setup {
+ oo::class create cls
+} -body {
+ oo::define cls {
+ method a {} {
+ my variable {b c} d
+ lappend c $d
+ }
+ method e {} {
+ my variable b d
+ return [list $b $d]
+ }
+ method f {x y} {
+ my variable b d
+ set b $x
+ set d $y
+ }
+ }
+ cls create obj
+ obj f p q
+ obj a
+ obj a
+ obj e
+} -cleanup {
+ cls destroy
+} -result {{p q q} q}
+test oo-20.8 {OO: variable method} -setup {
+ oo::class create cls
+} -body {
+ oo::define cls {
+ constructor {} {
+ namespace eval foo {
+ variable bar 1
+ }
+ }
+ method ns {} {self namespace}
+ method a {} {
+ my variable {foo::bar c} d
+ lappend c $d
+ }
+ method e {} {
+ my variable {foo::bar b} d
+ return [list $b $d]
+ }
+ method f {x} {
+ my variable d
+ set d $x
+ }
+ }
+ cls create obj
+ obj f p
+ obj a
+ obj a
+ list [obj e] [set [obj ns]::foo::bar]
+} -cleanup {
+ cls destroy
+} -result {{{1 p p} p} {1 p p}}
+test oo-20.9 {OO: variable method} -setup {
+ oo::object create obj
+} -body {
+ oo::define obj {
+ method a {} {
+ my variable {a ::b}
+ }
+ }
+ obj a
+} -cleanup {
+ obj destroy
+} -returnCodes 1 -result {variable name "::b" illegal: must not contain namespace separator}
+
+test oo-21.1 {OO: inheritance ordering} -setup {
+ oo::class create A
+} -body {
+ oo::define A method m {} {lappend ::result A}
+ oo::class create B {
+ superclass A
+ method m {} {lappend ::result B;next}
+ }
+ oo::class create C {
+ superclass A
+ method m {} {lappend ::result C;next}
+ }
+ oo::class create D {
+ superclass B C
+ method m {} {lappend ::result D;next}
+ }
+ D create o
+ oo::define o method m {} {lappend ::result o;next}
+ set result {}
+ o m
+ return $result
+} -cleanup {
+ A destroy
+} -result {o D B C A}
+test oo-21.2 {OO: inheritance ordering} -setup {
+ oo::class create A
+} -body {
+ oo::define A method m {} {lappend ::result A}
+ oo::class create B {
+ superclass A
+ method m {} {lappend ::result B;next}
+ }
+ oo::class create C {
+ superclass A
+ method m {} {lappend ::result C;next}
+ }
+ oo::class create D {
+ superclass B C
+ method m {} {lappend ::result D;next}
+ }
+ oo::class create Emix {
+ superclass C
+ method m {} {lappend ::result Emix;next}
+ }
+ oo::class create Fmix {
+ superclass Emix
+ method m {} {lappend ::result Fmix;next}
+ }
+ D create o
+ oo::define o method m {} {lappend ::result o;next}
+ oo::define o mixin Fmix
+ set result {}
+ o m
+ return $result
+} -cleanup {
+ A destroy
+} -result {Fmix Emix o D B C A}
+test oo-21.3 {OO: inheritance ordering} -setup {
+ oo::class create A
+} -body {
+ oo::define A method m {} {lappend ::result A}
+ oo::class create B {
+ superclass A
+ method m {} {lappend ::result B;next}
+ method f {} {lappend ::result B-filt;next}
+ }
+ oo::class create C {
+ superclass A
+ method m {} {lappend ::result C;next}
+ }
+ oo::class create D {
+ superclass B C
+ method m {} {lappend ::result D;next}
+ }
+ oo::class create Emix {
+ superclass C
+ method m {} {lappend ::result Emix;next}
+ method f {} {lappend ::result Emix-filt;next}
+ }
+ oo::class create Fmix {
+ superclass Emix
+ method m {} {lappend ::result Fmix;next}
+ }
+ D create o
+ oo::define o {
+ method m {} {lappend ::result o;next}
+ mixin Fmix
+ filter f
+ }
+ set result {}
+ o m
+ return $result
+} -cleanup {
+ A destroy
+} -result {Emix-filt B-filt Fmix Emix o D B C A}
+test oo-21.4 {OO: inheritance ordering} -setup {
+ oo::class create A
+} -body {
+ oo::define A method m {} {lappend ::result A}
+ oo::class create B {
+ superclass A
+ method m {} {lappend ::result B;next}
+ method f {} {lappend ::result B-filt;next}
+ method g {} {lappend ::result B-cfilt;next}
+ }
+ oo::class create C {
+ superclass A
+ method m {} {lappend ::result C;next}
+ }
+ oo::class create D {
+ superclass B C
+ method m {} {lappend ::result D;next}
+ method g {} {lappend ::result D-cfilt;next}
+ filter g
+ }
+ oo::class create Emix {
+ superclass C
+ method m {} {lappend ::result Emix;next}
+ method f {} {lappend ::result Emix-filt;next}
+ }
+ oo::class create Fmix {
+ superclass Emix
+ method m {} {lappend ::result Fmix;next}
+ }
+ D create o
+ oo::define o {
+ method m {} {lappend ::result o;next}
+ mixin Fmix
+ filter f
+ }
+ set result {}
+ o m
+ return $result
+} -cleanup {
+ A destroy
+} -result {Emix-filt B-filt D-cfilt B-cfilt Fmix Emix o D B C A}
+
+cleanupTests
+return
+
+# Local Variables:
+# mode: tcl
+# End:
generated by cgit v0.12 at 2024-07-02 19:33:12 (GMT)