![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to tclCmdAH.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 tclCmdAH.c CVS log | Up to [Research Unix] / researchv10no / cmd / worm / scsi / tcl |
1.1 root 1: /*
2: * tclCmdAH.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: * A to H.
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/tclCmdAH.c,v 1.45 90/04/18 17:09:19 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 <signal.h>
28: #include <stdio.h>
29: #include <stdlib.h>
30: #include <unistd.h>
31: #include <string.h>
32: #include <sys/types.h>
33: #include <fcntl.h>
34: #include <sys/stat.h>
35: #include <sys/wait.h>
36: #include "tclInt.h"
37:
38: extern long lseek();
39: extern char *mktemp();
40:
41: /*
42: *----------------------------------------------------------------------
43: *
44: * Tcl_BreakCmd --
45: *
46: * This procedure is invoked to process the "break" Tcl command.
47: * See the user documentation for details on what it does.
48: *
49: * Results:
50: * A standard Tcl result.
51: *
52: * Side effects:
53: * See the user documentation.
54: *
55: *----------------------------------------------------------------------
56: */
57:
58: /* ARGSUSED */
59: int
60: Tcl_BreakCmd(dummy, interp, argc, argv)
61: ClientData dummy; /* Not used. */
62: Tcl_Interp *interp; /* Current interpreter. */
63: int argc; /* Number of arguments. */
64: char **argv; /* Argument strings. */
65: {
66: #pragma ref dummy
67: if (argc != 1) {
68: sprintf(interp->result, "too many args: should be \"%.50s\"", argv[0]);
69: return TCL_ERROR;
70: }
71: return TCL_BREAK;
72: }
73:
74: /*
75: *----------------------------------------------------------------------
76: *
77: * Tcl_CaseCmd --
78: *
79: * This procedure is invoked to process the "case" Tcl command.
80: * See the user documentation for details on what it does.
81: *
82: * Results:
83: * A standard Tcl result.
84: *
85: * Side effects:
86: * See the user documentation.
87: *
88: *----------------------------------------------------------------------
89: */
90:
91: /* ARGSUSED */
92: int
93: Tcl_CaseCmd(dummy, interp, argc, argv)
94: ClientData dummy; /* Not used. */
95: Tcl_Interp *interp; /* Current interpreter. */
96: int argc; /* Number of arguments. */
97: char **argv; /* Argument strings. */
98: {
99: #pragma ref dummy
100: int i, result;
101: int body;
102: char *string;
103:
104: if (argc < 4) {
105: sprintf(interp->result,
106: "%s \"%.50s string [in] patList body ... [default body]\"",
107: "not enough args: should be", argv[0]);
108: return TCL_ERROR;
109: }
110: string = argv[1];
111: body = NULL;
112: if (strcmp(argv[2], "in") == 0) {
113: i = 3;
114: } else {
115: i = 2;
116: }
117: for (; i < argc; i += 2) {
118: int patArgc, j;
119: char **patArgv;
120: register char *p;
121:
122: if (i == (argc-1)) {
123: sprintf(interp->result, "extra pattern with no body in \"%.50s\"",
124: argv[0]);
125: return TCL_ERROR;
126: }
127:
128: /*
129: * Check for special case of single pattern (no list) with
130: * no backslash sequences.
131: */
132:
133: for (p = argv[i]; *p != 0; p++) {
134: if (isspace(*p) || (*p == '\\')) {
135: break;
136: }
137: }
138: if (*p == 0) {
139: if ((*argv[i] == 'd') && (strcmp(argv[i], "default") == 0)) {
140: body = i+1;
141: }
142: if (Tcl_StringMatch(string, argv[i])) {
143: body = i+1;
144: goto match;
145: }
146: continue;
147: }
148:
149: /*
150: * Break up pattern lists, then check each of the patterns
151: * in the list.
152: */
153:
154: result = Tcl_SplitList(interp, argv[i], &patArgc, &patArgv);
155: if (result != TCL_OK) {
156: return result;
157: }
158: for (j = 0; j < patArgc; j++) {
159: if (Tcl_StringMatch(string, patArgv[j])) {
160: body = i+1;
161: break;
162: }
163: }
164: free((char *) patArgv);
165: if (j < patArgc) {
166: break;
167: }
168: }
169:
170: match:
171: if (body != NULL) {
172: result = Tcl_Eval(interp, argv[body], 0, (char **) NULL);
173: if (result == TCL_ERROR) {
174: char msg[100];
175: sprintf(msg, " (\"%.50s\" arm line %d)", argv[i],
176: interp->errorLine);
177: Tcl_AddErrorInfo(interp, msg);
178: }
179: return result;
180: }
181:
182: /*
183: * Nothing matched: return nothing.
184: */
185: return TCL_OK;
186: }
187:
188: /*
189: *----------------------------------------------------------------------
190: *
191: * Tcl_CatchCmd --
192: *
193: * This procedure is invoked to process the "catch" Tcl command.
194: * See the user documentation for details on what it does.
195: *
196: * Results:
197: * A standard Tcl result.
198: *
199: * Side effects:
200: * See the user documentation.
201: *
202: *----------------------------------------------------------------------
203: */
204:
205: /* ARGSUSED */
206: int
207: Tcl_CatchCmd(dummy, interp, argc, argv)
208: ClientData dummy; /* Not used. */
209: Tcl_Interp *interp; /* Current interpreter. */
210: int argc; /* Number of arguments. */
211: char **argv; /* Argument strings. */
212: {
213: #pragma ref dummy
214: int result;
215:
216: if ((argc != 2) && (argc != 3)) {
217: sprintf(interp->result,
218: "wrong # args: should be \"%.50s command [varName]\"",
219: argv[0]);
220: return TCL_ERROR;
221: }
222: result = Tcl_Eval(interp, argv[1], 0, (char **) NULL);
223: if (argc == 3) {
224: Tcl_SetVar(interp, argv[2], interp->result, 0);
225: }
226: Tcl_Return(interp, (char *) NULL, TCL_STATIC);
227: sprintf(interp->result, "%d", result);
228: return TCL_OK;
229: }
230:
231: /*
232: *----------------------------------------------------------------------
233: *
234: * Tcl_ConcatCmd --
235: *
236: * This procedure is invoked to process the "concat" Tcl command.
237: * See the user documentation for details on what it does.
238: *
239: * Results:
240: * A standard Tcl result.
241: *
242: * Side effects:
243: * See the user documentation.
244: *
245: *----------------------------------------------------------------------
246: */
247:
248: /* ARGSUSED */
249: int
250: Tcl_ConcatCmd(dummy, interp, argc, argv)
251: ClientData dummy; /* Not used. */
252: Tcl_Interp *interp; /* Current interpreter. */
253: int argc; /* Number of arguments. */
254: char **argv; /* Argument strings. */
255: {
256: #pragma ref dummy
257: if (argc == 1) {
258: sprintf(interp->result,
259: "not enough args: should be \"%.50s arg [arg ...]\"",
260: argv[0]);
261: return TCL_ERROR;
262: }
263:
264: interp->result = Tcl_Concat(argc-1, argv+1);
265: interp->dynamic = 1;
266: return TCL_OK;
267: }
268:
269: /*
270: *----------------------------------------------------------------------
271: *
272: * Tcl_ContinueCmd --
273: *
274: * This procedure is invoked to process the "continue" Tcl command.
275: * See the user documentation for details on what it does.
276: *
277: * Results:
278: * A standard Tcl result.
279: *
280: * Side effects:
281: * See the user documentation.
282: *
283: *----------------------------------------------------------------------
284: */
285:
286: /* ARGSUSED */
287: int
288: Tcl_ContinueCmd(dummy, interp, argc, argv)
289: ClientData dummy; /* Not used. */
290: Tcl_Interp *interp; /* Current interpreter. */
291: int argc; /* Number of arguments. */
292: char **argv; /* Argument strings. */
293: {
294: #pragma ref dummy
295: if (argc != 1) {
296: sprintf(interp->result, "too many args: should be \"%.50s\"", argv[0]);
297: return TCL_ERROR;
298: }
299: return TCL_CONTINUE;
300: }
301:
302: /*
303: *----------------------------------------------------------------------
304: *
305: * Tcl_ErrorCmd --
306: *
307: * This procedure is invoked to process the "error" Tcl command.
308: * See the user documentation for details on what it does.
309: *
310: * Results:
311: * A standard Tcl result.
312: *
313: * Side effects:
314: * See the user documentation.
315: *
316: *----------------------------------------------------------------------
317: */
318:
319: /* ARGSUSED */
320: int
321: Tcl_ErrorCmd(dummy, interp, argc, argv)
322: ClientData dummy; /* Not used. */
323: Tcl_Interp *interp; /* Current interpreter. */
324: int argc; /* Number of arguments. */
325: char **argv; /* Argument strings. */
326: {
327: #pragma ref dummy
328: Interp *iPtr = (Interp *) interp;
329:
330: if ((argc != 2) && (argc != 3)) {
331: sprintf(interp->result, "wrong # args: should be \"%.50s message [errorInfo]\"",
332: argv[0]);
333: return TCL_ERROR;
334: }
335: if (argc == 3) {
336: Tcl_AddErrorInfo(interp, argv[2]);
337: iPtr->flags |= ERR_ALREADY_LOGGED;
338: }
339: Tcl_Return(interp, argv[1], TCL_VOLATILE);
340: return TCL_ERROR;
341: }
342:
343: /*
344: *----------------------------------------------------------------------
345: *
346: * Tcl_EvalCmd --
347: *
348: * This procedure is invoked to process the "eval" Tcl command.
349: * See the user documentation for details on what it does.
350: *
351: * Results:
352: * A standard Tcl result.
353: *
354: * Side effects:
355: * See the user documentation.
356: *
357: *----------------------------------------------------------------------
358: */
359:
360: /* ARGSUSED */
361: int
362: Tcl_EvalCmd(dummy, interp, argc, argv)
363: ClientData dummy; /* Not used. */
364: Tcl_Interp *interp; /* Current interpreter. */
365: int argc; /* Number of arguments. */
366: char **argv; /* Argument strings. */
367: {
368: #pragma ref dummy
369: int result;
370: char *cmd;
371:
372: if (argc < 2) {
373: sprintf(interp->result,
374: "not enough args: should be \"%.50s arg [arg ...]\"",
375: argv[0]);
376: return TCL_ERROR;
377: }
378: if (argc == 2) {
379: result = Tcl_Eval(interp, argv[1], 0, (char **) NULL);
380: } else {
381:
382: /*
383: * More than one argument: concatenate them together with spaces
384: * between, then evaluate the result.
385: */
386:
387: cmd = Tcl_Concat(argc-1, argv+1);
388: result = Tcl_Eval(interp, cmd, 0, (char **) NULL);
389: free(cmd);
390: }
391: if (result == TCL_ERROR) {
392: char msg[60];
393: sprintf(msg, " (\"eval\" body line %d)", interp->errorLine);
394: Tcl_AddErrorInfo(interp, msg);
395: }
396: return result;
397: }
398:
399: /*
400: *----------------------------------------------------------------------
401: *
402: * Tcl_ExecCmd --
403: *
404: * This procedure is invoked to process the "exec" Tcl command.
405: * See the user documentation for details on what it does.
406: *
407: * Results:
408: * A standard Tcl result.
409: *
410: * Side effects:
411: * See the user documentation.
412: *
413: *----------------------------------------------------------------------
414: */
415:
416: /* ARGSUSED */
417: int
418: Tcl_ExecCmd(dummy, interp, argc, argv)
419: ClientData dummy; /* Not used. */
420: Tcl_Interp *interp; /* Current interpreter. */
421: int argc; /* Number of arguments. */
422: char **argv; /* Argument strings. */
423: {
424: #pragma ref dummy
425: char *input = ""; /* Points to the input remaining to
426: * send to the child process. */
427: int inputSize; /* # of bytes of input. */
428: #define MAX_PIPE_INPUT 4095
429: #define TMP_FILE_NAME "/tmp/tcl.XXXXXX"
430: char *output = NULL; /* Output received from child. */
431: int outputSize; /* Number of valid bytes at output. */
432: int outputSpace; /* Total space available at output. */
433: int stdIn[2], stdOut[2], count, result, i;
434: int pid = -1; /* -1 means child process doesn't
435: * exist (yet). Non-zero gives its
436: * id (0 only in child). */
437: int status;
438: char *cmdName, *execName;
439:
440: /*
441: * Look through the arguments for a standard input specification
442: * ("< value" in two arguments). If found, collapse it out.
443: * Shuffle all the arguments back over the "exec" argument, so that
444: * there's room for a NULL argument at the end.
445: */
446:
447: cmdName = argv[0];
448: for (i = 1; i < argc; i++) {
449: argv[i-1] = argv[i];
450: if ((argv[i][0] != '<') || (argv[i][1] != 0)) {
451: continue;
452: }
453: i++;
454: if (i >= argc) {
455: sprintf(interp->result,
456: "specified \"<\" but no input in \"%.50s\" command",
457: cmdName);
458: return TCL_ERROR;
459: }
460: input = argv[i];
461: for (i++; i < argc; i++) {
462: argv[i-3] = argv[i];
463: }
464: argc -= 2;
465: }
466:
467: argc -= 1; /* Drop "exec" argument. */
468: argv[argc] = NULL;
469: if (argc < 1) {
470: sprintf(interp->result, "not enough arguments to \"%.50s\" command",
471: cmdName);
472: return TCL_ERROR;
473: }
474: execName = Tcl_TildeSubst(interp, argv[0]);
475: if (execName == NULL) {
476: return TCL_ERROR;
477: }
478:
479: /*
480: * Set up the input stream for child. Use a pipe if the amount of
481: * input data is small enough for us to write it to the pipe without
482: * overflowing the pipe and blocking. If there's too much input data,
483: * then write it to a temporary file.
484: */
485:
486: stdIn[0] = stdIn[1] = stdOut[0] = stdOut[1] = -1;
487: inputSize = strlen(input);
488: if (inputSize <= MAX_PIPE_INPUT) {
489: if (pipe(stdIn) < 0) {
490: sprintf(interp->result,
491: "couldn't create input pipe for \"%.50s\" command: %.50s",
492: cmdName, strerror(errno));
493: result = TCL_ERROR;
494: goto cleanup;
495: }
496: if (write(stdIn[1], input, inputSize) != inputSize) {
497: sprintf(interp->result,
498: "couldn't write pipe input for command: %.50s",
499: strerror(errno));
500: result = TCL_ERROR;
501: goto cleanup;
502: }
503: close(stdIn[1]);
504: stdIn[1] = -1;
505: } else {
506: char tmp[L_tmpnam];
507: tmpnam(tmp);
508: stdIn[0] = open(tmp, O_RDWR|O_CREAT, 0);
509: if (stdIn[0] < 0) {
510: sprintf(interp->result,
511: "couldn't create input file for \"%.50s\" command: %.50s",
512: cmdName, strerror(errno));
513: result = TCL_ERROR;
514: goto cleanup;
515: }
516: if (write(stdIn[0], input, inputSize) != inputSize) {
517: sprintf(interp->result,
518: "couldn't write file input for command: %.50s",
519: strerror(errno));
520: result = TCL_ERROR;
521: goto cleanup;
522: }
523: if ((lseek(stdIn[0], 0L, 0) == -1) || (unlink(tmp) == -1)) {
524: sprintf(interp->result,
525: "couldn't reset or close input file for command: %.50s",
526: strerror(errno));
527: result = TCL_ERROR;
528: goto cleanup;
529: }
530: }
531:
532: /*
533: * Set up an output pipe from the child's stdout/stderr back to
534: * us, then fork the child.
535: */
536:
537: if (pipe(stdOut) < 0) {
538: sprintf(interp->result,
539: "couldn't create output pipe for \"%.50s\" command",
540: cmdName);
541: result = TCL_ERROR;
542: goto cleanup;
543: }
544: pid = fork();
545: if (pid == -1) {
546: sprintf(interp->result,
547: "couldn't fork child for \"%.50s\" command: %.50s",
548: cmdName, strerror(errno));
549: result = TCL_ERROR;
550: goto cleanup;
551: }
552: if (pid == 0) {
553: char errSpace[100];
554:
555: if ((dup2(stdIn[0], 0) == -1) || (dup2(stdOut[1], 1) == -1)
556: || (dup2(stdOut[1], 2) == -1)) {
557: char *err;
558: err = "forked process couldn't set up input/output";
559: write(stdOut[1], err, strlen(err));
560: _exit(1);
561: }
562: close(stdIn[0]);
563: close(stdOut[0]);
564: close(stdOut[1]);
565: execvp(execName, argv);
566: sprintf(errSpace, "couldn't find a \"%.50s\" to execute", argv[0]);
567: write(1, errSpace, strlen(errSpace));
568: _exit(1);
569: }
570:
571: /*
572: * In the parent, read output from the child until end of file
573: * (this should mean that the child has completed and died).
574: */
575:
576: close(stdIn[0]);
577: stdIn[0] = -1;
578: close(stdOut[1]);
579: stdOut[1] = -1;
580: outputSize = 0;
581: outputSpace = 0;
582: result = -1;
583: while (1) {
584: if ((outputSpace - outputSize) < 100) {
585: char *newOutput;
586:
587: if (outputSpace == 0) {
588: outputSpace = 200;
589: } else {
590: outputSpace = 2*outputSpace;
591: }
592: newOutput = (char *) malloc((unsigned) outputSpace);
593: if (output != 0) {
594: bcopy(output, newOutput, outputSize);
595: free(output);
596: }
597: output = newOutput;
598: }
599: count = read(stdOut[0], output+outputSize,
600: outputSpace-outputSize-1);
601:
602: if (count == 0) {
603: break;
604: }
605: if (count < 0) {
606: sprintf(interp->result,
607: "error reading stdout during \"%.50s\": %.50s",
608: cmdName, strerror(errno));
609: result = TCL_ERROR;
610: goto cleanup;
611: }
612: outputSize += count;
613: }
614:
615: /*
616: * The command is supposedly done now. Terminate the result
617: * string and wait for the process really to complete.
618: */
619:
620: output[outputSize] = 0;
621: interp->result = output;
622: interp->dynamic = 1;
623:
624: cleanup:
625: if (pid != -1) {
626: while (1) {
627: int child;
628:
629: child = wait(&status);
630: if (child == -1) {
631: sprintf(interp->result,
632: "child process disappeared mysteriously");
633: result = TCL_ERROR;
634: break;
635: }
636: if (child == pid) {
637: break;
638: }
639: }
640: if (!WIFEXITED(status)) {
641: sprintf(interp->result, "command terminated abnormally");
642: result = TCL_ERROR;
643: }
644: result = status;
645: }
646: if (stdIn[0] != -1) {
647: close(stdIn[0]);
648: }
649: if (stdIn[1] != -1) {
650: close(stdIn[1]);
651: }
652: if (stdOut[0] != -1) {
653: close(stdOut[0]);
654: }
655: if (stdOut[1] != -1) {
656: close(stdOut[1]);
657: }
658: return result;
659: }
660:
661: /*
662: *----------------------------------------------------------------------
663: *
664: * Tcl_ExprCmd --
665: *
666: * This procedure is invoked to process the "expr" Tcl command.
667: * See the user documentation for details on what it does.
668: *
669: * Results:
670: * A standard Tcl result.
671: *
672: * Side effects:
673: * See the user documentation.
674: *
675: *----------------------------------------------------------------------
676: */
677:
678: /* ARGSUSED */
679: int
680: Tcl_ExprCmd(dummy, interp, argc, argv)
681: ClientData dummy; /* Not used. */
682: Tcl_Interp *interp; /* Current interpreter. */
683: int argc; /* Number of arguments. */
684: char **argv; /* Argument strings. */
685: {
686: #pragma ref dummy
687: int result, value;
688:
689: if (argc != 2) {
690: sprintf(interp->result,
691: "wrong # args: should be \"%.50s expression\"", argv[0]);
692: return TCL_ERROR;
693: }
694:
695: result = Tcl_Expr(interp, argv[1], &value);
696: if (result != TCL_OK) {
697: return result;
698: }
699:
700: /*
701: * Turn the integer result back into a string.
702: */
703:
704: sprintf(interp->result, "%d", value);
705: return TCL_OK;
706: }
707:
708: /*
709: *----------------------------------------------------------------------
710: *
711: * Tcl_FileCmd --
712: *
713: * This procedure is invoked to process the "file" Tcl command.
714: * See the user documentation for details on what it does.
715: *
716: * Results:
717: * A standard Tcl result.
718: *
719: * Side effects:
720: * See the user documentation.
721: *
722: *----------------------------------------------------------------------
723: */
724:
725: /* ARGSUSED */
726: int
727: Tcl_FileCmd(dummy, interp, argc, argv)
728: ClientData dummy; /* Not used. */
729: Tcl_Interp *interp; /* Current interpreter. */
730: int argc; /* Number of arguments. */
731: char **argv; /* Argument strings. */
732: {
733: #pragma ref dummy
734: char *p;
735: int length, mode, statOp;
736: struct stat statBuf;
737: char *fileName;
738:
739: if (argc != 3) {
740: sprintf(interp->result,
741: "wrong # args: should be \"%.50s name option\"", argv[0]);
742: return TCL_ERROR;
743: }
744: length = strlen(argv[2]);
745:
746: /*
747: * First handle operations on the file name.
748: */
749:
750: fileName = Tcl_TildeSubst(interp, argv[1]);
751: if ((argv[2][0] == 'd') && (strncmp(argv[2], "dirname", length) == 0)) {
752: p = strrchr(fileName, '/');
753: if (p == NULL) {
754: interp->result = ".";
755: } else if (p == fileName) {
756: interp->result = "/";
757: } else {
758: *p = 0;
759: Tcl_Return(interp, fileName, TCL_VOLATILE);
760: *p = '/';
761: }
762: return TCL_OK;
763: } else if ((argv[2][0] == 'r') && (length >= 2)
764: && (strncmp(argv[2], "rootname", length) == 0)) {
765: p = strrchr(fileName, '.');
766: if (p == NULL) {
767: Tcl_Return(interp, fileName, TCL_VOLATILE);
768: } else {
769: *p = 0;
770: Tcl_Return(interp, fileName, TCL_VOLATILE);
771: *p = '.';
772: }
773: return TCL_OK;
774: } else if ((argv[2][0] == 'e') && (length >= 3)
775: && (strncmp(argv[2], "extension", length) == 0)) {
776: char *lastSlash;
777:
778: p = strrchr(fileName, '.');
779: lastSlash = strrchr(fileName, '/');
780: if ((p != NULL) && ((lastSlash == NULL) || (lastSlash < p))) {
781: Tcl_Return(interp, p, TCL_VOLATILE);
782: }
783: return TCL_OK;
784: } else if ((argv[2][0] == 't') && (strncmp(argv[2], "tail", length) == 0)) {
785: p = strrchr(fileName, '/');
786: if (p != NULL) {
787: Tcl_Return(interp, p+1, TCL_VOLATILE);
788: } else {
789: Tcl_Return(interp, fileName, TCL_VOLATILE);
790: }
791: return TCL_OK;
792: }
793:
794: /*
795: * Next, handle operations that can be satisfied with the "access"
796: * kernel call.
797: */
798:
799: if (fileName == NULL) {
800: return TCL_ERROR;
801: }
802: if ((argv[2][0] == 'r') && (length >= 2)
803: && (strncmp(argv[2], "readable", length) == 0)) {
804: mode = R_OK;
805: checkAccess:
806: if (access(fileName, mode) == -1) {
807: interp->result = "0";
808: } else {
809: interp->result = "1";
810: }
811: return TCL_OK;
812: } else if ((argv[2][0] == 'w')
813: && (strncmp(argv[2], "writable", length) == 0)) {
814: mode = W_OK;
815: goto checkAccess;
816: } else if ((argv[2][0] == 'e') && (length >= 3)
817: && (strncmp(argv[2], "executable", length) == 0)) {
818: mode = X_OK;
819: goto checkAccess;
820: } else if ((argv[2][0] == 'e') && (length >= 3)
821: && (strncmp(argv[2], "exists", length) == 0)) {
822: mode = F_OK;
823: goto checkAccess;
824: }
825:
826: /*
827: * Lastly, check stuff that requires the file to be stat-ed.
828: */
829:
830: if ((argv[2][0] == 'o') && (strncmp(argv[2], "owned", length) == 0)) {
831: statOp = 0;
832: } else if ((argv[2][0] == 'i') && (length >= 3)
833: && (strncmp(argv[2], "isfile", length) == 0)) {
834: statOp = 1;
835: } else if ((argv[2][0] == 'i') && (length >= 3)
836: && (strncmp(argv[2], "isdirectory", length) == 0)) {
837: statOp = 2;
838: } else {
839: sprintf(interp->result, "bad \"%.30s\" option \"%.30s\": must be dirname, executable, exists, extension, isdirectory, isfile, owned, readable, root, tail, or writable",
840: argv[0], argv[2]);
841: return TCL_ERROR;
842: }
843: if (stat(fileName, &statBuf) == -1) {
844: interp->result = "0";
845: return TCL_OK;
846: }
847: switch (statOp) {
848: case 0:
849: mode = (geteuid() == statBuf.st_uid);
850: break;
851: case 1:
852: mode = S_ISREG(statBuf.st_mode);
853: break;
854: case 2:
855: mode = S_ISDIR(statBuf.st_mode);
856: break;
857: }
858: if (mode) {
859: interp->result = "1";
860: } else {
861: interp->result = "0";
862: }
863: return TCL_OK;
864: }
865:
866: /*
867: *----------------------------------------------------------------------
868: *
869: * Tcl_ForCmd --
870: *
871: * This procedure is invoked to process the "for" Tcl command.
872: * See the user documentation for details on what it does.
873: *
874: * Results:
875: * A standard Tcl result.
876: *
877: * Side effects:
878: * See the user documentation.
879: *
880: *----------------------------------------------------------------------
881: */
882:
883: /* ARGSUSED */
884: int
885: Tcl_ForCmd(dummy, interp, argc, argv)
886: ClientData dummy; /* Not used. */
887: Tcl_Interp *interp; /* Current interpreter. */
888: int argc; /* Number of arguments. */
889: char **argv; /* Argument strings. */
890: {
891: #pragma ref dummy
892: int result, value;
893:
894: if (argc != 5) {
895: sprintf(interp->result,
896: "wrong # args: should be \"%.50s start test next command\"",
897: argv[0]);
898: return TCL_ERROR;
899: }
900:
901: result = Tcl_Eval(interp, argv[1], 0, (char **) NULL);
902: if (result != TCL_OK) {
903: if (result == TCL_ERROR) {
904: Tcl_AddErrorInfo(interp, " (\"for\" initial command)");
905: }
906: return result;
907: }
908: while (1) {
909: result = Tcl_Expr(interp, argv[2], &value);
910: if (result != TCL_OK) {
911: return result;
912: }
913: if (!value) {
914: break;
915: }
916: result = Tcl_Eval(interp, argv[4], 0, (char **) NULL);
917: if (result == TCL_CONTINUE) {
918: result = TCL_OK;
919: } else if (result != TCL_OK) {
920: if (result == TCL_ERROR) {
921: char msg[60];
922: sprintf(msg, " (\"for\" body line %d)", interp->errorLine);
923: Tcl_AddErrorInfo(interp, msg);
924: }
925: break;
926: }
927: result = Tcl_Eval(interp, argv[3], 0, (char **) NULL);
928: if (result == TCL_BREAK) {
929: break;
930: } else if (result != TCL_OK) {
931: if (result == TCL_ERROR) {
932: Tcl_AddErrorInfo(interp, " (\"for\" loop-end command)");
933: }
934: return result;
935: }
936: }
937: if (result == TCL_BREAK) {
938: result = TCL_OK;
939: }
940: if (result == TCL_OK) {
941: Tcl_Return(interp, (char *) NULL, TCL_STATIC);
942: }
943: return result;
944: }
945:
946: /*
947: *----------------------------------------------------------------------
948: *
949: * Tcl_ForeachCmd --
950: *
951: * This procedure is invoked to process the "foreach" Tcl command.
952: * See the user documentation for details on what it does.
953: *
954: * Results:
955: * A standard Tcl result.
956: *
957: * Side effects:
958: * See the user documentation.
959: *
960: *----------------------------------------------------------------------
961: */
962:
963: /* ARGSUSED */
964: int
965: Tcl_ForeachCmd(dummy, interp, argc, argv)
966: ClientData dummy; /* Not used. */
967: Tcl_Interp *interp; /* Current interpreter. */
968: int argc; /* Number of arguments. */
969: char **argv; /* Argument strings. */
970: {
971: #pragma ref dummy
972: int listArgc, i, result;
973: char **listArgv;
974:
975: if (argc != 4) {
976: sprintf(interp->result,
977: "wrong # args: should be \"%.50s varName list command\"",
978: argv[0]);
979: return TCL_ERROR;
980: }
981:
982: /*
983: * Break the list up into elements, and execute the command once
984: * for each value of the element.
985: */
986:
987: result = Tcl_SplitList(interp, argv[2], &listArgc, &listArgv);
988: if (result != TCL_OK) {
989: return result;
990: }
991: for (i = 0; i < listArgc; i++) {
992: Tcl_SetVar(interp, argv[1], listArgv[i], 0);
993:
994: result = Tcl_Eval(interp, argv[3], 0, (char **) NULL);
995: if (result != TCL_OK) {
996: if (result == TCL_CONTINUE) {
997: result = TCL_OK;
998: } else if (result == TCL_BREAK) {
999: result = TCL_OK;
1000: break;
1001: } else if (result == TCL_ERROR) {
1002: char msg[100];
1003: sprintf(msg, " (\"foreach\" body line %d)", interp->errorLine);
1004: Tcl_AddErrorInfo(interp, msg);
1005: break;
1006: } else {
1007: break;
1008: }
1009: }
1010: }
1011: free((char *) listArgv);
1012: if (result == TCL_OK) {
1013: Tcl_Return(interp, (char *) NULL, TCL_STATIC);
1014: }
1015: return result;
1016: }
1017:
1018: /*
1019: *----------------------------------------------------------------------
1020: *
1021: * Tcl_FormatCmd --
1022: *
1023: * This procedure is invoked to process the "format" Tcl command.
1024: * See the user documentation for details on what it does.
1025: *
1026: * Results:
1027: * A standard Tcl result.
1028: *
1029: * Side effects:
1030: * See the user documentation.
1031: *
1032: *----------------------------------------------------------------------
1033: */
1034:
1035: /* ARGSUSED */
1036: int
1037: Tcl_FormatCmd(dummy, interp, argc, argv)
1038: ClientData dummy; /* Not used. */
1039: Tcl_Interp *interp; /* Current interpreter. */
1040: int argc; /* Number of arguments. */
1041: char **argv; /* Argument strings. */
1042: {
1043: #pragma ref dummy
1044: register char *format; /* Used to read characters from the format
1045: * string. */
1046: char newFormat[40]; /* A new format specifier is generated here. */
1047: int width; /* Field width from field specifier, or 0 if
1048: * no width given. */
1049: int precision; /* Field precision from field specifier, or 0
1050: * if no precision given. */
1051: int size; /* Number of bytes needed for result of
1052: * conversion, based on type of conversion
1053: * ("e", "s", etc.) and width from above. */
1054: char *oneWordValue; /* Used to hold value to pass to sprintf, if
1055: * it's a one-word value. */
1056: double twoWordValue; /* Used to hold value to pass to sprintf if
1057: * it's a two-word value. */
1058: int useTwoWords; /* 0 means use oneWordValue, 1 means use
1059: * twoWordValue. */
1060: char *dst = interp->result; /* Where result is stored. Starts off at
1061: * interp->resultSpace, but may get dynamically
1062: * re-allocated if this isn't enough. */
1063: int dstSize = 0; /* Number of non-null characters currently
1064: * stored at dst. */
1065: int dstSpace = TCL_RESULT_SIZE;
1066: /* Total amount of storage space available
1067: * in dst (not including null terminator. */
1068: int noPercent; /* Special case for speed: indicates there's
1069: * no field specifier, just a string to copy. */
1070: char **curArg; /* Remainder of argv array. */
1071:
1072: /*
1073: * This procedure is a bit nasty. The goal is to use sprintf to
1074: * do most of the dirty work. There are several problems:
1075: * 1. this procedure can't trust its arguments.
1076: * 2. we must be able to provide a large enough result area to hold
1077: * whatever's generated. This is hard to estimate.
1078: * 2. there's no way to move the arguments from argv to the call
1079: * to sprintf in a reasonable way. This is particularly nasty
1080: * because some of the arguments may be two-word values (doubles).
1081: * So, what happens here is to scan the format string one % group
1082: * at a time, making many individual calls to sprintf.
1083: */
1084:
1085: if (argc < 2) {
1086: sprintf(interp->result,
1087: "too few args: should be \"%.50s formatString [arg arg ...]\"",
1088: argv[0]);
1089: return TCL_ERROR;
1090: }
1091: curArg = argv+2;
1092: argc -= 2;
1093: for (format = argv[1]; *format != 0; ) {
1094: register char *newPtr = newFormat;
1095:
1096: width = precision = useTwoWords = noPercent = 0;
1097:
1098: /*
1099: * Get rid of any characters before the next field specifier.
1100: * Collapse backslash sequences found along the way.
1101: */
1102:
1103: if (*format != '%') {
1104: register char *p;
1105: int bsSize;
1106:
1107: oneWordValue = format;
1108: for (p = format; (*format != '%') && (*format != 0); p++) {
1109: if (*format == '\\') {
1110: *p = Tcl_Backslash(format, &bsSize);
1111: format += bsSize;
1112: } else {
1113: *p = *format;
1114: format++;
1115: }
1116: }
1117: size = p - oneWordValue;
1118: noPercent = 1;
1119: goto doField;
1120: }
1121:
1122: if (format[1] == '%') {
1123: oneWordValue = format;
1124: size = 1;
1125: noPercent = 1;
1126: format += 2;
1127: goto doField;
1128: }
1129:
1130: /*
1131: * Parse off a field specifier, compute how many characters
1132: * will be needed to store the result, and substitute for
1133: * "*" size specifiers.
1134: */
1135:
1136: *newPtr = '%';
1137: newPtr++;
1138: format++;
1139: if (*format == '-') {
1140: *newPtr = '-';
1141: newPtr++;
1142: format++;
1143: }
1144: if (*format == '0') {
1145: *newPtr = '0';
1146: newPtr++;
1147: format++;
1148: }
1149: if (isdigit(*format)) {
1150: width = atoi(format);
1151: do {
1152: format++;
1153: } while (isdigit(*format));
1154: } else if (*format == '*') {
1155: if (argc <= 0) {
1156: goto notEnoughArgs;
1157: }
1158: width = atoi(*curArg);
1159: argc--;
1160: curArg++;
1161: format++;
1162: }
1163: if (width != 0) {
1164: sprintf(newPtr, "%d", width);
1165: while (*newPtr != 0) {
1166: newPtr++;
1167: }
1168: }
1169: if (*format == '.') {
1170: *newPtr = '.';
1171: newPtr++;
1172: format++;
1173: }
1174: if (isdigit(*format)) {
1175: precision = atoi(format);
1176: do {
1177: format++;
1178: } while (isdigit(*format));
1179: } else if (*format == '*') {
1180: if (argc <= 0) {
1181: goto notEnoughArgs;
1182: }
1183: precision = atoi(*curArg);
1184: argc--;
1185: curArg++;
1186: format++;
1187: }
1188: if (precision != 0) {
1189: sprintf(newPtr, "%d", precision);
1190: while (*newPtr != 0) {
1191: newPtr++;
1192: }
1193: }
1194: if (*format == '#') {
1195: *newPtr = '#';
1196: newPtr++;
1197: format++;
1198: }
1199: if (*format == 'l') {
1200: format++;
1201: }
1202: *newPtr = *format;
1203: newPtr++;
1204: *newPtr = 0;
1205: if (argc <= 0) {
1206: goto notEnoughArgs;
1207: }
1208: switch (*format) {
1209: case 'D':
1210: case 'd':
1211: case 'O':
1212: case 'o':
1213: case 'X':
1214: case 'x':
1215: case 'U':
1216: case 'u': {
1217: char *end;
1218:
1219: oneWordValue = (char *) strtol(*curArg, &end, 0);
1220: if ((*curArg == 0) || (*end != 0)) {
1221: sprintf(interp->result,
1222: "expected integer but got \"%.50s\" instead",
1223: *curArg);
1224: goto fmtError;
1225: }
1226: size = 40;
1227: break;
1228: }
1229: case 's':
1230: oneWordValue = *curArg;
1231: size = strlen(*curArg);
1232: break;
1233: case 'c': {
1234: char *end;
1235:
1236: oneWordValue = (char *) strtol(*curArg, &end, 0);
1237: if ((*curArg == 0) || (*end != 0)) {
1238: sprintf(interp->result,
1239: "expected integer but got \"%.50s\" instead",
1240: *curArg);
1241: goto fmtError;
1242: }
1243: size = 1;
1244: break;
1245: }
1246: case 'F':
1247: case 'f':
1248: case 'E':
1249: case 'e':
1250: case 'G':
1251: case 'g':
1252: if (sscanf(*curArg, "%F", &twoWordValue) != 1) {
1253: sprintf(interp->result,
1254: "expected floating-point number but got \"%.50s\" instead",
1255: *curArg);
1256: goto fmtError;
1257: }
1258: useTwoWords = 1;
1259: size = 320;
1260: if (precision > 10) {
1261: size += precision;
1262: }
1263: break;
1264: case 0:
1265: interp->result = "format string ended in middle of field specifier";
1266: goto fmtError;
1267: default:
1268: sprintf(interp->result, "bad field specifier \"%c\"", *format);
1269: goto fmtError;
1270: }
1271: argc--;
1272: curArg++;
1273: format++;
1274:
1275: /*
1276: * Make sure that there's enough space to hold the formatted
1277: * result, then format it.
1278: */
1279:
1280: doField:
1281: if (width > size) {
1282: size = width;
1283: }
1284: if ((dstSize + size) > dstSpace) {
1285: char *newDst;
1286: int newSpace;
1287:
1288: newSpace = 2*(dstSize + size);
1289: newDst = (char *) malloc((unsigned) newSpace+1);
1290: if (dstSize != 0) {
1291: bcopy(dst, newDst, dstSize);
1292: }
1293: if (dstSpace != TCL_RESULT_SIZE) {
1294: free(dst);
1295: }
1296: dst = newDst;
1297: dstSpace = newSpace;
1298: }
1299: if (noPercent) {
1300: bcopy(oneWordValue, dst+dstSize, size);
1301: dstSize += size;
1302: dst[dstSize] = 0;
1303: } else {
1304: if (useTwoWords) {
1305: sprintf(dst+dstSize, newFormat, twoWordValue);
1306: } else {
1307: sprintf(dst+dstSize, newFormat, oneWordValue);
1308: }
1309: dstSize += strlen(dst+dstSize);
1310: }
1311: }
1312:
1313: interp->result = dst;
1314: interp->dynamic = !(dstSpace == TCL_RESULT_SIZE);
1315: return TCL_OK;
1316:
1317: notEnoughArgs:
1318: sprintf(interp->result,
1319: "invoked \"%.50s\" without enough arguments", argv[0]);
1320: fmtError:
1321: if (dstSpace != TCL_RESULT_SIZE) {
1322: free(dst);
1323: }
1324: return TCL_ERROR;
1325: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.