os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclIndexObj.c
1.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2 +++ b/os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclIndexObj.c Fri Jun 15 03:10:57 2012 +0200
1.3 @@ -0,0 +1,479 @@
1.4 +/*
1.5 + * tclIndexObj.c --
1.6 + *
1.7 + * This file implements objects of type "index". This object type
1.8 + * is used to lookup a keyword in a table of valid values and cache
1.9 + * the index of the matching entry.
1.10 + *
1.11 + * Copyright (c) 1997 Sun Microsystems, Inc.
1.12 + * Portions Copyright (c) 2007-2008 Nokia Corporation and/or its subsidiaries. All rights reserved.
1.13 + *
1.14 + * See the file "license.terms" for information on usage and redistribution
1.15 + * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
1.16 + *
1.17 + * RCS: @(#) $Id: tclIndexObj.c,v 1.16.2.5 2006/04/06 18:57:24 dgp Exp $
1.18 + */
1.19 +
1.20 +#include "tclInt.h"
1.21 +#include "tclPort.h"
1.22 +
1.23 +/*
1.24 + * Prototypes for procedures defined later in this file:
1.25 + */
1.26 +
1.27 +static int SetIndexFromAny _ANSI_ARGS_((Tcl_Interp *interp,
1.28 + Tcl_Obj *objPtr));
1.29 +static void UpdateStringOfIndex _ANSI_ARGS_((Tcl_Obj *objPtr));
1.30 +static void DupIndex _ANSI_ARGS_((Tcl_Obj *srcPtr,
1.31 + Tcl_Obj *dupPtr));
1.32 +static void FreeIndex _ANSI_ARGS_((Tcl_Obj *objPtr));
1.33 +
1.34 +/*
1.35 + * The structure below defines the index Tcl object type by means of
1.36 + * procedures that can be invoked by generic object code.
1.37 + */
1.38 +
1.39 +Tcl_ObjType tclIndexType = {
1.40 + "index", /* name */
1.41 + FreeIndex, /* freeIntRepProc */
1.42 + DupIndex, /* dupIntRepProc */
1.43 + UpdateStringOfIndex, /* updateStringProc */
1.44 + SetIndexFromAny /* setFromAnyProc */
1.45 +};
1.46 +
1.47 +/*
1.48 + * The definition of the internal representation of the "index"
1.49 + * object; The internalRep.otherValuePtr field of an object of "index"
1.50 + * type will be a pointer to one of these structures.
1.51 + *
1.52 + * Keep this structure declaration in sync with tclTestObj.c
1.53 + */
1.54 +
1.55 +typedef struct {
1.56 + VOID *tablePtr; /* Pointer to the table of strings */
1.57 + int offset; /* Offset between table entries */
1.58 + int index; /* Selected index into table. */
1.59 +} IndexRep;
1.60 +
1.61 +/*
1.62 + * The following macros greatly simplify moving through a table...
1.63 + */
1.64 +#define STRING_AT(table, offset, index) \
1.65 + (*((CONST char * CONST *)(((char *)(table)) + ((offset) * (index)))))
1.66 +#define NEXT_ENTRY(table, offset) \
1.67 + (&(STRING_AT(table, offset, 1)))
1.68 +#define EXPAND_OF(indexRep) \
1.69 + STRING_AT((indexRep)->tablePtr, (indexRep)->offset, (indexRep)->index)
1.70 +
1.71 +
1.72 +/*
1.73 + *----------------------------------------------------------------------
1.74 + *
1.75 + * Tcl_GetIndexFromObj --
1.76 + *
1.77 + * This procedure looks up an object's value in a table of strings
1.78 + * and returns the index of the matching string, if any.
1.79 + *
1.80 + * Results:
1.81 + *
1.82 + * If the value of objPtr is identical to or a unique abbreviation
1.83 + * for one of the entries in objPtr, then the return value is
1.84 + * TCL_OK and the index of the matching entry is stored at
1.85 + * *indexPtr. If there isn't a proper match, then TCL_ERROR is
1.86 + * returned and an error message is left in interp's result (unless
1.87 + * interp is NULL). The msg argument is used in the error
1.88 + * message; for example, if msg has the value "option" then the
1.89 + * error message will say something flag 'bad option "foo": must be
1.90 + * ...'
1.91 + *
1.92 + * Side effects:
1.93 + * The result of the lookup is cached as the internal rep of
1.94 + * objPtr, so that repeated lookups can be done quickly.
1.95 + *
1.96 + *----------------------------------------------------------------------
1.97 + */
1.98 +
1.99 +EXPORT_C int
1.100 +Tcl_GetIndexFromObj(interp, objPtr, tablePtr, msg, flags, indexPtr)
1.101 + Tcl_Interp *interp; /* Used for error reporting if not NULL. */
1.102 + Tcl_Obj *objPtr; /* Object containing the string to lookup. */
1.103 + CONST char **tablePtr; /* Array of strings to compare against the
1.104 + * value of objPtr; last entry must be NULL
1.105 + * and there must not be duplicate entries. */
1.106 + CONST char *msg; /* Identifying word to use in error messages. */
1.107 + int flags; /* 0 or TCL_EXACT */
1.108 + int *indexPtr; /* Place to store resulting integer index. */
1.109 +{
1.110 +
1.111 + /*
1.112 + * See if there is a valid cached result from a previous lookup
1.113 + * (doing the check here saves the overhead of calling
1.114 + * Tcl_GetIndexFromObjStruct in the common case where the result
1.115 + * is cached).
1.116 + */
1.117 +
1.118 + if (objPtr->typePtr == &tclIndexType) {
1.119 + IndexRep *indexRep = (IndexRep *) objPtr->internalRep.otherValuePtr;
1.120 + /*
1.121 + * Here's hoping we don't get hit by unfortunate packing
1.122 + * constraints on odd platforms like a Cray PVP...
1.123 + */
1.124 + if (indexRep->tablePtr == (VOID *)tablePtr &&
1.125 + indexRep->offset == sizeof(char *)) {
1.126 + *indexPtr = indexRep->index;
1.127 + return TCL_OK;
1.128 + }
1.129 + }
1.130 + return Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, sizeof(char *),
1.131 + msg, flags, indexPtr);
1.132 +}
1.133 +
1.134 +/*
1.135 + *----------------------------------------------------------------------
1.136 + *
1.137 + * Tcl_GetIndexFromObjStruct --
1.138 + *
1.139 + * This procedure looks up an object's value given a starting
1.140 + * string and an offset for the amount of space between strings.
1.141 + * This is useful when the strings are embedded in some other
1.142 + * kind of array.
1.143 + *
1.144 + * Results:
1.145 + *
1.146 + * If the value of objPtr is identical to or a unique abbreviation
1.147 + * for one of the entries in objPtr, then the return value is
1.148 + * TCL_OK and the index of the matching entry is stored at
1.149 + * *indexPtr. If there isn't a proper match, then TCL_ERROR is
1.150 + * returned and an error message is left in interp's result (unless
1.151 + * interp is NULL). The msg argument is used in the error
1.152 + * message; for example, if msg has the value "option" then the
1.153 + * error message will say something flag 'bad option "foo": must be
1.154 + * ...'
1.155 + *
1.156 + * Side effects:
1.157 + * The result of the lookup is cached as the internal rep of
1.158 + * objPtr, so that repeated lookups can be done quickly.
1.159 + *
1.160 + *----------------------------------------------------------------------
1.161 + */
1.162 +
1.163 +EXPORT_C int
1.164 +Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags,
1.165 + indexPtr)
1.166 + Tcl_Interp *interp; /* Used for error reporting if not NULL. */
1.167 + Tcl_Obj *objPtr; /* Object containing the string to lookup. */
1.168 + CONST VOID *tablePtr; /* The first string in the table. The second
1.169 + * string will be at this address plus the
1.170 + * offset, the third plus the offset again,
1.171 + * etc. The last entry must be NULL
1.172 + * and there must not be duplicate entries. */
1.173 + int offset; /* The number of bytes between entries */
1.174 + CONST char *msg; /* Identifying word to use in error messages. */
1.175 + int flags; /* 0 or TCL_EXACT */
1.176 + int *indexPtr; /* Place to store resulting integer index. */
1.177 +{
1.178 + int index, i, numAbbrev;
1.179 + char *key, *p1;
1.180 + CONST char *p2;
1.181 + CONST char * CONST *entryPtr;
1.182 + Tcl_Obj *resultPtr;
1.183 + IndexRep *indexRep;
1.184 +
1.185 + /*
1.186 + * See if there is a valid cached result from a previous lookup.
1.187 + */
1.188 +
1.189 + if (objPtr->typePtr == &tclIndexType) {
1.190 + indexRep = (IndexRep *) objPtr->internalRep.otherValuePtr;
1.191 + if (indexRep->tablePtr==tablePtr && indexRep->offset==offset) {
1.192 + *indexPtr = indexRep->index;
1.193 + return TCL_OK;
1.194 + }
1.195 + }
1.196 +
1.197 + /*
1.198 + * Lookup the value of the object in the table. Accept unique
1.199 + * abbreviations unless TCL_EXACT is set in flags.
1.200 + */
1.201 +
1.202 + key = TclGetString(objPtr);
1.203 + index = -1;
1.204 + numAbbrev = 0;
1.205 +
1.206 + /*
1.207 + * Scan the table looking for one of:
1.208 + * - An exact match (always preferred)
1.209 + * - A single abbreviation (allowed depending on flags)
1.210 + * - Several abbreviations (never allowed, but overridden by exact match)
1.211 + */
1.212 + for (entryPtr = tablePtr, i = 0; *entryPtr != NULL;
1.213 + entryPtr = NEXT_ENTRY(entryPtr, offset), i++) {
1.214 + for (p1 = key, p2 = *entryPtr; *p1 == *p2; p1++, p2++) {
1.215 + if (*p1 == '\0') {
1.216 + index = i;
1.217 + goto done;
1.218 + }
1.219 + }
1.220 + if (*p1 == '\0') {
1.221 + /*
1.222 + * The value is an abbreviation for this entry. Continue
1.223 + * checking other entries to make sure it's unique. If we
1.224 + * get more than one unique abbreviation, keep searching to
1.225 + * see if there is an exact match, but remember the number
1.226 + * of unique abbreviations and don't allow either.
1.227 + */
1.228 +
1.229 + numAbbrev++;
1.230 + index = i;
1.231 + }
1.232 + }
1.233 + /*
1.234 + * Check if we were instructed to disallow abbreviations.
1.235 + */
1.236 + if ((flags & TCL_EXACT) || (key[0] == '\0') || (numAbbrev != 1)) {
1.237 + goto error;
1.238 + }
1.239 +
1.240 + done:
1.241 + /*
1.242 + * Cache the found representation. Note that we want to avoid
1.243 + * allocating a new internal-rep if at all possible since that is
1.244 + * potentially a slow operation.
1.245 + */
1.246 + if (objPtr->typePtr == &tclIndexType) {
1.247 + indexRep = (IndexRep *) objPtr->internalRep.otherValuePtr;
1.248 + } else {
1.249 + if ((objPtr->typePtr != NULL)
1.250 + && (objPtr->typePtr->freeIntRepProc != NULL)) {
1.251 + objPtr->typePtr->freeIntRepProc(objPtr);
1.252 + }
1.253 + indexRep = (IndexRep *) ckalloc(sizeof(IndexRep));
1.254 + objPtr->internalRep.otherValuePtr = (VOID *) indexRep;
1.255 + objPtr->typePtr = &tclIndexType;
1.256 + }
1.257 + indexRep->tablePtr = (VOID*) tablePtr;
1.258 + indexRep->offset = offset;
1.259 + indexRep->index = index;
1.260 +
1.261 + *indexPtr = index;
1.262 + return TCL_OK;
1.263 +
1.264 + error:
1.265 + if (interp != NULL) {
1.266 + /*
1.267 + * Produce a fancy error message.
1.268 + */
1.269 + int count;
1.270 +
1.271 + TclNewObj(resultPtr);
1.272 + Tcl_SetObjResult(interp, resultPtr);
1.273 + Tcl_AppendStringsToObj(resultPtr, (numAbbrev > 1) &&
1.274 + !(flags & TCL_EXACT) ? "ambiguous " : "bad ", msg, " \"",
1.275 + key, "\": must be ", STRING_AT(tablePtr,offset,0), (char*)NULL);
1.276 + for (entryPtr = NEXT_ENTRY(tablePtr, offset), count = 0;
1.277 + *entryPtr != NULL;
1.278 + entryPtr = NEXT_ENTRY(entryPtr, offset), count++) {
1.279 + if (*NEXT_ENTRY(entryPtr, offset) == NULL) {
1.280 + Tcl_AppendStringsToObj(resultPtr,
1.281 + (count > 0) ? ", or " : " or ", *entryPtr,
1.282 + (char *) NULL);
1.283 + } else {
1.284 + Tcl_AppendStringsToObj(resultPtr, ", ", *entryPtr,
1.285 + (char *) NULL);
1.286 + }
1.287 + }
1.288 + }
1.289 + return TCL_ERROR;
1.290 +}
1.291 +
1.292 +/*
1.293 + *----------------------------------------------------------------------
1.294 + *
1.295 + * SetIndexFromAny --
1.296 + *
1.297 + * This procedure is called to convert a Tcl object to index
1.298 + * internal form. However, this doesn't make sense (need to have a
1.299 + * table of keywords in order to do the conversion) so the
1.300 + * procedure always generates an error.
1.301 + *
1.302 + * Results:
1.303 + * The return value is always TCL_ERROR, and an error message is
1.304 + * left in interp's result if interp isn't NULL.
1.305 + *
1.306 + * Side effects:
1.307 + * None.
1.308 + *
1.309 + *----------------------------------------------------------------------
1.310 + */
1.311 +
1.312 +static int
1.313 +SetIndexFromAny(interp, objPtr)
1.314 + Tcl_Interp *interp; /* Used for error reporting if not NULL. */
1.315 + register Tcl_Obj *objPtr; /* The object to convert. */
1.316 +{
1.317 + Tcl_AppendToObj(Tcl_GetObjResult(interp),
1.318 + "can't convert value to index except via Tcl_GetIndexFromObj API",
1.319 + -1);
1.320 + return TCL_ERROR;
1.321 +}
1.322 +
1.323 +/*
1.324 + *----------------------------------------------------------------------
1.325 + *
1.326 + * UpdateStringOfIndex --
1.327 + *
1.328 + * This procedure is called to convert a Tcl object from index
1.329 + * internal form to its string form. No abbreviation is ever
1.330 + * generated.
1.331 + *
1.332 + * Results:
1.333 + * None.
1.334 + *
1.335 + * Side effects:
1.336 + * The string representation of the object is updated.
1.337 + *
1.338 + *----------------------------------------------------------------------
1.339 + */
1.340 +
1.341 +static void
1.342 +UpdateStringOfIndex(objPtr)
1.343 + Tcl_Obj *objPtr;
1.344 +{
1.345 + IndexRep *indexRep = (IndexRep *) objPtr->internalRep.otherValuePtr;
1.346 + register char *buf;
1.347 + register unsigned len;
1.348 + register CONST char *indexStr = EXPAND_OF(indexRep);
1.349 +
1.350 + len = strlen(indexStr);
1.351 + buf = (char *) ckalloc(len + 1);
1.352 + memcpy(buf, indexStr, len+1);
1.353 + objPtr->bytes = buf;
1.354 + objPtr->length = len;
1.355 +}
1.356 +
1.357 +/*
1.358 + *----------------------------------------------------------------------
1.359 + *
1.360 + * DupIndex --
1.361 + *
1.362 + * This procedure is called to copy the internal rep of an index
1.363 + * Tcl object from to another object.
1.364 + *
1.365 + * Results:
1.366 + * None.
1.367 + *
1.368 + * Side effects:
1.369 + * The internal representation of the target object is updated
1.370 + * and the type is set.
1.371 + *
1.372 + *----------------------------------------------------------------------
1.373 + */
1.374 +
1.375 +static void
1.376 +DupIndex(srcPtr, dupPtr)
1.377 + Tcl_Obj *srcPtr, *dupPtr;
1.378 +{
1.379 + IndexRep *srcIndexRep = (IndexRep *) srcPtr->internalRep.otherValuePtr;
1.380 + IndexRep *dupIndexRep = (IndexRep *) ckalloc(sizeof(IndexRep));
1.381 +
1.382 + memcpy(dupIndexRep, srcIndexRep, sizeof(IndexRep));
1.383 + dupPtr->internalRep.otherValuePtr = (VOID *) dupIndexRep;
1.384 + dupPtr->typePtr = &tclIndexType;
1.385 +}
1.386 +
1.387 +/*
1.388 + *----------------------------------------------------------------------
1.389 + *
1.390 + * FreeIndex --
1.391 + *
1.392 + * This procedure is called to delete the internal rep of an index
1.393 + * Tcl object.
1.394 + *
1.395 + * Results:
1.396 + * None.
1.397 + *
1.398 + * Side effects:
1.399 + * The internal representation of the target object is deleted.
1.400 + *
1.401 + *----------------------------------------------------------------------
1.402 + */
1.403 +
1.404 +static void
1.405 +FreeIndex(objPtr)
1.406 + Tcl_Obj *objPtr;
1.407 +{
1.408 + ckfree((char *) objPtr->internalRep.otherValuePtr);
1.409 +}
1.410 +
1.411 +/*
1.412 + *----------------------------------------------------------------------
1.413 + *
1.414 + * Tcl_WrongNumArgs --
1.415 + *
1.416 + * This procedure generates a "wrong # args" error message in an
1.417 + * interpreter. It is used as a utility function by many command
1.418 + * procedures.
1.419 + *
1.420 + * Results:
1.421 + * None.
1.422 + *
1.423 + * Side effects:
1.424 + * An error message is generated in interp's result object to
1.425 + * indicate that a command was invoked with the wrong number of
1.426 + * arguments. The message has the form
1.427 + * wrong # args: should be "foo bar additional stuff"
1.428 + * where "foo" and "bar" are the initial objects in objv (objc
1.429 + * determines how many of these are printed) and "additional stuff"
1.430 + * is the contents of the message argument.
1.431 + *
1.432 + *----------------------------------------------------------------------
1.433 + */
1.434 +
1.435 +EXPORT_C void
1.436 +Tcl_WrongNumArgs(interp, objc, objv, message)
1.437 + Tcl_Interp *interp; /* Current interpreter. */
1.438 + int objc; /* Number of arguments to print
1.439 + * from objv. */
1.440 + Tcl_Obj *CONST objv[]; /* Initial argument objects, which
1.441 + * should be included in the error
1.442 + * message. */
1.443 + CONST char *message; /* Error message to print after the
1.444 + * leading objects in objv. The
1.445 + * message may be NULL. */
1.446 +{
1.447 + Tcl_Obj *objPtr;
1.448 + int i;
1.449 + register IndexRep *indexRep;
1.450 +
1.451 + TclNewObj(objPtr);
1.452 + Tcl_SetObjResult(interp, objPtr);
1.453 + Tcl_AppendToObj(objPtr, "wrong # args: should be \"", -1);
1.454 + for (i = 0; i < objc; i++) {
1.455 + /*
1.456 + * If the object is an index type use the index table which allows
1.457 + * for the correct error message even if the subcommand was
1.458 + * abbreviated. Otherwise, just use the string rep.
1.459 + */
1.460 +
1.461 + if (objv[i]->typePtr == &tclIndexType) {
1.462 + indexRep = (IndexRep *) objv[i]->internalRep.otherValuePtr;
1.463 + Tcl_AppendStringsToObj(objPtr, EXPAND_OF(indexRep), (char *) NULL);
1.464 + } else {
1.465 + Tcl_AppendStringsToObj(objPtr, Tcl_GetString(objv[i]),
1.466 + (char *) NULL);
1.467 + }
1.468 +
1.469 + /*
1.470 + * Append a space character (" ") if there is more text to follow
1.471 + * (either another element from objv, or the message string).
1.472 + */
1.473 + if ((i < (objc - 1)) || message) {
1.474 + Tcl_AppendStringsToObj(objPtr, " ", (char *) NULL);
1.475 + }
1.476 + }
1.477 +
1.478 + if (message) {
1.479 + Tcl_AppendStringsToObj(objPtr, message, (char *) NULL);
1.480 + }
1.481 + Tcl_AppendStringsToObj(objPtr, "\"", (char *) NULL);
1.482 +}