![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to tclunxaz.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Micropolis - Activity] / micropolis / src / tcl|
Return to tclunxaz.c CVS log | Up to [Micropolis - Activity] / micropolis / src / tcl |
1.1 root 1: /*
2: * tclUnixAZ.c --
3: *
4: * This file contains the top-level command procedures for
5: * commands in the Tcl core that require UNIX facilities
6: * such as files and process execution. Much of the code
7: * in this file is based on earlier versions contributed
8: * by Karl Lehenbauer, Mark Diekhans and Peter da Silva.
9: *
10: * Copyright 1991 Regents of the University of California
11: * Permission to use, copy, modify, and distribute this
12: * software and its documentation for any purpose and without
13: * fee is hereby granted, provided that this copyright
14: * notice appears in all copies. The University of California
15: * makes no representations about the suitability of this
16: * software for any purpose. It is provided "as is" without
17: * express or implied warranty.
18: */
19:
20: #ifndef lint
21: static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclUnixAZ.c,v 1.36 92/04/16 13:32:02 ouster Exp $ sprite (Berkeley)";
22: #endif /* not lint */
23:
24: #include "tclint.h"
25: #include "tclunix.h"
26:
27: /*
28: * The variable below caches the name of the current working directory
29: * in order to avoid repeated calls to getwd. The string is malloc-ed.
30: * NULL means the cache needs to be refreshed.
31: */
32:
33: static char *currentDir = NULL;
34:
35: /*
36: * Prototypes for local procedures defined in this file:
37: */
38:
39: static int CleanupChildren _ANSI_ARGS_((Tcl_Interp *interp,
40: int numPids, int *pidPtr, int errorId));
41: static char * GetFileType _ANSI_ARGS_((int mode));
42: static int StoreStatData _ANSI_ARGS_((Tcl_Interp *interp,
43: char *varName, struct stat *statPtr));
44:
45: /*
46: *----------------------------------------------------------------------
47: *
48: * Tcl_CdCmd --
49: *
50: * This procedure is invoked to process the "cd" Tcl command.
51: * See the user documentation for details on what it does.
52: *
53: * Results:
54: * A standard Tcl result.
55: *
56: * Side effects:
57: * See the user documentation.
58: *
59: *----------------------------------------------------------------------
60: */
61:
62: /* ARGSUSED */
63: int
64: Tcl_CdCmd(dummy, interp, argc, argv)
65: ClientData dummy; /* Not used. */
66: Tcl_Interp *interp; /* Current interpreter. */
67: int argc; /* Number of arguments. */
68: char **argv; /* Argument strings. */
69: {
70: char *dirName;
71:
72: if (argc > 2) {
73: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
74: " dirName\"", (char *) NULL);
75: return TCL_ERROR;
76: }
77:
78: if (argc == 2) {
79: dirName = argv[1];
80: } else {
81: dirName = "~";
82: }
83: dirName = Tcl_TildeSubst(interp, dirName);
84: if (dirName == NULL) {
85: return TCL_ERROR;
86: }
87: if (currentDir != NULL) {
88: ckfree(currentDir);
89: currentDir = NULL;
90: }
91: if (chdir(dirName) != 0) {
92: Tcl_AppendResult(interp, "couldn't change working directory to \"",
93: dirName, "\": ", Tcl_UnixError(interp), (char *) NULL);
94: return TCL_ERROR;
95: }
96: return TCL_OK;
97: }
98:
99: /*
100: *----------------------------------------------------------------------
101: *
102: * Tcl_CloseCmd --
103: *
104: * This procedure is invoked to process the "close" Tcl command.
105: * See the user documentation for details on what it does.
106: *
107: * Results:
108: * A standard Tcl result.
109: *
110: * Side effects:
111: * See the user documentation.
112: *
113: *----------------------------------------------------------------------
114: */
115:
116: /* ARGSUSED */
117: int
118: Tcl_CloseCmd(dummy, interp, argc, argv)
119: ClientData dummy; /* Not used. */
120: Tcl_Interp *interp; /* Current interpreter. */
121: int argc; /* Number of arguments. */
122: char **argv; /* Argument strings. */
123: {
124: OpenFile *filePtr;
125: int result = TCL_OK;
126:
127: if (argc != 2) {
128: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
129: " fileId\"", (char *) NULL);
130: return TCL_ERROR;
131: }
132: if (TclGetOpenFile(interp, argv[1], &filePtr) != TCL_OK) {
133: return TCL_ERROR;
134: }
135: ((Interp *) interp)->filePtrArray[fileno(filePtr->f)] = NULL;
136:
137: /*
138: * First close the file (in the case of a process pipeline, there may
139: * be two files, one for the pipe at each end of the pipeline).
140: */
141:
142: if (filePtr->f2 != NULL) {
143: if (fclose(filePtr->f2) == EOF) {
144: Tcl_AppendResult(interp, "error closing \"", argv[1],
145: "\": ", Tcl_UnixError(interp), "\n", (char *) NULL);
146: result = TCL_ERROR;
147: }
148: }
149: if (fclose(filePtr->f) == EOF) {
150: Tcl_AppendResult(interp, "error closing \"", argv[1],
151: "\": ", Tcl_UnixError(interp), "\n", (char *) NULL);
152: result = TCL_ERROR;
153: }
154:
155: /*
156: * If the file was a connection to a pipeline, clean up everything
157: * associated with the child processes.
158: */
159:
160: if (filePtr->numPids > 0) {
161: if (CleanupChildren(interp, filePtr->numPids, filePtr->pidPtr,
162: filePtr->errorId) != TCL_OK) {
163: result = TCL_ERROR;
164: }
165: }
166:
167: ckfree((char *) filePtr);
168: return result;
169: }
170:
171: /*
172: *----------------------------------------------------------------------
173: *
174: * Tcl_EofCmd --
175: *
176: * This procedure is invoked to process the "eof" Tcl command.
177: * See the user documentation for details on what it does.
178: *
179: * Results:
180: * A standard Tcl result.
181: *
182: * Side effects:
183: * See the user documentation.
184: *
185: *----------------------------------------------------------------------
186: */
187:
188: /* ARGSUSED */
189: int
190: Tcl_EofCmd(notUsed, interp, argc, argv)
191: ClientData notUsed; /* Not used. */
192: Tcl_Interp *interp; /* Current interpreter. */
193: int argc; /* Number of arguments. */
194: char **argv; /* Argument strings. */
195: {
196: OpenFile *filePtr;
197:
198: if (argc != 2) {
199: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
200: " fileId\"", (char *) NULL);
201: return TCL_ERROR;
202: }
203: if (TclGetOpenFile(interp, argv[1], &filePtr) != TCL_OK) {
204: return TCL_ERROR;
205: }
206: if (feof(filePtr->f)) {
207: interp->result = "1";
208: } else {
209: interp->result = "0";
210: }
211: return TCL_OK;
212: }
213:
214: /*
215: *----------------------------------------------------------------------
216: *
217: * Tcl_ExecCmd --
218: *
219: * This procedure is invoked to process the "exec" Tcl command.
220: * See the user documentation for details on what it does.
221: *
222: * Results:
223: * A standard Tcl result.
224: *
225: * Side effects:
226: * See the user documentation.
227: *
228: *----------------------------------------------------------------------
229: */
230:
231: /* ARGSUSED */
232: int
233: Tcl_ExecCmd(dummy, interp, argc, argv)
234: ClientData dummy; /* Not used. */
235: Tcl_Interp *interp; /* Current interpreter. */
236: int argc; /* Number of arguments. */
237: char **argv; /* Argument strings. */
238: {
239: int outputId; /* File id for output pipe. -1
240: * means command overrode. */
241: int errorId; /* File id for temporary file
242: * containing error output. */
243: int *pidPtr;
244: int numPids, result;
245:
246: /*
247: * See if the command is to be run in background; if so, create
248: * the command, detach it, and return.
249: */
250:
251: if ((argv[argc-1][0] == '&') && (argv[argc-1][1] == 0)) {
252: argc--;
253: argv[argc] = NULL;
254: numPids = Tcl_CreatePipeline(interp, argc-1, argv+1, &pidPtr,
255: (int *) NULL, (int *) NULL, (int *) NULL);
256: if (numPids < 0) {
257: return TCL_ERROR;
258: }
259: Tcl_DetachPids(numPids, pidPtr);
260: ckfree((char *) pidPtr);
261: return TCL_OK;
262: }
263:
264: /*
265: * Create the command's pipeline.
266: */
267:
268: numPids = Tcl_CreatePipeline(interp, argc-1, argv+1, &pidPtr,
269: (int *) NULL, &outputId, &errorId);
270: if (numPids < 0) {
271: return TCL_ERROR;
272: }
273:
274: /*
275: * Read the child's output (if any) and put it into the result.
276: */
277:
278: result = TCL_OK;
279: if (outputId != -1) {
280: while (1) {
281: # define BUFFER_SIZE 1000
282: char buffer[BUFFER_SIZE+1];
283: int count;
284:
285: count = read(outputId, buffer, BUFFER_SIZE);
286:
287: if (count == 0) {
288: break;
289: }
290: if (count < 0) {
291: Tcl_ResetResult(interp);
292: Tcl_AppendResult(interp,
293: "error reading from output pipe: ",
294: Tcl_UnixError(interp), (char *) NULL);
295: result = TCL_ERROR;
296: break;
297: }
298: buffer[count] = 0;
299: Tcl_AppendResult(interp, buffer, (char *) NULL);
300: }
301: close(outputId);
302: }
303:
304: if (CleanupChildren(interp, numPids, pidPtr, errorId) != TCL_OK) {
305: result = TCL_ERROR;
306: }
307: return result;
308: }
309:
310: /*
311: *----------------------------------------------------------------------
312: *
313: * Tcl_ExitCmd --
314: *
315: * This procedure is invoked to process the "exit" Tcl command.
316: * See the user documentation for details on what it does.
317: *
318: * Results:
319: * A standard Tcl result.
320: *
321: * Side effects:
322: * See the user documentation.
323: *
324: *----------------------------------------------------------------------
325: */
326:
327: /* ARGSUSED */
328: int
329: Tcl_ExitCmd(dummy, interp, argc, argv)
330: ClientData dummy; /* Not used. */
331: Tcl_Interp *interp; /* Current interpreter. */
332: int argc; /* Number of arguments. */
333: char **argv; /* Argument strings. */
334: {
335: int value;
336:
337: if ((argc != 1) && (argc != 2)) {
338: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
339: " ?returnCode?\"", (char *) NULL);
340: return TCL_ERROR;
341: }
342: if (argc == 1) {
343: exit(0);
344: }
345: if (Tcl_GetInt(interp, argv[1], &value) != TCL_OK) {
346: return TCL_ERROR;
347: }
348: exit(value);
349: #if 0
350: return TCL_OK; /* Better not ever reach this! */
351: #endif
352: }
353:
354: /*
355: *----------------------------------------------------------------------
356: *
357: * Tcl_FileCmd --
358: *
359: * This procedure is invoked to process the "file" Tcl command.
360: * See the user documentation for details on what it does.
361: *
362: * Results:
363: * A standard Tcl result.
364: *
365: * Side effects:
366: * See the user documentation.
367: *
368: *----------------------------------------------------------------------
369: */
370:
371: /* ARGSUSED */
372: int
373: Tcl_FileCmd(dummy, interp, argc, argv)
374: ClientData dummy; /* Not used. */
375: Tcl_Interp *interp; /* Current interpreter. */
376: int argc; /* Number of arguments. */
377: char **argv; /* Argument strings. */
378: {
379: char *p;
380: int length, statOp;
381: int mode = 0; /* Initialized only to prevent
382: * compiler warning message. */
383: struct stat statBuf;
384: char *fileName, c;
385:
386: if (argc < 3) {
387: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
388: " option name ?arg ...?\"", (char *) NULL);
389: return TCL_ERROR;
390: }
391: c = argv[1][0];
392: length = strlen(argv[1]);
393:
394: /*
395: * First handle operations on the file name.
396: */
397:
398: fileName = Tcl_TildeSubst(interp, argv[2]);
399: if (fileName == NULL) {
400: return TCL_ERROR;
401: }
402: if ((c == 'd') && (strncmp(argv[1], "dirname", length) == 0)) {
403: if (argc != 3) {
404: argv[1] = "dirname";
405: not3Args:
406: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
407: " ", argv[1], " name\"", (char *) NULL);
408: return TCL_ERROR;
409: }
410: #ifdef MSDOS
411: p = strrchr(fileName, '\\');
412: #else
413: p = strrchr(fileName, '/');
414: #endif
415: if (p == NULL) {
416: interp->result = ".";
417: } else if (p == fileName) {
418: #ifdef MSDOS
419: interp->result = "\\";
420: #else
421: interp->result = "/";
422: #endif
423: } else {
424: *p = 0;
425: Tcl_SetResult(interp, fileName, TCL_VOLATILE);
426: *p = '/';
427: }
428: return TCL_OK;
429: } else if ((c == 'r') && (strncmp(argv[1], "rootname", length) == 0)
430: && (length >= 2)) {
431: char *lastSlash;
432:
433: if (argc != 3) {
434: argv[1] = "rootname";
435: goto not3Args;
436: }
437: p = strrchr(fileName, '.');
438: #ifdef MSDOS
439: lastSlash = strrchr(fileName, '\\');
440: #else
441: lastSlash = strrchr(fileName, '/');
442: #endif
443: if ((p == NULL) || ((lastSlash != NULL) && (lastSlash > p))) {
444: Tcl_SetResult(interp, fileName, TCL_VOLATILE);
445: } else {
446: *p = 0;
447: Tcl_SetResult(interp, fileName, TCL_VOLATILE);
448: *p = '.';
449: }
450: return TCL_OK;
451: } else if ((c == 'e') && (strncmp(argv[1], "extension", length) == 0)
452: && (length >= 3)) {
453: char *lastSlash;
454:
455: if (argc != 3) {
456: argv[1] = "extension";
457: goto not3Args;
458: }
459: p = strrchr(fileName, '.');
460: #ifdef MSDOS
461: lastSlash = strrchr(fileName, '\\');
462: #else
463: lastSlash = strrchr(fileName, '/');
464: #endif
465: if ((p != NULL) && ((lastSlash == NULL) || (lastSlash < p))) {
466: Tcl_SetResult(interp, p, TCL_VOLATILE);
467: }
468: return TCL_OK;
469: } else if ((c == 't') && (strncmp(argv[1], "tail", length) == 0)
470: && (length >= 2)) {
471: if (argc != 3) {
472: argv[1] = "tail";
473: goto not3Args;
474: }
475: #ifdef MSDOS
476: p = strrchr(fileName, '\\');
477: #else
478: p = strrchr(fileName, '/');
479: #endif
480: if (p != NULL) {
481: Tcl_SetResult(interp, p+1, TCL_VOLATILE);
482: } else {
483: Tcl_SetResult(interp, fileName, TCL_VOLATILE);
484: }
485: return TCL_OK;
486: }
487:
488: /*
489: * Next, handle operations that can be satisfied with the "access"
490: * kernel call.
491: */
492:
493: if (fileName == NULL) {
494: return TCL_ERROR;
495: }
496: if ((c == 'r') && (strncmp(argv[1], "readable", length) == 0)
497: && (length >= 5)) {
498: if (argc != 3) {
499: argv[1] = "readable";
500: goto not3Args;
501: }
502: mode = R_OK;
503: checkAccess:
504: if (access(fileName, mode) == -1) {
505: interp->result = "0";
506: } else {
507: interp->result = "1";
508: }
509: return TCL_OK;
510: } else if ((c == 'w') && (strncmp(argv[1], "writable", length) == 0)) {
511: if (argc != 3) {
512: argv[1] = "writable";
513: goto not3Args;
514: }
515: mode = W_OK;
516: goto checkAccess;
517: } else if ((c == 'e') && (strncmp(argv[1], "executable", length) == 0)
518: && (length >= 3)) {
519: if (argc != 3) {
520: argv[1] = "executable";
521: goto not3Args;
522: }
523: mode = X_OK;
524: goto checkAccess;
525: } else if ((c == 'e') && (strncmp(argv[1], "exists", length) == 0)
526: && (length >= 3)) {
527: if (argc != 3) {
528: argv[1] = "exists";
529: goto not3Args;
530: }
531: mode = F_OK;
532: goto checkAccess;
533: }
534:
535: /*
536: * Lastly, check stuff that requires the file to be stat-ed.
537: */
538:
539: if ((c == 'a') && (strncmp(argv[1], "atime", length) == 0)) {
540: if (argc != 3) {
541: argv[1] = "atime";
542: goto not3Args;
543: }
544: if (stat(fileName, &statBuf) == -1) {
545: goto badStat;
546: }
547: sprintf(interp->result, "%ld", statBuf.st_atime);
548: return TCL_OK;
549: } else if ((c == 'i') && (strncmp(argv[1], "isdirectory", length) == 0)
550: && (length >= 3)) {
551: if (argc != 3) {
552: argv[1] = "isdirectory";
553: goto not3Args;
554: }
555: statOp = 2;
556: } else if ((c == 'i') && (strncmp(argv[1], "isfile", length) == 0)
557: && (length >= 3)) {
558: if (argc != 3) {
559: argv[1] = "isfile";
560: goto not3Args;
561: }
562: statOp = 1;
563: } else if ((c == 'l') && (strncmp(argv[1], "lstat", length) == 0)) {
564: if (argc != 4) {
565: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
566: " lstat name varName\"", (char *) NULL);
567: return TCL_ERROR;
568: }
569:
570: if (lstat(fileName, &statBuf) == -1) {
571: Tcl_AppendResult(interp, "couldn't lstat \"", argv[2],
572: "\": ", Tcl_UnixError(interp), (char *) NULL);
573: return TCL_ERROR;
574: }
575: return StoreStatData(interp, argv[3], &statBuf);
576: } else if ((c == 'm') && (strncmp(argv[1], "mtime", length) == 0)) {
577: if (argc != 3) {
578: argv[1] = "mtime";
579: goto not3Args;
580: }
581: if (stat(fileName, &statBuf) == -1) {
582: goto badStat;
583: }
584: sprintf(interp->result, "%ld", statBuf.st_mtime);
585: return TCL_OK;
586: } else if ((c == 'o') && (strncmp(argv[1], "owned", length) == 0)) {
587: if (argc != 3) {
588: argv[1] = "owned";
589: goto not3Args;
590: }
591: statOp = 0;
592: #ifdef S_IFLNK
593: /*
594: * This option is only included if symbolic links exist on this system
595: * (in which case S_IFLNK should be defined).
596: */
597: } else if ((c == 'r') && (strncmp(argv[1], "readlink", length) == 0)
598: && (length >= 5)) {
599: char linkValue[MAXPATHLEN+1];
600: int linkLength;
601:
602: if (argc != 3) {
603: argv[1] = "readlink";
604: goto not3Args;
605: }
606: linkLength = readlink(fileName, linkValue, sizeof(linkValue) - 1);
607: if (linkLength == -1) {
608: Tcl_AppendResult(interp, "couldn't readlink \"", argv[2],
609: "\": ", Tcl_UnixError(interp), (char *) NULL);
610: return TCL_ERROR;
611: }
612: linkValue[linkLength] = 0;
613: Tcl_SetResult(interp, linkValue, TCL_VOLATILE);
614: return TCL_OK;
615: #endif
616: } else if ((c == 's') && (strncmp(argv[1], "size", length) == 0)
617: && (length >= 2)) {
618: if (argc != 3) {
619: argv[1] = "size";
620: goto not3Args;
621: }
622: if (stat(fileName, &statBuf) == -1) {
623: goto badStat;
624: }
625: sprintf(interp->result, "%ld", statBuf.st_size);
626: return TCL_OK;
627: } else if ((c == 's') && (strncmp(argv[1], "stat", length) == 0)
628: && (length >= 2)) {
629: if (argc != 4) {
630: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
631: " stat name varName\"", (char *) NULL);
632: return TCL_ERROR;
633: }
634:
635: if (stat(fileName, &statBuf) == -1) {
636: badStat:
637: Tcl_AppendResult(interp, "couldn't stat \"", argv[2],
638: "\": ", Tcl_UnixError(interp), (char *) NULL);
639: return TCL_ERROR;
640: }
641: return StoreStatData(interp, argv[3], &statBuf);
642: } else if ((c == 't') && (strncmp(argv[1], "type", length) == 0)
643: && (length >= 2)) {
644: if (argc != 3) {
645: argv[1] = "type";
646: goto not3Args;
647: }
648: if (lstat(fileName, &statBuf) == -1) {
649: goto badStat;
650: }
651: interp->result = GetFileType((int) statBuf.st_mode);
652: return TCL_OK;
653: } else {
654: Tcl_AppendResult(interp, "bad option \"", argv[1],
655: "\": should be atime, dirname, executable, exists, ",
656: "extension, isdirectory, isfile, lstat, mtime, owned, ",
657: "readable, ",
658: #ifdef S_IFLNK
659: "readlink, ",
660: #endif
661: "root, size, stat, tail, type, ",
662: "or writable",
663: (char *) NULL);
664: return TCL_ERROR;
665: }
666: if (stat(fileName, &statBuf) == -1) {
667: interp->result = "0";
668: return TCL_OK;
669: }
670: switch (statOp) {
671: case 0:
672: mode = (geteuid() == statBuf.st_uid);
673: break;
674: case 1:
675: mode = S_ISREG(statBuf.st_mode);
676: break;
677: case 2:
678: mode = S_ISDIR(statBuf.st_mode);
679: break;
680: }
681: if (mode) {
682: interp->result = "1";
683: } else {
684: interp->result = "0";
685: }
686: return TCL_OK;
687: }
688:
689: /*
690: *----------------------------------------------------------------------
691: *
692: * StoreStatData --
693: *
694: * This is a utility procedure that breaks out the fields of a
695: * "stat" structure and stores them in textual form into the
696: * elements of an associative array.
697: *
698: * Results:
699: * Returns a standard Tcl return value. If an error occurs then
700: * a message is left in interp->result.
701: *
702: * Side effects:
703: * Elements of the associative array given by "varName" are modified.
704: *
705: *----------------------------------------------------------------------
706: */
707:
708: static int
709: StoreStatData(interp, varName, statPtr)
710: Tcl_Interp *interp; /* Interpreter for error reports. */
711: char *varName; /* Name of associative array variable
712: * in which to store stat results. */
713: struct stat *statPtr; /* Pointer to buffer containing
714: * stat data to store in varName. */
715: {
716: char string[30];
717:
718: sprintf(string, "%d", statPtr->st_dev);
719: if (Tcl_SetVar2(interp, varName, "dev", string, TCL_LEAVE_ERR_MSG)
720: == NULL) {
721: return TCL_ERROR;
722: }
723: sprintf(string, "%d", statPtr->st_ino);
724: if (Tcl_SetVar2(interp, varName, "ino", string, TCL_LEAVE_ERR_MSG)
725: == NULL) {
726: return TCL_ERROR;
727: }
728: sprintf(string, "%d", statPtr->st_mode);
729: if (Tcl_SetVar2(interp, varName, "mode", string, TCL_LEAVE_ERR_MSG)
730: == NULL) {
731: return TCL_ERROR;
732: }
733: sprintf(string, "%d", statPtr->st_nlink);
734: if (Tcl_SetVar2(interp, varName, "nlink", string, TCL_LEAVE_ERR_MSG)
735: == NULL) {
736: return TCL_ERROR;
737: }
738: sprintf(string, "%d", statPtr->st_uid);
739: if (Tcl_SetVar2(interp, varName, "uid", string, TCL_LEAVE_ERR_MSG)
740: == NULL) {
741: return TCL_ERROR;
742: }
743: sprintf(string, "%d", statPtr->st_gid);
744: if (Tcl_SetVar2(interp, varName, "gid", string, TCL_LEAVE_ERR_MSG)
745: == NULL) {
746: return TCL_ERROR;
747: }
748: sprintf(string, "%ld", statPtr->st_size);
749: if (Tcl_SetVar2(interp, varName, "size", string, TCL_LEAVE_ERR_MSG)
750: == NULL) {
751: return TCL_ERROR;
752: }
753: sprintf(string, "%ld", statPtr->st_atime);
754: if (Tcl_SetVar2(interp, varName, "atime", string, TCL_LEAVE_ERR_MSG)
755: == NULL) {
756: return TCL_ERROR;
757: }
758: sprintf(string, "%ld", statPtr->st_mtime);
759: if (Tcl_SetVar2(interp, varName, "mtime", string, TCL_LEAVE_ERR_MSG)
760: == NULL) {
761: return TCL_ERROR;
762: }
763: sprintf(string, "%ld", statPtr->st_ctime);
764: if (Tcl_SetVar2(interp, varName, "ctime", string, TCL_LEAVE_ERR_MSG)
765: == NULL) {
766: return TCL_ERROR;
767: }
768: if (Tcl_SetVar2(interp, varName, "type",
769: GetFileType((int) statPtr->st_mode), TCL_LEAVE_ERR_MSG) == NULL) {
770: return TCL_ERROR;
771: }
772: return TCL_OK;
773: }
774:
775: /*
776: *----------------------------------------------------------------------
777: *
778: * GetFileType --
779: *
780: * Given a mode word, returns a string identifying the type of a
781: * file.
782: *
783: * Results:
784: * A static text string giving the file type from mode.
785: *
786: * Side effects:
787: * None.
788: *
789: *----------------------------------------------------------------------
790: */
791:
792: static char *
793: GetFileType(mode)
794: int mode;
795: {
796: if (S_ISREG(mode)) {
797: return "file";
798: } else if (S_ISDIR(mode)) {
799: return "directory";
800: } else if (S_ISCHR(mode)) {
801: return "characterSpecial";
802: } else if (S_ISBLK(mode)) {
803: return "blockSpecial";
804: } else if (S_ISFIFO(mode)) {
805: return "fifo";
806: } else if (S_ISLNK(mode)) {
807: return "link";
808: } else if (S_ISSOCK(mode)) {
809: return "socket";
810: }
811: return "unknown";
812: }
813:
814: /*
815: *----------------------------------------------------------------------
816: *
817: * Tcl_FlushCmd --
818: *
819: * This procedure is invoked to process the "flush" 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_FlushCmd(notUsed, interp, argc, argv)
834: ClientData notUsed; /* Not used. */
835: Tcl_Interp *interp; /* Current interpreter. */
836: int argc; /* Number of arguments. */
837: char **argv; /* Argument strings. */
838: {
839: OpenFile *filePtr;
840: FILE *f;
841:
842: if (argc != 2) {
843: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
844: " fileId\"", (char *) NULL);
845: return TCL_ERROR;
846: }
847: if (TclGetOpenFile(interp, argv[1], &filePtr) != TCL_OK) {
848: return TCL_ERROR;
849: }
850: if (!filePtr->writable) {
851: Tcl_AppendResult(interp, "\"", argv[1],
852: "\" wasn't opened for writing", (char *) NULL);
853: return TCL_ERROR;
854: }
855: f = filePtr->f2;
856: if (f == NULL) {
857: f = filePtr->f;
858: }
859: if (fflush(f) == EOF) {
860: Tcl_AppendResult(interp, "error flushing \"", argv[1],
861: "\": ", Tcl_UnixError(interp), (char *) NULL);
862: clearerr(f);
863: return TCL_ERROR;
864: }
865: return TCL_OK;
866: }
867:
868: /*
869: *----------------------------------------------------------------------
870: *
871: * Tcl_GetsCmd --
872: *
873: * This procedure is invoked to process the "gets" Tcl command.
874: * See the user documentation for details on what it does.
875: *
876: * Results:
877: * A standard Tcl result.
878: *
879: * Side effects:
880: * See the user documentation.
881: *
882: *----------------------------------------------------------------------
883: */
884:
885: /* ARGSUSED */
886: int
887: Tcl_GetsCmd(notUsed, interp, argc, argv)
888: ClientData notUsed; /* Not used. */
889: Tcl_Interp *interp; /* Current interpreter. */
890: int argc; /* Number of arguments. */
891: char **argv; /* Argument strings. */
892: {
893: # define BUF_SIZE 200
894: char buffer[BUF_SIZE+1];
895: int totalCount, done, flags;
896: OpenFile *filePtr;
897: register FILE *f;
898:
899: if ((argc != 2) && (argc != 3)) {
900: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
901: " fileId ?varName?\"", (char *) NULL);
902: return TCL_ERROR;
903: }
904: if (TclGetOpenFile(interp, argv[1], &filePtr) != TCL_OK) {
905: return TCL_ERROR;
906: }
907: if (!filePtr->readable) {
908: Tcl_AppendResult(interp, "\"", argv[1],
909: "\" wasn't opened for reading", (char *) NULL);
910: return TCL_ERROR;
911: }
912:
913: /*
914: * We can't predict how large a line will be, so read it in
915: * pieces, appending to the current result or to a variable.
916: */
917:
918: totalCount = 0;
919: done = 0;
920: flags = 0;
921: f = filePtr->f;
922: while (!done) {
923: register int c, count;
924: register char *p;
925:
926: for (p = buffer, count = 0; count < BUF_SIZE-1; count++, p++) {
927: c = getc(f);
928: if (c == EOF) {
929: if (ferror(filePtr->f)) {
930: Tcl_ResetResult(interp);
931: Tcl_AppendResult(interp, "error reading \"", argv[1],
932: "\": ", Tcl_UnixError(interp), (char *) NULL);
933: clearerr(filePtr->f);
934: return TCL_ERROR;
935: } else if (feof(filePtr->f)) {
936: if ((totalCount == 0) && (count == 0)) {
937: totalCount = -1;
938: }
939: done = 1;
940: break;
941: }
942: }
943: if (c == '\n') {
944: done = 1;
945: break;
946: }
947: *p = c;
948: }
949: *p = 0;
950: if (argc == 2) {
951: Tcl_AppendResult(interp, buffer, (char *) NULL);
952: } else {
953: if (Tcl_SetVar(interp, argv[2], buffer, flags|TCL_LEAVE_ERR_MSG)
954: == NULL) {
955: return TCL_ERROR;
956: }
957: flags = TCL_APPEND_VALUE;
958: }
959: totalCount += count;
960: }
961:
962: if (argc == 3) {
963: sprintf(interp->result, "%d", totalCount);
964: }
965: return TCL_OK;
966: }
967:
968: /*
969: *----------------------------------------------------------------------
970: *
971: * Tcl_OpenCmd --
972: *
973: * This procedure is invoked to process the "open" Tcl command.
974: * See the user documentation for details on what it does.
975: *
976: * Results:
977: * A standard Tcl result.
978: *
979: * Side effects:
980: * See the user documentation.
981: *
982: *----------------------------------------------------------------------
983: */
984:
985: /* ARGSUSED */
986: int
987: Tcl_OpenCmd(notUsed, interp, argc, argv)
988: ClientData notUsed; /* Not used. */
989: Tcl_Interp *interp; /* Current interpreter. */
990: int argc; /* Number of arguments. */
991: char **argv; /* Argument strings. */
992: {
993: Interp *iPtr = (Interp *) interp;
994: int pipeline, fd;
995: char *access;
996: register OpenFile *filePtr;
997:
998: if (argc == 2) {
999: access = "r";
1000: } else if (argc == 3) {
1001: access = argv[2];
1002: } else {
1003: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
1004: " filename ?access?\"", (char *) NULL);
1005: return TCL_ERROR;
1006: }
1007:
1008: filePtr = (OpenFile *) ckalloc(sizeof(OpenFile));
1009: filePtr->f = NULL;
1010: filePtr->f2 = NULL;
1011: filePtr->readable = 0;
1012: filePtr->writable = 0;
1013: filePtr->numPids = 0;
1014: filePtr->pidPtr = NULL;
1015: filePtr->errorId = -1;
1016:
1017: /*
1018: * Verify the requested form of access.
1019: */
1020:
1021: pipeline = 0;
1022: if (argv[1][0] == '|') {
1023: pipeline = 1;
1024: }
1025: switch (access[0]) {
1026: case 'r':
1027: filePtr->readable = 1;
1028: break;
1029: case 'w':
1030: filePtr->writable = 1;
1031: break;
1032: case 'a':
1033: filePtr->writable = 1;
1034: break;
1035: default:
1036: badAccess:
1037: Tcl_AppendResult(interp, "illegal access mode \"", access,
1038: "\"", (char *) NULL);
1039: goto error;
1040: }
1041: if (access[1] == '+') {
1042: filePtr->readable = filePtr->writable = 1;
1043: if (access[2] != 0) {
1044: goto badAccess;
1045: }
1046: } else if (access[1] != 0) {
1047: goto badAccess;
1048: }
1049:
1050: /*
1051: * Open the file or create a process pipeline.
1052: */
1053:
1054: if (!pipeline) {
1055: char *fileName = argv[1];
1056:
1057: if (fileName[0] == '~') {
1058: fileName = Tcl_TildeSubst(interp, fileName);
1059: if (fileName == NULL) {
1060: goto error;
1061: }
1062: }
1063: filePtr->f = fopen(fileName, access);
1064: if (filePtr->f == NULL) {
1065: Tcl_AppendResult(interp, "couldn't open \"", argv[1],
1066: "\": ", Tcl_UnixError(interp), (char *) NULL);
1067: goto error;
1068: }
1069: } else {
1070: int *inPipePtr, *outPipePtr;
1071: int cmdArgc, inPipe, outPipe;
1072: char **cmdArgv;
1073:
1074: if (Tcl_SplitList(interp, argv[1]+1, &cmdArgc, &cmdArgv) != TCL_OK) {
1075: goto error;
1076: }
1077: inPipePtr = (filePtr->writable) ? &inPipe : NULL;
1078: outPipePtr = (filePtr->readable) ? &outPipe : NULL;
1079: inPipe = outPipe = -1;
1080: filePtr->numPids = Tcl_CreatePipeline(interp, cmdArgc, cmdArgv,
1081: &filePtr->pidPtr, inPipePtr, outPipePtr, &filePtr->errorId);
1082: ckfree((char *) cmdArgv);
1083: if (filePtr->numPids < 0) {
1084: goto error;
1085: }
1086: if (filePtr->readable) {
1087: if (outPipe == -1) {
1088: if (inPipe != -1) {
1089: close(inPipe);
1090: }
1091: Tcl_AppendResult(interp, "can't read output from command:",
1092: " standard output was redirected", (char *) NULL);
1093: goto error;
1094: }
1095: filePtr->f = fdopen(outPipe, "r");
1096: }
1097: if (filePtr->writable) {
1098: if (inPipe == -1) {
1099: Tcl_AppendResult(interp, "can't write input to command:",
1100: " standard input was redirected", (char *) NULL);
1101: goto error;
1102: }
1103: if (filePtr->f != NULL) {
1104: filePtr->f2 = fdopen(inPipe, "w");
1105: } else {
1106: filePtr->f = fdopen(inPipe, "w");
1107: }
1108: }
1109: }
1110:
1111: /*
1112: * Enter this new OpenFile structure in the table for the
1113: * interpreter. May have to expand the table to do this.
1114: */
1115:
1116: fd = fileno(filePtr->f);
1117: TclMakeFileTable(iPtr, fd);
1118: if (iPtr->filePtrArray[fd] != NULL) {
1119: panic("Tcl_OpenCmd found file already open");
1120: }
1121: iPtr->filePtrArray[fd] = filePtr;
1122: sprintf(interp->result, "file%d", fd);
1123: return TCL_OK;
1124:
1125: error:
1126: if (filePtr->f != NULL) {
1127: fclose(filePtr->f);
1128: }
1129: if (filePtr->f2 != NULL) {
1130: fclose(filePtr->f2);
1131: }
1132: if (filePtr->numPids > 0) {
1133: Tcl_DetachPids(filePtr->numPids, filePtr->pidPtr);
1134: ckfree((char *) filePtr->pidPtr);
1135: }
1136: if (filePtr->errorId != -1) {
1137: close(filePtr->errorId);
1138: }
1139: ckfree((char *) filePtr);
1140: return TCL_ERROR;
1141: }
1142:
1143: /*
1144: *----------------------------------------------------------------------
1145: *
1146: * Tcl_PwdCmd --
1147: *
1148: * This procedure is invoked to process the "pwd" Tcl command.
1149: * See the user documentation for details on what it does.
1150: *
1151: * Results:
1152: * A standard Tcl result.
1153: *
1154: * Side effects:
1155: * See the user documentation.
1156: *
1157: *----------------------------------------------------------------------
1158: */
1159:
1160: /* ARGSUSED */
1161: int
1162: Tcl_PwdCmd(dummy, interp, argc, argv)
1163: ClientData dummy; /* Not used. */
1164: Tcl_Interp *interp; /* Current interpreter. */
1165: int argc; /* Number of arguments. */
1166: char **argv; /* Argument strings. */
1167: {
1168: char buffer[MAXPATHLEN+1];
1169:
1170: if (argc != 1) {
1171: Tcl_AppendResult(interp, "wrong # args: should be \"",
1172: argv[0], "\"", (char *) NULL);
1173: return TCL_ERROR;
1174: }
1175: if (currentDir == NULL) {
1176: #if TCL_GETWD
1177: if (getwd(buffer) == NULL) {
1178: Tcl_AppendResult(interp, "error getting working directory name: ",
1179: buffer, (char *) NULL);
1180: return TCL_ERROR;
1181: }
1182: #else
1183: if (getcwd(buffer, MAXPATHLEN) == 0) {
1184: if (errno == ERANGE) {
1185: interp->result = "working directory name is too long";
1186: } else {
1187: Tcl_AppendResult(interp,
1188: "error getting working directory name: ",
1189: Tcl_UnixError(interp), (char *) NULL);
1190: }
1191: return TCL_ERROR;
1192: }
1193: #endif
1194: currentDir = (char *) ckalloc((unsigned) (strlen(buffer) + 1));
1195: strcpy(currentDir, buffer);
1196: }
1197: interp->result = currentDir;
1198: return TCL_OK;
1199: }
1200:
1201: /*
1202: *----------------------------------------------------------------------
1203: *
1204: * Tcl_PutsCmd --
1205: *
1206: * This procedure is invoked to process the "puts" Tcl command.
1207: * See the user documentation for details on what it does.
1208: *
1209: * Results:
1210: * A standard Tcl result.
1211: *
1212: * Side effects:
1213: * See the user documentation.
1214: *
1215: *----------------------------------------------------------------------
1216: */
1217:
1218: /* ARGSUSED */
1219: int
1220: Tcl_PutsCmd(dummy, interp, argc, argv)
1221: ClientData dummy; /* Not used. */
1222: Tcl_Interp *interp; /* Current interpreter. */
1223: int argc; /* Number of arguments. */
1224: char **argv; /* Argument strings. */
1225: {
1226: OpenFile *filePtr;
1227: FILE *f;
1228:
1229: if (argc == 4) {
1230: if (strncmp(argv[3], "nonewline", strlen(argv[3])) != 0) {
1231: Tcl_AppendResult(interp, "bad argument \"", argv[3],
1232: "\": should be \"nonewline\"", (char *) NULL);
1233: return TCL_ERROR;
1234: }
1235: } else if (argc != 3) {
1236: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
1237: " fileId string ?nonewline?\"", (char *) NULL);
1238: return TCL_ERROR;
1239: }
1240: if (TclGetOpenFile(interp, argv[1], &filePtr) != TCL_OK) {
1241: return TCL_ERROR;
1242: }
1243: if (!filePtr->writable) {
1244: Tcl_AppendResult(interp, "\"", argv[1],
1245: "\" wasn't opened for writing", (char *) NULL);
1246: return TCL_ERROR;
1247: }
1248:
1249: f = filePtr->f2;
1250: if (f == NULL) {
1251: f = filePtr->f;
1252: }
1253: fputs(argv[2], f);
1254: if (argc == 3) {
1255: fputc('\n', f);
1256: }
1257: if (ferror(f)) {
1258: Tcl_AppendResult(interp, "error writing \"", argv[1],
1259: "\": ", Tcl_UnixError(interp), (char *) NULL);
1260: clearerr(f);
1261: return TCL_ERROR;
1262: }
1263: return TCL_OK;
1264: }
1265:
1266: /*
1267: *----------------------------------------------------------------------
1268: *
1269: * Tcl_ReadCmd --
1270: *
1271: * This procedure is invoked to process the "read" Tcl command.
1272: * See the user documentation for details on what it does.
1273: *
1274: * Results:
1275: * A standard Tcl result.
1276: *
1277: * Side effects:
1278: * See the user documentation.
1279: *
1280: *----------------------------------------------------------------------
1281: */
1282:
1283: /* ARGSUSED */
1284: int
1285: Tcl_ReadCmd(dummy, interp, argc, argv)
1286: ClientData dummy; /* Not used. */
1287: Tcl_Interp *interp; /* Current interpreter. */
1288: int argc; /* Number of arguments. */
1289: char **argv; /* Argument strings. */
1290: {
1291: OpenFile *filePtr;
1292: int bytesLeft, bytesRead, count;
1293: #define READ_BUF_SIZE 4096
1294: char buffer[READ_BUF_SIZE+1];
1295: int newline;
1296:
1297: if ((argc != 2) && (argc != 3)) {
1298: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
1299: " fileId ?numBytes|nonewline?\"", (char *) NULL);
1300: return TCL_ERROR;
1301: }
1302: if (TclGetOpenFile(interp, argv[1], &filePtr) != TCL_OK) {
1303: return TCL_ERROR;
1304: }
1305: if (!filePtr->readable) {
1306: Tcl_AppendResult(interp, "\"", argv[1],
1307: "\" wasn't opened for reading", (char *) NULL);
1308: return TCL_ERROR;
1309: }
1310:
1311: /*
1312: * Compute how many bytes to read, and see whether the final
1313: * newline should be dropped.
1314: */
1315:
1316: newline = 1;
1317: if ((argc > 2) && isdigit(argv[2][0])) {
1318: if (Tcl_GetInt(interp, argv[2], &bytesLeft) != TCL_OK) {
1319: return TCL_ERROR;
1320: }
1321: } else {
1322: bytesLeft = 1<<30;
1323: if (argc > 2) {
1324: if (strncmp(argv[2], "nonewline", strlen(argv[2])) == 0) {
1325: newline = 0;
1326: } else {
1327: Tcl_AppendResult(interp, "bad argument \"", argv[2],
1328: "\": should be \"nonewline\"", (char *) NULL);
1329: return TCL_ERROR;
1330: }
1331: }
1332: }
1333:
1334: /*
1335: * Read the file in one or more chunks.
1336: */
1337:
1338: bytesRead = 0;
1339: while (bytesLeft > 0) {
1340: count = READ_BUF_SIZE;
1341: if (bytesLeft < READ_BUF_SIZE) {
1342: count = bytesLeft;
1343: }
1344: count = fread(buffer, 1, count, filePtr->f);
1345: if (ferror(filePtr->f)) {
1346: Tcl_ResetResult(interp);
1347: Tcl_AppendResult(interp, "error reading \"", argv[1],
1348: "\": ", Tcl_UnixError(interp), (char *) NULL);
1349: clearerr(filePtr->f);
1350: return TCL_ERROR;
1351: }
1352: if (count == 0) {
1353: break;
1354: }
1355: buffer[count] = 0;
1356: Tcl_AppendResult(interp, buffer, (char *) NULL);
1357: bytesLeft -= count;
1358: bytesRead += count;
1359: }
1360: if ((newline == 0) && (interp->result[bytesRead-1] == '\n')) {
1361: interp->result[bytesRead-1] = 0;
1362: }
1363: return TCL_OK;
1364: }
1365:
1366: /*
1367: *----------------------------------------------------------------------
1368: *
1369: * Tcl_SeekCmd --
1370: *
1371: * This procedure is invoked to process the "seek" Tcl command.
1372: * See the user documentation for details on what it does.
1373: *
1374: * Results:
1375: * A standard Tcl result.
1376: *
1377: * Side effects:
1378: * See the user documentation.
1379: *
1380: *----------------------------------------------------------------------
1381: */
1382:
1383: /* ARGSUSED */
1384: int
1385: Tcl_SeekCmd(notUsed, interp, argc, argv)
1386: ClientData notUsed; /* Not used. */
1387: Tcl_Interp *interp; /* Current interpreter. */
1388: int argc; /* Number of arguments. */
1389: char **argv; /* Argument strings. */
1390: {
1391: OpenFile *filePtr;
1392: int offset, mode;
1393:
1394: if ((argc != 3) && (argc != 4)) {
1395: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
1396: " fileId offset ?origin?\"", (char *) NULL);
1397: return TCL_ERROR;
1398: }
1399: if (TclGetOpenFile(interp, argv[1], &filePtr) != TCL_OK) {
1400: return TCL_ERROR;
1401: }
1402: if (Tcl_GetInt(interp, argv[2], &offset) != TCL_OK) {
1403: return TCL_ERROR;
1404: }
1405: mode = SEEK_SET;
1406: if (argc == 4) {
1407: int length;
1408: char c;
1409:
1410: length = strlen(argv[3]);
1411: c = argv[3][0];
1412: if ((c == 's') && (strncmp(argv[3], "start", length) == 0)) {
1413: mode = SEEK_SET;
1414: } else if ((c == 'c') && (strncmp(argv[3], "current", length) == 0)) {
1415: mode = SEEK_CUR;
1416: } else if ((c == 'e') && (strncmp(argv[3], "end", length) == 0)) {
1417: mode = SEEK_END;
1418: } else {
1419: Tcl_AppendResult(interp, "bad origin \"", argv[3],
1420: "\": should be start, current, or end", (char *) NULL);
1421: return TCL_ERROR;
1422: }
1423: }
1424: if (fseek(filePtr->f, offset, mode) == -1) {
1425: Tcl_AppendResult(interp, "error during seek: ",
1426: Tcl_UnixError(interp), (char *) NULL);
1427: clearerr(filePtr->f);
1428: return TCL_ERROR;
1429: }
1430:
1431: return TCL_OK;
1432: }
1433:
1434: /*
1435: *----------------------------------------------------------------------
1436: *
1437: * Tcl_SourceCmd --
1438: *
1439: * This procedure is invoked to process the "source" Tcl command.
1440: * See the user documentation for details on what it does.
1441: *
1442: * Results:
1443: * A standard Tcl result.
1444: *
1445: * Side effects:
1446: * See the user documentation.
1447: *
1448: *----------------------------------------------------------------------
1449: */
1450:
1451: /* ARGSUSED */
1452: int
1453: Tcl_SourceCmd(dummy, interp, argc, argv)
1454: ClientData dummy; /* Not used. */
1455: Tcl_Interp *interp; /* Current interpreter. */
1456: int argc; /* Number of arguments. */
1457: char **argv; /* Argument strings. */
1458: {
1459: if (argc != 2) {
1460: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
1461: " fileName\"", (char *) NULL);
1462: return TCL_ERROR;
1463: }
1464: return Tcl_EvalFile(interp, argv[1]);
1465: }
1466:
1467: /*
1468: *----------------------------------------------------------------------
1469: *
1470: * Tcl_TellCmd --
1471: *
1472: * This procedure is invoked to process the "tell" Tcl command.
1473: * See the user documentation for details on what it does.
1474: *
1475: * Results:
1476: * A standard Tcl result.
1477: *
1478: * Side effects:
1479: * See the user documentation.
1480: *
1481: *----------------------------------------------------------------------
1482: */
1483:
1484: /* ARGSUSED */
1485: int
1486: Tcl_TellCmd(notUsed, interp, argc, argv)
1487: ClientData notUsed; /* Not used. */
1488: Tcl_Interp *interp; /* Current interpreter. */
1489: int argc; /* Number of arguments. */
1490: char **argv; /* Argument strings. */
1491: {
1492: OpenFile *filePtr;
1493:
1494: if (argc != 2) {
1495: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
1496: " fileId\"", (char *) NULL);
1497: return TCL_ERROR;
1498: }
1499: if (TclGetOpenFile(interp, argv[1], &filePtr) != TCL_OK) {
1500: return TCL_ERROR;
1501: }
1502: sprintf(interp->result, "%d", ftell(filePtr->f));
1503: return TCL_OK;
1504: }
1505:
1506: /*
1507: *----------------------------------------------------------------------
1508: *
1509: * Tcl_TimeCmd --
1510: *
1511: * This procedure is invoked to process the "time" Tcl command.
1512: * See the user documentation for details on what it does.
1513: *
1514: * Results:
1515: * A standard Tcl result.
1516: *
1517: * Side effects:
1518: * See the user documentation.
1519: *
1520: *----------------------------------------------------------------------
1521: */
1522:
1523: /* ARGSUSED */
1524: int
1525: Tcl_TimeCmd(dummy, interp, argc, argv)
1526: ClientData dummy; /* Not used. */
1527: Tcl_Interp *interp; /* Current interpreter. */
1528: int argc; /* Number of arguments. */
1529: char **argv; /* Argument strings. */
1530: {
1531: int count, i, result;
1532: double timePer;
1533: #if TCL_GETTOD
1534: struct timeval start, stop;
1535: struct timezone tz;
1536: int micros;
1537: #else
1538: struct tms dummy2;
1539: long start, stop;
1540: #endif
1541:
1542: if (argc == 2) {
1543: count = 1;
1544: } else if (argc == 3) {
1545: if (Tcl_GetInt(interp, argv[2], &count) != TCL_OK) {
1546: return TCL_ERROR;
1547: }
1548: } else {
1549: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
1550: " command ?count?\"", (char *) NULL);
1551: return TCL_ERROR;
1552: }
1553: #if TCL_GETTOD
1554: gettimeofday(&start, &tz);
1555: #else
1556: start = times(&dummy2);
1557: #endif
1558: for (i = count ; i > 0; i--) {
1559: result = Tcl_Eval(interp, argv[1], 0, (char **) NULL);
1560: if (result != TCL_OK) {
1561: if (result == TCL_ERROR) {
1562: char msg[60];
1563: sprintf(msg, "\n (\"time\" body line %d)",
1564: interp->errorLine);
1565: Tcl_AddErrorInfo(interp, msg);
1566: }
1567: return result;
1568: }
1569: }
1570: #if TCL_GETTOD
1571: gettimeofday(&stop, &tz);
1572: micros = (stop.tv_sec - start.tv_sec)*1000000
1573: + (stop.tv_usec - start.tv_usec);
1574: timePer = micros;
1575: #else
1576: stop = times(&dummy2);
1577: timePer = (((double) (stop - start))*1000000.0)/CLK_TCK;
1578: #endif
1579: Tcl_ResetResult(interp);
1580: sprintf(interp->result, "%.0f microseconds per iteration", timePer/count);
1581: return TCL_OK;
1582: }
1583:
1584: /*
1585: *----------------------------------------------------------------------
1586: *
1587: * CleanupChildren --
1588: *
1589: * This is a utility procedure used to wait for child processes
1590: * to exit, record information about abnormal exits, and then
1591: * collect any stderr output generated by them.
1592: *
1593: * Results:
1594: * The return value is a standard Tcl result. If anything at
1595: * weird happened with the child processes, TCL_ERROR is returned
1596: * and a message is left in interp->result.
1597: *
1598: * Side effects:
1599: * If the last character of interp->result is a newline, then it
1600: * is removed. File errorId gets closed, and pidPtr is freed
1601: * back to the storage allocator.
1602: *
1603: *----------------------------------------------------------------------
1604: */
1605:
1606: static int
1607: CleanupChildren(interp, numPids, pidPtr, errorId)
1608: Tcl_Interp *interp; /* Used for error messages. */
1609: int numPids; /* Number of entries in pidPtr array. */
1610: int *pidPtr; /* Array of process ids of children. */
1611: int errorId; /* File descriptor index for file containing
1612: * stderr output from pipeline. -1 means
1613: * there isn't any stderr output. */
1614: {
1615: int result = TCL_OK;
1616: int i, pid, length;
1617: WAIT_STATUS_TYPE waitStatus;
1618:
1619: for (i = 0; i < numPids; i++) {
1620: pid = Tcl_WaitPids(1, &pidPtr[i], (int *) &waitStatus);
1621: if (pid == -1) {
1622: Tcl_AppendResult(interp, "error waiting for process to exit: ",
1623: Tcl_UnixError(interp), (char *) NULL);
1624: continue;
1625: }
1626:
1627: /*
1628: * Create error messages for unusual process exits. An
1629: * extra newline gets appended to each error message, but
1630: * it gets removed below (in the same fashion that an
1631: * extra newline in the command's output is removed).
1632: */
1633:
1634: if (!WIFEXITED(waitStatus) || (WEXITSTATUS(waitStatus) != 0)) {
1635: char msg1[20], msg2[20];
1636:
1637: result = TCL_ERROR;
1638: sprintf(msg1, "%d", pid);
1639: if (WIFEXITED(waitStatus)) {
1640: sprintf(msg2, "%d", WEXITSTATUS(waitStatus));
1641: Tcl_SetErrorCode(interp, "CHILDSTATUS", msg1, msg2,
1642: (char *) NULL);
1643: } else if (WIFSIGNALED(waitStatus)) {
1644: char *p;
1645:
1646: p = Tcl_SignalMsg((int) (WTERMSIG(waitStatus)));
1647: Tcl_SetErrorCode(interp, "CHILDKILLED", msg1,
1648: Tcl_SignalId((int) (WTERMSIG(waitStatus))), p,
1649: (char *) NULL);
1650: Tcl_AppendResult(interp, "child killed: ", p, "\n",
1651: (char *) NULL);
1652: } else if (WIFSTOPPED(waitStatus)) {
1653: char *p;
1654:
1655: p = Tcl_SignalMsg((int) (WSTOPSIG(waitStatus)));
1656: Tcl_SetErrorCode(interp, "CHILDSUSP", msg1,
1657: Tcl_SignalId((int) (WSTOPSIG(waitStatus))), p, (char *) NULL);
1658: Tcl_AppendResult(interp, "child suspended: ", p, "\n",
1659: (char *) NULL);
1660: } else {
1661: Tcl_AppendResult(interp,
1662: "child wait status didn't make sense\n",
1663: (char *) NULL);
1664: }
1665: }
1666: }
1667: ckfree((char *) pidPtr);
1668:
1669: /*
1670: * Read the standard error file. If there's anything there,
1671: * then return an error and add the file's contents to the result
1672: * string.
1673: */
1674:
1675: if (errorId >= 0) {
1676: while (1) {
1677: # define BUFFER_SIZE 1000
1678: char buffer[BUFFER_SIZE+1];
1679: int count;
1680:
1681: count = read(errorId, buffer, BUFFER_SIZE);
1682:
1683: if (count == 0) {
1684: break;
1685: }
1686: if (count < 0) {
1687: Tcl_AppendResult(interp,
1688: "error reading stderr output file: ",
1689: Tcl_UnixError(interp), (char *) NULL);
1690: break;
1691: }
1692: buffer[count] = 0;
1693: Tcl_AppendResult(interp, buffer, (char *) NULL);
1694: }
1695: close(errorId);
1696: }
1697:
1698: /*
1699: * If the last character of interp->result is a newline, then remove
1700: * the newline character (the newline would just confuse things).
1701: */
1702:
1703: length = strlen(interp->result);
1704: if ((length > 0) && (interp->result[length-1] == '\n')) {
1705: interp->result[length-1] = '\0';
1706: }
1707:
1708: return result;
1709: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.