![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to tclCmdIZ.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Research Unix] / researchv10no / cmd / worm / scsi / tcl|
Return to tclCmdIZ.c CVS log | Up to [Research Unix] / researchv10no / cmd / worm / scsi / tcl |
1.1 root 1: /*
2: * tclCmdIZ.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: * I to Z.
7: *
8: * Copyright 1987 Regents of the University of California
9: * Permission to use, copy, modify, and distribute this
10: * software and its documentation for any purpose and without
11: * fee is hereby granted, provided that the above copyright
12: * notice appear in all copies. The University of California
13: * makes no representations about the suitability of this
14: * software for any purpose. It is provided "as is" without
15: * express or implied warranty.
16: */
17:
18: #ifndef lint
19: static char rcsid[] = "$Header: /sprite/src/lib/tcl/RCS/tclCmdIZ.c,v 1.36 90/04/18 17:09:07 ouster Exp $ SPRITE (Berkeley)";
20: #pragma ref rcsid
21: #endif not lint
22:
23: #define _POSIX_SOURCE
24:
25: #include <ctype.h>
26: #include <errno.h>
27: #include <stdio.h>
28: #include <stdlib.h>
29: #include <string.h>
30: #include <sys/types.h>
31: #include <fcntl.h>
32: #include <sys/stat.h>
33: #include <sys/times.h>
34: #include "tclInt.h"
35:
36: /*
37: *----------------------------------------------------------------------
38: *
39: * Tcl_IfCmd --
40: *
41: * This procedure is invoked to process the "if" Tcl command.
42: * See the user documentation for details on what it does.
43: *
44: * Results:
45: * A standard Tcl result.
46: *
47: * Side effects:
48: * See the user documentation.
49: *
50: *----------------------------------------------------------------------
51: */
52:
53: /* ARGSUSED */
54: int
55: Tcl_IfCmd(dummy, interp, argc, argv)
56: ClientData dummy; /* Not used. */
57: Tcl_Interp *interp; /* Current interpreter. */
58: int argc; /* Number of arguments. */
59: char **argv; /* Argument strings. */
60: {
61: #pragma ref dummy
62: char *condition, *ifPart, *elsePart, *cmd, *name;
63: int result, value;
64:
65: name = argv[0];
66: if (argc < 3) {
67: ifSyntax:
68: sprintf(interp->result, "wrong # args: should be \"%.50s bool [then] command [[else] command]\"",
69: name);
70: return TCL_ERROR;
71: }
72: condition = argv[1];
73: argc -= 2;
74: argv += 2;
75: if ((**argv == 't') && (strncmp(*argv, "then", strlen(*argv)) == 0)) {
76: argc--;
77: argv++;
78: }
79: if (argc < 1) {
80: goto ifSyntax;
81: }
82: ifPart = *argv;
83: argv++;
84: argc--;
85: if (argc == 0) {
86: elsePart = "";
87: } else {
88: if ((**argv == 'e') && (strncmp(*argv, "else", strlen(*argv)) == 0)) {
89: argc--;
90: argv++;
91: }
92: if (argc != 1) {
93: goto ifSyntax;
94: }
95: elsePart = *argv;
96: }
97:
98: cmd = ifPart;
99: result = Tcl_Expr(interp, condition, &value);
100: if (result != TCL_OK) {
101: return result;
102: }
103: if (value == 0) {
104: cmd = elsePart;
105: }
106: result = Tcl_Eval(interp, cmd, 0, (char **) NULL);
107: if (result == TCL_ERROR) {
108: char msg[60];
109: sprintf(msg, " (\"if\" body line %d)", interp->errorLine);
110: Tcl_AddErrorInfo(interp, msg);
111: }
112: return result;
113: }
114:
115: /*
116: *----------------------------------------------------------------------
117: *
118: * Tcl_IndexCmd --
119: *
120: * This procedure is invoked to process the "index" Tcl command.
121: * See the user documentation for details on what it does.
122: *
123: * Results:
124: * A standard Tcl result.
125: *
126: * Side effects:
127: * See the user documentation.
128: *
129: *----------------------------------------------------------------------
130: */
131:
132: /* ARGSUSED */
133: int
134: Tcl_IndexCmd(dummy, interp, argc, argv)
135: ClientData dummy; /* Not used. */
136: Tcl_Interp *interp; /* Current interpreter. */
137: int argc; /* Number of arguments. */
138: char **argv; /* Argument strings. */
139: {
140: #pragma ref dummy
141: char *p, *element;
142: int index, size, parenthesized, result;
143:
144: if (argc < 3) {
145: indexSyntax:
146: sprintf(interp->result,
147: "wrong # args: should be \"%.50s value index [chars]\"",
148: argv[0]);
149: return TCL_ERROR;
150: }
151: p = argv[1];
152: index = atoi(argv[2]);
153: if (!isdigit(*argv[2]) || (index < 0)) {
154: sprintf(interp->result, "bad index \"%.50s\"", argv[2]);
155: return TCL_ERROR;
156: }
157: if (argc == 3) {
158: for ( ; index >= 0; index--) {
159: result = TclFindElement(interp, p, &element, &p, &size,
160: &parenthesized);
161: if (result != TCL_OK) {
162: return result;
163: }
164: }
165: if (size >= TCL_RESULT_SIZE) {
166: interp->result = (char *) malloc((unsigned) size+1);
167: interp->dynamic = 1;
168: }
169: if (parenthesized) {
170: bcopy(element, interp->result, size);
171: interp->result[size] = 0;
172: } else {
173: TclCopyAndCollapse(size, element, interp->result);
174: }
175: } else if (argc == 4) {
176: if (strncmp(argv[3], "chars", strlen(argv[3])) != 0) {
177: sprintf(interp->result, "bad argument \"%s\": must be \"chars\"",
178: argv[3]);
179: return TCL_ERROR;
180: }
181: size = strlen(p);
182: if (index < size) {
183: interp->result[0] = p[index];
184: interp->result[1] = 0;
185: }
186: } else {
187: goto indexSyntax;
188: }
189: return TCL_OK;
190: }
191:
192: /*
193: *----------------------------------------------------------------------
194: *
195: * Tcl_InfoCmd --
196: *
197: * This procedure is invoked to process the "info" Tcl command.
198: * See the user documentation for details on what it does.
199: *
200: * Results:
201: * A standard Tcl result.
202: *
203: * Side effects:
204: * See the user documentation.
205: *
206: *----------------------------------------------------------------------
207: */
208:
209: /* ARGSUSED */
210: int
211: Tcl_InfoCmd(dummy, interp, argc, argv)
212: ClientData dummy; /* Not used. */
213: Tcl_Interp *interp; /* Current interpreter. */
214: int argc; /* Number of arguments. */
215: char **argv; /* Argument strings. */
216: {
217: #pragma ref dummy
218: register Interp *iPtr = (Interp *) interp;
219: Proc *procPtr;
220: Var *varPtr;
221: Command *cmdPtr;
222: int length;
223: char c;
224:
225: /*
226: * When collecting a list of things (e.g. args or vars) "flag" tells
227: * what kind of thing is being collected, according to the definitions
228: * below.
229: */
230:
231: int flag;
232: # define VARS 0
233: # define LOCALS 1
234: # define PROCS 2
235: # define CMDS 3
236:
237: # define ARG_SIZE 20
238: char *argSpace[ARG_SIZE];
239: int argSize;
240: char *pattern;
241:
242: if (argc < 2) {
243: sprintf(iPtr->result,
244: "too few args: should be \"%.50s option [arg arg ...]\"",
245: argv[0]);
246: return TCL_ERROR;
247: }
248: c = argv[1][0];
249: length = strlen(argv[1]);
250: if ((c == 'a') && (strncmp(argv[1], "args", length)) == 0) {
251: if (argc != 3) {
252: sprintf(iPtr->result,
253: "wrong # args: should be \"%.50s args procname\"",
254: argv[0]);
255: return TCL_ERROR;
256: }
257: procPtr = TclFindProc(iPtr, argv[2]);
258: if (procPtr == NULL) {
259: infoNoSuchProc:
260: sprintf(iPtr->result,
261: "info requested on \"%s\", which isn't a procedure",
262: argv[2]);
263: return TCL_ERROR;
264: }
265: flag = VARS;
266: varPtr = procPtr->argPtr;
267: argc = 0; /* Prevent pattern matching. */
268: } else if ((c == 'b') && (strncmp(argv[1], "body", length)) == 0) {
269: if (argc != 3) {
270: sprintf(iPtr->result,
271: "wrong # args: should be \"%.50s body procname\"",
272: argv[0]);
273: return TCL_ERROR;
274: }
275: procPtr = TclFindProc(iPtr, argv[2]);
276: if (procPtr == NULL) {
277: goto infoNoSuchProc;
278: }
279: iPtr->result = procPtr->command;
280: return TCL_OK;
281: } else if ((c == 'c') && (strncmp(argv[1], "cmdcount", length) == 0)
282: && (length >= 2)) {
283: if (argc != 2) {
284: sprintf(iPtr->result,
285: "wrong # args: should be \"%.50s cmdcount\"",
286: argv[0]);
287: return TCL_ERROR;
288: }
289: sprintf(iPtr->result, "%d", iPtr->cmdCount);
290: return TCL_OK;
291: } else if ((c == 'c') && (strncmp(argv[1], "commands", length) == 0)
292: && (length >= 2)){
293: if (argc > 3) {
294: sprintf(iPtr->result,
295: "wrong # args: should be \"%.50s commands [pattern]\"",
296: argv[0]);
297: return TCL_ERROR;
298: }
299: flag = CMDS;
300: cmdPtr = iPtr->commandPtr;
301: } else if ((c == 'd') && (strncmp(argv[1], "default", length)) == 0) {
302: if (argc != 5) {
303: sprintf(iPtr->result, "wrong # args: should be \"%.50s default procname arg varname\"",
304: argv[0]);
305: return TCL_ERROR;
306: }
307: procPtr = TclFindProc(iPtr, argv[2]);
308: if (procPtr == NULL) {
309: goto infoNoSuchProc;
310: }
311: for (varPtr = procPtr->argPtr; ; varPtr = varPtr->nextPtr) {
312: if (varPtr == NULL) {
313: sprintf(iPtr->result,
314: "procedure \"%s\" doesn't have an argument \"%s\"",
315: argv[2], argv[3]);
316: return TCL_ERROR;
317: }
318: if (strcmp(argv[3], varPtr->name) == 0) {
319: if (varPtr->value != NULL) {
320: Tcl_SetVar((Tcl_Interp *) iPtr, argv[4], varPtr->value, 0);
321: iPtr->result = "1";
322: } else {
323: Tcl_SetVar((Tcl_Interp *) iPtr, argv[4], "", 0);
324: iPtr->result = "0";
325: }
326: return TCL_OK;
327: }
328: }
329: } else if ((c == 'e') && (strncmp(argv[1], "exists", length) == 0)) {
330: char *p;
331: if (argc != 3) {
332: sprintf(iPtr->result,
333: "wrong # args: should be \"%.50s exists varName\"",
334: argv[0]);
335: return TCL_ERROR;
336: }
337: p = Tcl_GetVar((Tcl_Interp *) iPtr, argv[2], 0);
338: if (p != NULL) {
339: iPtr->result[0] = '1';
340: } else {
341: iPtr->result[0] = '0';
342: }
343: iPtr->result[1] = 0;
344: return TCL_OK;
345: } else if ((c == 'g') && (strncmp(argv[1], "globals", length) == 0)) {
346: if (argc > 3) {
347: sprintf(iPtr->result,
348: "wrong # args: should be \"%.50s globals [pattern]\"",
349: argv[0]);
350: return TCL_ERROR;
351: }
352: flag = VARS;
353: varPtr = iPtr->globalPtr;
354: } else if ((c == 'l') && (strncmp(argv[1], "locals", length) == 0)
355: && (length >= 2)) {
356: if (argc > 3) {
357: sprintf(iPtr->result,
358: "wrong # args: should be \"%.50s locals [pattern]\"",
359: argv[0]);
360: return TCL_ERROR;
361: }
362: flag = LOCALS;
363: if (iPtr->varFramePtr == NULL) {
364: varPtr = NULL;
365: } else {
366: varPtr = iPtr->varFramePtr->varPtr;
367: }
368: } else if ((c == 'l') && (strncmp(argv[1], "level", length) == 0)
369: && (length >= 2)) {
370: if (argc == 2) {
371: if (iPtr->varFramePtr == NULL) {
372: iPtr->result = "0";
373: } else {
374: sprintf(iPtr->result, "%d", iPtr->varFramePtr->level);
375: }
376: return TCL_OK;
377: } else if (argc == 3) {
378: int level;
379: char *end;
380: CallFrame *framePtr;
381:
382: level = strtol(argv[2], &end, 10);
383: if ((end == argv[2]) || (*end != '\0')) {
384: levelError:
385: sprintf(iPtr->result, "bad level \"%.50s\"", argv[1]);
386: return TCL_ERROR;
387: }
388: if (level <= 0) {
389: if (iPtr->varFramePtr == NULL) {
390: goto levelError;
391: }
392: level += iPtr->varFramePtr->level;
393: }
394: if (level == 0) {
395: return TCL_OK;
396: }
397: for (framePtr = iPtr->varFramePtr; framePtr != NULL;
398: framePtr = framePtr->callerVarPtr) {
399: if (framePtr->level == level) {
400: break;
401: }
402: }
403: if (framePtr == NULL) {
404: goto levelError;
405: }
406: iPtr->result = Tcl_Merge(framePtr->argc, framePtr->argv);
407: iPtr->dynamic = 1;
408: return TCL_OK;
409: }
410: sprintf(iPtr->result,
411: "wrong # args: should be \"%.50s level [number]\"",
412: argv[0]);
413: return TCL_ERROR;
414: } else if ((c == 'p') && (strncmp(argv[1], "procs", length)) == 0) {
415: if (argc > 3) {
416: sprintf(iPtr->result,
417: "wrong # args: should be \"%.50s procs [pattern]\"",
418: argv[0]);
419: return TCL_ERROR;
420: }
421: flag = PROCS;
422: cmdPtr = iPtr->commandPtr;
423: } else if ((c == 't') && (strncmp(argv[1], "tclversion", length) == 0)) {
424:
425: /*
426: * Note: TCL_VERSION below is expected to be set with a "-D"
427: * switch in the Makefile.
428: */
429:
430: strcpy(iPtr->result, TCL_VERSION);
431: return TCL_OK;
432: } else if ((c == 'v') && (strncmp(argv[1], "vars", length)) == 0) {
433: if (argc > 3) {
434: sprintf(iPtr->result,
435: "wrong # args: should be \"%.50s vars [pattern]\"",
436: argv[0]);
437: return TCL_ERROR;
438: }
439: flag = VARS;
440: if (iPtr->varFramePtr == NULL) {
441: varPtr = iPtr->globalPtr;
442: } else {
443: varPtr = iPtr->varFramePtr->varPtr;
444: }
445: } else {
446: sprintf(iPtr->result, "bad \"%.50s\" option \"%.50s\": must be args, body, commands, cmdcount, default, exists, globals, level, locals, procs, tclversion, or vars",
447: argv[0], argv[1]);
448: return TCL_ERROR;
449: }
450:
451: /*
452: * At this point we have to assemble a list of something or other.
453: * Collect them in an expandable argv-argc array.
454: */
455:
456: if (argc == 3) {
457: pattern = argv[2];
458: } else {
459: pattern = NULL;
460: }
461: argv = argSpace;
462: argSize = ARG_SIZE;
463: argc = 0;
464: while (1) {
465: /*
466: * Increase the size of the argument array if necessary to
467: * accommodate another string.
468: */
469:
470: if (argc == argSize) {
471: char **newArgs;
472:
473: argSize *= 2;
474: newArgs = (char **) malloc((unsigned) argSize*sizeof(char *));
475: bcopy((char *) argv, (char *) newArgs, argc*sizeof(char *));
476: if (argv != argSpace) {
477: free((char *) argv);
478: }
479: argv = newArgs;
480: }
481:
482: if ((flag == PROCS) || (flag == CMDS)) {
483: if (flag == PROCS) {
484: for ( ; cmdPtr != NULL; cmdPtr = cmdPtr->nextPtr) {
485: if (TclIsProc(cmdPtr)) {
486: break;
487: }
488: }
489: }
490: if (cmdPtr == NULL) {
491: break;
492: }
493: argv[argc] = cmdPtr->name;
494: cmdPtr = cmdPtr->nextPtr;
495: } else {
496: if (flag == LOCALS) {
497: for ( ; varPtr != NULL; varPtr = varPtr->nextPtr) {
498: if (!(varPtr->flags & VAR_GLOBAL)) {
499: break;
500: }
501: }
502: }
503: if (varPtr == NULL) {
504: break;
505: }
506: argv[argc] = varPtr->name;
507: varPtr = varPtr->nextPtr;
508: }
509: if ((pattern == NULL) || Tcl_StringMatch(argv[argc], pattern)) {
510: argc++;
511: }
512: }
513:
514: iPtr->result = Tcl_Merge(argc, argv);
515: iPtr->dynamic = 1;
516: if (argv != argSpace) {
517: free((char *) argv);
518: }
519: return TCL_OK;
520: }
521:
522: /*
523: *----------------------------------------------------------------------
524: *
525: * Tcl_LengthCmd --
526: *
527: * This procedure is invoked to process the "length" Tcl command.
528: * See the user documentation for details on what it does.
529: *
530: * Results:
531: * A standard Tcl result.
532: *
533: * Side effects:
534: * See the user documentation.
535: *
536: *----------------------------------------------------------------------
537: */
538:
539: /* ARGSUSED */
540: int
541: Tcl_LengthCmd(dummy, interp, argc, argv)
542: ClientData dummy; /* Not used. */
543: Tcl_Interp *interp; /* Current interpreter. */
544: int argc; /* Number of arguments. */
545: char **argv; /* Argument strings. */
546: {
547: #pragma ref dummy
548: int count;
549: char *p;
550:
551: if (argc < 2) {
552: lengthSyntax:
553: sprintf(interp->result,
554: "wrong # args: should be \"%.50s value [chars]\"", argv[0]);
555: return TCL_ERROR;
556: }
557: p = argv[1];
558: if (argc == 2) {
559: char *element;
560: int result;
561:
562: for (count = 0; *p != 0 ; count++) {
563: result = TclFindElement(interp, p, &element, &p, (int *) NULL,
564: (int *) NULL);
565: if (result != TCL_OK) {
566: return result;
567: }
568: if (*element == 0) {
569: break;
570: }
571: }
572: } else if ((argc == 3)
573: && (strncmp(argv[2], "chars", strlen(argv[2])) == 0)) {
574: count = strlen(p);
575: } else {
576: goto lengthSyntax;
577: }
578: sprintf(interp->result, "%d", count);
579: return TCL_OK;
580: }
581:
582: /*
583: *----------------------------------------------------------------------
584: *
585: * Tcl_ListCmd --
586: *
587: * This procedure is invoked to process the "list" Tcl command.
588: * See the user documentation for details on what it does.
589: *
590: * Results:
591: * A standard Tcl result.
592: *
593: * Side effects:
594: * See the user documentation.
595: *
596: *----------------------------------------------------------------------
597: */
598:
599: /* ARGSUSED */
600: int
601: Tcl_ListCmd(dummy, interp, argc, argv)
602: ClientData dummy; /* Not used. */
603: Tcl_Interp *interp; /* Current interpreter. */
604: int argc; /* Number of arguments. */
605: char **argv; /* Argument strings. */
606: {
607: #pragma ref dummy
608: if (argc < 2) {
609: sprintf(interp->result,
610: "not enough args: should be \"%.50s arg [arg ...]\"",
611: argv[0]);
612: return TCL_ERROR;
613: }
614: interp->result = Tcl_Merge(argc-1, argv+1);
615: interp->dynamic = 1;
616: return TCL_OK;
617: }
618:
619: /*
620: *----------------------------------------------------------------------
621: *
622: * Tcl_PrintCmd --
623: *
624: * This procedure is invoked to process the "print" Tcl command.
625: * See the user documentation for details on what it does.
626: *
627: * Results:
628: * A standard Tcl result.
629: *
630: * Side effects:
631: * See the user documentation.
632: *
633: *----------------------------------------------------------------------
634: */
635:
636: /* ARGSUSED */
637: int
638: Tcl_PrintCmd(notUsed, interp, argc, argv)
639: ClientData notUsed; /* Not used. */
640: Tcl_Interp *interp; /* Current interpreter. */
641: int argc; /* Number of arguments. */
642: char **argv; /* Argument strings. */
643: {
644: #pragma ref notUsed
645: FILE *f;
646: int result;
647:
648: if ((argc < 2) || (argc > 4)) {
649: sprintf(interp->result,
650: "wrong # args: should be \"%.50s string [file [append]]\"",
651: argv[0]);
652: return TCL_ERROR;
653: }
654:
655: if (argc == 2) {
656: f = stdout;
657: } else {
658: if (argc == 4) {
659: if (strncmp(argv[3], "append", strlen(argv[3])) != 0) {
660: sprintf(interp->result,
661: "bad option \"%.50s\": must be \"append\"",
662: argv[3]);
663: return TCL_ERROR;
664: }
665: f = fopen(argv[2], "a");
666: } else {
667: f = fopen(argv[2], "w");
668: }
669: if (f == NULL) {
670: sprintf(interp->result, "couldn't open \"%.50s\": %.80s",
671: argv[2], strerror(errno));
672: return TCL_ERROR;
673: }
674: }
675: fputs(argv[1], f);
676: if (argc == 2) {
677: result = fflush(stdout);
678: } else {
679: result = fclose(f);
680: }
681: if (result == EOF) {
682: sprintf(interp->result, "I/O error while writing: %.50s",
683: strerror(errno));
684: return TCL_ERROR;
685: }
686: return TCL_OK;
687: }
688:
689: /*
690: *----------------------------------------------------------------------
691: *
692: * Tcl_RangeCmd --
693: *
694: * This procedure is invoked to process the "range" Tcl command.
695: * See the user documentation for details on what it does.
696: *
697: * Results:
698: * A standard Tcl result.
699: *
700: * Side effects:
701: * See the user documentation.
702: *
703: *----------------------------------------------------------------------
704: */
705:
706: /* ARGSUSED */
707: int
708: Tcl_RangeCmd(notUsed, interp, argc, argv)
709: ClientData notUsed; /* Not used. */
710: Tcl_Interp *interp; /* Current interpreter. */
711: int argc; /* Number of arguments. */
712: char **argv; /* Argument strings. */
713: {
714: #pragma ref notUsed
715: int first, last, result;
716: char *begin, *end, c, *dummy;
717: int count;
718:
719: if (argc < 4) {
720: rangeSyntax:
721: sprintf(interp->result, "wrong #/type of args: should be \"%.50s value first last [chars]\"",
722: argv[0]);
723: return TCL_ERROR;
724: }
725: first = atoi(argv[2]);
726: if (!isdigit(*argv[2]) || (first < 0)) {
727: sprintf(interp->result, "bad range specifier \"%.50s\"", argv[2]);
728: return TCL_ERROR;
729: }
730: if ((*argv[3] == 'e') && (strncmp(argv[3], "end", strlen(argv[3])) == 0)) {
731: last = -1;
732: } else {
733: last = atoi(argv[3]);
734: if (!isdigit(*argv[3]) || (last < 0)) {
735: sprintf(interp->result, "bad range specifier \"%.50s\"", argv[3]);
736: return TCL_ERROR;
737: }
738: }
739:
740: if (argc == 5) {
741: count = strlen(argv[4]);
742: if ((count == 0) || (strncmp(argv[4], "chars", count) != 0)) {
743: goto rangeSyntax;
744: }
745:
746: /*
747: * Extract a range of characters.
748: */
749:
750: count = strlen(argv[1]);
751: if (first >= count) {
752: interp->result = "";
753: return TCL_OK;
754: }
755: begin = argv[1] + first;
756: if ((last == -1) || (last >= count)) {
757: last = count;
758: } else if (last < first) {
759: interp->result = "";
760: return TCL_OK;
761: }
762: end = argv[1] + last + 1;
763: } else {
764: if (argc != 4) {
765: goto rangeSyntax;
766: }
767:
768: /*
769: * Extract a range of fields.
770: */
771:
772: for (count = 0, begin = argv[1]; count < first; count++) {
773: result = TclFindElement(interp, begin, &dummy, &begin, (int *) NULL,
774: (int *) NULL);
775: if (result != TCL_OK) {
776: return result;
777: }
778: if (*begin == 0) {
779: break;
780: }
781: }
782: if (last == -1) {
783: Tcl_Return(interp, begin, TCL_VOLATILE);
784: return TCL_OK;
785: }
786: if (last < first) {
787: interp->result = "";
788: return TCL_OK;
789: }
790: for (count = first, end = begin; (count <= last) && (*end != 0);
791: count++) {
792: result = TclFindElement(interp, end, &dummy, &end, (int *) NULL,
793: (int *) NULL);
794: if (result != TCL_OK) {
795: return result;
796: }
797: }
798:
799: /*
800: * Chop off trailing spaces.
801: */
802:
803: while (isspace(end[-1])) {
804: end--;
805: }
806: }
807: c = *end;
808: *end = 0;
809: Tcl_Return(interp, begin, TCL_VOLATILE);
810: *end = c;
811: return TCL_OK;
812: }
813:
814: /*
815: *----------------------------------------------------------------------
816: *
817: * Tcl_RenameCmd --
818: *
819: * This procedure is invoked to process the "rename" Tcl command.
820: * See the user documentation for details on what it does.
821: *
822: * Results:
823: * A standard Tcl result.
824: *
825: * Side effects:
826: * See the user documentation.
827: *
828: *----------------------------------------------------------------------
829: */
830:
831: /* ARGSUSED */
832: int
833: Tcl_RenameCmd(dummy, interp, argc, argv)
834: ClientData dummy; /* Not used. */
835: Tcl_Interp *interp; /* Current interpreter. */
836: int argc; /* Number of arguments. */
837: char **argv; /* Argument strings. */
838: {
839: #pragma ref dummy
840: register Command *oldPtr, *newPtr;
841: Interp *iPtr = (Interp *) interp;
842:
843: if (argc != 3) {
844: sprintf(interp->result,
845: "wrong # args: should be \"%.50s oldName newName\"",
846: argv[0]);
847: return TCL_ERROR;
848: }
849: if (argv[2][0] == '\0') {
850: Tcl_DeleteCommand(interp, argv[1]);
851: return TCL_OK;
852: }
853: newPtr = TclFindCmd(iPtr, argv[2], 0);
854: if (newPtr != NULL) {
855: sprintf(interp->result, "can't rename to \"%.50s\": already exists",
856: argv[2]);
857: return TCL_ERROR;
858: }
859: oldPtr = TclFindCmd(iPtr, argv[1], 0);
860: if (oldPtr == NULL) {
861: sprintf(interp->result,
862: "can't rename \"%.50s\": command doesn't exist",
863: argv[1]);
864: return TCL_ERROR;
865: }
866: iPtr->commandPtr = oldPtr->nextPtr;
867: newPtr = (Command *) malloc(CMD_SIZE(strlen(argv[2])));
868: newPtr->proc = oldPtr->proc;
869: newPtr->clientData = oldPtr->clientData;
870: newPtr->deleteProc = oldPtr->deleteProc;
871: newPtr->nextPtr = iPtr->commandPtr;
872: iPtr->commandPtr = newPtr;
873: strcpy(newPtr->name, argv[2]);
874: free((char *) oldPtr);
875: return TCL_OK;
876: }
877:
878: /*
879: *----------------------------------------------------------------------
880: *
881: * Tcl_ReturnCmd --
882: *
883: * This procedure is invoked to process the "return" Tcl command.
884: * See the user documentation for details on what it does.
885: *
886: * Results:
887: * A standard Tcl result.
888: *
889: * Side effects:
890: * See the user documentation.
891: *
892: *----------------------------------------------------------------------
893: */
894:
895: /* ARGSUSED */
896: int
897: Tcl_ReturnCmd(dummy, interp, argc, argv)
898: ClientData dummy; /* Not used. */
899: Tcl_Interp *interp; /* Current interpreter. */
900: int argc; /* Number of arguments. */
901: char **argv; /* Argument strings. */
902: {
903: #pragma ref dummy
904: if (argc > 2) {
905: sprintf(interp->result, "too many args: should be \"%.50s [value]\"",
906: argv[0]);
907: return TCL_ERROR;
908: }
909: if (argc == 2) {
910: Tcl_Return(interp, argv[1], TCL_VOLATILE);
911: }
912: return TCL_RETURN;
913: }
914:
915: /*
916: *----------------------------------------------------------------------
917: *
918: * Tcl_ScanCmd --
919: *
920: * This procedure is invoked to process the "scan" Tcl command.
921: * See the user documentation for details on what it does.
922: *
923: * Results:
924: * A standard Tcl result.
925: *
926: * Side effects:
927: * See the user documentation.
928: *
929: *----------------------------------------------------------------------
930: */
931:
932: /* ARGSUSED */
933: int
934: Tcl_ScanCmd(dummy, interp, argc, argv)
935: ClientData dummy; /* Not used. */
936: Tcl_Interp *interp; /* Current interpreter. */
937: int argc; /* Number of arguments. */
938: char **argv; /* Argument strings. */
939: {
940: #pragma ref dummy
941: int arg1Length; /* Number of bytes in argument to be
942: * scanned. This gives an upper limit
943: * on string field sizes. */
944: # define MAX_FIELDS 20
945: typedef struct {
946: char fmt; /* Format for field. */
947: int size; /* How many bytes to allow for
948: * field. */
949: char *location; /* Where field will be stored. */
950: } Field;
951: Field fields[MAX_FIELDS]; /* Info about all the fields in the
952: * format string. */
953: register Field *curField;
954: int numFields = 0; /* Number of fields actually
955: * specified. */
956: int suppress; /* Current field is assignment-
957: * suppressed. */
958: int totalSize = 0; /* Number of bytes needed to store
959: * all results combined. */
960: char *results; /* Where scanned output goes. */
961: int numScanned; /* sscanf's result. */
962: register char *fmt;
963: int i;
964:
965: if (argc < 3) {
966: sprintf(interp->result,
967: "too few args: should be \"%.50s string format varName ...\"",
968: argv[0]);
969: return TCL_ERROR;
970: }
971:
972: /*
973: * This procedure operates in four stages:
974: * 1. Scan the format string, collecting information about each field.
975: * 2. Allocate an array to hold all of the scanned fields.
976: * 3. Call sscanf to do all the dirty work, and have it store the
977: * parsed fields in the array.
978: * 4. Pick off the fields from the array and assign them to variables.
979: */
980:
981: arg1Length = (strlen(argv[1]) + 4) & ~03;
982: for (fmt = argv[2]; *fmt != 0; fmt++) {
983: if (*fmt != '%') {
984: continue;
985: }
986: fmt++;
987: if (*fmt == '*') {
988: suppress = 1;
989: fmt++;
990: } else {
991: suppress = 0;
992: }
993: while (isdigit(*fmt)) {
994: fmt++;
995: }
996: if (suppress) {
997: continue;
998: }
999: if (numFields == MAX_FIELDS) {
1000: sprintf(interp->result,
1001: "can't have more than %d fields in \"%.50s\"", MAX_FIELDS,
1002: argv[0]);
1003: return TCL_ERROR;
1004: }
1005: curField = &fields[numFields];
1006: numFields++;
1007: switch (*fmt) {
1008: case 'D':
1009: case 'O':
1010: case 'X':
1011: case 'd':
1012: case 'o':
1013: case 'x':
1014: curField->fmt = 'd';
1015: curField->size = sizeof(int);
1016: break;
1017:
1018: case 's':
1019: curField->fmt = 's';
1020: curField->size = arg1Length;
1021: break;
1022:
1023: case 'c':
1024: curField->fmt = 'c';
1025: curField->size = sizeof(int);
1026: break;
1027:
1028: case 'E':
1029: case 'F':
1030: curField->fmt = 'F';
1031: curField->size = 8;
1032: break;
1033:
1034: case 'e':
1035: case 'f':
1036: curField->fmt = 'f';
1037: curField->size = 4;
1038: break;
1039:
1040: case '[':
1041: curField->fmt = 's';
1042: curField->size = arg1Length;
1043: do {
1044: fmt++;
1045: } while (*fmt != ']');
1046: break;
1047:
1048: default:
1049: sprintf(interp->result, "bad scan conversion character \"%c\"",
1050: *fmt);
1051: return TCL_ERROR;
1052: }
1053: totalSize += curField->size;
1054: }
1055:
1056: if (numFields != (argc-3)) {
1057: interp->result =
1058: "different numbers of variable names and field specifiers";
1059: return TCL_ERROR;
1060: }
1061:
1062: /*
1063: * Step 2:
1064: */
1065:
1066: results = (char *) malloc((unsigned) totalSize);
1067: for (i = 0, totalSize = 0, curField = fields;
1068: i < numFields; i++, curField++) {
1069: curField->location = results + totalSize;
1070: totalSize += curField->size;
1071: }
1072:
1073: /*
1074: * Step 3:
1075: */
1076:
1077: numScanned = sscanf(argv[1], argv[2],
1078: fields[0].location, fields[1].location, fields[2].location,
1079: fields[3].location, fields[4].location);
1080:
1081: /*
1082: * Step 4:
1083: */
1084:
1085: if (numScanned < numFields) {
1086: numFields = numScanned;
1087: }
1088: for (i = 0, curField = fields; i < numFields; i++, curField++) {
1089: switch (curField->fmt) {
1090: char string[30];
1091:
1092: case 'd':
1093: sprintf(string, "%d", *((int *) curField->location));
1094: Tcl_SetVar(interp, argv[i+3], string, 0);
1095: break;
1096:
1097: case 'c':
1098: sprintf(string, "%d", *((char *) curField->location) & 0xff);
1099: Tcl_SetVar(interp, argv[i+3], string, 0);
1100: break;
1101:
1102: case 's':
1103: Tcl_SetVar(interp, argv[i+3], curField->location, 0);
1104: break;
1105:
1106: case 'F':
1107: sprintf(string, "%g", *((double *) curField->location));
1108: Tcl_SetVar(interp, argv[i+3], string, 0);
1109: break;
1110:
1111: case 'f':
1112: sprintf(string, "%g", *((float *) curField->location));
1113: Tcl_SetVar(interp, argv[i+3], string, 0);
1114: break;
1115: }
1116: }
1117: free(results);
1118: sprintf(interp->result, "%d", numScanned);
1119: return TCL_OK;
1120: }
1121:
1122: /*
1123: *----------------------------------------------------------------------
1124: *
1125: * Tcl_SourceCmd --
1126: *
1127: * This procedure is invoked to process the "source" Tcl command.
1128: * See the user documentation for details on what it does.
1129: *
1130: * Results:
1131: * A standard Tcl result.
1132: *
1133: * Side effects:
1134: * See the user documentation.
1135: *
1136: *----------------------------------------------------------------------
1137: */
1138:
1139: /* ARGSUSED */
1140: int
1141: Tcl_SourceCmd(dummy, interp, argc, argv)
1142: ClientData dummy; /* Not used. */
1143: Tcl_Interp *interp; /* Current interpreter. */
1144: int argc; /* Number of arguments. */
1145: char **argv; /* Argument strings. */
1146: {
1147: #pragma ref dummy
1148: int fileId, result;
1149: struct stat statBuf;
1150: char *cmdBuffer, *end;
1151: char *fileName;
1152:
1153: if (argc != 2) {
1154: sprintf(interp->result, "wrong # args: should be \"%.50s fileName\"",
1155: argv[0]);
1156: return TCL_ERROR;
1157: }
1158: fileName = Tcl_TildeSubst(interp, argv[1]);
1159: if (fileName == NULL) {
1160: return TCL_ERROR;
1161: }
1162: fileId = open(fileName, O_RDONLY, 0);
1163: if (fileId < 0) {
1164: sprintf(interp->result, "couldn't read file \"%.50s\"", argv[1]);
1165: return TCL_ERROR;
1166: }
1167: if (fstat(fileId, &statBuf) == -1) {
1168: sprintf(interp->result, "couldn't stat file \"%.50s\"", argv[1]);
1169: close(fileId);
1170: return TCL_ERROR;
1171: }
1172: cmdBuffer = (char *) malloc((unsigned) statBuf.st_size+1);
1173: if (read(fileId, cmdBuffer, (int) statBuf.st_size) != statBuf.st_size) {
1174: sprintf(interp->result, "error in reading file \"%.50s\"", argv[1]);
1175: close(fileId);
1176: return TCL_ERROR;
1177: }
1178: close(fileId);
1179: cmdBuffer[statBuf.st_size] = 0;
1180: result = Tcl_Eval(interp, cmdBuffer, 0, &end);
1181: if (result == TCL_RETURN) {
1182: result = TCL_OK;
1183: }
1184: if (result == TCL_ERROR) {
1185: char msg[100];
1186:
1187: /*
1188: * Record information telling where the error occurred.
1189: */
1190:
1191: sprintf(msg, " (file \"%.50s\" line %d)", argv[1], interp->errorLine);
1192: Tcl_AddErrorInfo(interp, msg);
1193: }
1194: free(cmdBuffer);
1195: return result;
1196: }
1197:
1198: /*
1199: *----------------------------------------------------------------------
1200: *
1201: * Tcl_StringCmd --
1202: *
1203: * This procedure is invoked to process the "string" Tcl command.
1204: * See the user documentation for details on what it does.
1205: *
1206: * Results:
1207: * A standard Tcl result.
1208: *
1209: * Side effects:
1210: * See the user documentation.
1211: *
1212: *----------------------------------------------------------------------
1213: */
1214:
1215: /* ARGSUSED */
1216: int
1217: Tcl_StringCmd(dummy, interp, argc, argv)
1218: ClientData dummy; /* Not used. */
1219: Tcl_Interp *interp; /* Current interpreter. */
1220: int argc; /* Number of arguments. */
1221: char **argv; /* Argument strings. */
1222: {
1223: #pragma ref dummy
1224: int length;
1225: register char *p, c;
1226: int match;
1227: int first;
1228:
1229: if (argc != 4) {
1230: sprintf(interp->result,
1231: "wrong # args: should be \"%.50s option a b\"",
1232: argv[0]);
1233: return TCL_ERROR;
1234: }
1235: length = strlen(argv[1]);
1236: if (strncmp(argv[1], "compare", length) == 0) {
1237: match = strcmp(argv[2], argv[3]);
1238: if (match > 0) {
1239: interp->result = "1";
1240: } else if (match < 0) {
1241: interp->result = "-1";
1242: } else {
1243: interp->result = "0";
1244: }
1245: return TCL_OK;
1246: }
1247: if (strncmp(argv[1], "first", length) == 0) {
1248: first = 1;
1249: } else if (strncmp(argv[1], "last", length) == 0) {
1250: first = 0;
1251: } else if (strncmp(argv[1], "match", length) == 0) {
1252: if (Tcl_StringMatch(argv[3], argv[2]) != 0) {
1253: interp->result = "1";
1254: } else {
1255: interp->result = "0";
1256: }
1257: return TCL_OK;
1258: } else {
1259: sprintf(interp->result,
1260: "bad \"%.50s\" option \"%.50s\": must be compare, first, or last",
1261: argv[0], argv[1]);
1262: return TCL_ERROR;
1263: }
1264: match = -1;
1265: c = *argv[2];
1266: length = strlen(argv[2]);
1267: for (p = argv[3]; *p != 0; p++) {
1268: if (*p != c) {
1269: continue;
1270: }
1271: if (strncmp(argv[2], p, length) == 0) {
1272: match = p-argv[3];
1273: if (first) {
1274: break;
1275: }
1276: }
1277: }
1278: sprintf(interp->result, "%d", match);
1279: return TCL_OK;
1280: }
1281:
1282: /*
1283: *----------------------------------------------------------------------
1284: *
1285: * Tcl_TimeCmd --
1286: *
1287: * This procedure is invoked to process the "time" Tcl command.
1288: * See the user documentation for details on what it does.
1289: *
1290: * Results:
1291: * A standard Tcl result.
1292: *
1293: * Side effects:
1294: * See the user documentation.
1295: *
1296: *----------------------------------------------------------------------
1297: */
1298:
1299: /* ARGSUSED */
1300: int
1301: Tcl_TimeCmd(dummy, interp, argc, argv)
1302: ClientData dummy; /* Not used. */
1303: Tcl_Interp *interp; /* Current interpreter. */
1304: int argc; /* Number of arguments. */
1305: char **argv; /* Argument strings. */
1306: {
1307: #pragma ref dummy
1308: int count, i, result;
1309: struct tms start, stop;
1310: int micros;
1311: double timePer;
1312:
1313: if (argc == 2) {
1314: count = 1;
1315: } else if (argc == 3) {
1316: if (sscanf(argv[2], "%d", &count) != 1) {
1317: sprintf(interp->result, "bad count \"%.50s\" given to \"%.50s\"",
1318: argv[2], argv[0]);
1319: return TCL_ERROR;
1320: }
1321: } else {
1322: sprintf(interp->result,
1323: "wrong # args: should be \"%.50s command [count]\"",
1324: argv[0]);
1325: return TCL_ERROR;
1326: }
1327: times(&start);
1328: for (i = count ; i > 0; i--) {
1329: result = Tcl_Eval(interp, argv[1], 0, (char **) NULL);
1330: if (result != TCL_OK) {
1331: if (result == TCL_ERROR) {
1332: char msg[60];
1333: sprintf(msg, " (\"time\" body line %d)", interp->errorLine);
1334: Tcl_AddErrorInfo(interp, msg);
1335: }
1336: return result;
1337: }
1338: }
1339: times(&stop);
1340: micros = (stop.tms_utime - start.tms_utime)*1000000;
1341: timePer = micros;
1342: Tcl_Return(interp, (char *) NULL, TCL_STATIC);
1343: sprintf(interp->result, "%.0f microseconds per iteration", timePer/count);
1344: return TCL_OK;
1345: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.