[25] | 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 | |
---|
| 22 | static int SetIndexFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); |
---|
| 23 | static void UpdateStringOfIndex(Tcl_Obj *objPtr); |
---|
| 24 | static void DupIndex(Tcl_Obj *srcPtr, Tcl_Obj *dupPtr); |
---|
| 25 | static 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 | |
---|
| 32 | static 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 | |
---|
| 48 | typedef 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 | |
---|
| 90 | int |
---|
| 91 | Tcl_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 | |
---|
| 153 | int |
---|
| 154 | Tcl_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 | |
---|
| 303 | static int |
---|
| 304 | SetIndexFromAny( |
---|
| 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 | |
---|
| 331 | static void |
---|
| 332 | UpdateStringOfIndex( |
---|
| 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 | |
---|
| 365 | static void |
---|
| 366 | DupIndex( |
---|
| 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 | |
---|
| 395 | static void |
---|
| 396 | FreeIndex( |
---|
| 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 | |
---|
| 441 | void |
---|
| 442 | Tcl_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 | */ |
---|