/* 

 * tclIndexObj.c --

 *

 *	This file implements objects of type "index".  This object type

 *	is used to lookup a keyword in a table of valid values and cache

 *	the index of the matching entry.

 *

 * Copyright (c) 1997 Sun Microsystems, Inc.

 * 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: tclIndexObj.c,v 1.16.2.5 2006/04/06 18:57:24 dgp Exp $

 */

#include "tclInt.h"

#include "tclPort.h"

/*

 * Prototypes for procedures defined later in this file:

 */

static int		SetIndexFromAny _ANSI_ARGS_((Tcl_Interp *interp,

			    Tcl_Obj *objPtr));

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

static void		DupIndex _ANSI_ARGS_((Tcl_Obj *srcPtr,

			    Tcl_Obj *dupPtr));

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

/*

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

 * procedures that can be invoked by generic object code.

 */

Tcl_ObjType tclIndexType = {

    "index",				/* name */

    FreeIndex,				/* freeIntRepProc */

    DupIndex,				/* dupIntRepProc */

    UpdateStringOfIndex,		/* updateStringProc */

    SetIndexFromAny			/* setFromAnyProc */

};

/*

 * The definition of the internal representation of the "index"

 * object; The internalRep.otherValuePtr field of an object of "index"

 * type will be a pointer to one of these structures.

 *

 * Keep this structure declaration in sync with tclTestObj.c

 */

typedef struct {

    VOID *tablePtr;			/* Pointer to the table of strings */

    int offset;				/* Offset between table entries */

    int index;				/* Selected index into table. */

} IndexRep;

/*

 * The following macros greatly simplify moving through a table...

 */

#define STRING_AT(table, offset, index) \

	(*((CONST char * CONST *)(((char *)(table)) + ((offset) * (index)))))

#define NEXT_ENTRY(table, offset) \

	(&(STRING_AT(table, offset, 1)))

#define EXPAND_OF(indexRep) \

	STRING_AT((indexRep)->tablePtr, (indexRep)->offset, (indexRep)->index)

/*

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

 *

 * Tcl_GetIndexFromObj --

 *

 *	This procedure looks up an object's value in a table of strings

 *	and returns the index of the matching string, if any.

 *

 * Results:

 *

 *	If the value of objPtr is identical to or a unique abbreviation

 *	for one of the entries in objPtr, then the return value is

 *	TCL_OK and the index of the matching entry is stored at

 *	*indexPtr.  If there isn't a proper match, then TCL_ERROR is

 *	returned and an error message is left in interp's result (unless

 *	interp is NULL).  The msg argument is used in the error

 *	message; for example, if msg has the value "option" then the

 *	error message will say something flag 'bad option "foo": must be

 *	...'

 *

 * Side effects:

 *	The result of the lookup is cached as the internal rep of

 *	objPtr, so that repeated lookups can be done quickly.

 *

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

 */

EXPORT_C int

Tcl_GetIndexFromObj(interp, objPtr, tablePtr, msg, flags, indexPtr)

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

    Tcl_Obj *objPtr;		/* Object containing the string to lookup. */

    CONST char **tablePtr;	/* Array of strings to compare against the

				 * value of objPtr; last entry must be NULL

				 * and there must not be duplicate entries. */

    CONST char *msg;		/* Identifying word to use in error messages. */

    int flags;			/* 0 or TCL_EXACT */

    int *indexPtr;		/* Place to store resulting integer index. */

{

    /*

     * See if there is a valid cached result from a previous lookup

     * (doing the check here saves the overhead of calling

     * Tcl_GetIndexFromObjStruct in the common case where the result

     * is cached).

     */

    if (objPtr->typePtr == &tclIndexType) {

	IndexRep *indexRep = (IndexRep *) objPtr->internalRep.otherValuePtr;

	/*

	 * Here's hoping we don't get hit by unfortunate packing

	 * constraints on odd platforms like a Cray PVP...

	 */

	if (indexRep->tablePtr == (VOID *)tablePtr &&

		indexRep->offset == sizeof(char *)) {

	    *indexPtr = indexRep->index;

	    return TCL_OK;

	}

    }

    return Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, sizeof(char *),

	    msg, flags, indexPtr);

}

/*

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

 *

 * Tcl_GetIndexFromObjStruct --

 *

 *	This procedure looks up an object's value given a starting

 *	string and an offset for the amount of space between strings.

 *	This is useful when the strings are embedded in some other

 *	kind of array.

 *

 * Results:

 *

 *	If the value of objPtr is identical to or a unique abbreviation

 *	for one of the entries in objPtr, then the return value is

 *	TCL_OK and the index of the matching entry is stored at

 *	*indexPtr.  If there isn't a proper match, then TCL_ERROR is

 *	returned and an error message is left in interp's result (unless

 *	interp is NULL).  The msg argument is used in the error

 *	message; for example, if msg has the value "option" then the

 *	error message will say something flag 'bad option "foo": must be

 *	...'

 *

 * Side effects:

 *	The result of the lookup is cached as the internal rep of

 *	objPtr, so that repeated lookups can be done quickly.

 *

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

 */

