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