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.16.2.5 2006/04/06 18:57:24 dgp Exp $ 14 */ 15 16#include "tclInt.h" 17#include "tclPort.h" 18 19/* 20 * Prototypes for procedures defined later in this file: 21 */ 22 23static int SetIndexFromAny _ANSI_ARGS_((Tcl_Interp *interp, 24 Tcl_Obj *objPtr)); 25static void UpdateStringOfIndex _ANSI_ARGS_((Tcl_Obj *objPtr)); 26static void DupIndex _ANSI_ARGS_((Tcl_Obj *srcPtr, 27 Tcl_Obj *dupPtr)); 28static void FreeIndex _ANSI_ARGS_((Tcl_Obj *objPtr)); 29 30/* 31 * The structure below defines the index Tcl object type by means of 32 * procedures that can be invoked by generic object code. 33 */ 34 35Tcl_ObjType tclIndexType = { 36 "index", /* name */ 37 FreeIndex, /* freeIntRepProc */ 38 DupIndex, /* dupIntRepProc */ 39 UpdateStringOfIndex, /* updateStringProc */ 40 SetIndexFromAny /* setFromAnyProc */ 41}; 42 43/* 44 * The definition of the internal representation of the "index" 45 * object; The internalRep.otherValuePtr field of an object of "index" 46 * type will be a pointer to one of these structures. 47 * 48 * Keep this structure declaration in sync with tclTestObj.c 49 */ 50 51typedef struct { 52 VOID *tablePtr; /* Pointer to the table of strings */ 53 int offset; /* Offset between table entries */ 54 int index; /* Selected index into table. */ 55} IndexRep; 56 57/* 58 * The following macros greatly simplify moving through a table... 59 */ 60#define STRING_AT(table, offset, index) \ 61 (*((CONST char * CONST *)(((char *)(table)) + ((offset) * (index))))) 62#define NEXT_ENTRY(table, offset) \ 63 (&(STRING_AT(table, offset, 1))) 64#define EXPAND_OF(indexRep) \ 65 STRING_AT((indexRep)->tablePtr, (indexRep)->offset, (indexRep)->index) 66 67 68/* 69 *---------------------------------------------------------------------- 70 * 71 * Tcl_GetIndexFromObj -- 72 * 73 * This procedure looks up an object's value in a table of strings 74 * and returns the index of the matching string, if any. 75 * 76 * Results: 77 * 78 * If the value of objPtr is identical to or a unique abbreviation 79 * for one of the entries in objPtr, then the return value is 80 * TCL_OK and the index of the matching entry is stored at 81 * *indexPtr. If there isn't a proper match, then TCL_ERROR is 82 * returned and an error message is left in interp's result (unless 83 * interp is NULL). The msg argument is used in the error 84 * message; for example, if msg has the value "option" then the 85 * error message will say something flag 'bad option "foo": must be 86 * ...' 87 * 88 * Side effects: 89 * The result of the lookup is cached as the internal rep of 90 * objPtr, so that repeated lookups can be done quickly. 91 * 92 *---------------------------------------------------------------------- 93 */ 94 95int 96Tcl_GetIndexFromObj(interp, objPtr, tablePtr, msg, flags, indexPtr) 97 Tcl_Interp *interp; /* Used for error reporting if not NULL. */ 98 Tcl_Obj *objPtr; /* Object containing the string to lookup. */ 99 CONST char **tablePtr; /* Array of strings to compare against the 100 * value of objPtr; last entry must be NULL 101 * and there must not be duplicate entries. */ 102 CONST char *msg; /* Identifying word to use in error messages. */ 103 int flags; /* 0 or TCL_EXACT */ 104 int *indexPtr; /* Place to store resulting integer index. */ 105{ 106 107 /* 108 * See if there is a valid cached result from a previous lookup 109 * (doing the check here saves the overhead of calling 110 * Tcl_GetIndexFromObjStruct in the common case where the result 111 * is cached). 112 */ 113 114 if (objPtr->typePtr == &tclIndexType) { 115 IndexRep *indexRep = (IndexRep *) objPtr->internalRep.otherValuePtr; 116 /* 117 * Here's hoping we don't get hit by unfortunate packing 118 * constraints on odd platforms like a Cray PVP... 119 */ 120 if (indexRep->tablePtr == (VOID *)tablePtr && 121 indexRep->offset == sizeof(char *)) { 122 *indexPtr = indexRep->index; 123 return TCL_OK; 124 } 125 } 126 return Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, sizeof(char *), 127 msg, flags, indexPtr); 128} 129 130/* 131 *---------------------------------------------------------------------- 132 * 133 * Tcl_GetIndexFromObjStruct -- 134 * 135 * This procedure looks up an object's value given a starting 136 * string and an offset for the amount of space between strings. 137 * This is useful when the strings are embedded in some other 138 * kind of array. 139 * 140 * Results: 141 * 142 * If the value of objPtr is identical to or a unique abbreviation 143 * for one of the entries in objPtr, then the return value is 144 * TCL_OK and the index of the matching entry is stored at 145 * *indexPtr. If there isn't a proper match, then TCL_ERROR is 146 * returned and an error message is left in interp's result (unless 147 * interp is NULL). The msg argument is used in the error 148 * message; for example, if msg has the value "option" then the 149 * error message will say something flag 'bad option "foo": must be 150 * ...' 151 * 152 * Side effects: 153 * The result of the lookup is cached as the internal rep of 154 * objPtr, so that repeated lookups can be done quickly. 155 * 156 *---------------------------------------------------------------------- 157 */ 158 159int 160Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, 161 indexPtr) 162 Tcl_Interp *interp; /* Used for error reporting if not NULL. */ 163 Tcl_Obj *objPtr; /* Object containing the string to lookup. */ 164 CONST VOID *tablePtr; /* The first string in the table. The second 165 * string will be at this address plus the 166 * offset, the third plus the offset again, 167 * etc. The last entry must be NULL 168 * and there must not be duplicate entries. */ 169 int offset; /* The number of bytes between entries */ 170 CONST char *msg; /* Identifying word to use in error messages. */ 171 int flags; /* 0 or TCL_EXACT */ 172 int *indexPtr; /* Place to store resulting integer index. */ 173{ 174 int index, i, numAbbrev; 175 char *key, *p1; 176 CONST char *p2; 177 CONST char * CONST *entryPtr; 178 Tcl_Obj *resultPtr; 179 IndexRep *indexRep; 180 181 /* 182 * See if there is a valid cached result from a previous lookup. 183 */ 184 185 if (objPtr->typePtr == &tclIndexType) { 186 indexRep = (IndexRep *) objPtr->internalRep.otherValuePtr; 187 if (indexRep->tablePtr==tablePtr && indexRep->offset==offset) { 188 *indexPtr = indexRep->index; 189 return TCL_OK; 190 } 191 } 192 193 /* 194 * Lookup the value of the object in the table. Accept unique 195 * abbreviations unless TCL_EXACT is set in flags. 196 */ 197 198 key = TclGetString(objPtr); 199 index = -1; 200 numAbbrev = 0; 201 202 /* 203 * Scan the table looking for one of: 204 * - An exact match (always preferred) 205 * - A single abbreviation (allowed depending on flags) 206 * - Several abbreviations (never allowed, but overridden by exact match) 207 */ 208 for (entryPtr = tablePtr, i = 0; *entryPtr != NULL; 209 entryPtr = NEXT_ENTRY(entryPtr, offset), i++) { 210 for (p1 = key, p2 = *entryPtr; *p1 == *p2; p1++, p2++) { 211 if (*p1 == '\0') { 212 index = i; 213 goto done; 214 } 215 } 216 if (*p1 == '\0') { 217 /* 218 * The value is an abbreviation for this entry. Continue 219 * checking other entries to make sure it's unique. If we 220 * get more than one unique abbreviation, keep searching to 221 * see if there is an exact match, but remember the number 222 * of unique abbreviations and don't allow either. 223 */ 224 225 numAbbrev++; 226 index = i; 227 } 228 } 229 /* 230 * Check if we were instructed to disallow abbreviations. 231 */ 232 if ((flags & TCL_EXACT) || (key[0] == '\0') || (numAbbrev != 1)) { 233 goto error; 234 } 235 236 done: 237 /* 238 * Cache the found representation. Note that we want to avoid 239 * allocating a new internal-rep if at all possible since that is 240 * potentially a slow operation. 241 */ 242 if (objPtr->typePtr == &tclIndexType) { 243 indexRep = (IndexRep *) objPtr->internalRep.otherValuePtr; 244 } else { 245 if ((objPtr->typePtr != NULL) 246 && (objPtr->typePtr->freeIntRepProc != NULL)) { 247 objPtr->typePtr->freeIntRepProc(objPtr); 248 } 249 indexRep = (IndexRep *) ckalloc(sizeof(IndexRep)); 250 objPtr->internalRep.otherValuePtr = (VOID *) indexRep; 251 objPtr->typePtr = &tclIndexType; 252 } 253 indexRep->tablePtr = (VOID*) tablePtr; 254 indexRep->offset = offset; 255 indexRep->index = index; 256 257 *indexPtr = index; 258 return TCL_OK; 259 260 error: 261 if (interp != NULL) { 262 /* 263 * Produce a fancy error message. 264 */ 265 int count; 266 267 TclNewObj(resultPtr); 268 Tcl_SetObjResult(interp, resultPtr); 269 Tcl_AppendStringsToObj(resultPtr, (numAbbrev > 1) && 270 !(flags & TCL_EXACT) ? "ambiguous " : "bad ", msg, " \"", 271 key, "\": must be ", STRING_AT(tablePtr,offset,0), (char*)NULL); 272 for (entryPtr = NEXT_ENTRY(tablePtr, offset), count = 0; 273 *entryPtr != NULL; 274 entryPtr = NEXT_ENTRY(entryPtr, offset), count++) { 275 if (*NEXT_ENTRY(entryPtr, offset) == NULL) { 276 Tcl_AppendStringsToObj(resultPtr, 277 (count > 0) ? ", or " : " or ", *entryPtr, 278 (char *) NULL); 279 } else { 280 Tcl_AppendStringsToObj(resultPtr, ", ", *entryPtr, 281 (char *) NULL); 282 } 283 } 284 } 285 return TCL_ERROR; 286} 287 288/* 289 *---------------------------------------------------------------------- 290 * 291 * SetIndexFromAny -- 292 * 293 * This procedure is called to convert a Tcl object to index 294 * internal form. However, this doesn't make sense (need to have a 295 * table of keywords in order to do the conversion) so the 296 * procedure always generates an error. 297 * 298 * Results: 299 * The return value is always TCL_ERROR, and an error message is 300 * left in interp's result if interp isn't NULL. 301 * 302 * Side effects: 303 * None. 304 * 305 *---------------------------------------------------------------------- 306 */ 307 308static int 309SetIndexFromAny(interp, objPtr) 310 Tcl_Interp *interp; /* Used for error reporting if not NULL. */ 311 register Tcl_Obj *objPtr; /* The object to convert. */ 312{ 313 Tcl_AppendToObj(Tcl_GetObjResult(interp), 314 "can't convert value to index except via Tcl_GetIndexFromObj API", 315 -1); 316 return TCL_ERROR; 317} 318 319/* 320 *---------------------------------------------------------------------- 321 * 322 * UpdateStringOfIndex -- 323 * 324 * This procedure is called to convert a Tcl object from index 325 * internal form to its string form. No abbreviation is ever 326 * generated. 327 * 328 * Results: 329 * None. 330 * 331 * Side effects: 332 * The string representation of the object is updated. 333 * 334 *---------------------------------------------------------------------- 335 */ 336 337static void 338UpdateStringOfIndex(objPtr) 339 Tcl_Obj *objPtr; 340{ 341 IndexRep *indexRep = (IndexRep *) objPtr->internalRep.otherValuePtr; 342 register char *buf; 343 register unsigned len; 344 register CONST char *indexStr = EXPAND_OF(indexRep); 345 346 len = strlen(indexStr); 347 buf = (char *) ckalloc(len + 1); 348 memcpy(buf, indexStr, len+1); 349 objPtr->bytes = buf; 350 objPtr->length = len; 351} 352 353/* 354 *---------------------------------------------------------------------- 355 * 356 * DupIndex -- 357 * 358 * This procedure is called to copy the internal rep of an index 359 * Tcl object from to another object. 360 * 361 * Results: 362 * None. 363 * 364 * Side effects: 365 * The internal representation of the target object is updated 366 * and the type is set. 367 * 368 *---------------------------------------------------------------------- 369 */ 370 371static void 372DupIndex(srcPtr, dupPtr) 373 Tcl_Obj *srcPtr, *dupPtr; 374{ 375 IndexRep *srcIndexRep = (IndexRep *) srcPtr->internalRep.otherValuePtr; 376 IndexRep *dupIndexRep = (IndexRep *) ckalloc(sizeof(IndexRep)); 377 378 memcpy(dupIndexRep, srcIndexRep, sizeof(IndexRep)); 379 dupPtr->internalRep.otherValuePtr = (VOID *) dupIndexRep; 380 dupPtr->typePtr = &tclIndexType; 381} 382 383/* 384 *---------------------------------------------------------------------- 385 * 386 * FreeIndex -- 387 * 388 * This procedure is called to delete the internal rep of an index 389 * Tcl object. 390 * 391 * Results: 392 * None. 393 * 394 * Side effects: 395 * The internal representation of the target object is deleted. 396 * 397 *---------------------------------------------------------------------- 398 */ 399 400static void 401FreeIndex(objPtr) 402 Tcl_Obj *objPtr; 403{ 404 ckfree((char *) objPtr->internalRep.otherValuePtr); 405} 406 407/* 408 *---------------------------------------------------------------------- 409 * 410 * Tcl_WrongNumArgs -- 411 * 412 * This procedure generates a "wrong # args" error message in an 413 * interpreter. It is used as a utility function by many command 414 * procedures. 415 * 416 * Results: 417 * None. 418 * 419 * Side effects: 420 * An error message is generated in interp's result object to 421 * indicate that a command was invoked with the wrong number of 422 * arguments. The message has the form 423 * wrong # args: should be "foo bar additional stuff" 424 * where "foo" and "bar" are the initial objects in objv (objc 425 * determines how many of these are printed) and "additional stuff" 426 * is the contents of the message argument. 427 * 428 *---------------------------------------------------------------------- 429 */ 430 431void 432Tcl_WrongNumArgs(interp, objc, objv, message) 433 Tcl_Interp *interp; /* Current interpreter. */ 434 int objc; /* Number of arguments to print 435 * from objv. */ 436 Tcl_Obj *CONST objv[]; /* Initial argument objects, which 437 * should be included in the error 438 * message. */ 439 CONST char *message; /* Error message to print after the 440 * leading objects in objv. The 441 * message may be NULL. */ 442{ 443 Tcl_Obj *objPtr; 444 int i; 445 register IndexRep *indexRep; 446 447 TclNewObj(objPtr); 448 Tcl_SetObjResult(interp, objPtr); 449 Tcl_AppendToObj(objPtr, "wrong # args: should be \"", -1); 450 for (i = 0; i < objc; i++) { 451 /* 452 * If the object is an index type use the index table which allows 453 * for the correct error message even if the subcommand was 454 * abbreviated. Otherwise, just use the string rep. 455 */ 456 457 if (objv[i]->typePtr == &tclIndexType) { 458 indexRep = (IndexRep *) objv[i]->internalRep.otherValuePtr; 459 Tcl_AppendStringsToObj(objPtr, EXPAND_OF(indexRep), (char *) NULL); 460 } else { 461 Tcl_AppendStringsToObj(objPtr, Tcl_GetString(objv[i]), 462 (char *) NULL); 463 } 464 465 /* 466 * Append a space character (" ") if there is more text to follow 467 * (either another element from objv, or the message string). 468 */ 469 if ((i < (objc - 1)) || message) { 470 Tcl_AppendStringsToObj(objPtr, " ", (char *) NULL); 471 } 472 } 473 474 if (message) { 475 Tcl_AppendStringsToObj(objPtr, message, (char *) NULL); 476 } 477 Tcl_AppendStringsToObj(objPtr, "\"", (char *) NULL); 478} 479