diff options
| -rw-r--r-- | doc/define.n | 15 | ||||
| -rw-r--r-- | generic/tclOO.c | 1 | ||||
| -rw-r--r-- | generic/tclOODefineCmds.c | 43 | ||||
| -rw-r--r-- | generic/tclOOInt.h | 3 | ||||
| -rw-r--r-- | tests/oo.test | 107 |
5 files changed, 164 insertions, 5 deletions
diff --git a/doc/define.n b/doc/define.n index 7599ec0..1692c94 100644 --- a/doc/define.n +++ b/doc/define.n @@ -142,6 +142,8 @@ be afterwards. \fBself\fI subcommand arg ...\fR .TP \fBself\fI script\fR +.TP +\fBself\fR . This command is equivalent to calling \fBoo::objdefine\fR on the class being defined (see \fBCONFIGURING OBJECTS\fR below for a description of the @@ -151,6 +153,13 @@ and .QW "\fBoo::define \fIcls \fBself \fIsubcommand ...\fR" operates identically to .QW "\fBoo::objdefine \fIcls subcommand ...\fR" . +.RS +.PP +.VS TIP470 +If no arguments at all are used, this gives the name of the class currently +being configured. +.VE TIP470 +.RE .TP \fBsuperclass\fR ?\fI\-slotOperation\fR? ?\fIclassName ...\fR? .VS @@ -265,6 +274,12 @@ not previously refer to a method in that object. Does not affect the classes that the object is an instance of. Does not change the export status of the method; if it was exported before, it will be afterwards. .TP +\fBself \fR +. +.VS TIP470 +This gives the name of the object currently being configured. +.VE TIP470 +.TP \fBunexport\fI name \fR?\fIname ...\fR? . This arranges for each of the named methods, \fIname\fR, to be not exported diff --git a/generic/tclOO.c b/generic/tclOO.c index ef0c987..73acce8 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -41,6 +41,7 @@ static const struct { {"forward", TclOODefineForwardObjCmd, 1}, {"method", TclOODefineMethodObjCmd, 1}, {"renamemethod", TclOODefineRenameMethodObjCmd, 1}, + {"self", TclOODefineObjSelfObjCmd, 0}, {"unexport", TclOODefineUnexportObjCmd, 1}, {NULL, NULL, 0} }; diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index 70a0a32..b0bfd9c 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -1015,16 +1015,16 @@ TclOODefineSelfObjCmd( Object *oPtr; int result; - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "arg ?arg ...?"); - return TCL_ERROR; - } - oPtr = (Object *) TclOOGetDefineCmdContext(interp); if (oPtr == NULL) { return TCL_ERROR; } + if (objc < 2) { + Tcl_SetObjResult(interp, TclOOObjectName(interp, oPtr)); + return TCL_OK; + } + /* * Make the oo::objdefine namespace the current namespace and evaluate the * command(s). @@ -1061,6 +1061,39 @@ TclOODefineSelfObjCmd( /* * ---------------------------------------------------------------------- * + * TclOODefineObjSelfObjCmd -- + * Implementation of the "self" subcommand of the "oo::objdefine" + * command. + * + * ---------------------------------------------------------------------- + */ + +int +TclOODefineObjSelfObjCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + Object *oPtr; + + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return TCL_ERROR; + } + + oPtr = (Object *) TclOOGetDefineCmdContext(interp); + if (oPtr == NULL) { + return TCL_ERROR; + } + + Tcl_SetObjResult(interp, TclOOObjectName(interp, oPtr)); + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * * TclOODefineClassObjCmd -- * Implementation of the "class" subcommand of the "oo::objdefine" * command. diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index ae24dee..476446d 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -431,6 +431,9 @@ MODULE_SCOPE int TclOODefineClassObjCmd(ClientData clientData, MODULE_SCOPE int TclOODefineSelfObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); +MODULE_SCOPE int TclOODefineObjSelfObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const *objv); MODULE_SCOPE int TclOOUnknownDefinition(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); diff --git a/tests/oo.test b/tests/oo.test index e03911b..ae36f87 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -3766,6 +3766,113 @@ test oo-35.4 {Bug 593baa032c: mixins list teardown} { namespace eval [info object namespace D] [list [namespace which B] destroy] } {} +test oo-36.1 {TIP #470: introspection within oo::define} { + oo::define oo::object self +} ::oo::object +test oo-36.2 {TIP #470: introspection within oo::define} -setup { + oo::class create Cls +} -body { + oo::define Cls self +} -cleanup { + Cls destroy +} -result ::Cls +test oo-36.3 {TIP #470: introspection within oo::define} -setup { + oo::class create Super + set result uncalled +} -body { + oo::class create Sub { + superclass Super + ::set ::result [self] + } + return $result +} -cleanup { + Super destroy +} -result ::Sub +test oo-36.4 {TIP #470: introspection within oo::define} -setup { + oo::class create Super + set result uncalled +} -body { + oo::class create Sub { + superclass Super + ::set ::result [self {}] + } + return $result +} -cleanup { + Super destroy +} -result {} +test oo-36.5 {TIP #470: introspection within oo::define} -setup { + oo::class create Super + set result uncalled +} -body { + oo::class create Sub { + superclass Super + ::set ::result [self self] + } +} -cleanup { + Super destroy +} -result ::Sub +test oo-36.6 {TIP #470: introspection within oo::objdefine} -setup { + oo::class create Cls + set result uncalled +} -body { + Cls create obj + oo::objdefine obj { + ::set ::result [self] + } +} -cleanup { + Cls destroy +} -result ::obj +test oo-36.7 {TIP #470: introspection within oo::objdefine} -setup { + oo::class create Cls +} -body { + Cls create obj + oo::objdefine obj { + self + } +} -cleanup { + Cls destroy +} -result ::obj +test oo-36.8 {TIP #470: introspection within oo::objdefine} -setup { + oo::class create Cls +} -body { + Cls create obj + oo::objdefine obj { + self anything + } +} -returnCodes error -cleanup { + Cls destroy +} -result {wrong # args: should be "self"} +test oo-36.9 {TIP #470: introspection within oo::define} -setup { + oo::class create Cls + set result uncalled +} -body { + proc oo::define::testself {} { + global result + set result [list [catch {self} msg] $msg \ + [catch {uplevel 1 self} msg] $msg] + return + } + list [oo::define Cls testself] $result +} -cleanup { + Cls destroy + catch {rename oo::define::testself {}} +} -result {{} {1 {this command may only be called from within the context of an ::oo::define or ::oo::objdefine command} 0 ::Cls}} +test oo-36.10 {TIP #470: introspection within oo::define} -setup { + oo::class create Cls + set result uncalled +} -body { + proc oo::objdefine::testself {} { + global result + set result [list [catch {self} msg] $msg \ + [catch {uplevel 1 self} msg] $msg] + return + } + Cls create obj + list [oo::objdefine obj testself] $result +} -cleanup { + Cls destroy + catch {rename oo::objdefine::testself {}} +} -result {{} {1 {this command may only be called from within the context of an ::oo::define or ::oo::objdefine command} 0 ::obj}} cleanupTests return |