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