src/c_tcl_base_7_5_w_mods/tclindexobj.c

/* $Header$ */
/* 
 * 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.
 *
 * 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.
 *
 * RCS: @(#) $Id: tclindexobj.c,v 1.1.1.1 2001/06/13 04:39:30 dtashley Exp $
 */

#include "tclInt.h"

/*
 * Prototypes for procedures defined later in this file:
 */

static int              SetIndexFromAny _ANSI_ARGS_((Tcl_Interp *interp,
                            Tcl_Obj *objPtr));

/*
 * The structure below defines the index Tcl object type by means of
 * procedures that can be invoked by generic object code.
 */

Tcl_ObjType tclIndexType = {
    "index",                            /* name */
    (Tcl_FreeInternalRepProc *) NULL,   /* freeIntRepProc */
    (Tcl_DupInternalRepProc *) NULL,    /* dupIntRepProc */
    (Tcl_UpdateStringProc *) NULL,      /* updateStringProc */
    SetIndexFromAny                     /* setFromAnyProc */
};

/*
 * Boolean flag indicating whether or not the tclIndexType object
 * type has been registered with the Tcl compiler.
 */

static int indexTypeInitialized = 0;

/*
 *----------------------------------------------------------------------
 *
 * 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.
 *
 * 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
 *      ...'
 *
 * Side effects:
 *      The result of the lookup is cached as the internal rep of
 *      objPtr, so that repeated lookups can be done quickly.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetIndexFromObj(interp, objPtr, tablePtr, msg, flags, indexPtr)
    Tcl_Interp *interp;         /* Used for error reporting if not NULL. */
    Tcl_Obj *objPtr;            /* Object containing the string to lookup. */
    char **tablePtr;            /* Array of strings to compare against the
                                 * value of objPtr; last entry must be NULL
                                 * and there must not be duplicate entries. */
    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).
     */

    if ((objPtr->typePtr == &tclIndexType)
            && (objPtr->internalRep.twoPtrValue.ptr1 == (VOID *) tablePtr)) {
        *indexPtr = (int) objPtr->internalRep.twoPtrValue.ptr2;
        return TCL_OK;
    }
    return Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, sizeof(char *),
            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.
 *
 * 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
 *      ...'
 *
 * Side effects:
 *      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, 
        indexPtr)
    Tcl_Interp *interp;         /* Used for error reporting if not NULL. */
    Tcl_Obj *objPtr;            /* Object containing the string to lookup. */
    char **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. */
    int offset;                 /* The number of bytes between entries */
    char *msg;                  /* Identifying word to use in error messages. */
    int flags;                  /* 0 or TCL_EXACT */
    int *indexPtr;              /* Place to store resulting integer index. */
{
    int index, length, i, numAbbrev;
    char *key, *p1, *p2, **entryPtr;
    Tcl_Obj *resultPtr;

    /*
     * See if there is a valid cached result from a previous lookup.
     */

    if ((objPtr->typePtr == &tclIndexType)
            && (objPtr->internalRep.twoPtrValue.ptr1 == (VOID *) tablePtr)) {
        *indexPtr = (int) objPtr->internalRep.twoPtrValue.ptr2;
        return TCL_OK;
    }

    /*
     * Lookup the value of the object in the table.  Accept unique
     * abbreviations unless TCL_EXACT is set in flags.
     */

    if (!indexTypeInitialized) {
        /*
         * This is the first time we've done a lookup.  Register the
         * tclIndexType.
         */

        Tcl_RegisterObjType(&tclIndexType);
        indexTypeInitialized = 1;
    }

    key = Tcl_GetStringFromObj(objPtr, &length);
    index = -1;
    numAbbrev = 0;

    /*
     * The key should not be empty, otherwise it's not a match.
     */
    
    if (key[0] == '\0') {
        goto error;
    }
    
    for (entryPtr = tablePtr, i = 0; *entryPtr != NULL; 
            entryPtr = (char **) ((long) entryPtr + offset), i++) {
        for (p1 = key, p2 = *entryPtr; *p1 == *p2; p1++, p2++) {
            if (*p1 == 0) {
                index = i;
                goto done;
            }
        }
        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.
             */

            numAbbrev++;
            index = i;
        }
    }
    if ((flags & TCL_EXACT) || (numAbbrev != 1)) {
        goto error;
    }

    done:
    if ((objPtr->typePtr != NULL)
            && (objPtr->typePtr->freeIntRepProc != NULL)) {
        objPtr->typePtr->freeIntRepProc(objPtr);
    }
    objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) tablePtr;
    objPtr->internalRep.twoPtrValue.ptr2 = (VOID *) index;
    objPtr->typePtr = &tclIndexType;
    *indexPtr = index;
    return TCL_OK;

    error:
    if (interp != NULL) {
        int count;
        resultPtr = Tcl_GetObjResult(interp);
        Tcl_AppendStringsToObj(resultPtr,
                (numAbbrev > 1) ? "ambiguous " : "bad ", msg, " \"",
                key, "\": must be ", *tablePtr, (char *) NULL);
        for (entryPtr = (char **) ((long) tablePtr + offset), count = 0;
                *entryPtr != NULL;
                entryPtr = (char **) ((long) entryPtr + offset), count++) {
            if ((*((char **) ((long) entryPtr + offset))) == NULL) {
                Tcl_AppendStringsToObj(resultPtr,
                        (count > 0) ? ", or " : " or ", *entryPtr,
                        (char *) NULL);
            } else {
                Tcl_AppendStringsToObj(resultPtr, ", ", *entryPtr,
                        (char *) NULL);
            }
        }
    }
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * 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.
 *
 * 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(interp, objPtr)
    Tcl_Interp *interp;         /* Used for error reporting if not NULL. */
    register Tcl_Obj *objPtr;   /* The object to convert. */
{
    Tcl_AppendToObj(Tcl_GetObjResult(interp),
            "can't convert value to index except via Tcl_GetIndexFromObj API",
            -1);
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_WrongNumArgs --
 *
 *      This procedure generates a "wrong # args" error message in an
 *      interpreter.  It is used as a utility function by many command
 *      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
 *              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.
 *
 *----------------------------------------------------------------------
 */

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. */
    char *message;                      /* Error message to print after the
                                         * leading objects in objv. The
                                         * message may be NULL. */
{
    Tcl_Obj *objPtr;
    char **tablePtr;
    int i;

    objPtr = Tcl_GetObjResult(interp);
    Tcl_AppendToObj(objPtr, "wrong # args: should be \"", -1);
    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 (objv[i]->typePtr == &tclIndexType) {
            tablePtr = ((char **) objv[i]->internalRep.twoPtrValue.ptr1);
            Tcl_AppendStringsToObj(objPtr,
                    tablePtr[(int) objv[i]->internalRep.twoPtrValue.ptr2],
                    (char *) NULL);
        } else {
            Tcl_AppendStringsToObj(objPtr, Tcl_GetString(objv[i]),
                    (char *) NULL);
        }
        if (i < (objc - 1)) {
            Tcl_AppendStringsToObj(objPtr, " ", (char *) NULL);
        }
    }
    if (message) {
      Tcl_AppendStringsToObj(objPtr, " ", message, (char *) NULL);
    }
    Tcl_AppendStringsToObj(objPtr, "\"", (char *) NULL);
}

