1/*
2 * ------------------------------------------------------------------------
3 *      PACKAGE:  [incr Tcl]
4 *  DESCRIPTION:  Object-Oriented Extensions to Tcl
5 *
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.
14 *
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.
18 *
19 * ========================================================================
20 *  AUTHOR:  Michael J. McLennan
21 *           Bell Labs Innovations for Lucent Technologies
22 *           mmclennan@lucent.com
23 *           http://www.tcltk.com/itcl
24 *
25 *     RCS:  $Id: itcl_linkage.c,v 1.2 2003/12/17 02:25:37 davygrvy Exp $
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.
31 */
32#include "itclInt.h"
33
34/*
35 *  These records store the pointers for all "RegisterC" functions.
36 */
37typedef 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 */
42} ItclCfunc;
43
44static Tcl_HashTable* ItclGetRegisteredProcs _ANSI_ARGS_((Tcl_Interp *interp));
45static void ItclFreeC _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp));
46
47
48/*
49 * ------------------------------------------------------------------------
50 *  Itcl_RegisterC()
51 *
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.
58 *
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.
62 *
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.
71 *
72 *  Returns TCL_OK on success, or TCL_ERROR (along with an error message
73 *  in interp->result) if anything goes wrong.
74 * ------------------------------------------------------------------------
75 */
76int
77Itcl_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 */
83{
84    int newEntry;
85    Tcl_HashEntry *entry;
86    Tcl_HashTable *procTable;
87    ItclCfunc *cfunc;
88
89    /*
90     *  Make sure that a proc was specified.
91     */
92    if (!proc) {
93        Tcl_AppendResult(interp, "initialization error: null pointer for ",
94            "C procedure \"", name, "\"",
95            (char*)NULL);
96        return TCL_ERROR;
97    }
98
99    /*
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.
103     */
104    procTable = ItclGetRegisteredProcs(interp);
105    entry = Tcl_CreateHashEntry(procTable, name, &newEntry);
106    if (!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",
111                (char*)NULL);
112            return TCL_ERROR;
113        }
114
115        if (cfunc->deleteProc != NULL) {
116            (*cfunc->deleteProc)(cfunc->clientData);
117        }
118    }
119    else {
120        cfunc = (ItclCfunc*)ckalloc(sizeof(ItclCfunc));
121        cfunc->objCmdProc = NULL;
122    }
123
124    cfunc->argCmdProc = proc;
125    cfunc->clientData = clientData;
126    cfunc->deleteProc = deleteProc;
127
128    Tcl_SetHashValue(entry, (ClientData)cfunc);
129    return TCL_OK;
130}
131
132
133/*
134 * ------------------------------------------------------------------------
135 *  Itcl_RegisterObjC()
136 *
137 *  Used to associate a symbolic name with an (objc,objv) C procedure
138 *  that handles a Tcl command.  Procedures that are registered in this
139 *  manner can be referenced in the body of an [incr Tcl] class
140 *  definition to specify C procedures to acting as methods/procs.
141 *  Usually invoked in an initialization routine for an extension,
142 *  called out in Tcl_AppInit() at the start of an application.
143 *
144 *  Each symbolic procedure can have an arbitrary client data value
145 *  associated with it.  This value is passed into the command
146 *  handler whenever it is invoked.
147 *
148 *  A symbolic procedure name can be used only once for a given style
149 *  (arg/obj) handler.  If the name is defined with an arg-style
150 *  handler, it can be redefined with an obj-style handler; or if
151 *  the name is defined with an obj-style handler, it can be redefined
152 *  with an arg-style handler.  In either case, any previous client
153 *  data is discarded and the new client data is remembered.  However,
154 *  if a name is redefined to a different handler of the same style,
155 *  this procedure returns an error.
156 *
157 *  Returns TCL_OK on success, or TCL_ERROR (along with an error message
158 *  in interp->result) if anything goes wrong.
159 * ------------------------------------------------------------------------
160 */
161int
162Itcl_RegisterObjC(interp, name, proc, clientData, deleteProc)
163    Tcl_Interp *interp;     /* interpreter handling this registration */
164    CONST char *name;       /* symbolic name for procedure */
165    Tcl_ObjCmdProc *proc;   /* procedure handling Tcl command */
166    ClientData clientData;          /* client data associated with proc */
167    Tcl_CmdDeleteProc *deleteProc;  /* proc called to free up client data */
168{
169    int newEntry;
170    Tcl_HashEntry *entry;
171    Tcl_HashTable *procTable;
172    ItclCfunc *cfunc;
173
174    /*
175     *  Make sure that a proc was specified.
176     */
177    if (!proc) {
178        Tcl_AppendResult(interp, "initialization error: null pointer for ",
179            "C procedure \"", name, "\"",
180            (char*)NULL);
181        return TCL_ERROR;
182    }
183
184    /*
185     *  Add a new entry for the given procedure.  If an entry with
186     *  this name already exists, then make sure that it was defined
187     *  with the same proc.
188     */
189    procTable = ItclGetRegisteredProcs(interp);
190    entry = Tcl_CreateHashEntry(procTable, name, &newEntry);
191    if (!newEntry) {
192        cfunc = (ItclCfunc*)Tcl_GetHashValue(entry);
193        if (cfunc->objCmdProc != NULL && cfunc->objCmdProc != proc) {
194            Tcl_AppendResult(interp, "initialization error: C procedure ",
195                "with name \"", name, "\" already defined",
196                (char*)NULL);
197            return TCL_ERROR;
198        }
199
200        if (cfunc->deleteProc != NULL) {
201            (*cfunc->deleteProc)(cfunc->clientData);
202        }
203    }
204    else {
205        cfunc = (ItclCfunc*)ckalloc(sizeof(ItclCfunc));
206        cfunc->argCmdProc = NULL;
207    }
208
209    cfunc->objCmdProc = proc;
210    cfunc->clientData = clientData;
211    cfunc->deleteProc = deleteProc;
212
213    Tcl_SetHashValue(entry, (ClientData)cfunc);
214    return TCL_OK;
215}
216
217
218/*
219 * ------------------------------------------------------------------------
220 *  Itcl_FindC()
221 *
222 *  Used to query a C procedure via its symbolic name.  Looks at the
223 *  list of procedures registered previously by either Itcl_RegisterC
224 *  or Itcl_RegisterObjC and returns pointers to the appropriate
225 *  (argc,argv) or (objc,objv) handlers.  Returns non-zero if the
226 *  name is recognized and pointers are returned; returns zero
227 *  otherwise.
228 * ------------------------------------------------------------------------
229 */
230int
231Itcl_FindC(interp, name, argProcPtr, objProcPtr, cDataPtr)
232    Tcl_Interp *interp;           /* interpreter handling this registration */
233    CONST char *name;             /* symbolic name for procedure */
234    Tcl_CmdProc **argProcPtr;     /* returns (argc,argv) command handler */
235    Tcl_ObjCmdProc **objProcPtr;  /* returns (objc,objv) command handler */
236    ClientData *cDataPtr;         /* returns client data */
237{
238    Tcl_HashEntry *entry;
239    Tcl_HashTable *procTable;
240    ItclCfunc *cfunc;
241
242    *argProcPtr = NULL;  /* assume info won't be found */
243    *objProcPtr = NULL;
244    *cDataPtr   = NULL;
245
246    if (interp) {
247        procTable = (Tcl_HashTable*)Tcl_GetAssocData(interp,
248            "itcl_RegC", (Tcl_InterpDeleteProc**)NULL);
249
250        if (procTable) {
251            entry = Tcl_FindHashEntry(procTable, name);
252            if (entry) {
253                cfunc = (ItclCfunc*)Tcl_GetHashValue(entry);
254                *argProcPtr = cfunc->argCmdProc;
255                *objProcPtr = cfunc->objCmdProc;
256                *cDataPtr   = cfunc->clientData;
257            }
258        }
259    }
260    return (*argProcPtr != NULL || *objProcPtr != NULL);
261}
262
263
264/*
265 * ------------------------------------------------------------------------
266 *  ItclGetRegisteredProcs()
267 *
268 *  Returns a pointer to a hash table containing the list of registered
269 *  procs in the specified interpreter.  If the hash table does not
270 *  already exist, it is created.
271 * ------------------------------------------------------------------------
272 */
273static Tcl_HashTable*
274ItclGetRegisteredProcs(interp)
275    Tcl_Interp *interp;  /* interpreter handling this registration */
276{
277    Tcl_HashTable* procTable;
278
279    /*
280     *  If the registration table does not yet exist, then create it.
281     */
282    procTable = (Tcl_HashTable*)Tcl_GetAssocData(interp, "itcl_RegC",
283        (Tcl_InterpDeleteProc**)NULL);
284
285    if (!procTable) {
286        procTable = (Tcl_HashTable*)ckalloc(sizeof(Tcl_HashTable));
287        Tcl_InitHashTable(procTable, TCL_STRING_KEYS);
288        Tcl_SetAssocData(interp, "itcl_RegC", ItclFreeC,
289            (ClientData)procTable);
290    }
291    return procTable;
292}
293
294
295/*
296 * ------------------------------------------------------------------------
297 *  ItclFreeC()
298 *
299 *  When an interpreter is deleted, this procedure is called to
300 *  free up the associated data created by Itcl_RegisterC and
301 *  Itcl_RegisterObjC.
302 * ------------------------------------------------------------------------
303 */
304static void
305ItclFreeC(clientData, interp)
306    ClientData clientData;       /* associated data */
307    Tcl_Interp *interp;          /* intepreter being deleted */
308{
309    Tcl_HashTable *tablePtr = (Tcl_HashTable*)clientData;
310    Tcl_HashSearch place;
311    Tcl_HashEntry *entry;
312    ItclCfunc *cfunc;
313
314    entry = Tcl_FirstHashEntry(tablePtr, &place);
315    while (entry) {
316        cfunc = (ItclCfunc*)Tcl_GetHashValue(entry);
317
318        if (cfunc->deleteProc != NULL) {
319            (*cfunc->deleteProc)(cfunc->clientData);
320        }
321        ckfree ( (char*)cfunc );
322        entry = Tcl_NextHashEntry(&place);
323    }
324
325    Tcl_DeleteHashTable(tablePtr);
326    ckfree((char*)tablePtr);
327}
328