/* 

 * tclVar.c --

 *

 *	This file contains routines that implement Tcl variables

 *	(both scalars and arrays).

 *

 *	The implementation of arrays is modelled after an initial

 *	implementation by Mark Diekhans and Karl Lehenbauer.

 *

 * Copyright (c) 1987-1994 The Regents of the University of California.

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

 * Copyright (c) 1998-1999 by Scriptics Corporation.

 * Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.

 * 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: tclVar.c,v 1.69.2.14 2007/05/10 18:23:58 dgp Exp $

 */

#include "tclInt.h"

#include "tclPort.h"

/*

 * The strings below are used to indicate what went wrong when a

 * variable access is denied.

 */

static CONST char *noSuchVar =		"no such variable";

static CONST char *isArray =		"variable is array";

static CONST char *needArray =		"variable isn't array";

static CONST char *noSuchElement =	"no such element in array";

static CONST char *danglingElement =

				"upvar refers to element in deleted array";

static CONST char *danglingVar =	

				"upvar refers to variable in deleted namespace";

static CONST char *badNamespace =	"parent namespace doesn't exist";

static CONST char *missingName =	"missing variable name";

static CONST char *isArrayElement =	"name refers to an element in an array";

/*

 * Forward references to procedures defined later in this file:

 */

static int		CallVarTraces _ANSI_ARGS_((Interp *iPtr, Var *arrayPtr,

			    Var *varPtr, CONST char *part1, CONST char *part2,

			    int flags, CONST int leaveErrMsg));

static void		CleanupVar _ANSI_ARGS_((Var *varPtr,

			    Var *arrayPtr));

static void		DeleteSearches _ANSI_ARGS_((Var *arrayVarPtr));

static void		DeleteArray _ANSI_ARGS_((Interp *iPtr,

			    CONST char *arrayName, Var *varPtr, int flags));

static void		DisposeTraceResult _ANSI_ARGS_((int flags,

			    char *result));

static int              ObjMakeUpvar _ANSI_ARGS_((Tcl_Interp *interp, 

                            CallFrame *framePtr, Tcl_Obj *otherP1Ptr, 

                            CONST char *otherP2, CONST int otherFlags,

		            CONST char *myName, int myFlags, int index));

static Var *		NewVar _ANSI_ARGS_((void));

static ArraySearch *	ParseSearchId _ANSI_ARGS_((Tcl_Interp *interp,

			    CONST Var *varPtr, CONST char *varName,

			    Tcl_Obj *handleObj));

static void		VarErrMsg _ANSI_ARGS_((Tcl_Interp *interp,

			    CONST char *part1, CONST char *part2,

			    CONST char *operation, CONST char *reason));

static int		SetArraySearchObj _ANSI_ARGS_((Tcl_Interp *interp,

			    Tcl_Obj *objPtr));

static void		UnsetVarStruct _ANSI_ARGS_((Var *varPtr, Var *arrayPtr,

			    Interp *iPtr, CONST char *part1, CONST char *part2,

			    int flags));

/*

 * Functions defined in this file that may be exported in the future

 * for use by the bytecode compiler and engine or to the public interface.

 */

Var *		TclLookupSimpleVar _ANSI_ARGS_((Tcl_Interp *interp,

		    CONST char *varName, int flags, CONST int create,

		    CONST char **errMsgPtr, int *indexPtr));

int		TclObjUnsetVar2 _ANSI_ARGS_((Tcl_Interp *interp,

		    Tcl_Obj *part1Ptr, CONST char *part2, int flags));

static Tcl_FreeInternalRepProc FreeLocalVarName;

static Tcl_DupInternalRepProc DupLocalVarName;

static Tcl_UpdateStringProc UpdateLocalVarName;

static Tcl_FreeInternalRepProc FreeNsVarName;

static Tcl_DupInternalRepProc DupNsVarName;

static Tcl_FreeInternalRepProc FreeParsedVarName;

static Tcl_DupInternalRepProc DupParsedVarName;

static Tcl_UpdateStringProc UpdateParsedVarName;

