Tcl Source Code

Check-in [1bfaa1ff89]
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:Create a special command, [ :my:class], (in each instance namespace) that allows objects to delegate methods to their class.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | tip-478
Files: files | file ages | folders
SHA3-256: 1bfaa1ff8963b27f30dbe442826753d8f24f2a9415c2fdc9e0b698fcbe8536f4
User & Date: dkf 2018-07-01 16:39:11
Context
2018-07-02
07:44
Documentation for [classmethod] check-in: b90d390915 user: dkf tags: tip-478
2018-07-01
16:39
Create a special command, [ :my:class], (in each instance namespace) that allows objects to delegate... check-in: 1bfaa1ff89 user: dkf tags: tip-478
2018-06-30
21:36
More docs check-in: eb46b97a2c user: dkf tags: tip-478
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to generic/tclOO.c.

98
99
100
101
102
103
104







105
106
107
108
109
110
111
...
743
744
745
746
747
748
749



750
751
752
753
754
755
756
....
1161
1162
1163
1164
1165
1166
1167



1168
1169
1170
1171
1172
1173
1174
....
2480
2481
2482
2483
2484
2485
2486













































2487
2488
2489
2490
2491
2492
2493
			    Tcl_Obj *const *objv);
static int		PrivateObjectCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const *objv);
static int		PrivateNRObjectCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const *objv);








/*
 * Methods in the oo::object and oo::class classes. First, we define a helper
 * macro that makes building the method type declaration structure a lot
 * easier. No point in making life harder than it has to be!
 *
 * Note that the core methods don't need clone or free proc callbacks.
................................................................................
    tracePtr->clientData = oPtr;
    tracePtr->flags = TCL_TRACE_RENAME|TCL_TRACE_DELETE;
    tracePtr->nextPtr = NULL;
    tracePtr->refCount = 1;

    oPtr->myCommand = TclNRCreateCommandInNs(interp, "my", oPtr->namespacePtr,
	    PrivateObjectCmd, PrivateNRObjectCmd, oPtr, MyDeleted);



    return oPtr;
}
 
/*
 * ----------------------------------------------------------------------
 *
 * SquelchCachedName --
................................................................................
	 * The namespace must have been deleted directly.  Delete the command
	 * as well.
	 */

	Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->command);
    }




    if (oPtr->myCommand) {
	Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->myCommand);
    }

    /*
     * Splice the object out of its context. After this, we must *not* call
     * methods on the object.
................................................................................
	return TclOOObjectCmdCore((Object *) object, interp, objc, objv,
		PRIVATE_METHOD, (Class *) startCls);
    default:
	return TclOOObjectCmdCore((Object *) object, interp, objc, objv, 0,
		(Class *) startCls);
    }
}













































 
/*
 * ----------------------------------------------------------------------
 *
 * TclOOObjectCmdCore, FinalizeObjectCall --
 *
 *	Main function for object invocations. Does call chain creation,






>
>
>
>
>
>
>







 







>
>
>







 







>
>
>







 







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







98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
...
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
....
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
....
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
			    Tcl_Obj *const *objv);
static int		PrivateObjectCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const *objv);
static int		PrivateNRObjectCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const *objv);
static int		MyClassObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const *objv);
static int		MyClassNRObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const *objv);
static void		MyClassDeletedCmd(ClientData clientData);

/*
 * Methods in the oo::object and oo::class classes. First, we define a helper
 * macro that makes building the method type declaration structure a lot
 * easier. No point in making life harder than it has to be!
 *
 * Note that the core methods don't need clone or free proc callbacks.
................................................................................
    tracePtr->clientData = oPtr;
    tracePtr->flags = TCL_TRACE_RENAME|TCL_TRACE_DELETE;
    tracePtr->nextPtr = NULL;
    tracePtr->refCount = 1;

    oPtr->myCommand = TclNRCreateCommandInNs(interp, "my", oPtr->namespacePtr,
	    PrivateObjectCmd, PrivateNRObjectCmd, oPtr, MyDeleted);
    oPtr->myclassCommand = TclNRCreateCommandInNs(interp, " :my:class",
	    oPtr->namespacePtr, MyClassObjCmd, MyClassNRObjCmd, oPtr,
            MyClassDeletedCmd);
    return oPtr;
}
 
/*
 * ----------------------------------------------------------------------
 *
 * SquelchCachedName --
................................................................................
	 * The namespace must have been deleted directly.  Delete the command
	 * as well.
	 */

	Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->command);
    }

    if (oPtr->myclassCommand) {
	Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->myclassCommand);
    }
    if (oPtr->myCommand) {
	Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->myCommand);
    }

    /*
     * Splice the object out of its context. After this, we must *not* call
     * methods on the object.
................................................................................
	return TclOOObjectCmdCore((Object *) object, interp, objc, objv,
		PRIVATE_METHOD, (Class *) startCls);
    default:
	return TclOOObjectCmdCore((Object *) object, interp, objc, objv, 0,
		(Class *) startCls);
    }
}
 
/*
 * ----------------------------------------------------------------------
 *
 * MyClassObjCmd, MyClassNRObjCmd, MyClassDeletedCmd --
 *
 *	Special trap door to allow an object to delegate simply to its class.
 *
 * ----------------------------------------------------------------------
 */

static int
MyClassObjCmd(
    ClientData clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const *objv)
{
    return Tcl_NRCallObjProc(interp, MyClassNRObjCmd, clientData, objc, objv);
}

static int
MyClassNRObjCmd(
    ClientData clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = clientData;

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "methodName ?arg ...?");
	return TCL_ERROR;
    }
    return TclOOObjectCmdCore(oPtr->selfCls->thisPtr, interp, objc, objv, 0,
	    NULL);
}

static void
MyClassDeletedCmd(
    ClientData clientData)
{
    Object *oPtr = clientData;
    oPtr->myclassCommand = NULL;
}
 
/*
 * ----------------------------------------------------------------------
 *
 * TclOOObjectCmdCore, FinalizeObjectCall --
 *
 *	Main function for object invocations. Does call chain creation,

Changes to generic/tclOOInt.h.

205
206
207
208
209
210
211


212
213
214
215
216
217
218
    Tcl_ObjectMapMethodNameProc *mapMethodNameProc;
				/* Function to allow remapping of method
				 * names. For itcl-ng. */
    VariableNameList variables;
    PrivateVariableList privateVariables;
				/* Configurations for the variable resolver
				 * used inside methods. */


} Object;

#define OBJECT_DELETED	1	/* Flag to say that an object has been
				 * destroyed. */
#define DESTRUCTOR_CALLED 2	/* Flag to say that the destructor has been
				 * called. */
#define CLASS_GONE	4	/* Obsolete. Indicates that the class of this






>
>







205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
    Tcl_ObjectMapMethodNameProc *mapMethodNameProc;
				/* Function to allow remapping of method
				 * names. For itcl-ng. */
    VariableNameList variables;
    PrivateVariableList privateVariables;
				/* Configurations for the variable resolver
				 * used inside methods. */
    Tcl_Command myclassCommand;	/* Reference to this object's class dispatcher
				 * command. */
} Object;

#define OBJECT_DELETED	1	/* Flag to say that an object has been
				 * destroyed. */
#define DESTRUCTOR_CALLED 2	/* Flag to say that the destructor has been
				 * called. */
#define CLASS_GONE	4	/* Obsolete. Indicates that the class of this

Changes to generic/tclOOScript.h.

81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
"                [lindex [info level 0] 0] { name ?args body?\"}]\n"
"    }\n"
"    set cls [uplevel 1 self]\n"
"    if {$argc == 4} {\n"
"        ::oo::define [::oo::DelegateName $cls] method $name $args $body\n"
"    }\n"
"    # Make the connection by forwarding\n"
"    tailcall forward $name [info object namespace $cls]::my $name\n"
"}\n"

"proc ::oo::MixinClassDelegates {class} {\n"
"    if {![info object isa class $class]} {\n"
"        return\n"
"    }\n"
"    set delegate [::oo::DelegateName $class]\n"






|







81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
"                [lindex [info level 0] 0] { name ?args body?\"}]\n"
"    }\n"
"    set cls [uplevel 1 self]\n"
"    if {$argc == 4} {\n"
"        ::oo::define [::oo::DelegateName $cls] method $name $args $body\n"
"    }\n"
"    # Make the connection by forwarding\n"
"    tailcall forward $name { :my:class} $name\n"
"}\n"

"proc ::oo::MixinClassDelegates {class} {\n"
"    if {![info object isa class $class]} {\n"
"        return\n"
"    }\n"
"    set delegate [::oo::DelegateName $class]\n"

Changes to tests/ooUtil.test.

92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
...
111
112
113
114
115
116
117























