TclOO Package

Check-in [ac6eac612c]
Login
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to [email protected]
or submit via the online form by Sep 9.

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:
* generic/tclOOBasic.c (TclOO_Class_Constructor): [Bug 2023112]: Cut the amount of hackiness in class constructors, and refactor some of the error message handling from [oo::define] to be saner in the face of odd happenings.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: ac6eac612c76c3e4bc73e9a76e95d0605dc4f11b
User & Date: dkf 2012-05-20 09:21:23
Context
2012-07-26
21:09
[Bug 3547839]: Use the memory management scheme used in version of TclOO that is included in Tcl 8.6; prevents memory accesses to deleted structures! check-in: 7db541b369 user: dkf tags: trunk
2012-07-12
12:49
merge trunk check-in: d78e8093fb user: dkf tags: development-friends
12:49
merge trunk check-in: cd511545b9 user: dkf tags: development-gc
12:49
merge trunk check-in: 8d72871e22 user: dkf tags: development-submethods
08:50
Preparing for 0.7 release (to correspond to Tcl 8.6b3) check-in: 20bdfae4bf user: dkf tags: 0.7-rc
2012-06-02
09:51
Create [currentdefinition] to better support scripted definition commands. Document how to create scripted definition commands! check-in: d692bc3528 user: dkf tags: development-currentdefinition
2012-05-20
09:21
* generic/tclOOBasic.c (TclOO_Class_Constructor): [Bug 2023112]: Cut the amount of hackiness in class constructors, and refactor some of the error message handling from [oo::define] to be saner in the face of odd happenings.
check-in: ac6eac612c user: dkf tags: trunk
2012-04-10
06:44
Fix [Bug 3396896] check-in: e6d86d3472 user: dkf tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to ChangeLog.








1
2
3
4
5
6
7






2012-04-10  Donal K. Fellows  <[email protected]>

	* generic/tclOODefineCmds.c (ClassVarsSet, ObjVarsSet): [Bug 3396896]:
	Ensure that the lists of variable names used to drive variable
	resolution will never have the same name twice.

2012-04-04  Donal K. Fellows  <[email protected]>
>
>
>
>
>
>
>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
2012-05-20  Donal K. Fellows  <[email protected]>

	* generic/tclOOBasic.c (TclOO_Class_Constructor): [Bug 2023112]: Cut
	the amount of hackiness in class constructors, and refactor some of
	the error message handling from [oo::define] to be saner in the face
	of odd happenings.

2012-04-10  Donal K. Fellows  <[email protected]>

	* generic/tclOODefineCmds.c (ClassVarsSet, ObjVarsSet): [Bug 3396896]:
	Ensure that the lists of variable names used to drive variable
	resolution will never have the same name twice.

2012-04-04  Donal K. Fellows  <[email protected]>

Changes to generic/tclOO.c.

106
107
108
109
110
111
112










113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
...
300
301
302
303
304
305
306

307
308
309
310
311
312
313
314
315
316
317
318
...
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406

407
408
409
410
411
412
413
...
497
498
499
500
501
502
503

504
505
506
507
508
509
510
}, clsMethods[] = {
    DCM("create", 1,	TclOO_Class_Create),
    DCM("new", 1,	TclOO_Class_New),
    DCM("createWithNamespace", 0, TclOO_Class_CreateNs),
    {NULL}
};











/*
 * Scripted parts of TclOO. Note that we embed the scripts for simpler
 * deployment (i.e., no separate script to load).
 */

static const char *initScript =
"namespace eval ::oo { variable version " TCLOO_VERSION " };"
"namespace eval ::oo { variable patchlevel " TCLOO_PATCHLEVEL " };";
/*"tcl_findLibrary tcloo $oo::version $oo::version" */
/*"     tcloo.tcl OO_LIBRARY oo::library;"; */

static const char *classConstructorBody =
"lassign [::oo::UpCatch ::oo::define [self] $definitionScript] msg opts;"
"if {[dict get $opts -code] == 1} {dict set opts -errorline 0xDeadBeef};"
"return -options $opts $msg";