EXPORT_C int

Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, 

	indexPtr)

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

    Tcl_Obj *objPtr;		/* Object containing the string to lookup. */

    CONST VOID *tablePtr;	/* The first string in the table. The second

				 * string will be at this address plus the

				 * offset, the third plus the offset again,

				 * etc. The last entry must be NULL

				 * and there must not be duplicate entries. */

    int offset;			/* The number of bytes between entries */

    CONST char *msg;		/* Identifying word to use in error messages. */

    int flags;			/* 0 or TCL_EXACT */

    int *indexPtr;		/* Place to store resulting integer index. */

{

    int index, i, numAbbrev;

    char *key, *p1;

    CONST char *p2;

    CONST char * CONST *entryPtr;

    Tcl_Obj *resultPtr;

    IndexRep *indexRep;

    /*

     * See if there is a valid cached result from a previous lookup.

     */

    if (objPtr->typePtr == &tclIndexType) {

	indexRep = (IndexRep *) objPtr->internalRep.otherValuePtr;

	if (indexRep->tablePtr==tablePtr && indexRep->offset==offset) {

	    *indexPtr = indexRep->index;

	    return TCL_OK;

	}

    }

    /*

     * Lookup the value of the object in the table.  Accept unique

     * abbreviations unless TCL_EXACT is set in flags.

     */

    key = TclGetString(objPtr);

    index = -1;

    numAbbrev = 0;

    /*

     * Scan the table looking for one of:

     *  - An exact match (always preferred)

     *  - A single abbreviation (allowed depending on flags)

     *  - Several abbreviations (never allowed, but overridden by exact match)

     */

    for (entryPtr = tablePtr, i = 0; *entryPtr != NULL; 

	    entryPtr = NEXT_ENTRY(entryPtr, offset), i++) {

	for (p1 = key, p2 = *entryPtr; *p1 == *p2; p1++, p2++) {

	    if (*p1 == '\0') {

		index = i;

		goto done;

	    }

	}

	if (*p1 == '\0') {

	    /*

	     * The value is an abbreviation for this entry.  Continue

	     * checking other entries to make sure it's unique.  If we

	     * get more than one unique abbreviation, keep searching to

	     * see if there is an exact match, but remember the number

	     * of unique abbreviations and don't allow either.

	     */

	    numAbbrev++;

	    index = i;

	}

    }

    /*

     * Check if we were instructed to disallow abbreviations. 

     */

    if ((flags & TCL_EXACT) || (key[0] == '\0') || (numAbbrev != 1)) {

	goto error;

    }

    done:

    /*

     * Cache the found representation.  Note that we want to avoid

     * allocating a new internal-rep if at all possible since that is

     * potentially a slow operation.

     */

    if (objPtr->typePtr == &tclIndexType) {

 	indexRep = (IndexRep *) objPtr->internalRep.otherValuePtr;

    } else {

 	if ((objPtr->typePtr != NULL)

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

 	    objPtr->typePtr->freeIntRepProc(objPtr);

 	}

 	indexRep = (IndexRep *) ckalloc(sizeof(IndexRep));

 	objPtr->internalRep.otherValuePtr = (VOID *) indexRep;

 	objPtr->typePtr = &tclIndexType;

    }

    indexRep->tablePtr = (VOID*) tablePtr;

    indexRep->offset = offset;

    indexRep->index = index;

    *indexPtr = index;

    return TCL_OK;

    error:

    if (interp != NULL) {

	/*

	 * Produce a fancy error message.

	 */

	int count;

	TclNewObj(resultPtr);

	Tcl_SetObjResult(interp, resultPtr);

	Tcl_AppendStringsToObj(resultPtr, (numAbbrev > 1) &&

		!(flags & TCL_EXACT) ? "ambiguous " : "bad ", msg, " \"",

		key, "\": must be ", STRING_AT(tablePtr,offset,0), (char*)NULL);

	for (entryPtr = NEXT_ENTRY(tablePtr, offset), count = 0;

		*entryPtr != NULL;

		entryPtr = NEXT_ENTRY(entryPtr, offset), count++) {

	    if (*NEXT_ENTRY(entryPtr, offset) == NULL) {

		Tcl_AppendStringsToObj(resultPtr,

			(count > 0) ? ", or " : " or ", *entryPtr,

			(char *) NULL);

	    } else {

		Tcl_AppendStringsToObj(resultPtr, ", ", *entryPtr,

			(char *) NULL);

	    }

	}

    }

    return TCL_ERROR;

}

/*

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

 *

 * SetIndexFromAny --

 *

 *	This procedure is called to convert a Tcl object to index

 *	internal form. However, this doesn't make sense (need to have a

 *	table of keywords in order to do the conversion) so the

 *	procedure always generates an error.

 *

 * Results:

 *	The return value is always TCL_ERROR, and an error message is

 *	left in interp's result if interp isn't NULL. 

 *

 * Side effects:

 *	None.

 *

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

 */

