/* 

 * tclObj.c --

 *

 *	This file contains Tcl object-related procedures that are used by

 * 	many Tcl commands.

 *

 * Copyright (c) 1995-1997 Sun Microsystems, Inc.

 * Copyright (c) 1999 by Scriptics Corporation.

 * Copyright (c) 2001 by ActiveState Corporation.

 * Portions Copyright (c) 2007-2008 Nokia Corporation and/or its subsidiaries. All rights reserved.  

 *

 * See the file "license.terms" for information on usage and redistribution

 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.

 *

 * RCS: @(#) $Id: tclObj.c,v 1.42.2.14 2005/11/29 14:02:04 dkf Exp $

 */

#include "tclInt.h"

#include "tclCompile.h"

#include "tclPort.h"

#if defined(__SYMBIAN32__) 

#include "tclSymbianGlobals.h"

#endif 

/*

 * Table of all object types.

 */

#if !defined(__SYMBIAN32__) || !defined(__WINSCW__)

static Tcl_HashTable typeTable;

static int typeTableInitialized = 0;    /* 0 means not yet initialized. */

#endif

TCL_DECLARE_MUTEX(tableMutex)

/*

 * Head of the list of free Tcl_Obj structs we maintain.

 */

Tcl_Obj *tclFreeObjList = NULL;

/*

 * The object allocator is single threaded.  This mutex is referenced

 * by the TclNewObj macro, however, so must be visible.

 */

#ifdef TCL_THREADS

Tcl_Mutex tclObjMutex;

#endif

/*

 * Pointer to a heap-allocated string of length zero that the Tcl core uses

 * as the value of an empty string representation for an object. This value

 * is shared by all new objects allocated by Tcl_NewObj.

 */

char tclEmptyString = '\0';

char *tclEmptyStringRep = &tclEmptyString;

/*

 * Prototypes for procedures defined later in this file:

 */

static int		SetBooleanFromAny _ANSI_ARGS_((Tcl_Interp *interp,

			    Tcl_Obj *objPtr));

static int		SetDoubleFromAny _ANSI_ARGS_((Tcl_Interp *interp,

			    Tcl_Obj *objPtr));

static int		SetIntFromAny _ANSI_ARGS_((Tcl_Interp *interp,

			    Tcl_Obj *objPtr));

static int		SetIntOrWideFromAny _ANSI_ARGS_((Tcl_Interp* interp,

							 Tcl_Obj *objPtr));

static void		UpdateStringOfBoolean _ANSI_ARGS_((Tcl_Obj *objPtr));

static void		UpdateStringOfDouble _ANSI_ARGS_((Tcl_Obj *objPtr));

static void		UpdateStringOfInt _ANSI_ARGS_((Tcl_Obj *objPtr));

static int		SetWideIntFromAny _ANSI_ARGS_((Tcl_Interp *interp,

			    Tcl_Obj *objPtr));

#ifndef TCL_WIDE_INT_IS_LONG

static void		UpdateStringOfWideInt _ANSI_ARGS_((Tcl_Obj *objPtr));

#endif

/*

 * Prototypes for the array hash key methods.

 */

static Tcl_HashEntry *	AllocObjEntry _ANSI_ARGS_((

			    Tcl_HashTable *tablePtr, VOID *keyPtr));

static int		CompareObjKeys _ANSI_ARGS_((

			    VOID *keyPtr, Tcl_HashEntry *hPtr));

static void		FreeObjEntry _ANSI_ARGS_((

			    Tcl_HashEntry *hPtr));

static unsigned int	HashObjKey _ANSI_ARGS_((

			    Tcl_HashTable *tablePtr,

			    VOID *keyPtr));

/*

 * Prototypes for the CommandName object type.

 */

static void		DupCmdNameInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr,

			    Tcl_Obj *copyPtr));

static void		FreeCmdNameInternalRep _ANSI_ARGS_((

    			    Tcl_Obj *objPtr));

static int		SetCmdNameFromAny _ANSI_ARGS_((Tcl_Interp *interp,

			    Tcl_Obj *objPtr));

/*

 * The structures below defines the Tcl object types defined in this file by

 * means of procedures that can be invoked by generic object code. See also

 * tclStringObj.c, tclListObj.c, tclByteCode.c for other type manager

 * implementations.

 */

Tcl_ObjType tclBooleanType = {

    "boolean",				/* name */

    (Tcl_FreeInternalRepProc *) NULL,   /* freeIntRepProc */

    (Tcl_DupInternalRepProc *) NULL,	/* dupIntRepProc */

    UpdateStringOfBoolean,		/* updateStringProc */

    SetBooleanFromAny			/* setFromAnyProc */

};