static const char *clonedBody =
"foreach p [info procs [info object namespace $originObject]::*] {"
"    set args [info args $p];"
"    set idx -1;"
"    foreach a $args {"
"        lset args [incr idx] "
"            [if {[info default $p $a d]} {list $a $d} {list $a}]"
................................................................................
	    DeletedHelpersNamespace);
    fPtr->epoch = 0;
    fPtr->tsdPtr = tsdPtr;
    fPtr->unknownMethodNameObj = Tcl_NewStringObj("unknown", -1);
    fPtr->constructorName = Tcl_NewStringObj("<constructor>", -1);
    fPtr->destructorName = Tcl_NewStringObj("<destructor>", -1);
    fPtr->clonedName = Tcl_NewStringObj("<cloned>", -1);

    Tcl_IncrRefCount(fPtr->unknownMethodNameObj);
    Tcl_IncrRefCount(fPtr->constructorName);
    Tcl_IncrRefCount(fPtr->destructorName);
    Tcl_IncrRefCount(fPtr->clonedName);
    Tcl_CreateObjCommand(interp, "::oo::UpCatch", TclOOUpcatchCmd, NULL,NULL);
    Tcl_CreateObjCommand(interp, "::oo::UnknownDefinition",
	    TclOOUnknownDefinition, NULL, NULL);
    namePtr = Tcl_NewStringObj("::oo::UnknownDefinition", -1);
    Tcl_SetNamespaceUnknownHandler(interp, fPtr->defineNs, namePtr);
    Tcl_SetNamespaceUnknownHandler(interp, fPtr->objdefNs, namePtr);

    /*
................................................................................
	    bodyPtr, NULL);
    Tcl_DecrRefCount(argsPtr);

    /*
     * Finish setting up the class of classes by marking the 'new' method as
     * private; classes, unlike general objects, must have explicit names. We
     * also need to create the constructor for classes.
     *
     * The 0xDeadBeef is a special signal to the errorInfo logger that is used
     * by constructors that stops it from generating extra error information
     * that is confusing.
     */

    namePtr = Tcl_NewStringObj("new", -1);
    Tcl_NewInstanceMethod(interp, (Tcl_Object) fPtr->classCls->thisPtr,
	    namePtr /* keeps ref */, 0 /* ==private */, NULL, NULL);

    argsPtr = Tcl_NewStringObj("{definitionScript {}}", -1);
    Tcl_IncrRefCount(argsPtr);
    bodyPtr = Tcl_NewStringObj(classConstructorBody, -1);
    fPtr->classCls->constructorPtr = TclOONewProcMethod(interp,
	    fPtr->classCls, 0, NULL, argsPtr, bodyPtr, NULL);
    Tcl_DecrRefCount(argsPtr);


    /*
     * Create non-object commands and plug ourselves into the Tcl [info]
     * ensemble.
     */

    Tcl_CreateObjCommand(interp, "::oo::Helpers::next", TclOONextObjCmd, NULL,
................................................................................

    DelRef(fPtr->objectCls->thisPtr);
    DelRef(fPtr->objectCls);
    Tcl_DecrRefCount(fPtr->unknownMethodNameObj);
    Tcl_DecrRefCount(fPtr->constructorName);
    Tcl_DecrRefCount(fPtr->destructorName);
    Tcl_DecrRefCount(fPtr->clonedName);

    ckfree((char *) fPtr);
}
 
/*
 * ----------------------------------------------------------------------
 *
 * AllocObject --






>
>
>
>
>
>
>
>
>
>











<
<
<
<
<







 







>




|







 







<
<
<
<





<
<
<
<
|
<
<
>







 







>







106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133





134
135
136
137
138
139
140
...
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
...
390
391
392
393
394
395
396




397
398
399
400
401




402


403
404
405
406
407
408
409
410
...
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
}, clsMethods[] = {
    DCM("create", 1,	TclOO_Class_Create),
    DCM("new", 1,	TclOO_Class_New),
    DCM("createWithNamespace", 0, TclOO_Class_CreateNs),
    {NULL}
};

/*
 * And for the oo::class constructor...
 */

static const Tcl_MethodType classConstructor = {
    TCL_OO_METHOD_VERSION_CURRENT,
    "oo::class constructor",
    TclOO_Class_Constructor, NULL, NULL
};

/*
 * Scripted parts of TclOO. Note that we embed the scripts for simpler
 * deployment (i.e., no separate script to load).
 */

static const char *initScript =
"namespace eval ::oo { variable version " TCLOO_VERSION " };"
"namespace eval ::oo { variable patchlevel " TCLOO_PATCHLEVEL " };";
/*"tcl_findLibrary tcloo $oo::version $oo::version" */
/*"     tcloo.tcl OO_LIBRARY oo::library;"; */






static const char *clonedBody =
"foreach p [info procs [info object namespace $originObject]::*] {"
"    set args [info args $p];"
"    set idx -1;"
"    foreach a $args {"
"        lset args [incr idx] "
"            [if {[info default $p $a d]} {list $a $d} {list $a}]"
................................................................................
	    DeletedHelpersNamespace);
    fPtr->epoch = 0;
    fPtr->tsdPtr = tsdPtr;
    fPtr->unknownMethodNameObj = Tcl_NewStringObj("unknown", -1);
    fPtr->constructorName = Tcl_NewStringObj("<constructor>", -1);
    fPtr->destructorName = Tcl_NewStringObj("<destructor>", -1);
    fPtr->clonedName = Tcl_NewStringObj("<cloned>", -1);
    fPtr->defineName = Tcl_NewStringObj("::oo::define", -1);
    Tcl_IncrRefCount(fPtr->unknownMethodNameObj);
    Tcl_IncrRefCount(fPtr->constructorName);
    Tcl_IncrRefCount(fPtr->destructorName);
    Tcl_IncrRefCount(fPtr->clonedName);
    Tcl_IncrRefCount(fPtr->defineName);
    Tcl_CreateObjCommand(interp, "::oo::UnknownDefinition",
	    TclOOUnknownDefinition, NULL, NULL);
    namePtr = Tcl_NewStringObj("::oo::UnknownDefinition", -1);
    Tcl_SetNamespaceUnknownHandler(interp, fPtr->defineNs, namePtr);
    Tcl_SetNamespaceUnknownHandler(interp, fPtr->objdefNs, namePtr);

    /*
................................................................................
	    bodyPtr, NULL);
    Tcl_DecrRefCount(argsPtr);

    /*
     * Finish setting up the class of classes by marking the 'new' method as
     * private; classes, unlike general objects, must have explicit names. We
     * also need to create the constructor for classes.




     */

    namePtr = Tcl_NewStringObj("new", -1);
    Tcl_NewInstanceMethod(interp, (Tcl_Object) fPtr->classCls->thisPtr,
	    namePtr /* keeps ref */, 0 /* ==private */, NULL, NULL);




    fPtr->classCls->constructorPtr = (Method *) Tcl_NewMethod(interp,


	    (Tcl_Class) fPtr->classCls, NULL, 0, &classConstructor, NULL);

    /*
     * Create non-object commands and plug ourselves into the Tcl [info]
     * ensemble.
     */

    Tcl_CreateObjCommand(interp, "::oo::Helpers::next", TclOONextObjCmd, NULL,
................................................................................

    DelRef(fPtr->objectCls->thisPtr);
    DelRef(fPtr->objectCls);
    Tcl_DecrRefCount(fPtr->unknownMethodNameObj);
    Tcl_DecrRefCount(fPtr->constructorName);
    Tcl_DecrRefCount(fPtr->destructorName);
    Tcl_DecrRefCount(fPtr->clonedName);
    Tcl_DecrRefCount(fPtr->defineName);
    ckfree((char *) fPtr);
}
 
/*
 * ----------------------------------------------------------------------
 *
 * AllocObject --

Changes to generic/tclOOBasic.c.

15
16
17
18
19
20
21




























































22
23
24
25
26
27
28
....
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
#endif
#include "tclInt.h"
#include "tclOOInt.h"
 
/*
 * ----------------------------------------------------------------------
 *




























































 * TclOO_Class_Create --
 *
 *	Implementation for oo::class->create method.
 *
 * ----------------------------------------------------------------------
 */

................................................................................
    /*
     * Return the name of the cloned object.
     */

    Tcl_SetObjResult(interp, TclOOObjectName(interp, (Object *) o2Ptr));
    return TCL_OK;
}
 
/*
 * ----------------------------------------------------------------------
 *
 * TclOOUpcatchCmd --
 *
 *	Implementation of the [oo::UpCatch] command, which is a combination of
 *	[uplevel 1] and [catch] that makes it easier to write transparent
 *	error handling in scripts.
 *
 * ----------------------------------------------------------------------
 */

int
TclOOUpcatchCmd(
    ClientData ignored,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    Interp *iPtr = (Interp *) interp;
    CallFrame *savedFramePtr = iPtr->varFramePtr;
    Tcl_Obj *resultObj[2];
    int result;

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "cmd ...");
	return TCL_ERROR;
    }
    if (iPtr->varFramePtr->callerVarPtr != NULL) {
	iPtr->varFramePtr = iPtr->varFramePtr->callerVarPtr;
    }
    result = Tcl_EvalObjv(interp, objc-1, objv+1, TCL_EVAL_INVOKE);
    iPtr->varFramePtr = savedFramePtr;
    if (Tcl_LimitExceeded(interp)) {
	Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
		"\n    (\"UpCatch\" body line %d)", interp->errorLine));
	return TCL_ERROR;
    }
    resultObj[0] = Tcl_GetObjResult(interp);
    resultObj[1] = Tcl_GetReturnOptions(interp, result);
    Tcl_SetObjResult(interp, Tcl_NewListObj(2, resultObj));
    return TCL_OK;
}
 
/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */






>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







 







<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<








15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
....
1110
1111
1112
1113
1114
1115
1116












































1117
1118
1119
1120
1121
1122
1123
1124
#endif
#include "tclInt.h"
#include "tclOOInt.h"
 
/*
 * ----------------------------------------------------------------------
 *
 * TclOO_Class_Constructor --
 *
 *	Implementation for oo::class constructor.
 *
 * ----------------------------------------------------------------------
 */

int
TclOO_Class_Constructor(
    ClientData clientData,
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
    Tcl_Obj *invoke[3];
    int result;

    if (objc-1 > Tcl_ObjectContextSkippedArgs(context)) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"?definitionScript?");
	return TCL_ERROR;
    } else if (objc == Tcl_ObjectContextSkippedArgs(context)) {
	return TCL_OK;
    }

    /*
     * Delegate to [oo::define] to do the work.
     */

    invoke[0] = oPtr->fPtr->defineName;
    invoke[1] = TclOOObjectName(interp, oPtr);
    invoke[2] = objv[objc-1];

    /*
     * Must add references or errors in configuration script will cause
     * trouble.
     */

    Tcl_IncrRefCount(invoke[0]);
    Tcl_IncrRefCount(invoke[1]);
    Tcl_IncrRefCount(invoke[2]);

    /*
     * Tricky point: do not want the extra reported level in the Tcl stack
     * trace, so use TCL_EVAL_INVOKE.
     */

    result = Tcl_EvalObjv(interp, 3, invoke, TCL_EVAL_INVOKE);

    Tcl_DecrRefCount(invoke[0]);
    Tcl_DecrRefCount(invoke[1]);
    Tcl_DecrRefCount(invoke[2]);
    return result;
}
 
