/*
 * genintrep.c --
 *
 *	Procedures to manipulate the internal representation of
 *	GenObject Tcl objects.
 *
 * Copyright (c) 2000-2003 JYL Software, Inc.
 *
 * Permission is hereby granted, free of charge, to any person obtaining
 * a copy of this software and associated documentation files (the
 * "Software"), to deal in the Software without restriction, including
 * without limitation the rights to use, copy, modify, merge, publish,
 * distribute, sublicense, and/or sell copies of the Software, and to
 * permit persons to whom the Software is furnished to do so, subject to
 * the following conditions:
 * 
 * The above copyright notice and this permission notice shall be
 * included in all copies or substantial portions of the Software.
 * 
 * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
 * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
 * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
 * NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
 * LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
 * OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
 * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE, EVEN IF
 * JYL SOFTWARE INC. IS MADE AWARE OF THE POSSIBILITY OF SUCH DAMAGE.
 */

#include "genobject.h"
#include "genintrep.h"

/*
 * Static routines in this file:
 */

static int		GenObjectCmdProc(ClientData clientData,
					 Tcl_Interp *interp,
					 int objc, Tcl_Obj *CONST objv[]);

/*
 * Increment, decrement refcount.
 */

void
GenObjectIncrRefcount(GO_InternalRep *ptr2)
{
#ifdef	DEBUG
    if (ptr2->destroyed == 1) {
	Tcl_Panic("ptr2 0x%x destroyed %d refcount %d\n",
		  ptr2, ptr2->destroyed, ptr2->refcount);
    }
#endif
    ptr2->refcount++;
#ifdef	DEBUG    
    if (ptr2->refcount < 0) {
	Tcl_Panic("ptr2 0x%x refcount wrapped around. ABORT\n", ptr2);
    }
#endif
}

void
GenObjectDecrRefcount(GO_InternalRep *ptr2)
{
#ifdef	DEBUG
    if (ptr2->destroyed == 1) {
	Tcl_Panic("ptr2 0x%x destroyed %d refcount %d\n",
		  ptr2, ptr2->destroyed, ptr2->refcount);
    }
#endif
    ptr2->refcount--;
#ifdef	DEBUG
    if (ptr2->refcount < 0) {
	Tcl_Panic("ptr2 0x%x refcount %d after decr. ABORT\n",
		  ptr2, ptr2->refcount);
    }
#endif
    if (ptr2->refcount <= 0) {
	if ((ptr2->extension->cleanup != NULL) && (ptr2->interp != NULL)) {
	    (*ptr2->extension->cleanup)(ptr2->interp,
					ptr2->data,
					ptr2->extension);
	}

	/*
	 * DAS found that invoking "llength $myob" on a GenObject would
	 * cause a corrupt state. The Tcl_DeleteCommandFromToken below
	 * was added to ensure that the command goes away with the internal
	 * rep when the internal rep refcount reaches zero.
	 */

	Tcl_DeleteCommandFromToken(ptr2->interp, ptr2->cmdToken);

	/*
	 * Sanity insurance: smash all the value fields in the GenObject
	 * so that if, by some chance, someone still has a reference and
	 * the memory hasn't been reused (G*d protect them if it has been)
	 * then they'll see a sane state.
	 */

	ptr2->destroyed = 1;
	ptr2->interp = NULL;
	ptr2->extension = NULL;
	ptr2->cmdToken = NULL;

	/*
	 * Free the internal representation. No need to free ptr2->name
	 * because Tcl already freed the string representation of the
	 * Tcl_Obj that referred to this GenObject extension object.
	 */

	Tcl_Free((char *) ptr2);
    }
}

/*
 * Make a new GenObject internal representation.
 */

GO_InternalRep *
NewGenObjectInternalRep(GO_Extension *extPtr, Tcl_Interp *interp, void *data)
{
    GO_InternalRep *ptr2;

#ifdef	DEBUG
    if (interp == NULL) {
	Tcl_Panic("NewGenObjectInternalRep 0x%x %s called with NULL interp\n",
		  data, extPtr->name);
    }
#endif
    ptr2 = (GO_InternalRep *) Tcl_Alloc((unsigned) sizeof(GO_InternalRep));

    ptr2->interp = interp;
    ptr2->name = NULL;
    ptr2->cmdToken = (Tcl_Command) NULL;
    ptr2->extension = extPtr;
    ptr2->data = data;
    ptr2->refcount = 0;
    ptr2->destroyed = 0;

    return ptr2;
}

/*
 * Make a Tcl command corresponding to a new GenObject instance.
 */

void
GenObjectMakeTclCommand(GO_InternalRep *ptr2)
{
    if (ptr2->cmdToken == (Tcl_Command) NULL) {
	ptr2->cmdToken = Tcl_CreateObjCommand(ptr2->interp,
					      ptr2->name,
					      GenObjectCmdProc,
					      (ClientData) ptr2,
					      NULL);
    }
}

/*
 *----------------------------------------------------------------------
 * GenObjectCmdProc --
 *
 *	The command procedure invoked when a GenObject instance is used as
 *	a command.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	Whatever the "invoke" routine of the instance's extension type does.
 */

static int
GenObjectCmdProc(ClientData clientData, Tcl_Interp *interp,
		 int objc, Tcl_Obj *CONST objv[])
{
    GO_InternalRep *ptr2 = (GO_InternalRep *) clientData;

#ifdef	DEBUG
    if (interp == NULL) {
	Tcl_Panic("GenObjectCmdProc ptr2 0x%x invoked with NULL interp\n",
		  ptr2);
    }
#endif

    /*
     * Ensure that the object can be invoked.
     */

    if ((ptr2 == NULL) ||
	(ptr2->interp == NULL) ||
	(ptr2->extension == NULL) ||
	(ptr2->extension->invoke == NULL)) {
	Tcl_SetStringObj(Tcl_GetObjResult(interp),
			 "GenObject instance does not have invoke procedure",
			 -1);
	return TCL_ERROR;
    }

    /*
     * Ensure this object is from the current interpreter.
     */

    if (ptr2->interp != interp) {
	Tcl_AppendResult(interp, ptr2->name, " cannot be invoked", NULL);
	return TCL_ERROR;
    }

    /*
     * Finally invoke the extension's "invoke" procedure.
     */

    return (*ptr2->extension->invoke)(ptr2->interp,
				      ptr2->name,
				      ptr2->data,
				      objc,
				      objv,
				      ptr2->extension);
}