TclOO Package

Check-in [594b9c80a8]
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:Implement TIP 470: Reliable Access to OO Definition Context Object
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | tip-470
Files: files | file ages | folders
SHA1: 594b9c80a88665198207f28a99748c4c9479da9e
User & Date: dkf 2017-06-18 07:51:02
Original Comment: Backport of TIP 470 from Tcl.
Context
2017-06-18
07:51
Implement TIP 470: Reliable Access to OO Definition Context Object Leaf check-in: 594b9c80a8 user: dkf tags: tip-470
2016-04-20
07:58
[6adfa8fddf] Fix test target check-in: e5b56214c7 user: gahr tags: trunk
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Changes to doc/define.n.

   138    138   (except when they have a call chain through the class being modified). Does
   139    139   not change the export status of the method; if it was exported before, it will
   140    140   be afterwards.
   141    141   .TP
   142    142   \fBself\fI subcommand arg ...\fR
   143    143   .TP
   144    144   \fBself\fI script\fR
          145  +.TP
          146  +\fBself\fR
   145    147   .
   146    148   This command is equivalent to calling \fBoo::objdefine\fR on the class being
   147    149   defined (see \fBCONFIGURING OBJECTS\fR below for a description of the
   148    150   supported values of \fIsubcommand\fR). It follows the same general pattern of
   149    151   argument handling as the \fBoo::define\fR and \fBoo::objdefine\fR commands,
   150    152   and
   151    153   .QW "\fBoo::define \fIcls \fBself \fIsubcommand ...\fR"
   152    154   operates identically to
   153    155   .QW "\fBoo::objdefine \fIcls subcommand ...\fR" .
          156  +.RS
          157  +.PP
          158  +.VS TIP470
          159  +If no arguments at all are used, this gives the name of the class currently
          160  +being configured.
          161  +.VE TIP470
          162  +.RE
   154    163   .TP
   155    164   \fBsuperclass\fR ?\fI\-slotOperation\fR? ?\fIclassName ...\fR?
   156    165   .VS
   157    166   This slot (see \fBSLOTTED DEFINITIONS\fR below)
   158    167   .VE
   159    168   allows the alteration of the superclasses of the class being defined.
   160    169   Each \fIclassName\fR argument names one class that is to be a superclass of
................................................................................
   260    269   \fBrenamemethod\fI fromName toName\fR
   261    270   .
   262    271   This renames the method called \fIfromName\fR in an object to \fItoName\fR.
   263    272   The method must have previously existed in the object, and \fItoName\fR must
   264    273   not previously refer to a method in that object. Does not affect the classes
   265    274   that the object is an instance of. Does not change the export status of the
   266    275   method; if it was exported before, it will be afterwards.
          276  +.TP
          277  +\fBself \fR
          278  +.
          279  +.VS TIP470
          280  +This gives the name of the object currently being configured.
          281  +.VE TIP470
   267    282   .TP
   268    283   \fBunexport\fI name \fR?\fIname ...\fR?
   269    284   .
   270    285   This arranges for each of the named methods, \fIname\fR, to be not exported
   271    286   (i.e. not usable outside the object through the object's command, but instead
   272    287   just through the \fBmy\fR command visible in the object's context) by the
   273    288   object being defined. Note that the methods themselves may be actually defined

Changes to generic/tclOO.c.

    37     37   }, objdefCmds[] = {
    38     38       {"class", TclOODefineClassObjCmd, 1},
    39     39       {"deletemethod", TclOODefineDeleteMethodObjCmd, 1},
    40     40       {"export", TclOODefineExportObjCmd, 1},
    41     41       {"forward", TclOODefineForwardObjCmd, 1},
    42     42       {"method", TclOODefineMethodObjCmd, 1},
    43     43       {"renamemethod", TclOODefineRenameMethodObjCmd, 1},
           44  +    {"self", TclOODefineObjSelfObjCmd, 0},
    44     45       {"unexport", TclOODefineUnexportObjCmd, 1},
    45     46       {NULL, NULL, 0}
    46     47   };
    47     48   
    48     49   /*
    49     50    * What sort of size of things we like to allocate.
    50     51    */

