1/* 2 * tclIndexObj.c -- 3 * 4 * This file implements objects of type "index". This object type is used 5 * to lookup a keyword in a table of valid values and cache the index of 6 * the matching entry. 7 * 8 * Copyright (c) 1997 Sun Microsystems, Inc. 9 * 10 * See the file "license.terms" for information on usage and redistribution of 11 * this file, and for a DISCLAIMER OF ALL WARRANTIES. 12 * 13 * RCS: @(#) $Id: tclIndexObj.c,v 1.38 2007/12/13 15:23:18 dgp Exp $ 14 */ 15 16#include "tclInt.h" 17 18/* 19 * Prototypes for functions defined later in this file: 20 */ 21 22static int SetIndexFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); 23static void UpdateStringOfIndex(Tcl_Obj *objPtr); 24static void DupIndex(Tcl_Obj *srcPtr, Tcl_Obj *dupPtr); 25static void FreeIndex(Tcl_Obj *objPtr); 26 27/* 28 * The structure below defines the index Tcl object type by means of functions 29 * that can be invoked by generic object code. 30 */ 31 32static Tcl_ObjType indexType = { 33 "index", /* name */ 34 FreeIndex, /* freeIntRepProc */ 35 DupIndex, /* dupIntRepProc */ 36 UpdateStringOfIndex, /* updateStringProc */ 37 SetIndexFromAny /* setFromAnyProc */ 38}; 39 40/* 41 * The definition of the internal representation of the "index" object; The 42 * internalRep.otherValuePtr field of an object of "index" type will be a 43 * pointer to one of these structures. 44 * 45 * Keep this structure declaration in sync with tclTestObj.c 46 */ 47 48typedef struct { 49 void *tablePtr; /* Pointer to the table of strings */ 50 int offset; /* Offset between table entries */ 51 int index; /* Selected index into table. */ 52} IndexRep; 53 54/* 55 * The following macros greatly simplify moving through a table... 56 */ 57 58#define STRING_AT(table, offset, index) \ 59 (*((const char *const *)(((char *)(table)) + ((offset) * (index))))) 60#define NEXT_ENTRY(table, offset) \ 61 (&(STRING_AT(table, offset, 1))) 62#define EXPAND_OF(indexRep) \ 63 STRING_AT((indexRep)->tablePtr, (indexRep)->offset, (indexRep)->index) 64 65/* 66 *---------------------------------------------------------------------- 67 * 68 * Tcl_GetIndexFromObj -- 69 * 70 * This function looks up an object's value in a table of strings and 71 * returns the index of the matching string, if any. 72 * 73 * Results: 74 * If the value of objPtr is identical to or a unique abbreviation for 75 * one of the entries in objPtr, then the return value is TCL_OK and the 76 * index of the matching entry is stored at *indexPtr. If there isn't a 77 * proper match, then TCL_ERROR is returned and an error message is left 78 * in interp's result (unless interp is NULL). The msg argument is used 79 * in the error message; for example, if msg has the value "option" then 80 * the error message will say something flag 'bad option "foo": must be 81 * ...' 82 * 83 * Side effects: 84 * The result of the lookup is cached as the internal rep of objPtr, so 85 * that repeated lookups can be done quickly. 86 * 87 *---------------------------------------------------------------------- 88 */ 89 90int 91Tcl_GetIndexFromObj( 92 Tcl_Interp *interp, /* Used for error reporting if not NULL. */ 93 Tcl_Obj *objPtr, /* Object containing the string to lookup. */ 94 const char **tablePtr, /* Array of strings to compare against the 95 * value of objPtr; last entry must be NULL 96 * and there must not be duplicate entries. */ 97 const char *msg, /* Identifying word to use in error 98 * messages. */ 99 int flags, /* 0 or TCL_EXACT */ 100 int *indexPtr) /* Place to store resulting integer index. */ 101{ 102 103 /* 104 * See if there is a valid cached result from a previous lookup (doing the 105 * check here saves the overhead of calling Tcl_GetIndexFromObjStruct in 106 * the common case where the result is cached). 107 */ 108 109 if (objPtr->typePtr == &indexType) { 110 IndexRep *indexRep = objPtr->internalRep.otherValuePtr; 111 112 /* 113 * Here's hoping we don't get hit by unfortunate packing constraints 114 * on odd platforms like a Cray PVP... 115 */ 116 117 if (indexRep->tablePtr == (void *) tablePtr 118 && indexRep->offset == sizeof(char *)) { 119 *indexPtr = indexRep->index; 120 return TCL_OK; 121 } 122 } 123 return Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, sizeof(char *), 124 msg, flags, indexPtr); 125} 126 127/* 128 *---------------------------------------------------------------------- 129 * 130 * Tcl_GetIndexFromObjStruct -- 131 * 132 * This function looks up an object's value given a starting string and 133 * an offset for the amount of space between strings. This is useful when 134 * the strings are embedded in some other kind of array. 135 * 136 * Results: 137 * If the value of objPtr is identical to or a unique abbreviation for 138 * one of the entries in objPtr, then the return value is TCL_OK and the 139 * index of the matching entry is stored at *indexPtr. If there isn't a 140 * proper match, then TCL_ERROR is returned and an error message is left 141 * in interp's result (unless interp is NULL). The msg argument is used 142 * in the error message; for example, if msg has the value "option" then 143 * the error message will say something flag 'bad option "foo": must be 144 * ...' 145 * 146 * Side effects: 147 * The result of the lookup is cached as the internal rep of objPtr, so 148 * that repeated lookups can be done quickly. 149 * 150 *---------------------------------------------------------------------- 151 */ 152 153int 154Tcl_GetIndexFromObjStruct( 155 Tcl_Interp *interp, /* Used for error reporting if not NULL. */ 156 Tcl_Obj *objPtr, /* Object containing the string to lookup. */ 157 const void *tablePtr, /* The first string in the table. The second 158 * string will be at this address plus the 159 * offset, the third plus the offset again, 160 * etc. The last entry must be NULL and there 161 * must not be duplicate entries. */ 162 int offset, /* The number of bytes between entries */ 163 const char *msg, /* Identifying word to use in error 164 * messages. */ 165 int flags, /* 0 or TCL_EXACT */ 166 int *indexPtr) /* Place to store resulting integer index. */ 167{ 168 int index, idx, numAbbrev; 169 char *key, *p1; 170 const char *p2; 171 const char *const *entryPtr; 172 Tcl_Obj *resultPtr; 173 IndexRep *indexRep; 174 175 /* 176 * See if there is a valid cached result from a previous lookup. 177 */ 178 179 if (objPtr->typePtr == &indexType) { 180 indexRep = objPtr->internalRep.otherValuePtr; 181 if (indexRep->tablePtr==tablePtr && indexRep->offset==offset) { 182 *indexPtr = indexRep->index; 183 return TCL_OK; 184 } 185 } 186 187 /* 188 * Lookup the value of the object in the table. Accept unique 189 * abbreviations unless TCL_EXACT is set in flags. 190 */ 191 192 key = TclGetString(objPtr); 193 index = -1; 194 numAbbrev = 0; 195 196 /* 197 * Scan the table looking for one of: 198 * - An exact match (always preferred) 199 * - A single abbreviation (allowed depending on flags) 200 * - Several abbreviations (never allowed, but overridden by exact match) 201 */ 202 203 for (entryPtr = tablePtr, idx = 0; *entryPtr != NULL; 204 entryPtr = NEXT_ENTRY(entryPtr, offset), idx++) { 205 for (p1 = key, p2 = *entryPtr; *p1 == *p2; p1++, p2++) { 206 if (*p1 == '\0') { 207 index = idx; 208 goto done; 209 } 210 } 211 if (*p1 == '\0') { 212 /* 213 * The value is an abbreviation for this entry. Continue checking 214 * other entries to make sure it's unique. If we get more than one 215 * unique abbreviation, keep searching to see if there is an exact 216 * match, but remember the number of unique abbreviations and 217 * don't allow either. 218 */ 219 220 numAbbrev++; 221 index = idx; 222 } 223 } 224 225 /* 226 * Check if we were instructed to disallow abbreviations. 227 */ 228 229 if ((flags & TCL_EXACT) || (key[0] == '\0') || (numAbbrev != 1)) { 230 goto error; 231 } 232 233 done: 234 /* 235 * Cache the found representation. Note that we want to avoid allocating a 236 * new internal-rep if at all possible since that is potentially a slow 237 * operation. 238 */ 239 240 if (objPtr->typePtr == &indexType) { 241 indexRep = objPtr->internalRep.otherValuePtr; 242 } else { 243 TclFreeIntRep(objPtr); 244 indexRep = (IndexRep *) ckalloc(sizeof(IndexRep)); 245 objPtr->internalRep.otherValuePtr = indexRep; 246 objPtr->typePtr = &indexType; 247 } 248 indexRep->tablePtr = (void *) tablePtr; 249 indexRep->offset = offset; 250 indexRep->index = index; 251 252 *indexPtr = index; 253 return TCL_OK; 254 255 error: 256 if (interp != NULL) { 257 /* 258 * Produce a fancy error message. 259 */ 260 261 int count; 262 263 TclNewObj(resultPtr); 264 Tcl_SetObjResult(interp, resultPtr); 265 Tcl_AppendStringsToObj(resultPtr, (numAbbrev > 1) && 266 !(flags & TCL_EXACT) ? "ambiguous " : "bad ", msg, " \"", key, 267 "\": must be ", STRING_AT(tablePtr, offset, 0), NULL); 268 for (entryPtr = NEXT_ENTRY(tablePtr, offset), count = 0; 269 *entryPtr != NULL; 270 entryPtr = NEXT_ENTRY(entryPtr, offset), count++) { 271 if (*NEXT_ENTRY(entryPtr, offset) == NULL) { 272 Tcl_AppendStringsToObj(resultPtr, ((count > 0) ? "," : ""), 273 " or ", *entryPtr, NULL); 274 } else { 275 Tcl_AppendStringsToObj(resultPtr, ", ", *entryPtr, NULL); 276 } 277 } 278 Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", msg, key, NULL); 279 } 280 return TCL_ERROR; 281} 282 283/* 284 *---------------------------------------------------------------------- 285 * 286 * SetIndexFromAny -- 287 * 288 * This function is called to convert a Tcl object to index internal 289 * form. However, this doesn't make sense (need to have a table of 290 * keywords in order to do the conversion) so the function always 291 * generates an error. 292 * 293 * Results: 294 * The return value is always TCL_ERROR, and an error message is left in 295 * interp's result if interp isn't NULL. 296 * 297 * Side effects: 298 * None. 299 * 300 *---------------------------------------------------------------------- 301 */ 302 303static int 304SetIndexFromAny( 305 Tcl_Interp *interp, /* Used for error reporting if not NULL. */ 306 register Tcl_Obj *objPtr) /* The object to convert. */ 307{ 308 Tcl_SetObjResult(interp, Tcl_NewStringObj( 309 "can't convert value to index except via Tcl_GetIndexFromObj API", 310 -1)); 311 return TCL_ERROR; 312} 313 314/* 315 *---------------------------------------------------------------------- 316 * 317 * UpdateStringOfIndex -- 318 * 319 * This function is called to convert a Tcl object from index internal 320 * form to its string form. No abbreviation is ever generated. 321 * 322 * Results: 323 * None. 324 * 325 * Side effects: 326 * The string representation of the object is updated. 327 * 328 *---------------------------------------------------------------------- 329 */ 330 331static void 332UpdateStringOfIndex( 333 Tcl_Obj *objPtr) 334{ 335 IndexRep *indexRep = objPtr->internalRep.otherValuePtr; 336 register char *buf; 337 register unsigned len; 338 register const char *indexStr = EXPAND_OF(indexRep); 339 340 len = strlen(indexStr); 341 buf = (char *) ckalloc(len + 1); 342 memcpy(buf, indexStr, len+1); 343 objPtr->bytes = buf; 344 objPtr->length = len; 345} 346 347/* 348 *---------------------------------------------------------------------- 349 * 350 * DupIndex -- 351 * 352 * This function is called to copy the internal rep of an index Tcl 353 * object from to another object. 354 * 355 * Results: 356 * None. 357 * 358 * Side effects: 359 * The internal representation of the target object is updated and the 360 * type is set. 361 * 362 *---------------------------------------------------------------------- 363 */ 364 365static void 366DupIndex( 367 Tcl_Obj *srcPtr, 368 Tcl_Obj *dupPtr) 369{ 370 IndexRep *srcIndexRep = srcPtr->internalRep.otherValuePtr; 371 IndexRep *dupIndexRep = (IndexRep *) ckalloc(sizeof(IndexRep)); 372 373 memcpy(dupIndexRep, srcIndexRep, sizeof(IndexRep)); 374 dupPtr->internalRep.otherValuePtr = dupIndexRep; 375 dupPtr->typePtr = &indexType; 376} 377 378/* 379 *---------------------------------------------------------------------- 380 * 381 * FreeIndex -- 382 * 383 * This function is called to delete the internal rep of an index Tcl 384 * object. 385 * 386 * Results: 387 * None. 388 * 389 * Side effects: 390 * The internal representation of the target object is deleted. 391 * 392 *---------------------------------------------------------------------- 393 */ 394 395static void 396FreeIndex( 397 Tcl_Obj *objPtr) 398{ 399 ckfree((char *) objPtr->internalRep.otherValuePtr); 400} 401 402/* 403 *---------------------------------------------------------------------- 404 * 405 * Tcl_WrongNumArgs -- 406 * 407 * This function generates a "wrong # args" error message in an 408 * interpreter. It is used as a utility function by many command 409 * functions, including the function that implements procedures. 410 * 411 * Results: 412 * None. 413 * 414 * Side effects: 415 * An error message is generated in interp's result object to indicate 416 * that a command was invoked with the wrong number of arguments. The 417 * message has the form 418 * wrong # args: should be "foo bar additional stuff" 419 * where "foo" and "bar" are the initial objects in objv (objc determines 420 * how many of these are printed) and "additional stuff" is the contents 421 * of the message argument. 422 * 423 * The message printed is modified somewhat if the command is wrapped 424 * inside an ensemble. In that case, the error message generated is 425 * rewritten in such a way that it appears to be generated from the 426 * user-visible command and not how that command is actually implemented, 427 * giving a better overall user experience. 428 * 429 * Internally, the Tcl core may set the flag INTERP_ALTERNATE_WRONG_ARGS 430 * in the interpreter to generate complex multi-part messages by calling 431 * this function repeatedly. This allows the code that knows how to 432 * handle ensemble-related error messages to be kept here while still 433 * generating suitable error messages for commands like [read] and 434 * [socket]. Ideally, this would be done through an extra flags argument, 435 * but that wouldn't be source-compatible with the existing API and it's 436 * a fairly rare requirement anyway. 437 * 438 *---------------------------------------------------------------------- 439 */ 440 441void 442Tcl_WrongNumArgs( 443 Tcl_Interp *interp, /* Current interpreter. */ 444 int objc, /* Number of arguments to print from objv. */ 445 Tcl_Obj *const objv[], /* Initial argument objects, which should be 446 * included in the error message. */ 447 const char *message) /* Error message to print after the leading 448 * objects in objv. The message may be 449 * NULL. */ 450{ 451 Tcl_Obj *objPtr; 452 int i, len, elemLen, flags; 453 Interp *iPtr = (Interp *) interp; 454 const char *elementStr; 455 456 /* 457 * [incr Tcl] does something fairly horrific when generating error 458 * messages for its ensembles; it passes the whole set of ensemble 459 * arguments as a list in the first argument. This means that this code 460 * causes a problem in iTcl if it attempts to correctly quote all 461 * arguments, which would be the correct thing to do. We work around this 462 * nasty behaviour for now, and hope that we can remove it all in the 463 * future... 464 */ 465 466#ifndef AVOID_HACKS_FOR_ITCL 467 int isFirst = 1; /* Special flag used to inhibit the treating 468 * of the first word as a list element so the 469 * hacky way Itcl generates error messages for 470 * its ensembles will still work. [Bug 471 * 1066837] */ 472# define MAY_QUOTE_WORD (!isFirst) 473# define AFTER_FIRST_WORD (isFirst = 0) 474#else /* !AVOID_HACKS_FOR_ITCL */ 475# define MAY_QUOTE_WORD 1 476# define AFTER_FIRST_WORD (void) 0 477#endif /* AVOID_HACKS_FOR_ITCL */ 478 479 TclNewObj(objPtr); 480 if (iPtr->flags & INTERP_ALTERNATE_WRONG_ARGS) { 481 Tcl_AppendObjToObj(objPtr, Tcl_GetObjResult(interp)); 482 Tcl_AppendToObj(objPtr, " or \"", -1); 483 } else { 484 Tcl_AppendToObj(objPtr, "wrong # args: should be \"", -1); 485 } 486 487 /* 488 * Check to see if we are processing an ensemble implementation, and if so 489 * rewrite the results in terms of how the ensemble was invoked. 490 */ 491 492 if (iPtr->ensembleRewrite.sourceObjs != NULL) { 493 int toSkip = iPtr->ensembleRewrite.numInsertedObjs; 494 int toPrint = iPtr->ensembleRewrite.numRemovedObjs; 495 Tcl_Obj *const *origObjv = iPtr->ensembleRewrite.sourceObjs; 496 497 /* 498 * We only know how to do rewriting if all the replaced objects are 499 * actually arguments (in objv) to this function. Otherwise it just 500 * gets too complicated and we'd be better off just giving a slightly 501 * confusing error message... 502 */ 503 504 if (objc < toSkip) { 505 goto addNormalArgumentsToMessage; 506 } 507 508 /* 509 * Strip out the actual arguments that the ensemble inserted. 510 */ 511 512 objv += toSkip; 513 objc -= toSkip; 514 515 /* 516 * We assume no object is of index type. 517 */ 518 519 for (i=0 ; i<toPrint ; i++) { 520 /* 521 * Add the element, quoting it if necessary. 522 */ 523 524 if (origObjv[i]->typePtr == &indexType) { 525 register IndexRep *indexRep = 526 origObjv[i]->internalRep.otherValuePtr; 527 528 elementStr = EXPAND_OF(indexRep); 529 elemLen = strlen(elementStr); 530 } else if (origObjv[i]->typePtr == &tclEnsembleCmdType) { 531 register EnsembleCmdRep *ecrPtr = 532 origObjv[i]->internalRep.otherValuePtr; 533 534 elementStr = ecrPtr->fullSubcmdName; 535 elemLen = strlen(elementStr); 536 } else { 537 elementStr = TclGetStringFromObj(origObjv[i], &elemLen); 538 } 539 len = Tcl_ScanCountedElement(elementStr, elemLen, &flags); 540 541 if (MAY_QUOTE_WORD && len != elemLen) { 542 char *quotedElementStr = TclStackAlloc(interp, (unsigned)len); 543 544 len = Tcl_ConvertCountedElement(elementStr, elemLen, 545 quotedElementStr, flags); 546 Tcl_AppendToObj(objPtr, quotedElementStr, len); 547 TclStackFree(interp, quotedElementStr); 548 } else { 549 Tcl_AppendToObj(objPtr, elementStr, elemLen); 550 } 551 552 AFTER_FIRST_WORD; 553 554 /* 555 * Add a space if the word is not the last one (which has a 556 * moderately complex condition here). 557 */ 558 559 if (i<toPrint-1 || objc!=0 || message!=NULL) { 560 Tcl_AppendStringsToObj(objPtr, " ", NULL); 561 } 562 } 563 } 564 565 /* 566 * Now add the arguments (other than those rewritten) that the caller took 567 * from its calling context. 568 */ 569 570 addNormalArgumentsToMessage: 571 for (i = 0; i < objc; i++) { 572 /* 573 * If the object is an index type use the index table which allows for 574 * the correct error message even if the subcommand was abbreviated. 575 * Otherwise, just use the string rep. 576 */ 577 578 if (objv[i]->typePtr == &indexType) { 579 register IndexRep *indexRep = objv[i]->internalRep.otherValuePtr; 580 581 Tcl_AppendStringsToObj(objPtr, EXPAND_OF(indexRep), NULL); 582 } else if (objv[i]->typePtr == &tclEnsembleCmdType) { 583 register EnsembleCmdRep *ecrPtr = 584 objv[i]->internalRep.otherValuePtr; 585 586 Tcl_AppendStringsToObj(objPtr, ecrPtr->fullSubcmdName, NULL); 587 } else { 588 /* 589 * Quote the argument if it contains spaces (Bug 942757). 590 */ 591 592 elementStr = TclGetStringFromObj(objv[i], &elemLen); 593 len = Tcl_ScanCountedElement(elementStr, elemLen, &flags); 594 595 if (MAY_QUOTE_WORD && len != elemLen) { 596 char *quotedElementStr = TclStackAlloc(interp,(unsigned) len); 597 598 len = Tcl_ConvertCountedElement(elementStr, elemLen, 599 quotedElementStr, flags); 600 Tcl_AppendToObj(objPtr, quotedElementStr, len); 601 TclStackFree(interp, quotedElementStr); 602 } else { 603 Tcl_AppendToObj(objPtr, elementStr, elemLen); 604 } 605 } 606 607 AFTER_FIRST_WORD; 608 609 /* 610 * Append a space character (" ") if there is more text to follow 611 * (either another element from objv, or the message string). 612 */ 613 614 if (i<objc-1 || message!=NULL) { 615 Tcl_AppendStringsToObj(objPtr, " ", NULL); 616 } 617 } 618 619 /* 620 * Add any trailing message bits and set the resulting string as the 621 * interpreter result. Caller is responsible for reporting this as an 622 * actual error. 623 */ 624 625 if (message != NULL) { 626 Tcl_AppendStringsToObj(objPtr, message, NULL); 627 } 628 Tcl_AppendStringsToObj(objPtr, "\"", NULL); 629 Tcl_SetObjResult(interp, objPtr); 630#undef MAY_QUOTE_WORD 631#undef AFTER_FIRST_WORD 632} 633 634/* 635 * Local Variables: 636 * mode: c 637 * c-basic-offset: 4 638 * fill-column: 78 639 * End: 640 */ 641