/*
 * ----------------------------------------------------------------------
 *
 * TclOO_Class_Create --
 *
 *	Implementation for oo::class->create method.
 *
 * ----------------------------------------------------------------------
 */

................................................................................
    /*
     * Return the name of the cloned object.
     */

    Tcl_SetObjResult(interp, TclOOObjectName(interp, (Object *) o2Ptr));
    return TCL_OK;
}












































 
/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to generic/tclOODefineCmds.c.

12
13
14
15
16
17
18







19
20
21
22
23
24
25
..
36
37
38
39
40
41
42


43
44
45
46
47
48
49
..
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
...
668
669
670
671
672
673
674

675
676
677
678
679
680
681
682
683






684
685
686
687
688
689
690
...
718
719
720
721
722
723
724







































725
726
727
728
729
730
731
...
769
770
771
772
773
774
775



776
777
778
779
780
781
782
783
784
785
786
787
788
789

790
791
792
793
794
795
796
...
888
889
890
891
892
893
894



895
896
897
898
899
900
901
902
903
904
905
906
907
908

909
910
911
912
913
914
915
....
1007
1008
1009
1010
1011
1012
1013



1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028

1029
1030
1031
1032
1033
1034
1035
#ifdef HAVE_CONFIG_H
#include "config.h"
#endif
#include "tclInt.h"
#include "tclOOInt.h"








/*
 * Some things that make it easier to declare a slot.
 */

struct DeclaredSlot {
    const char *name;
    const Tcl_MethodType getterType;
................................................................................
/*
 * Forward declarations.
 */

static inline void	BumpGlobalEpoch(Tcl_Interp *interp, Class *classPtr);
static Tcl_Command	FindCommand(Tcl_Interp *interp, Tcl_Obj *stringObj,
			    Tcl_Namespace *const namespacePtr);


static inline Class *	GetClassInOuterContext(Tcl_Interp *interp,
			    Tcl_Obj *className, const char *errMsg);
static inline int	InitDefineContext(Tcl_Interp *interp,
			    Tcl_Namespace *namespacePtr, Object *oPtr,
			    int objc, Tcl_Obj *const objv[]);
static inline void	RecomputeClassCacheFlag(Object *oPtr);
static int		RenameDeleteMethod(Tcl_Interp *interp, Object *oPtr,
................................................................................
			    int objc, Tcl_Obj *const *objv);

/*
 * Now define the slots used in declarations.
 */

static const struct DeclaredSlot slots[] = {
    SLOT("define::filter",      ClassFilterGet, ClassFilterSet),
    SLOT("define::mixin",       ClassMixinGet,  ClassMixinSet),
    SLOT("define::superclass",  ClassSuperGet,  ClassSuperSet),
    SLOT("define::variable",    ClassVarsGet,   ClassVarsSet),
    SLOT("objdefine::filter",   ObjFilterGet,   ObjFilterSet),
    SLOT("objdefine::mixin",    ObjMixinGet,    ObjMixinSet),
    SLOT("objdefine::variable", ObjVarsGet,     ObjVarsSet),
    {NULL}
};
................................................................................
 */

Tcl_Object
TclOOGetDefineCmdContext(
    Tcl_Interp *interp)
{
    Interp *iPtr = (Interp *) interp;


    if ((iPtr->varFramePtr == NULL)
	    || (iPtr->varFramePtr->isProcCallFrame != FRAME_IS_OO_DEFINE)) {
	Tcl_AppendResult(interp, "this command may only be called from within"
		" the context of an ::oo::define or ::oo::objdefine command",
		NULL);
	return NULL;
    }
    return (Tcl_Object) iPtr->varFramePtr->clientData;






}
 
/*
 * ----------------------------------------------------------------------
 *
 * GetClassInOuterContext --
 *	Wrapper round Tcl_GetObjectFromObj to perform the lookup in the
................................................................................
    }
    if (oPtr->classPtr == NULL) {
	Tcl_AppendResult(interp, errMsg, NULL);
	return NULL;
    }
    return oPtr->classPtr;
}







































 
/*
 * ----------------------------------------------------------------------
 *
 * TclOODefineObjCmd --
 *	Implementation of the "oo::define" command. Works by effectively doing
 *	the same as 'namespace eval', but with extra magic applied so that the
................................................................................

    if (InitDefineContext(interp, fPtr->defineNs, oPtr, objc,objv) != TCL_OK){
	return TCL_ERROR;
    }

    AddRef(oPtr);
    if (objc == 3) {



	result = TclEvalObjEx(interp, objv[2], 0,
		((Interp *)interp)->cmdFramePtr, 2);

	if (result == TCL_ERROR) {
	    int length;
	    const char *objName = Tcl_GetStringFromObj(objv[1], &length);
	    int limit = 60;
	    int overflow = (length > limit);

	    Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
		    "\n    (in definition script for object \"%.*s%s\" line %d)",
		    (overflow ? limit : length), objName,
		    (overflow ? "..." : ""), interp->errorLine));
	}

    } else {
	Tcl_Obj *objPtr, *obj2Ptr, **objs;
	Interp *iPtr = (Interp *) interp;
	Tcl_Command cmd;
	int dummy;

	/*
................................................................................

    if (InitDefineContext(interp, fPtr->objdefNs, oPtr, objc,objv) != TCL_OK){
	return TCL_ERROR;
    }

    AddRef(oPtr);
    if (objc == 3) {



	result = TclEvalObjEx(interp, objv[2], 0,
		((Interp *)interp)->cmdFramePtr, 2);

	if (result == TCL_ERROR) {
	    int length;
	    const char *objName = Tcl_GetStringFromObj(objv[1], &length);
	    int limit = 60;
	    int overflow = (length > limit);

	    Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
		    "\n    (in definition script for object \"%.*s%s\" line %d)",
		    (overflow ? limit : length), objName,
		    (overflow ? "..." : ""), interp->errorLine));
	}

    } else {
	Tcl_Obj *objPtr, *obj2Ptr, **objs;
	Interp *iPtr = (Interp *) interp;
	Tcl_Command cmd;
	int dummy;

	/*
................................................................................

    if (InitDefineContext(interp, fPtr->objdefNs, oPtr, objc,objv) != TCL_OK){
	return TCL_ERROR;
    }

    AddRef(oPtr);
    if (objc == 2) {



	result = TclEvalObjEx(interp, objv[1], 0,
		((Interp *)interp)->cmdFramePtr, 2);

	if (result == TCL_ERROR) {
	    int length;
	    const char *objName = Tcl_GetStringFromObj(
		    TclOOObjectName(interp, oPtr), &length);
	    int limit = 60;
	    int overflow = (length > limit);

	    Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
		    "\n    (in definition script for object \"%.*s%s\" line %d)",
		    (overflow ? limit : length), objName,
		    (overflow ? "..." : ""), interp->errorLine));
	}

    } else {
	Tcl_Obj *objPtr, *obj2Ptr, **objs;
	Interp *iPtr = (Interp *) interp;
	Tcl_Command cmd;
	int dummy;

	/*






>
>
>
>
>
>
>







 







>
>







 







|
|







 







>








|
>
>
>
>
>
>







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







 







>
>
>


<

<
<
|
<
|
<
<
<
<
<
>







 







>
>
>


<

<
<
|
<
|
<
<
<
<
<
>







 







>
>
>


<

<
<
|
<
<
|
<
<
<
<
<
>







12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
..
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
...
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
...
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
...
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
...
824
825
826
827
828
829
830
831
832
833
834
835

836


837

838





839
840
841
842
843
844
845
846
...
938
939
940
941
942
943
944
945
946
947
948
949

950


951

952





953
954
955
956
957
958
959
960
....
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063

1064


1065


1066





1067
1068
1069
1070
1071
1072
1073
1074
#ifdef HAVE_CONFIG_H
#include "config.h"
#endif
#include "tclInt.h"
#include "tclOOInt.h"

/*
 * The maximum length of fully-qualified object name to use in an errorinfo
 * message. Longer than this will be curtailed.
 */

#define OBJNAME_LENGTH_IN_ERRORINFO_LIMIT 30

/*
 * Some things that make it easier to declare a slot.
 */

struct DeclaredSlot {
    const char *name;
    const Tcl_MethodType getterType;
................................................................................
/*
 * Forward declarations.
 */

static inline void	BumpGlobalEpoch(Tcl_Interp *interp, Class *classPtr);
static Tcl_Command	FindCommand(Tcl_Interp *interp, Tcl_Obj *stringObj,
			    Tcl_Namespace *const namespacePtr);
static void		GenerateErrorInfo(Tcl_Interp *interp, Object *oPtr,
			    Tcl_Obj *savedNameObj, const char *typeOfSubject);
static inline Class *	GetClassInOuterContext(Tcl_Interp *interp,
			    Tcl_Obj *className, const char *errMsg);
static inline int	InitDefineContext(Tcl_Interp *interp,
			    Tcl_Namespace *namespacePtr, Object *oPtr,
			    int objc, Tcl_Obj *const objv[]);
static inline void	RecomputeClassCacheFlag(Object *oPtr);
static int		RenameDeleteMethod(Tcl_Interp *interp, Object *oPtr,
................................................................................
			    int objc, Tcl_Obj *const *objv);

/*
 * Now define the slots used in declarations.
 */

static const struct DeclaredSlot slots[] = {
    SLOT("define::filter",	ClassFilterGet, ClassFilterSet),
    SLOT("define::mixin",	ClassMixinGet,  ClassMixinSet),
    SLOT("define::superclass",  ClassSuperGet,  ClassSuperSet),
    SLOT("define::variable",    ClassVarsGet,   ClassVarsSet),
    SLOT("objdefine::filter",   ObjFilterGet,   ObjFilterSet),
    SLOT("objdefine::mixin",    ObjMixinGet,    ObjMixinSet),
    SLOT("objdefine::variable", ObjVarsGet,     ObjVarsSet),
    {NULL}
};
................................................................................
 */

Tcl_Object
TclOOGetDefineCmdContext(
    Tcl_Interp *interp)
{
    Interp *iPtr = (Interp *) interp;
    Tcl_Object object;

    if ((iPtr->varFramePtr == NULL)
	    || (iPtr->varFramePtr->isProcCallFrame != FRAME_IS_OO_DEFINE)) {
	Tcl_AppendResult(interp, "this command may only be called from within"
		" the context of an ::oo::define or ::oo::objdefine command",
		NULL);
	return NULL;
    }
    object = iPtr->varFramePtr->clientData;
    if (Tcl_ObjectDeleted(object)) {
	Tcl_AppendResult(interp, "this command cannot be called when the "
		"object has been deleted", NULL);
	return NULL;
    }
    return object;
}
 
/*
 * ----------------------------------------------------------------------
 *
 * GetClassInOuterContext --
 *	Wrapper round Tcl_GetObjectFromObj to perform the lookup in the
................................................................................
    }
    if (oPtr->classPtr == NULL) {
	Tcl_AppendResult(interp, errMsg, NULL);
	return NULL;
    }
    return oPtr->classPtr;
}
 
/*
 * ----------------------------------------------------------------------
 *
 * GenerateErrorInfo --
 *
 *	Factored out code to generate part of the error trace messages.
 *
 * ----------------------------------------------------------------------
 */

static void
GenerateErrorInfo(
    Tcl_Interp *interp,		/* Where to store the error info trace. */
    Object *oPtr,		/* What object (or class) was being configured
				 * when the error occurred? */
    Tcl_Obj *savedNameObj,	/* Name of object saved from before script was
				 * evaluated, which is needed if the object
				 * goes away part way through execution. OTOH,
				 * if the object isn't deleted then its
				 * current name (post-execution) has to be
				 * used. This matters, because the object
				 * could have been renamed... */
    const char *typeOfSubject)	/* Part of the message, saying whether it was
				 * an object, class or class-as-object that
				 * was being configured. */
{
    int length;
    Tcl_Obj *realNameObj = Tcl_ObjectDeleted((Tcl_Object) oPtr)
	    ? savedNameObj : TclOOObjectName(interp, oPtr);
    const char *objName = Tcl_GetStringFromObj(realNameObj, &length);
    int limit = OBJNAME_LENGTH_IN_ERRORINFO_LIMIT;
    int overflow = (length > limit);

    Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
	    "\n    (in definition script for %s \"%.*s%s\" line %d)",
	    typeOfSubject, (overflow ? limit : length), objName,
	    (overflow ? "..." : ""), interp->errorLine));
}
 
