TclOO Package

Check-in [3d75ad8d85]
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:Fix [Bug 3514761] and related ensemble/construction problems.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: 3d75ad8d857c4e47501329b4f8f92b837302a250
User & Date: dkf 2012-04-04 21:07:27
Context
2012-04-10
06:44
Fix [Bug 3396896] check-in: e6d86d3472 user: dkf tags: trunk
2012-04-04
21:07
Fix [Bug 3514761] and related ensemble/construction problems. check-in: 3d75ad8d85 user: dkf tags: trunk
2012-03-27
07:00
Implementation of TIP #397 check-in: e0c1f21884 user: dkf tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to ChangeLog.

1












2
3
4
5
6




7
8
9
10
11
12
13
2012-02-10  Donal K. Fellows  <[email protected]>













	* generic/tclOO.c (Tcl_CopyObjectInstance): [Bug 3474460]: Make the
	target object name optional when copying classes. [RFE 3485060]: Add
	callback method ("<cloned>") so that scripted control over copying is
	easier.





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

	IMPLEMENTATION OF TIP#380.

	* doc/define.n, doc/object.n, generic/tclOO.c, generic/tclOOBasic.c:
	* generic/tclOOCall.c, generic/tclOODefineCmds.c, generic/tclOOInt.h:
|
>
>
>
>
>
>
>
>
>
>
>
>





>
>
>
>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
2012-04-04  Donal K. Fellows  <[email protected]>

	* generic/tclOO.c (Tcl_NewObjectInstance, TclNRNewObjectInstance):
	[Bug 3514761]: Fixed bogosity with automated argument description
	handling when constructing an instance of a class that is itself a
	member of an ensemble. Thanks to Andreas Kupries for identifying that
	this was a problem case at all!
	(Tcl_CopyObjectInstance): Fix potential bleed-over of ensemble
	information into [oo::copy].

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

	IMPLEMENTATION OF TIP#397.

	* generic/tclOO.c (Tcl_CopyObjectInstance): [Bug 3474460]: Make the
	target object name optional when copying classes. [RFE 3485060]: Add
	callback method ("<cloned>") so that scripted control over copying is
	easier.
	***POTENTIAL INCOMPATIBILITY***
	If you'd previously been using the "<cloned>" method name, this now
	has a standard semantics and call interface. Only a problem if you are
	also using [oo::copy].

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

	IMPLEMENTATION OF TIP#380.

	* doc/define.n, doc/object.n, generic/tclOO.c, generic/tclOOBasic.c:
	* generic/tclOOCall.c, generic/tclOODefineCmds.c, generic/tclOOInt.h:

Changes to generic/tclOO.c.

1493
1494
1495
1496
1497
1498
1499









1500
1501
1502
1503
1504
1505
1506
....
1782
1783
1784
1785
1786
1787
1788



1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801




