| 1 | /*
|
|---|
| 2 | * tclIndexObj.c --
|
|---|
| 3 | *
|
|---|
| 4 | * This file implements objects of type "index". This object type
|
|---|
| 5 | * is used to lookup a keyword in a table of valid values and cache
|
|---|
| 6 | * the index of the matching entry.
|
|---|
| 7 | *
|
|---|
| 8 | * Copyright (c) 1997 Sun Microsystems, Inc.
|
|---|
| 9 | *
|
|---|
| 10 | * See the file "license.terms" for information on usage and redistribution
|
|---|
| 11 | * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
|---|
| 12 | *
|
|---|
| 13 | * RCS: @(#) $Id: tclIndexObj.c,v 1.1 2008-06-04 13:58:07 demin Exp $
|
|---|
| 14 | */
|
|---|
| 15 |
|
|---|
| 16 | #include "tclInt.h"
|
|---|
| 17 |
|
|---|
| 18 | /*
|
|---|
| 19 | * Prototypes for procedures defined later in this file:
|
|---|
| 20 | */
|
|---|
| 21 |
|
|---|
| 22 | static void DupIndexInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr,
|
|---|
| 23 | Tcl_Obj *copyPtr));
|
|---|
| 24 | static int SetIndexFromAny _ANSI_ARGS_((Tcl_Interp *interp,
|
|---|
| 25 | Tcl_Obj *objPtr));
|
|---|
| 26 | static void UpdateStringOfIndex _ANSI_ARGS_((Tcl_Obj *listPtr));
|
|---|
| 27 |
|
|---|
| 28 | /*
|
|---|
| 29 | * The structure below defines the index Tcl object type by means of
|
|---|
| 30 | * procedures that can be invoked by generic object code.
|
|---|
| 31 | */
|
|---|
| 32 |
|
|---|
| 33 | Tcl_ObjType tclIndexType = {
|
|---|
| 34 | "index", /* name */
|
|---|
| 35 | (Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */
|
|---|
| 36 | DupIndexInternalRep, /* dupIntRepProc */
|
|---|
| 37 | UpdateStringOfIndex, /* updateStringProc */
|
|---|
| 38 | SetIndexFromAny /* setFromAnyProc */
|
|---|
| 39 | };
|
|---|
| 40 | |
|---|
| 41 |
|
|---|
| 42 | /*
|
|---|
| 43 | *----------------------------------------------------------------------
|
|---|
| 44 | *
|
|---|
| 45 | * Tcl_GetIndexFromObj --
|
|---|
| 46 | *
|
|---|
| 47 | * This procedure looks up an object's value in a table of strings
|
|---|
| 48 | * and returns the index of the matching string, if any.
|
|---|
| 49 | *
|
|---|
| 50 | * Results:
|
|---|
| 51 |
|
|---|
| 52 | * If the value of objPtr is identical to or a unique abbreviation
|
|---|
| 53 | * for one of the entries in objPtr, then the return value is
|
|---|
| 54 | * TCL_OK and the index of the matching entry is stored at
|
|---|
| 55 | * *indexPtr. If there isn't a proper match, then TCL_ERROR is
|
|---|
| 56 | * returned and an error message is left in interp's result (unless
|
|---|
| 57 | * interp is NULL). The msg argument is used in the error
|
|---|
| 58 | * message; for example, if msg has the value "option" then the
|
|---|
| 59 | * error message will say something flag 'bad option "foo": must be
|
|---|
| 60 | * ...'
|
|---|
| 61 | *
|
|---|
| 62 | * Side effects:
|
|---|
| 63 | * The result of the lookup is cached as the internal rep of
|
|---|
| 64 | * objPtr, so that repeated lookups can be done quickly.
|
|---|
| 65 | *
|
|---|
| 66 | *----------------------------------------------------------------------
|
|---|
| 67 | */
|
|---|
| 68 |
|
|---|
| 69 | int
|
|---|
| 70 | Tcl_GetIndexFromObj(interp, objPtr, tablePtr, msg, flags, indexPtr)
|
|---|
| 71 | Tcl_Interp *interp; /* Used for error reporting if not NULL. */
|
|---|
| 72 | Tcl_Obj *objPtr; /* Object containing the string to lookup. */
|
|---|
| 73 | char **tablePtr; /* Array of strings to compare against the
|
|---|
| 74 | * value of objPtr; last entry must be NULL
|
|---|
| 75 | * and there must not be duplicate entries. */
|
|---|
| 76 | char *msg; /* Identifying word to use in error messages. */
|
|---|
| 77 | int flags; /* 0 or TCL_EXACT */
|
|---|
| 78 | int *indexPtr; /* Place to store resulting integer index. */
|
|---|
| 79 | {
|
|---|
| 80 | int index, length, i, numAbbrev;
|
|---|
| 81 | char *key, *p1, *p2, **entryPtr;
|
|---|
| 82 | Tcl_Obj *resultPtr;
|
|---|
| 83 |
|
|---|
| 84 | /*
|
|---|
| 85 | * See if there is a valid cached result from a previous lookup.
|
|---|
| 86 | */
|
|---|
| 87 |
|
|---|
| 88 | if ((objPtr->typePtr == &tclIndexType)
|
|---|
| 89 | && (objPtr->internalRep.twoPtrValue.ptr1 == (VOID *) tablePtr)) {
|
|---|
| 90 | *indexPtr = (int) objPtr->internalRep.twoPtrValue.ptr2;
|
|---|
| 91 | return TCL_OK;
|
|---|
| 92 | }
|
|---|
| 93 |
|
|---|
| 94 | /*
|
|---|
| 95 | * Lookup the value of the object in the table. Accept unique
|
|---|
| 96 | * abbreviations unless TCL_EXACT is set in flags.
|
|---|
| 97 | */
|
|---|
| 98 |
|
|---|
| 99 | key = Tcl_GetStringFromObj(objPtr, &length);
|
|---|
| 100 | index = -1;
|
|---|
| 101 | numAbbrev = 0;
|
|---|
| 102 | for (entryPtr = tablePtr, i = 0; *entryPtr != NULL; entryPtr++, i++) {
|
|---|
| 103 | for (p1 = key, p2 = *entryPtr; *p1 == *p2; p1++, p2++) {
|
|---|
| 104 | if (*p1 == 0) {
|
|---|
| 105 | index = i;
|
|---|
| 106 | goto done;
|
|---|
| 107 | }
|
|---|
| 108 | }
|
|---|
| 109 | if (*p1 == 0) {
|
|---|
| 110 | /*
|
|---|
| 111 | * The value is an abbreviation for this entry. Continue
|
|---|
| 112 | * checking other entries to make sure it's unique. If we
|
|---|
| 113 | * get more than one unique abbreviation, keep searching to
|
|---|
| 114 | * see if there is an exact match, but remember the number
|
|---|
| 115 | * of unique abbreviations and don't allow either.
|
|---|
| 116 | */
|
|---|
| 117 |
|
|---|
| 118 | numAbbrev++;
|
|---|
| 119 | index = i;
|
|---|
| 120 | }
|
|---|
| 121 | }
|
|---|
| 122 | if ((flags & TCL_EXACT) || (numAbbrev != 1)) {
|
|---|
| 123 | goto error;
|
|---|
| 124 | }
|
|---|
| 125 |
|
|---|
| 126 | done:
|
|---|
| 127 | if ((objPtr->typePtr != NULL)
|
|---|
| 128 | && (objPtr->typePtr->freeIntRepProc != NULL)) {
|
|---|
| 129 | objPtr->typePtr->freeIntRepProc(objPtr);
|
|---|
| 130 | }
|
|---|
| 131 | objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) tablePtr;
|
|---|
| 132 | objPtr->internalRep.twoPtrValue.ptr2 = (VOID *) index;
|
|---|
| 133 | objPtr->typePtr = &tclIndexType;
|
|---|
| 134 | *indexPtr = index;
|
|---|
| 135 | return TCL_OK;
|
|---|
| 136 |
|
|---|
| 137 | error:
|
|---|
| 138 | if (interp != NULL) {
|
|---|
| 139 | resultPtr = Tcl_GetObjResult(interp);
|
|---|
| 140 | Tcl_AppendStringsToObj(resultPtr,
|
|---|
| 141 | (numAbbrev > 1) ? "ambiguous " : "bad ", msg, " \"",
|
|---|
| 142 | key, "\": must be ", *tablePtr, (char *) NULL);
|
|---|
| 143 | for (entryPtr = tablePtr+1; *entryPtr != NULL; entryPtr++) {
|
|---|
| 144 | if (entryPtr[1] == NULL) {
|
|---|
| 145 | Tcl_AppendStringsToObj(resultPtr, ", or ", *entryPtr,
|
|---|
| 146 | (char *) NULL);
|
|---|
| 147 | } else {
|
|---|
| 148 | Tcl_AppendStringsToObj(resultPtr, ", ", *entryPtr,
|
|---|
| 149 | (char *) NULL);
|
|---|
| 150 | }
|
|---|
| 151 | }
|
|---|
| 152 | }
|
|---|
| 153 | return TCL_ERROR;
|
|---|
| 154 | }
|
|---|
| 155 | |
|---|
| 156 |
|
|---|
| 157 | /*
|
|---|
| 158 | *----------------------------------------------------------------------
|
|---|
| 159 | *
|
|---|
| 160 | * DupIndexInternalRep --
|
|---|
| 161 | *
|
|---|
| 162 | * Copy the internal representation of an index Tcl_Obj from one
|
|---|
| 163 | * object to another.
|
|---|
| 164 | *
|
|---|
| 165 | * Results:
|
|---|
| 166 | * None.
|
|---|
| 167 | *
|
|---|
| 168 | * Side effects:
|
|---|
| 169 | * "copyPtr"s internal rep is set to same value as "srcPtr"s
|
|---|
| 170 | * internal rep.
|
|---|
| 171 | *
|
|---|
| 172 | *----------------------------------------------------------------------
|
|---|
| 173 | */
|
|---|
| 174 |
|
|---|
| 175 | static void
|
|---|
| 176 | DupIndexInternalRep(srcPtr, copyPtr)
|
|---|
| 177 | register Tcl_Obj *srcPtr; /* Object with internal rep to copy. */
|
|---|
| 178 | register Tcl_Obj *copyPtr; /* Object with internal rep to set. */
|
|---|
| 179 | {
|
|---|
| 180 | copyPtr->internalRep.twoPtrValue.ptr1
|
|---|
| 181 | = srcPtr->internalRep.twoPtrValue.ptr1;
|
|---|
| 182 | copyPtr->internalRep.twoPtrValue.ptr2
|
|---|
| 183 | = srcPtr->internalRep.twoPtrValue.ptr2;
|
|---|
| 184 | copyPtr->typePtr = &tclIndexType;
|
|---|
| 185 | }
|
|---|
| 186 | |
|---|
| 187 |
|
|---|
| 188 | /*
|
|---|
| 189 | *----------------------------------------------------------------------
|
|---|
| 190 | *
|
|---|
| 191 | * SetIndexFromAny --
|
|---|
| 192 | *
|
|---|
| 193 | * This procedure is called to convert a Tcl object to index
|
|---|
| 194 | * internal form. However, this doesn't make sense (need to have a
|
|---|
| 195 | * table of keywords in order to do the conversion) so the
|
|---|
| 196 | * procedure always generates an error.
|
|---|
| 197 | *
|
|---|
| 198 | * Results:
|
|---|
| 199 | * The return value is always TCL_ERROR, and an error message is
|
|---|
| 200 | * left in interp's result if interp isn't NULL.
|
|---|
| 201 | *
|
|---|
| 202 | * Side effects:
|
|---|
| 203 | * None.
|
|---|
| 204 | *
|
|---|
| 205 | *----------------------------------------------------------------------
|
|---|
| 206 | */
|
|---|
| 207 |
|
|---|
| 208 | static int
|
|---|
| 209 | SetIndexFromAny(interp, objPtr)
|
|---|
| 210 | Tcl_Interp *interp; /* Used for error reporting if not NULL. */
|
|---|
| 211 | register Tcl_Obj *objPtr; /* The object to convert. */
|
|---|
| 212 | {
|
|---|
| 213 | Tcl_AppendToObj(Tcl_GetObjResult(interp),
|
|---|
| 214 | "can't convert value to index except via Tcl_GetIndexFromObj API",
|
|---|
| 215 | -1);
|
|---|
| 216 | return TCL_ERROR;
|
|---|
| 217 | }
|
|---|
| 218 | |
|---|
| 219 |
|
|---|
| 220 | /*
|
|---|
| 221 | *----------------------------------------------------------------------
|
|---|
| 222 | *
|
|---|
| 223 | * UpdateStringOfIndex --
|
|---|
| 224 | *
|
|---|
| 225 | * This procedure is called to update the string representation for
|
|---|
| 226 | * an index object. It should never be called, because we never
|
|---|
| 227 | * invalidate the string representation for an index object.
|
|---|
| 228 | *
|
|---|
| 229 | * Results:
|
|---|
| 230 | * None.
|
|---|
| 231 | *
|
|---|
| 232 | * Side effects:
|
|---|
| 233 | * A panic is added
|
|---|
| 234 | *
|
|---|
| 235 | *----------------------------------------------------------------------
|
|---|
| 236 | */
|
|---|
| 237 |
|
|---|
| 238 | static void
|
|---|
| 239 | UpdateStringOfIndex(objPtr)
|
|---|
| 240 | register Tcl_Obj *objPtr; /* Int object whose string rep to update. */
|
|---|
| 241 | {
|
|---|
| 242 | panic("UpdateStringOfIndex should never be invoked");
|
|---|
| 243 | }
|
|---|
| 244 | |
|---|
| 245 |
|
|---|
| 246 | /*
|
|---|
| 247 | *----------------------------------------------------------------------
|
|---|
| 248 | *
|
|---|
| 249 | * Tcl_WrongNumArgs --
|
|---|
| 250 | *
|
|---|
| 251 | * This procedure generates a "wrong # args" error message in an
|
|---|
| 252 | * interpreter. It is used as a utility function by many command
|
|---|
| 253 | * procedures.
|
|---|
| 254 | *
|
|---|
| 255 | * Results:
|
|---|
| 256 | * None.
|
|---|
| 257 | *
|
|---|
| 258 | * Side effects:
|
|---|
| 259 | * An error message is generated in interp's result object to
|
|---|
| 260 | * indicate that a command was invoked with the wrong number of
|
|---|
| 261 | * arguments. The message has the form
|
|---|
| 262 | * wrong # args: should be "foo bar additional stuff"
|
|---|
| 263 | * where "foo" and "bar" are the initial objects in objv (objc
|
|---|
| 264 | * determines how many of these are printed) and "additional stuff"
|
|---|
| 265 | * is the contents of the message argument.
|
|---|
| 266 | *
|
|---|
| 267 | *----------------------------------------------------------------------
|
|---|
| 268 | */
|
|---|
| 269 |
|
|---|
| 270 | void
|
|---|
| 271 | Tcl_WrongNumArgs(interp, objc, objv, message)
|
|---|
| 272 | Tcl_Interp *interp; /* Current interpreter. */
|
|---|
| 273 | int objc; /* Number of arguments to print
|
|---|
| 274 | * from objv. */
|
|---|
| 275 | Tcl_Obj *CONST objv[]; /* Initial argument objects, which
|
|---|
| 276 | * should be included in the error
|
|---|
| 277 | * message. */
|
|---|
| 278 | char *message; /* Error message to print after the
|
|---|
| 279 | * leading objects in objv. The
|
|---|
| 280 | * message may be NULL. */
|
|---|
| 281 | {
|
|---|
| 282 | Tcl_Obj *objPtr;
|
|---|
| 283 | char **tablePtr;
|
|---|
| 284 | int i;
|
|---|
| 285 |
|
|---|
| 286 | objPtr = Tcl_GetObjResult(interp);
|
|---|
| 287 | Tcl_AppendToObj(objPtr, "wrong # args: should be \"", -1);
|
|---|
| 288 | for (i = 0; i < objc; i++) {
|
|---|
| 289 | /*
|
|---|
| 290 | * If the object is an index type use the index table which allows
|
|---|
| 291 | * for the correct error message even if the subcommand was
|
|---|
| 292 | * abbreviated. Otherwise, just use the string rep.
|
|---|
| 293 | */
|
|---|
| 294 |
|
|---|
| 295 | if (objv[i]->typePtr == &tclIndexType) {
|
|---|
| 296 | tablePtr = ((char **) objv[i]->internalRep.twoPtrValue.ptr1);
|
|---|
| 297 | Tcl_AppendStringsToObj(objPtr,
|
|---|
| 298 | tablePtr[(int) objv[i]->internalRep.twoPtrValue.ptr2],
|
|---|
| 299 | (char *) NULL);
|
|---|
| 300 | } else {
|
|---|
| 301 | Tcl_AppendStringsToObj(objPtr,
|
|---|
| 302 | Tcl_GetStringFromObj(objv[i], (int *) NULL),
|
|---|
| 303 | (char *) NULL);
|
|---|
| 304 | }
|
|---|
| 305 | if (i < (objc - 1)) {
|
|---|
| 306 | Tcl_AppendStringsToObj(objPtr, " ", (char *) NULL);
|
|---|
| 307 | }
|
|---|
| 308 | }
|
|---|
| 309 | if (message) {
|
|---|
| 310 | Tcl_AppendStringsToObj(objPtr, " ", message, (char *) NULL);
|
|---|
| 311 | }
|
|---|
| 312 | Tcl_AppendStringsToObj(objPtr, "\"", (char *) NULL);
|
|---|
| 313 | }
|
|---|
