diff options
| -rw-r--r-- | ChangeLog | 8 | ||||
| -rw-r--r-- | doc/define.n | 32 | ||||
| -rw-r--r-- | generic/tclOOInt.h | 16 | ||||
| -rw-r--r-- | generic/tclOOMethod.c | 18 | ||||
| -rw-r--r-- | tests/oo.test | 94 |
5 files changed, 146 insertions, 22 deletions
@@ -1,3 +1,11 @@ +2009-04-11 Donal K. Fellows <dkf@users.sf.net> + + * generic/tclOOMethod.c (InvokeForwardMethod): Clarify the resolution + behaviour of the name of the command that is forwarded to: it's now + resolved using the object's namespace as context, which is much more + useful than the previous (somewhat random) behaviour of using the + caller's current namespace. + 2009-04-10 Pat Thoyts <patthoyts@users.sourceforge.net> * library/http/http.tcl: Improved HTTP/1.1 support and added diff --git a/doc/define.n b/doc/define.n index ddbf476..e3f2e39 100644 --- a/doc/define.n +++ b/doc/define.n @@ -4,7 +4,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: define.n,v 1.2 2008/09/23 05:05:47 dkf Exp $ +'\" RCS: @(#) $Id: define.n,v 1.3 2009/04/11 11:18:51 dkf Exp $ '\" .so man.macros .TH define n 0.3 TclOO "TclOO Commands" @@ -94,23 +94,27 @@ arguments are present, the list of filter names is set to empty. .TP \fBforward\fI name cmdName \fR?\fIarg ...\fR? . -This creates or updates a forwarded method called \fIname\fR. The method -is defined be forwarded to the command called \fIcmdName\fR, with additional +This creates or updates a forwarded method called \fIname\fR. The method is +defined be forwarded to the command called \fIcmdName\fR, with additional arguments, \fIarg\fR etc., added before those arguments specified by the -caller of the method. Forwarded methods should be deleted using the -\fBmethod\fR subcommand. The method will be exported if \fIname\fR starts with -a lower-case letter, and non-exported otherwise. +caller of the method. The \fIcmdName\fR will always be resolved using the +rules of the invoking objects' namespaces, i.e., when \fIcmdName\fR is not +fully-qualified, the command will be searched for in each object's namespace, +using the instances' namespace's path, or by looking in the global namespace. +The method will be exported if \fIname\fR starts with a lower-case letter, and +non-exported otherwise. .TP \fBmethod\fI name argList bodyScript\fR . -This creates, updates or deletes a method. The name of the method is -\fIname\fR, the formal arguments to the method (defined using the same format -as for the Tcl \fBproc\fR command) will be \fIargList\fR, and the body of the -method will be \fIbodyScript\fR. When the body of the method is evaluated, the -current namespace of the method will be a namespace that is unique to the -current object. The method will be exported if \fIname\fR starts with a -lower-case letter, and non-exported otherwise; this behavior can be overridden -via \fBexport\fR and \fBunexport\fR. +This creates or updates a method that is implemented as a procedure-like +script. The name of the method is \fIname\fR, the formal arguments to the +method (defined using the same format as for the Tcl \fBproc\fR command) will +be \fIargList\fR, and the body of the method will be \fIbodyScript\fR. When +the body of the method is evaluated, the current namespace of the method will +be a namespace that is unique to the current object. The method will be +exported if \fIname\fR starts with a lower-case letter, and non-exported +otherwise; this behavior can be overridden via \fBexport\fR and +\fBunexport\fR. .TP \fBmixin\fR ?\fIclassName ...\fR? . diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index 3221fcc..1579ddb 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -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: tclOOInt.h,v 1.10 2008/10/31 22:08:32 dkf Exp $ + * RCS: @(#) $Id: tclOOInt.h,v 1.11 2009/04/11 11:18:51 dkf Exp $ */ #ifndef TCL_OO_INTERNAL_H @@ -117,13 +117,19 @@ typedef struct ProcedureMethod { #define USE_DECLARER_NS 0x80 /* - * Forwarded methods have the following extra information. It is a - * single-field structure because this allows for future expansion without - * changing vast amounts of code. + * Forwarded methods have the following extra information. */ typedef struct ForwardMethod { - Tcl_Obj *prefixObj; + Tcl_Obj *prefixObj; /* The list of values to use to replace the + * object and method name with. Will be a + * non-empty list. */ + int fullyQualified; /* If 1, the command name is fully qualified + * and we should let the default Tcl mechanism + * handle the command lookup because it is + * more efficient. If 0, we need to do a + * specialized lookup based on the current + * object's namespace. */ } ForwardMethod; /* diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index 2606f0a..3422660 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.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: tclOOMethod.c,v 1.21 2008/12/02 19:40:41 dgp Exp $ + * RCS: @(#) $Id: tclOOMethod.c,v 1.22 2009/04/11 11:18:51 dkf Exp $ */ #ifdef HAVE_CONFIG_H @@ -1316,6 +1316,7 @@ TclOONewForwardInstanceMethod( { int prefixLen; register ForwardMethod *fmPtr; + Tcl_Obj *cmdObj; if (Tcl_ListObjLength(interp, prefixObj, &prefixLen) != TCL_OK) { return NULL; @@ -1328,6 +1329,8 @@ TclOONewForwardInstanceMethod( fmPtr = (ForwardMethod *) ckalloc(sizeof(ForwardMethod)); fmPtr->prefixObj = prefixObj; + Tcl_ListObjIndex(interp, prefixObj, 0, &cmdObj); + fmPtr->fullyQualified = (strncmp(TclGetString(cmdObj), "::", 2) == 0); Tcl_IncrRefCount(prefixObj); return (Method *) Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr, nameObj, flags, &fwdMethodType, fmPtr); @@ -1354,6 +1357,7 @@ TclOONewForwardMethod( { int prefixLen; register ForwardMethod *fmPtr; + Tcl_Obj *cmdObj; if (Tcl_ListObjLength(interp, prefixObj, &prefixLen) != TCL_OK) { return NULL; @@ -1366,6 +1370,8 @@ TclOONewForwardMethod( fmPtr = (ForwardMethod *) ckalloc(sizeof(ForwardMethod)); fmPtr->prefixObj = prefixObj; + Tcl_ListObjIndex(interp, prefixObj, 0, &cmdObj); + fmPtr->fullyQualified = (strncmp(TclGetString(cmdObj), "::", 2) == 0); Tcl_IncrRefCount(prefixObj); return (Method *) Tcl_NewMethod(interp, (Tcl_Class) clsPtr, nameObj, flags, &fwdMethodType, fmPtr); @@ -1394,6 +1400,7 @@ InvokeForwardMethod( ForwardMethod *fmPtr = clientData; Tcl_Obj **argObjs, **prefixObjs; int numPrefixes, len, skip = contextPtr->skip; + Command *cmdPtr; /* * Build the real list of arguments to use. Note that we know that the @@ -1406,8 +1413,14 @@ InvokeForwardMethod( argObjs = InitEnsembleRewrite(interp, objc, objv, skip, numPrefixes, prefixObjs, &len); + if (fmPtr->fullyQualified) { + cmdPtr = NULL; + } else { + cmdPtr = (Command *) Tcl_FindCommand(interp, TclGetString(argObjs[0]), + contextPtr->oPtr->namespacePtr, 0 /* normal lookup */); + } Tcl_NRAddCallback(interp, FinalizeForwardCall, argObjs, NULL, NULL, NULL); - return Tcl_NREvalObjv(interp, len, argObjs, TCL_EVAL_INVOKE); + return TclNREvalObjv(interp, len, argObjs, TCL_EVAL_INVOKE, cmdPtr); } static int @@ -1452,6 +1465,7 @@ CloneForwardMethod( ForwardMethod *fm2Ptr = (ForwardMethod *) ckalloc(sizeof(ForwardMethod)); fm2Ptr->prefixObj = fmPtr->prefixObj; + fm2Ptr->fullyQualified = fmPtr->fullyQualified; Tcl_IncrRefCount(fm2Ptr->prefixObj); *newClientData = fm2Ptr; return TCL_OK; diff --git a/tests/oo.test b/tests/oo.test index 6c3187b..6b81f37 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -7,7 +7,7 @@ # 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.24 2009/03/24 10:46:04 dkf Exp $ +# RCS: @(#) $Id: oo.test,v 1.25 2009/04/11 11:18:51 dkf Exp $ package require TclOO 0.6.1 ;# Must match value in generic/tclOO.h if {[lsearch [namespace children] ::tcltest] == -1} { @@ -448,6 +448,98 @@ test oo-6.1 {OO: forward} { foo destroy return $result } {1 2} +test oo-6.2 {OO: forward resolution scope} -setup { + oo::class create fooClass +} -body { + proc foo {} {return bad} + oo::define fooClass { + constructor {} { + proc foo {} {return good} + } + forward bar foo + } + [fooClass new] bar +} -cleanup { + fooClass destroy + rename foo {} +} -result good +test oo-6.3 {OO: forward resolution scope} -setup { + oo::class create fooClass +} -body { + proc foo {} {return bad} + oo::define fooClass { + constructor {} { + proc foo {} {return good} + } + } + oo::define fooClass forward bar foo + [fooClass new] bar +} -cleanup { + fooClass destroy + rename foo {} +} -result good +test oo-6.4 {OO: forward resolution scope} -setup { + oo::class create fooClass +} -body { + proc foo {} {return good} + oo::define fooClass { + constructor {} { + proc foo {} {return bad} + } + forward bar ::foo + } + [fooClass new] bar +} -cleanup { + fooClass destroy + rename foo {} +} -result good +test oo-6.5 {OO: forward resolution scope} -setup { + oo::class create fooClass + namespace eval foo {} +} -body { + proc foo::foo {} {return good} + oo::define fooClass { + constructor {} { + proc foo {} {return bad} + } + forward bar foo::foo + } + [fooClass new] bar +} -cleanup { + fooClass destroy + namespace delete foo +} -result good +test oo-6.6 {OO: forward resolution scope} -setup { + oo::class create fooClass + namespace eval foo {} +} -body { + proc foo::foo {} {return bad} + oo::define fooClass { + constructor {} { + namespace eval foo { + proc foo {} {return good} + } + } + forward bar foo::foo + } + [fooClass new] bar +} -cleanup { + fooClass destroy + namespace delete foo +} -result good +test oo-6.7 {OO: forward resolution scope is per-object} -setup { + oo::class create fooClass +} -body { + oo::define fooClass { + constructor {} { + proc curns {} {namespace current} + } + forward ns curns + } + expr {[[fooClass new] ns] ne [[fooClass new] ns]} +} -cleanup { + fooClass destroy +} -result 1 test oo-7.1 {OO: inheritance 101} -setup { oo::class create superClass |