]> cvs.zerfleddert.de Git - micropolis/blame_incremental - src/tcl/tclunxaz.c
projects / micropolis / blame_incremental
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (non-incremental) | history | HEAD
target "all" should be phony
[micropolis] / src / tcl / tclunxaz.c
... / ...
CommitLineData
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
21static 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
33static char *currentDir = NULL;
34
35/*
36 * Prototypes for local procedures defined in this file:
37 */
38
39static int CleanupChildren _ANSI_ARGS_((Tcl_Interp *interp,
40 int numPids, int *pidPtr, int errorId));
41static char * GetFileType _ANSI_ARGS_((int mode));
42static int StoreStatData _ANSI_ARGS_((Tcl_Interp *interp,
43 char *varName, struct stat *statPtr));
44\f
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 */
63int
64Tcl_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\f
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 */
117int
118Tcl_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\f
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 */
189int
190Tcl_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\f
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 */
232int
233Tcl_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\f
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 */
328int
329Tcl_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\f
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 */
372int
373Tcl_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\f
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
708static int
709StoreStatData(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\f
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
792static char *
793GetFileType(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\f
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 */
832int
833Tcl_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\f
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 */
886int
887Tcl_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\f
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 */
986int
987Tcl_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\f
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 */
1161int
1162Tcl_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\f
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 */
1219int
1220Tcl_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\f
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 */
1284int
1285Tcl_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\f
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 */
1384int
1385Tcl_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\f
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 */
1452int
1453Tcl_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\f
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 */
1485int
1486Tcl_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\f
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 */
1524int
1525Tcl_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\f
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
1606static int
1607CleanupChildren(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}
Micropolis
Impressum, Datenschutz