/*
 * ------------------------------------------------------------------------
 *      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 */
    void *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(void *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 */
    void *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 */
    void *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;
}

#if TCL_MAJOR_VERSION > 8

typedef struct {
    Tcl_ObjCmdProc2 *objProc;
    void *clientData;
    Tcl_CmdDeleteProc *deleteProc;
} regInfo;

static int regCmdProc(
    void *clientData,
    Tcl_Interp *interp,
    int argc,
    Tcl_Obj *const *objv)
{
    regInfo *info = (regInfo *)clientData;
    return info->objProc(info->clientData, interp, argc, objv);
}

static void reg2DeleteProc(
    void *clientData)
{
    regInfo *info = (regInfo *)clientData;
    if (info->deleteProc != NULL) {
	info->deleteProc(info->clientData);
    }
    ckfree(info);
}


int
Itcl_RegisterObjC2(
    Tcl_Interp *interp,     /* interpreter handling this registration */
    const char *name,       /* symbolic name for procedure */
    Tcl_ObjCmdProc2 *proc,   /* procedure handling Tcl command */
    void *clientData,       /* client data associated with proc */
    Tcl_CmdDeleteProc *deleteProc)  /* proc called to free up client data */
{
    regInfo *info = (regInfo *)ckalloc(sizeof(regInfo));
    info->objProc = proc;
    info->clientData = clientData;
    info->deleteProc = deleteProc;
    return Itcl_RegisterObjC(interp, name, regCmdProc, info, reg2DeleteProc);
}
#endif /* TCL_MAJOR_VERSION */

/*
 * ------------------------------------------------------------------------
 *  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, can be NULL */
    Tcl_ObjCmdProc **objProcPtr,  /* returns (objc,objv) command handler */
    void **cDataPtr)              /* returns client data */
{
    Tcl_HashEntry *entry;
    Tcl_HashTable *procTable;
    ItclCfunc *cfunc;
    Tcl_CmdProc *argProc = 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);
		argProc = cfunc->argCmdProc;
		*objProcPtr = cfunc->objCmdProc;
		*cDataPtr   = cfunc->clientData;
	    }
	}
    }
    if (argProcPtr) {
	*argProcPtr = argProc;
    }
    return (((argProcPtr != NULL) && (argProc != NULL)) || (*objProcPtr != NULL));
}

#if TCL_MAJOR_VERSION > 8
int
Itcl_FindC2(
    Tcl_Interp *interp,           /* interpreter handling this registration */
    const char *name,             /* symbolic name for procedure */
    Tcl_ObjCmdProc2 **objProcPtr, /* returns (objc,objv) command handler */
    void **cDataPtr)              /* returns client data */
{
    Tcl_ObjCmdProc *regProcPtr;
    void *dataPtr;

    *objProcPtr = NULL;  /* assume info won't be found */
    *cDataPtr = NULL;

    if (Itcl_FindC(interp, name, NULL, &regProcPtr, &dataPtr)) {
	if (regProcPtr == regCmdProc) {
	    regInfo *info = (regInfo *)dataPtr;
	    *objProcPtr = info->objProc;
	    *cDataPtr = info->clientData;
	}
    }
    return (*objProcPtr != NULL);
}
#endif /* TCL_MAJOR_VERSION */


/*
 * ------------------------------------------------------------------------
 *  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(
    void *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);
}