diff options
Diffstat (limited to 'generic/tclIndexObj.c')
| -rw-r--r-- | generic/tclIndexObj.c | 371 |
1 files changed, 210 insertions, 161 deletions
diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index 77b1965..3733241 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -1,22 +1,22 @@ -/* +/* * 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. + * 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. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIndexObj.c,v 1.24 2005/06/07 21:46:08 dgp Exp $ + * RCS: @(#) $Id: tclIndexObj.c,v 1.25 2005/07/21 14:38:49 dkf Exp $ */ #include "tclInt.h" /* - * Prototypes for procedures defined later in this file: + * Prototypes for functions defined later in this file: */ static int SetIndexFromAny _ANSI_ARGS_((Tcl_Interp *interp, @@ -27,8 +27,8 @@ static void DupIndex _ANSI_ARGS_((Tcl_Obj *srcPtr, static void FreeIndex _ANSI_ARGS_((Tcl_Obj *objPtr)); /* - * The structure below defines the index Tcl object type by means of - * procedures that can be invoked by generic object code. + * The structure below defines the index Tcl object type by means of functions + * that can be invoked by generic object code. */ static Tcl_ObjType indexType = { @@ -40,9 +40,9 @@ static Tcl_ObjType indexType = { }; /* - * The definition of the internal representation of the "index" - * object; The internalRep.otherValuePtr field of an object of "index" - * type will be a pointer to one of these structures. + * The definition of the internal representation of the "index" object; The + * internalRep.otherValuePtr field of an object of "index" type will be a + * pointer to one of these structures. * * Keep this structure declaration in sync with tclTestObj.c */ @@ -62,31 +62,28 @@ typedef struct { (&(STRING_AT(table, offset, 1))) #define EXPAND_OF(indexRep) \ STRING_AT((indexRep)->tablePtr, (indexRep)->offset, (indexRep)->index) - /* *---------------------------------------------------------------------- * * 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. + * This function 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 + * 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. + * The result of the lookup is cached as the internal rep of objPtr, so + * that repeated lookups can be done quickly. * *---------------------------------------------------------------------- */ @@ -98,24 +95,26 @@ Tcl_GetIndexFromObj(interp, objPtr, tablePtr, msg, flags, indexPtr) CONST char **tablePtr; /* Array of strings to compare against the * value of objPtr; last entry must be NULL * and there must not be duplicate entries. */ - CONST char *msg; /* Identifying word to use in error messages. */ + CONST char *msg; /* Identifying word to use in error + * messages. */ int flags; /* 0 or TCL_EXACT */ int *indexPtr; /* Place to store resulting integer index. */ { /* - * See if there is a valid cached result from a previous lookup - * (doing the check here saves the overhead of calling - * Tcl_GetIndexFromObjStruct in the common case where the result - * is cached). + * See if there is a valid cached result from a previous lookup (doing the + * check here saves the overhead of calling Tcl_GetIndexFromObjStruct in + * the common case where the result is cached). */ if (objPtr->typePtr == &indexType) { IndexRep *indexRep = (IndexRep *) objPtr->internalRep.otherValuePtr; + /* - * Here's hoping we don't get hit by unfortunate packing - * constraints on odd platforms like a Cray PVP... + * Here's hoping we don't get hit by unfortunate packing constraints + * on odd platforms like a Cray PVP... */ + if (indexRep->tablePtr == (VOID *)tablePtr && indexRep->offset == sizeof(char *)) { *indexPtr = indexRep->index; @@ -131,42 +130,40 @@ Tcl_GetIndexFromObj(interp, objPtr, tablePtr, msg, flags, indexPtr) * * Tcl_GetIndexFromObjStruct -- * - * This procedure looks up an object's value given a starting - * string and an offset for the amount of space between strings. - * This is useful when the strings are embedded in some other - * kind of array. + * This function looks up an object's value given a starting string and + * an offset for the amount of space between strings. This is useful when + * the strings are embedded in some other kind of array. * * 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 + * 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. + * The result of the lookup is cached as the internal rep of objPtr, so + * that repeated lookups can be done quickly. * *---------------------------------------------------------------------- */ int -Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, +Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr) Tcl_Interp *interp; /* Used for error reporting if not NULL. */ Tcl_Obj *objPtr; /* Object containing the string to lookup. */ CONST VOID *tablePtr; /* The first string in the table. The second * string will be at this address plus the * offset, the third plus the offset again, - * etc. The last entry must be NULL - * and there must not be duplicate entries. */ + * etc. The last entry must be NULL and there + * must not be duplicate entries. */ int offset; /* The number of bytes between entries */ - CONST char *msg; /* Identifying word to use in error messages. */ + CONST char *msg; /* Identifying word to use in error + * messages. */ int flags; /* 0 or TCL_EXACT */ int *indexPtr; /* Place to store resulting integer index. */ { @@ -201,18 +198,19 @@ Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, /* * The key should not be empty, otherwise it's not a match. */ - + if (key[0] == '\0') { goto error; } - + /* * Scan the table looking for one of: * - An exact match (always preferred) * - A single abbreviation (allowed depending on flags) * - Several abbreviations (never allowed, but overridden by exact match) */ - for (entryPtr = tablePtr, i = 0; *entryPtr != NULL; + + for (entryPtr = tablePtr, i = 0; *entryPtr != NULL; entryPtr = NEXT_ENTRY(entryPtr, offset), i++) { for (p1 = key, p2 = *entryPtr; *p1 == *p2; p1++, p2++) { if (*p1 == '\0') { @@ -222,30 +220,33 @@ Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, } 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. + * 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; } } + /* * Check if we were instructed to disallow abbreviations. */ + if ((flags & TCL_EXACT) || (numAbbrev != 1)) { goto error; } - done: + done: /* - * Cache the found representation. Note that we want to avoid - * allocating a new internal-rep if at all possible since that is - * potentially a slow operation. + * Cache the found representation. Note that we want to avoid allocating a + * new internal-rep if at all possible since that is potentially a slow + * operation. */ + if (objPtr->typePtr == &indexType) { indexRep = (IndexRep *) objPtr->internalRep.otherValuePtr; } else { @@ -261,18 +262,19 @@ Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, *indexPtr = index; return TCL_OK; - error: + error: if (interp != NULL) { /* * Produce a fancy error message. */ + int count; TclNewObj(resultPtr); Tcl_SetObjResult(interp, resultPtr); Tcl_AppendStringsToObj(resultPtr, - (numAbbrev > 1) ? "ambiguous " : "bad ", msg, " \"", - key, "\": must be ", STRING_AT(tablePtr,offset,0), (char*)NULL); + (numAbbrev > 1) ? "ambiguous " : "bad ", msg, " \"", key, + "\": must be ", STRING_AT(tablePtr,offset,0), (char*) NULL); for (entryPtr = NEXT_ENTRY(tablePtr, offset), count = 0; *entryPtr != NULL; entryPtr = NEXT_ENTRY(entryPtr, offset), count++) { @@ -294,14 +296,14 @@ Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, * * 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. + * This function 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 function 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. + * 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. @@ -325,9 +327,8 @@ SetIndexFromAny(interp, objPtr) * * UpdateStringOfIndex -- * - * This procedure is called to convert a Tcl object from index - * internal form to its string form. No abbreviation is ever - * generated. + * This function is called to convert a Tcl object from index internal + * form to its string form. No abbreviation is ever generated. * * Results: * None. @@ -359,15 +360,15 @@ UpdateStringOfIndex(objPtr) * * DupIndex -- * - * This procedure is called to copy the internal rep of an index - * Tcl object from to another object. + * This function is called to copy the internal rep of an index Tcl + * object from to another object. * * Results: * None. * * Side effects: - * The internal representation of the target object is updated - * and the type is set. + * The internal representation of the target object is updated and the + * type is set. * *---------------------------------------------------------------------- */ @@ -389,8 +390,8 @@ DupIndex(srcPtr, dupPtr) * * FreeIndex -- * - * This procedure is called to delete the internal rep of an index - * Tcl object. + * This function is called to delete the internal rep of an index Tcl + * object. * * Results: * None. @@ -413,52 +414,77 @@ FreeIndex(objPtr) * * Tcl_WrongNumArgs -- * - * This procedure generates a "wrong # args" error message in an - * interpreter. It is used as a utility function by many command - * procedures. + * This function generates a "wrong # args" error message in an + * interpreter. It is used as a utility function by many command + * functions, including the function that implements 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 + * 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. + * 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. + * + * The message printed is modified somewhat if the command is wrapped + * inside an ensemble. In that case, the error message generated is + * rewritten in such a way that it appears to be generated from the + * user-visible command and not how that command is actually implemented, + * giving a better overall user experience. + * + * Internally, the Tcl core may set the flag INTERP_ALTERNATE_WRONG_ARGS + * in the interpreter to generate complex multi-part messages by calling + * this function repeatedly. This allows the code that knows how to + * handle ensemble-related error messages to be kept here while still + * generating suitable error messages for commands like [read] and + * [socket]. Ideally, this would be done through an extra flags argument, + * but that wouldn't be source-compatible with the existing API and it's + * a fairly rare requirement anyway. * *---------------------------------------------------------------------- */ 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. */ - CONST char *message; /* Error message to print after the - * leading objects in objv. The - * message may be NULL. */ + 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. */ + CONST char *message; /* Error message to print after the leading + * objects in objv. The message may be + * NULL. */ { Tcl_Obj *objPtr; int i, len, elemLen, flags; register IndexRep *indexRep; Interp *iPtr = (Interp *) interp; char *elementStr; + + /* + * [incr Tcl] does something fairly horrific when generating error + * messages for its ensembles; it passes the whole set of ensemble + * arguments as a list in the first argument. This means that this code + * causes a problem in iTcl if it attempts to correctly quote all + * arguments, which would be the correct thing to do. We work around this + * nasty behaviour for now, and hope that we can remove it all in the + * future... + */ + #ifndef AVOID_HACKS_FOR_ITCL - int isFirst = 1; /* Special flag used to inhibit the - * treating of the first word as a - * list element so the hacky way Itcl - * does error message generation for - * ensembles will still work. - * [Bug 1066837] */ -#define MAY_QUOTE_WORD (!isFirst) + int isFirst = 1; /* Special flag used to inhibit the treating + * of the first word as a list element so the + * hacky way Itcl generates error messages for + * its ensembles will still work. [Bug + * 1066837] */ +# define MAY_QUOTE_WORD (!isFirst) +# define AFTER_FIRST_WORD (isFirst = 0) #else /* !AVOID_HACKS_FOR_ITCL */ -#define MAY_QUOTE_WORD 1 +# define MAY_QUOTE_WORD 1 +# define AFTER_FIRST_WORD (void) 0 #endif /* AVOID_HACKS_FOR_ITCL */ TclNewObj(objPtr); @@ -470,70 +496,82 @@ Tcl_WrongNumArgs(interp, objc, objv, message) } /* - * Check to see if we are processing an ensemble implementation, - * and if so rewrite the results in terms of how the ensemble was - * invoked. + * Check to see if we are processing an ensemble implementation, and if so + * rewrite the results in terms of how the ensemble was invoked. */ if (iPtr->ensembleRewrite.sourceObjs != NULL) { + int toSkip = iPtr->ensembleRewrite.numInsertedObjs; + int toPrint = iPtr->ensembleRewrite.numRemovedObjs; + Tcl_Obj *origObjv = iPtr->ensembleRewrite.sourceObjs; + + /* + * We only know how to do rewriting if all the replaced objects are + * actually arguments (in objv) to this function. Otherwise it just + * gets too complicated and we'd be better off just giving a slightly + * confusing error message... + */ + + if (objc < toSkip) { + goto addNormalArgumentsToMessage; + } + + /* + * Strip out the actual arguments that the ensemble inserted. + */ + + objv += toSkip; + objc -= toSkip; + /* - * We only know how to do rewriting if all the replaced - * objects are actually arguments (in objv) to this function. - * Otherwise it just gets too complicated... + * We assume no object is of index type. */ - if (objc >= iPtr->ensembleRewrite.numInsertedObjs) { - objv += iPtr->ensembleRewrite.numInsertedObjs; - objc -= iPtr->ensembleRewrite.numInsertedObjs; + for (i=0 ; i<toPrint ; i++) { /* - * We assume no object is of index type. + * Add the element, quoting it if necessary. */ - for (i=0 ; i<iPtr->ensembleRewrite.numRemovedObjs ; i++) { - /* - * Add the element, quoting it if necessary. - */ - - elementStr = Tcl_GetStringFromObj( - iPtr->ensembleRewrite.sourceObjs[i], &elemLen); - len = Tcl_ScanCountedElement(elementStr, elemLen, &flags); - if (MAY_QUOTE_WORD && len != elemLen) { - char *quotedElementStr = ckalloc((unsigned) len); - len = Tcl_ConvertCountedElement(elementStr, elemLen, - quotedElementStr, flags); - Tcl_AppendToObj(objPtr, quotedElementStr, len); - ckfree(quotedElementStr); - } else { - Tcl_AppendToObj(objPtr, elementStr, elemLen); - } -#ifndef AVOID_HACKS_FOR_ITCL - isFirst = 0; -#endif /* AVOID_HACKS_FOR_ITCL */ - /* - * Add a space if the word is not the last one (which - * has a moderately complex condition here). - */ + elementStr = Tcl_GetStringFromObj(origObjv[i], &elemLen); + len = Tcl_ScanCountedElement(elementStr, elemLen, &flags); + + if (MAY_QUOTE_WORD && len != elemLen) { + char *quotedElementStr = ckalloc((unsigned) len); + + len = Tcl_ConvertCountedElement(elementStr, elemLen, + quotedElementStr, flags); + Tcl_AppendToObj(objPtr, quotedElementStr, len); + ckfree(quotedElementStr); + } else { + Tcl_AppendToObj(objPtr, elementStr, elemLen); + } + + AFTER_FIRST_WORD; + + /* + * Add a space if the word is not the last one (which has a + * moderately complex condition here). + */ - if ((i < (iPtr->ensembleRewrite.numRemovedObjs - 1)) - || objc || message) { - Tcl_AppendStringsToObj(objPtr, " ", (char *) NULL); - } + if (i<toPrint-1 || objc!=0 || message!=NULL) { + Tcl_AppendStringsToObj(objPtr, " ", (char *) NULL); } } } /* - * Now add the arguments (other than those rewritten) that the - * caller took from its calling context. + * Now add the arguments (other than those rewritten) that the caller took + * from its calling context. */ + addNormalArgumentsToMessage: 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 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 == &indexType) { indexRep = (IndexRep *) objv[i]->internalRep.otherValuePtr; Tcl_AppendStringsToObj(objPtr, EXPAND_OF(indexRep), (char *) NULL); @@ -544,8 +582,10 @@ Tcl_WrongNumArgs(interp, objc, objv, message) elementStr = Tcl_GetStringFromObj(objv[i], &elemLen); len = Tcl_ScanCountedElement(elementStr, elemLen, &flags); + if (MAY_QUOTE_WORD && len != elemLen) { char *quotedElementStr = ckalloc((unsigned) len); + len = Tcl_ConvertCountedElement(elementStr, elemLen, quotedElementStr, flags); Tcl_AppendToObj(objPtr, quotedElementStr, len); @@ -554,29 +594,38 @@ Tcl_WrongNumArgs(interp, objc, objv, message) Tcl_AppendToObj(objPtr, elementStr, elemLen); } } -#ifndef AVOID_HACKS_FOR_ITCL - isFirst = 0; -#endif /* AVOID_HACKS_FOR_ITCL */ + + AFTER_FIRST_WORD; /* * Append a space character (" ") if there is more text to follow * (either another element from objv, or the message string). */ - if ((i < (objc - 1)) || message) { + + if (i<objc-1 || message!=NULL) { Tcl_AppendStringsToObj(objPtr, " ", (char *) NULL); } } /* - * Add any trailing message bits and set the resulting string as - * the interpreter result. Caller is responsible for reporting - * this as an actual error. + * Add any trailing message bits and set the resulting string as the + * interpreter result. Caller is responsible for reporting this as an + * actual error. */ - if (message) { + if (message != NULL) { Tcl_AppendStringsToObj(objPtr, message, (char *) NULL); } Tcl_AppendStringsToObj(objPtr, "\"", (char *) NULL); Tcl_SetObjResult(interp, objPtr); #undef MAY_QUOTE_WORD +#undef AFTER_FIRST_WORD } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ |