diff options
Diffstat (limited to 'generic/tclIndexObj.c')
| -rw-r--r-- | generic/tclIndexObj.c | 1133 |
1 files changed, 154 insertions, 979 deletions
diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index d999cc9..73ba515 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -3,11 +3,9 @@ * * 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. Also provides table-based argv/argc processing. + * the matching entry. * - * Copyright © 1990-1994 The Regents of the University of California. - * Copyright © 1997 Sun Microsystems, Inc. - * Copyright © 2006 Sam Bromley. + * 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. @@ -19,29 +17,22 @@ * Prototypes for functions defined later in this file: */ -static int GetIndexFromObjList(Tcl_Interp *interp, - Tcl_Obj *objPtr, Tcl_Obj *tableObjPtr, - const char *msg, int flags, Tcl_Size *indexPtr); +static int SetIndexFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static void UpdateStringOfIndex(Tcl_Obj *objPtr); static void DupIndex(Tcl_Obj *srcPtr, Tcl_Obj *dupPtr); static void FreeIndex(Tcl_Obj *objPtr); -static Tcl_ObjCmdProc PrefixAllObjCmd; -static Tcl_ObjCmdProc PrefixLongestObjCmd; -static Tcl_ObjCmdProc PrefixMatchObjCmd; -static void PrintUsage(Tcl_Interp *interp, - const Tcl_ArgvInfo *argTable); /* * The structure below defines the index Tcl object type by means of functions * that can be invoked by generic object code. */ -const Tcl_ObjType tclIndexType = { - "index", /* name */ - FreeIndex, /* freeIntRepProc */ - DupIndex, /* dupIntRepProc */ - UpdateStringOfIndex, /* updateStringProc */ - NULL /* setFromAnyProc */ +static Tcl_ObjType indexType = { + "index", /* name */ + FreeIndex, /* freeIntRepProc */ + DupIndex, /* dupIntRepProc */ + UpdateStringOfIndex, /* updateStringProc */ + SetIndexFromAny /* setFromAnyProc */ }; /* @@ -53,9 +44,9 @@ const Tcl_ObjType tclIndexType = { */ typedef struct { - void *tablePtr; /* Pointer to the table of strings */ - Tcl_Size offset; /* Offset between table entries */ - Tcl_Size index; /* Selected index into table. */ + void *tablePtr; /* Pointer to the table of strings */ + int offset; /* Offset between table entries */ + int index; /* Selected index into table. */ } IndexRep; /* @@ -67,7 +58,7 @@ typedef struct { #define NEXT_ENTRY(table, offset) \ (&(STRING_AT(table, offset))) #define EXPAND_OF(indexRep) \ - (((indexRep)->index >= 0) ? STRING_AT((indexRep)->tablePtr, (indexRep)->offset*(indexRep)->index) : "") + STRING_AT((indexRep)->tablePtr, (indexRep)->offset*(indexRep)->index) /* *---------------------------------------------------------------------- @@ -79,7 +70,7 @@ typedef struct { * * Results: * If the value of objPtr is identical to or a unique abbreviation for - * one of the entries in tablePtr, then the return value is TCL_OK and the + * 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 @@ -94,13 +85,12 @@ typedef struct { *---------------------------------------------------------------------- */ -#ifndef TCL_NO_DEPRECATED #undef Tcl_GetIndexFromObj int Tcl_GetIndexFromObj( - Tcl_Interp *interp, /* Used for error reporting if not NULL. */ + Tcl_Interp *interp, /* Used for error reporting if not NULL. */ Tcl_Obj *objPtr, /* Object containing the string to lookup. */ - const char *const *tablePtr, /* Array of strings to compare against the + 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 @@ -108,7 +98,6 @@ Tcl_GetIndexFromObj( int flags, /* 0 or TCL_EXACT */ int *indexPtr) /* Place to store resulting integer index. */ { - if (!(flags & TCL_INDEX_TEMP_TABLE)) { /* * See if there is a valid cached result from a previous lookup (doing the @@ -116,107 +105,23 @@ Tcl_GetIndexFromObj( * the common case where the result is cached). */ - const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objPtr, &tclIndexType); - - if (irPtr) { - IndexRep *indexRep = (IndexRep *)irPtr->twoPtrValue.ptr1; + if (objPtr->typePtr == &indexType) { + IndexRep *indexRep = objPtr->internalRep.twoPtrValue.ptr1; /* * Here's hoping we don't get hit by unfortunate packing constraints * on odd platforms like a Cray PVP... */ - if (indexRep->tablePtr == (void *)tablePtr + if (indexRep->tablePtr == (void *) tablePtr && indexRep->offset == sizeof(char *)) { *indexPtr = indexRep->index; return TCL_OK; } } - } return Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, sizeof(char *), msg, flags, indexPtr); } -#endif /* TCL_NO_DEPRECATED */ - -/* - *---------------------------------------------------------------------- - * - * GetIndexFromObjList -- - * - * This procedure 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 tableObjPtr, 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: - * Removes any internal representation that the object might have. (TODO: - * find a way to cache the lookup.) - * - *---------------------------------------------------------------------- - */ - -int -GetIndexFromObjList( - Tcl_Interp *interp, /* Used for error reporting if not NULL. */ - Tcl_Obj *objPtr, /* Object containing the string to lookup. */ - Tcl_Obj *tableObjPtr, /* List of strings to compare against the - * value of objPtr. */ - const char *msg, /* Identifying word to use in error - * messages. */ - int flags, /* 0 or TCL_EXACT */ - Tcl_Size *indexPtr) /* Place to store resulting index. */ -{ - - Tcl_Size objc, t; - int result; - Tcl_Obj **objv; - const char **tablePtr; - - /* - * Use Tcl_GetIndexFromObjStruct to do the work to avoid duplicating most - * of the code there. This is a bit inefficient but simpler. - */ - - result = TclListObjGetElements(interp, tableObjPtr, &objc, &objv); - if (result != TCL_OK) { - return result; - } - - /* - * Build a string table from the list. - */ - - tablePtr = (const char **)ckalloc((objc + 1) * sizeof(char *)); - for (t = 0; t < objc; t++) { - if (objv[t] == objPtr) { - /* - * An exact match is always chosen, so we can stop here. - */ - - ckfree(tablePtr); - *indexPtr = t; - return TCL_OK; - } - - tablePtr[t] = TclGetString(objv[t]); - } - tablePtr[objc] = NULL; - - result = Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, - sizeof(char *), msg, flags | TCL_INDEX_TEMP_TABLE, indexPtr); - - ckfree(tablePtr); - - return result; -} /* *---------------------------------------------------------------------- @@ -229,14 +134,13 @@ GetIndexFromObjList( * * Results: * If the value of objPtr is identical to or a unique abbreviation for - * one of the entries in tablePtr, then the return value is TCL_OK and - * the index of the matching entry is stored at *indexPtr - * (unless indexPtr is NULL). 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 like 'bad option "foo": must - * be ...' + * 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 like 'bad option "foo": must be + * ...' * * Side effects: * The result of the lookup is cached as the internal rep of objPtr, so @@ -245,63 +149,53 @@ GetIndexFromObjList( *---------------------------------------------------------------------- */ -#undef Tcl_GetIndexFromObjStruct int Tcl_GetIndexFromObjStruct( - Tcl_Interp *interp, /* Used for error reporting if not NULL. */ + 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. */ - Tcl_Size offset, /* The number of bytes between entries */ + int offset, /* The number of bytes between entries */ const char *msg, /* Identifying word to use in error * messages. */ - int flags, /* 0, TCL_EXACT, TCL_NULL_OK or TCL_INDEX_TEMP_TABLE */ - void *indexPtr) /* Place to store resulting index. */ + int flags, /* 0 or TCL_EXACT */ + int *indexPtr) /* Place to store resulting integer index. */ { - Tcl_Size index, idx, numAbbrev; - const char *key, *p1; + int index, idx, numAbbrev; + char *key, *p1; const char *p2; const char *const *entryPtr; Tcl_Obj *resultPtr; IndexRep *indexRep; - const Tcl_ObjInternalRep *irPtr; /* Protect against invalid values, like -1 or 0. */ - if (offset < (Tcl_Size)sizeof(char *)) { - offset = (Tcl_Size)sizeof(char *); + if (offset < (int)sizeof(char *)) { + offset = (int)sizeof(char *); } /* * See if there is a valid cached result from a previous lookup. */ - if (objPtr && !(flags & TCL_INDEX_TEMP_TABLE)) { - irPtr = TclFetchInternalRep(objPtr, &tclIndexType); - if (irPtr) { - indexRep = (IndexRep *)irPtr->twoPtrValue.ptr1; - if ((indexRep->tablePtr == tablePtr) - && (indexRep->offset == offset) - && (indexRep->index >= 0)) { - index = indexRep->index; - goto uncachedDone; + if (objPtr->typePtr == &indexType) { + indexRep = objPtr->internalRep.twoPtrValue.ptr1; + if (indexRep->tablePtr==tablePtr && indexRep->offset==offset) { + *indexPtr = indexRep->index; + return TCL_OK; } } - } /* * Lookup the value of the object in the table. Accept unique * abbreviations unless TCL_EXACT is set in flags. */ - key = objPtr ? TclGetString(objPtr) : ""; - index = TCL_INDEX_NONE; + key = TclGetString(objPtr); + index = -1; numAbbrev = 0; - if (!*key && (flags & TCL_NULL_OK)) { - goto uncachedDone; - } /* * Scan the table looking for one of: * - An exact match (always preferred) @@ -309,7 +203,7 @@ Tcl_GetIndexFromObjStruct( * - Several abbreviations (never allowed, but overridden by exact match) */ - for (entryPtr = (const char *const *)tablePtr, idx = 0; *entryPtr != NULL; + for (entryPtr = tablePtr, idx = 0; *entryPtr != NULL; entryPtr = NEXT_ENTRY(entryPtr, offset), idx++) { for (p1 = key, p2 = *entryPtr; *p1 == *p2; p1++, p2++) { if (*p1 == '\0') { @@ -346,42 +240,19 @@ Tcl_GetIndexFromObjStruct( * operation. */ - if (objPtr && (index >= 0) && !(flags & TCL_INDEX_TEMP_TABLE)) { - irPtr = TclFetchInternalRep(objPtr, &tclIndexType); - if (irPtr) { - indexRep = (IndexRep *)irPtr->twoPtrValue.ptr1; + if (objPtr->typePtr == &indexType) { + indexRep = objPtr->internalRep.twoPtrValue.ptr1; } else { - Tcl_ObjInternalRep ir; - - indexRep = (IndexRep*)ckalloc(sizeof(IndexRep)); - ir.twoPtrValue.ptr1 = indexRep; - Tcl_StoreInternalRep(objPtr, &tclIndexType, &ir); + TclFreeIntRep(objPtr); + indexRep = (IndexRep *) ckalloc(sizeof(IndexRep)); + objPtr->internalRep.twoPtrValue.ptr1 = indexRep; + objPtr->typePtr = &indexType; } indexRep->tablePtr = (void *) tablePtr; indexRep->offset = offset; indexRep->index = index; - } - uncachedDone: - if (indexPtr != NULL) { - flags &= (30-(int)(sizeof(int)<<1)); - if (flags) { - if (flags == sizeof(uint16_t)<<1) { - *(uint16_t *)indexPtr = index; - return TCL_OK; - } else if (flags == (int)(sizeof(uint8_t)<<1)) { - *(uint8_t *)indexPtr = index; - return TCL_OK; - } else if (flags == (int)(sizeof(int64_t)<<1)) { - *(int64_t *)indexPtr = index; - return TCL_OK; - } else if (flags == (int)(sizeof(int32_t)<<1)) { - *(int32_t *)indexPtr = index; - return TCL_OK; - } - } - *(int *)indexPtr = index; - } + *indexPtr = index; return TCL_OK; error: @@ -393,41 +264,62 @@ Tcl_GetIndexFromObjStruct( int count = 0; TclNewObj(resultPtr); - entryPtr = (const char *const *)tablePtr; + Tcl_SetObjResult(interp, resultPtr); + entryPtr = tablePtr; while ((*entryPtr != NULL) && !**entryPtr) { entryPtr = NEXT_ENTRY(entryPtr, offset); } - Tcl_AppendStringsToObj(resultPtr, - (numAbbrev>1 && !(flags & TCL_EXACT) ? "ambiguous " : "bad "), - msg, " \"", key, (char *)NULL); - if (*entryPtr == NULL) { - Tcl_AppendStringsToObj(resultPtr, "\": no valid options", (char *)NULL); - } else { - Tcl_AppendStringsToObj(resultPtr, "\": must be ", - *entryPtr, (char *)NULL); - entryPtr = NEXT_ENTRY(entryPtr, offset); - while (*entryPtr != NULL) { - if ((*NEXT_ENTRY(entryPtr, offset) == NULL) && !(flags & TCL_NULL_OK)) { - Tcl_AppendStringsToObj(resultPtr, (count > 0 ? "," : ""), - " or ", *entryPtr, (char *)NULL); - } else if (**entryPtr) { - Tcl_AppendStringsToObj(resultPtr, ", ", *entryPtr, (char *)NULL); - count++; - } - entryPtr = NEXT_ENTRY(entryPtr, offset); - } - if ((flags & TCL_NULL_OK)) { - Tcl_AppendStringsToObj(resultPtr, ", or \"\"", (char *)NULL); + Tcl_AppendStringsToObj(resultPtr, (numAbbrev > 1) && + !(flags & TCL_EXACT) ? "ambiguous " : "bad ", msg, " \"", key, + "\": must be ", *entryPtr, NULL); + entryPtr = NEXT_ENTRY(entryPtr, offset); + while (*entryPtr != NULL) { + if (*NEXT_ENTRY(entryPtr, offset) == NULL) { + Tcl_AppendStringsToObj(resultPtr, ((count > 0) ? "," : ""), + " or ", *entryPtr, NULL); + } else if (**entryPtr) { + Tcl_AppendStringsToObj(resultPtr, ", ", *entryPtr, NULL); + count++; } + entryPtr = NEXT_ENTRY(entryPtr, offset); } - Tcl_SetObjResult(interp, resultPtr); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", msg, key, (char *)NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", msg, key, NULL); + } + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * SetIndexFromAny -- + * + * 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. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +SetIndexFromAny( + Tcl_Interp *interp, /* Used for error reporting if not NULL. */ + register Tcl_Obj *objPtr) /* The object to convert. */ +{ + if (interp) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "can't convert value to index except via Tcl_GetIndexFromObj API", + -1)); } return TCL_ERROR; } -/* #define again, needed below */ -#define Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr) \ - ((Tcl_GetIndexFromObjStruct)((interp), (objPtr), (tablePtr), (offset), (msg), (flags)|(int)(sizeof(*(indexPtr))<<1), (indexPtr))) /* *---------------------------------------------------------------------- @@ -450,10 +342,16 @@ static void UpdateStringOfIndex( Tcl_Obj *objPtr) { - IndexRep *indexRep = (IndexRep *)TclFetchInternalRep(objPtr, &tclIndexType)->twoPtrValue.ptr1; - const char *indexStr = EXPAND_OF(indexRep); - - Tcl_InitStringRep(objPtr, indexStr, strlen(indexStr)); + IndexRep *indexRep = objPtr->internalRep.twoPtrValue.ptr1; + register char *buf; + register unsigned len; + register const char *indexStr = EXPAND_OF(indexRep); + + len = strlen(indexStr); + buf = (char *) ckalloc(len + 1); + memcpy(buf, indexStr, len+1); + objPtr->bytes = buf; + objPtr->length = len; } /* @@ -479,14 +377,12 @@ DupIndex( Tcl_Obj *srcPtr, Tcl_Obj *dupPtr) { - Tcl_ObjInternalRep ir; - IndexRep *dupIndexRep = (IndexRep *)ckalloc(sizeof(IndexRep)); - - memcpy(dupIndexRep, TclFetchInternalRep(srcPtr, &tclIndexType)->twoPtrValue.ptr1, - sizeof(IndexRep)); + IndexRep *srcIndexRep = srcPtr->internalRep.twoPtrValue.ptr1; + IndexRep *dupIndexRep = (IndexRep *) ckalloc(sizeof(IndexRep)); - ir.twoPtrValue.ptr1 = dupIndexRep; - Tcl_StoreInternalRep(dupPtr, &tclIndexType, &ir); + memcpy(dupIndexRep, srcIndexRep, sizeof(IndexRep)); + dupPtr->internalRep.twoPtrValue.ptr1 = dupIndexRep; + dupPtr->typePtr = &indexType; } /* @@ -510,327 +406,13 @@ static void FreeIndex( Tcl_Obj *objPtr) { - ckfree(TclFetchInternalRep(objPtr, &tclIndexType)->twoPtrValue.ptr1); + ckfree((char *) objPtr->internalRep.twoPtrValue.ptr1); objPtr->typePtr = NULL; } /* *---------------------------------------------------------------------- * - * TclInitPrefixCmd -- - * - * This procedure creates the "prefix" Tcl command. See the user - * documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - -Tcl_Command -TclInitPrefixCmd( - Tcl_Interp *interp) /* Current interpreter. */ -{ - static const EnsembleImplMap prefixImplMap[] = { - {"all", PrefixAllObjCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, - {"longest", PrefixLongestObjCmd,TclCompileBasic2ArgCmd, NULL, NULL, 0}, - {"match", PrefixMatchObjCmd, TclCompileBasicMin2ArgCmd, NULL, NULL, 0}, - {NULL, NULL, NULL, NULL, NULL, 0} - }; - Tcl_Command prefixCmd; - - prefixCmd = TclMakeEnsemble(interp, "::tcl::prefix", prefixImplMap); - Tcl_Export(interp, Tcl_FindNamespace(interp, "::tcl", NULL, 0), - "prefix", 0); - return prefixCmd; -} - -/*---------------------------------------------------------------------- - * - * PrefixMatchObjCmd -- - * - * This function implements the 'prefix match' Tcl command. Refer to the - * user documentation for details on what it does. - * - * Results: - * Returns a standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -PrefixMatchObjCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - int flags = 0, result, index; - Tcl_Size errorLength, i; - Tcl_Obj *errorPtr = NULL; - const char *message = "option"; - Tcl_Obj *tablePtr, *objPtr, *resultPtr; - static const char *const matchOptions[] = { - "-error", "-exact", "-message", NULL - }; - enum matchOptionsEnum { - PRFMATCH_ERROR, PRFMATCH_EXACT, PRFMATCH_MESSAGE - }; - - if (objc < 3) { - Tcl_WrongNumArgs(interp, 1, objv, "?options? table string"); - return TCL_ERROR; - } - - for (i = 1; i < (objc - 2); i++) { - if (Tcl_GetIndexFromObjStruct(interp, objv[i], matchOptions, - sizeof(char *), "option", 0, &index) != TCL_OK) { - return TCL_ERROR; - } - switch ((enum matchOptionsEnum) index) { - case PRFMATCH_EXACT: - flags |= TCL_EXACT; - break; - case PRFMATCH_MESSAGE: - if (i > objc-4) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "missing value for -message", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NOARG", (char *)NULL); - return TCL_ERROR; - } - i++; - message = TclGetString(objv[i]); - break; - case PRFMATCH_ERROR: - if (i > objc-4) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "missing value for -error", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NOARG", (char *)NULL); - return TCL_ERROR; - } - i++; - result = TclListObjLength(interp, objv[i], &errorLength); - if (result != TCL_OK) { - return TCL_ERROR; - } - if ((errorLength % 2) != 0) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "error options must have an even number of elements", - -1)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "DICTIONARY", (char *)NULL); - return TCL_ERROR; - } - errorPtr = objv[i]; - break; - } - } - - tablePtr = objv[objc - 2]; - objPtr = objv[objc - 1]; - - /* - * Check that table is a valid list first, since we want to handle that - * error case regardless of level. - */ - - result = TclListObjLength(interp, tablePtr, &i); - if (result != TCL_OK) { - return result; - } - - result = GetIndexFromObjList(interp, objPtr, tablePtr, message, flags, - &i); - if (result != TCL_OK) { - if (errorPtr != NULL && errorLength == 0) { - Tcl_ResetResult(interp); - return TCL_OK; - } else if (errorPtr == NULL) { - return TCL_ERROR; - } - - if (Tcl_IsShared(errorPtr)) { - errorPtr = Tcl_DuplicateObj(errorPtr); - } - Tcl_ListObjAppendElement(interp, errorPtr, - Tcl_NewStringObj("-code", 5)); - Tcl_ListObjAppendElement(interp, errorPtr, Tcl_NewWideIntObj(result)); - - return Tcl_SetReturnOptions(interp, errorPtr); - } - - result = Tcl_ListObjIndex(interp, tablePtr, i, &resultPtr); - if (result != TCL_OK) { - return result; - } - Tcl_SetObjResult(interp, resultPtr); - return TCL_OK; -} - -/*---------------------------------------------------------------------- - * - * PrefixAllObjCmd -- - * - * This function implements the 'prefix all' Tcl command. Refer to the - * user documentation for details on what it does. - * - * Results: - * Returns a standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -PrefixAllObjCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - int result; - Tcl_Size length, elemLength, tableObjc, t; - const char *string, *elemString; - Tcl_Obj **tableObjv, *resultPtr; - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "table string"); - return TCL_ERROR; - } - - result = TclListObjGetElements(interp, objv[1], &tableObjc, &tableObjv); - if (result != TCL_OK) { - return result; - } - resultPtr = Tcl_NewListObj(0, NULL); - string = TclGetStringFromObj(objv[2], &length); - - for (t = 0; t < tableObjc; t++) { - elemString = TclGetStringFromObj(tableObjv[t], &elemLength); - - /* - * A prefix cannot match if it is longest. - */ - - if (length <= elemLength) { - if (TclpUtfNcmp2(elemString, string, length) == 0) { - Tcl_ListObjAppendElement(interp, resultPtr, tableObjv[t]); - } - } - } - - Tcl_SetObjResult(interp, resultPtr); - return TCL_OK; -} - -/*---------------------------------------------------------------------- - * - * PrefixLongestObjCmd -- - * - * This function implements the 'prefix longest' Tcl command. Refer to - * the user documentation for details on what it does. - * - * Results: - * Returns a standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -PrefixLongestObjCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - int result; - Tcl_Size i, length, elemLength, resultLength, tableObjc, t; - const char *string, *elemString, *resultString; - Tcl_Obj **tableObjv; - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "table string"); - return TCL_ERROR; - } - - result = TclListObjGetElements(interp, objv[1], &tableObjc, &tableObjv); - if (result != TCL_OK) { - return result; - } - string = TclGetStringFromObj(objv[2], &length); - - resultString = NULL; - resultLength = 0; - - for (t = 0; t < tableObjc; t++) { - elemString = TclGetStringFromObj(tableObjv[t], &elemLength); - - /* - * First check if the prefix string matches the element. A prefix - * cannot match if it is longest. - */ - - if ((length > elemLength) || - TclpUtfNcmp2(elemString, string, length) != 0) { - continue; - } - - if (resultString == NULL) { - /* - * If this is the first match, the longest common substring this - * far is the complete string. The result is part of this string - * so we only need to adjust the length later. - */ - - resultString = elemString; - resultLength = elemLength; - } else { - /* - * Longest common substring cannot be longer than shortest string. - */ - - if (elemLength < resultLength) { - resultLength = elemLength; - } - - /* - * Compare strings. - */ - - for (i = 0; i < resultLength; i++) { - if (resultString[i] != elemString[i]) { - /* - * Adjust in case we stopped in the middle of a UTF char. - */ - - resultLength = Tcl_UtfPrev(&resultString[i+1], - resultString) - resultString; - break; - } - } - } - } - if (resultLength > 0) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj(resultString, resultLength)); - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * * Tcl_WrongNumArgs -- * * This function generates a "wrong # args" error message in an @@ -870,7 +452,7 @@ PrefixLongestObjCmd( void Tcl_WrongNumArgs( Tcl_Interp *interp, /* Current interpreter. */ - Tcl_Size objc, /* Number of arguments to print from objv. */ + 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 @@ -878,9 +460,8 @@ Tcl_WrongNumArgs( * NULL. */ { Tcl_Obj *objPtr; - Tcl_Size i, len, elemLen; - char flags; - Interp *iPtr = (Interp *)interp; + int i, len, elemLen, flags; + Interp *iPtr = (Interp *) interp; const char *elementStr; /* @@ -908,27 +489,26 @@ Tcl_WrongNumArgs( TclNewObj(objPtr); if (iPtr->flags & INTERP_ALTERNATE_WRONG_ARGS) { - iPtr->flags &= ~INTERP_ALTERNATE_WRONG_ARGS; Tcl_AppendObjToObj(objPtr, Tcl_GetObjResult(interp)); - Tcl_AppendToObj(objPtr, " or \"", TCL_INDEX_NONE); + Tcl_AppendToObj(objPtr, " or \"", -1); } else { - Tcl_AppendToObj(objPtr, "wrong # args: should be \"", TCL_INDEX_NONE); + Tcl_AppendToObj(objPtr, "wrong # args: should be \"", -1); } /* - * If processing an an ensemble implementation, 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) { - Tcl_Size toSkip = iPtr->ensembleRewrite.numInsertedObjs; - Tcl_Size toPrint = iPtr->ensembleRewrite.numRemovedObjs; - Tcl_Obj *const *origObjv = TclEnsembleGetRewriteValues(interp); + int toSkip = iPtr->ensembleRewrite.numInsertedObjs; + int toPrint = iPtr->ensembleRewrite.numRemovedObjs; + Tcl_Obj *const *origObjv = iPtr->ensembleRewrite.sourceObjs; /* - * Only do rewrite the command if all the replaced objects are + * 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 it's to just give a slightly + * gets too complicated and we'd be better off just giving a slightly * confusing error message... */ @@ -944,20 +524,26 @@ Tcl_WrongNumArgs( objc -= toSkip; /* - * Assume no object is of index type. + * We assume no object is of index type. */ for (i=0 ; i<toPrint ; i++) { /* * Add the element, quoting it if necessary. */ - const Tcl_ObjInternalRep *irPtr; - if ((irPtr = TclFetchInternalRep(origObjv[i], &tclIndexType))) { - IndexRep *indexRep = (IndexRep *)irPtr->twoPtrValue.ptr1; + if (origObjv[i]->typePtr == &indexType) { + register IndexRep *indexRep = + origObjv[i]->internalRep.twoPtrValue.ptr1; elementStr = EXPAND_OF(indexRep); elemLen = strlen(elementStr); + } else if (origObjv[i]->typePtr == &tclEnsembleCmdType) { + register EnsembleCmdRep *ecrPtr = + origObjv[i]->internalRep.twoPtrValue.ptr1; + + elementStr = ecrPtr->fullSubcmdName; + elemLen = strlen(elementStr); } else { elementStr = TclGetStringFromObj(origObjv[i], &elemLen); } @@ -965,7 +551,8 @@ Tcl_WrongNumArgs( len = TclScanElement(elementStr, elemLen, &flags); if (MAY_QUOTE_WORD && len != elemLen) { - char *quotedElementStr = (char *)TclStackAlloc(interp, len + 1); + char *quotedElementStr = TclStackAlloc(interp, + (unsigned)len + 1); len = TclConvertElement(elementStr, elemLen, quotedElementStr, flags); @@ -982,8 +569,8 @@ Tcl_WrongNumArgs( * moderately complex condition here). */ - if (i + 1 < toPrint || objc!=0 || message!=NULL) { - Tcl_AppendStringsToObj(objPtr, " ", (char *)NULL); + if (i<toPrint-1 || objc!=0 || message!=NULL) { + Tcl_AppendStringsToObj(objPtr, " ", NULL); } } } @@ -996,16 +583,20 @@ Tcl_WrongNumArgs( addNormalArgumentsToMessage: for (i = 0; i < objc; i++) { /* - * If the object is an index type, use the index table which allows for + * 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. */ - const Tcl_ObjInternalRep *irPtr; - if ((irPtr = TclFetchInternalRep(objv[i], &tclIndexType))) { - IndexRep *indexRep = (IndexRep *)irPtr->twoPtrValue.ptr1; + if (objv[i]->typePtr == &indexType) { + register IndexRep *indexRep = objv[i]->internalRep.twoPtrValue.ptr1; + + Tcl_AppendStringsToObj(objPtr, EXPAND_OF(indexRep), NULL); + } else if (objv[i]->typePtr == &tclEnsembleCmdType) { + register EnsembleCmdRep *ecrPtr = + objv[i]->internalRep.twoPtrValue.ptr1; - Tcl_AppendStringsToObj(objPtr, EXPAND_OF(indexRep), (char *)NULL); + Tcl_AppendStringsToObj(objPtr, ecrPtr->fullSubcmdName, NULL); } else { /* * Quote the argument if it contains spaces (Bug 942757). @@ -1016,7 +607,8 @@ Tcl_WrongNumArgs( len = TclScanElement(elementStr, elemLen, &flags); if (MAY_QUOTE_WORD && len != elemLen) { - char *quotedElementStr = (char *)TclStackAlloc(interp, len + 1); + char *quotedElementStr = TclStackAlloc(interp, + (unsigned) len + 1); len = TclConvertElement(elementStr, elemLen, quotedElementStr, flags); @@ -1034,8 +626,8 @@ Tcl_WrongNumArgs( * (either another element from objv, or the message string). */ - if (i + 1 < objc || message!=NULL) { - Tcl_AppendStringsToObj(objPtr, " ", (char *)NULL); + if (i<objc-1 || message!=NULL) { + Tcl_AppendStringsToObj(objPtr, " ", NULL); } } @@ -1046,432 +638,15 @@ Tcl_WrongNumArgs( */ if (message != NULL) { - Tcl_AppendStringsToObj(objPtr, message, (char *)NULL); + Tcl_AppendStringsToObj(objPtr, message, NULL); } - Tcl_AppendStringsToObj(objPtr, "\"", (char *)NULL); - Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", (char *)NULL); + Tcl_AppendStringsToObj(objPtr, "\"", NULL); Tcl_SetObjResult(interp, objPtr); #undef MAY_QUOTE_WORD #undef AFTER_FIRST_WORD } /* - *---------------------------------------------------------------------- - * - * Tcl_ParseArgsObjv -- - * - * Process an objv array according to a table of expected command-line - * options. See the manual page for more details. - * - * Results: - * The return value is a standard Tcl return value. If an error occurs - * then an error message is left in the interp's result. Under normal - * conditions, both *objcPtr and *objv are modified to return the - * arguments that couldn't be processed here (they didn't match the - * option table, or followed an TCL_ARGV_REST argument). - * - * Side effects: - * Variables may be modified, or procedures may be called. It all depends - * on the arguments and their entries in argTable. See the user - * documentation for details. - * - *---------------------------------------------------------------------- - */ - -#undef Tcl_ParseArgsObjv -int -Tcl_ParseArgsObjv( - Tcl_Interp *interp, /* Place to store error message. */ - const Tcl_ArgvInfo *argTable, - /* Array of option descriptions. */ - Tcl_Size *objcPtr, /* Number of arguments in objv. Modified to - * hold # args left in objv at end. */ - Tcl_Obj *const *objv, /* Array of arguments to be parsed. */ - Tcl_Obj ***remObjv) /* Pointer to array of arguments that were not - * processed here. Should be NULL if no return - * of arguments is desired. */ -{ - Tcl_Obj **leftovers; /* Array to write back to remObjv on - * successful exit. Will include the name of - * the command. */ - Tcl_Size nrem; /* Size of leftovers.*/ - const Tcl_ArgvInfo *infoPtr; - /* Pointer to the current entry in the table - * of argument descriptions. */ - const Tcl_ArgvInfo *matchPtr; - /* Descriptor that matches current argument */ - Tcl_Obj *curArg; /* Current argument */ - const char *str = NULL; - char c; /* Second character of current arg (used for - * quick check for matching; use 2nd char. - * because first char. will almost always be - * '-'). */ - Tcl_Size srcIndex; /* Location from which to read next argument - * from objv. */ - Tcl_Size dstIndex; /* Used to keep track of current arguments - * being processed, primarily for error - * reporting. */ - Tcl_Size objc; /* # arguments in objv still to process. */ - Tcl_Size length; /* Number of characters in current argument */ - - if (remObjv != NULL) { - /* - * Then we should copy the name of the command (0th argument). The - * upper bound on the number of elements is known, and (undocumented, - * but historically true) there should be a NULL argument after the - * last result. [Bug 3413857] - */ - - nrem = 1; - leftovers = (Tcl_Obj **)ckalloc((1 + *objcPtr) * sizeof(Tcl_Obj *)); - leftovers[0] = objv[0]; - } else { - nrem = 0; - leftovers = NULL; - } - - /* - * OK, now start processing from the second element (1st argument). - */ - - srcIndex = dstIndex = 1; - objc = *objcPtr-1; - - while (objc > 0) { - curArg = objv[srcIndex]; - srcIndex++; - objc--; - str = TclGetStringFromObj(curArg, &length); - if (length > 0) { - c = str[1]; - } else { - c = 0; - } - - /* - * Loop through the argument descriptors searching for one with the - * matching key string. If found, leave a pointer to it in matchPtr. - */ - - matchPtr = NULL; - infoPtr = argTable; - for (; infoPtr != NULL && infoPtr->type != TCL_ARGV_END ; infoPtr++) { - if (infoPtr->keyStr == NULL) { - continue; - } - if ((infoPtr->keyStr[1] != c) - || (strncmp(infoPtr->keyStr, str, length) != 0)) { - continue; - } - if (infoPtr->keyStr[length] == 0) { - matchPtr = infoPtr; - goto gotMatch; - } - if (matchPtr != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "ambiguous option \"%s\"", str)); - goto error; - } - matchPtr = infoPtr; - } - if (matchPtr == NULL) { - /* - * Unrecognized argument. Just copy it down, unless the caller - * prefers an error to be registered. - */ - - if (remObjv == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "unrecognized argument \"%s\"", str)); - goto error; - } - - dstIndex++; /* This argument is now handled */ - leftovers[nrem++] = curArg; - continue; - } - - /* - * Take the appropriate action based on the option type - */ - - gotMatch: - infoPtr = matchPtr; - switch (infoPtr->type) { - case TCL_ARGV_CONSTANT: - *((int *) infoPtr->dstPtr) = PTR2INT(infoPtr->srcPtr); - break; - case TCL_ARGV_INT: - if (objc == 0) { - goto missingArg; - } - if (Tcl_GetIntFromObj(interp, objv[srcIndex], - (int *) infoPtr->dstPtr) == TCL_ERROR) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "expected integer argument for \"%s\" but got \"%s\"", - infoPtr->keyStr, TclGetString(objv[srcIndex]))); - goto error; - } - srcIndex++; - objc--; - break; - case TCL_ARGV_STRING: - if (objc == 0) { - goto missingArg; - } - *((const char **) infoPtr->dstPtr) = - TclGetString(objv[srcIndex]); - srcIndex++; - objc--; - break; - case TCL_ARGV_REST: - /* - * Only store the point where we got to if it's not to be written - * to NULL, so that TCL_ARGV_AUTO_REST works. - */ - - if (infoPtr->dstPtr != NULL) { - *((int *) infoPtr->dstPtr) = dstIndex; - } - goto argsDone; - case TCL_ARGV_FLOAT: - if (objc == 0) { - goto missingArg; - } - if (Tcl_GetDoubleFromObj(interp, objv[srcIndex], - (double *) infoPtr->dstPtr) == TCL_ERROR) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "expected floating-point argument for \"%s\" but got \"%s\"", - infoPtr->keyStr, TclGetString(objv[srcIndex]))); - goto error; - } - srcIndex++; - objc--; - break; - case TCL_ARGV_FUNC: { - Tcl_ArgvFuncProc *handlerProc = (Tcl_ArgvFuncProc *) - infoPtr->srcPtr; - Tcl_Obj *argObj; - - if (objc == 0) { - argObj = NULL; - } else { - argObj = objv[srcIndex]; - } - if (handlerProc(infoPtr->clientData, argObj, infoPtr->dstPtr)) { - srcIndex++; - objc--; - } - break; - } - case TCL_ARGV_GENFUNC: { - Tcl_ArgvGenFuncProc *handlerProc = (Tcl_ArgvGenFuncProc *) - infoPtr->srcPtr; - - objc = handlerProc(infoPtr->clientData, interp, objc, - &objv[srcIndex], infoPtr->dstPtr); - if (objc < 0) { - goto error; - } - break; - } - case TCL_ARGV_HELP: - PrintUsage(interp, argTable); - goto error; - default: - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad argument type %d in Tcl_ArgvInfo", infoPtr->type)); - goto error; - } - } - - /* - * If we broke out of the loop because of an OPT_REST argument, copy the - * remaining arguments down. Note that there is always at least one - * argument left over - the command name - so we always have a result if - * our caller is willing to receive it. [Bug 3413857] - */ - - argsDone: - if (remObjv == NULL) { - /* - * Nothing to do. - */ - - return TCL_OK; - } - - if (objc > 0) { - memcpy(leftovers+nrem, objv+srcIndex, objc*sizeof(Tcl_Obj *)); - nrem += objc; - } - leftovers[nrem] = NULL; - *objcPtr = nrem++; - *remObjv = (Tcl_Obj **)ckrealloc(leftovers, nrem * sizeof(Tcl_Obj *)); - return TCL_OK; - - /* - * Make sure to handle freeing any temporary space we've allocated on the - * way to an error. - */ - - missingArg: - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "\"%s\" option requires an additional argument", str)); - error: - if (leftovers != NULL) { - ckfree(leftovers); - } - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * PrintUsage -- - * - * Generate a help string describing command-line options. - * - * Results: - * The interp's result will be modified to hold a help string describing - * all the options in argTable. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static void -PrintUsage( - Tcl_Interp *interp, /* Place information in this interp's result - * area. */ - const Tcl_ArgvInfo *argTable) - /* Array of command-specific argument - * descriptions. */ -{ - const Tcl_ArgvInfo *infoPtr; - int width, numSpaces; -#define NUM_SPACES 20 - static const char spaces[] = " "; - Tcl_Obj *msg; - - /* - * First, compute the width of the widest option key, so that we can make - * everything line up. - */ - - width = 4; - for (infoPtr = argTable; infoPtr->type != TCL_ARGV_END; infoPtr++) { - Tcl_Size length; - - if (infoPtr->keyStr == NULL) { - continue; - } - length = strlen(infoPtr->keyStr); - if (length > width) { - width = length; - } - } - - /* - * Now add the option information, with pretty-printing. - */ - - msg = Tcl_NewStringObj("Command-specific options:", TCL_INDEX_NONE); - for (infoPtr = argTable; infoPtr->type != TCL_ARGV_END; infoPtr++) { - if ((infoPtr->type == TCL_ARGV_HELP) && (infoPtr->keyStr == NULL)) { - Tcl_AppendPrintfToObj(msg, "\n%s", infoPtr->helpStr); - continue; - } - Tcl_AppendPrintfToObj(msg, "\n %s:", infoPtr->keyStr); - numSpaces = width + 1 - strlen(infoPtr->keyStr); - while (numSpaces > 0) { - if (numSpaces >= NUM_SPACES) { - Tcl_AppendToObj(msg, spaces, NUM_SPACES); - } else { - Tcl_AppendToObj(msg, spaces, numSpaces); - } - numSpaces -= NUM_SPACES; - } - Tcl_AppendToObj(msg, infoPtr->helpStr, TCL_INDEX_NONE); - switch (infoPtr->type) { - case TCL_ARGV_INT: - Tcl_AppendPrintfToObj(msg, "\n\t\tDefault value: %d", - *((int *) infoPtr->dstPtr)); - break; - case TCL_ARGV_FLOAT: - Tcl_AppendPrintfToObj(msg, "\n\t\tDefault value: %g", - *((double *) infoPtr->dstPtr)); - break; - case TCL_ARGV_STRING: { - char *string = *((char **) infoPtr->dstPtr); - - if (string != NULL) { - Tcl_AppendPrintfToObj(msg, "\n\t\tDefault value: \"%s\"", - string); - } - break; - } - default: - break; - } - } - Tcl_SetObjResult(interp, msg); -} - -/* - *---------------------------------------------------------------------- - * - * TclGetCompletionCodeFromObj -- - * - * Parses Completion code Code - * - * Results: - * Returns TCL_ERROR if the value is an invalid completion code. - * Otherwise, returns TCL_OK, and writes the completion code to the - * pointer provided. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -TclGetCompletionCodeFromObj( - Tcl_Interp *interp, /* Current interpreter. */ - Tcl_Obj *value, - int *codePtr) /* Argument objects. */ -{ - static const char *const returnCodes[] = { - "ok", "error", "return", "break", "continue", NULL - }; - - if (!TclHasInternalRep(value, &tclIndexType) - && TclGetIntFromObj(NULL, value, codePtr) == TCL_OK) { - return TCL_OK; - } - if (Tcl_GetIndexFromObjStruct(NULL, value, returnCodes, - sizeof(char *), NULL, TCL_EXACT, codePtr) == TCL_OK) { - return TCL_OK; - } - - /* - * Value is not a legal completion code. - */ - - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad completion code \"%s\": must be" - " ok, error, return, break, continue, or an integer", - TclGetString(value))); - Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_CODE", (char *)NULL); - } - return TCL_ERROR; -} - -/* * Local Variables: * mode: c * c-basic-offset: 4 |