src/c_tcl_base_7_5_w_mods/tclindexobj.c

/* $Header: /cvsroot/esrg/sfesrg/esrgpcpj/shared/tcl_base/tclindexobj.c,v 1.1.1.1 2001/06/13 04:39:30 dtashley Exp $ */

/* 
 * 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);
}


/* $History: tclindexobj.c $
 * 
 * *****************  Version 1  *****************
 * User: Dtashley     Date: 1/02/01    Time: 1:30a
 * Created in $/IjuScripter, IjuConsole/Source/Tcl Base
 * Initial check-in.
 */ 

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