1 | /* |
---|
2 | * tclCmdMZ.c -- |
---|
3 | * |
---|
4 | * This file contains the top-level command routines for most of |
---|
5 | * the Tcl built-in commands whose names begin with the letters |
---|
6 | * M to Z. It contains only commands in the generic core (i.e. |
---|
7 | * those that don't depend much upon UNIX facilities). |
---|
8 | * |
---|
9 | * Copyright (c) 1987-1993 The Regents of the University of California. |
---|
10 | * Copyright (c) 1994-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: tclCmdMZ.c,v 1.1 2008-06-04 13:58:04 demin Exp $ |
---|
16 | */ |
---|
17 | |
---|
18 | #include "tclInt.h" |
---|
19 | #include "tclPort.h" |
---|
20 | #include "tclCompile.h" |
---|
21 | |
---|
22 | /* |
---|
23 | * Structure used to hold information about variable traces: |
---|
24 | */ |
---|
25 | |
---|
26 | typedef struct { |
---|
27 | int flags; /* Operations for which Tcl command is |
---|
28 | * to be invoked. */ |
---|
29 | char *errMsg; /* Error message returned from Tcl command, |
---|
30 | * or NULL. Malloc'ed. */ |
---|
31 | int length; /* Number of non-NULL chars. in command. */ |
---|
32 | char command[4]; /* Space for Tcl command to invoke. Actual |
---|
33 | * size will be as large as necessary to |
---|
34 | * hold command. This field must be the |
---|
35 | * last in the structure, so that it can |
---|
36 | * be larger than 4 bytes. */ |
---|
37 | } TraceVarInfo; |
---|
38 | |
---|
39 | /* |
---|
40 | * Forward declarations for procedures defined in this file: |
---|
41 | */ |
---|
42 | |
---|
43 | static char * TraceVarProc _ANSI_ARGS_((ClientData clientData, |
---|
44 | Tcl_Interp *interp, char *name1, char *name2, |
---|
45 | int flags)); |
---|
46 | |
---|
47 | /* |
---|
48 | *---------------------------------------------------------------------- |
---|
49 | * |
---|
50 | * Tcl_ReturnObjCmd -- |
---|
51 | * |
---|
52 | * This object-based procedure is invoked to process the "return" Tcl |
---|
53 | * command. See the user documentation for details on what it does. |
---|
54 | * |
---|
55 | * Results: |
---|
56 | * A standard Tcl object result. |
---|
57 | * |
---|
58 | * Side effects: |
---|
59 | * See the user documentation. |
---|
60 | * |
---|
61 | *---------------------------------------------------------------------- |
---|
62 | */ |
---|
63 | |
---|
64 | /* ARGSUSED */ |
---|
65 | int |
---|
66 | Tcl_ReturnObjCmd(dummy, interp, objc, objv) |
---|
67 | ClientData dummy; /* Not used. */ |
---|
68 | Tcl_Interp *interp; /* Current interpreter. */ |
---|
69 | int objc; /* Number of arguments. */ |
---|
70 | Tcl_Obj *CONST objv[]; /* Argument objects. */ |
---|
71 | { |
---|
72 | Interp *iPtr = (Interp *) interp; |
---|
73 | int optionLen, argLen, code, result; |
---|
74 | |
---|
75 | if (iPtr->errorInfo != NULL) { |
---|
76 | ckfree(iPtr->errorInfo); |
---|
77 | iPtr->errorInfo = NULL; |
---|
78 | } |
---|
79 | if (iPtr->errorCode != NULL) { |
---|
80 | ckfree(iPtr->errorCode); |
---|
81 | iPtr->errorCode = NULL; |
---|
82 | } |
---|
83 | code = TCL_OK; |
---|
84 | |
---|
85 | /* |
---|
86 | * THIS FAILS IF AN OBJECT CONTAINS AN EMBEDDED NULL. |
---|
87 | */ |
---|
88 | |
---|
89 | for (objv++, objc--; objc > 1; objv += 2, objc -= 2) { |
---|
90 | char *option = Tcl_GetStringFromObj(objv[0], &optionLen); |
---|
91 | char *arg = Tcl_GetStringFromObj(objv[1], &argLen); |
---|
92 | |
---|
93 | if (strcmp(option, "-code") == 0) { |
---|
94 | register int c = arg[0]; |
---|
95 | if ((c == 'o') && (strcmp(arg, "ok") == 0)) { |
---|
96 | code = TCL_OK; |
---|
97 | } else if ((c == 'e') && (strcmp(arg, "error") == 0)) { |
---|
98 | code = TCL_ERROR; |
---|
99 | } else if ((c == 'r') && (strcmp(arg, "return") == 0)) { |
---|
100 | code = TCL_RETURN; |
---|
101 | } else if ((c == 'b') && (strcmp(arg, "break") == 0)) { |
---|
102 | code = TCL_BREAK; |
---|
103 | } else if ((c == 'c') && (strcmp(arg, "continue") == 0)) { |
---|
104 | code = TCL_CONTINUE; |
---|
105 | } else { |
---|
106 | result = Tcl_GetIntFromObj((Tcl_Interp *) NULL, objv[1], |
---|
107 | &code); |
---|
108 | if (result != TCL_OK) { |
---|
109 | Tcl_ResetResult(interp); |
---|
110 | Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), |
---|
111 | "bad completion code \"", |
---|
112 | Tcl_GetStringFromObj(objv[1], (int *) NULL), |
---|
113 | "\": must be ok, error, return, break, ", |
---|
114 | "continue, or an integer", (char *) NULL); |
---|
115 | return result; |
---|
116 | } |
---|
117 | } |
---|
118 | } else if (strcmp(option, "-errorinfo") == 0) { |
---|
119 | iPtr->errorInfo = |
---|
120 | (char *) ckalloc((unsigned) (strlen(arg) + 1)); |
---|
121 | strcpy(iPtr->errorInfo, arg); |
---|
122 | } else if (strcmp(option, "-errorcode") == 0) { |
---|
123 | iPtr->errorCode = |
---|
124 | (char *) ckalloc((unsigned) (strlen(arg) + 1)); |
---|
125 | strcpy(iPtr->errorCode, arg); |
---|
126 | } else { |
---|
127 | Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), |
---|
128 | "bad option \"", option, |
---|
129 | "\": must be -code, -errorcode, or -errorinfo", |
---|
130 | (char *) NULL); |
---|
131 | return TCL_ERROR; |
---|
132 | } |
---|
133 | } |
---|
134 | |
---|
135 | if (objc == 1) { |
---|
136 | /* |
---|
137 | * Set the interpreter's object result. An inline version of |
---|
138 | * Tcl_SetObjResult. |
---|
139 | */ |
---|
140 | |
---|
141 | Tcl_SetObjResult(interp, objv[0]); |
---|
142 | } |
---|
143 | iPtr->returnCode = code; |
---|
144 | return TCL_RETURN; |
---|
145 | } |
---|
146 | |
---|
147 | /* |
---|
148 | *---------------------------------------------------------------------- |
---|
149 | * |
---|
150 | * Tcl_ScanCmd -- |
---|
151 | * |
---|
152 | * This procedure is invoked to process the "scan" Tcl command. |
---|
153 | * See the user documentation for details on what it does. |
---|
154 | * |
---|
155 | * Results: |
---|
156 | * A standard Tcl result. |
---|
157 | * |
---|
158 | * Side effects: |
---|
159 | * See the user documentation. |
---|
160 | * |
---|
161 | *---------------------------------------------------------------------- |
---|
162 | */ |
---|
163 | |
---|
164 | /* ARGSUSED */ |
---|
165 | int |
---|
166 | Tcl_ScanCmd(dummy, interp, argc, argv) |
---|
167 | ClientData dummy; /* Not used. */ |
---|
168 | Tcl_Interp *interp; /* Current interpreter. */ |
---|
169 | int argc; /* Number of arguments. */ |
---|
170 | char **argv; /* Argument strings. */ |
---|
171 | { |
---|
172 | # define MAX_FIELDS 20 |
---|
173 | typedef struct { |
---|
174 | char fmt; /* Format for field. */ |
---|
175 | int size; /* How many bytes to allow for |
---|
176 | * field. */ |
---|
177 | char *location; /* Where field will be stored. */ |
---|
178 | } Field; |
---|
179 | Field fields[MAX_FIELDS]; /* Info about all the fields in the |
---|
180 | * format string. */ |
---|
181 | register Field *curField; |
---|
182 | int numFields = 0; /* Number of fields actually |
---|
183 | * specified. */ |
---|
184 | int suppress; /* Current field is assignment- |
---|
185 | * suppressed. */ |
---|
186 | int totalSize = 0; /* Number of bytes needed to store |
---|
187 | * all results combined. */ |
---|
188 | char *results; /* Where scanned output goes. |
---|
189 | * Malloced; NULL means not allocated |
---|
190 | * yet. */ |
---|
191 | int numScanned; /* sscanf's result. */ |
---|
192 | register char *fmt; |
---|
193 | int i, widthSpecified, length, code; |
---|
194 | char buf[40]; |
---|
195 | |
---|
196 | /* |
---|
197 | * The variables below are used to hold a copy of the format |
---|
198 | * string, so that we can replace format specifiers like "%f" |
---|
199 | * and "%F" with specifiers like "%lf" |
---|
200 | */ |
---|
201 | |
---|
202 | # define STATIC_SIZE 5 |
---|
203 | char copyBuf[STATIC_SIZE], *fmtCopy; |
---|
204 | register char *dst; |
---|
205 | |
---|
206 | if (argc < 3) { |
---|
207 | Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], |
---|
208 | " string format ?varName varName ...?\"", (char *) NULL); |
---|
209 | return TCL_ERROR; |
---|
210 | } |
---|
211 | |
---|
212 | /* |
---|
213 | * This procedure operates in four stages: |
---|
214 | * 1. Scan the format string, collecting information about each field. |
---|
215 | * 2. Allocate an array to hold all of the scanned fields. |
---|
216 | * 3. Call sscanf to do all the dirty work, and have it store the |
---|
217 | * parsed fields in the array. |
---|
218 | * 4. Pick off the fields from the array and assign them to variables. |
---|
219 | */ |
---|
220 | |
---|
221 | code = TCL_OK; |
---|
222 | results = NULL; |
---|
223 | length = strlen(argv[2]) * 2 + 1; |
---|
224 | if (length < STATIC_SIZE) { |
---|
225 | fmtCopy = copyBuf; |
---|
226 | } else { |
---|
227 | fmtCopy = (char *) ckalloc((unsigned) length); |
---|
228 | } |
---|
229 | dst = fmtCopy; |
---|
230 | for (fmt = argv[2]; *fmt != 0; fmt++) { |
---|
231 | *dst = *fmt; |
---|
232 | dst++; |
---|
233 | if (*fmt != '%') { |
---|
234 | continue; |
---|
235 | } |
---|
236 | fmt++; |
---|
237 | if (*fmt == '%') { |
---|
238 | *dst = *fmt; |
---|
239 | dst++; |
---|
240 | continue; |
---|
241 | } |
---|
242 | if (*fmt == '*') { |
---|
243 | suppress = 1; |
---|
244 | *dst = *fmt; |
---|
245 | dst++; |
---|
246 | fmt++; |
---|
247 | } else { |
---|
248 | suppress = 0; |
---|
249 | } |
---|
250 | widthSpecified = 0; |
---|
251 | while (isdigit(UCHAR(*fmt))) { |
---|
252 | widthSpecified = 1; |
---|
253 | *dst = *fmt; |
---|
254 | dst++; |
---|
255 | fmt++; |
---|
256 | } |
---|
257 | if ((*fmt == 'l') || (*fmt == 'h') || (*fmt == 'L')) { |
---|
258 | fmt++; |
---|
259 | } |
---|
260 | *dst = *fmt; |
---|
261 | dst++; |
---|
262 | if (suppress) { |
---|
263 | continue; |
---|
264 | } |
---|
265 | if (numFields == MAX_FIELDS) { |
---|
266 | Tcl_SetResult(interp, "too many fields to scan", TCL_STATIC); |
---|
267 | code = TCL_ERROR; |
---|
268 | goto done; |
---|
269 | } |
---|
270 | curField = &fields[numFields]; |
---|
271 | numFields++; |
---|
272 | switch (*fmt) { |
---|
273 | case 'd': |
---|
274 | case 'i': |
---|
275 | case 'o': |
---|
276 | case 'x': |
---|
277 | curField->fmt = 'd'; |
---|
278 | curField->size = sizeof(int); |
---|
279 | break; |
---|
280 | |
---|
281 | case 'u': |
---|
282 | curField->fmt = 'u'; |
---|
283 | curField->size = sizeof(int); |
---|
284 | break; |
---|
285 | |
---|
286 | case 's': |
---|
287 | curField->fmt = 's'; |
---|
288 | curField->size = strlen(argv[1]) + 1; |
---|
289 | break; |
---|
290 | |
---|
291 | case 'c': |
---|
292 | if (widthSpecified) { |
---|
293 | Tcl_SetResult(interp, |
---|
294 | "field width may not be specified in %c conversion", |
---|
295 | TCL_STATIC); |
---|
296 | code = TCL_ERROR; |
---|
297 | goto done; |
---|
298 | } |
---|
299 | curField->fmt = 'c'; |
---|
300 | curField->size = sizeof(int); |
---|
301 | break; |
---|
302 | |
---|
303 | case 'e': |
---|
304 | case 'f': |
---|
305 | case 'g': |
---|
306 | dst[-1] = 'l'; |
---|
307 | dst[0] = 'f'; |
---|
308 | dst++; |
---|
309 | curField->fmt = 'f'; |
---|
310 | curField->size = sizeof(double); |
---|
311 | break; |
---|
312 | |
---|
313 | case '[': |
---|
314 | curField->fmt = 's'; |
---|
315 | curField->size = strlen(argv[1]) + 1; |
---|
316 | do { |
---|
317 | fmt++; |
---|
318 | if (*fmt == 0) { |
---|
319 | Tcl_SetResult(interp, |
---|
320 | "unmatched [ in format string", TCL_STATIC); |
---|
321 | code = TCL_ERROR; |
---|
322 | goto done; |
---|
323 | } |
---|
324 | *dst = *fmt; |
---|
325 | dst++; |
---|
326 | } while (*fmt != ']'); |
---|
327 | break; |
---|
328 | |
---|
329 | default: |
---|
330 | { |
---|
331 | char buf[50]; |
---|
332 | |
---|
333 | sprintf(buf, "bad scan conversion character \"%c\"", *fmt); |
---|
334 | Tcl_SetResult(interp, buf, TCL_VOLATILE); |
---|
335 | code = TCL_ERROR; |
---|
336 | goto done; |
---|
337 | } |
---|
338 | } |
---|
339 | curField->size = TCL_ALIGN(curField->size); |
---|
340 | totalSize += curField->size; |
---|
341 | } |
---|
342 | *dst = 0; |
---|
343 | |
---|
344 | if (numFields != (argc-3)) { |
---|
345 | Tcl_SetResult(interp, |
---|
346 | "different numbers of variable names and field specifiers", |
---|
347 | TCL_STATIC); |
---|
348 | code = TCL_ERROR; |
---|
349 | goto done; |
---|
350 | } |
---|
351 | |
---|
352 | /* |
---|
353 | * Step 2: |
---|
354 | */ |
---|
355 | |
---|
356 | results = (char *) ckalloc((unsigned) totalSize); |
---|
357 | for (i = 0, totalSize = 0, curField = fields; |
---|
358 | i < numFields; i++, curField++) { |
---|
359 | curField->location = results + totalSize; |
---|
360 | totalSize += curField->size; |
---|
361 | } |
---|
362 | |
---|
363 | /* |
---|
364 | * Fill in the remaining fields with NULL; the only purpose of |
---|
365 | * this is to keep some memory analyzers, like Purify, from |
---|
366 | * complaining. |
---|
367 | */ |
---|
368 | |
---|
369 | for ( ; i < MAX_FIELDS; i++, curField++) { |
---|
370 | curField->location = NULL; |
---|
371 | } |
---|
372 | |
---|
373 | /* |
---|
374 | * Step 3: |
---|
375 | */ |
---|
376 | |
---|
377 | numScanned = sscanf(argv[1], fmtCopy, |
---|
378 | fields[0].location, fields[1].location, fields[2].location, |
---|
379 | fields[3].location, fields[4].location, fields[5].location, |
---|
380 | fields[6].location, fields[7].location, fields[8].location, |
---|
381 | fields[9].location, fields[10].location, fields[11].location, |
---|
382 | fields[12].location, fields[13].location, fields[14].location, |
---|
383 | fields[15].location, fields[16].location, fields[17].location, |
---|
384 | fields[18].location, fields[19].location); |
---|
385 | |
---|
386 | /* |
---|
387 | * Step 4: |
---|
388 | */ |
---|
389 | |
---|
390 | if (numScanned < numFields) { |
---|
391 | numFields = numScanned; |
---|
392 | } |
---|
393 | for (i = 0, curField = fields; i < numFields; i++, curField++) { |
---|
394 | switch (curField->fmt) { |
---|
395 | char string[TCL_DOUBLE_SPACE]; |
---|
396 | |
---|
397 | case 'd': |
---|
398 | TclFormatInt(string, *((int *) curField->location)); |
---|
399 | if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) { |
---|
400 | storeError: |
---|
401 | Tcl_AppendResult(interp, |
---|
402 | "couldn't set variable \"", argv[i+3], "\"", |
---|
403 | (char *) NULL); |
---|
404 | code = TCL_ERROR; |
---|
405 | goto done; |
---|
406 | } |
---|
407 | break; |
---|
408 | |
---|
409 | case 'u': |
---|
410 | sprintf(string, "%u", *((int *) curField->location)); |
---|
411 | if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) { |
---|
412 | goto storeError; |
---|
413 | } |
---|
414 | break; |
---|
415 | |
---|
416 | case 'c': |
---|
417 | TclFormatInt(string, *((char *) curField->location) & 0xff); |
---|
418 | if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) { |
---|
419 | goto storeError; |
---|
420 | } |
---|
421 | break; |
---|
422 | |
---|
423 | case 's': |
---|
424 | if (Tcl_SetVar(interp, argv[i+3], curField->location, 0) |
---|
425 | == NULL) { |
---|
426 | goto storeError; |
---|
427 | } |
---|
428 | break; |
---|
429 | |
---|
430 | case 'f': |
---|
431 | Tcl_PrintDouble((Tcl_Interp *) NULL, |
---|
432 | *((double *) curField->location), string); |
---|
433 | if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) { |
---|
434 | goto storeError; |
---|
435 | } |
---|
436 | break; |
---|
437 | } |
---|
438 | } |
---|
439 | TclFormatInt(buf, numScanned); |
---|
440 | Tcl_SetResult(interp, buf, TCL_VOLATILE); |
---|
441 | done: |
---|
442 | if (results != NULL) { |
---|
443 | ckfree(results); |
---|
444 | } |
---|
445 | if (fmtCopy != copyBuf) { |
---|
446 | ckfree(fmtCopy); |
---|
447 | } |
---|
448 | return code; |
---|
449 | } |
---|
450 | |
---|
451 | /* |
---|
452 | *---------------------------------------------------------------------- |
---|
453 | * |
---|
454 | * Tcl_SplitObjCmd -- |
---|
455 | * |
---|
456 | * This procedure is invoked to process the "split" Tcl command. |
---|
457 | * See the user documentation for details on what it does. |
---|
458 | * |
---|
459 | * Results: |
---|
460 | * A standard Tcl result. |
---|
461 | * |
---|
462 | * Side effects: |
---|
463 | * See the user documentation. |
---|
464 | * |
---|
465 | *---------------------------------------------------------------------- |
---|
466 | */ |
---|
467 | |
---|
468 | /* ARGSUSED */ |
---|
469 | int |
---|
470 | Tcl_SplitObjCmd(dummy, interp, objc, objv) |
---|
471 | ClientData dummy; /* Not used. */ |
---|
472 | Tcl_Interp *interp; /* Current interpreter. */ |
---|
473 | int objc; /* Number of arguments. */ |
---|
474 | Tcl_Obj *CONST objv[]; /* Argument objects. */ |
---|
475 | { |
---|
476 | register char *p, *p2; |
---|
477 | char *splitChars, *string, *elementStart; |
---|
478 | int splitCharLen, stringLen, i, j; |
---|
479 | Tcl_Obj *listPtr; |
---|
480 | |
---|
481 | if (objc == 2) { |
---|
482 | splitChars = " \n\t\r"; |
---|
483 | splitCharLen = 4; |
---|
484 | } else if (objc == 3) { |
---|
485 | splitChars = Tcl_GetStringFromObj(objv[2], &splitCharLen); |
---|
486 | } else { |
---|
487 | Tcl_WrongNumArgs(interp, 1, objv, "string ?splitChars?"); |
---|
488 | return TCL_ERROR; |
---|
489 | } |
---|
490 | |
---|
491 | string = Tcl_GetStringFromObj(objv[1], &stringLen); |
---|
492 | listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); |
---|
493 | |
---|
494 | /* |
---|
495 | * Handle the special case of splitting on every character. |
---|
496 | */ |
---|
497 | |
---|
498 | if (splitCharLen == 0) { |
---|
499 | for (i = 0, p = string; i < stringLen; i++, p++) { |
---|
500 | Tcl_ListObjAppendElement(interp, listPtr, |
---|
501 | Tcl_NewStringObj(p, 1)); |
---|
502 | } |
---|
503 | } else { |
---|
504 | /* |
---|
505 | * Normal case: split on any of a given set of characters. |
---|
506 | * Discard instances of the split characters. |
---|
507 | */ |
---|
508 | |
---|
509 | for (i = 0, p = elementStart = string; i < stringLen; i++, p++) { |
---|
510 | for (j = 0, p2 = splitChars; j < splitCharLen; j++, p2++) { |
---|
511 | if (*p2 == *p) { |
---|
512 | Tcl_ListObjAppendElement(interp, listPtr, |
---|
513 | Tcl_NewStringObj(elementStart, (p-elementStart))); |
---|
514 | elementStart = p+1; |
---|
515 | break; |
---|
516 | } |
---|
517 | } |
---|
518 | } |
---|
519 | if (p != string) { |
---|
520 | int remainingChars = stringLen - (elementStart-string); |
---|
521 | Tcl_ListObjAppendElement(interp, listPtr, |
---|
522 | Tcl_NewStringObj(elementStart, remainingChars)); |
---|
523 | } |
---|
524 | } |
---|
525 | |
---|
526 | Tcl_SetObjResult(interp, listPtr); |
---|
527 | return TCL_OK; |
---|
528 | } |
---|
529 | |
---|
530 | /* |
---|
531 | *---------------------------------------------------------------------- |
---|
532 | * |
---|
533 | * Tcl_StringObjCmd -- |
---|
534 | * |
---|
535 | * This procedure is invoked to process the "string" Tcl command. |
---|
536 | * See the user documentation for details on what it does. |
---|
537 | * |
---|
538 | * Results: |
---|
539 | * A standard Tcl result. |
---|
540 | * |
---|
541 | * Side effects: |
---|
542 | * See the user documentation. |
---|
543 | * |
---|
544 | *---------------------------------------------------------------------- |
---|
545 | */ |
---|
546 | |
---|
547 | /* ARGSUSED */ |
---|
548 | int |
---|
549 | Tcl_StringObjCmd(dummy, interp, objc, objv) |
---|
550 | ClientData dummy; /* Not used. */ |
---|
551 | Tcl_Interp *interp; /* Current interpreter. */ |
---|
552 | int objc; /* Number of arguments. */ |
---|
553 | Tcl_Obj *CONST objv[]; /* Argument objects. */ |
---|
554 | { |
---|
555 | int index, left, right; |
---|
556 | Tcl_Obj *resultPtr; |
---|
557 | char *string1, *string2; |
---|
558 | int length1, length2; |
---|
559 | static char *options[] = { |
---|
560 | "compare", "first", "index", "last", |
---|
561 | "length", "match", "range", "tolower", |
---|
562 | "toupper", "trim", "trimleft", "trimright", |
---|
563 | "wordend", "wordstart", NULL |
---|
564 | }; |
---|
565 | enum options { |
---|
566 | STR_COMPARE, STR_FIRST, STR_INDEX, STR_LAST, |
---|
567 | STR_LENGTH, STR_MATCH, STR_RANGE, STR_TOLOWER, |
---|
568 | STR_TOUPPER, STR_TRIM, STR_TRIMLEFT, STR_TRIMRIGHT, |
---|
569 | STR_WORDEND, STR_WORDSTART |
---|
570 | }; |
---|
571 | |
---|
572 | if (objc < 2) { |
---|
573 | Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?"); |
---|
574 | return TCL_ERROR; |
---|
575 | } |
---|
576 | |
---|
577 | if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0, |
---|
578 | &index) != TCL_OK) { |
---|
579 | return TCL_ERROR; |
---|
580 | } |
---|
581 | |
---|
582 | resultPtr = Tcl_GetObjResult(interp); |
---|
583 | switch ((enum options) index) { |
---|
584 | case STR_COMPARE: { |
---|
585 | int match, length; |
---|
586 | |
---|
587 | if (objc != 4) { |
---|
588 | Tcl_WrongNumArgs(interp, 2, objv, "string1 string2"); |
---|
589 | return TCL_ERROR; |
---|
590 | } |
---|
591 | |
---|
592 | string1 = Tcl_GetStringFromObj(objv[2], &length1); |
---|
593 | string2 = Tcl_GetStringFromObj(objv[3], &length2); |
---|
594 | |
---|
595 | length = (length1 < length2) ? length1 : length2; |
---|
596 | match = memcmp(string1, string2, (unsigned) length); |
---|
597 | if (match == 0) { |
---|
598 | match = length1 - length2; |
---|
599 | } |
---|
600 | Tcl_SetIntObj(resultPtr, (match > 0) ? 1 : (match < 0) ? -1 : 0); |
---|
601 | break; |
---|
602 | } |
---|
603 | case STR_FIRST: { |
---|
604 | register char *p, *end; |
---|
605 | int match; |
---|
606 | |
---|
607 | if (objc != 4) { |
---|
608 | badFirstLastArgs: |
---|
609 | Tcl_WrongNumArgs(interp, 2, objv, "string1 string2"); |
---|
610 | return TCL_ERROR; |
---|
611 | } |
---|
612 | |
---|
613 | match = -1; |
---|
614 | string1 = Tcl_GetStringFromObj(objv[2], &length1); |
---|
615 | string2 = Tcl_GetStringFromObj(objv[3], &length2); |
---|
616 | if (length1 > 0) { |
---|
617 | end = string2 + length2 - length1 + 1; |
---|
618 | for (p = string2; p < end; p++) { |
---|
619 | /* |
---|
620 | * Scan forward to find the first character. |
---|
621 | */ |
---|
622 | |
---|
623 | p = memchr(p, *string1, (unsigned) (end - p)); |
---|
624 | if (p == NULL) { |
---|
625 | break; |
---|
626 | } |
---|
627 | if (memcmp(string1, p, (unsigned) length1) == 0) { |
---|
628 | match = p - string2; |
---|
629 | break; |
---|
630 | } |
---|
631 | } |
---|
632 | } |
---|
633 | Tcl_SetIntObj(resultPtr, match); |
---|
634 | break; |
---|
635 | } |
---|
636 | case STR_INDEX: { |
---|
637 | int index; |
---|
638 | |
---|
639 | if (objc != 4) { |
---|
640 | Tcl_WrongNumArgs(interp, 2, objv, "string charIndex"); |
---|
641 | return TCL_ERROR; |
---|
642 | } |
---|
643 | |
---|
644 | string1 = Tcl_GetStringFromObj(objv[2], &length1); |
---|
645 | if (Tcl_GetIntFromObj(interp, objv[3], &index) != TCL_OK) { |
---|
646 | return TCL_ERROR; |
---|
647 | } |
---|
648 | if ((index >= 0) && (index < length1)) { |
---|
649 | Tcl_SetStringObj(resultPtr, string1 + index, 1); |
---|
650 | } |
---|
651 | break; |
---|
652 | } |
---|
653 | case STR_LAST: { |
---|
654 | register char *p; |
---|
655 | int match; |
---|
656 | |
---|
657 | if (objc != 4) { |
---|
658 | goto badFirstLastArgs; |
---|
659 | } |
---|
660 | |
---|
661 | match = -1; |
---|
662 | string1 = Tcl_GetStringFromObj(objv[2], &length1); |
---|
663 | string2 = Tcl_GetStringFromObj(objv[3], &length2); |
---|
664 | if (length1 > 0) { |
---|
665 | for (p = string2 + length2 - length1; p >= string2; p--) { |
---|
666 | /* |
---|
667 | * Scan backwards to find the first character. |
---|
668 | */ |
---|
669 | |
---|
670 | while ((p != string2) && (*p != *string1)) { |
---|
671 | p--; |
---|
672 | } |
---|
673 | if (memcmp(string1, p, (unsigned) length1) == 0) { |
---|
674 | match = p - string2; |
---|
675 | break; |
---|
676 | } |
---|
677 | } |
---|
678 | } |
---|
679 | Tcl_SetIntObj(resultPtr, match); |
---|
680 | break; |
---|
681 | } |
---|
682 | case STR_LENGTH: { |
---|
683 | if (objc != 3) { |
---|
684 | Tcl_WrongNumArgs(interp, 2, objv, "string"); |
---|
685 | return TCL_ERROR; |
---|
686 | } |
---|
687 | |
---|
688 | (void) Tcl_GetStringFromObj(objv[2], &length1); |
---|
689 | Tcl_SetIntObj(resultPtr, length1); |
---|
690 | break; |
---|
691 | } |
---|
692 | case STR_MATCH: { |
---|
693 | if (objc != 4) { |
---|
694 | Tcl_WrongNumArgs(interp, 2, objv, "pattern string"); |
---|
695 | return TCL_ERROR; |
---|
696 | } |
---|
697 | |
---|
698 | string1 = Tcl_GetStringFromObj(objv[2], &length1); |
---|
699 | string2 = Tcl_GetStringFromObj(objv[3], &length2); |
---|
700 | Tcl_SetBooleanObj(resultPtr, Tcl_StringMatch(string2, string1)); |
---|
701 | break; |
---|
702 | } |
---|
703 | case STR_RANGE: { |
---|
704 | int first, last; |
---|
705 | |
---|
706 | if (objc != 5) { |
---|
707 | Tcl_WrongNumArgs(interp, 2, objv, "string first last"); |
---|
708 | return TCL_ERROR; |
---|
709 | } |
---|
710 | |
---|
711 | string1 = Tcl_GetStringFromObj(objv[2], &length1); |
---|
712 | if (TclGetIntForIndex(interp, objv[3], length1 - 1, |
---|
713 | &first) != TCL_OK) { |
---|
714 | return TCL_ERROR; |
---|
715 | } |
---|
716 | if (TclGetIntForIndex(interp, objv[4], length1 - 1, |
---|
717 | &last) != TCL_OK) { |
---|
718 | return TCL_ERROR; |
---|
719 | } |
---|
720 | if (first < 0) { |
---|
721 | first = 0; |
---|
722 | } |
---|
723 | if (last >= length1 - 1) { |
---|
724 | last = length1 - 1; |
---|
725 | } |
---|
726 | if (last >= first) { |
---|
727 | Tcl_SetStringObj(resultPtr, string1 + first, last - first + 1); |
---|
728 | } |
---|
729 | break; |
---|
730 | } |
---|
731 | case STR_TOLOWER: { |
---|
732 | register char *p, *end; |
---|
733 | |
---|
734 | if (objc != 3) { |
---|
735 | Tcl_WrongNumArgs(interp, 2, objv, "string"); |
---|
736 | return TCL_ERROR; |
---|
737 | } |
---|
738 | |
---|
739 | string1 = Tcl_GetStringFromObj(objv[2], &length1); |
---|
740 | |
---|
741 | /* |
---|
742 | * Since I know resultPtr is not a shared object, I can reach |
---|
743 | * in and diddle the bytes in its string rep to convert them in |
---|
744 | * place to lower case. |
---|
745 | */ |
---|
746 | |
---|
747 | Tcl_SetStringObj(resultPtr, string1, length1); |
---|
748 | string1 = Tcl_GetStringFromObj(resultPtr, &length1); |
---|
749 | end = string1 + length1; |
---|
750 | for (p = string1; p < end; p++) { |
---|
751 | if (isupper(UCHAR(*p))) { |
---|
752 | *p = (char) tolower(UCHAR(*p)); |
---|
753 | } |
---|
754 | } |
---|
755 | break; |
---|
756 | } |
---|
757 | case STR_TOUPPER: { |
---|
758 | register char *p, *end; |
---|
759 | |
---|
760 | if (objc != 3) { |
---|
761 | Tcl_WrongNumArgs(interp, 2, objv, "string"); |
---|
762 | return TCL_ERROR; |
---|
763 | } |
---|
764 | |
---|
765 | string1 = Tcl_GetStringFromObj(objv[2], &length1); |
---|
766 | |
---|
767 | /* |
---|
768 | * Since I know resultPtr is not a shared object, I can reach |
---|
769 | * in and diddle the bytes in its string rep to convert them in |
---|
770 | * place to upper case. |
---|
771 | */ |
---|
772 | |
---|
773 | Tcl_SetStringObj(resultPtr, string1, length1); |
---|
774 | string1 = Tcl_GetStringFromObj(resultPtr, &length1); |
---|
775 | end = string1 + length1; |
---|
776 | for (p = string1; p < end; p++) { |
---|
777 | if (islower(UCHAR(*p))) { |
---|
778 | *p = (char) toupper(UCHAR(*p)); |
---|
779 | } |
---|
780 | } |
---|
781 | break; |
---|
782 | } |
---|
783 | case STR_TRIM: { |
---|
784 | char ch; |
---|
785 | register char *p, *end; |
---|
786 | char *check, *checkEnd; |
---|
787 | |
---|
788 | left = 1; |
---|
789 | right = 1; |
---|
790 | |
---|
791 | trim: |
---|
792 | if (objc == 4) { |
---|
793 | string2 = Tcl_GetStringFromObj(objv[3], &length2); |
---|
794 | } else if (objc == 3) { |
---|
795 | string2 = " \t\n\r"; |
---|
796 | length2 = strlen(string2); |
---|
797 | } else { |
---|
798 | Tcl_WrongNumArgs(interp, 2, objv, "string ?chars?"); |
---|
799 | return TCL_ERROR; |
---|
800 | } |
---|
801 | string1 = Tcl_GetStringFromObj(objv[2], &length1); |
---|
802 | checkEnd = string2 + length2; |
---|
803 | |
---|
804 | if (left) { |
---|
805 | end = string1 + length1; |
---|
806 | for (p = string1; p < end; p++) { |
---|
807 | ch = *p; |
---|
808 | for (check = string2; ; check++) { |
---|
809 | if (check >= checkEnd) { |
---|
810 | p = end; |
---|
811 | break; |
---|
812 | } |
---|
813 | if (ch == *check) { |
---|
814 | length1--; |
---|
815 | string1++; |
---|
816 | break; |
---|
817 | } |
---|
818 | } |
---|
819 | } |
---|
820 | } |
---|
821 | if (right) { |
---|
822 | end = string1; |
---|
823 | for (p = string1 + length1; p > end; ) { |
---|
824 | p--; |
---|
825 | ch = *p; |
---|
826 | for (check = string2; ; check++) { |
---|
827 | if (check >= checkEnd) { |
---|
828 | p = end; |
---|
829 | break; |
---|
830 | } |
---|
831 | if (ch == *check) { |
---|
832 | length1--; |
---|
833 | break; |
---|
834 | } |
---|
835 | } |
---|
836 | } |
---|
837 | } |
---|
838 | Tcl_SetStringObj(resultPtr, string1, length1); |
---|
839 | break; |
---|
840 | } |
---|
841 | case STR_TRIMLEFT: { |
---|
842 | left = 1; |
---|
843 | right = 0; |
---|
844 | goto trim; |
---|
845 | } |
---|
846 | case STR_TRIMRIGHT: { |
---|
847 | left = 0; |
---|
848 | right = 1; |
---|
849 | goto trim; |
---|
850 | } |
---|
851 | case STR_WORDEND: { |
---|
852 | int cur, c; |
---|
853 | |
---|
854 | if (objc != 4) { |
---|
855 | Tcl_WrongNumArgs(interp, 2, objv, "string index"); |
---|
856 | return TCL_ERROR; |
---|
857 | } |
---|
858 | |
---|
859 | string1 = Tcl_GetStringFromObj(objv[2], &length1); |
---|
860 | if (Tcl_GetIntFromObj(interp, objv[3], &index) != TCL_OK) { |
---|
861 | return TCL_ERROR; |
---|
862 | } |
---|
863 | if (index < 0) { |
---|
864 | index = 0; |
---|
865 | } |
---|
866 | cur = length1; |
---|
867 | if (index < length1) { |
---|
868 | for (cur = index; cur < length1; cur++) { |
---|
869 | c = UCHAR(string1[cur]); |
---|
870 | if (!isalnum(c) && (c != '_')) { |
---|
871 | break; |
---|
872 | } |
---|
873 | } |
---|
874 | if (cur == index) { |
---|
875 | cur = index + 1; |
---|
876 | } |
---|
877 | } |
---|
878 | Tcl_SetIntObj(resultPtr, cur); |
---|
879 | break; |
---|
880 | } |
---|
881 | case STR_WORDSTART: { |
---|
882 | int cur, c; |
---|
883 | |
---|
884 | if (objc != 4) { |
---|
885 | Tcl_WrongNumArgs(interp, 2, objv, "string index"); |
---|
886 | return TCL_ERROR; |
---|
887 | } |
---|
888 | |
---|
889 | string1 = Tcl_GetStringFromObj(objv[2], &length1); |
---|
890 | if (Tcl_GetIntFromObj(interp, objv[3], &index) != TCL_OK) { |
---|
891 | return TCL_ERROR; |
---|
892 | } |
---|
893 | if (index >= length1) { |
---|
894 | index = length1 - 1; |
---|
895 | } |
---|
896 | cur = 0; |
---|
897 | if (index > 0) { |
---|
898 | for (cur = index; cur >= 0; cur--) { |
---|
899 | c = UCHAR(string1[cur]); |
---|
900 | if (!isalnum(c) && (c != '_')) { |
---|
901 | break; |
---|
902 | } |
---|
903 | } |
---|
904 | if (cur != index) { |
---|
905 | cur += 1; |
---|
906 | } |
---|
907 | } |
---|
908 | Tcl_SetIntObj(resultPtr, cur); |
---|
909 | break; |
---|
910 | } |
---|
911 | } |
---|
912 | return TCL_OK; |
---|
913 | } |
---|
914 | |
---|
915 | /* |
---|
916 | *---------------------------------------------------------------------- |
---|
917 | * |
---|
918 | * Tcl_SubstCmd -- |
---|
919 | * |
---|
920 | * This procedure is invoked to process the "subst" Tcl command. |
---|
921 | * See the user documentation for details on what it does. This |
---|
922 | * command is an almost direct copy of an implementation by |
---|
923 | * Andrew Payne. |
---|
924 | * |
---|
925 | * Results: |
---|
926 | * A standard Tcl result. |
---|
927 | * |
---|
928 | * Side effects: |
---|
929 | * See the user documentation. |
---|
930 | * |
---|
931 | *---------------------------------------------------------------------- |
---|
932 | */ |
---|
933 | |
---|
934 | /* ARGSUSED */ |
---|
935 | int |
---|
936 | Tcl_SubstCmd(dummy, interp, argc, argv) |
---|
937 | ClientData dummy; /* Not used. */ |
---|
938 | Tcl_Interp *interp; /* Current interpreter. */ |
---|
939 | int argc; /* Number of arguments. */ |
---|
940 | char **argv; /* Argument strings. */ |
---|
941 | { |
---|
942 | Interp *iPtr = (Interp *) interp; |
---|
943 | Tcl_DString result; |
---|
944 | char *p, *old, *value; |
---|
945 | int code, count, doVars, doCmds, doBackslashes, i; |
---|
946 | size_t length; |
---|
947 | char c; |
---|
948 | |
---|
949 | /* |
---|
950 | * Parse command-line options. |
---|
951 | */ |
---|
952 | |
---|
953 | doVars = doCmds = doBackslashes = 1; |
---|
954 | for (i = 1; i < (argc-1); i++) { |
---|
955 | p = argv[i]; |
---|
956 | if (*p != '-') { |
---|
957 | break; |
---|
958 | } |
---|
959 | length = strlen(p); |
---|
960 | if (length < 4) { |
---|
961 | badSwitch: |
---|
962 | Tcl_AppendResult(interp, "bad switch \"", p, |
---|
963 | "\": must be -nobackslashes, -nocommands, ", |
---|
964 | "or -novariables", (char *) NULL); |
---|
965 | return TCL_ERROR; |
---|
966 | } |
---|
967 | if ((p[3] == 'b') && (strncmp(p, "-nobackslashes", length) == 0)) { |
---|
968 | doBackslashes = 0; |
---|
969 | } else if ((p[3] == 'c') && (strncmp(p, "-nocommands", length) == 0)) { |
---|
970 | doCmds = 0; |
---|
971 | } else if ((p[3] == 'v') && (strncmp(p, "-novariables", length) == 0)) { |
---|
972 | doVars = 0; |
---|
973 | } else { |
---|
974 | goto badSwitch; |
---|
975 | } |
---|
976 | } |
---|
977 | if (i != (argc-1)) { |
---|
978 | Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], |
---|
979 | " ?-nobackslashes? ?-nocommands? ?-novariables? string\"", |
---|
980 | (char *) NULL); |
---|
981 | return TCL_ERROR; |
---|
982 | } |
---|
983 | |
---|
984 | /* |
---|
985 | * Scan through the string one character at a time, performing |
---|
986 | * command, variable, and backslash substitutions. |
---|
987 | */ |
---|
988 | |
---|
989 | Tcl_DStringInit(&result); |
---|
990 | old = p = argv[i]; |
---|
991 | while (*p != 0) { |
---|
992 | switch (*p) { |
---|
993 | case '\\': |
---|
994 | if (doBackslashes) { |
---|
995 | if (p != old) { |
---|
996 | Tcl_DStringAppend(&result, old, p-old); |
---|
997 | } |
---|
998 | c = Tcl_Backslash(p, &count); |
---|
999 | Tcl_DStringAppend(&result, &c, 1); |
---|
1000 | p += count; |
---|
1001 | old = p; |
---|
1002 | } else { |
---|
1003 | p++; |
---|
1004 | } |
---|
1005 | break; |
---|
1006 | |
---|
1007 | case '$': |
---|
1008 | if (doVars) { |
---|
1009 | if (p != old) { |
---|
1010 | Tcl_DStringAppend(&result, old, p-old); |
---|
1011 | } |
---|
1012 | value = Tcl_ParseVar(interp, p, &p); |
---|
1013 | if (value == NULL) { |
---|
1014 | Tcl_DStringFree(&result); |
---|
1015 | return TCL_ERROR; |
---|
1016 | } |
---|
1017 | Tcl_DStringAppend(&result, value, -1); |
---|
1018 | old = p; |
---|
1019 | } else { |
---|
1020 | p++; |
---|
1021 | } |
---|
1022 | break; |
---|
1023 | |
---|
1024 | case '[': |
---|
1025 | if (doCmds) { |
---|
1026 | if (p != old) { |
---|
1027 | Tcl_DStringAppend(&result, old, p-old); |
---|
1028 | } |
---|
1029 | iPtr->evalFlags = TCL_BRACKET_TERM; |
---|
1030 | code = Tcl_Eval(interp, p+1); |
---|
1031 | if (code == TCL_ERROR) { |
---|
1032 | Tcl_DStringFree(&result); |
---|
1033 | return code; |
---|
1034 | } |
---|
1035 | old = p = (p+1 + iPtr->termOffset+1); |
---|
1036 | Tcl_DStringAppend(&result, iPtr->result, -1); |
---|
1037 | Tcl_ResetResult(interp); |
---|
1038 | } else { |
---|
1039 | p++; |
---|
1040 | } |
---|
1041 | break; |
---|
1042 | |
---|
1043 | default: |
---|
1044 | p++; |
---|
1045 | break; |
---|
1046 | } |
---|
1047 | } |
---|
1048 | if (p != old) { |
---|
1049 | Tcl_DStringAppend(&result, old, p-old); |
---|
1050 | } |
---|
1051 | Tcl_DStringResult(interp, &result); |
---|
1052 | return TCL_OK; |
---|
1053 | } |
---|
1054 | |
---|
1055 | /* |
---|
1056 | *---------------------------------------------------------------------- |
---|
1057 | * |
---|
1058 | * Tcl_TraceCmd -- |
---|
1059 | * |
---|
1060 | * This procedure is invoked to process the "trace" Tcl command. |
---|
1061 | * See the user documentation for details on what it does. |
---|
1062 | * |
---|
1063 | * Results: |
---|
1064 | * A standard Tcl result. |
---|
1065 | * |
---|
1066 | * Side effects: |
---|
1067 | * See the user documentation. |
---|
1068 | * |
---|
1069 | *---------------------------------------------------------------------- |
---|
1070 | */ |
---|
1071 | |
---|
1072 | /* ARGSUSED */ |
---|
1073 | int |
---|
1074 | Tcl_TraceCmd(dummy, interp, argc, argv) |
---|
1075 | ClientData dummy; /* Not used. */ |
---|
1076 | Tcl_Interp *interp; /* Current interpreter. */ |
---|
1077 | int argc; /* Number of arguments. */ |
---|
1078 | char **argv; /* Argument strings. */ |
---|
1079 | { |
---|
1080 | int c; |
---|
1081 | size_t length; |
---|
1082 | |
---|
1083 | if (argc < 2) { |
---|
1084 | Tcl_AppendResult(interp, "too few args: should be \"", |
---|
1085 | argv[0], " option [arg arg ...]\"", (char *) NULL); |
---|
1086 | return TCL_ERROR; |
---|
1087 | } |
---|
1088 | c = argv[1][1]; |
---|
1089 | length = strlen(argv[1]); |
---|
1090 | if ((c == 'a') && (strncmp(argv[1], "variable", length) == 0) |
---|
1091 | && (length >= 2)) { |
---|
1092 | char *p; |
---|
1093 | int flags, length; |
---|
1094 | TraceVarInfo *tvarPtr; |
---|
1095 | |
---|
1096 | if (argc != 5) { |
---|
1097 | Tcl_AppendResult(interp, "wrong # args: should be \"", |
---|
1098 | argv[0], " variable name ops command\"", (char *) NULL); |
---|
1099 | return TCL_ERROR; |
---|
1100 | } |
---|
1101 | |
---|
1102 | flags = 0; |
---|
1103 | for (p = argv[3] ; *p != 0; p++) { |
---|
1104 | if (*p == 'r') { |
---|
1105 | flags |= TCL_TRACE_READS; |
---|
1106 | } else if (*p == 'w') { |
---|
1107 | flags |= TCL_TRACE_WRITES; |
---|
1108 | } else if (*p == 'u') { |
---|
1109 | flags |= TCL_TRACE_UNSETS; |
---|
1110 | } else { |
---|
1111 | goto badOps; |
---|
1112 | } |
---|
1113 | } |
---|
1114 | if (flags == 0) { |
---|
1115 | goto badOps; |
---|
1116 | } |
---|
1117 | |
---|
1118 | length = strlen(argv[4]); |
---|
1119 | tvarPtr = (TraceVarInfo *) ckalloc((unsigned) |
---|
1120 | (sizeof(TraceVarInfo) - sizeof(tvarPtr->command) + length + 1)); |
---|
1121 | tvarPtr->flags = flags; |
---|
1122 | tvarPtr->errMsg = NULL; |
---|
1123 | tvarPtr->length = length; |
---|
1124 | flags |= TCL_TRACE_UNSETS; |
---|
1125 | strcpy(tvarPtr->command, argv[4]); |
---|
1126 | if (Tcl_TraceVar(interp, argv[2], flags, TraceVarProc, |
---|
1127 | (ClientData) tvarPtr) != TCL_OK) { |
---|
1128 | ckfree((char *) tvarPtr); |
---|
1129 | return TCL_ERROR; |
---|
1130 | } |
---|
1131 | } else if ((c == 'd') && (strncmp(argv[1], "vdelete", length) |
---|
1132 | && (length >= 2)) == 0) { |
---|
1133 | char *p; |
---|
1134 | int flags, length; |
---|
1135 | TraceVarInfo *tvarPtr; |
---|
1136 | ClientData clientData; |
---|
1137 | |
---|
1138 | if (argc != 5) { |
---|
1139 | Tcl_AppendResult(interp, "wrong # args: should be \"", |
---|
1140 | argv[0], " vdelete name ops command\"", (char *) NULL); |
---|
1141 | return TCL_ERROR; |
---|
1142 | } |
---|
1143 | |
---|
1144 | flags = 0; |
---|
1145 | for (p = argv[3] ; *p != 0; p++) { |
---|
1146 | if (*p == 'r') { |
---|
1147 | flags |= TCL_TRACE_READS; |
---|
1148 | } else if (*p == 'w') { |
---|
1149 | flags |= TCL_TRACE_WRITES; |
---|
1150 | } else if (*p == 'u') { |
---|
1151 | flags |= TCL_TRACE_UNSETS; |
---|
1152 | } else { |
---|
1153 | goto badOps; |
---|
1154 | } |
---|
1155 | } |
---|
1156 | if (flags == 0) { |
---|
1157 | goto badOps; |
---|
1158 | } |
---|
1159 | |
---|
1160 | /* |
---|
1161 | * Search through all of our traces on this variable to |
---|
1162 | * see if there's one with the given command. If so, then |
---|
1163 | * delete the first one that matches. |
---|
1164 | */ |
---|
1165 | |
---|
1166 | length = strlen(argv[4]); |
---|
1167 | clientData = 0; |
---|
1168 | while ((clientData = Tcl_VarTraceInfo(interp, argv[2], 0, |
---|
1169 | TraceVarProc, clientData)) != 0) { |
---|
1170 | tvarPtr = (TraceVarInfo *) clientData; |
---|
1171 | if ((tvarPtr->length == length) && (tvarPtr->flags == flags) |
---|
1172 | && (strncmp(argv[4], tvarPtr->command, |
---|
1173 | (size_t) length) == 0)) { |
---|
1174 | Tcl_UntraceVar(interp, argv[2], flags | TCL_TRACE_UNSETS, |
---|
1175 | TraceVarProc, clientData); |
---|
1176 | if (tvarPtr->errMsg != NULL) { |
---|
1177 | ckfree(tvarPtr->errMsg); |
---|
1178 | } |
---|
1179 | ckfree((char *) tvarPtr); |
---|
1180 | break; |
---|
1181 | } |
---|
1182 | } |
---|
1183 | } else if ((c == 'i') && (strncmp(argv[1], "vinfo", length) == 0) |
---|
1184 | && (length >= 2)) { |
---|
1185 | ClientData clientData; |
---|
1186 | char ops[4], *p; |
---|
1187 | char *prefix = "{"; |
---|
1188 | |
---|
1189 | if (argc != 3) { |
---|
1190 | Tcl_AppendResult(interp, "wrong # args: should be \"", |
---|
1191 | argv[0], " vinfo name\"", (char *) NULL); |
---|
1192 | return TCL_ERROR; |
---|
1193 | } |
---|
1194 | clientData = 0; |
---|
1195 | while ((clientData = Tcl_VarTraceInfo(interp, argv[2], 0, |
---|
1196 | TraceVarProc, clientData)) != 0) { |
---|
1197 | TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData; |
---|
1198 | p = ops; |
---|
1199 | if (tvarPtr->flags & TCL_TRACE_READS) { |
---|
1200 | *p = 'r'; |
---|
1201 | p++; |
---|
1202 | } |
---|
1203 | if (tvarPtr->flags & TCL_TRACE_WRITES) { |
---|
1204 | *p = 'w'; |
---|
1205 | p++; |
---|
1206 | } |
---|
1207 | if (tvarPtr->flags & TCL_TRACE_UNSETS) { |
---|
1208 | *p = 'u'; |
---|
1209 | p++; |
---|
1210 | } |
---|
1211 | *p = '\0'; |
---|
1212 | Tcl_AppendResult(interp, prefix, (char *) NULL); |
---|
1213 | Tcl_AppendElement(interp, ops); |
---|
1214 | Tcl_AppendElement(interp, tvarPtr->command); |
---|
1215 | Tcl_AppendResult(interp, "}", (char *) NULL); |
---|
1216 | prefix = " {"; |
---|
1217 | } |
---|
1218 | } else { |
---|
1219 | Tcl_AppendResult(interp, "bad option \"", argv[1], |
---|
1220 | "\": should be variable, vdelete, or vinfo", |
---|
1221 | (char *) NULL); |
---|
1222 | return TCL_ERROR; |
---|
1223 | } |
---|
1224 | return TCL_OK; |
---|
1225 | |
---|
1226 | badOps: |
---|
1227 | Tcl_AppendResult(interp, "bad operations \"", argv[3], |
---|
1228 | "\": should be one or more of rwu", (char *) NULL); |
---|
1229 | return TCL_ERROR; |
---|
1230 | } |
---|
1231 | |
---|
1232 | /* |
---|
1233 | *---------------------------------------------------------------------- |
---|
1234 | * |
---|
1235 | * TraceVarProc -- |
---|
1236 | * |
---|
1237 | * This procedure is called to handle variable accesses that have |
---|
1238 | * been traced using the "trace" command. |
---|
1239 | * |
---|
1240 | * Results: |
---|
1241 | * Normally returns NULL. If the trace command returns an error, |
---|
1242 | * then this procedure returns an error string. |
---|
1243 | * |
---|
1244 | * Side effects: |
---|
1245 | * Depends on the command associated with the trace. |
---|
1246 | * |
---|
1247 | *---------------------------------------------------------------------- |
---|
1248 | */ |
---|
1249 | |
---|
1250 | /* ARGSUSED */ |
---|
1251 | static char * |
---|
1252 | TraceVarProc(clientData, interp, name1, name2, flags) |
---|
1253 | ClientData clientData; /* Information about the variable trace. */ |
---|
1254 | Tcl_Interp *interp; /* Interpreter containing variable. */ |
---|
1255 | char *name1; /* Name of variable or array. */ |
---|
1256 | char *name2; /* Name of element within array; NULL means |
---|
1257 | * scalar variable is being referenced. */ |
---|
1258 | int flags; /* OR-ed bits giving operation and other |
---|
1259 | * information. */ |
---|
1260 | { |
---|
1261 | Interp *iPtr = (Interp *) interp; |
---|
1262 | TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData; |
---|
1263 | char *result; |
---|
1264 | int code; |
---|
1265 | Interp dummy; |
---|
1266 | Tcl_DString cmd; |
---|
1267 | Tcl_Obj *saveObjPtr, *oldObjResultPtr; |
---|
1268 | |
---|
1269 | result = NULL; |
---|
1270 | if (tvarPtr->errMsg != NULL) { |
---|
1271 | ckfree(tvarPtr->errMsg); |
---|
1272 | tvarPtr->errMsg = NULL; |
---|
1273 | } |
---|
1274 | if ((tvarPtr->flags & flags) && !(flags & TCL_INTERP_DESTROYED)) { |
---|
1275 | |
---|
1276 | /* |
---|
1277 | * Generate a command to execute by appending list elements |
---|
1278 | * for the two variable names and the operation. The five |
---|
1279 | * extra characters are for three space, the opcode character, |
---|
1280 | * and the terminating null. |
---|
1281 | */ |
---|
1282 | |
---|
1283 | if (name2 == NULL) { |
---|
1284 | name2 = ""; |
---|
1285 | } |
---|
1286 | Tcl_DStringInit(&cmd); |
---|
1287 | Tcl_DStringAppend(&cmd, tvarPtr->command, tvarPtr->length); |
---|
1288 | Tcl_DStringAppendElement(&cmd, name1); |
---|
1289 | Tcl_DStringAppendElement(&cmd, name2); |
---|
1290 | if (flags & TCL_TRACE_READS) { |
---|
1291 | Tcl_DStringAppend(&cmd, " r", 2); |
---|
1292 | } else if (flags & TCL_TRACE_WRITES) { |
---|
1293 | Tcl_DStringAppend(&cmd, " w", 2); |
---|
1294 | } else if (flags & TCL_TRACE_UNSETS) { |
---|
1295 | Tcl_DStringAppend(&cmd, " u", 2); |
---|
1296 | } |
---|
1297 | |
---|
1298 | /* |
---|
1299 | * Execute the command. Be careful to save and restore both the |
---|
1300 | * string and object results from the interpreter used for |
---|
1301 | * the command. We discard any object result the command returns. |
---|
1302 | */ |
---|
1303 | |
---|
1304 | dummy.objResultPtr = Tcl_NewObj(); |
---|
1305 | Tcl_IncrRefCount(dummy.objResultPtr); |
---|
1306 | if (interp->freeProc == 0) { |
---|
1307 | dummy.freeProc = (Tcl_FreeProc *) 0; |
---|
1308 | dummy.result = ""; |
---|
1309 | Tcl_SetResult((Tcl_Interp *) &dummy, interp->result, |
---|
1310 | TCL_VOLATILE); |
---|
1311 | } else { |
---|
1312 | dummy.freeProc = interp->freeProc; |
---|
1313 | dummy.result = interp->result; |
---|
1314 | interp->freeProc = (Tcl_FreeProc *) 0; |
---|
1315 | } |
---|
1316 | |
---|
1317 | saveObjPtr = Tcl_GetObjResult(interp); |
---|
1318 | Tcl_IncrRefCount(saveObjPtr); |
---|
1319 | |
---|
1320 | code = Tcl_Eval(interp, Tcl_DStringValue(&cmd)); |
---|
1321 | if (code != TCL_OK) { /* copy error msg to result */ |
---|
1322 | tvarPtr->errMsg = (char *) |
---|
1323 | ckalloc((unsigned) (strlen(interp->result) + 1)); |
---|
1324 | strcpy(tvarPtr->errMsg, interp->result); |
---|
1325 | result = tvarPtr->errMsg; |
---|
1326 | Tcl_ResetResult(interp); /* must clear error state. */ |
---|
1327 | } |
---|
1328 | |
---|
1329 | /* |
---|
1330 | * Restore the interpreter's string result. |
---|
1331 | */ |
---|
1332 | |
---|
1333 | Tcl_SetResult(interp, dummy.result, |
---|
1334 | (dummy.freeProc == 0) ? TCL_VOLATILE : dummy.freeProc); |
---|
1335 | |
---|
1336 | /* |
---|
1337 | * Restore the interpreter's object result from saveObjPtr. |
---|
1338 | */ |
---|
1339 | |
---|
1340 | oldObjResultPtr = iPtr->objResultPtr; |
---|
1341 | iPtr->objResultPtr = saveObjPtr; /* was incremented above */ |
---|
1342 | Tcl_DecrRefCount(oldObjResultPtr); |
---|
1343 | |
---|
1344 | Tcl_DecrRefCount(dummy.objResultPtr); |
---|
1345 | dummy.objResultPtr = NULL; |
---|
1346 | Tcl_DStringFree(&cmd); |
---|
1347 | } |
---|
1348 | if (flags & TCL_TRACE_DESTROYED) { |
---|
1349 | result = NULL; |
---|
1350 | if (tvarPtr->errMsg != NULL) { |
---|
1351 | ckfree(tvarPtr->errMsg); |
---|
1352 | } |
---|
1353 | ckfree((char *) tvarPtr); |
---|
1354 | } |
---|
1355 | return result; |
---|
1356 | } |
---|
1357 | |
---|
1358 | /* |
---|
1359 | *---------------------------------------------------------------------- |
---|
1360 | * |
---|
1361 | * Tcl_WhileCmd -- |
---|
1362 | * |
---|
1363 | * This procedure is invoked to process the "while" Tcl command. |
---|
1364 | * See the user documentation for details on what it does. |
---|
1365 | * |
---|
1366 | * With the bytecode compiler, this procedure is only called when |
---|
1367 | * a command name is computed at runtime, and is "while" or the name |
---|
1368 | * to which "while" was renamed: e.g., "set z while; $z {$i<100} {}" |
---|
1369 | * |
---|
1370 | * Results: |
---|
1371 | * A standard Tcl result. |
---|
1372 | * |
---|
1373 | * Side effects: |
---|
1374 | * See the user documentation. |
---|
1375 | * |
---|
1376 | *---------------------------------------------------------------------- |
---|
1377 | */ |
---|
1378 | |
---|
1379 | /* ARGSUSED */ |
---|
1380 | int |
---|
1381 | Tcl_WhileCmd(dummy, interp, argc, argv) |
---|
1382 | ClientData dummy; /* Not used. */ |
---|
1383 | Tcl_Interp *interp; /* Current interpreter. */ |
---|
1384 | int argc; /* Number of arguments. */ |
---|
1385 | char **argv; /* Argument strings. */ |
---|
1386 | { |
---|
1387 | int result, value; |
---|
1388 | |
---|
1389 | if (argc != 3) { |
---|
1390 | Tcl_AppendResult(interp, "wrong # args: should be \"", |
---|
1391 | argv[0], " test command\"", (char *) NULL); |
---|
1392 | return TCL_ERROR; |
---|
1393 | } |
---|
1394 | |
---|
1395 | while (1) { |
---|
1396 | result = Tcl_ExprBoolean(interp, argv[1], &value); |
---|
1397 | if (result != TCL_OK) { |
---|
1398 | return result; |
---|
1399 | } |
---|
1400 | if (!value) { |
---|
1401 | break; |
---|
1402 | } |
---|
1403 | result = Tcl_Eval(interp, argv[2]); |
---|
1404 | if ((result != TCL_OK) && (result != TCL_CONTINUE)) { |
---|
1405 | if (result == TCL_ERROR) { |
---|
1406 | char msg[60]; |
---|
1407 | sprintf(msg, "\n (\"while\" body line %d)", |
---|
1408 | interp->errorLine); |
---|
1409 | Tcl_AddErrorInfo(interp, msg); |
---|
1410 | } |
---|
1411 | break; |
---|
1412 | } |
---|
1413 | } |
---|
1414 | if (result == TCL_BREAK) { |
---|
1415 | result = TCL_OK; |
---|
1416 | } |
---|
1417 | if (result == TCL_OK) { |
---|
1418 | Tcl_ResetResult(interp); |
---|
1419 | } |
---|
1420 | return result; |
---|
1421 | } |
---|
1422 | |
---|