Tcl Source Code

The end of the array is marked by a NULL string pointer.
.AP "const char" *msg in
Null-terminated string describing what is being looked up, such as
\fBoption\fR.  This string is included in error messages.
.AP int flags in
OR-ed combination of bits providing additional information for
operation.  The only bits that are currently defined are \fBTCL_EXACT\fR
, \fBTCL_INDEX_TEMP_TABLE\fR, and \fBTCL_INDEX_NULL_OK\fR.
.AP enum|char|short|int|long *indexPtr out
If not (int *)NULL, the index of the string in \fItablePtr\fR that
matches the value of \fIobjPtr\fR is returned here. The variable can
be any integer type, signed or unsigned, char, short, long or
long long. It can also be an enum.
.BE
.SH DESCRIPTION
.PP
These procedures provide an efficient way for looking up keywords,
switch names, option names, and similar things where the literal value of
a Tcl value must be chosen from a predefined set.
\fBTcl_GetIndexFromObj\fR compares \fIobjPtr\fR against each of
the strings in \fItablePtr\fR to find a match.  A match occurs if
\fIobjPtr\fR's string value is identical to one of the strings in
\fItablePtr\fR, or if it is a non-empty unique abbreviation
for exactly one of the strings in \fItablePtr\fR and the
\fBTCL_EXACT\fR flag was not specified; in either case
\fBTCL_OK\fR is returned. If \fIindexPtr\fR is not NULL the index
of the matching entry is stored at \fI*indexPtr\fR.