118
119
120
121
122
123
124
    oo::class create Table {
	superclass ActiveRecord
    }
    set t [Table new]
    $t find 1 2 3
} -cleanup {
    parent destroy
} -result {::ActiveRecord called with arguments: 1 2 3}
test ooUtil-1.6 {TIP 478: classmethod and instances} -setup {
    oo::class create parent
} -body {
    oo::class create ActiveRecord {
	superclass parent
        classmethod find args {
	    return "[self] called with arguments: $args"
................................................................................
	unexport find
    }
    set t [Table new]
    $t find 1 2 3
} -returnCodes error -cleanup {
    parent destroy
} -match glob -result {unknown method "find": must be *}
























test ooUtil-2.1 {TIP 478: callback generation} -setup {
    oo::class create parent
} -body {
    oo::class create c {
	superclass parent
	method CallMe {} { return ok,[self] }






|







 







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







92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
...
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
    oo::class create Table {
	superclass ActiveRecord
    }
    set t [Table new]
    $t find 1 2 3
} -cleanup {
    parent destroy
} -result {::Table called with arguments: 1 2 3}
test ooUtil-1.6 {TIP 478: classmethod and instances} -setup {
    oo::class create parent
} -body {
    oo::class create ActiveRecord {
	superclass parent
        classmethod find args {
	    return "[self] called with arguments: $args"
................................................................................
	unexport find
    }
    set t [Table new]
    $t find 1 2 3
} -returnCodes error -cleanup {
    parent destroy
} -match glob -result {unknown method "find": must be *}
test ooUtil-1.7 {} -setup {
    oo::class create parent
} -body {
    oo::class create Foo {
	superclass parent
        classmethod bar {} {
            puts "This is in the class; self is [self]"
            my meee
        }
        classmethod meee {} {
            puts "This is meee"
        }
    }
    oo::class create Grill {
        superclass Foo
        classmethod meee {} {
            puts "This is meee 2"
        }
    }
    list [Foo bar] [Grill bar] [[Foo new] bar] [[Grill new] bar]
} -cleanup {
    parent destroy
} -result {{} {} {} {}} -output "This is in the class; self is ::Foo\nThis is meee\nThis is in the class; self is ::Grill\nThis is meee 2\nThis is in the class; self is ::Foo\nThis is meee\nThis is in the class; self is ::Grill\nThis is meee 2\n"

test ooUtil-2.1 {TIP 478: callback generation} -setup {
    oo::class create parent
} -body {
    oo::class create c {
	superclass parent
	method CallMe {} { return ok,[self] }

Changes to unix/Makefile.in.

255
256
257
258
259
260
261

262
263
264
265
266
267
268
...
725
726
727
728
729
730
731






732
733
734
735
736
737
738
#--------------------------------------------------------------------------
# The information below is usually usable as is. The configure script won't
# modify it and it only exists to make working around selected rare system
# configurations easier.
#--------------------------------------------------------------------------

GDB			= gdb

TRACE			= strace
TRACE_OPTS		=
VALGRIND		= valgrind
VALGRINDARGS		= --tool=memcheck --num-callers=8 --leak-resolution=high --leak-check=yes --show-reachable=yes -v

#--------------------------------------------------------------------------
# The information below should be usable as is. The configure script won't
................................................................................

gdb-test: ${TCLTEST_EXE}
	@echo "set env @[email protected]=`pwd`:$${@[email protected]}" > gdb.run
	@echo "set env TCL_LIBRARY=${TCL_BUILDTIME_LIBRARY}" >> gdb.run
	@echo "set args $(TOP_DIR)/tests/all.tcl $(TESTFLAGS) -singleproc 1" >> gdb.run
	$(GDB) ./${TCLTEST_EXE} --command=gdb.run
	rm gdb.run







# Useful target to launch a built tcltest with the proper path,...
runtest: ${TCLTEST_EXE}
	$(SHELL_ENV) ./${TCLTEST_EXE}

# Useful target for running the test suite with an unwritable current
# directory...






>







 







>
>
>
>
>
>







255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
...
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
#--------------------------------------------------------------------------
# The information below is usually usable as is. The configure script won't
# modify it and it only exists to make working around selected rare system
# configurations easier.
#--------------------------------------------------------------------------

GDB			= gdb
LLDB			= lldb
TRACE			= strace
TRACE_OPTS		=
VALGRIND		= valgrind
VALGRINDARGS		= --tool=memcheck --num-callers=8 --leak-resolution=high --leak-check=yes --show-reachable=yes -v

#--------------------------------------------------------------------------
# The information below should be usable as is. The configure script won't
................................................................................

gdb-test: ${TCLTEST_EXE}
	@echo "set env @[email protected]=`pwd`:$${@[email protected]}" > gdb.run
	@echo "set env TCL_LIBRARY=${TCL_BUILDTIME_LIBRARY}" >> gdb.run
	@echo "set args $(TOP_DIR)/tests/all.tcl $(TESTFLAGS) -singleproc 1" >> gdb.run
	$(GDB) ./${TCLTEST_EXE} --command=gdb.run
	rm gdb.run

lldb-test: ${TCLTEST_EXE}
	@echo "settings set target.env-vars @[email protected]=`pwd`:$${@[email protected]}" > lldb.run
	@echo "settings set target.env-vars TCL_LIBRARY=${TCL_BUILDTIME_LIBRARY}" >> lldb.run
	$(LLDB) --source lldb.run ./${TCLTEST_EXE} -- $(TOP_DIR)/tests/all.tcl $(TESTFLAGS) -singleproc 1
	rm lldb.run

# Useful target to launch a built tcltest with the proper path,...
runtest: ${TCLTEST_EXE}
	$(SHELL_ENV) ./${TCLTEST_EXE}

# Useful target for running the test suite with an unwritable current
# directory...