Changes to generic/tclOODefineCmds.c.

  1033   1033       int objc,
  1034   1034       Tcl_Obj *const *objv)
  1035   1035   {
  1036   1036       Foundation *fPtr = TclOOGetFoundation(interp);
  1037   1037       int result;
  1038   1038       Object *oPtr;
  1039   1039   
  1040         -    if (objc < 2) {
  1041         -	Tcl_WrongNumArgs(interp, 1, objv, "arg ?arg ...?");
  1042         -	return TCL_ERROR;
  1043         -    }
  1044         -
  1045   1040       oPtr = (Object *) TclOOGetDefineCmdContext(interp);
  1046   1041       if (oPtr == NULL) {
  1047   1042   	return TCL_ERROR;
  1048   1043       }
         1044  +
         1045  +    if (objc < 2) {
         1046  +	Tcl_SetObjResult(interp, TclOOObjectName(interp, oPtr));
         1047  +	return TCL_OK;
         1048  +    }
  1049   1049   
  1050   1050       /*
  1051   1051        * Make the oo::objdefine namespace the current namespace and evaluate the
  1052   1052        * command(s).
  1053   1053        */
  1054   1054   
  1055   1055       if (InitDefineContext(interp, fPtr->objdefNs, oPtr, objc,objv) != TCL_OK){
................................................................................
  1122   1122       /*
  1123   1123        * Restore the previous "current" namespace.
  1124   1124        */
  1125   1125   
  1126   1126       TclPopStackFrame(interp);
  1127   1127       return result;
  1128   1128   }
         1129  +
         1130  +/*
         1131  + * ----------------------------------------------------------------------
         1132  + *
         1133  + * TclOODefineObjSelfObjCmd --
         1134  + *	Implementation of the "self" subcommand of the "oo::objdefine"
         1135  + *	command.
         1136  + *
         1137  + * ----------------------------------------------------------------------
         1138  + */
         1139  +
         1140  +int
         1141  +TclOODefineObjSelfObjCmd(
         1142  +    ClientData clientData,
         1143  +    Tcl_Interp *interp,
         1144  +    int objc,
         1145  +    Tcl_Obj *const *objv)
         1146  +{
         1147  +    Object *oPtr;
         1148  +
         1149  +    if (objc != 1) {
         1150  +	Tcl_WrongNumArgs(interp, 1, objv, NULL);
         1151  +	return TCL_ERROR;
         1152  +    }
         1153  +
         1154  +    oPtr = (Object *) TclOOGetDefineCmdContext(interp);
         1155  +    if (oPtr == NULL) {
         1156  +	return TCL_ERROR;
         1157  +    }
         1158  +
         1159  +    Tcl_SetObjResult(interp, TclOOObjectName(interp, oPtr));
         1160  +    return TCL_OK;
         1161  +}
  1129   1162   
  1130   1163   /*
  1131   1164    * ----------------------------------------------------------------------
  1132   1165    *
  1133   1166    * TclOODefineClassObjCmd --
  1134   1167    *	Implementation of the "class" subcommand of the "oo::objdefine"
  1135   1168    *	command.

Changes to generic/tclOOInt.h.

   445    445   			    Tcl_Interp *interp, int objc,
   446    446   			    Tcl_Obj *const *objv);
   447    447   MODULE_SCOPE int	TclOODefineClassObjCmd(ClientData clientData,
   448    448   			    Tcl_Interp *interp, int objc,
   449    449   			    Tcl_Obj *const *objv);
   450    450   MODULE_SCOPE int	TclOODefineSelfObjCmd(ClientData clientData,
   451    451   			    Tcl_Interp *interp, int objc,
          452  +			    Tcl_Obj *const *objv);
          453  +MODULE_SCOPE int	TclOODefineObjSelfObjCmd(ClientData clientData,
          454  +			    Tcl_Interp *interp, int objc,
   452    455   			    Tcl_Obj *const *objv);
   453    456   MODULE_SCOPE int	TclOOUnknownDefinition(ClientData clientData,
   454    457   			    Tcl_Interp *interp, int objc,
   455    458   			    Tcl_Obj *const *objv);
   456    459   MODULE_SCOPE int	TclOOCopyObjectCmd(ClientData clientData,
   457    460   			    Tcl_Interp *interp, int objc,
   458    461   			    Tcl_Obj *const *objv);

Changes to tests/oo.test.

  3443   3443   } {}
  3444   3444   test oo-35.4 {Bug 593baa032c: mixins list teardown} {
  3445   3445       # Bug makes this crash, especially with mem-debugging on
  3446   3446       oo::class create B {}
  3447   3447       oo::class create D {mixin B}
  3448   3448       namespace eval [info object namespace D] [list [namespace which B] destroy]
  3449   3449   } {}
         3450  +
         3451  +test oo-36.1 {TIP #470: introspection within oo::define} {
         3452  +    oo::define oo::object self
         3453  +} ::oo::object
         3454  +test oo-36.2 {TIP #470: introspection within oo::define} -setup {
         3455  +    oo::class create Cls
         3456  +} -body {
         3457  +    oo::define Cls self
         3458  +} -cleanup {
         3459  +    Cls destroy
         3460  +} -result ::Cls
         3461  +test oo-36.3 {TIP #470: introspection within oo::define} -setup {
         3462  +    oo::class create Super
         3463  +    set result uncalled
         3464  +} -body {
         3465  +    oo::class create Sub {
         3466  +	superclass Super
         3467  +	::set ::result [self]
         3468  +    }
         3469  +    return $result
         3470  +} -cleanup {
         3471  +    Super destroy
         3472  +} -result ::Sub
         3473  +test oo-36.4 {TIP #470: introspection within oo::define} -setup {
         3474  +    oo::class create Super
         3475  +    set result uncalled
         3476  +} -body {
         3477  +    oo::class create Sub {
         3478  +	superclass Super
         3479  +	::set ::result [self {}]
         3480  +    }
         3481  +    return $result
         3482  +} -cleanup {
         3483  +    Super destroy
         3484  +} -result {}
         3485  +test oo-36.5 {TIP #470: introspection within oo::define} -setup {
         3486  +    oo::class create Super
         3487  +    set result uncalled
         3488  +} -body {
         3489  +    oo::class create Sub {
         3490  +	superclass Super
         3491  +	::set ::result [self self]
         3492  +    }
         3493  +} -cleanup {
         3494  +    Super destroy
         3495  +} -result ::Sub
         3496  +test oo-36.6 {TIP #470: introspection within oo::objdefine} -setup {
         3497  +    oo::class create Cls
         3498  +    set result uncalled
         3499  +} -body {
         3500  +    Cls create obj
         3501  +    oo::objdefine obj {
         3502  +	::set ::result [self]
         3503  +    }
         3504  +} -cleanup {
         3505  +    Cls destroy
         3506  +} -result ::obj
         3507  +test oo-36.7 {TIP #470: introspection within oo::objdefine} -setup {
         3508  +    oo::class create Cls
         3509  +} -body {
         3510  +    Cls create obj
         3511  +    oo::objdefine obj {
         3512  +	self
         3513  +    }
         3514  +} -cleanup {
         3515  +    Cls destroy
         3516  +} -result ::obj
         3517  +test oo-36.8 {TIP #470: introspection within oo::objdefine} -setup {
         3518  +    oo::class create Cls
         3519  +} -body {
         3520  +    Cls create obj
         3521  +    oo::objdefine obj {
         3522  +	self anything
         3523  +    }
         3524  +} -returnCodes error -cleanup {
         3525  +    Cls destroy
         3526  +} -result {wrong # args: should be "self"}
         3527  +test oo-36.9 {TIP #470: introspection within oo::define} -setup {
         3528  +    oo::class create Cls
         3529  +    set result uncalled
         3530  +} -body {
         3531  +    proc oo::define::testself {} {
         3532  +	global result
         3533  +	set result [list [catch {self} msg] $msg \
         3534  +			[catch {uplevel 1 self} msg] $msg]
         3535  +	return
         3536  +    }
         3537  +    list [oo::define Cls testself] $result
         3538  +} -cleanup {
         3539  +    Cls destroy
         3540  +    catch {rename oo::define::testself {}}
         3541  +} -result {{} {1 {this command may only be called from within the context of an ::oo::define or ::oo::objdefine command} 0 ::Cls}}
         3542  +test oo-36.10 {TIP #470: introspection within oo::define} -setup {
         3543  +    oo::class create Cls
         3544  +    set result uncalled
         3545  +} -body {
         3546  +    proc oo::objdefine::testself {} {
         3547  +	global result
         3548  +	set result [list [catch {self} msg] $msg \
         3549  +			[catch {uplevel 1 self} msg] $msg]
         3550  +	return
         3551  +    }
         3552  +    Cls create obj
         3553  +    list [oo::objdefine obj testself] $result
         3554  +} -cleanup {
         3555  +    Cls destroy
         3556  +    catch {rename oo::objdefine::testself {}}
         3557  +} -result {{} {1 {this command may only be called from within the context of an ::oo::define or ::oo::objdefine command} 0 ::obj}}
  3450   3558   
  3451   3559   cleanupTests
  3452   3560   return
  3453   3561   
  3454   3562   # Local Variables:
  3455   3563   # mode: tcl
  3456   3564   # End: