shared_source/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	/* $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 */