Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Changes In Branch tip-524 Excluding Merge-Ins
This is equivalent to a diff from fc3996f465 to 5fbb86d1a1
2018-11-06
| ||
11:15 | Implement TIP 524 check-in: f726350fc9 user: dkf tags: core-8-branch | |
2018-10-29
| ||
13:19 | [TIP 522] New option "-errorCode" to [tcltest::test] in tcltest 2.5 check-in: 6852438731 user: dgp tags: core-8-branch | |
2018-10-28
| ||
19:26 | Merge 8.7 check-in: 4f12a75d03 user: jan.nijtmans tags: tip-468 | |
19:21 | Experiment: See if we can build and test using cross-compiled mingw-w64 with wine check-in: 4c6c98a736 user: jan.nijtmans tags: travis-8.7-wine | |
15:36 | Documentation Closed-Leaf check-in: 5fbb86d1a1 user: dkf tags: tip-524 | |
12:48 | Test cases (and some fixes) check-in: c1d92c86e0 user: dkf tags: tip-524 | |
2018-10-27
| ||
22:12 | merge core-8-branch check-in: c000f42f30 user: dkf tags: tip-524 | |
19:46 | Merge 8.7 check-in: 6966eb6f6f user: jan.nijtmans tags: trunk | |
19:45 | Merge 8.6 check-in: fc3996f465 user: jan.nijtmans tags: core-8-branch | |
19:43 | merge-mark... well ... almost: Except for a missing <include> in tclWinDde.c check-in: db9d745b8d user: jan.nijtmans tags: core-8-6-branch | |
18:08 | Update TZ info to tzdata2018g. check-in: 0bf9474c61 user: jima tags: core-8-branch | |
Changes to doc/define.n.
︙ | ︙ | |||
30 31 32 33 34 35 36 | configuration of all subclasses of the class and all objects that are instances of that class or which mix it in (as modified by any per-instance configuration). The way in which the configuration is done is controlled by either the \fIdefScript\fR argument or by the \fIsubcommand\fR and following \fIarg\fR arguments; when the second is present, it is exactly as if all the arguments from \fIsubcommand\fR onwards are made into a list and that list is used as the \fIdefScript\fR argument. | > > > > | | 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 | configuration of all subclasses of the class and all objects that are instances of that class or which mix it in (as modified by any per-instance configuration). The way in which the configuration is done is controlled by either the \fIdefScript\fR argument or by the \fIsubcommand\fR and following \fIarg\fR arguments; when the second is present, it is exactly as if all the arguments from \fIsubcommand\fR onwards are made into a list and that list is used as the \fIdefScript\fR argument. .PP Note that the constructor for \fBoo::class\fR will call \fBoo::define\fR on the script argument that it is provided. This is a convenient way to create and define a class in one step. .SH "CONFIGURING CLASSES" .PP The following commands are supported in the \fIdefScript\fR for \fBoo::define\fR, each of which may also be used in the \fIsubcommand\fR form: .TP \fBclassmethod\fI name\fR ?\fIargList bodyScrip\fR? .VS TIP478 This creates a class method, or (if \fIargList\fR and \fIbodyScript\fR are |
︙ | ︙ | |||
66 67 68 69 70 71 72 | the constructor (defined using the same format as for the Tcl \fBproc\fR command) will be \fIargList\fR, and the body of the constructor will be \fIbodyScript\fR. When the body of the constructor is evaluated, the current namespace of the constructor will be a namespace that is unique to the object being constructed. Within the constructor, the \fBnext\fR command should be used to call the superclasses' constructors. If \fIbodyScript\fR is the empty string, the constructor will be deleted. | | < | < > | < < > | 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 | the constructor (defined using the same format as for the Tcl \fBproc\fR command) will be \fIargList\fR, and the body of the constructor will be \fIbodyScript\fR. When the body of the constructor is evaluated, the current namespace of the constructor will be a namespace that is unique to the object being constructed. Within the constructor, the \fBnext\fR command should be used to call the superclasses' constructors. If \fIbodyScript\fR is the empty string, the constructor will be deleted. .RS .PP Classes do not need to have a constructor defined. If none is specified, the superclass's constructor will be used instead. .RE .TP \fBdestructor\fI bodyScript\fR . This creates or updates the destructor for a class. Destructors take no arguments, and the body of the destructor will be \fIbodyScript\fR. The destructor is called when objects of the class are deleted, and when called will have the object's unique namespace as the current namespace. Destructors |
︙ | ︙ | |||
98 99 100 101 102 103 104 | . This arranges for each of the named methods, \fIname\fR, to be exported (i.e. usable outside an instance through the instance object's command) by the class being defined. Note that the methods themselves may be actually defined by a superclass; subclass exports override superclass visibility, and may in turn be overridden by instances. .TP | < < < < < < < < < < | 100 101 102 103 104 105 106 107 108 109 110 111 112 113 | . This arranges for each of the named methods, \fIname\fR, to be exported (i.e. usable outside an instance through the instance object's command) by the class being defined. Note that the methods themselves may be actually defined by a superclass; subclass exports override superclass visibility, and may in turn be overridden by instances. .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 arguments, \fIarg\fR etc., added before those arguments specified by the 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 |
︙ | ︙ | |||
155 156 157 158 159 160 161 | .PP .VS TIP500 If in a private definition context (see the \fBprivate\fR definition command, below), this command creates private procedure-like methods. .VE TIP500 .RE .TP | < < < < < < < < < < < < < < < < < < | 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 | .PP .VS TIP500 If in a private definition context (see the \fBprivate\fR definition command, below), this command creates private procedure-like methods. .VE TIP500 .RE .TP \fBprivate \fIcmd arg...\fR .TP \fBprivate \fIscript\fR . .VS TIP500 This evaluates the \fIscript\fR (or the list of command and arguments given by \fIcmd\fR and \fIarg\fRs) in a context where the definitions made on the current class will be private definitions. .RS .PP The following class definition commands are affected by \fBprivate\fR: \fBforward\fR, \fBmethod\fR, \fBself\fR, and \fBvariable\fR. Nesting \fBprivate\fR inside \fBprivate\fR has no cumulative effect; the innermost definition context is just a private definition context. All other definition commands have no difference in behavior when used in a private definition context. .RE .VE TIP500 .TP \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 |
︙ | ︙ | |||
265 266 267 268 269 270 271 | instance object is different to the name given in the definition; the name used in the definition is the name that you use to access the variable within the methods of this class, and the name of the variable in the instance namespace has a unique prefix that makes accidental use from other classes extremely unlikely. .VE TIP500 .RE | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | < < < < < < < < < < < < < < < < < < < < < < < | 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 | instance object is different to the name given in the definition; the name used in the definition is the name that you use to access the variable within the methods of this class, and the name of the variable in the instance namespace has a unique prefix that makes accidental use from other classes extremely unlikely. .VE TIP500 .RE .SS "ADVANCED CLASS CONFIGURATION OPTIONS" .PP The following definitions are also supported, but are not required in simple programs: .TP \fBdefinitionnamespace\fR ?\fIkind\fR? \fInamespaceName\fR .VS TIP524 This allows control over what namespace will be used by the \fBoo::define\fR and \fBoo::objdefine\fR commands to look up the definition commands they use. When any object has a definition operation applied to it, \fIthe class that it is an instance of\fR (and its superclasses and mixins) is consulted for what definition namespace to use. \fBoo::define\fR gets the class definition namespace, and \fB::oo::objdefine\fR gets the instance definition namespace, but both otherwise use the identical lookup operation. .RS .PP This sets the definition namespace of kind \fIkind\fR provided by the current class to \fInamespaceName\fR. The \fInamespaceName\fR must refer to a currently existing namespace, or must be the empty string (to stop the current class from having such a namespace connected). The \fIkind\fR, if supplied, must be either \fB\-class\fR (the default) or \fB\-instance\fR to specify the whether the namespace for use with \fBoo::define\fR or \fBoo::objdefine\fR respectively is being set. .PP The class \fBoo::object\fR has its instance namespace locked to \fB::oo::objdefine\fR, and the class \fBoo::class\fR has its class namespace locked to \fB::oo::define\fR. A consequence of this is that effective use of this feature for classes requires the definition of a metaclass. .RE .VE TIP524 .TP \fBdeletemethod\fI name\fR ?\fIname ...\fR? . This deletes each of the methods called \fIname\fR from a class. The methods must have previously existed in that class. Does not affect the superclasses of the class, nor does it affect the subclasses or instances of the class (except when they have a call chain through the class being modified). .TP \fBfilter\fR ?\fI\-slotOperation\fR? ?\fImethodName ...\fR? . This slot (see \fBSLOTTED DEFINITIONS\fR below) sets or updates the list of method names that are used to guard whether method call to instances of the class may be called and what the method's results are. Each \fImethodName\fR names a single filtering method (which may be exposed or not exposed); it is not an error for a non-existent method to be named since they may be defined by subclasses. By default, this slot works by appending. .TP \fBmixin\fR ?\fI\-slotOperation\fR? ?\fIclassName ...\fR? . This slot (see \fBSLOTTED DEFINITIONS\fR below) sets or updates the list of additional classes that are to be mixed into all the instances of the class being defined. Each \fIclassName\fR argument names a single class that is to be mixed in. By default, this slot works by replacement. .TP \fBrenamemethod\fI fromName toName\fR . This renames the method called \fIfromName\fR in a class to \fItoName\fR. The method must have previously existed in the class, and \fItoName\fR must not previously refer to a method in that class. Does not affect the superclasses of the class, nor does it affect the subclasses or instances of the class (except when they have a call chain through the class being modified). Does not change the export status of the method; if it was exported before, it will be afterwards. .SH "CONFIGURING OBJECTS" .PP The following commands are supported in the \fIdefScript\fR for \fBoo::objdefine\fR, each of which may also be used in the \fIsubcommand\fR form: .TP \fBexport\fI name \fR?\fIname ...\fR? . This arranges for each of the named methods, \fIname\fR, to be exported (i.e. usable outside the object through the object's command) by the object being defined. Note that the methods themselves may be actually defined by a class or superclass; object exports override class visibility. .TP \fBforward\fI name cmdName \fR?\fIarg ...\fR? . This creates or updates a forwarded object 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 |
︙ | ︙ | |||
359 360 361 362 363 364 365 | \fBforward\fR, \fBmethod\fR, and \fBvariable\fR. Nesting \fBprivate\fR inside \fBprivate\fR has no cumulative effect; the innermost definition context is just a private definition context. All other definition commands have no difference in behavior when used in a private definition context. .RE .VE TIP500 .TP | < < < < < < < < < < < < < | 375 376 377 378 379 380 381 382 383 384 385 386 387 388 | \fBforward\fR, \fBmethod\fR, and \fBvariable\fR. Nesting \fBprivate\fR inside \fBprivate\fR has no cumulative effect; the innermost definition context is just a private definition context. All other definition commands have no difference in behavior when used in a private definition context. .RE .VE TIP500 .TP \fBunexport\fI name \fR?\fIname ...\fR? . This arranges for each of the named methods, \fIname\fR, to be not exported (i.e. not usable outside the object through the object's command, but instead just through the \fBmy\fR command visible in the object's context) by the object being defined. Note that the methods themselves may be actually defined by a class; instance unexports override class visibility. |
︙ | ︙ | |||
404 405 406 407 408 409 410 411 412 413 414 415 416 417 | instance object is different to the name given in the definition; the name used in the definition is the name that you use to access the variable within the methods of this instance object, and the name of the variable in the instance namespace has a unique prefix that makes accidental use from superclass methods extremely unlikely. .VE TIP500 .RE .SH "PRIVATE METHODS" .VS TIP500 When a class or instance has a private method, that private method can only be invoked from within methods of that class or instance. Other callers of the object's methods \fIcannot\fR invoke private methods, it is as if the private methods do not exist. However, a private method of a class \fIcan\fR be invoked from the class's methods when those methods are being used on another | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 | instance object is different to the name given in the definition; the name used in the definition is the name that you use to access the variable within the methods of this instance object, and the name of the variable in the instance namespace has a unique prefix that makes accidental use from superclass methods extremely unlikely. .VE TIP500 .RE .SS "ADVANCED OBJECT CONFIGURATION OPTIONS" .PP The following definitions are also supported, but are not required in simple programs: .TP \fBclass\fI className\fR . This allows the class of an object to be changed after creation. Note that the class's constructors are not called when this is done, and so the object may well be in an inconsistent state unless additional configuration work is done. .TP \fBdeletemethod\fI name\fR ?\fIname ...\fR . This deletes each of the methods called \fIname\fR from an object. The methods must have previously existed in that object. Does not affect the classes that the object is an instance of. .TP \fBfilter\fR ?\fI\-slotOperation\fR? ?\fImethodName ...\fR? . This slot (see \fBSLOTTED DEFINITIONS\fR below) sets or updates the list of method names that are used to guard whether a method call to the object may be called and what the method's results are. Each \fImethodName\fR names a single filtering method (which may be exposed or not exposed); it is not an error for a non-existent method to be named. Note that the actual list of filters also depends on the filters set upon any classes that the object is an instance of. By default, this slot works by appending. .TP \fBrenamemethod\fI fromName toName\fR . This renames the method called \fIfromName\fR in an object to \fItoName\fR. The method must have previously existed in the object, and \fItoName\fR must 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 .SH "PRIVATE METHODS" .VS TIP500 When a class or instance has a private method, that private method can only be invoked from within methods of that class or instance. Other callers of the object's methods \fIcannot\fR invoke private methods, it is as if the private methods do not exist. However, a private method of a class \fIcan\fR be invoked from the class's methods when those methods are being used on another |
︙ | ︙ | |||
655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 | \fI\(-> DB: delete row ::oo::Obj123\fR set g [Group find "groupname=webadmins"] \fI\(-> DB: locate row ::Group with groupname=webadmins\fR $g update "emailaddress=admins" \fI\(-> DB: update row ::oo::Obj125 with emailaddress=admins\fR .CE .VE TIP478 .SH "SEE ALSO" next(n), oo::class(n), oo::object(n) .SH KEYWORDS class, definition, method, object, slot .\" Local variables: .\" mode: nroff .\" fill-column: 78 .\" End: | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 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 | \fI\(-> DB: delete row ::oo::Obj123\fR set g [Group find "groupname=webadmins"] \fI\(-> DB: locate row ::Group with groupname=webadmins\fR $g update "emailaddress=admins" \fI\(-> DB: update row ::oo::Obj125 with emailaddress=admins\fR .CE .VE TIP478 .PP .VS TIP524 This example shows how to make a custom definition for a class. Note that it explicitly includes delegation to the existing definition commands via \fBnamespace path\fR. .PP .CS namespace eval myDefinitions { # Delegate to existing definitions where not overridden namespace path \fB::oo::define\fR # A custom type of method proc exprmethod {name arguments body} { tailcall \fBmethod\fR $name $arguments [list expr $body] } # A custom way of building a constructor proc parameters args { uplevel 1 [list \fBvariable\fR {*}$args] set body [join [lmap a $args { string map [list VAR $a] { set [my varname VAR] [expr {double($VAR)}] } }] ";"] tailcall \fBconstructor\fR $args $body } } # Bind the namespace into a (very simple) metaclass for use oo::class create exprclass { \fBsuperclass\fR oo::class \fBdefinitionnamespace\fR myDefinitions } # Use the custom definitions exprclass create quadratic { parameters a b c exprmethod evaluate {x} { ($a * $x**2) + ($b * $x) + $c } } # Showing the resulting class and object in action quadratic create quad 1 2 3 for {set x 0} {$x <= 4} {incr x} { puts [format "quad(%d) = %.2f" $x [quad evaluate $x]] } \fI\(-> quad(0) = 3.00\fR \fI\(-> quad(1) = 6.00\fR \fI\(-> quad(2) = 11.00\fR \fI\(-> quad(3) = 18.00\fR \fI\(-> quad(4) = 27.00\fR .CE .VE TIP524 .SH "SEE ALSO" next(n), oo::class(n), oo::object(n) .SH KEYWORDS class, definition, method, object, slot .\" Local variables: .\" mode: nroff .\" fill-column: 78 .\" End: |
Changes to doc/info.n.
︙ | ︙ | |||
476 477 478 479 480 481 482 483 484 485 486 487 488 489 | \fBinfo class definition\fI class method\fR . This subcommand returns a description of the definition of the method named \fImethod\fR of class \fIclass\fR. The definition is described as a two element list; the first element is the list of arguments to the method in a form suitable for passing to another call to \fBproc\fR or a method definition, and the second element is the body of the method. .TP \fBinfo class destructor\fI class\fR . This subcommand returns the body of the destructor of class \fIclass\fR. If no destructor is present, this returns the empty string. .TP \fBinfo class filters\fI class\fR | > > > > > > > > > > > > > > > > > > | 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 | \fBinfo class definition\fI class method\fR . This subcommand returns a description of the definition of the method named \fImethod\fR of class \fIclass\fR. The definition is described as a two element list; the first element is the list of arguments to the method in a form suitable for passing to another call to \fBproc\fR or a method definition, and the second element is the body of the method. .TP \fBinfo class definitionnamespace\fI class\fR ?\fIkind\fR? .VS TIP524 This subcommand returns the definition namespace for \fIkind\fR definitions of the class \fIclass\fR; the definition namespace only affects the instances of \fIclass\fR, not \fIclass\fR itself. The \fIkind\fR can be either \fB\-class\fR to return the definition namespace used for \fBoo::define\fR, or \fB\-instance\fR to return the definition namespace used for \fBoo::objdefine\fR; the \fB\-class\fR kind is default (though this is only actually useful on classes that are subclasses of \fBoo::class\fR). .RS .PP If \fIclass\fR does not provide a definition namespace of the specified kind, this command returns the empty string. In those circumstances, the \fBoo::define\fR and \fBoo::objdefine\fR commands look up which definition namespace to use using the class inheritance hierarchy. .RE .VE TIP524 .TP \fBinfo class destructor\fI class\fR . This subcommand returns the body of the destructor of class \fIclass\fR. If no destructor is present, this returns the empty string. .TP \fBinfo class filters\fI class\fR |
︙ | ︙ |
Changes to generic/tclOO.c.
︙ | ︙ | |||
22 23 24 25 26 27 28 29 30 31 32 33 34 35 | static const struct { const char *name; Tcl_ObjCmdProc *objProc; int flag; } defineCmds[] = { {"constructor", TclOODefineConstructorObjCmd, 0}, {"deletemethod", TclOODefineDeleteMethodObjCmd, 0}, {"destructor", TclOODefineDestructorObjCmd, 0}, {"export", TclOODefineExportObjCmd, 0}, {"forward", TclOODefineForwardObjCmd, 0}, {"method", TclOODefineMethodObjCmd, 0}, {"private", TclOODefinePrivateObjCmd, 0}, {"renamemethod", TclOODefineRenameMethodObjCmd, 0}, | > | 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 | static const struct { const char *name; Tcl_ObjCmdProc *objProc; int flag; } defineCmds[] = { {"constructor", TclOODefineConstructorObjCmd, 0}, {"definitionnamespace", TclOODefineDefnNsObjCmd, 0}, {"deletemethod", TclOODefineDeleteMethodObjCmd, 0}, {"destructor", TclOODefineDestructorObjCmd, 0}, {"export", TclOODefineExportObjCmd, 0}, {"forward", TclOODefineForwardObjCmd, 0}, {"method", TclOODefineMethodObjCmd, 0}, {"private", TclOODefinePrivateObjCmd, 0}, {"renamemethod", TclOODefineRenameMethodObjCmd, 0}, |
︙ | ︙ | |||
441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 | static void InitClassSystemRoots( Tcl_Interp *interp, Foundation *fPtr) { Class fakeCls; Object fakeObject; /* Stand up a phony class for bootstrapping. */ fPtr->objectCls = &fakeCls; /* referenced in TclOOAllocClass to increment the refCount. */ fakeCls.thisPtr = &fakeObject; fPtr->objectCls = TclOOAllocClass(interp, AllocObject(interp, "object", (Namespace *)fPtr->ooNs, NULL)); /* Corresponding TclOODecrRefCount in KillFoudation */ AddRef(fPtr->objectCls->thisPtr); | > > | | > > > | > > > > > > | > > > > > | 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 | static void InitClassSystemRoots( Tcl_Interp *interp, Foundation *fPtr) { Class fakeCls; Object fakeObject; Tcl_Obj *defNsName; /* Stand up a phony class for bootstrapping. */ fPtr->objectCls = &fakeCls; /* referenced in TclOOAllocClass to increment the refCount. */ fakeCls.thisPtr = &fakeObject; fPtr->objectCls = TclOOAllocClass(interp, AllocObject(interp, "object", (Namespace *)fPtr->ooNs, NULL)); /* Corresponding TclOODecrRefCount in KillFoudation */ AddRef(fPtr->objectCls->thisPtr); /* * This is why it is unnecessary in this routine to replace the * incremented reference count of fPtr->objectCls that was swallowed by * fakeObject. */ fPtr->objectCls->superclasses.num = 0; ckfree(fPtr->objectCls->superclasses.list); fPtr->objectCls->superclasses.list = NULL; /* * Special initialization for the primordial objects. */ fPtr->objectCls->thisPtr->flags |= ROOT_OBJECT; fPtr->objectCls->flags |= ROOT_OBJECT; TclNewLiteralStringObj(defNsName, "::oo::objdefine"); fPtr->objectCls->objDefinitionNs = defNsName; Tcl_IncrRefCount(defNsName); fPtr->classCls = TclOOAllocClass(interp, AllocObject(interp, "class", (Namespace *)fPtr->ooNs, NULL)); /* Corresponding TclOODecrRefCount in KillFoudation */ AddRef(fPtr->classCls->thisPtr); /* * Increment reference counts for each reference because these * relationships can be dynamically changed. * * Corresponding TclOODecrRefCount for all incremented refcounts is in * KillFoundation. */ /* * Rewire bootstrapped objects. */ fPtr->objectCls->thisPtr->selfCls = fPtr->classCls; AddRef(fPtr->classCls->thisPtr); TclOOAddToInstances(fPtr->objectCls->thisPtr, fPtr->classCls); fPtr->classCls->thisPtr->selfCls = fPtr->classCls; AddRef(fPtr->classCls->thisPtr); TclOOAddToInstances(fPtr->classCls->thisPtr, fPtr->classCls); fPtr->classCls->thisPtr->flags |= ROOT_CLASS; fPtr->classCls->flags |= ROOT_CLASS; TclNewLiteralStringObj(defNsName, "::oo::define"); fPtr->classCls->clsDefinitionNs = defNsName; Tcl_IncrRefCount(defNsName); /* Standard initialization for new Objects */ TclOOAddToSubclasses(fPtr->classCls, fPtr->objectCls); /* * THIS IS THE ONLY FUNCTION THAT DOES NON-STANDARD CLASS SPLICING. * Everything else is careful to prohibit looping. |
︙ | ︙ | |||
953 954 955 956 957 958 959 960 961 962 963 964 965 966 | Tcl_Panic("deleting class structure for non-deleted %s", "::oo::class"); } else if (IsRootObject(oPtr)) { Tcl_Panic("deleting class structure for non-deleted %s", "::oo::object"); } } /* * Squelch method implementation chain caches. */ if (clsPtr->constructorChainPtr) { TclOODeleteChain(clsPtr->constructorChainPtr); | > > > > > > > > > > > > > | 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 | Tcl_Panic("deleting class structure for non-deleted %s", "::oo::class"); } else if (IsRootObject(oPtr)) { Tcl_Panic("deleting class structure for non-deleted %s", "::oo::object"); } } /* * Stop using the class for definition information. */ if (clsPtr->clsDefinitionNs) { Tcl_DecrRefCount(clsPtr->clsDefinitionNs); clsPtr->clsDefinitionNs = NULL; } if (clsPtr->objDefinitionNs) { Tcl_DecrRefCount(clsPtr->objDefinitionNs); clsPtr->objDefinitionNs = NULL; } /* * Squelch method implementation chain caches. */ if (clsPtr->constructorChainPtr) { TclOODeleteChain(clsPtr->constructorChainPtr); |
︙ | ︙ |
Changes to generic/tclOOCall.c.
︙ | ︙ | |||
26 27 28 29 30 31 32 33 34 35 36 37 38 39 | int filterLength; /* Number of entries in the call chain that * are due to processing filters and not the * main call chain. */ Object *oPtr; /* The object that we are building the chain * for. */ }; /* * Extra flags used for call chain management. */ #define DEFINITE_PROTECTED 0x100000 #define DEFINITE_PUBLIC 0x200000 #define KNOWN_STATE (DEFINITE_PROTECTED | DEFINITE_PUBLIC) | > > > > > > > > > > > > > > > > | 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 | int filterLength; /* Number of entries in the call chain that * are due to processing filters and not the * main call chain. */ Object *oPtr; /* The object that we are building the chain * for. */ }; /* * Structures used for traversing the class hierarchy to find out where * definitions are supposed to be done. */ typedef struct { Class *definerCls; Tcl_Obj *namespaceName; } DefineEntry; typedef struct { DefineEntry *list; int num; int size; } DefineChain; /* * Extra flags used for call chain management. */ #define DEFINITE_PROTECTED 0x100000 #define DEFINITE_PUBLIC 0x200000 #define KNOWN_STATE (DEFINITE_PROTECTED | DEFINITE_PUBLIC) |
︙ | ︙ | |||
73 74 75 76 77 78 79 80 81 82 83 84 85 86 | static void AddClassFiltersToCallContext(Object *const oPtr, Class *clsPtr, struct ChainBuilder *const cbPtr, Tcl_HashTable *const doneFilters, int flags); static void AddClassMethodNames(Class *clsPtr, const int flags, Tcl_HashTable *const namesPtr, Tcl_HashTable *const examinedClassesPtr); static inline void AddMethodToCallChain(Method *const mPtr, struct ChainBuilder *const cbPtr, Tcl_HashTable *const doneFilters, Class *const filterDecl, int flags); static inline int AddInstancePrivateToCallContext(Object *const oPtr, Tcl_Obj *const methodNameObj, struct ChainBuilder *const cbPtr, int flags); | > > > | 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 | static void AddClassFiltersToCallContext(Object *const oPtr, Class *clsPtr, struct ChainBuilder *const cbPtr, Tcl_HashTable *const doneFilters, int flags); static void AddClassMethodNames(Class *clsPtr, const int flags, Tcl_HashTable *const namesPtr, Tcl_HashTable *const examinedClassesPtr); static inline void AddDefinitionNamespaceToChain(Class *const definerCls, Tcl_Obj *const namespaceName, DefineChain *const definePtr, const int flags); static inline void AddMethodToCallChain(Method *const mPtr, struct ChainBuilder *const cbPtr, Tcl_HashTable *const doneFilters, Class *const filterDecl, int flags); static inline int AddInstancePrivateToCallContext(Object *const oPtr, Tcl_Obj *const methodNameObj, struct ChainBuilder *const cbPtr, int flags); |
︙ | ︙ | |||
101 102 103 104 105 106 107 108 109 110 111 112 113 114 | Tcl_HashTable *const doneFilters, int flags, Class *const filterDecl); static int AddSimpleClassChainToCallContext(Class *classPtr, Tcl_Obj *const methodNameObj, struct ChainBuilder *const cbPtr, Tcl_HashTable *const doneFilters, int flags, Class *const filterDecl); static int CmpStr(const void *ptr1, const void *ptr2); static void DupMethodNameRep(Tcl_Obj *srcPtr, Tcl_Obj *dstPtr); static Tcl_NRPostProc FinalizeMethodRefs; static void FreeMethodNameRep(Tcl_Obj *objPtr); static inline int IsStillValid(CallChain *callPtr, Object *oPtr, int flags, int reuseMask); static Tcl_NRPostProc ResetFilterFlags; | > > > > | 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 | Tcl_HashTable *const doneFilters, int flags, Class *const filterDecl); static int AddSimpleClassChainToCallContext(Class *classPtr, Tcl_Obj *const methodNameObj, struct ChainBuilder *const cbPtr, Tcl_HashTable *const doneFilters, int flags, Class *const filterDecl); static void AddSimpleClassDefineNamespaces(Class *classPtr, DefineChain *const definePtr, int flags); static inline void AddSimpleDefineNamespaces(Object *const oPtr, DefineChain *const definePtr, int flags); static int CmpStr(const void *ptr1, const void *ptr2); static void DupMethodNameRep(Tcl_Obj *srcPtr, Tcl_Obj *dstPtr); static Tcl_NRPostProc FinalizeMethodRefs; static void FreeMethodNameRep(Tcl_Obj *objPtr); static inline int IsStillValid(CallChain *callPtr, Object *oPtr, int flags, int reuseMask); static Tcl_NRPostProc ResetFilterFlags; |
︙ | ︙ | |||
1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 | * Finish building the description and return it. */ resultObj = Tcl_NewListObj(callPtr->numChain, objv); TclStackFree(interp, objv); return resultObj; } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 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 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 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 | * Finish building the description and return it. */ resultObj = Tcl_NewListObj(callPtr->numChain, objv); TclStackFree(interp, objv); return resultObj; } /* * ---------------------------------------------------------------------- * * TclOOGetDefineContextNamespace -- * * Responsible for determining which namespace to use for definitions. * This is done by building a define chain, which models (strongly!) the * way that a call chain works but with a different internal model. * * Then it walks the chain to find the first namespace name that actually * resolves to an existing namespace. * * Returns: * Name of namespace, or NULL if none can be found. Note that this * function does *not* set an error message in the interpreter on failure. * * ---------------------------------------------------------------------- */ #define DEFINE_CHAIN_STATIC_SIZE 4 /* Enough space to store most cases. */ Tcl_Namespace * TclOOGetDefineContextNamespace( Tcl_Interp *interp, /* In what interpreter should namespace names * actually be resolved. */ Object *oPtr, /* The object to get the context for. */ int forClass) /* What sort of context are we looking for. * If true, we are going to use this for * [oo::define], otherwise, we are going to * use this for [oo::objdefine]. */ { DefineChain define; DefineEntry staticSpace[DEFINE_CHAIN_STATIC_SIZE]; DefineEntry *entryPtr; Tcl_Namespace *nsPtr = NULL; int i; define.list = staticSpace; define.num = 0; define.size = DEFINE_CHAIN_STATIC_SIZE; /* * Add the actual define locations. We have to do this twice to handle * class mixins right. */ AddSimpleDefineNamespaces(oPtr, &define, forClass | BUILDING_MIXINS); AddSimpleDefineNamespaces(oPtr, &define, forClass); /* * Go through the list until we find a namespace whose name we can * resolve. */ FOREACH_STRUCT(entryPtr, define) { if (TclGetNamespaceFromObj(interp, entryPtr->namespaceName, &nsPtr) == TCL_OK) { break; } Tcl_ResetResult(interp); } if (define.list != staticSpace) { ckfree(define.list); } return nsPtr; } /* * ---------------------------------------------------------------------- * * AddSimpleDefineNamespaces -- * * Adds to the definition chain all the definitions provided by an * object's class and its mixins, taking into account everything they * inherit from. * * ---------------------------------------------------------------------- */ static inline void AddSimpleDefineNamespaces( Object *const oPtr, /* Object to add define chain entries for. */ DefineChain *const definePtr, /* Where to add the define chain entries. */ int flags) /* What sort of define chain are we * building. */ { Class *mixinPtr; int i; FOREACH(mixinPtr, oPtr->mixins) { AddSimpleClassDefineNamespaces(mixinPtr, definePtr, flags | TRAVERSED_MIXIN); } AddSimpleClassDefineNamespaces(oPtr->selfCls, definePtr, flags); } /* * ---------------------------------------------------------------------- * * AddSimpleClassDefineNamespaces -- * * Adds to the definition chain all the definitions provided by a class * and its superclasses and its class mixins. * * ---------------------------------------------------------------------- */ static void AddSimpleClassDefineNamespaces( Class *classPtr, /* Class to add the define chain entries for. */ DefineChain *const definePtr, /* Where to add the define chain entries. */ int flags) /* What sort of define chain are we * building. */ { int i; Class *superPtr; /* * We hard-code the tail-recursive form. It's by far the most common case * *and* it is much more gentle on the stack. */ tailRecurse: FOREACH(superPtr, classPtr->mixins) { AddSimpleClassDefineNamespaces(superPtr, definePtr, flags | TRAVERSED_MIXIN); } if (flags & ~(TRAVERSED_MIXIN | BUILDING_MIXINS)) { AddDefinitionNamespaceToChain(classPtr, classPtr->clsDefinitionNs, definePtr, flags); } else { AddDefinitionNamespaceToChain(classPtr, classPtr->objDefinitionNs, definePtr, flags); } switch (classPtr->superclasses.num) { case 1: classPtr = classPtr->superclasses.list[0]; goto tailRecurse; default: FOREACH(superPtr, classPtr->superclasses) { AddSimpleClassDefineNamespaces(superPtr, definePtr, flags); } case 0: return; } } /* * ---------------------------------------------------------------------- * * AddDefinitionNamespaceToChain -- * * Adds a single item to the definition chain (if it is meaningful), * reallocating the space for the chain if necessary. * * ---------------------------------------------------------------------- */ static inline void AddDefinitionNamespaceToChain( Class *definerCls, /* What class defines this entry. */ Tcl_Obj *namespaceName, /* The name for this entry (or NULL, a * no-op). */ DefineChain *const definePtr, /* The define chain to add the method * implementation to. */ int flags) /* Used to check if we're mixin-consistent * only. Mixin-consistent means that either * we're looking to add things from a mixin * and we have passed a mixin, or we're not * looking to add things from a mixin and have * not passed a mixin. */ { int i; /* * Return if this entry is blank. This is also where we enforce * mixin-consistency. */ if (namespaceName == NULL || !MIXIN_CONSISTENT(flags)) { return; } /* * First test whether the method is already in the call chain. */ for (i=0 ; i<definePtr->num ; i++) { if (definePtr->list[i].definerCls == definerCls) { /* * Call chain semantics states that methods come as *late* in the * call chain as possible. This is done by copying down the * following methods. Note that this does not change the number of * method invocations in the call chain; it just rearranges them. * * We skip changing anything if the place we found was already at * the end of the list. */ if (i < definePtr->num - 1) { memmove(&definePtr->list[i], &definePtr->list[i + 1], sizeof(DefineEntry) * (definePtr->num - i - 1)); definePtr->list[i].definerCls = definerCls; definePtr->list[i].namespaceName = namespaceName; } return; } } /* * Need to really add the define. This is made a bit more complex by the * fact that we are using some "static" space initially, and only start * realloc-ing if the chain gets long. */ if (definePtr->num == definePtr->size) { definePtr->size *= 2; if (definePtr->num == DEFINE_CHAIN_STATIC_SIZE) { DefineEntry *staticList = definePtr->list; definePtr->list = ckalloc(sizeof(DefineEntry) * definePtr->size); memcpy(definePtr->list, staticList, sizeof(DefineEntry) * definePtr->num); } else { definePtr->list = ckrealloc(definePtr->list, sizeof(DefineEntry) * definePtr->size); } } definePtr->list[i].definerCls = definerCls; definePtr->list[i].namespaceName = namespaceName; definePtr->num++; } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to generic/tclOODefineCmds.c.
︙ | ︙ | |||
59 60 61 62 63 64 65 66 67 68 69 70 71 72 | static inline void GenerateErrorInfo(Tcl_Interp *interp, Object *oPtr, Tcl_Obj *savedNameObj, const char *typeOfSubject); static inline int MagicDefinitionInvoke(Tcl_Interp *interp, Tcl_Namespace *nsPtr, int cmdIndex, int objc, Tcl_Obj *const *objv); 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 useClass, Tcl_Obj *const fromPtr, Tcl_Obj *const toPtr); | > > | 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 | static inline void GenerateErrorInfo(Tcl_Interp *interp, Object *oPtr, Tcl_Obj *savedNameObj, const char *typeOfSubject); static inline int MagicDefinitionInvoke(Tcl_Interp *interp, Tcl_Namespace *nsPtr, int cmdIndex, int objc, Tcl_Obj *const *objv); static inline Class * GetClassInOuterContext(Tcl_Interp *interp, Tcl_Obj *className, const char *errMsg); static inline Tcl_Namespace *GetNamespaceInOuterContext(Tcl_Interp *interp, Tcl_Obj *namespaceName); 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 useClass, Tcl_Obj *const fromPtr, Tcl_Obj *const toPtr); |
︙ | ︙ | |||
824 825 826 827 828 829 830 | int objc, Tcl_Obj *const objv[]) { CallFrame *framePtr, **framePtrPtr = &framePtr; if (namespacePtr == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( | | < | 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 | int objc, Tcl_Obj *const objv[]) { CallFrame *framePtr, **framePtrPtr = &framePtr; if (namespacePtr == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "no definition namespace available", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; } /* * framePtrPtr is needed to satisfy GCC 3.3's strict aliasing rules. */ |
︙ | ︙ | |||
884 885 886 887 888 889 890 | } return object; } /* * ---------------------------------------------------------------------- * | | | | | | | 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 | } return object; } /* * ---------------------------------------------------------------------- * * GetClassInOuterContext, GetNamespaceInOuterContext -- * * Wrappers round Tcl_GetObjectFromObj and TclGetNamespaceFromObj to * perform the lookup in the context that called oo::define (or * equivalent). Note that this may have to go up multiple levels to get * the level that we started doing definitions at. * * ---------------------------------------------------------------------- */ static inline Class * GetClassInOuterContext( Tcl_Interp *interp, |
︙ | ︙ | |||
924 925 926 927 928 929 930 931 932 933 934 935 936 937 | Tcl_SetObjResult(interp, Tcl_NewStringObj(errMsg, -1)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS", TclGetString(className), NULL); return NULL; } return oPtr->classPtr; } /* * ---------------------------------------------------------------------- * * GenerateErrorInfo -- * * Factored out code to generate part of the error trace messages. | > > > > > > > > > > > > > > > > > > > > > > > > > | 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 | Tcl_SetObjResult(interp, Tcl_NewStringObj(errMsg, -1)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS", TclGetString(className), NULL); return NULL; } return oPtr->classPtr; } static inline Tcl_Namespace * GetNamespaceInOuterContext( Tcl_Interp *interp, Tcl_Obj *namespaceName) { Interp *iPtr = (Interp *) interp; Tcl_Namespace *nsPtr; int result; CallFrame *savedFramePtr = iPtr->varFramePtr; while (iPtr->varFramePtr->isProcCallFrame == FRAME_IS_OO_DEFINE || iPtr->varFramePtr->isProcCallFrame == PRIVATE_FRAME) { if (iPtr->varFramePtr->callerVarPtr == NULL) { Tcl_Panic("getting outer context when already in global context"); } iPtr->varFramePtr = iPtr->varFramePtr->callerVarPtr; } result = TclGetNamespaceFromObj(interp, namespaceName, &nsPtr); iPtr->varFramePtr = savedFramePtr; if (result != TCL_OK) { return NULL; } return nsPtr; } /* * ---------------------------------------------------------------------- * * GenerateErrorInfo -- * * Factored out code to generate part of the error trace messages. |
︙ | ︙ | |||
1049 1050 1051 1052 1053 1054 1055 | int TclOODefineObjCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { | | | > | | | 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 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 | int TclOODefineObjCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { Tcl_Namespace *nsPtr; Object *oPtr; int result; if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, "className arg ?arg ...?"); return TCL_ERROR; } oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); if (oPtr == NULL) { return TCL_ERROR; } if (oPtr->classPtr == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "%s does not refer to a class", TclGetString(objv[1]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS", TclGetString(objv[1]), NULL); return TCL_ERROR; } /* * Make the oo::define namespace the current namespace and evaluate the * command(s). */ nsPtr = TclOOGetDefineContextNamespace(interp, oPtr, 1); if (InitDefineContext(interp, nsPtr, 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"); } TclDecrRefCount(objNameObj); } else { result = MagicDefinitionInvoke(interp, nsPtr, 2, objc, objv); } TclOODecrRefCount(oPtr); /* * Restore the previous "current" namespace. */ |
︙ | ︙ | |||
1124 1125 1126 1127 1128 1129 1130 | int TclOOObjDefObjCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { | | > | | | 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 | int TclOOObjDefObjCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { Tcl_Namespace *nsPtr; Object *oPtr; int result; if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, "objectName arg ?arg ...?"); return TCL_ERROR; } oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); if (oPtr == NULL) { return TCL_ERROR; } /* * Make the oo::objdefine namespace the current namespace and evaluate the * command(s). */ nsPtr = TclOOGetDefineContextNamespace(interp, oPtr, 0); if (InitDefineContext(interp, nsPtr, 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"); } TclDecrRefCount(objNameObj); } else { result = MagicDefinitionInvoke(interp, nsPtr, 2, objc, objv); } TclOODecrRefCount(oPtr); /* * Restore the previous "current" namespace. */ |
︙ | ︙ | |||
1192 1193 1194 1195 1196 1197 1198 | int TclOODefineSelfObjCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { | | > | | | 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 | int TclOODefineSelfObjCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { Tcl_Namespace *nsPtr; Object *oPtr; int result, private; oPtr = (Object *) TclOOGetDefineCmdContext(interp); if (oPtr == NULL) { return TCL_ERROR; } if (objc < 2) { Tcl_SetObjResult(interp, TclOOObjectName(interp, oPtr)); return TCL_OK; } private = IsPrivateDefine(interp); /* * Make the oo::objdefine namespace the current namespace and evaluate the * command(s). */ nsPtr = TclOOGetDefineContextNamespace(interp, oPtr, 0); if (InitDefineContext(interp, nsPtr, oPtr, objc, objv) != TCL_OK) { return TCL_ERROR; } if (private) { ((Interp *) interp)->varFramePtr->isProcCallFrame = PRIVATE_FRAME; } AddRef(oPtr); if (objc == 2) { Tcl_Obj *objNameObj = TclOOObjectName(interp, oPtr); Tcl_IncrRefCount(objNameObj); result = TclEvalObjEx(interp, objv[1], 0, ((Interp *)interp)->cmdFramePtr, 1); if (result == TCL_ERROR) { GenerateErrorInfo(interp, oPtr, objNameObj, "class object"); } TclDecrRefCount(objNameObj); } else { result = MagicDefinitionInvoke(interp, nsPtr, 1, objc, objv); } TclOODecrRefCount(oPtr); /* * Restore the previous "current" namespace. */ |
︙ | ︙ | |||
1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 | * immediately delete the constructor as this might be being done during * execution of the constructor itself. */ Tcl_ClassSetConstructor(interp, (Tcl_Class) clsPtr, method); return TCL_OK; } /* * ---------------------------------------------------------------------- * * TclOODefineDeleteMethodObjCmd -- * * Implementation of the "deletemethod" subcommand of the "oo::define" | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 | * immediately delete the constructor as this might be being done during * execution of the constructor itself. */ Tcl_ClassSetConstructor(interp, (Tcl_Class) clsPtr, method); return TCL_OK; } /* * ---------------------------------------------------------------------- * * TclOODefineDefnNsObjCmd -- * * Implementation of the "definitionnamespace" subcommand of the * "oo::define" command. * * ---------------------------------------------------------------------- */ int TclOODefineDefnNsObjCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { static const char *kindList[] = { "-class", "-instance", NULL }; int kind = 0; Object *oPtr; Tcl_Namespace *nsPtr; Tcl_Obj *nsNamePtr, **storagePtr; oPtr = (Object *) TclOOGetDefineCmdContext(interp); if (oPtr == NULL) { return TCL_ERROR; } if (!oPtr->classPtr) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "attempt to misuse API", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; } if (oPtr->flags & (ROOT_OBJECT | ROOT_CLASS)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "may not modify the definition namespace of the root classes", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; } /* * Parse the arguments and work out what the user wants to do. */ if (objc != 2 && objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "?kind? namespace"); return TCL_ERROR; } if (objc == 3 && Tcl_GetIndexFromObj(interp, objv[1], kindList, "kind", 0, &kind) != TCL_OK) { return TCL_ERROR; } if (!Tcl_GetString(objv[objc - 1])[0]) { nsNamePtr = NULL; } else { nsPtr = GetNamespaceInOuterContext(interp, objv[objc - 1]); if (nsPtr == NULL) { return TCL_ERROR; } nsNamePtr = Tcl_NewStringObj(nsPtr->fullName, -1); Tcl_IncrRefCount(nsNamePtr); } /* * Update the correct field of the class definition. */ if (kind) { storagePtr = &oPtr->classPtr->objDefinitionNs; } else { storagePtr = &oPtr->classPtr->clsDefinitionNs; } if (*storagePtr != NULL) { Tcl_DecrRefCount(*storagePtr); } *storagePtr = nsNamePtr; return TCL_OK; } /* * ---------------------------------------------------------------------- * * TclOODefineDeleteMethodObjCmd -- * * Implementation of the "deletemethod" subcommand of the "oo::define" |
︙ | ︙ |
Changes to generic/tclOOInfo.c.
︙ | ︙ | |||
29 30 31 32 33 34 35 36 37 38 39 40 41 42 | static Tcl_ObjCmdProc InfoObjectMixinsCmd; static Tcl_ObjCmdProc InfoObjectNsCmd; static Tcl_ObjCmdProc InfoObjectVarsCmd; static Tcl_ObjCmdProc InfoObjectVariablesCmd; static Tcl_ObjCmdProc InfoClassCallCmd; static Tcl_ObjCmdProc InfoClassConstrCmd; static Tcl_ObjCmdProc InfoClassDefnCmd; static Tcl_ObjCmdProc InfoClassDestrCmd; static Tcl_ObjCmdProc InfoClassFiltersCmd; static Tcl_ObjCmdProc InfoClassForwardCmd; static Tcl_ObjCmdProc InfoClassInstancesCmd; static Tcl_ObjCmdProc InfoClassMethodsCmd; static Tcl_ObjCmdProc InfoClassMethodTypeCmd; static Tcl_ObjCmdProc InfoClassMixinsCmd; | > | 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 | static Tcl_ObjCmdProc InfoObjectMixinsCmd; static Tcl_ObjCmdProc InfoObjectNsCmd; static Tcl_ObjCmdProc InfoObjectVarsCmd; static Tcl_ObjCmdProc InfoObjectVariablesCmd; static Tcl_ObjCmdProc InfoClassCallCmd; static Tcl_ObjCmdProc InfoClassConstrCmd; static Tcl_ObjCmdProc InfoClassDefnCmd; static Tcl_ObjCmdProc InfoClassDefnNsCmd; static Tcl_ObjCmdProc InfoClassDestrCmd; static Tcl_ObjCmdProc InfoClassFiltersCmd; static Tcl_ObjCmdProc InfoClassForwardCmd; static Tcl_ObjCmdProc InfoClassInstancesCmd; static Tcl_ObjCmdProc InfoClassMethodsCmd; static Tcl_ObjCmdProc InfoClassMethodTypeCmd; static Tcl_ObjCmdProc InfoClassMixinsCmd; |
︙ | ︙ | |||
69 70 71 72 73 74 75 76 77 78 79 80 81 82 | * List of commands that are used to implement the [info class] subcommands. */ static const EnsembleImplMap infoClassCmds[] = { {"call", InfoClassCallCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, {"constructor", InfoClassConstrCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"definition", InfoClassDefnCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, {"destructor", InfoClassDestrCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"filters", InfoClassFiltersCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"forward", InfoClassForwardCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, {"instances", InfoClassInstancesCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, {"methods", InfoClassMethodsCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0}, {"methodtype", InfoClassMethodTypeCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, {"mixins", InfoClassMixinsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, | > | 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 | * List of commands that are used to implement the [info class] subcommands. */ static const EnsembleImplMap infoClassCmds[] = { {"call", InfoClassCallCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, {"constructor", InfoClassConstrCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"definition", InfoClassDefnCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, {"definitionnamespace", InfoClassDefnNsCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, {"destructor", InfoClassDestrCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"filters", InfoClassFiltersCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"forward", InfoClassForwardCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, {"instances", InfoClassInstancesCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, {"methods", InfoClassMethodsCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0}, {"methodtype", InfoClassMethodTypeCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, {"mixins", InfoClassMixinsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, |
︙ | ︙ | |||
1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 | Tcl_ListObjAppendElement(NULL, resultObjs[0], argObj); } } resultObjs[1] = TclOOGetMethodBody(Tcl_GetHashValue(hPtr)); Tcl_SetObjResult(interp, Tcl_NewListObj(2, resultObjs)); return TCL_OK; } /* * ---------------------------------------------------------------------- * * InfoClassDestrCmd -- * * Implements [info class destructor $clsName] | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 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 | Tcl_ListObjAppendElement(NULL, resultObjs[0], argObj); } } resultObjs[1] = TclOOGetMethodBody(Tcl_GetHashValue(hPtr)); Tcl_SetObjResult(interp, Tcl_NewListObj(2, resultObjs)); return TCL_OK; } /* * ---------------------------------------------------------------------- * * InfoClassDefnNsCmd -- * * Implements [info class definitionnamespace $clsName ?$kind?] * * ---------------------------------------------------------------------- */ static int InfoClassDefnNsCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { static const char *kindList[] = { "-class", "-instance", NULL }; int kind = 0; Tcl_Obj *nsNamePtr; Class *clsPtr; if (objc != 2 && objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "className ?kind?"); return TCL_ERROR; } clsPtr = GetClassFromObj(interp, objv[1]); if (clsPtr == NULL) { return TCL_ERROR; } if (objc == 3 && Tcl_GetIndexFromObj(interp, objv[2], kindList, "kind", 0, &kind) != TCL_OK) { return TCL_ERROR; } if (kind) { nsNamePtr = clsPtr->objDefinitionNs; } else { nsNamePtr = clsPtr->clsDefinitionNs; } if (nsNamePtr) { Tcl_SetObjResult(interp, nsNamePtr); } return TCL_OK; } /* * ---------------------------------------------------------------------- * * InfoClassDestrCmd -- * * Implements [info class destructor $clsName] |
︙ | ︙ |
Changes to generic/tclOOInt.h.
︙ | ︙ | |||
300 301 302 303 304 305 306 307 308 309 310 311 312 313 | * object doesn't override with its own mixins * (and filters and method implementations for * when getting method chains). */ VariableNameList variables; PrivateVariableList privateVariables; /* Configurations for the variable resolver * used inside methods. */ } Class; /* * The foundation of the object system within an interpreter contains * references to the key classes and namespaces, together with a few other * useful bits and pieces. Probably ought to eventually go in the Interp * structure itself. | > > > > > > > > > > > > > > > > > > | 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 | * object doesn't override with its own mixins * (and filters and method implementations for * when getting method chains). */ VariableNameList variables; PrivateVariableList privateVariables; /* Configurations for the variable resolver * used inside methods. */ Tcl_Obj *clsDefinitionNs; /* Name of the namespace to use for * definitions commands of instances of this * class in when those instances are defined * as classes. If NULL, use the value from the * class hierarchy. It's an error at * [oo::define] call time if this namespace is * defined but doesn't exist; we also check at * setting time but don't check between * times. */ Tcl_Obj *objDefinitionNs; /* Name of the namespace to use for * definitions commands of instances of this * class in when those instances are defined * as instances. If NULL, use the value from * the class hierarchy. It's an error at * [oo::objdefine]/[self] call time if this * namespace is defined but doesn't exist; we * also check at setting time but don't check * between times. */ } Class; /* * The foundation of the object system within an interpreter contains * references to the key classes and namespaces, together with a few other * useful bits and pieces. Probably ought to eventually go in the Interp * structure itself. |
︙ | ︙ | |||
436 437 438 439 440 441 442 443 444 445 446 447 448 449 | Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); MODULE_SCOPE int TclOOObjDefObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); MODULE_SCOPE int TclOODefineConstructorObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); MODULE_SCOPE int TclOODefineDeleteMethodObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); MODULE_SCOPE int TclOODefineDestructorObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); | > > > | 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 | Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); MODULE_SCOPE int TclOOObjDefObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); MODULE_SCOPE int TclOODefineConstructorObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); MODULE_SCOPE int TclOODefineDefnNsObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); MODULE_SCOPE int TclOODefineDeleteMethodObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); MODULE_SCOPE int TclOODefineDestructorObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); |
︙ | ︙ | |||
549 550 551 552 553 554 555 556 557 558 559 560 561 562 | MODULE_SCOPE void TclOODeleteDescendants(Tcl_Interp *interp, Object *oPtr); MODULE_SCOPE void TclOODelMethodRef(Method *method); MODULE_SCOPE CallContext *TclOOGetCallContext(Object *oPtr, Tcl_Obj *methodNameObj, int flags, Object *contextObjPtr, Class *contextClsPtr, Tcl_Obj *cacheInThisObj); MODULE_SCOPE CallChain *TclOOGetStereotypeCallChain(Class *clsPtr, Tcl_Obj *methodNameObj, int flags); MODULE_SCOPE Foundation *TclOOGetFoundation(Tcl_Interp *interp); MODULE_SCOPE Tcl_Obj * TclOOGetFwdFromMethod(Method *mPtr); MODULE_SCOPE Proc * TclOOGetProcFromMethod(Method *mPtr); MODULE_SCOPE Tcl_Obj * TclOOGetMethodBody(Method *mPtr); MODULE_SCOPE int TclOOGetSortedClassMethodList(Class *clsPtr, | > > | 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 | MODULE_SCOPE void TclOODeleteDescendants(Tcl_Interp *interp, Object *oPtr); MODULE_SCOPE void TclOODelMethodRef(Method *method); MODULE_SCOPE CallContext *TclOOGetCallContext(Object *oPtr, Tcl_Obj *methodNameObj, int flags, Object *contextObjPtr, Class *contextClsPtr, Tcl_Obj *cacheInThisObj); MODULE_SCOPE Tcl_Namespace *TclOOGetDefineContextNamespace( Tcl_Interp *interp, Object *oPtr, int forClass); MODULE_SCOPE CallChain *TclOOGetStereotypeCallChain(Class *clsPtr, Tcl_Obj *methodNameObj, int flags); MODULE_SCOPE Foundation *TclOOGetFoundation(Tcl_Interp *interp); MODULE_SCOPE Tcl_Obj * TclOOGetFwdFromMethod(Method *mPtr); MODULE_SCOPE Proc * TclOOGetProcFromMethod(Method *mPtr); MODULE_SCOPE Tcl_Obj * TclOOGetMethodBody(Method *mPtr); MODULE_SCOPE int TclOOGetSortedClassMethodList(Class *clsPtr, |
︙ | ︙ |
Changes to generic/tclOOScript.h.
︙ | ︙ | |||
94 95 96 97 98 99 100 | "\t\t\treturn\n" "\t\t}\n" "\t\tforeach c [info class superclass $class] {\n" "\t\t\tset d [DelegateName $c]\n" "\t\t\tif {![info object isa class $d]} {\n" "\t\t\t\tcontinue\n" "\t\t\t}\n" | | | | 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 | "\t\t\treturn\n" "\t\t}\n" "\t\tforeach c [info class superclass $class] {\n" "\t\t\tset d [DelegateName $c]\n" "\t\t\tif {![info object isa class $d]} {\n" "\t\t\t\tcontinue\n" "\t\t\t}\n" "\t\t\tdefine $delegate ::oo::define::superclass -append $d\n" "\t\t}\n" "\t\tobjdefine $class ::oo::objdefine::mixin -append $delegate\n" "\t}\n" "\tproc UpdateClassDelegatesAfterClone {originObject targetObject} {\n" "\t\tset originDelegate [DelegateName $originObject]\n" "\t\tset targetDelegate [DelegateName $targetObject]\n" "\t\tif {\n" "\t\t\t[info object isa class $originDelegate]\n" "\t\t\t&& ![info object isa class $targetDelegate]\n" |
︙ | ︙ |
Changes to generic/tclOOScript.tcl.
︙ | ︙ | |||
149 150 151 152 153 154 155 | return } foreach c [info class superclass $class] { set d [DelegateName $c] if {![info object isa class $d]} { continue } | | | | | 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 | return } foreach c [info class superclass $class] { set d [DelegateName $c] if {![info object isa class $d]} { continue } define $delegate ::oo::define::superclass -append $d } objdefine $class ::oo::objdefine::mixin -append $delegate } # ---------------------------------------------------------------------- # # UpdateClassDelegatesAfterClone -- # # Support code that is like [MixinClassDelegates] except for when a # class is cloned. # # ---------------------------------------------------------------------- proc UpdateClassDelegatesAfterClone {originObject targetObject} { # Rebuild the class inheritance delegation class set originDelegate [DelegateName $originObject] set targetDelegate [DelegateName $targetObject] if { [info object isa class $originDelegate] && ![info object isa class $targetDelegate] } then { copy $originDelegate $targetDelegate objdefine $targetObject ::oo::objdefine::mixin -set \ {*}[lmap c [info object mixin $targetObject] { if {$c eq $originDelegate} {set targetDelegate} {set c} }] } } # ---------------------------------------------------------------------- |
︙ | ︙ |
Changes to tests/oo.test.
︙ | ︙ | |||
325 326 327 328 329 330 331 332 | obj destroy info commands ::AGlobalName } -result {} test oo-1.21 {basic test of OO functionality: default relations} -setup { set fresh [interp create] } -body { lmap x [$fresh eval { foreach cmd {instances subclasses mixins superclass} { | > | | | | | | 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 | obj destroy info commands ::AGlobalName } -result {} test oo-1.21 {basic test of OO functionality: default relations} -setup { set fresh [interp create] } -body { lmap x [$fresh eval { set initials {::oo::object ::oo::class ::oo::Slot} foreach cmd {instances subclasses mixins superclass} { foreach initial $initials { lappend x [info class $cmd $initial] } } foreach initial $initials { lappend x [info object class $initial] } return $x }] {lsort [lsearch -all -not -inline $x *::delegate]} } -cleanup { interp delete $fresh } -result {{} {::oo::Slot ::oo::abstract ::oo::class ::oo::object ::oo::singleton} {::oo::define::filter ::oo::define::mixin ::oo::define::superclass ::oo::define::variable ::oo::objdefine::filter ::oo::objdefine::mixin ::oo::objdefine::variable} {::oo::Slot ::oo::class} {::oo::abstract ::oo::singleton} {} {} {} {} {} ::oo::object ::oo::object ::oo::class ::oo::class ::oo::class} test oo-2.1 {basic test of OO functionality: constructor} -setup { # This is a bit complex because it needs to run in a sub-interp as # we're modifying the root object class's constructor |
︙ | ︙ | |||
2515 2516 2517 2518 2519 2520 2521 | } -body { info class superclass foo } -returnCodes 1 -cleanup { foo destroy } -result {"foo" is not a class} test oo-17.4 {OO: class introspection} -body { info class gorp oo::object | | | 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 | } -body { info class superclass foo } -returnCodes 1 -cleanup { foo destroy } -result {"foo" is not a class} test oo-17.4 {OO: class introspection} -body { info class gorp oo::object } -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be call, constructor, definition, definitionnamespace, destructor, filters, forward, instances, methods, methodtype, mixins, subclasses, superclasses, or variables} test oo-17.5 {OO: class introspection} -setup { oo::class create testClass } -body { testClass create foo testClass create bar testClass create spong lsort [info class instances testClass] |
︙ | ︙ | |||
5072 5073 5074 5075 5076 5077 5078 5079 5080 5081 5082 5083 5084 5085 | forward poke myclass Hi } cls1 create x lappend result [catch {cls1 Hi}] [x poke] } -cleanup { parent destroy } -result {1 {this is ::cls1}} cleanupTests return # Local Variables: # mode: tcl # End: | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 5073 5074 5075 5076 5077 5078 5079 5080 5081 5082 5083 5084 5085 5086 5087 5088 5089 5090 5091 5092 5093 5094 5095 5096 5097 5098 5099 5100 5101 5102 5103 5104 5105 5106 5107 5108 5109 5110 5111 5112 5113 5114 5115 5116 5117 5118 5119 5120 5121 5122 5123 5124 5125 5126 5127 5128 5129 5130 5131 5132 5133 5134 5135 5136 5137 5138 5139 5140 5141 5142 5143 5144 5145 5146 5147 5148 5149 5150 5151 5152 5153 5154 5155 5156 5157 5158 5159 5160 5161 5162 5163 5164 5165 5166 5167 5168 5169 5170 5171 5172 5173 5174 5175 5176 5177 5178 5179 5180 5181 5182 5183 5184 5185 5186 5187 5188 5189 5190 5191 5192 5193 5194 5195 5196 5197 5198 5199 5200 5201 5202 5203 5204 5205 5206 5207 5208 5209 5210 5211 5212 5213 5214 5215 5216 5217 5218 5219 5220 5221 5222 5223 5224 5225 5226 5227 5228 5229 5230 5231 5232 5233 5234 5235 5236 5237 5238 5239 5240 5241 5242 5243 5244 5245 5246 5247 5248 5249 5250 5251 5252 5253 5254 5255 5256 5257 5258 5259 5260 5261 5262 5263 5264 5265 5266 5267 5268 5269 5270 5271 5272 5273 5274 5275 5276 5277 5278 5279 5280 5281 5282 5283 5284 5285 5286 5287 5288 5289 5290 5291 5292 5293 5294 5295 5296 5297 5298 5299 5300 5301 5302 5303 5304 5305 5306 5307 5308 5309 5310 5311 5312 5313 5314 5315 5316 5317 5318 5319 5320 5321 5322 5323 5324 5325 5326 5327 5328 5329 5330 5331 5332 5333 5334 | forward poke myclass Hi } cls1 create x lappend result [catch {cls1 Hi}] [x poke] } -cleanup { parent destroy } -result {1 {this is ::cls1}} test oo-42.1 {TIP 524: definition namespace control: introspection} { info class definitionnamespace oo::object } {} test oo-42.2 {TIP 524: definition namespace control: introspection} { info class definitionnamespace oo::object -class } {} test oo-42.3 {TIP 524: definition namespace control: introspection} { info class definitionnamespace oo::object -instance } ::oo::objdefine test oo-42.4 {TIP 524: definition namespace control: introspection} -body { info class definitionnamespace oo::object -gorp } -returnCodes error -result {bad kind "-gorp": must be -class or -instance} test oo-42.5 {TIP 524: definition namespace control: introspection} -body { info class definitionnamespace oo::object -class x } -returnCodes error -result {wrong # args: should be "info class definitionnamespace className ?kind?"} test oo-42.6 {TIP 524: definition namespace control: introspection} { info class definitionnamespace oo::class } ::oo::define test oo-42.7 {TIP 524: definition namespace control: introspection} { info class definitionnamespace oo::class -class } ::oo::define test oo-42.8 {TIP 524: definition namespace control: introspection} { info class definitionnamespace oo::class -instance } {} test oo-43.1 {TIP 524: definition namespace control: semantics} -setup { oo::class create parent namespace eval foodef {} } -body { namespace eval foodef { proc sparkle {} {return ok} } oo::class create foocls { superclass oo::class parent definitionnamespace foodef } oo::class create foo { superclass parent self class foocls } oo::define foo { sparkle } } -cleanup { parent destroy namespace delete foodef } -result ok test oo-43.2 {TIP 524: definition namespace control: semantics} -setup { oo::class create parent namespace eval foodef {} unset -nocomplain ::result } -body { namespace eval foodef { namespace path ::oo::define proc sparkle {} {return ok} } oo::class create foocls { superclass oo::class parent definitionnamespace foodef } foocls create foo { superclass parent lappend ::result [sparkle] } return $result } -cleanup { parent destroy namespace delete foodef } -result ok test oo-43.3 {TIP 524: definition namespace control: semantics} -setup { oo::class create parent namespace eval foodef {} unset -nocomplain ::result } -body { namespace eval foodef { namespace path ::oo::define proc sparkle {} {return ok} } oo::class create foocls { superclass oo::class parent definitionnamespace -class foodef } foocls create foo { superclass parent lappend ::result [sparkle] } return $result } -cleanup { parent destroy namespace delete foodef } -result ok test oo-43.4 {TIP 524: definition namespace control: semantics} -setup { oo::class create parent namespace eval foodef {} } -body { namespace eval foodef { namespace path ::oo::objdefine proc sparkle {} {return ok} } oo::class create foocls { superclass oo::class parent definitionnamespace -instance foodef } foocls create foo { sparkle } } -returnCodes error -cleanup { parent destroy namespace delete foodef } -result {invalid command name "sparkle"} test oo-43.5 {TIP 524: definition namespace control: semantics} -setup { oo::class create parent namespace eval foodef {} } -body { namespace eval foodef { namespace path ::oo::objdefine proc sparkle {} {return ok} } oo::class create foocls { superclass oo::class parent definitionnamespace foodef } namespace delete foodef foocls create foo { sparkle } } -returnCodes error -cleanup { parent destroy catch {namespace delete foodef} } -result {invalid command name "sparkle"} test oo-43.6 {TIP 524: definition namespace control: semantics} -setup { oo::class create parent namespace eval foodef {} unset -nocomplain result } -body { namespace eval foodef { namespace path ::oo::objdefine proc sparkle {} {return ok} } oo::class create foocls { superclass oo::class parent definitionnamespace foodef } foocls create foo lappend result [catch {oo::define foo sparkle} msg] $msg namespace delete foodef lappend result [catch {oo::define foo sparkle} msg] $msg namespace eval foodef { namespace path ::oo::objdefine proc sparkle {} {return ok} } lappend result [catch {oo::define foo sparkle} msg] $msg } -cleanup { parent destroy catch {namespace delete foodef} } -result {0 ok 1 {invalid command name "sparkle"} 0 ok} test oo-43.7 {TIP 524: definition namespace control: semantics} -setup { oo::class create parent namespace eval foodef {} } -body { namespace eval foodef { namespace path ::oo::define proc sparkle {x} {return ok} } oo::class create foocls { superclass oo::class parent definitionnamespace foodef } foocls create foo { superclass parent } oo::define foo spar gorp } -cleanup { parent destroy namespace delete foodef } -result ok test oo-43.8 {TIP 524: definition namespace control: semantics} -setup { oo::class create parent namespace eval foodef {} } -body { namespace eval foodef { namespace path ::oo::objdefine proc sparkle {} {return ok} } oo::class create foo { superclass parent definitionnamespace -instance foodef } oo::objdefine [foo new] { method x y z sparkle } } -cleanup { parent destroy namespace delete foodef } -result ok test oo-43.9 {TIP 524: definition namespace control: syntax} -body { oo::class create foo { definitionnamespace -gorp foodef } } -returnCodes error -result {bad kind "-gorp": must be -class or -instance} test oo-43.10 {TIP 524: definition namespace control: syntax} -body { oo::class create foo { definitionnamespace -class foodef x } } -returnCodes error -result {wrong # args: should be "definitionnamespace ?kind? namespace"} test oo-43.11 {TIP 524: definition namespace control: syntax} -setup { catch {namespace delete ::no_such_ns} } -body { oo::class create foo { definitionnamespace -class ::no_such_ns } } -returnCodes error -result {namespace "::no_such_ns" not found} test oo-43.12 {TIP 524: definition namespace control: user-level introspection} -setup { oo::class create parent namespace eval foodef {} } -body { namespace eval foodef {} oo::class create foo { superclass oo::class parent } list [info class definitionnamespace foo] \ [oo::define foo definitionnamespace foodef] \ [info class definitionnamespace foo] \ [oo::define foo definitionnamespace {}] \ [info class definitionnamespace foo] } -cleanup { parent destroy namespace delete foodef } -result {{} {} ::foodef {} {}} test oo-43.13 {TIP 524: definition namespace control: user-level introspection} -setup { oo::class create parent namespace eval foodef {} } -body { namespace eval foodef {} oo::class create foo { superclass parent } list [info class definitionnamespace foo -instance] \ [oo::define foo definitionnamespace -instance foodef] \ [info class definitionnamespace foo -instance] \ [oo::define foo definitionnamespace -instance {}] \ [info class definitionnamespace foo -instance] } -cleanup { parent destroy namespace delete foodef } -result {{} {} ::foodef {} {}} cleanupTests return # Local Variables: # mode: tcl # End: |