home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 January / usenetsourcesnewsgroupsinfomagicjanuary1994.iso / sources / misc / volume25 / tcl / part30 < prev    next >
Encoding:
Text File  |  1991-11-15  |  42.1 KB  |  1,608 lines

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