diff options
| -rw-r--r-- | generic/tclOO.decls | 4 | ||||
| -rw-r--r-- | generic/tclOO.h | 9 | ||||
| -rw-r--r-- | generic/tclOODecls.h | 8 | ||||
| -rw-r--r-- | generic/tclOODefineCmds.c | 13 | ||||
| -rw-r--r-- | tests/oo.test | 88 |
5 files changed, 111 insertions, 11 deletions
diff --git a/generic/tclOO.decls b/generic/tclOO.decls index 265ba88..5bce926 100644 --- a/generic/tclOO.decls +++ b/generic/tclOO.decls @@ -58,12 +58,12 @@ declare 10 { } declare 11 { Tcl_Method Tcl_NewInstanceMethod(Tcl_Interp *interp, Tcl_Object object, - Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr, + Tcl_Obj *nameObj, int flags, const Tcl_MethodType *typePtr, ClientData clientData) } declare 12 { Tcl_Method Tcl_NewMethod(Tcl_Interp *interp, Tcl_Class cls, - Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr, + Tcl_Obj *nameObj, int flags, const Tcl_MethodType *typePtr, ClientData clientData) } declare 13 { diff --git a/generic/tclOO.h b/generic/tclOO.h index d051e79..9c1dd1e 100644 --- a/generic/tclOO.h +++ b/generic/tclOO.h @@ -99,6 +99,15 @@ typedef struct { */ #define TCL_OO_METHOD_VERSION_CURRENT 1 + +/* + * Visibility constants for the flags parameter to Tcl_NewMethod and + * Tcl_NewInstanceMethod. + */ + +#define TCL_OO_METHOD_PUBLIC 1 +#define TCL_OO_METHOD_UNEXPORTED 0 +#define TCL_OO_METHOD_PRIVATE 0x20 /* * The type of some object (or class) metadata. This describes how to delete diff --git a/generic/tclOODecls.h b/generic/tclOODecls.h index 9fd62ec..fd0f687 100644 --- a/generic/tclOODecls.h +++ b/generic/tclOODecls.h @@ -59,11 +59,11 @@ TCLAPI Tcl_Obj * Tcl_MethodName(Tcl_Method method); /* 11 */ TCLAPI Tcl_Method Tcl_NewInstanceMethod(Tcl_Interp *interp, Tcl_Object object, Tcl_Obj *nameObj, - int isPublic, const Tcl_MethodType *typePtr, + int flags, const Tcl_MethodType *typePtr, ClientData clientData); /* 12 */ TCLAPI Tcl_Method Tcl_NewMethod(Tcl_Interp *interp, Tcl_Class cls, - Tcl_Obj *nameObj, int isPublic, + Tcl_Obj *nameObj, int flags, const Tcl_MethodType *typePtr, ClientData clientData); /* 13 */ @@ -136,8 +136,8 @@ typedef struct TclOOStubs { int (*tcl_MethodIsPublic) (Tcl_Method method); /* 8 */ int (*tcl_MethodIsType) (Tcl_Method method, const Tcl_MethodType *typePtr, ClientData *clientDataPtr); /* 9 */ Tcl_Obj * (*tcl_MethodName) (Tcl_Method method); /* 10 */ - Tcl_Method (*tcl_NewInstanceMethod) (Tcl_Interp *interp, Tcl_Object object, Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr, ClientData clientData); /* 11 */ - Tcl_Method (*tcl_NewMethod) (Tcl_Interp *interp, Tcl_Class cls, Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr, ClientData clientData); /* 12 */ + Tcl_Method (*tcl_NewInstanceMethod) (Tcl_Interp *interp, Tcl_Object object, Tcl_Obj *nameObj, int flags, const Tcl_MethodType *typePtr, ClientData clientData); /* 11 */ + Tcl_Method (*tcl_NewMethod) (Tcl_Interp *interp, Tcl_Class cls, Tcl_Obj *nameObj, int flags, const Tcl_MethodType *typePtr, ClientData clientData); /* 12 */ Tcl_Object (*tcl_NewObjectInstance) (Tcl_Interp *interp, Tcl_Class cls, const char *nameStr, const char *nsNameStr, int objc, Tcl_Obj *const *objv, int skip); /* 13 */ int (*tcl_ObjectDeleted) (Tcl_Object object); /* 14 */ int (*tcl_ObjectContextIsFiltering) (Tcl_ObjectContext context); /* 15 */ diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index 403ed1a..7281d7a 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -1187,7 +1187,7 @@ TclOODefineSelfObjCmd( { Foundation *fPtr = TclOOGetFoundation(interp); Object *oPtr; - int result; + int result, private; oPtr = (Object *) TclOOGetDefineCmdContext(interp); if (oPtr == NULL) { @@ -1199,6 +1199,8 @@ TclOODefineSelfObjCmd( return TCL_OK; } + private = IsPrivateDefine(interp); + /* * Make the oo::objdefine namespace the current namespace and evaluate the * command(s). @@ -1207,6 +1209,9 @@ TclOODefineSelfObjCmd( if (InitDefineContext(interp, fPtr->objdefNs, oPtr, objc,objv) != TCL_OK){ return TCL_ERROR; } + if (private) { + ((Interp *) interp)->varFramePtr->isProcCallFrame = PRIVATE_FRAME; + } AddRef(oPtr); if (objc == 2) { @@ -1298,9 +1303,9 @@ TclOODefinePrivateObjCmd( if (oPtr == NULL) { return TCL_ERROR; } - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "definitionCommand ..."); - return TCL_ERROR; + if (objc == 1) { + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(IsPrivateDefine(interp))); + return TCL_OK; } /* diff --git a/tests/oo.test b/tests/oo.test index 9563b4f..24f23ae 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -4298,7 +4298,7 @@ test oo-38.2 {TIP 500: private variables introspection} -setup { } -cleanup { parent destroy } -result {{y1 y2} {x1 x2} {b1 b2} {a1 a2}} -test oo-38.3 {TIP 500: private variables and obj·varname} -setup { +test oo-38.3 {TIP 500: private variables and oo::object·varname} -setup { oo::class create parent } -body { oo::class create clsA { @@ -4372,6 +4372,65 @@ test oo-38.4 {TIP 500: private variables introspection} -setup { } -cleanup { parent destroy } -result {ok {ok x1 x2 y1 y2 z} 0 yes {a1 a2 b1 b2 yes z} 0} +test oo-38.5 {TIP 500: private variables and oo::object·variable} -setup { + oo::class create parent +} -body { + oo::class create cls1 { + superclass parent + private variable x + method abc val { + my variable x + set x $val + } + method def val { + my variable y + set y $val + } + method get1 {} { + my variable x y + return [list $x $y] + } + } + oo::class create cls2 { + superclass cls1 + private variable x + method x-exists {} { + return [info exists x],[uplevel 1 {info exists x}] + } + method ghi x { + # Additional instrumentation to show that we're not using the + # resolved variable until we ask for it; the argument nixed that + # happening by default. + set val $x + set before [my x-exists] + unset x + set x $val + set mid [my x-exists] + unset x + set mid2 [my x-exists] + my variable x + set x $val + set after [my x-exists] + return "$before;$mid;$mid2;$after" + } + method jkl val { + my variable y + set y $val + } + method get2 {} { + my variable x y + return [list $x $y] + } + } + cls2 create a + a abc 123 + a def 234 + set tmp [a ghi 345] + a jkl 456 + list $tmp [a get1] [a get2] +} -cleanup { + parent destroy +} -result {{0,1;0,1;0,0;1,1} {123 456} {345 456}} test oo-39.1 {TIP 500: private methods internal call; class private} -setup { oo::class create parent @@ -4727,6 +4786,33 @@ test oo-39.12 {TIP 500: private methods; introspection} -setup { } -cleanup { parent destroy } -result {a: {{} {} {}} b: {foo ABC ghi} cls: {chain {} abc} cls2: {chain2 chain3 def}} + +test oo-40.1 {TIP 500: private and self} -setup { + oo::class create cls +} -body { + oo::define cls { + self { + private { + variable a + } + variable b + } + private { + self { + variable c + } + variable d + } + variable e + } + list \ + [lsort [info class variables cls]] \ + [lsort [info class variables cls -private]] \ + [lsort [info object variables cls]] \ + [lsort [info object variables cls -private]] +} -cleanup { + cls destroy +} -result {e d b {a c}} cleanupTests return |