static int

SetIndexFromAny(interp, objPtr)

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

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

{

    Tcl_AppendToObj(Tcl_GetObjResult(interp),

	    "can't convert value to index except via Tcl_GetIndexFromObj API",

	    -1);

    return TCL_ERROR;

}

/*

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

 *

 * UpdateStringOfIndex --

 *

 *	This procedure is called to convert a Tcl object from index

 *	internal form to its string form.  No abbreviation is ever

 *	generated.

 *

 * Results:

 *	None.

 *

 * Side effects:

 *	The string representation of the object is updated.

 *

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

 */

static void

UpdateStringOfIndex(objPtr)

    Tcl_Obj *objPtr;

{

    IndexRep *indexRep = (IndexRep *) objPtr->internalRep.otherValuePtr;

    register char *buf;

    register unsigned len;

    register CONST char *indexStr = EXPAND_OF(indexRep);

    len = strlen(indexStr);

    buf = (char *) ckalloc(len + 1);

    memcpy(buf, indexStr, len+1);

    objPtr->bytes = buf;

    objPtr->length = len;

}

/*

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

 *

 * DupIndex --

 *

 *	This procedure is called to copy the internal rep of an index

 *	Tcl object from to another object.

 *

 * Results:

 *	None.

 *

 * Side effects:

 *	The internal representation of the target object is updated

 *	and the type is set.

 *

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

 */

static void

DupIndex(srcPtr, dupPtr)

    Tcl_Obj *srcPtr, *dupPtr;

{

    IndexRep *srcIndexRep = (IndexRep *) srcPtr->internalRep.otherValuePtr;

    IndexRep *dupIndexRep = (IndexRep *) ckalloc(sizeof(IndexRep));

    memcpy(dupIndexRep, srcIndexRep, sizeof(IndexRep));

    dupPtr->internalRep.otherValuePtr = (VOID *) dupIndexRep;

    dupPtr->typePtr = &tclIndexType;

}

/*

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

 *

 * FreeIndex --

 *

 *	This procedure is called to delete the internal rep of an index

 *	Tcl object.

 *

 * Results:

 *	None.

 *

 * Side effects:

 *	The internal representation of the target object is deleted.

 *

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

 */

static void

FreeIndex(objPtr)

    Tcl_Obj *objPtr;

{

    ckfree((char *) objPtr->internalRep.otherValuePtr);

}

/*

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

 *

 * Tcl_WrongNumArgs --

 *

 *	This procedure generates a "wrong # args" error message in an

 *	interpreter.  It is used as a utility function by many command

 *	procedures.

 *

 * Results:

 *	None.

 *

 * Side effects:

 *	An error message is generated in interp's result object to

 *	indicate that a command was invoked with the wrong number of

 *	arguments.  The message has the form

 *		wrong # args: should be "foo bar additional stuff"

 *	where "foo" and "bar" are the initial objects in objv (objc

 *	determines how many of these are printed) and "additional stuff"

 *	is the contents of the message argument.

 *

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

 */

EXPORT_C void

Tcl_WrongNumArgs(interp, objc, objv, message)

    Tcl_Interp *interp;			/* Current interpreter. */

    int objc;				/* Number of arguments to print

					 * from objv. */

    Tcl_Obj *CONST objv[];		/* Initial argument objects, which

					 * should be included in the error

					 * message. */

    CONST char *message;		/* Error message to print after the

					 * leading objects in objv. The

					 * message may be NULL. */

{

    Tcl_Obj *objPtr;

    int i;

    register IndexRep *indexRep;

    TclNewObj(objPtr);

    Tcl_SetObjResult(interp, objPtr);

    Tcl_AppendToObj(objPtr, "wrong # args: should be \"", -1);

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

	/*

	 * If the object is an index type use the index table which allows

	 * for the correct error message even if the subcommand was

	 * abbreviated.  Otherwise, just use the string rep.

	 */

	if (objv[i]->typePtr == &tclIndexType) {

	    indexRep = (IndexRep *) objv[i]->internalRep.otherValuePtr;

	    Tcl_AppendStringsToObj(objPtr, EXPAND_OF(indexRep), (char *) NULL);

	} else {

	    Tcl_AppendStringsToObj(objPtr, Tcl_GetString(objv[i]),

		    (char *) NULL);

	}

	/*

	 * Append a space character (" ") if there is more text to follow

	 * (either another element from objv, or the message string).

	 */

	if ((i < (objc - 1)) || message) {

	    Tcl_AppendStringsToObj(objPtr, " ", (char *) NULL);

	}

    }

    if (message) {

	Tcl_AppendStringsToObj(objPtr, message, (char *) NULL);

    }

    Tcl_AppendStringsToObj(objPtr, "\"", (char *) NULL);

}