.PP
If there is no matching entry,
\fBTCL_ERROR\fR is returned and an error message is left in \fIinterp\fR's
result if \fIinterp\fR is not NULL.  \fIMsg\fR is included in the
error message to indicate what was being looked up.  For example,
if \fImsg\fR is \fBoption\fR the error message will have a form like
.QW "\fBbad option \N'34'firt\N'34': must be first, second, or third\fR" .
.PP
If the \fBTCL_INDEX_TEMP_TABLE\fR was not specified, when
\fBTcl_GetIndexFromObj\fR completes successfully it modifies the
internal representation of \fIobjPtr\fR to hold the address of
the table and the index of the matching entry.  If \fBTcl_GetIndexFromObj\fR
is invoked again with the same \fIobjPtr\fR and \fItablePtr\fR
arguments (e.g. during a reinvocation of a Tcl command), it returns
the matching index immediately without having to redo the lookup
operation.  Note: \fBTcl_GetIndexFromObj\fR assumes that the entries
in \fItablePtr\fR are static: they must not change between
invocations.  This caching mechanism can be disallowed by specifying
the \fBTCL_INDEX_TEMP_TABLE\fR flag.
If the \fBTCL_INDEX_NULL_OK\fR flag was specified, objPtr is allowed
to be NULL or the empty string. The resulting index is -1.
Otherwise, if the value of \fIobjPtr\fR is the empty string,
\fBTcl_GetIndexFromObj\fR will treat it as a non-matching value
and return \fBTCL_ERROR\fR.
.PP
\fBTcl_GetIndexFromObjStruct\fR works just like
\fBTcl_GetIndexFromObj\fR, except that instead of treating
\fItablePtr\fR as an array of string pointers, it treats it as a
pointer to the first string in a series of strings that have

}
declare 303 {
    void Tcl_GetEncodingNames(Tcl_Interp *interp)
}
declare 304 {
    int Tcl_GetIndexFromObjStruct(Tcl_Interp *interp, Tcl_Obj *objPtr,
	    const void *tablePtr, int offset, const char *msg, int flags,
	    void *indexPtr)
}
declare 305 {
    void *Tcl_GetThreadData(Tcl_ThreadDataKey *keyPtr, int size)
}
declare 306 {
    Tcl_Obj *Tcl_GetVar2Ex(Tcl_Interp *interp, const char *part1,
	    const char *part2, int flags)

#define TCL_DONT_QUOTE_HASH	8

/*
 * Flags that may be passed to Tcl_GetIndexFromObj.
 * TCL_EXACT disallows abbreviated strings.
 * TCL_INDEX_TEMP_TABLE disallows caching of lookups. A possible use case is
 *      a table that will not live long enough to make it worthwhile.
 * TCL_INDEX_NULL_OK allows the empty string or NULL to return TCL_OK.
 *      The returned value will be -1;
 */

#define TCL_EXACT		1
#define TCL_INDEX_TEMP_TABLE	2
#define TCL_INDEX_NULL_OK	4

/*
 *----------------------------------------------------------------------------
 * Flag values passed to Tcl_RecordAndEval, Tcl_EvalObj, Tcl_EvalObjv.
 * WARNING: these bit choices must not conflict with the bit choices for
 * evalFlag bits in tclInt.h!
 *

EXTERN const char *	Tcl_GetEncodingName(Tcl_Encoding encoding);
/* 303 */
EXTERN void		Tcl_GetEncodingNames(Tcl_Interp *interp);
/* 304 */
EXTERN int		Tcl_GetIndexFromObjStruct(Tcl_Interp *interp,
				Tcl_Obj *objPtr, const void *tablePtr,
				int offset, const char *msg, int flags,
				void *indexPtr);
/* 305 */
EXTERN void *		Tcl_GetThreadData(Tcl_ThreadDataKey *keyPtr,
				int size);
/* 306 */
EXTERN Tcl_Obj *	Tcl_GetVar2Ex(Tcl_Interp *interp, const char *part1,
				const char *part2, int flags);
/* 307 */

    void (*tcl_FinalizeThread) (void); /* 297 */
    void (*tcl_FinalizeNotifier) (ClientData clientData); /* 298 */
    void (*tcl_FreeEncoding) (Tcl_Encoding encoding); /* 299 */
    Tcl_ThreadId (*tcl_GetCurrentThread) (void); /* 300 */
    Tcl_Encoding (*tcl_GetEncoding) (Tcl_Interp *interp, const char *name); /* 301 */
    const char * (*tcl_GetEncodingName) (Tcl_Encoding encoding); /* 302 */
    void (*tcl_GetEncodingNames) (Tcl_Interp *interp); /* 303 */
    int (*tcl_GetIndexFromObjStruct) (Tcl_Interp *interp, Tcl_Obj *objPtr, const void *tablePtr, int offset, const char *msg, int flags, void *indexPtr); /* 304 */
    void * (*tcl_GetThreadData) (Tcl_ThreadDataKey *keyPtr, int size); /* 305 */
    Tcl_Obj * (*tcl_GetVar2Ex) (Tcl_Interp *interp, const char *part1, const char *part2, int flags); /* 306 */
    ClientData (*tcl_InitNotifier) (void); /* 307 */
    void (*tcl_MutexLock) (Tcl_Mutex *mutexPtr); /* 308 */
    void (*tcl_MutexUnlock) (Tcl_Mutex *mutexPtr); /* 309 */
    void (*tcl_ConditionNotify) (Tcl_Condition *condPtr); /* 310 */
    void (*tcl_ConditionWait) (Tcl_Condition *condPtr, Tcl_Mutex *mutexPtr, const Tcl_Time *timePtr); /* 311 */

#undef Tcl_GetString
#undef Tcl_GetUnicode
#define Tcl_GetString(objPtr) \
	Tcl_GetStringFromObj(objPtr, (int *)NULL)
#define Tcl_GetUnicode(objPtr) \
	Tcl_GetUnicodeFromObj(objPtr, (int *)NULL)
#undef Tcl_GetBytesFromObj
#undef Tcl_GetIndexFromObjStruct
#ifdef TCL_NO_DEPRECATED
#undef Tcl_GetStringFromObj
#undef Tcl_GetUnicodeFromObj
#undef Tcl_GetByteArrayFromObj
#endif
#if defined(USE_TCL_STUBS)
#define Tcl_GetBytesFromObj(interp, objPtr, sizePtr) \
	(sizeof(*sizePtr) <= sizeof(int) ? tclStubsPtr->tclGetBytesFromObj(interp, objPtr, (int *)sizePtr) : tclStubsPtr->tcl_GetBytesFromObj(interp, objPtr, (size_t *)sizePtr))
#define Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr) \
	(tclStubsPtr->tcl_GetIndexFromObjStruct((interp), (objPtr), (tablePtr), (offset), (msg), (flags)|(int)(sizeof(*indexPtr)<<8), (indexPtr)))
#ifdef TCL_NO_DEPRECATED
#define Tcl_GetStringFromObj(objPtr, sizePtr) \
	(sizeof(*sizePtr) <= sizeof(int) ? tclStubsPtr->tcl_GetStringFromObj(objPtr, (int *)sizePtr) : tclStubsPtr->tclGetStringFromObj(objPtr, (size_t *)sizePtr))
#define Tcl_GetByteArrayFromObj(objPtr, sizePtr) \
	(sizeof(*sizePtr) <= sizeof(int) ? tclStubsPtr->tcl_GetByteArrayFromObj(objPtr, (int *)sizePtr) : tclStubsPtr->tclGetByteArrayFromObj(objPtr, (size_t *)sizePtr))
#define Tcl_GetUnicodeFromObj(objPtr, sizePtr) \
	(sizeof(*sizePtr) <= sizeof(int) ? tclStubsPtr->tcl_GetUnicodeFromObj(objPtr, (int *)sizePtr) : tclStubsPtr->tclGetUnicodeFromObj(objPtr, (size_t *)sizePtr))
#endif
#else
#define Tcl_GetBytesFromObj(interp, objPtr, sizePtr) \
	(sizeof(*sizePtr) <= sizeof(int) ? (TclGetBytesFromObj)(interp, objPtr, (int *)sizePtr) : (Tcl_GetBytesFromObj)(interp, objPtr, (size_t *)sizePtr))
#define Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr) \
	((Tcl_GetIndexFromObjStruct)((interp), (objPtr), (tablePtr), (offset), (msg), (flags)|(int)(sizeof(*indexPtr)<<8), (indexPtr)))
#ifdef TCL_NO_DEPRECATED
#define Tcl_GetStringFromObj(objPtr, sizePtr) \
	(sizeof(*sizePtr) <= sizeof(int) ? (Tcl_GetStringFromObj)(objPtr, (int *)sizePtr) : (TclGetStringFromObj)(objPtr, (size_t *)sizePtr))
#define Tcl_GetByteArrayFromObj(objPtr, sizePtr) \
	(sizeof(*sizePtr) <= sizeof(int) ? (Tcl_GetByteArrayFromObj)(objPtr, (int *)sizePtr) : TclGetByteArrayFromObj(objPtr, (size_t *)sizePtr))
#define Tcl_GetUnicodeFromObj(objPtr, sizePtr) \
	(sizeof(*sizePtr) <= sizeof(int) ? (Tcl_GetUnicodeFromObj)(objPtr, (int *)sizePtr) : TclGetUnicodeFromObj(objPtr, (size_t *)sizePtr))

 *	This function 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 tablePtr, then the return value is TCL_OK and
 *	the index of the matching entry is stored at *indexPtr
 *	(unless indexPtr is NULL). 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 like '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.
 *
 *----------------------------------------------------------------------
 */

#undef Tcl_GetIndexFromObjStruct
int
Tcl_GetIndexFromObjStruct(
    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, TCL_EXACT, TCL_INDEX_TEMP_TABLE or TCL_INDEX_NULL_OK */
    void *indexPtr)		/* Place to store resulting index. */
{
    int index, idx, numAbbrev;
    const char *key, *p1;
    const char *p2;
    const char *const *entryPtr;
    Tcl_Obj *resultPtr;
    IndexRep *indexRep;

    if (objPtr && !(flags & TCL_INDEX_TEMP_TABLE)) {
    irPtr = TclFetchInternalRep(objPtr, &indexType);
    if (irPtr) {
	indexRep = (IndexRep *)irPtr->twoPtrValue.ptr1;
	if ((indexRep->tablePtr == tablePtr)
		&& (indexRep->offset == offset)
		&& (indexRep->index >= 0)) {
	    index = indexRep->index;
	    goto uncachedDone;
	}
    }
    }

    /*
     * Lookup the value of the object in the table. Accept unique
     * abbreviations unless TCL_EXACT is set in flags.
     */

    key = objPtr ? TclGetString(objPtr) : "";
    index = -1;
    numAbbrev = 0;

    if (!*key && (flags & TCL_INDEX_NULL_OK)) {
	goto uncachedDone;
    }
    /*
     * 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)
     */

	Tcl_StoreInternalRep(objPtr, &indexType, &ir);
    }
    indexRep->tablePtr = (void *) tablePtr;
    indexRep->offset = offset;
    indexRep->index = index;
    }

  uncachedDone:
    if (indexPtr != NULL) {
	if ((flags>>8) & (int)~sizeof(int)) {
	    if ((flags>>8) == sizeof(uint64_t)) {
		*(uint64_t *)indexPtr = index;
		return TCL_OK;
	    } else if ((flags>>8) == sizeof(uint32_t)) {
		*(uint32_t *)indexPtr = index;
		return TCL_OK;
	    } else if ((flags>>8) == sizeof(uint16_t)) {
		*(uint16_t *)indexPtr = index;
		return TCL_OK;
	    } else if ((flags>>8) == sizeof(uint8_t)) {
		*(uint8_t *)indexPtr = index;
		return TCL_OK;
	}
	}
	*(int *)indexPtr = index;
    }
    return TCL_OK;

  error:
    if (interp != NULL) {
	/*
	 * Produce a fancy error message.
	 */

	if (*entryPtr == NULL) {
	    Tcl_AppendStringsToObj(resultPtr, "\": no valid options", NULL);
	} else {
	    Tcl_AppendStringsToObj(resultPtr, "\": must be ",
		    *entryPtr, NULL);
	    entryPtr = NEXT_ENTRY(entryPtr, offset);
	    while (*entryPtr != NULL) {
		if ((*NEXT_ENTRY(entryPtr, offset) == NULL) && !(flags & TCL_INDEX_NULL_OK)) {
		    Tcl_AppendStringsToObj(resultPtr, (count > 0 ? "," : ""),
			    " or ", *entryPtr, NULL);
		} else if (**entryPtr) {
		    Tcl_AppendStringsToObj(resultPtr, ", ", *entryPtr, NULL);
		    count++;
		}
		entryPtr = NEXT_ENTRY(entryPtr, offset);
	    }
	    if ((flags & TCL_INDEX_NULL_OK)) {
		Tcl_AppendStringsToObj(resultPtr, ", or \"\"", NULL);
	    }
	}
	Tcl_SetObjResult(interp, resultPtr);
	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", msg, key, NULL);
    }
    return TCL_ERROR;
}


    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    const char *const ary[] = {
	"a", "b", "c", "d", "ee", "ff", NULL, NULL
    };
    int target, flags = 0;
    signed char idx[8];

    if (objc != 3 && objc != 4) {
	Tcl_WrongNumArgs(interp, 1, objv, "argument targetvalue ?flags?");
	return TCL_ERROR;
    }
    if (Tcl_GetIntFromObj(interp, objv[2], &target) != TCL_OK) {
	return TCL_ERROR;
    }
    if ((objc > 3) && (Tcl_GetIntFromObj(interp, objv[3], &flags) != TCL_OK)) {
	return TCL_ERROR;
    }
    memset(idx, 85, sizeof(idx));
    if (Tcl_GetIndexFromObjStruct(interp, (Tcl_GetString(objv[1])[0] ? objv[1] : NULL), ary, 2*sizeof(char *),
	    "dummy", flags, &idx[1]) != TCL_OK) {
	return TCL_ERROR;
    }
    if (idx[0] != 85 || idx[2] != 85) {
	Tcl_AppendResult(interp, "Tcl_GetIndexFromObjStruct overwrites bytes near index variable", NULL);
	return TCL_ERROR;
    } else if (idx[1] != target) {
	char buffer[64];
	sprintf(buffer, "%d", idx[1]);
	Tcl_AppendResult(interp, "index value comparison failed: got ",
		buffer, NULL);
	sprintf(buffer, "%d", target);
	Tcl_AppendResult(interp, " when ", buffer, " expected", NULL);
	return TCL_ERROR;
    }
    Tcl_WrongNumArgs(interp, objc, objv, NULL);

    set x e
    testgetindexfromobjstruct $x 0 1
} -returnCodes error -result {bad dummy "e": must be a, c, or ee}
test indexObj-6.6 {Tcl_GetIndexFromObjStruct with NULL input} -constraints testindexobj -body {
    set x ""
    testgetindexfromobjstruct $x 0
} -returnCodes error -result {ambiguous dummy "": must be a, c, or ee}
test indexObj-6.7 {Tcl_GetIndexFromObjStruct} testindexobj {
    set x ""
    testgetindexfromobjstruct $x -1 4
} "wrong # args: should be \"testgetindexfromobjstruct {} -1 4\""

test indexObj-7.1 {Tcl_ParseArgsObjv} testparseargs {
    testparseargs
} {0 1 testparseargs}
test indexObj-7.2 {Tcl_ParseArgsObjv} testparseargs {
    testparseargs -bool
} {1 1 testparseargs}