Tcl_ObjType tclDoubleType = {

    "double",				/* name */

    (Tcl_FreeInternalRepProc *) NULL,   /* freeIntRepProc */

    (Tcl_DupInternalRepProc *) NULL,	/* dupIntRepProc */

    UpdateStringOfDouble,		/* updateStringProc */

    SetDoubleFromAny			/* setFromAnyProc */

};

Tcl_ObjType tclIntType = {

    "int",				/* name */

    (Tcl_FreeInternalRepProc *) NULL,   /* freeIntRepProc */

    (Tcl_DupInternalRepProc *) NULL,	/* dupIntRepProc */

    UpdateStringOfInt,			/* updateStringProc */

    SetIntFromAny			/* setFromAnyProc */

};

Tcl_ObjType tclWideIntType = {

    "wideInt",				/* name */

    (Tcl_FreeInternalRepProc *) NULL,   /* freeIntRepProc */

    (Tcl_DupInternalRepProc *) NULL,	/* dupIntRepProc */

#ifdef TCL_WIDE_INT_IS_LONG

    UpdateStringOfInt,			/* updateStringProc */

#else /* !TCL_WIDE_INT_IS_LONG */

    UpdateStringOfWideInt,		/* updateStringProc */

#endif

    SetWideIntFromAny			/* setFromAnyProc */

};

/*

 * The structure below defines the Tcl obj hash key type.

 */

Tcl_HashKeyType tclObjHashKeyType = {

    TCL_HASH_KEY_TYPE_VERSION,		/* version */

    0,					/* flags */

    HashObjKey,				/* hashKeyProc */

    CompareObjKeys,			/* compareKeysProc */

    AllocObjEntry,			/* allocEntryProc */

    FreeObjEntry			/* freeEntryProc */

};

/*

 * The structure below defines the command name Tcl object type by means of

 * procedures that can be invoked by generic object code. Objects of this

 * type cache the Command pointer that results from looking up command names

 * in the command hashtable. Such objects appear as the zeroth ("command

 * name") argument in a Tcl command.

 *

 * NOTE: the ResolvedCmdName that gets cached is stored in the

 * twoPtrValue.ptr1 field, and the twoPtrValue.ptr2 field is unused.

 * You might think you could use the simpler otherValuePtr field to

 * store the single ResolvedCmdName pointer, but DO NOT DO THIS.  It

 * seems that some extensions use the second internal pointer field

 * of the twoPtrValue field for their own purposes.

 */

static Tcl_ObjType tclCmdNameType = {

    "cmdName",				/* name */

    FreeCmdNameInternalRep,		/* freeIntRepProc */

    DupCmdNameInternalRep,		/* dupIntRepProc */

    (Tcl_UpdateStringProc *) NULL,	/* updateStringProc */

    SetCmdNameFromAny			/* setFromAnyProc */

};

/*

 * Structure containing a cached pointer to a command that is the result

 * of resolving the command's name in some namespace. It is the internal

 * representation for a cmdName object. It contains the pointer along

 * with some information that is used to check the pointer's validity.

 */

typedef struct ResolvedCmdName {

    Command *cmdPtr;		/* A cached Command pointer. */

    Namespace *refNsPtr;	/* Points to the namespace containing the

				 * reference (not the namespace that

				 * contains the referenced command). */

    long refNsId;		/* refNsPtr's unique namespace id. Used to

				 * verify that refNsPtr is still valid

				 * (e.g., it's possible that the cmd's

				 * containing namespace was deleted and a

				 * new one created at the same address). */

    int refNsCmdEpoch;		/* Value of the referencing namespace's

				 * cmdRefEpoch when the pointer was cached.

				 * Before using the cached pointer, we check

				 * if the namespace's epoch was incremented;

				 * if so, this cached pointer is invalid. */

    int cmdEpoch;		/* Value of the command's cmdEpoch when this

				 * pointer was cached. Before using the

				 * cached pointer, we check if the cmd's

				 * epoch was incremented; if so, the cmd was

				 * renamed, deleted, hidden, or exposed, and

				 * so the pointer is invalid. */

    int refCount;		/* Reference count: 1 for each cmdName

				 * object that has a pointer to this

				 * ResolvedCmdName structure as its internal

				 * rep. This structure can be freed when

				 * refCount becomes zero. */

} ResolvedCmdName;

/*

 *-------------------------------------------------------------------------

 *

 * TclInitObjectSubsystem --

 *

 *	This procedure is invoked to perform once-only initialization of

 *	the type table. It also registers the object types defined in 

 *	this file.

 *

 * Results:

 *	None.

 *

 * Side effects:

 *	Initializes the table of defined object types "typeTable" with

 *	builtin object types defined in this file.  

 *

 *-------------------------------------------------------------------------

 */