/* End of tclindexobj.c */
1	dashley	71	/* $Header$ */
2			/*
3			* tclIndexObj.c --
4			*
5			* This file implements objects of type "index". This object type
6			* is used to lookup a keyword in a table of valid values and cache
7			* the index of the matching entry.
8			*
9			* Copyright (c) 1997 Sun Microsystems, Inc.
10			*
11			* See the file "license.terms" for information on usage and redistribution
12			* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
13			*
14			* RCS: @(#) $Id: tclindexobj.c,v 1.1.1.1 2001/06/13 04:39:30 dtashley Exp $
15			*/
16
17			#include "tclInt.h"
18
19			/*
20			* Prototypes for procedures defined later in this file:
21			*/
22
23			static int SetIndexFromAny _ANSI_ARGS_((Tcl_Interp *interp,
24			Tcl_Obj *objPtr));
25
26			/*
27			* The structure below defines the index Tcl object type by means of
28			* procedures that can be invoked by generic object code.
29			*/
30
31			Tcl_ObjType tclIndexType = {
32			"index", /* name */
33			(Tcl_FreeInternalRepProc ) NULL, / freeIntRepProc */
34			(Tcl_DupInternalRepProc ) NULL, / dupIntRepProc */
35			(Tcl_UpdateStringProc ) NULL, / updateStringProc */
36			SetIndexFromAny /* setFromAnyProc */
37			};
38
39			/*
40			* Boolean flag indicating whether or not the tclIndexType object
41			* type has been registered with the Tcl compiler.
42			*/
43
44			static int indexTypeInitialized = 0;
45
46			/*
47			*----------------------------------------------------------------------
48			*
49			* Tcl_GetIndexFromObj --
50			*
51			* This procedure looks up an object's value in a table of strings
52			* and returns the index of the matching string, if any.
53			*
54			* Results:
55			*
56			* If the value of objPtr is identical to or a unique abbreviation
57			* for one of the entries in objPtr, then the return value is
58			* TCL_OK and the index of the matching entry is stored at
59			* *indexPtr. If there isn't a proper match, then TCL_ERROR is
60			* returned and an error message is left in interp's result (unless
61			* interp is NULL). The msg argument is used in the error
62			* message; for example, if msg has the value "option" then the
63			* error message will say something flag 'bad option "foo": must be
64			* ...'
65			*
66			* Side effects:
67			* The result of the lookup is cached as the internal rep of
68			* objPtr, so that repeated lookups can be done quickly.
69			*
70			*----------------------------------------------------------------------
71			*/
72
73			int
74			Tcl_GetIndexFromObj(interp, objPtr, tablePtr, msg, flags, indexPtr)
75			Tcl_Interp interp; / Used for error reporting if not NULL. */
76			Tcl_Obj objPtr; / Object containing the string to lookup. */
77			char *tablePtr; / Array of strings to compare against the
78			* value of objPtr; last entry must be NULL
79			* and there must not be duplicate entries. */
80			char msg; / Identifying word to use in error messages. */
81			int flags; /* 0 or TCL_EXACT */
82			int indexPtr; / Place to store resulting integer index. */
83			{
84
85			/*
86			* See if there is a valid cached result from a previous lookup
87			* (doing the check here saves the overhead of calling
88			* Tcl_GetIndexFromObjStruct in the common case where the result
89			* is cached).
90			*/
91
92			if ((objPtr->typePtr == &tclIndexType)
93			&& (objPtr->internalRep.twoPtrValue.ptr1 == (VOID *) tablePtr)) {
94			*indexPtr = (int) objPtr->internalRep.twoPtrValue.ptr2;
95			return TCL_OK;
96			}
97			return Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, sizeof(char *),
98			msg, flags, indexPtr);
99			}
100
101			/*
102			*----------------------------------------------------------------------
103			*
104			* Tcl_GetIndexFromObjStruct --
105			*
106			* This procedure looks up an object's value given a starting
107			* string and an offset for the amount of space between strings.
108			* This is useful when the strings are embedded in some other
109			* kind of array.
110			*
111			* Results:
112			*
113			* If the value of objPtr is identical to or a unique abbreviation
114			* for one of the entries in objPtr, then the return value is
115			* TCL_OK and the index of the matching entry is stored at
116			* *indexPtr. If there isn't a proper match, then TCL_ERROR is
117			* returned and an error message is left in interp's result (unless
118			* interp is NULL). The msg argument is used in the error
119			* message; for example, if msg has the value "option" then the
120			* error message will say something flag 'bad option "foo": must be
121			* ...'
122			*
123			* Side effects:
124			* The result of the lookup is cached as the internal rep of
125			* objPtr, so that repeated lookups can be done quickly.
126			*
127			*----------------------------------------------------------------------
128			*/
129
130			int
131			Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags,
132			indexPtr)
133			Tcl_Interp interp; / Used for error reporting if not NULL. */
134			Tcl_Obj objPtr; / Object containing the string to lookup. */
135			char *tablePtr; / The first string in the table. The second
136			* string will be at this address plus the
137			* offset, the third plus the offset again,
138			* etc. The last entry must be NULL
139			* and there must not be duplicate entries. */
140			int offset; /* The number of bytes between entries */
141			char msg; / Identifying word to use in error messages. */
142			int flags; /* 0 or TCL_EXACT */
143			int indexPtr; / Place to store resulting integer index. */
144			{
145			int index, length, i, numAbbrev;
146			char key, p1, p2, *entryPtr;
147			Tcl_Obj *resultPtr;
148
149			/*
150			* See if there is a valid cached result from a previous lookup.
151			*/
152
153			if ((objPtr->typePtr == &tclIndexType)
154			&& (objPtr->internalRep.twoPtrValue.ptr1 == (VOID *) tablePtr)) {
155			*indexPtr = (int) objPtr->internalRep.twoPtrValue.ptr2;
156			return TCL_OK;
157			}
158
159			/*
160			* Lookup the value of the object in the table. Accept unique
161			* abbreviations unless TCL_EXACT is set in flags.
162			*/
163
164			if (!indexTypeInitialized) {
165			/*
166			* This is the first time we've done a lookup. Register the
167			* tclIndexType.
168			*/
169
170			Tcl_RegisterObjType(&tclIndexType);
171			indexTypeInitialized = 1;
172			}
173
174			key = Tcl_GetStringFromObj(objPtr, &length);
175			index = -1;
176			numAbbrev = 0;
177
178			/*
179			* The key should not be empty, otherwise it's not a match.
180			*/
181
182			if (key[0] == '\0') {
183			goto error;
184			}
185
186			for (entryPtr = tablePtr, i = 0; *entryPtr != NULL;
187			entryPtr = (char **) ((long) entryPtr + offset), i++) {
188			for (p1 = key, p2 = entryPtr; p1 == *p2; p1++, p2++) {
189			if (*p1 == 0) {
190			index = i;
191			goto done;
192			}
193			}
194			if (*p1 == 0) {
195			/*
196			* The value is an abbreviation for this entry. Continue
197			* checking other entries to make sure it's unique. If we
198			* get more than one unique abbreviation, keep searching to
199			* see if there is an exact match, but remember the number
200			* of unique abbreviations and don't allow either.
201			*/
202
203			numAbbrev++;
204			index = i;
205			}
206			}
207			if ((flags & TCL_EXACT) \|\| (numAbbrev != 1)) {
208			goto error;
209			}
210
211			done:
212			if ((objPtr->typePtr != NULL)
213			&& (objPtr->typePtr->freeIntRepProc != NULL)) {
214			objPtr->typePtr->freeIntRepProc(objPtr);
215			}
216			objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) tablePtr;
217			objPtr->internalRep.twoPtrValue.ptr2 = (VOID *) index;
218			objPtr->typePtr = &tclIndexType;
219			*indexPtr = index;
220			return TCL_OK;
221
222			error:
223			if (interp != NULL) {
224			int count;
225			resultPtr = Tcl_GetObjResult(interp);
226			Tcl_AppendStringsToObj(resultPtr,
227			(numAbbrev > 1) ? "ambiguous " : "bad ", msg, " \"",
228			key, "\": must be ", tablePtr, (char ) NULL);
229			for (entryPtr = (char **) ((long) tablePtr + offset), count = 0;
230			*entryPtr != NULL;
231			entryPtr = (char **) ((long) entryPtr + offset), count++) {
232			if ((((char *) ((long) entryPtr + offset))) == NULL) {
233			Tcl_AppendStringsToObj(resultPtr,
234			(count > 0) ? ", or " : " or ", *entryPtr,
235			(char *) NULL);
236			} else {
237			Tcl_AppendStringsToObj(resultPtr, ", ", *entryPtr,
238			(char *) NULL);
239			}
240			}
241			}
242			return TCL_ERROR;
243			}
244
245			/*
246			*----------------------------------------------------------------------
247			*
248			* SetIndexFromAny --
249			*
250			* This procedure is called to convert a Tcl object to index
251			* internal form. However, this doesn't make sense (need to have a
252			* table of keywords in order to do the conversion) so the
253			* procedure always generates an error.
254			*
255			* Results:
256			* The return value is always TCL_ERROR, and an error message is
257			* left in interp's result if interp isn't NULL.
258			*
259			* Side effects:
260			* None.
261			*
262			*----------------------------------------------------------------------
263			*/
264
265			static int
266			SetIndexFromAny(interp, objPtr)
267			Tcl_Interp interp; / Used for error reporting if not NULL. */
268			register Tcl_Obj objPtr; / The object to convert. */
269			{
270			Tcl_AppendToObj(Tcl_GetObjResult(interp),
271			"can't convert value to index except via Tcl_GetIndexFromObj API",
272			-1);
273			return TCL_ERROR;
274			}
275
276			/*
277			*----------------------------------------------------------------------
278			*
279			* Tcl_WrongNumArgs --
280			*
281			* This procedure generates a "wrong # args" error message in an
282			* interpreter. It is used as a utility function by many command
283			* procedures.
284			*
285			* Results:
286			* None.
287			*
288			* Side effects:
289			* An error message is generated in interp's result object to
290			* indicate that a command was invoked with the wrong number of
291			* arguments. The message has the form
292			* wrong # args: should be "foo bar additional stuff"
293			* where "foo" and "bar" are the initial objects in objv (objc
294			* determines how many of these are printed) and "additional stuff"
295			* is the contents of the message argument.
296			*
297			*----------------------------------------------------------------------
298			*/
299
300			void
301			Tcl_WrongNumArgs(interp, objc, objv, message)
302			Tcl_Interp interp; / Current interpreter. */
303			int objc; /* Number of arguments to print
304			* from objv. */
305			Tcl_Obj CONST objv[]; / Initial argument objects, which
306			* should be included in the error
307			* message. */
308			char message; / Error message to print after the
309			* leading objects in objv. The
310			* message may be NULL. */
311			{
312			Tcl_Obj *objPtr;
313			char **tablePtr;
314			int i;
315
316			objPtr = Tcl_GetObjResult(interp);
317			Tcl_AppendToObj(objPtr, "wrong # args: should be \"", -1);
318			for (i = 0; i < objc; i++) {
319			/*
320			* If the object is an index type use the index table which allows
321			* for the correct error message even if the subcommand was
322			* abbreviated. Otherwise, just use the string rep.
323			*/
324
325			if (objv[i]->typePtr == &tclIndexType) {
326			tablePtr = ((char **) objv[i]->internalRep.twoPtrValue.ptr1);
327			Tcl_AppendStringsToObj(objPtr,
328			tablePtr[(int) objv[i]->internalRep.twoPtrValue.ptr2],
329			(char *) NULL);
330			} else {
331			Tcl_AppendStringsToObj(objPtr, Tcl_GetString(objv[i]),
332			(char *) NULL);
333			}
334			if (i < (objc - 1)) {
335			Tcl_AppendStringsToObj(objPtr, " ", (char *) NULL);
336			}
337			}
338			if (message) {
339			Tcl_AppendStringsToObj(objPtr, " ", message, (char *) NULL);
340			}
341			Tcl_AppendStringsToObj(objPtr, "\"", (char *) NULL);
342			}
343
344			/* End of tclindexobj.c */