/*
 * ----------------------------------------------------------------------
 *
 * TclOODefineObjCmd --
 *	Implementation of the "oo::define" command. Works by effectively doing
 *	the same as 'namespace eval', but with extra magic applied so that the
................................................................................

    if (InitDefineContext(interp, fPtr->defineNs, oPtr, objc,objv) != TCL_OK){
	return TCL_ERROR;
    }

    AddRef(oPtr);
    if (objc == 3) {
	Tcl_Obj *objNameObj = TclOOObjectName(interp, oPtr);

	Tcl_IncrRefCount(objNameObj);
	result = TclEvalObjEx(interp, objv[2], 0,
		((Interp *)interp)->cmdFramePtr, 2);

	if (result == TCL_ERROR) {


	    GenerateErrorInfo(interp, oPtr, objNameObj, "class");

	}





	Tcl_DecrRefCount(objNameObj);
    } else {
	Tcl_Obj *objPtr, *obj2Ptr, **objs;
	Interp *iPtr = (Interp *) interp;
	Tcl_Command cmd;
	int dummy;

	/*
................................................................................

    if (InitDefineContext(interp, fPtr->objdefNs, oPtr, objc,objv) != TCL_OK){
	return TCL_ERROR;
    }

    AddRef(oPtr);
    if (objc == 3) {
	Tcl_Obj *objNameObj = TclOOObjectName(interp, oPtr);

	Tcl_IncrRefCount(objNameObj);
	result = TclEvalObjEx(interp, objv[2], 0,
		((Interp *)interp)->cmdFramePtr, 2);

	if (result == TCL_ERROR) {


	    GenerateErrorInfo(interp, oPtr, objNameObj, "object");

	}





	Tcl_DecrRefCount(objNameObj);
    } else {
	Tcl_Obj *objPtr, *obj2Ptr, **objs;
	Interp *iPtr = (Interp *) interp;
	Tcl_Command cmd;
	int dummy;

	/*
................................................................................

    if (InitDefineContext(interp, fPtr->objdefNs, oPtr, objc,objv) != TCL_OK){
	return TCL_ERROR;
    }

    AddRef(oPtr);
    if (objc == 2) {
	Tcl_Obj *objNameObj = TclOOObjectName(interp, oPtr);

	Tcl_IncrRefCount(objNameObj);
	result = TclEvalObjEx(interp, objv[1], 0,
		((Interp *)interp)->cmdFramePtr, 2);

	if (result == TCL_ERROR) {


	    GenerateErrorInfo(interp, oPtr, objNameObj, "class object");


	}





	Tcl_DecrRefCount(objNameObj);
    } else {
	Tcl_Obj *objPtr, *obj2Ptr, **objs;
	Interp *iPtr = (Interp *) interp;
	Tcl_Command cmd;
	int dummy;

	/*

Changes to generic/tclOOInt.h.

318
319
320
321
322
323
324

325
326
327
328
329
330
331
...
462
463
464
465
466
467
468



469
470
471
472
473
474
475
...
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
				 * unknown method handler method. */
    Tcl_Obj *constructorName;	/* Shared object containing the "name" of a
				 * constructor. */
    Tcl_Obj *destructorName;	/* Shared object containing the "name" of a
				 * destructor. */
    Tcl_Obj *clonedName;	/* Shared object containing the name of a
				 * "<cloned>" pseudo-constructor. */

} Foundation;