/*

 * Types of Tcl_Objs used to cache variable lookups.

 *

 * 

 * localVarName - INTERNALREP DEFINITION:

 *   twoPtrValue.ptr1 = pointer to the corresponding Proc 

 *   twoPtrValue.ptr2 = index into locals table

 *

 * nsVarName - INTERNALREP DEFINITION:

 *   twoPtrValue.ptr1: pointer to the namespace containing the 

 *                     reference

 *   twoPtrValue.ptr2: pointer to the corresponding Var 

 *

 * parsedVarName - INTERNALREP DEFINITION:

 *   twoPtrValue.ptr1 = pointer to the array name Tcl_Obj, 

 *                      or NULL if it is a scalar variable

 *   twoPtrValue.ptr2 = pointer to the element name string

 *                      (owned by this Tcl_Obj), or NULL if 

 *                      it is a scalar variable

 */

static Tcl_ObjType tclLocalVarNameType = {

    "localVarName",

    FreeLocalVarName, DupLocalVarName, UpdateLocalVarName, NULL

};

static Tcl_ObjType tclNsVarNameType = {

    "namespaceVarName",

    FreeNsVarName, DupNsVarName, NULL, NULL

};

static Tcl_ObjType tclParsedVarNameType = {

    "parsedVarName",

    FreeParsedVarName, DupParsedVarName, UpdateParsedVarName, NULL

};

/*

 * Type of Tcl_Objs used to speed up array searches.

 *

 * INTERNALREP DEFINITION:

 *   twoPtrValue.ptr1 = searchIdNumber as offset from (char*)NULL

 *   twoPtrValue.ptr2 = variableNameStartInString as offset from (char*)NULL

 *

 * Note that the value stored in ptr2 is the offset into the string of

 * the start of the variable name and not the address of the variable

 * name itself, as this can be safely copied.

 */

Tcl_ObjType tclArraySearchType = {

    "array search",

    NULL, NULL, NULL, SetArraySearchObj

};

/*

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

 *

 * TclLookupVar --

 *

 *	This procedure is used to locate a variable given its name(s). It

 *      has been mostly superseded by TclObjLookupVar, it is now only used 

 *      by the string-based interfaces. It is kept in tcl8.4 mainly because 

 *      it is in the internal stubs table, so that some extension may be 

 *      calling it. 

 *

 * Results:

 *	The return value is a pointer to the variable structure indicated by

 *	part1 and part2, or NULL if the variable couldn't be found. If the

 *	variable is found, *arrayPtrPtr is filled in with the address of the

 *	variable structure for the array that contains the variable (or NULL

 *	if the variable is a scalar). If the variable can't be found and

 *	either createPart1 or createPart2 are 1, a new as-yet-undefined

 *	(VAR_UNDEFINED) variable structure is created, entered into a hash

 *	table, and returned.

 *

 *	If the variable isn't found and creation wasn't specified, or some

 *	other error occurs, NULL is returned and an error message is left in

 *	the interp's result if TCL_LEAVE_ERR_MSG is set in flags. 

 *

 *	Note: it's possible for the variable returned to be VAR_UNDEFINED

 *	even if createPart1 or createPart2 are 1 (these only cause the hash

 *	table entry or array to be created). For example, the variable might

 *	be a global that has been unset but is still referenced by a

 *	procedure, or a variable that has been unset but it only being kept

 *	in existence (if VAR_UNDEFINED) by a trace.

 *

 * Side effects:

 *	New hashtable entries may be created if createPart1 or createPart2

 *	are 1.

 *

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

 */

Var *

TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2,

        arrayPtrPtr)

    Tcl_Interp *interp;		/* Interpreter to use for lookup. */

    CONST char *part1;	        /* If part2 isn't NULL, this is the name of

				 * an array. Otherwise, this

				 * is a full variable name that could

				 * include a parenthesized array element. */

    CONST char *part2;		/* Name of element within array, or NULL. */

    int flags;			/* Only TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,

				 * and TCL_LEAVE_ERR_MSG bits matter. */

    CONST char *msg;			/* Verb to use in error messages, e.g.

				 * "read" or "set". Only needed if

				 * TCL_LEAVE_ERR_MSG is set in flags. */

    int createPart1;		/* If 1, create hash table entry for part 1

				 * of name, if it doesn't already exist. If

				 * 0, return error if it doesn't exist. */

    int createPart2;		/* If 1, create hash table entry for part 2

				 * of name, if it doesn't already exist. If

				 * 0, return error if it doesn't exist. */

    Var **arrayPtrPtr;		/* If the name refers to an element of an

				 * array, *arrayPtrPtr gets filled in with

				 * address of array variable. Otherwise

				 * this is set to NULL. */

