diff options
Diffstat (limited to 'tcl/generic/tclIndexObj.c')
| -rw-r--r-- | tcl/generic/tclIndexObj.c | 308 |
1 files changed, 308 insertions, 0 deletions
diff --git a/tcl/generic/tclIndexObj.c b/tcl/generic/tclIndexObj.c new file mode 100644 index 00000000000..f88d216e751 --- /dev/null +++ b/tcl/generic/tclIndexObj.c @@ -0,0 +1,308 @@ +/* + * 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. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * RCS: @(#) $Id$ + */ + +#include "tclInt.h" + +/* + * Prototypes for procedures defined later in this file: + */ + +static void DupIndexInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr, + Tcl_Obj *copyPtr)); +static int SetIndexFromAny _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr)); +static void UpdateStringOfIndex _ANSI_ARGS_((Tcl_Obj *listPtr)); + +/* + * 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 */ + (Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */ + DupIndexInternalRep, /* dupIntRepProc */ + UpdateStringOfIndex, /* updateStringProc */ + SetIndexFromAny /* setFromAnyProc */ +}; + +/* + *---------------------------------------------------------------------- + * + * 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. + * + *---------------------------------------------------------------------- + */ + +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. */ + char **tablePtr; /* Array of strings to compare against the + * value of objPtr; last entry must be NULL + * and there must not be duplicate entries. */ + 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, length, i, numAbbrev; + char *key, *p1, *p2, **entryPtr; + Tcl_Obj *resultPtr; + + /* + * See if there is a valid cached result from a previous lookup. + */ + + if ((objPtr->typePtr == &tclIndexType) + && (objPtr->internalRep.twoPtrValue.ptr1 == (VOID *) tablePtr)) { + *indexPtr = (int) objPtr->internalRep.twoPtrValue.ptr2; + return TCL_OK; + } + + /* + * Lookup the value of the object in the table. Accept unique + * abbreviations unless TCL_EXACT is set in flags. + */ + + key = Tcl_GetStringFromObj(objPtr, &length); + index = -1; + numAbbrev = 0; + for (entryPtr = tablePtr, i = 0; *entryPtr != NULL; entryPtr++, 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; + } + } + if ((flags & TCL_EXACT) || (numAbbrev != 1)) { + goto error; + } + + done: + if ((objPtr->typePtr != NULL) + && (objPtr->typePtr->freeIntRepProc != NULL)) { + objPtr->typePtr->freeIntRepProc(objPtr); + } + objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) tablePtr; + objPtr->internalRep.twoPtrValue.ptr2 = (VOID *) index; + objPtr->typePtr = &tclIndexType; + *indexPtr = index; + return TCL_OK; + + error: + if (interp != NULL) { + resultPtr = Tcl_GetObjResult(interp); + Tcl_AppendStringsToObj(resultPtr, + (numAbbrev > 1) ? "ambiguous " : "bad ", msg, " \"", + key, "\": must be ", *tablePtr, (char *) NULL); + for (entryPtr = tablePtr+1; *entryPtr != NULL; entryPtr++) { + if (entryPtr[1] == NULL) { + Tcl_AppendStringsToObj(resultPtr, ", or ", *entryPtr, + (char *) NULL); + } else { + Tcl_AppendStringsToObj(resultPtr, ", ", *entryPtr, + (char *) NULL); + } + } + } + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * DupIndexInternalRep -- + * + * Copy the internal representation of an index Tcl_Obj from one + * object to another. + * + * Results: + * None. + * + * Side effects: + * "copyPtr"s internal rep is set to same value as "srcPtr"s + * internal rep. + * + *---------------------------------------------------------------------- + */ + +static void +DupIndexInternalRep(srcPtr, copyPtr) + register Tcl_Obj *srcPtr; /* Object with internal rep to copy. */ + register Tcl_Obj *copyPtr; /* Object with internal rep to set. */ +{ + copyPtr->internalRep.twoPtrValue.ptr1 + = srcPtr->internalRep.twoPtrValue.ptr1; + copyPtr->internalRep.twoPtrValue.ptr2 + = srcPtr->internalRep.twoPtrValue.ptr2; + copyPtr->typePtr = &tclIndexType; +} + +/* + *---------------------------------------------------------------------- + * + * 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 update the string representation for + * an index object. It should never be called, because we never + * invalidate the string representation for an index object. + * + * Results: + * None. + * + * Side effects: + * A panic is added + * + *---------------------------------------------------------------------- + */ + +static void +UpdateStringOfIndex(objPtr) + register Tcl_Obj *objPtr; /* Int object whose string rep to update. */ +{ + panic("UpdateStringOfIndex should never be invoked"); +} + +/* + *---------------------------------------------------------------------- + * + * 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. + * + *---------------------------------------------------------------------- + */ + +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. */ + char *message; /* Error message to print after the + * leading objects in objv. The + * message may be NULL. */ +{ + Tcl_Obj *objPtr; + char **tablePtr; + int i; + + objPtr = Tcl_GetObjResult(interp); + 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) { + tablePtr = ((char **) objv[i]->internalRep.twoPtrValue.ptr1); + Tcl_AppendStringsToObj(objPtr, + tablePtr[(int) objv[i]->internalRep.twoPtrValue.ptr2], + (char *) NULL); + } else { + Tcl_AppendStringsToObj(objPtr, + Tcl_GetStringFromObj(objv[i], (int *) NULL), + (char *) NULL); + } + if (i < (objc - 1)) { + Tcl_AppendStringsToObj(objPtr, " ", (char *) NULL); + } + } + if (message) { + Tcl_AppendStringsToObj(objPtr, " ", message, (char *) NULL); + } + Tcl_AppendStringsToObj(objPtr, "\"", (char *) NULL); +} |