/*
 * A call context structure is built when a method is called. They contain the
 * chain of method implementations that are to be invoked by a particular
 * call, and the process of calling walks the chain, with the [next] command
 * proceeding to the next entry in the chain.
................................................................................
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const *objv);

/*
 * Method implementations (in tclOOBasic.c).
 */




MODULE_SCOPE int	TclOO_Class_Create(ClientData clientData,
			    Tcl_Interp *interp, Tcl_ObjectContext context,
			    int objc, Tcl_Obj *const *objv);
MODULE_SCOPE int	TclOO_Class_CreateNs(ClientData clientData,
			    Tcl_Interp *interp, Tcl_ObjectContext context,
			    int objc, Tcl_Obj *const *objv);
MODULE_SCOPE int	TclOO_Class_New(ClientData clientData,
................................................................................
MODULE_SCOPE void	TclOORemoveFromSubclasses(Class *subPtr,
			    Class *superPtr);
MODULE_SCOPE Tcl_Obj *	TclOORenderCallChain(Tcl_Interp *interp,
			    CallChain *callPtr);
MODULE_SCOPE void	TclOOStashContext(Tcl_Obj *objPtr,
			    CallContext *contextPtr);
MODULE_SCOPE void	TclOOSetupVariableResolver(Tcl_Namespace *nsPtr);
MODULE_SCOPE int	TclOOUpcatchCmd(ClientData ignored,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);
 
/*
 * Include all the private API, generated from tclOO.decls.
 */

#include "tclOOIntDecls.h"
 






>







 







>
>
>







 







<
<
<







318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
...
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
...
533
534
535
536
537
538
539



540
541
542
543
544
545
546
				 * unknown method handler method. */
    Tcl_Obj *constructorName;	/* Shared object containing the "name" of a
				 * constructor. */
    Tcl_Obj *destructorName;	/* Shared object containing the "name" of a
				 * destructor. */
    Tcl_Obj *clonedName;	/* Shared object containing the name of a
				 * "<cloned>" pseudo-constructor. */
    Tcl_Obj *defineName;	/* Fully qualified name of oo::define. */
} Foundation;

/*
 * A call context structure is built when a method is called. They contain the
 * chain of method implementations that are to be invoked by a particular
 * call, and the process of calling walks the chain, with the [next] command
 * proceeding to the next entry in the chain.
................................................................................
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const *objv);

/*
 * Method implementations (in tclOOBasic.c).
 */

MODULE_SCOPE int	TclOO_Class_Constructor(ClientData clientData,
			    Tcl_Interp *interp, Tcl_ObjectContext context,
			    int objc, Tcl_Obj *const *objv);
MODULE_SCOPE int	TclOO_Class_Create(ClientData clientData,
			    Tcl_Interp *interp, Tcl_ObjectContext context,
			    int objc, Tcl_Obj *const *objv);
MODULE_SCOPE int	TclOO_Class_CreateNs(ClientData clientData,
			    Tcl_Interp *interp, Tcl_ObjectContext context,
			    int objc, Tcl_Obj *const *objv);