{

    Var *varPtr;

    CONST char *elName;		/* Name of array element or NULL; may be

				 * same as part2, or may be openParen+1. */

    int openParen, closeParen;

                                /* If this procedure parses a name into

				 * array and index, these are the offsets to 

				 * the parens around the index.  Otherwise 

				 * they are -1. */

    register CONST char *p;

    CONST char *errMsg = NULL;

    int index;

#define VAR_NAME_BUF_SIZE 26

    char buffer[VAR_NAME_BUF_SIZE];

    char *newVarName = buffer;

    varPtr = NULL;

    *arrayPtrPtr = NULL;

    openParen = closeParen = -1;

    /*

     * Parse part1 into array name and index.

     * Always check if part1 is an array element name and allow it only if

     * part2 is not given.   

     * (if one does not care about creating array elements that can't be used

     *  from tcl, and prefer slightly better performance, one can put

     *  the following in an   if (part2 == NULL) { ... } block and remove

     *  the part2's test and error reporting  or move that code in array set)

     */

    elName = part2;

    for (p = part1; *p ; p++) {

	if (*p == '(') {

	    openParen = p - part1;

	    do {

		p++;

	    } while (*p != '\0');

	    p--;

	    if (*p == ')') {

		if (part2 != NULL) {

		    if (flags & TCL_LEAVE_ERR_MSG) {

			VarErrMsg(interp, part1, part2, msg, needArray);

		    }

		    return NULL;

		}

		closeParen = p - part1;

	    } else {

		openParen = -1;

	    }

	    break;

	}

    }

    if (openParen != -1) {

	if (closeParen >= VAR_NAME_BUF_SIZE) {

	    newVarName = ckalloc((unsigned int) (closeParen+1));

	}

	memcpy(newVarName, part1, (unsigned int) closeParen);

	newVarName[openParen] = '\0';

	newVarName[closeParen] = '\0';

	part1 = newVarName;

	elName = newVarName + openParen + 1;

    }

    varPtr = TclLookupSimpleVar(interp, part1, flags, 

            createPart1, &errMsg, &index);

    if (varPtr == NULL) {

	if ((errMsg != NULL) && (flags & TCL_LEAVE_ERR_MSG)) {

	    VarErrMsg(interp, part1, elName, msg, errMsg);

	}

    } else {

	while (TclIsVarLink(varPtr)) {

	    varPtr = varPtr->value.linkPtr;

	}

	if (elName != NULL) {

	    *arrayPtrPtr = varPtr;

	    varPtr = TclLookupArrayElement(interp, part1, elName, flags, 

		    msg, createPart1, createPart2, varPtr);

	}

    }

    if (newVarName != buffer) {

	ckfree(newVarName);

    }

    return varPtr;

#undef VAR_NAME_BUF_SIZE

}

/*

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

 *

 * TclObjLookupVar --

 *

 *	This procedure is used by virtually all of the variable code to

 *	locate a variable given its name(s). The parsing into array/element

 *      components and (if possible) the lookup results are cached in 

 *      part1Ptr, which is converted to one of the varNameTypes.

 *

 * Results:

 *	The return value is a pointer to the variable structure indicated by

 *	part1Ptr and part2, or NULL if the variable couldn't be found. If 

 *      the variable is found, *arrayPtrPtr is filled with the address of the

 *	variable structure for the array that contains the variable (or NULL

 *	if the variable is a scalar). If the variable can't be found and

 *	either createPart1 or createPart2 are 1, a new as-yet-undefined

 *	(VAR_UNDEFINED) variable structure is created, entered into a hash

 *	table, and returned.

 *

 *	If the variable isn't found and creation wasn't specified, or some

 *	other error occurs, NULL is returned and an error message is left in

 *	the interp's result if TCL_LEAVE_ERR_MSG is set in flags. 

 *

 *	Note: it's possible for the variable returned to be VAR_UNDEFINED

 *	even if createPart1 or createPart2 are 1 (these only cause the hash

 *	table entry or array to be created). For example, the variable might

 *	be a global that has been unset but is still referenced by a

 *	procedure, or a variable that has been unset but it only being kept

 *	in existence (if VAR_UNDEFINED) by a trace.

 *

 * Side effects:

 *	New hashtable entries may be created if createPart1 or createPart2

 *	are 1.

 *      The object part1Ptr is converted to one of tclLocalVarNameType, 

 *      tclNsVarNameType or tclParsedVarNameType and caches as much of the

 *      lookup as it can.

 *

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

 */

