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