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