MODULE_SCOPE int	TclOO_Class_New(ClientData clientData,
................................................................................
MODULE_SCOPE void	TclOORemoveFromSubclasses(Class *subPtr,
			    Class *superPtr);
MODULE_SCOPE Tcl_Obj *	TclOORenderCallChain(Tcl_Interp *interp,
			    CallChain *callPtr);
MODULE_SCOPE void	TclOOStashContext(Tcl_Obj *objPtr,
			    CallContext *contextPtr);
MODULE_SCOPE void	TclOOSetupVariableResolver(Tcl_Namespace *nsPtr);



 
/*
 * Include all the private API, generated from tclOO.decls.
 */

#include "tclOOIntDecls.h"
 

Changes to generic/tclOOMethod.c.

1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
{
    CallContext *contextPtr = ((Interp *) interp)->varFramePtr->clientData;
    Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr;
    Object *declarerPtr;
    const char *objectName, *kindName;
    int objectNameLen;

    if (interp->errorLine == (int) 0xDEADBEEF) {
	/*
	 * Horrible hack to deal with certain constructors that must not add
	 * information to the error trace.
	 */

	return;
    }

    if (mPtr->declaringObjectPtr != NULL) {
	declarerPtr = mPtr->declaringObjectPtr;
	kindName = "object";
    } else {
	if (mPtr->declaringClassPtr == NULL) {
	    Tcl_Panic("method not declared in class or object");
	}






<
<
<
<
<
<
<
<
<







1178
1179
1180
1181
1182
1183
1184









1185
1186
1187
1188
1189
1190
1191
{
    CallContext *contextPtr = ((Interp *) interp)->varFramePtr->clientData;
    Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr;
    Object *declarerPtr;
    const char *objectName, *kindName;
    int objectNameLen;










    if (mPtr->declaringObjectPtr != NULL) {
	declarerPtr = mPtr->declaringObjectPtr;
	kindName = "object";
    } else {
	if (mPtr->declaringClassPtr == NULL) {
	    Tcl_Panic("method not declared in class or object");
	}

Changes to tests/oo.test.

1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
....
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
....
2016
2017
2018
2019
2020
2021
2022




































































































2023
2024
2025
2026
2027
2028
2029
} -result {}

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.3a {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 2)
    invoked from within
"oo::class create foo {
    error bar
}"}}
test oo-18.3b {OO: define command support} {
    list [catch {oo::class create foo {
    eval eval error bar
................................................................................
"error bar"
    ("eval" body line 1)
    invoked from within
"eval error bar"
    ("eval" body line 1)
    invoked from within
"eval eval error bar"
    (in definition script for object "::foo" line 2)
    invoked from within
"oo::class create foo {
    eval eval error bar
}"}}
test oo-18.4 {OO: more error traces from the guts} -setup {
    oo::object create obj
} -body {
................................................................................
"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::objdefine inst export eval
    set result {}
    inst eval { variable x }
} -body {






|












|









|







 







|







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
....
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
....
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
} -result {}

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 class "::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 class "::foo" line 1)
    invoked from within
"oo::class create foo {error bar}"}}
test oo-18.3a {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 class "::foo" line 2)
    invoked from within
"oo::class create foo {
    error bar
}"}}
test oo-18.3b {OO: define command support} {
    list [catch {oo::class create foo {
    eval eval error bar
................................................................................
"error bar"
    ("eval" body line 1)
    invoked from within
"eval error bar"
    ("eval" body line 1)
    invoked from within
"eval eval error bar"
    (in definition script for class "::foo" line 2)
    invoked from within
"oo::class create foo {
    eval eval error bar
}"}}
test oo-18.4 {OO: more error traces from the guts} -setup {
    oo::object create obj
} -body {
................................................................................
"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-18.6 {class construction reference management and errors} -setup {
    oo::class create super_abc
} -body {
    catch {
oo::class create abc {
    superclass super_abc
    ::rename abc ::def
    ::error foo
}
    } msg opt
    dict get $opt -errorinfo
} -cleanup {
    super_abc destroy
} -result {foo
    while executing
"::error foo"
    (in definition script for class "::def" line 4)
    invoked from within
"oo::class create abc {
    superclass super_abc
    ::rename abc ::def
    ::error foo
}"}
test oo-18.7 {OO: objdefine command support} -setup {
    oo::object create ::inst
} -body {
    list [catch {oo::objdefine inst {rename ::inst ::INST;error foo}} msg] $msg $errorInfo
} -cleanup {
    catch {::inst destroy}
    catch {::INST destroy}
} -result {1 foo {foo
    while executing
"error foo"
    (in definition script for object "::INST" line 1)
    invoked from within
"oo::objdefine inst {rename ::inst ::INST;error foo}"}}
test oo-18.8 {OO: define/self command support} -setup {
    oo::class create master
    oo::class create ::foo {superclass master}
} -body {
    catch {oo::define foo {rename ::foo ::bar; self {error foobar}}} msg opt
    dict get $opt -errorinfo
} -cleanup {
    master destroy
} -result {foobar
    while executing
"error foobar"
    (in definition script for class object "::bar" line 1)
    invoked from within
"self {error foobar}"
    (in definition script for class "::bar" line 1)
    invoked from within
"oo::define foo {rename ::foo ::bar; self {error foobar}}"}
test oo-18.9 {OO: define/self command support} -setup {
    oo::class create master
    set c [oo::class create now_this_is_a_very_very_long_class_name_indeed {
        superclass master
    }]
} -body {
    catch {oo::define $c {error err}} msg opt
    dict get $opt -errorinfo
} -cleanup {
    master destroy
} -result {err
    while executing
"error err"
    (in definition script for class "::now_this_is_a_very_very_long..." line 1)
    invoked from within
"oo::define $c {error err}"}
test oo-18.10 {OO: define/self command support} -setup {
    oo::class create master
    oo::class create ::foo {superclass master}
} -body {
    catch {oo::define foo {self {rename ::foo {}; error foobar}}} msg opt
    dict get $opt -errorinfo
} -cleanup {
    master destroy
} -result {foobar
    while executing
"error foobar"
    (in definition script for class object "::foo" line 1)
    invoked from within
"self {rename ::foo {}; error foobar}"
    (in definition script for class "::foo" line 1)
    invoked from within
"oo::define foo {self {rename ::foo {}; error foobar}}"}
test oo-18.11 {OO: define/self command support} -setup {
    oo::class create master
    oo::class create ::foo {superclass master}
} -body {
    catch {oo::define foo {rename ::foo {}; self {error foobar}}} msg opt
    dict get $opt -errorinfo
} -cleanup {
    master destroy
} -result {this command cannot be called when the object has been deleted
    while executing
"self {error foobar}"
    (in definition script for class "::foo" line 1)
    invoked from within
"oo::define foo {rename ::foo {}; self {error foobar}}"}

test oo-19.1 {OO: varname method} -setup {
    oo::object create inst
    oo::objdefine inst export eval
    set result {}
    inst eval { variable x }
} -body {