1802
1803
1804
1805
1806
1807
1808
	if (contextPtr != NULL) {
	    int result, flags;
	    Tcl_InterpState state;

	    state = Tcl_SaveInterpState(interp, TCL_OK);
	    contextPtr->callPtr->flags |= CONSTRUCTOR;
	    contextPtr->skip = skip;









	    result = TclOOInvokeContext(interp, contextPtr, objc, objv);
	    flags = oPtr->flags;

	    /*
	     * It's an error if the object was whacked in the constructor.
	     * Force this if it isn't already an error (don't want to lose
	     * errors by accident...)  [Bug 2903011]
................................................................................
		    Tcl_ClassSetMetadata((Tcl_Class) cls2Ptr, metadataTypePtr,
			    duplicate);
		}
	    }
	}
    }




    contextPtr = TclOOGetCallContext(o2Ptr, oPtr->fPtr->clonedName, 0);
    if (contextPtr) {
	args[0] = TclOOObjectName(interp, o2Ptr);
	args[1] = oPtr->fPtr->clonedName;
	args[2] = TclOOObjectName(interp, oPtr);
	Tcl_IncrRefCount(args[0]);
	Tcl_IncrRefCount(args[1]);
	Tcl_IncrRefCount(args[2]);
	result = TclOOInvokeContext(interp, contextPtr, 3, args);
	Tcl_DecrRefCount(args[0]);
	Tcl_DecrRefCount(args[1]);
	Tcl_DecrRefCount(args[2]);
	TclOODeleteContext(contextPtr);




	if (result != TCL_OK) {
	    Tcl_DeleteCommandFromToken(interp, o2Ptr->command);
	    return NULL;
	}
    }

    return (Tcl_Object) o2Ptr;






>
>
>
>
>
>
>
>
>







 







>
>
>













>
>
>
>







1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
....
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
	if (contextPtr != NULL) {
	    int result, flags;
	    Tcl_InterpState state;

	    state = Tcl_SaveInterpState(interp, TCL_OK);
	    contextPtr->callPtr->flags |= CONSTRUCTOR;
	    contextPtr->skip = skip;

	    /*
	     * Adjust the ensmble tracking record if necessary. [Bug 3514761]
	     */

	    if (((Interp*) interp)->ensembleRewrite.sourceObjs) {
		((Interp*) interp)->ensembleRewrite.numInsertedObjs += skip-1;
		((Interp*) interp)->ensembleRewrite.numRemovedObjs += skip-1;
	    }
	    result = TclOOInvokeContext(interp, contextPtr, objc, objv);
	    flags = oPtr->flags;

	    /*
	     * It's an error if the object was whacked in the constructor.
	     * Force this if it isn't already an error (don't want to lose
	     * errors by accident...)  [Bug 2903011]
................................................................................
		    Tcl_ClassSetMetadata((Tcl_Class) cls2Ptr, metadataTypePtr,
			    duplicate);
		}
	    }
	}
    }

    ((Interp *) interp)->ensembleRewrite.sourceObjs = NULL;
    ((Interp *) interp)->ensembleRewrite.numRemovedObjs = 0;
    ((Interp *) interp)->ensembleRewrite.numInsertedObjs = 0;
    contextPtr = TclOOGetCallContext(o2Ptr, oPtr->fPtr->clonedName, 0);
    if (contextPtr) {
	args[0] = TclOOObjectName(interp, o2Ptr);
	args[1] = oPtr->fPtr->clonedName;
	args[2] = TclOOObjectName(interp, oPtr);
	Tcl_IncrRefCount(args[0]);
	Tcl_IncrRefCount(args[1]);
	Tcl_IncrRefCount(args[2]);
	result = TclOOInvokeContext(interp, contextPtr, 3, args);
	Tcl_DecrRefCount(args[0]);
	Tcl_DecrRefCount(args[1]);
	Tcl_DecrRefCount(args[2]);
	TclOODeleteContext(contextPtr);
	if (result == TCL_ERROR) {
	    Tcl_AddErrorInfo(interp,
		    "\n    (while performing post-copy callback)");
	}
	if (result != TCL_OK) {
	    Tcl_DeleteCommandFromToken(interp, o2Ptr->command);
	    return NULL;
	}
    }

    return (Tcl_Object) o2Ptr;

Changes to tests/oo.test.

316
317
318
319
320
321
322


























































323
324
325
326
327
328
329
....
1621
1622
1623
1624
1625
1626
1627











































1628
1629
1630
1631
1632
1633
1634
    oo::define foo constructor {} {error x}
    lappend result [catch {foo new}]
    oo::define foo constructor {} {}
    lappend result [llength [info command [foo new]]]
} -cleanup {
    foo destroy
} -result {1 1}



























































test oo-3.1 {basic test of OO functionality: destructor} -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
    interp create subinterp
    initInterpreter subinterp
    subinterp eval {
................................................................................
    set result [list [a eval {foo 2}] [a eval {foo 3}]]
    oo::copy a b
    a eval {rename foo bar}
    lappend result [b eval {foo 2}] [b eval {foo 3}] [a eval {bar 4}]
} -cleanup {
    ArbitraryClass destroy
} -result {2 33 222 3333 444}












































test oo-16.1 {OO: object introspection} -body {
    info object
} -returnCodes 1 -result "wrong \# args: should be \"info object subcommand ?argument ...?\""
test oo-16.2 {OO: object introspection} -body {
    info object class NOTANOBJECT
} -returnCodes 1 -result {NOTANOBJECT does not refer to an object}






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







 







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







316
317
318
319
320
321
322
323
324
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
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
....
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
    oo::define foo constructor {} {error x}
    lappend result [catch {foo new}]
    oo::define foo constructor {} {}
    lappend result [llength [info command [foo new]]]
} -cleanup {
    foo destroy
} -result {1 1}
# Test produces wrong result here, probably due to bug-3400658 which is not
# fixable without non-trivial *linked* changes to the guts of Tcl.
test oo-2.7 {construction, method calls and ensembles - Bug 3514761} -setup {
    namespace eval k {}
} -constraints bug-3400658 -body {
    namespace eval k {
	oo::class create s {
	    constructor {j} {
		# nothing
	    }
	}
	namespace export s
	namespace ensemble create
    }
    k s create X
} -returnCodes error -cleanup {
    namespace delete k
} -result {wrong # args: should be "k s create X j"}
# Replacement for above test; verifies that things aren't too broken!
test oo-2.7a {construction, method calls and ensembles - Bug 3514761} -setup {
    namespace eval k {}
} -body {
    namespace eval k {
	oo::class create s {
	    constructor {j} {
		# nothing
	    }
	}
	namespace export s
	namespace ensemble create
    }
    k s create X
} -returnCodes error -cleanup {
    namespace delete k
} -match glob -result {wrong # args: should be "* create X j"}
test oo-2.8 {construction, method calls and ensembles - Bug 3514761} -setup {
    namespace eval k {}
} -body {
    namespace eval k {
	oo::class create s {
	    constructor {j} {
		# nothing
	    }
	}
	oo::class create t {
	    superclass s
	    constructor args {
		k next {*}$args
	    }
	}
	interp alias {} ::k::next {} ::oo::Helpers::next
	namespace export t next
	namespace ensemble create
    }
    k t create X
} -returnCodes error -cleanup {
    namespace delete k
} -result {wrong # args: should be "k next j"}

test oo-3.1 {basic test of OO functionality: destructor} -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
    interp create subinterp
    initInterpreter subinterp
    subinterp eval {
................................................................................
    set result [list [a eval {foo 2}] [a eval {foo 3}]]
    oo::copy a b
    a eval {rename foo bar}
    lappend result [b eval {foo 2}] [b eval {foo 3}] [a eval {bar 4}]
} -cleanup {
    ArbitraryClass destroy
} -result {2 33 222 3333 444}
test oo-15.7 {OO: classes can be cloned anonymously} -setup {
    oo::class create ArbitraryClassA
    oo::class create ArbitraryClassB {superclass ArbitraryClassA}
} -body {
    info object isa class [oo::copy ArbitraryClassB]
} -cleanup {
    ArbitraryClassA destroy
} -result 1
test oo-15.8 {OO: intercept object cloning} -setup {
    oo::class create Foo
    set result {}
} -body {
    oo::define Foo {
	constructor {msg} {
	    variable v $msg
	}
	method <cloned> {from} {
	    next $from
	    lappend ::result cloned $from [self]
	}
	method check {} {
	    variable v
	    lappend ::result check [self] $v
	}
    }
    Foo create foo ok
    oo::copy foo bar
    foo check
    bar check
} -cleanup {
    Foo destroy
} -result {cloned ::foo ::bar check ::foo ok check ::bar ok}
test oo-15.9 {ensemble rewriting must not bleed through oo::copy} -setup {
    oo::class create Foo
} -body {
    oo::define Foo {
	method <cloned> {a b} {}
    }
    interp alias {} Bar {} oo::copy [Foo create foo]
    Bar bar
} -returnCodes error -cleanup {
    Foo destroy
} -result {wrong # args: should be "::bar <cloned> a b"}

test oo-16.1 {OO: object introspection} -body {
    info object
} -returnCodes 1 -result "wrong \# args: should be \"info object subcommand ?argument ...?\""
test oo-16.2 {OO: object introspection} -body {
    info object class NOTANOBJECT
} -returnCodes 1 -result {NOTANOBJECT does not refer to an object}