Var *

TclObjLookupVar(interp, part1Ptr, part2, flags, msg, createPart1, createPart2,

        arrayPtrPtr)

    Tcl_Interp *interp;		/* Interpreter to use for lookup. */

    register Tcl_Obj *part1Ptr;	/* If part2 isn't NULL, this is the name 

				 * of an array. Otherwise, this is a full 

				 * variable name that could include a parenthesized 

				 * array element. */

    CONST char *part2;		/* Name of element within array, or NULL. */

    int flags;		        /* Only TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,

				 * and TCL_LEAVE_ERR_MSG bits matter. */

    CONST char *msg;		/* Verb to use in error messages, e.g.

				 * "read" or "set". Only needed if

				 * TCL_LEAVE_ERR_MSG is set in flags. */

    CONST int createPart1;	/* If 1, create hash table entry for part 1

				 * of name, if it doesn't already exist. If

				 * 0, return error if it doesn't exist. */

    CONST int createPart2;	/* If 1, create hash table entry for part 2

				 * of name, if it doesn't already exist. If

				 * 0, return error if it doesn't exist. */

    Var **arrayPtrPtr;		/* If the name refers to an element of an

				 * array, *arrayPtrPtr gets filled in with

				 * address of array variable. Otherwise

				 * this is set to NULL. */

{

    Interp *iPtr = (Interp *) interp;

    register Var *varPtr;	/* Points to the variable's in-frame Var

				 * structure. */

    char *part1;

    int index, len1, len2;

    int parsed = 0;

    Tcl_Obj *objPtr;

    Tcl_ObjType *typePtr = part1Ptr->typePtr;

    CONST char *errMsg = NULL;

    CallFrame *varFramePtr = iPtr->varFramePtr;

    Namespace *nsPtr;

    /*

     * If part1Ptr is a tclParsedVarNameType, separate it into the 

     * pre-parsed parts.

     */

    *arrayPtrPtr = NULL;

    if (typePtr == &tclParsedVarNameType) {

	if (part1Ptr->internalRep.twoPtrValue.ptr1 != NULL) {

	    if (part2 != NULL) {

		/*

		 * ERROR: part1Ptr is already an array element, cannot 

		 * specify a part2.

		 */

		if (flags & TCL_LEAVE_ERR_MSG) {

		    part1 = TclGetString(part1Ptr);

		    VarErrMsg(interp, part1, part2, msg, needArray);

		}

		return NULL;

	    }

	    part2 = (char *) part1Ptr->internalRep.twoPtrValue.ptr2;

	    part1Ptr = (Tcl_Obj *) part1Ptr->internalRep.twoPtrValue.ptr1;

	    typePtr = part1Ptr->typePtr;

	}

	parsed = 1;

    }

    part1 = Tcl_GetStringFromObj(part1Ptr, &len1);    

    nsPtr = ((varFramePtr == NULL)? iPtr->globalNsPtr : varFramePtr->nsPtr);

    if (nsPtr->varResProc != NULL || iPtr->resolverPtr != NULL) {

	goto doParse;

    }

    if (typePtr == &tclLocalVarNameType) {

	Proc *procPtr = (Proc *) part1Ptr->internalRep.twoPtrValue.ptr1;

	int localIndex = (int) part1Ptr->internalRep.twoPtrValue.ptr2;

	int useLocal;

	useLocal = ((varFramePtr != NULL) && varFramePtr->isProcCallFrame

	        && !(flags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY)));

	if (useLocal && (procPtr == varFramePtr->procPtr)) {

	    /*

	     * part1Ptr points to an indexed local variable of the

	     * correct procedure: use the cached value.

	     */

	    varPtr = &(varFramePtr->compiledLocals[localIndex]);

	    goto donePart1;

	}

	goto doneParsing;

    } else if (typePtr == &tclNsVarNameType) {

	Namespace *cachedNsPtr;

	int useGlobal, useReference;

	varPtr = (Var *) part1Ptr->internalRep.twoPtrValue.ptr2;

	cachedNsPtr = (Namespace *) part1Ptr->internalRep.twoPtrValue.ptr1;

	useGlobal = (cachedNsPtr == iPtr->globalNsPtr) 

	    && ((flags & TCL_GLOBAL_ONLY) 

		|| ((*part1 == ':') && (*(part1+1) == ':'))

		|| (varFramePtr == NULL) 

		|| (!varFramePtr->isProcCallFrame 

		    && (nsPtr == iPtr->globalNsPtr)));

	useReference = useGlobal || ((cachedNsPtr == nsPtr) 

	        && ((flags & TCL_NAMESPACE_ONLY) 

		    || (varFramePtr && !varFramePtr->isProcCallFrame 

			&& !(flags & TCL_GLOBAL_ONLY)

			/* careful: an undefined ns variable could

			 * be hiding a valid global reference. */

			&& !(varPtr->flags & VAR_UNDEFINED))));

	if (useReference && (varPtr->hPtr != NULL)) {

	    /*

	     * A straight global or namespace reference, use it. It isn't 

	     * so simple to deal with 'implicit' namespace references, i.e., 

	     * those where the reference could be to either a namespace 

	     * or a global variable. Those we lookup again.

	     *

	     * If (varPtr->hPtr == NULL), this might be a reference to a

	     * variable in a deleted namespace, kept alive by e.g. part1Ptr.

	     * We could conceivably be so unlucky that a new namespace was

	     * created at the same address as the deleted one, so to be 

	     * safe we test for a valid hPtr.

	     */

	    goto donePart1;

	}

	goto doneParsing;

    }

    doParse:

    if (!parsed && (*(part1 + len1 - 1) == ')')) {

	/*

	 * part1Ptr is possibly an unparsed array element.

	 */

	register int i;

	char *newPart2;

	len2 = -1;

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

	    if (*(part1 + i) == '(') {

		if (part2 != NULL) {

		    if (flags & TCL_LEAVE_ERR_MSG) {

			VarErrMsg(interp, part1, part2, msg, needArray);

		    }

		}			

		/*

		 * part1Ptr points to an array element; first copy 

		 * the element name to a new string part2.

		 */

		part2 = part1 + i + 1;

		len2 = len1 - i - 2;

		len1 = i;

		newPart2 = ckalloc((unsigned int) (len2+1));

		memcpy(newPart2, part2, (unsigned int) len2);

		*(newPart2+len2) = '\0';

		part2 = newPart2;

		/*

		 * Free the internal rep of the original part1Ptr, now

		 * renamed objPtr, and set it to tclParsedVarNameType.

		 */

		objPtr = part1Ptr;

		if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) {

		    typePtr->freeIntRepProc(objPtr);

		}

		objPtr->typePtr = &tclParsedVarNameType;

		/*

		 * Define a new string object to hold the new part1Ptr, i.e., 

		 * the array name. Set the internal rep of objPtr, reset

		 * typePtr and part1 to contain the references to the

		 * array name.

		 */

		part1Ptr = Tcl_NewStringObj(part1, len1);

		Tcl_IncrRefCount(part1Ptr);

		objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) part1Ptr;

		objPtr->internalRep.twoPtrValue.ptr2 = (VOID *) part2;		

		typePtr = part1Ptr->typePtr;

		part1 = TclGetString(part1Ptr);

		break;

	    }

	}

    }

    doneParsing:

    /*

     * part1Ptr is not an array element; look it up, and convert 

     * it to one of the cached types if possible.

     */

    if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) {