327 lines
12 KiB
C
327 lines
12 KiB
C
/*
|
||
* ------------------------------------------------------------------------
|
||
* PACKAGE: [incr Tcl]
|
||
* DESCRIPTION: Object-Oriented Extensions to Tcl
|
||
*
|
||
* [incr Tcl] provides object-oriented extensions to Tcl, much as
|
||
* C++ provides object-oriented extensions to C. It provides a means
|
||
* of encapsulating related procedures together with their shared data
|
||
* in a local namespace that is hidden from the outside world. It
|
||
* promotes code re-use through inheritance. More than anything else,
|
||
* it encourages better organization of Tcl applications through the
|
||
* object-oriented paradigm, leading to code that is easier to
|
||
* understand and maintain.
|
||
*
|
||
* This part adds a mechanism for integrating C procedures into
|
||
* [incr Tcl] classes as methods and procs. Each C procedure must
|
||
* either be declared via Itcl_RegisterC() or dynamically loaded.
|
||
*
|
||
* ========================================================================
|
||
* AUTHOR: Michael J. McLennan
|
||
* Bell Labs Innovations for Lucent Technologies
|
||
* mmclennan@lucent.com
|
||
* http://www.tcltk.com/itcl
|
||
*
|
||
* overhauled version author: Arnulf Wiedemann
|
||
* ========================================================================
|
||
* Copyright (c) 1993-1998 Lucent Technologies, Inc.
|
||
* ------------------------------------------------------------------------
|
||
* See the file "license.terms" for information on usage and redistribution
|
||
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||
*/
|
||
#include "itclInt.h"
|
||
|
||
/*
|
||
* These records store the pointers for all "RegisterC" functions.
|
||
*/
|
||
typedef struct ItclCfunc {
|
||
Tcl_CmdProc *argCmdProc; /* old-style (argc,argv) command handler */
|
||
Tcl_ObjCmdProc *objCmdProc; /* new (objc,objv) command handler */
|
||
ClientData clientData; /* client data passed into this function */
|
||
Tcl_CmdDeleteProc *deleteProc; /* proc called to free clientData */
|
||
} ItclCfunc;
|
||
|
||
static Tcl_HashTable* ItclGetRegisteredProcs(Tcl_Interp *interp);
|
||
static void ItclFreeC(ClientData clientData, Tcl_Interp *interp);
|
||
|
||
|
||
/*
|
||
* ------------------------------------------------------------------------
|
||
* Itcl_RegisterC()
|
||
*
|
||
* Used to associate a symbolic name with an (argc,argv) C procedure
|
||
* that handles a Tcl command. Procedures that are registered in this
|
||
* manner can be referenced in the body of an [incr Tcl] class
|
||
* definition to specify C procedures to acting as methods/procs.
|
||
* Usually invoked in an initialization routine for an extension,
|
||
* called out in Tcl_AppInit() at the start of an application.
|
||
*
|
||
* Each symbolic procedure can have an arbitrary client data value
|
||
* associated with it. This value is passed into the command
|
||
* handler whenever it is invoked.
|
||
*
|
||
* A symbolic procedure name can be used only once for a given style
|
||
* (arg/obj) handler. If the name is defined with an arg-style
|
||
* handler, it can be redefined with an obj-style handler; or if
|
||
* the name is defined with an obj-style handler, it can be redefined
|
||
* with an arg-style handler. In either case, any previous client
|
||
* data is discarded and the new client data is remembered. However,
|
||
* if a name is redefined to a different handler of the same style,
|
||
* this procedure returns an error.
|
||
*
|
||
* Returns TCL_OK on success, or TCL_ERROR (along with an error message
|
||
* in interp->result) if anything goes wrong.
|
||
* ------------------------------------------------------------------------
|
||
*/
|
||
int
|
||
Itcl_RegisterC(
|
||
Tcl_Interp *interp, /* interpreter handling this registration */
|
||
const char *name, /* symbolic name for procedure */
|
||
Tcl_CmdProc *proc, /* procedure handling Tcl command */
|
||
ClientData clientData, /* client data associated with proc */
|
||
Tcl_CmdDeleteProc *deleteProc) /* proc called to free up client data */
|
||
{
|
||
int newEntry;
|
||
Tcl_HashEntry *entry;
|
||
Tcl_HashTable *procTable;
|
||
ItclCfunc *cfunc;
|
||
|
||
/*
|
||
* Make sure that a proc was specified.
|
||
*/
|
||
if (!proc) {
|
||
Tcl_AppendResult(interp, "initialization error: null pointer for ",
|
||
"C procedure \"", name, "\"",
|
||
NULL);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* Add a new entry for the given procedure. If an entry with
|
||
* this name already exists, then make sure that it was defined
|
||
* with the same proc.
|
||
*/
|
||
procTable = ItclGetRegisteredProcs(interp);
|
||
entry = Tcl_CreateHashEntry(procTable, name, &newEntry);
|
||
if (!newEntry) {
|
||
cfunc = (ItclCfunc*)Tcl_GetHashValue(entry);
|
||
if (cfunc->argCmdProc != NULL && cfunc->argCmdProc != proc) {
|
||
Tcl_AppendResult(interp, "initialization error: C procedure ",
|
||
"with name \"", name, "\" already defined",
|
||
NULL);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
if (cfunc->deleteProc != NULL) {
|
||
(*cfunc->deleteProc)(cfunc->clientData);
|
||
}
|
||
} else {
|
||
cfunc = (ItclCfunc*)ckalloc(sizeof(ItclCfunc));
|
||
cfunc->objCmdProc = NULL;
|
||
}
|
||
|
||
cfunc->argCmdProc = proc;
|
||
cfunc->clientData = clientData;
|
||
cfunc->deleteProc = deleteProc;
|
||
|
||
Tcl_SetHashValue(entry, cfunc);
|
||
return TCL_OK;
|
||
}
|
||
|
||
|
||
/*
|
||
* ------------------------------------------------------------------------
|
||
* Itcl_RegisterObjC()
|
||
*
|
||
* Used to associate a symbolic name with an (objc,objv) C procedure
|
||
* that handles a Tcl command. Procedures that are registered in this
|
||
* manner can be referenced in the body of an [incr Tcl] class
|
||
* definition to specify C procedures to acting as methods/procs.
|
||
* Usually invoked in an initialization routine for an extension,
|
||
* called out in Tcl_AppInit() at the start of an application.
|
||
*
|
||
* Each symbolic procedure can have an arbitrary client data value
|
||
* associated with it. This value is passed into the command
|
||
* handler whenever it is invoked.
|
||
*
|
||
* A symbolic procedure name can be used only once for a given style
|
||
* (arg/obj) handler. If the name is defined with an arg-style
|
||
* handler, it can be redefined with an obj-style handler; or if
|
||
* the name is defined with an obj-style handler, it can be redefined
|
||
* with an arg-style handler. In either case, any previous client
|
||
* data is discarded and the new client data is remembered. However,
|
||
* if a name is redefined to a different handler of the same style,
|
||
* this procedure returns an error.
|
||
*
|
||
* Returns TCL_OK on success, or TCL_ERROR (along with an error message
|
||
* in interp->result) if anything goes wrong.
|
||
* ------------------------------------------------------------------------
|
||
*/
|
||
int
|
||
Itcl_RegisterObjC(
|
||
Tcl_Interp *interp, /* interpreter handling this registration */
|
||
const char *name, /* symbolic name for procedure */
|
||
Tcl_ObjCmdProc *proc, /* procedure handling Tcl command */
|
||
ClientData clientData, /* client data associated with proc */
|
||
Tcl_CmdDeleteProc *deleteProc) /* proc called to free up client data */
|
||
{
|
||
int newEntry;
|
||
Tcl_HashEntry *entry;
|
||
Tcl_HashTable *procTable;
|
||
ItclCfunc *cfunc;
|
||
|
||
/*
|
||
* Make sure that a proc was specified.
|
||
*/
|
||
if (!proc) {
|
||
Tcl_AppendResult(interp, "initialization error: null pointer for ",
|
||
"C procedure \"", name, "\"",
|
||
NULL);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* Add a new entry for the given procedure. If an entry with
|
||
* this name already exists, then make sure that it was defined
|
||
* with the same proc.
|
||
*/
|
||
procTable = ItclGetRegisteredProcs(interp);
|
||
entry = Tcl_CreateHashEntry(procTable, name, &newEntry);
|
||
if (!newEntry) {
|
||
cfunc = (ItclCfunc*)Tcl_GetHashValue(entry);
|
||
if (cfunc->objCmdProc != NULL && cfunc->objCmdProc != proc) {
|
||
Tcl_AppendResult(interp, "initialization error: C procedure ",
|
||
"with name \"", name, "\" already defined",
|
||
NULL);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
if (cfunc->deleteProc != NULL) {
|
||
(*cfunc->deleteProc)(cfunc->clientData);
|
||
}
|
||
}
|
||
else {
|
||
cfunc = (ItclCfunc*)ckalloc(sizeof(ItclCfunc));
|
||
cfunc->argCmdProc = NULL;
|
||
}
|
||
|
||
cfunc->objCmdProc = proc;
|
||
cfunc->clientData = clientData;
|
||
cfunc->deleteProc = deleteProc;
|
||
|
||
Tcl_SetHashValue(entry, cfunc);
|
||
return TCL_OK;
|
||
}
|
||
|
||
|
||
/*
|
||
* ------------------------------------------------------------------------
|
||
* Itcl_FindC()
|
||
*
|
||
* Used to query a C procedure via its symbolic name. Looks at the
|
||
* list of procedures registered previously by either Itcl_RegisterC
|
||
* or Itcl_RegisterObjC and returns pointers to the appropriate
|
||
* (argc,argv) or (objc,objv) handlers. Returns non-zero if the
|
||
* name is recognized and pointers are returned; returns zero
|
||
* otherwise.
|
||
* ------------------------------------------------------------------------
|
||
*/
|
||
int
|
||
Itcl_FindC(
|
||
Tcl_Interp *interp, /* interpreter handling this registration */
|
||
const char *name, /* symbolic name for procedure */
|
||
Tcl_CmdProc **argProcPtr, /* returns (argc,argv) command handler */
|
||
Tcl_ObjCmdProc **objProcPtr, /* returns (objc,objv) command handler */
|
||
ClientData *cDataPtr) /* returns client data */
|
||
{
|
||
Tcl_HashEntry *entry;
|
||
Tcl_HashTable *procTable;
|
||
ItclCfunc *cfunc;
|
||
|
||
*argProcPtr = NULL; /* assume info won't be found */
|
||
*objProcPtr = NULL;
|
||
*cDataPtr = NULL;
|
||
|
||
if (interp) {
|
||
procTable = (Tcl_HashTable*)Tcl_GetAssocData(interp,
|
||
"itcl_RegC", NULL);
|
||
|
||
if (procTable) {
|
||
entry = Tcl_FindHashEntry(procTable, name);
|
||
if (entry) {
|
||
cfunc = (ItclCfunc*)Tcl_GetHashValue(entry);
|
||
*argProcPtr = cfunc->argCmdProc;
|
||
*objProcPtr = cfunc->objCmdProc;
|
||
*cDataPtr = cfunc->clientData;
|
||
}
|
||
}
|
||
}
|
||
return (*argProcPtr != NULL || *objProcPtr != NULL);
|
||
}
|
||
|
||
|
||
/*
|
||
* ------------------------------------------------------------------------
|
||
* ItclGetRegisteredProcs()
|
||
*
|
||
* Returns a pointer to a hash table containing the list of registered
|
||
* procs in the specified interpreter. If the hash table does not
|
||
* already exist, it is created.
|
||
* ------------------------------------------------------------------------
|
||
*/
|
||
static Tcl_HashTable*
|
||
ItclGetRegisteredProcs(
|
||
Tcl_Interp *interp) /* interpreter handling this registration */
|
||
{
|
||
Tcl_HashTable* procTable;
|
||
|
||
/*
|
||
* If the registration table does not yet exist, then create it.
|
||
*/
|
||
procTable = (Tcl_HashTable*)Tcl_GetAssocData(interp, "itcl_RegC",
|
||
NULL);
|
||
|
||
if (!procTable) {
|
||
procTable = (Tcl_HashTable*)ckalloc(sizeof(Tcl_HashTable));
|
||
Tcl_InitHashTable(procTable, TCL_STRING_KEYS);
|
||
Tcl_SetAssocData(interp, "itcl_RegC", ItclFreeC,
|
||
procTable);
|
||
}
|
||
return procTable;
|
||
}
|
||
|
||
|
||
/*
|
||
* ------------------------------------------------------------------------
|
||
* ItclFreeC()
|
||
*
|
||
* When an interpreter is deleted, this procedure is called to
|
||
* free up the associated data created by Itcl_RegisterC and
|
||
* Itcl_RegisterObjC.
|
||
* ------------------------------------------------------------------------
|
||
*/
|
||
static void
|
||
ItclFreeC(
|
||
ClientData clientData, /* associated data */
|
||
TCL_UNUSED(Tcl_Interp *)) /* interpreter being deleted */
|
||
{
|
||
Tcl_HashTable *tablePtr = (Tcl_HashTable*)clientData;
|
||
Tcl_HashSearch place;
|
||
Tcl_HashEntry *entry;
|
||
ItclCfunc *cfunc;
|
||
|
||
entry = Tcl_FirstHashEntry(tablePtr, &place);
|
||
while (entry) {
|
||
cfunc = (ItclCfunc*)Tcl_GetHashValue(entry);
|
||
|
||
if (cfunc->deleteProc != NULL) {
|
||
(*cfunc->deleteProc)(cfunc->clientData);
|
||
}
|
||
ckfree ( (char*)cfunc );
|
||
entry = Tcl_NextHashEntry(&place);
|
||
}
|
||
|
||
Tcl_DeleteHashTable(tablePtr);
|
||
ckfree((char*)tablePtr);
|
||
}
|