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