2
* ------------------------------------------------------------------------
4
* DESCRIPTION: Object-Oriented Extensions to Tcl
6
* [incr Tcl] provides object-oriented extensions to Tcl, much as
7
* C++ provides object-oriented extensions to C. It provides a means
8
* of encapsulating related procedures together with their shared data
9
* in a local namespace that is hidden from the outside world. It
10
* promotes code re-use through inheritance. More than anything else,
11
* it encourages better organization of Tcl applications through the
12
* object-oriented paradigm, leading to code that is easier to
13
* understand and maintain.
15
* This part adds a mechanism for integrating C procedures into
16
* [incr Tcl] classes as methods and procs. Each C procedure must
17
* either be declared via Itcl_RegisterC() or dynamically loaded.
19
* ========================================================================
20
* AUTHOR: Michael J. McLennan
21
* Bell Labs Innovations for Lucent Technologies
22
* mmclennan@lucent.com
23
* http://www.tcltk.com/itcl
25
* overhauled version author: Arnulf Wiedemann
26
* ========================================================================
27
* Copyright (c) 1993-1998 Lucent Technologies, Inc.
28
* ------------------------------------------------------------------------
29
* See the file "license.terms" for information on usage and redistribution
30
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
35
* These records store the pointers for all "RegisterC" functions.
37
typedef struct ItclCfunc {
38
Tcl_CmdProc *argCmdProc; /* old-style (argc,argv) command handler */
39
Tcl_ObjCmdProc *objCmdProc; /* new (objc,objv) command handler */
40
ClientData clientData; /* client data passed into this function */
41
Tcl_CmdDeleteProc *deleteProc; /* proc called to free clientData */
44
static Tcl_HashTable* ItclGetRegisteredProcs(Tcl_Interp *interp);
45
static void ItclFreeC(ClientData clientData, Tcl_Interp *interp);
49
* ------------------------------------------------------------------------
52
* Used to associate a symbolic name with an (argc,argv) C procedure
53
* that handles a Tcl command. Procedures that are registered in this
54
* manner can be referenced in the body of an [incr Tcl] class
55
* definition to specify C procedures to acting as methods/procs.
56
* Usually invoked in an initialization routine for an extension,
57
* called out in Tcl_AppInit() at the start of an application.
59
* Each symbolic procedure can have an arbitrary client data value
60
* associated with it. This value is passed into the command
61
* handler whenever it is invoked.
63
* A symbolic procedure name can be used only once for a given style
64
* (arg/obj) handler. If the name is defined with an arg-style
65
* handler, it can be redefined with an obj-style handler; or if
66
* the name is defined with an obj-style handler, it can be redefined
67
* with an arg-style handler. In either case, any previous client
68
* data is discarded and the new client data is remembered. However,
69
* if a name is redefined to a different handler of the same style,
70
* this procedure returns an error.
72
* Returns TCL_OK on success, or TCL_ERROR (along with an error message
73
* in interp->result) if anything goes wrong.
74
* ------------------------------------------------------------------------
77
Itcl_RegisterC(interp, name, proc, clientData, deleteProc)
78
Tcl_Interp *interp; /* interpreter handling this registration */
79
const char *name; /* symbolic name for procedure */
80
Tcl_CmdProc *proc; /* procedure handling Tcl command */
81
ClientData clientData; /* client data associated with proc */
82
Tcl_CmdDeleteProc *deleteProc; /* proc called to free up client data */
86
Tcl_HashTable *procTable;
90
* Make sure that a proc was specified.
93
Tcl_AppendResult(interp, "initialization error: null pointer for ",
94
"C procedure \"", name, "\"",
100
* Add a new entry for the given procedure. If an entry with
101
* this name already exists, then make sure that it was defined
102
* with the same proc.
104
procTable = ItclGetRegisteredProcs(interp);
105
entry = Tcl_CreateHashEntry(procTable, name, &newEntry);
107
cfunc = (ItclCfunc*)Tcl_GetHashValue(entry);
108
if (cfunc->argCmdProc != NULL && cfunc->argCmdProc != proc) {
109
Tcl_AppendResult(interp, "initialization error: C procedure ",
110
"with name \"", name, "\" already defined",
115
if (cfunc->deleteProc != NULL) {
116
(*cfunc->deleteProc)(cfunc->clientData);
119
cfunc = (ItclCfunc*)ckalloc(sizeof(ItclCfunc));
120
cfunc->objCmdProc = NULL;
123
cfunc->argCmdProc = proc;
124
cfunc->clientData = clientData;
125
cfunc->deleteProc = deleteProc;
127
Tcl_SetHashValue(entry, (ClientData)cfunc);
133
* ------------------------------------------------------------------------
134
* Itcl_RegisterObjC()
136
* Used to associate a symbolic name with an (objc,objv) C procedure
137
* that handles a Tcl command. Procedures that are registered in this
138
* manner can be referenced in the body of an [incr Tcl] class
139
* definition to specify C procedures to acting as methods/procs.
140
* Usually invoked in an initialization routine for an extension,
141
* called out in Tcl_AppInit() at the start of an application.
143
* Each symbolic procedure can have an arbitrary client data value
144
* associated with it. This value is passed into the command
145
* handler whenever it is invoked.
147
* A symbolic procedure name can be used only once for a given style
148
* (arg/obj) handler. If the name is defined with an arg-style
149
* handler, it can be redefined with an obj-style handler; or if
150
* the name is defined with an obj-style handler, it can be redefined
151
* with an arg-style handler. In either case, any previous client
152
* data is discarded and the new client data is remembered. However,
153
* if a name is redefined to a different handler of the same style,
154
* this procedure returns an error.
156
* Returns TCL_OK on success, or TCL_ERROR (along with an error message
157
* in interp->result) if anything goes wrong.
158
* ------------------------------------------------------------------------
161
Itcl_RegisterObjC(interp, name, proc, clientData, deleteProc)
162
Tcl_Interp *interp; /* interpreter handling this registration */
163
const char *name; /* symbolic name for procedure */
164
Tcl_ObjCmdProc *proc; /* procedure handling Tcl command */
165
ClientData clientData; /* client data associated with proc */
166
Tcl_CmdDeleteProc *deleteProc; /* proc called to free up client data */
169
Tcl_HashEntry *entry;
170
Tcl_HashTable *procTable;
174
* Make sure that a proc was specified.
177
Tcl_AppendResult(interp, "initialization error: null pointer for ",
178
"C procedure \"", name, "\"",
184
* Add a new entry for the given procedure. If an entry with
185
* this name already exists, then make sure that it was defined
186
* with the same proc.
188
procTable = ItclGetRegisteredProcs(interp);
189
entry = Tcl_CreateHashEntry(procTable, name, &newEntry);
191
cfunc = (ItclCfunc*)Tcl_GetHashValue(entry);
192
if (cfunc->objCmdProc != NULL && cfunc->objCmdProc != proc) {
193
Tcl_AppendResult(interp, "initialization error: C procedure ",
194
"with name \"", name, "\" already defined",
199
if (cfunc->deleteProc != NULL) {
200
(*cfunc->deleteProc)(cfunc->clientData);
204
cfunc = (ItclCfunc*)ckalloc(sizeof(ItclCfunc));
205
cfunc->argCmdProc = NULL;
208
cfunc->objCmdProc = proc;
209
cfunc->clientData = clientData;
210
cfunc->deleteProc = deleteProc;
212
Tcl_SetHashValue(entry, (ClientData)cfunc);
218
* ------------------------------------------------------------------------
221
* Used to query a C procedure via its symbolic name. Looks at the
222
* list of procedures registered previously by either Itcl_RegisterC
223
* or Itcl_RegisterObjC and returns pointers to the appropriate
224
* (argc,argv) or (objc,objv) handlers. Returns non-zero if the
225
* name is recognized and pointers are returned; returns zero
227
* ------------------------------------------------------------------------
231
Tcl_Interp *interp, /* interpreter handling this registration */
232
const char *name, /* symbolic name for procedure */
233
Tcl_CmdProc **argProcPtr, /* returns (argc,argv) command handler */
234
Tcl_ObjCmdProc **objProcPtr, /* returns (objc,objv) command handler */
235
ClientData *cDataPtr) /* returns client data */
237
Tcl_HashEntry *entry;
238
Tcl_HashTable *procTable;
241
*argProcPtr = NULL; /* assume info won't be found */
246
procTable = (Tcl_HashTable*)Tcl_GetAssocData(interp,
247
"itcl_RegC", (Tcl_InterpDeleteProc**)NULL);
250
entry = Tcl_FindHashEntry(procTable, name);
252
cfunc = (ItclCfunc*)Tcl_GetHashValue(entry);
253
*argProcPtr = cfunc->argCmdProc;
254
*objProcPtr = cfunc->objCmdProc;
255
*cDataPtr = cfunc->clientData;
259
return (*argProcPtr != NULL || *objProcPtr != NULL);
264
* ------------------------------------------------------------------------
265
* ItclGetRegisteredProcs()
267
* Returns a pointer to a hash table containing the list of registered
268
* procs in the specified interpreter. If the hash table does not
269
* already exist, it is created.
270
* ------------------------------------------------------------------------
272
static Tcl_HashTable*
273
ItclGetRegisteredProcs(interp)
274
Tcl_Interp *interp; /* interpreter handling this registration */
276
Tcl_HashTable* procTable;
279
* If the registration table does not yet exist, then create it.
281
procTable = (Tcl_HashTable*)Tcl_GetAssocData(interp, "itcl_RegC",
282
(Tcl_InterpDeleteProc**)NULL);
285
procTable = (Tcl_HashTable*)ckalloc(sizeof(Tcl_HashTable));
286
Tcl_InitHashTable(procTable, TCL_STRING_KEYS);
287
Tcl_SetAssocData(interp, "itcl_RegC", ItclFreeC,
288
(ClientData)procTable);
295
* ------------------------------------------------------------------------
298
* When an interpreter is deleted, this procedure is called to
299
* free up the associated data created by Itcl_RegisterC and
301
* ------------------------------------------------------------------------
304
ItclFreeC(clientData, interp)
305
ClientData clientData; /* associated data */
306
Tcl_Interp *interp; /* intepreter being deleted */
308
Tcl_HashTable *tablePtr = (Tcl_HashTable*)clientData;
309
Tcl_HashSearch place;
310
Tcl_HashEntry *entry;
313
entry = Tcl_FirstHashEntry(tablePtr, &place);
315
cfunc = (ItclCfunc*)Tcl_GetHashValue(entry);
317
if (cfunc->deleteProc != NULL) {
318
(*cfunc->deleteProc)(cfunc->clientData);
320
ckfree ( (char*)cfunc );
321
entry = Tcl_NextHashEntry(&place);
324
Tcl_DeleteHashTable(tablePtr);
325
ckfree((char*)tablePtr);
added
removed
generic/itclLinkage.c