void

TclInitObjSubsystem()

{

    Tcl_MutexLock(&tableMutex);

    typeTableInitialized = 1;

    Tcl_InitHashTable(&typeTable, TCL_STRING_KEYS);

    Tcl_MutexUnlock(&tableMutex);

    Tcl_RegisterObjType(&tclBooleanType);

    Tcl_RegisterObjType(&tclByteArrayType);

    Tcl_RegisterObjType(&tclDoubleType);

    Tcl_RegisterObjType(&tclEndOffsetType);

    Tcl_RegisterObjType(&tclIntType);

    Tcl_RegisterObjType(&tclWideIntType);

    Tcl_RegisterObjType(&tclStringType);

    Tcl_RegisterObjType(&tclListType);

    Tcl_RegisterObjType(&tclByteCodeType);

    Tcl_RegisterObjType(&tclProcBodyType);

    Tcl_RegisterObjType(&tclArraySearchType);

    Tcl_RegisterObjType(&tclIndexType);

    Tcl_RegisterObjType(&tclNsNameType);

    Tcl_RegisterObjType(&tclCmdNameType);

#ifdef TCL_COMPILE_STATS

    Tcl_MutexLock(&tclObjMutex);

    tclObjsAlloced = 0;

    tclObjsFreed = 0;

    {

	int i;

	for (i = 0;  i < TCL_MAX_SHARED_OBJ_STATS;  i++) {

	    tclObjsShared[i] = 0;

	}

    }

    Tcl_MutexUnlock(&tclObjMutex);

#endif

}

/*

 *----------------------------------------------------------------------

 *

 * TclFinalizeObjects --

 *

 *	This procedure is called by Tcl_Finalize to clean up all

 *	registered Tcl_ObjType's and to reset the tclFreeObjList.

 *

 * Results:

 *	None.

 *

 * Side effects:

 *	None.

 *

 *----------------------------------------------------------------------

 */

void

TclFinalizeObjects()

{

    Tcl_MutexLock(&tableMutex);

    if (typeTableInitialized) {

        Tcl_DeleteHashTable(&typeTable);

        typeTableInitialized = 0;

    }

    Tcl_MutexUnlock(&tableMutex);

    /* 

     * All we do here is reset the head pointer of the linked list of

     * free Tcl_Obj's to NULL;  the memory finalization will take care

     * of releasing memory for us.

     */

    Tcl_MutexLock(&tclObjMutex);

    tclFreeObjList = NULL;

    Tcl_MutexUnlock(&tclObjMutex);

}

/*

 *--------------------------------------------------------------

 *

 * Tcl_RegisterObjType --

 *

 *	This procedure is called to register a new Tcl object type

 *	in the table of all object types supported by Tcl.

 *

 * Results:

 *	None.

 *

 * Side effects:

 *	The type is registered in the Tcl type table. If there was already

 *	a type with the same name as in typePtr, it is replaced with the

 *	new type.

 *

 *--------------------------------------------------------------

 */

EXPORT_C void

Tcl_RegisterObjType(typePtr)

    Tcl_ObjType *typePtr;	/* Information about object type;

				 * storage must be statically

				 * allocated (must live forever). */

{

    int new;

    Tcl_MutexLock(&tableMutex);

    Tcl_SetHashValue(

	    Tcl_CreateHashEntry(&typeTable, typePtr->name, &new), typePtr);

    Tcl_MutexUnlock(&tableMutex);

}

/*

 *----------------------------------------------------------------------

 *

 * Tcl_AppendAllObjTypes --

 *

 *	This procedure appends onto the argument object the name of each

 *	object type as a list element. This includes the builtin object

 *	types (e.g. int, list) as well as those added using

 *	Tcl_NewObj. These names can be used, for example, with

 *	Tcl_GetObjType to get pointers to the corresponding Tcl_ObjType

 *	structures.

 *

 * Results:

 *	The return value is normally TCL_OK; in this case the object

 *	referenced by objPtr has each type name appended to it. If an

 *	error occurs, TCL_ERROR is returned and the interpreter's result

 *	holds an error message.

 *

 * Side effects:

 *	If necessary, the object referenced by objPtr is converted into

 *	a list object.

 *

 *----------------------------------------------------------------------

 */

EXPORT_C int

Tcl_AppendAllObjTypes(interp, objPtr)

    Tcl_Interp *interp;		/* Interpreter used for error reporting. */

    Tcl_Obj *objPtr;		/* Points to the Tcl object onto which the

				 * name of each registered type is appended

				 * as a list element. */

{

    register Tcl_HashEntry *hPtr;

    Tcl_HashSearch search;

    int objc;

    Tcl_Obj **objv;

    /*

     * Get the test for a valid list out of the way first.

     */

    if (Tcl_ListObjGetElements(interp, objPtr, &objc, &objv) != TCL_OK) {

	return TCL_ERROR;

    }

    /*

     * Type names are NUL-terminated, not counted strings.

     * This code relies on that.

     */

    Tcl_MutexLock(&tableMutex);

    for (hPtr = Tcl_FirstHashEntry(&typeTable, &search);

	    hPtr != NULL;  hPtr = Tcl_NextHashEntry(&search)) {

	Tcl_ListObjAppendElement(NULL, objPtr,

	        Tcl_NewStringObj(Tcl_GetHashKey(&typeTable, hPtr), -1));

    }

    Tcl_MutexUnlock(&tableMutex);

    return TCL_OK;

}

/*

 *----------------------------------------------------------------------

 *

 * Tcl_GetObjType --

 *

 *	This procedure looks up an object type by name.

 *

 * Results:

 *	If an object type with name matching "typeName" is found, a pointer

 *	to its Tcl_ObjType structure is returned; otherwise, NULL is

 *	returned.

 *

 * Side effects:

 *	None.

 *

 *----------------------------------------------------------------------

 */

EXPORT_C Tcl_ObjType *

Tcl_GetObjType(typeName)

    CONST char *typeName;	/* Name of Tcl object type to look up. */

{

    register Tcl_HashEntry *hPtr;

    Tcl_ObjType *typePtr = NULL;

    Tcl_MutexLock(&tableMutex);

    hPtr = Tcl_FindHashEntry(&typeTable, typeName);

    if (hPtr != (Tcl_HashEntry *) NULL) {

        typePtr = (Tcl_ObjType *) Tcl_GetHashValue(hPtr);

    }

    Tcl_MutexUnlock(&tableMutex);

    return typePtr;

}

/*

 *----------------------------------------------------------------------

 *

 * Tcl_ConvertToType --

 *

 *	Convert the Tcl object "objPtr" to have type "typePtr" if possible.

 *

 * Results:

 *	The return value is TCL_OK on success and TCL_ERROR on failure. If

 *	TCL_ERROR is returned, then the interpreter's result contains an

 *	error message unless "interp" is NULL. Passing a NULL "interp"

 *	allows this procedure to be used as a test whether the conversion

 *	could be done (and in fact was done).

 *

 * Side effects:

 *	Any internal representation for the old type is freed.

 *

 *----------------------------------------------------------------------

 */

EXPORT_C int

Tcl_ConvertToType(interp, objPtr, typePtr)

    Tcl_Interp *interp;		/* Used for error reporting if not NULL. */

    Tcl_Obj *objPtr;		/* The object to convert. */

    Tcl_ObjType *typePtr;	/* The target type. */

{

    if (objPtr->typePtr == typePtr) {

	return TCL_OK;

    }

    /*

     * Use the target type's Tcl_SetFromAnyProc to set "objPtr"s internal

     * form as appropriate for the target type. This frees the old internal

     * representation.

     */

    return typePtr->setFromAnyProc(interp, objPtr);

}

/*

 *----------------------------------------------------------------------

 *

 * Tcl_NewObj --

 *

 *	This procedure is normally called when not debugging: i.e., when

 *	TCL_MEM_DEBUG is not defined. It creates new Tcl objects that denote

 *	the empty string. These objects have a NULL object type and NULL

 *	string representation byte pointer. Type managers call this routine

 *	to allocate new objects that they further initialize.

 *

 *	When TCL_MEM_DEBUG is defined, this procedure just returns the

 *	result of calling the debugging version Tcl_DbNewObj.

 *

 * Results:

 *	The result is a newly allocated object that represents the empty

 *	string. The new object's typePtr is set NULL and its ref count

 *	is set to 0.

 *

 * Side effects:

 *	If compiling with TCL_COMPILE_STATS, this procedure increments

 *	the global count of allocated objects (tclObjsAlloced).

 *

 *----------------------------------------------------------------------

 */

#ifdef TCL_MEM_DEBUG

#undef Tcl_NewObj

EXPORT_C Tcl_Obj *

Tcl_NewObj()

{

    return Tcl_DbNewObj("unknown", 0);

}

#else /* if not TCL_MEM_DEBUG */

EXPORT_C Tcl_Obj *

Tcl_NewObj()

{

    register Tcl_Obj *objPtr;

    /*

     * Use the macro defined in tclInt.h - it will use the

     * correct allocator.

     */

    TclNewObj(objPtr);

    return objPtr;

}