cde/programs/dtdocbook/tcl/tclIOUtil.c

   1 /*
   2  * CDE - Common Desktop Environment
   3  *
   4  * Copyright (c) 1993-2012, The Open Group. All rights reserved.
   5  *
   6  * These libraries and programs are free software; you can
   7  * redistribute them and/or modify them under the terms of the GNU
   8  * Lesser General Public License as published by the Free Software
   9  * Foundation; either version 2 of the License, or (at your option)
  10  * any later version.
  11  *
  12  * These libraries and programs are distributed in the hope that
  13  * they will be useful, but WITHOUT ANY WARRANTY; without even the
  14  * implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
  15  * PURPOSE. See the GNU Lesser General Public License for more
  16  * details.
  17  *
  18  * You should have received a copy of the GNU Lesser General Public
  19  * License along with these librararies and programs; if not, write
  20  * to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
  21  * Floor, Boston, MA 02110-1301 USA
  22  */
  23 /* $XConsortium: tclIOUtil.c /main/3 1996/10/03 17:17:59 drk $ */
  24 /*
  25  * tclIOUtil.c --
  26  *
  27  *      This file contains a collection of utility procedures that
  28  *      are shared by the platform specific IO drivers.
  29  *
  30  *      Parts of this file are based on code contributed by Karl
  31  *      Lehenbauer, Mark Diekhans and Peter da Silva.
  32  *
  33  * Copyright (c) 1991-1994 The Regents of the University of California.
  34  * Copyright (c) 1994-1996 Sun Microsystems, Inc.
  35  *
  36  * See the file "license.terms" for information on usage and redistribution
  37  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  38  *
  39  * SCCS: @(#) tclIOUtil.c 1.122 96/04/02 18:46:40
  40  */
  41
  42 #include "tclInt.h"
  43 #include "tclPort.h"
  44
  45 /*
  46  * A linked list of the following structures is used to keep track
  47  * of child processes that have been detached but haven't exited
  48  * yet, so we can make sure that they're properly "reaped" (officially
  49  * waited for) and don't lie around as zombies cluttering the
  50  * system.
  51  */
  52
  53 typedef struct Detached {
  54     pid_t pid;                          /* Id of process that's been detached
  55                                          * but isn't known to have exited. */
  56     struct Detached *nextPtr;           /* Next in list of all detached
  57                                          * processes. */
  58 } Detached;
  59
  60 static Detached *detList = NULL;        /* List of all detached proceses. */
  61
  62 /*
  63  * Declarations for local procedures defined in this file:
  64  */
  65
  66 static Tcl_File FileForRedirect _ANSI_ARGS_((Tcl_Interp *interp,
  67                             char *spec, int atOk, char *arg, int flags,
  68                             char *nextArg, int *skipPtr, int *closePtr));
  69 \f
  70 /*
  71  *----------------------------------------------------------------------
  72  *
  73  * FileForRedirect --
  74  *
  75  *      This procedure does much of the work of parsing redirection
  76  *      operators.  It handles "@" if specified and allowed, and a file
  77  *      name, and opens the file if necessary.
  78  *
  79  * Results:
  80  *      The return value is the descriptor number for the file.  If an
  81  *      error occurs then NULL is returned and an error message is left
  82  *      in interp->result.  Several arguments are side-effected; see
  83  *      the argument list below for details.
  84  *
  85  * Side effects:
  86  *      None.
  87  *
  88  *----------------------------------------------------------------------
  89  */
  90
  91 static Tcl_File
  92 FileForRedirect(interp, spec, atOk, arg, flags, nextArg, skipPtr, closePtr)
  93     Tcl_Interp *interp;                 /* Intepreter to use for error
  94                                          * reporting. */
  95     register char *spec;                        /* Points to character just after
  96                                          * redirection character. */
  97     int atOk;                           /* Non-zero means '@' notation is
  98                                          * OK, zero means it isn't. */
  99     char *arg;                          /* Pointer to entire argument
 100                                          * containing spec:  used for error
 101                                          * reporting. */
 102     int flags;                          /* Flags to use for opening file. */
 103     char *nextArg;                      /* Next argument in argc/argv
 104                                          * array, if needed for file name.
 105                                          * May be NULL. */
 106     int *skipPtr;                       /* This value is incremented if
 107                                          * nextArg is used for redirection
 108                                          * spec. */
 109     int *closePtr;                      /* This value is set to 1 if the file
 110                                          * that's returned must be closed, 0
 111                                          * if it was specified with "@" so
 112                                          * it must be left open. */
 113 {
 114     int writing = (flags & O_WRONLY);
 115     Tcl_Channel chan;
 116     Tcl_File file;
 117
 118     if (atOk && (*spec == '@')) {
 119         spec++;
 120         if (*spec == 0) {
 121             spec = nextArg;
 122             if (spec == NULL) {
 123                 goto badLastArg;
 124             }
 125             *skipPtr += 1;
 126         }
 127         chan = Tcl_GetChannel(interp, spec, NULL);
 128         if (chan == (Tcl_Channel) NULL) {
 129             return NULL;
 130         }
 131         *closePtr = 0;
 132         file = Tcl_GetChannelFile(chan, writing ? TCL_WRITABLE : TCL_READABLE);
 133         if (file == NULL) {
 134             Tcl_AppendResult(interp,
 135                     "channel \"",
 136                     Tcl_GetChannelName(chan),
 137                     "\" wasn't opened for ",
 138                     writing ? "writing" : "reading", (char *) NULL);
 139             return NULL;
 140         }
 141         if (writing) {
 142
 143             /*
 144              * Be sure to flush output to the file, so that anything
 145              * written by the child appears after stuff we've already
 146              * written.
 147              */
 148
 149             Tcl_Flush(chan);
 150         }
 151     } else {
 152         Tcl_DString buffer;
 153         char *name;
 154
 155         if (*spec == 0) {
 156             spec = nextArg;
 157             if (spec == NULL) {
 158                 goto badLastArg;
 159             }
 160             *skipPtr += 1;
 161         }
 162         name = Tcl_TranslateFileName(interp, spec, &buffer);
 163         if (name) {
 164             file = TclOpenFile(name, flags);
 165         } else {
 166             file = NULL;
 167         }
 168         Tcl_DStringFree(&buffer);
 169         if (file == NULL) {
 170             Tcl_AppendResult(interp, "couldn't ",
 171                     (writing) ? "write" : "read", " file \"", spec, "\": ",
 172                     Tcl_PosixError(interp), (char *) NULL);
 173             return NULL;
 174         }
 175         *closePtr = 1;
 176     }
 177     return file;
 178
 179     badLastArg:
 180     Tcl_AppendResult(interp, "can't specify \"", arg,
 181             "\" as last word in command", (char *) NULL);
 182     return NULL;
 183 }
 184 \f
 185 /*
 186  *----------------------------------------------------------------------
 187  *
 188  * TclGetOpenMode --
 189  *
 190  * Description:
 191  *      Computes a POSIX mode mask for opening a file, from a given string,
 192  *      and also sets a flag to indicate whether the caller should seek to
 193  *      EOF after opening the file.
 194  *
 195  * Results:
 196  *      On success, returns mode to pass to "open". If an error occurs, the
 197  *      returns -1 and if interp is not NULL, sets interp->result to an
 198  *      error message.
 199  *
 200  * Side effects:
 201  *      Sets the integer referenced by seekFlagPtr to 1 to tell the caller
 202  *      to seek to EOF after opening the file.
 203  *
 204  * Special note:
 205  *      This code is based on a prototype implementation contributed
 206  *      by Mark Diekhans.
 207  *
 208  *----------------------------------------------------------------------
 209  */
 210
 211 int
 212 TclGetOpenMode(interp, string, seekFlagPtr)
 213     Tcl_Interp *interp;                 /* Interpreter to use for error
 214                                          * reporting - may be NULL. */
 215     char *string;                       /* Mode string, e.g. "r+" or
 216                                          * "RDONLY CREAT". */
 217     int *seekFlagPtr;                   /* Set this to 1 if the caller
 218                                          * should seek to EOF during the
 219                                          * opening of the file. */
 220 {
 221     int mode, modeArgc, c, i, gotRW;
 222     char **modeArgv, *flag;
 223 #define RW_MODES (O_RDONLY|O_WRONLY|O_RDWR)
 224
 225     /*
 226      * Check for the simpler fopen-like access modes (e.g. "r").  They
 227      * are distinguished from the POSIX access modes by the presence
 228      * of a lower-case first letter.
 229      */
 230
 231     *seekFlagPtr = 0;
 232     mode = 0;
 233     if (islower(UCHAR(string[0]))) {
 234         switch (string[0]) {
 235             case 'r':
 236                 mode = O_RDONLY;
 237                 break;
 238             case 'w':
 239                 mode = O_WRONLY|O_CREAT|O_TRUNC;
 240                 break;
 241             case 'a':
 242                 mode = O_WRONLY|O_CREAT;
 243                 *seekFlagPtr = 1;
 244                 break;
 245             default:
 246                 error:
 247                 if (interp != (Tcl_Interp *) NULL) {
 248                     Tcl_AppendResult(interp,
 249                             "illegal access mode \"", string, "\"",
 250                             (char *) NULL);
 251                 }
 252                 return -1;
 253         }
 254         if (string[1] == '+') {
 255             mode &= ~(O_RDONLY|O_WRONLY);
 256             mode |= O_RDWR;
 257             if (string[2] != 0) {
 258                 goto error;
 259             }
 260         } else if (string[1] != 0) {
 261             goto error;
 262         }
 263         return mode;
 264     }
 265
 266     /*
 267      * The access modes are specified using a list of POSIX modes
 268      * such as O_CREAT.
 269      *
 270      * IMPORTANT NOTE: We rely on Tcl_SplitList working correctly when
 271      * a NULL interpreter is passed in.
 272      */
 273
 274     if (Tcl_SplitList(interp, string, &modeArgc, &modeArgv) != TCL_OK) {
 275         if (interp != (Tcl_Interp *) NULL) {
 276             Tcl_AddErrorInfo(interp,
 277                     "\n    while processing open access modes \"");
 278             Tcl_AddErrorInfo(interp, string);
 279             Tcl_AddErrorInfo(interp, "\"");
 280         }
 281         return -1;
 282     }
 283
 284     gotRW = 0;
 285     for (i = 0; i < modeArgc; i++) {
 286         flag = modeArgv[i];
 287         c = flag[0];
 288         if ((c == 'R') && (strcmp(flag, "RDONLY") == 0)) {
 289             mode = (mode & ~RW_MODES) | O_RDONLY;
 290             gotRW = 1;
 291         } else if ((c == 'W') && (strcmp(flag, "WRONLY") == 0)) {
 292             mode = (mode & ~RW_MODES) | O_WRONLY;
 293             gotRW = 1;
 294         } else if ((c == 'R') && (strcmp(flag, "RDWR") == 0)) {
 295             mode = (mode & ~RW_MODES) | O_RDWR;
 296             gotRW = 1;
 297         } else if ((c == 'A') && (strcmp(flag, "APPEND") == 0)) {
 298             mode |= O_APPEND;
 299             *seekFlagPtr = 1;
 300         } else if ((c == 'C') && (strcmp(flag, "CREAT") == 0)) {
 301             mode |= O_CREAT;
 302         } else if ((c == 'E') && (strcmp(flag, "EXCL") == 0)) {
 303             mode |= O_EXCL;
 304         } else if ((c == 'N') && (strcmp(flag, "NOCTTY") == 0)) {
 305 #ifdef O_NOCTTY
 306             mode |= O_NOCTTY;
 307 #else
 308             if (interp != (Tcl_Interp *) NULL) {
 309                 Tcl_AppendResult(interp, "access mode \"", flag,
 310                         "\" not supported by this system", (char *) NULL);
 311             }
 312             ckfree((char *) modeArgv);
 313             return -1;
 314 #endif
 315         } else if ((c == 'N') && (strcmp(flag, "NONBLOCK") == 0)) {
 316 #if defined(O_NDELAY) || defined(O_NONBLOCK)
 317 #   ifdef O_NONBLOCK
 318             mode |= O_NONBLOCK;
 319 #   else
 320             mode |= O_NDELAY;
 321 #   endif
 322 #else
 323             if (interp != (Tcl_Interp *) NULL) {
 324                 Tcl_AppendResult(interp, "access mode \"", flag,
 325                         "\" not supported by this system", (char *) NULL);
 326             }
 327             ckfree((char *) modeArgv);
 328             return -1;
 329 #endif
 330         } else if ((c == 'T') && (strcmp(flag, "TRUNC") == 0)) {
 331             mode |= O_TRUNC;
 332         } else {
 333             if (interp != (Tcl_Interp *) NULL) {
 334                 Tcl_AppendResult(interp, "invalid access mode \"", flag,
 335                         "\": must be RDONLY, WRONLY, RDWR, APPEND, CREAT",
 336                         " EXCL, NOCTTY, NONBLOCK, or TRUNC", (char *) NULL);
 337             }
 338             ckfree((char *) modeArgv);
 339             return -1;
 340         }
 341     }
 342     ckfree((char *) modeArgv);
 343     if (!gotRW) {
 344         if (interp != (Tcl_Interp *) NULL) {
 345             Tcl_AppendResult(interp, "access mode must include either",
 346                     " RDONLY, WRONLY, or RDWR", (char *) NULL);
 347         }
 348         return -1;
 349     }
 350     return mode;
 351 }
 352 \f
 353 /*
 354  *----------------------------------------------------------------------
 355  *
 356  * Tcl_EvalFile --
 357  *
 358  *      Read in a file and process the entire file as one gigantic
 359  *      Tcl command.
 360  *
 361  * Results:
 362  *      A standard Tcl result, which is either the result of executing
 363  *      the file or an error indicating why the file couldn't be read.
 364  *
 365  * Side effects:
 366  *      Depends on the commands in the file.
 367  *
 368  *----------------------------------------------------------------------
 369  */
 370
 371 int
 372 Tcl_EvalFile(interp, fileName)
 373     Tcl_Interp *interp;         /* Interpreter in which to process file. */
 374     char *fileName;             /* Name of file to process.  Tilde-substitution
 375                                  * will be performed on this name. */
 376 {
 377     int result;
 378     struct stat statBuf;
 379     char *cmdBuffer = (char *) NULL;
 380     char *oldScriptFile = (char *) NULL;
 381     Interp *iPtr = (Interp *) interp;
 382     Tcl_DString buffer;
 383     char *nativeName = (char *) NULL;
 384     Tcl_Channel chan = (Tcl_Channel) NULL;
 385
 386     Tcl_ResetResult(interp);
 387     oldScriptFile = iPtr->scriptFile;
 388     iPtr->scriptFile = fileName;
 389     Tcl_DStringInit(&buffer);
 390     nativeName = Tcl_TranslateFileName(interp, fileName, &buffer);
 391     if (nativeName == NULL) {
 392         goto error;
 393     }
 394
 395     /*
 396      * If Tcl_TranslateFileName didn't already copy the file name, do it
 397      * here.  This way we don't depend on fileName staying constant
 398      * throughout the execution of the script (e.g., what if it happens
 399      * to point to a Tcl variable that the script could change?).
 400      */
 401
 402     if (nativeName != Tcl_DStringValue(&buffer)) {
 403         Tcl_DStringSetLength(&buffer, 0);
 404         Tcl_DStringAppend(&buffer, nativeName, -1);
 405         nativeName = Tcl_DStringValue(&buffer);
 406     }
 407     if (stat(nativeName, &statBuf) == -1) {
 408         Tcl_SetErrno(errno);
 409         Tcl_AppendResult(interp, "couldn't read file \"", fileName,
 410                 "\": ", Tcl_PosixError(interp), (char *) NULL);
 411         goto error;
 412     }
 413     chan = Tcl_OpenFileChannel(interp, nativeName, "r", 0644);
 414     if (chan == (Tcl_Channel) NULL) {
 415         Tcl_ResetResult(interp);
 416         Tcl_AppendResult(interp, "couldn't read file \"", fileName,
 417                 "\": ", Tcl_PosixError(interp), (char *) NULL);
 418         goto error;
 419     }
 420     cmdBuffer = (char *) ckalloc((unsigned) statBuf.st_size+1);
 421     result = Tcl_Read(chan, cmdBuffer, statBuf.st_size);
 422     if (result < 0) {
 423         Tcl_Close(interp, chan);
 424         Tcl_AppendResult(interp, "couldn't read file \"", fileName,
 425                 "\": ", Tcl_PosixError(interp), (char *) NULL);
 426         goto error;
 427     }
 428     cmdBuffer[result] = 0;
 429     if (Tcl_Close(interp, chan) != TCL_OK) {
 430         goto error;
 431     }
 432
 433     result = Tcl_Eval(interp, cmdBuffer);
 434     if (result == TCL_RETURN) {
 435         result = TclUpdateReturnInfo(iPtr);
 436     } else if (result == TCL_ERROR) {
 437         char msg[200];
 438
 439         /*
 440          * Record information telling where the error occurred.
 441          */
 442
 443         sprintf(msg, "\n    (file \"%.150s\" line %d)", fileName,
 444                 interp->errorLine);
 445         Tcl_AddErrorInfo(interp, msg);
 446     }
 447     iPtr->scriptFile = oldScriptFile;
 448     ckfree(cmdBuffer);
 449     Tcl_DStringFree(&buffer);
 450     return result;
 451
 452 error:
 453     if (cmdBuffer != (char *) NULL) {
 454         ckfree(cmdBuffer);
 455     }
 456     iPtr->scriptFile = oldScriptFile;
 457     Tcl_DStringFree(&buffer);
 458     return TCL_ERROR;
 459 }
 460 \f
 461 /*
 462  *----------------------------------------------------------------------
 463  *
 464  * Tcl_DetachPids --
 465  *
 466  *      This procedure is called to indicate that one or more child
 467  *      processes have been placed in background and will never be
 468  *      waited for;  they should eventually be reaped by
 469  *      Tcl_ReapDetachedProcs.
 470  *
 471  * Results:
 472  *      None.
 473  *
 474  * Side effects:
 475  *      None.
 476  *
 477  *----------------------------------------------------------------------
 478  */
 479
 480 void
 481 Tcl_DetachPids(numPids, pidPtr)
 482     int numPids;                /* Number of pids to detach:  gives size
 483                                  * of array pointed to by pidPtr. */
 484     pid_t *pidPtr;              /* Array of pids to detach. */
 485 {
 486     register Detached *detPtr;
 487     int i;
 488
 489     for (i = 0; i < numPids; i++) {
 490         detPtr = (Detached *) ckalloc(sizeof(Detached));
 491         detPtr->pid = pidPtr[i];
 492         detPtr->nextPtr = detList;
 493         detList = detPtr;
 494     }
 495 }
 496 \f
 497 /*
 498  *----------------------------------------------------------------------
 499  *
 500  * Tcl_ReapDetachedProcs --
 501  *
 502  *      This procedure checks to see if any detached processes have
 503  *      exited and, if so, it "reaps" them by officially waiting on
 504  *      them.  It should be called "occasionally" to make sure that
 505  *      all detached processes are eventually reaped.
 506  *
 507  * Results:
 508  *      None.
 509  *
 510  * Side effects:
 511  *      Processes are waited on, so that they can be reaped by the
 512  *      system.
 513  *
 514  *----------------------------------------------------------------------
 515  */
 516
 517 void
 518 Tcl_ReapDetachedProcs()
 519 {
 520     register Detached *detPtr;
 521     Detached *nextPtr, *prevPtr;
 522     int status;
 523     pid_t pid;
 524
 525     for (detPtr = detList, prevPtr = NULL; detPtr != NULL; ) {
 526         pid = Tcl_WaitPid(detPtr->pid, &status, WNOHANG);
 527         if ((pid == 0) || ((pid == (pid_t)-1) && (errno != ECHILD))) {
 528             prevPtr = detPtr;
 529             detPtr = detPtr->nextPtr;
 530             continue;
 531         }
 532         nextPtr = detPtr->nextPtr;
 533         if (prevPtr == NULL) {
 534             detList = detPtr->nextPtr;
 535         } else {
 536             prevPtr->nextPtr = detPtr->nextPtr;
 537         }
 538         ckfree((char *) detPtr);
 539         detPtr = nextPtr;
 540     }
 541 }
 542 \f
 543 /*
 544  *----------------------------------------------------------------------
 545  *
 546  * TclCleanupChildren --
 547  *
 548  *      This is a utility procedure used to wait for child processes
 549  *      to exit, record information about abnormal exits, and then
 550  *      collect any stderr output generated by them.
 551  *
 552  * Results:
 553  *      The return value is a standard Tcl result.  If anything at
 554  *      weird happened with the child processes, TCL_ERROR is returned
 555  *      and a message is left in interp->result.
 556  *
 557  * Side effects:
 558  *      If the last character of interp->result is a newline, then it
 559  *      is removed unless keepNewline is non-zero.  File errorId gets
 560  *      closed, and pidPtr is freed back to the storage allocator.
 561  *
 562  *----------------------------------------------------------------------
 563  */
 564
 565 int
 566 TclCleanupChildren(interp, numPids, pidPtr, errorChan)
 567     Tcl_Interp *interp;         /* Used for error messages. */
 568     int numPids;                /* Number of entries in pidPtr array. */
 569     pid_t *pidPtr;              /* Array of process ids of children. */
 570     Tcl_Channel errorChan;      /* Channel for file containing stderr output
 571                                  * from pipeline.  NULL means there isn't any
 572                                  * stderr output. */
 573 {
 574     int result = TCL_OK;
 575     pid_t pid;
 576     int i, abnormalExit, anyErrorInfo;
 577     WAIT_STATUS_TYPE waitStatus;
 578     char *msg;
 579
 580     abnormalExit = 0;
 581     for (i = 0; i < numPids; i++) {
 582         pid = Tcl_WaitPid(pidPtr[i], (int *) &waitStatus, 0);
 583         if (pid == (pid_t)-1) {
 584             result = TCL_ERROR;
 585             if (interp != (Tcl_Interp *) NULL) {
 586                 msg = Tcl_PosixError(interp);
 587                 if (errno == ECHILD) {
 588                     /*
 589                      * This changeup in message suggested by Mark Diekhans
 590                      * to remind people that ECHILD errors can occur on
 591                      * some systems if SIGCHLD isn't in its default state.
 592                      */
 593
 594                     msg =
 595                         "child process lost (is SIGCHLD ignored or trapped?)";
 596                 }
 597                 Tcl_AppendResult(interp, "error waiting for process to exit: ",
 598                         msg, (char *) NULL);
 599             }
 600             continue;
 601         }
 602
 603         /*
 604          * Create error messages for unusual process exits.  An
 605          * extra newline gets appended to each error message, but
 606          * it gets removed below (in the same fashion that an
 607          * extra newline in the command's output is removed).
 608          */
 609
 610         if (!WIFEXITED(waitStatus) || (WEXITSTATUS(waitStatus) != 0)) {
 611             char msg1[20], msg2[20];
 612
 613             result = TCL_ERROR;
 614             sprintf(msg1, "%ld", (long)pid);
 615             if (WIFEXITED(waitStatus)) {
 616                 if (interp != (Tcl_Interp *) NULL) {
 617                     sprintf(msg2, "%d", WEXITSTATUS(waitStatus));
 618                     Tcl_SetErrorCode(interp, "CHILDSTATUS", msg1, msg2,
 619                             (char *) NULL);
 620                 }
 621                 abnormalExit = 1;
 622             } else if (WIFSIGNALED(waitStatus)) {
 623                 if (interp != (Tcl_Interp *) NULL) {
 624                     char *p;
 625
 626                     p = Tcl_SignalMsg((int) (WTERMSIG(waitStatus)));
 627                     Tcl_SetErrorCode(interp, "CHILDKILLED", msg1,
 628                             Tcl_SignalId((int) (WTERMSIG(waitStatus))), p,
 629                             (char *) NULL);
 630                     Tcl_AppendResult(interp, "child killed: ", p, "\n",
 631                             (char *) NULL);
 632                 }
 633             } else if (WIFSTOPPED(waitStatus)) {
 634                 if (interp != (Tcl_Interp *) NULL) {
 635                     char *p;
 636
 637                     p = Tcl_SignalMsg((int) (WSTOPSIG(waitStatus)));
 638                     Tcl_SetErrorCode(interp, "CHILDSUSP", msg1,
 639                             Tcl_SignalId((int) (WSTOPSIG(waitStatus))),
 640                             p, (char *) NULL);
 641                     Tcl_AppendResult(interp, "child suspended: ", p, "\n",
 642                             (char *) NULL);
 643                 }
 644             } else {
 645                 if (interp != (Tcl_Interp *) NULL) {
 646                     Tcl_AppendResult(interp,
 647                             "child wait status didn't make sense\n",
 648                             (char *) NULL);
 649                 }
 650             }
 651         }
 652     }
 653
 654     /*
 655      * Read the standard error file.  If there's anything there,
 656      * then return an error and add the file's contents to the result
 657      * string.
 658      */
 659
 660     anyErrorInfo = 0;
 661     if (errorChan != NULL) {
 662
 663         /*
 664          * Make sure we start at the beginning of the file.
 665          */
 666
 667         Tcl_Seek(errorChan, 0L, SEEK_SET);
 668
 669         if (interp != (Tcl_Interp *) NULL) {
 670             while (1) {
 671 #define BUFFER_SIZE 1000
 672                 char buffer[BUFFER_SIZE+1];
 673                 int count;
 674
 675                 count = Tcl_Read(errorChan, buffer, BUFFER_SIZE);
 676                 if (count == 0) {
 677                     break;
 678                 }
 679                 result = TCL_ERROR;
 680                 if (count < 0) {
 681                     Tcl_AppendResult(interp,
 682                             "error reading stderr output file: ",
 683                             Tcl_PosixError(interp), (char *) NULL);
 684                     break;      /* out of the "while (1)" loop. */
 685                 }
 686                 buffer[count] = 0;
 687                 Tcl_AppendResult(interp, buffer, (char *) NULL);
 688                 anyErrorInfo = 1;
 689             }
 690         }
 691
 692         Tcl_Close(NULL, errorChan);
 693     }
 694
 695     /*
 696      * If a child exited abnormally but didn't output any error information
 697      * at all, generate an error message here.
 698      */
 699
 700     if (abnormalExit && !anyErrorInfo && (interp != (Tcl_Interp *) NULL)) {
 701         Tcl_AppendResult(interp, "child process exited abnormally",
 702                 (char *) NULL);
 703     }
 704
 705     return result;
 706 }
 707 \f
 708 /*
 709  *----------------------------------------------------------------------
 710  *
 711  * TclCreatePipeline --
 712  *
 713  *      Given an argc/argv array, instantiate a pipeline of processes
 714  *      as described by the argv.
 715  *
 716  * Results:
 717  *      The return value is a count of the number of new processes
 718  *      created, or -1 if an error occurred while creating the pipeline.
 719  *      *pidArrayPtr is filled in with the address of a dynamically
 720  *      allocated array giving the ids of all of the processes.  It
 721  *      is up to the caller to free this array when it isn't needed
 722  *      anymore.  If inPipePtr is non-NULL, *inPipePtr is filled in
 723  *      with the file id for the input pipe for the pipeline (if any):
 724  *      the caller must eventually close this file.  If outPipePtr
 725  *      isn't NULL, then *outPipePtr is filled in with the file id
 726  *      for the output pipe from the pipeline:  the caller must close
 727  *      this file.  If errFilePtr isn't NULL, then *errFilePtr is filled
 728  *      with a file id that may be used to read error output after the
 729  *      pipeline completes.
 730  *
 731  * Side effects:
 732  *      Processes and pipes are created.
 733  *
 734  *----------------------------------------------------------------------
 735  */
 736
 737 int
 738 TclCreatePipeline(interp, argc, argv, pidArrayPtr, inPipePtr,
 739         outPipePtr, errFilePtr)
 740     Tcl_Interp *interp;         /* Interpreter to use for error reporting. */
 741     int argc;                   /* Number of entries in argv. */
 742     char **argv;                /* Array of strings describing commands in
 743                                  * pipeline plus I/O redirection with <,
 744                                  * <<,  >, etc.  Argv[argc] must be NULL. */
 745     pid_t **pidArrayPtr;        /* Word at *pidArrayPtr gets filled in with
 746                                  * address of array of pids for processes
 747                                  * in pipeline (first pid is first process
 748                                  * in pipeline). */
 749     Tcl_File *inPipePtr;        /* If non-NULL, input to the pipeline comes
 750                                  * from a pipe (unless overridden by
 751                                  * redirection in the command).  The file
 752                                  * id with which to write to this pipe is
 753                                  * stored at *inPipePtr.  NULL means command
 754                                  * specified its own input source. */
 755     Tcl_File *outPipePtr;       /* If non-NULL, output to the pipeline goes
 756                                  * to a pipe, unless overriden by redirection
 757                                  * in the command.  The file id with which to
 758                                  * read frome this pipe is stored at
 759                                  * *outPipePtr.  NULL means command specified
 760                                  * its own output sink. */
 761     Tcl_File *errFilePtr;       /* If non-NULL, all stderr output from the
 762                                  * pipeline will go to a temporary file
 763                                  * created here, and a descriptor to read
 764                                  * the file will be left at *errFilePtr.
 765                                  * The file will be removed already, so
 766                                  * closing this descriptor will be the end
 767                                  * of the file.  If this is NULL, then
 768                                  * all stderr output goes to our stderr.
 769                                  * If the pipeline specifies redirection
 770                                  * then the file will still be created
 771                                  * but it will never get any data. */
 772 {
 773 #if defined( MAC_TCL )
 774     Tcl_AppendResult(interp,
 775             "command pipelines not supported on Macintosh OS", NULL);
 776     return -1;
 777 #else /* !MAC_TCL */
 778     pid_t *pidPtr = NULL;       /* Points to malloc-ed array holding all
 779                                  * the pids of child processes. */
 780     int numPids = 0;            /* Actual number of processes that exist
 781                                  * at *pidPtr right now. */
 782     int cmdCount;               /* Count of number of distinct commands
 783                                  * found in argc/argv. */
 784     char *input = NULL;         /* If non-null, then this points to a
 785                                  * string containing input data (specified
 786                                  * via <<) to be piped to the first process
 787                                  * in the pipeline. */
 788     Tcl_File inputFile = NULL;
 789                                 /* If != NULL, gives file to use as input for
 790                                  * first process in pipeline (specified via <
 791                                  * or <@). */
 792     int closeInput = 0;         /* If non-zero, then must close inputId
 793                                  * when cleaning up (zero means the file needs
 794                                  * to stay open for some other reason). */
 795     Tcl_File outputFile = NULL;
 796                                 /* Writable file for output from last command
 797                                  * in pipeline (could be file or pipe).  NULL
 798                                  * means use stdout. */
 799     int closeOutput = 0;        /* Non-zero means must close outputId when
 800                                  * cleaning up (similar to closeInput). */
 801     Tcl_File errorFile = NULL;
 802                                 /* Writable file for error output from all
 803                                  * commands in pipeline.  NULL means use
 804                                  * stderr. */
 805     int closeError = 0;         /* Non-zero means must close errorId when
 806                                  * cleaning up. */
 807     int skip;                   /* Number of arguments to skip (because they
 808                                  * specify redirection). */
 809     int lastBar;
 810     int i, j;
 811     char *p;
 812     int hasPipes = TclHasPipes();
 813     char finalOut[L_tmpnam];
 814     char intIn[L_tmpnam];
 815
 816     finalOut[0]  = '\0';
 817     intIn[0] = '\0';
 818
 819     if (inPipePtr != NULL) {
 820         *inPipePtr = NULL;
 821     }
 822     if (outPipePtr != NULL) {
 823         *outPipePtr = NULL;
 824     }
 825     if (errFilePtr != NULL) {
 826         *errFilePtr = NULL;
 827     }
 828
 829     /*
 830      * First, scan through all the arguments to figure out the structure
 831      * of the pipeline.  Process all of the input and output redirection
 832      * arguments and remove them from the argument list in the pipeline.
 833      * Count the number of distinct processes (it's the number of "|"
 834      * arguments plus one) but don't remove the "|" arguments.
 835      */
 836
 837     cmdCount = 1;
 838     lastBar = -1;
 839     for (i = 0; i < argc; i++) {
 840         if ((argv[i][0] == '|') && (((argv[i][1] == 0))
 841                 || ((argv[i][1] == '&') && (argv[i][2] == 0)))) {
 842             if ((i == (lastBar+1)) || (i == (argc-1))) {
 843                 interp->result = "illegal use of | or |& in command";
 844                 return -1;
 845             }
 846             lastBar = i;
 847             cmdCount++;
 848             continue;
 849         } else if (argv[i][0] == '<') {
 850             if ((inputFile != NULL) && closeInput) {
 851                 TclCloseFile(inputFile);
 852             }
 853             inputFile = NULL;
 854             skip = 1;
 855             if (argv[i][1] == '<') {
 856                 input = argv[i]+2;
 857                 if (*input == 0) {
 858                     input = argv[i+1];
 859                     if (input == 0) {
 860                         Tcl_AppendResult(interp, "can't specify \"", argv[i],
 861                                 "\" as last word in command", (char *) NULL);
 862                         goto error;
 863                     }
 864                     skip = 2;
 865                 }
 866             } else {
 867                 input = 0;
 868                 inputFile = FileForRedirect(interp, argv[i]+1, 1, argv[i],
 869                         O_RDONLY, argv[i+1], &skip, &closeInput);
 870                 if (inputFile == NULL) {
 871                     goto error;
 872                 }
 873
 874                 /* When Win32s dies out, this code can be removed */
 875                 if (!hasPipes) {
 876                     if (!closeInput) {
 877                         Tcl_AppendResult(interp, "redirection with '@'",
 878                                 " notation is not supported on this system",
 879                                 (char *) NULL);
 880                         goto error;
 881                     }
 882                     strcpy(intIn, skip == 1 ? argv[i]+1 : argv[i+1]);
 883                 }
 884             }
 885         } else if (argv[i][0] == '>') {
 886             int append, useForStdErr, useForStdOut, mustClose, atOk, flags;
 887             Tcl_File file;
 888
 889             skip = atOk = 1;
 890             append = useForStdErr = 0;
 891             useForStdOut = 1;
 892             if (argv[i][1] == '>') {
 893                 p = argv[i] + 2;
 894                 append = 1;
 895                 atOk = 0;
 896                 flags = O_WRONLY|O_CREAT;
 897             } else {
 898                 p = argv[i] + 1;
 899                 flags = O_WRONLY|O_CREAT|O_TRUNC;
 900             }
 901             if (*p == '&') {
 902                 useForStdErr = 1;
 903                 p++;
 904             }
 905             file = FileForRedirect(interp, p, atOk, argv[i], flags, argv[i+1],
 906                     &skip, &mustClose);
 907             if (file == NULL) {
 908                 goto error;
 909             }
 910
 911             /* When Win32s dies out, this code can be removed */
 912             if (!hasPipes) {
 913                 if (!mustClose) {
 914                     Tcl_AppendResult(interp, "redirection with '@'",
 915                             " notation is not supported on this system",
 916                             (char *) NULL);
 917                     goto error;
 918                 }
 919                 strcpy(finalOut, skip == 1 ? p : argv[i+1]);
 920             }
 921
 922             if (hasPipes && append) {
 923                 TclSeekFile(file, 0L, 2);
 924             }
 925
 926             /*
 927              * Got the file descriptor.  Now use it for standard output,
 928              * standard error, or both, depending on the redirection.
 929              */
 930
 931             if (useForStdOut) {
 932                 if ((outputFile != NULL) && closeOutput) {
 933                     TclCloseFile(outputFile);
 934                 }
 935                 outputFile = file;
 936                 closeOutput = mustClose;
 937             }
 938             if (useForStdErr) {
 939                 if ((errorFile != NULL) && closeError) {
 940                     TclCloseFile(errorFile);
 941                 }
 942                 errorFile = file;
 943                 closeError = (useForStdOut) ? 0 : mustClose;
 944             }
 945         } else if ((argv[i][0] == '2') && (argv[i][1] == '>')) {
 946             int append, atOk, flags;
 947
 948             if ((errorFile != NULL) && closeError) {
 949                 TclCloseFile(errorFile);
 950             }
 951             skip = 1;
 952             p = argv[i] + 2;
 953             if (*p == '>') {
 954                 p++;
 955                 append = 1;
 956                 atOk = 0;
 957                 flags = O_WRONLY|O_CREAT;
 958             } else {
 959                 append = 0;
 960                 atOk = 1;
 961                 flags = O_WRONLY|O_CREAT|O_TRUNC;
 962             }
 963             errorFile = FileForRedirect(interp, p, atOk, argv[i], flags,
 964                     argv[i+1], &skip, &closeError);
 965             if (errorFile == NULL) {
 966                 goto error;
 967             }
 968             if (hasPipes && append) {
 969                 TclSeekFile(errorFile, 0L, 2);
 970             }
 971         } else {
 972             continue;
 973         }
 974         for (j = i+skip; j < argc; j++) {
 975             argv[j-skip] = argv[j];
 976         }
 977         argc -= skip;
 978         i -= 1;                 /* Process next arg from same position. */
 979     }
 980     if (argc == 0) {
 981         interp->result =  "didn't specify command to execute";
 982         return -1;
 983     }
 984
 985     if ((hasPipes && inputFile == NULL) || (!hasPipes && intIn[0] == '\0')) {
 986         if (input != NULL) {
 987
 988             /*
 989              * The input for the first process is immediate data coming from
 990              * Tcl.  Create a temporary file for it and put the data into the
 991              * file.
 992              */
 993
 994             inputFile = TclCreateTempFile(input);
 995             closeInput = 1;
 996             if (inputFile == NULL) {
 997                 Tcl_AppendResult(interp,
 998                         "couldn't create input file for command: ",
 999                         Tcl_PosixError(interp), (char *) NULL);
1000                 goto error;
1001             }
1002         } else if (inPipePtr != NULL) {
1003             Tcl_File inPipe, outPipe;
1004             /*
1005              * The input for the first process in the pipeline is to
1006              * come from a pipe that can be written from this end.
1007              */
1008
1009             if (!hasPipes || TclCreatePipe(&inPipe, &outPipe) == 0) {
1010                 Tcl_AppendResult(interp,
1011                         "couldn't create input pipe for command: ",
1012                         Tcl_PosixError(interp), (char *) NULL);
1013                 goto error;
1014             }
1015             inputFile = inPipe;
1016             closeInput = 1;
1017             *inPipePtr = outPipe;
1018         }
1019     }
1020
1021     /*
1022      * Set up a pipe to receive output from the pipeline, if no other
1023      * output sink has been specified.
1024      */
1025
1026     if ((outputFile == NULL) && (outPipePtr != NULL)) {
1027         if (!hasPipes) {
1028             tmpnam(finalOut);
1029         } else {
1030             Tcl_File inPipe, outPipe;
1031             if (TclCreatePipe(&inPipe, &outPipe) == 0) {
1032                 Tcl_AppendResult(interp,
1033                         "couldn't create output pipe for command: ",
1034                         Tcl_PosixError(interp), (char *) NULL);
1035                 goto error;
1036             }
1037             outputFile = outPipe;
1038             closeOutput = 1;
1039             *outPipePtr = inPipe;
1040         }
1041     }
1042
1043     /*
1044      * Set up the standard error output sink for the pipeline, if
1045      * requested.  Use a temporary file which is opened, then deleted.
1046      * Could potentially just use pipe, but if it filled up it could
1047      * cause the pipeline to deadlock:  we'd be waiting for processes
1048      * to complete before reading stderr, and processes couldn't complete
1049      * because stderr was backed up.
1050      */
1051
1052     if (errFilePtr && !errorFile) {
1053         *errFilePtr = TclCreateTempFile(NULL);
1054         if (*errFilePtr == NULL) {
1055             Tcl_AppendResult(interp,
1056                     "couldn't create error file for command: ",
1057                     Tcl_PosixError(interp), (char *) NULL);
1058             goto error;
1059         }
1060         errorFile = *errFilePtr;
1061         closeError = 0;
1062     }
1063
1064     /*
1065      * Scan through the argc array, forking off a process for each
1066      * group of arguments between "|" arguments.
1067      */
1068
1069     pidPtr = (pid_t *) ckalloc((unsigned) (cmdCount * sizeof(pid_t)));
1070     Tcl_ReapDetachedProcs();
1071
1072     if (TclSpawnPipeline(interp, pidPtr, &numPids, argc, argv,
1073             inputFile, outputFile, errorFile, intIn, finalOut) == 0) {
1074         goto error;
1075     }
1076     *pidArrayPtr = pidPtr;
1077
1078     /*
1079      * All done.  Cleanup open files lying around and then return.
1080      */
1081
1082 cleanup:
1083     if ((inputFile != NULL) && closeInput) {
1084         TclCloseFile(inputFile);
1085     }
1086     if ((outputFile != NULL) && closeOutput) {
1087         TclCloseFile(outputFile);
1088     }
1089     if ((errorFile != NULL) && closeError) {
1090         TclCloseFile(errorFile);
1091     }
1092     return numPids;
1093
1094     /*
1095      * An error occurred.  There could have been extra files open, such
1096      * as pipes between children.  Clean them all up.  Detach any child
1097      * processes that have been created.
1098      */
1099
1100 error:
1101     if ((inPipePtr != NULL) && (*inPipePtr != NULL)) {
1102         TclCloseFile(*inPipePtr);
1103         *inPipePtr = NULL;
1104     }
1105     if ((outPipePtr != NULL) && (*outPipePtr != NULL)) {
1106         TclCloseFile(*outPipePtr);
1107         *outPipePtr = NULL;
1108     }
1109     if ((errFilePtr != NULL) && (*errFilePtr != NULL)) {
1110         TclCloseFile(*errFilePtr);
1111         *errFilePtr = NULL;
1112     }
1113     if (pidPtr != NULL) {
1114         for (i = 0; i < numPids; i++) {
1115             if (pidPtr[i] != (pid_t)-1) {
1116                 Tcl_DetachPids(1, &pidPtr[i]);
1117             }
1118         }
1119         ckfree((char *) pidPtr);
1120     }
1121     numPids = -1;
1122     goto cleanup;
1123 #endif /* !MAC_TCL */
1124 }
1125 \f
1126 /*
1127  *----------------------------------------------------------------------
1128  *
1129  * Tcl_GetErrno --
1130  *
1131  *      Gets the current value of the Tcl error code variable. This is
1132  *      currently the global variable "errno" but could in the future
1133  *      change to something else.
1134  *
1135  * Results:
1136  *      The value of the Tcl error code variable.
1137  *
1138  * Side effects:
1139  *      None. Note that the value of the Tcl error code variable is
1140  *      UNDEFINED if a call to Tcl_SetErrno did not precede this call.
1141  *
1142  *----------------------------------------------------------------------
1143  */
1144
1145 int
1146 Tcl_GetErrno()
1147 {
1148     return errno;
1149 }
1150 \f
1151 /*
1152  *----------------------------------------------------------------------
1153  *
1154  * Tcl_SetErrno --
1155  *
1156  *      Sets the Tcl error code variable to the supplied value.
1157  *
1158  * Results:
1159  *      None.
1160  *
1161  * Side effects:
1162  *      Modifies the value of the Tcl error code variable.
1163  *
1164  *----------------------------------------------------------------------
1165  */
1166
1167 void
1168 Tcl_SetErrno(err)
1169     int err;                    /* The new value. */
1170 {
1171     errno = err;
1172 }
1173 \f
1174 /*
1175  *----------------------------------------------------------------------
1176  *
1177  * Tcl_PosixError --
1178  *
1179  *      This procedure is typically called after UNIX kernel calls
1180  *      return errors.  It stores machine-readable information about
1181  *      the error in $errorCode returns an information string for
1182  *      the caller's use.
1183  *
1184  * Results:
1185  *      The return value is a human-readable string describing the
1186  *      error.
1187  *
1188  * Side effects:
1189  *      The global variable $errorCode is reset.
1190  *
1191  *----------------------------------------------------------------------
1192  */
1193
1194 char *
1195 Tcl_PosixError(interp)
1196     Tcl_Interp *interp;         /* Interpreter whose $errorCode variable
1197                                  * is to be changed. */
1198 {
1199     char *id, *msg;
1200
1201     msg = Tcl_ErrnoMsg(errno);
1202     id = Tcl_ErrnoId();
1203     Tcl_SetErrorCode(interp, "POSIX", id, msg, (char *) NULL);
1204     return msg;
1205 }
1206 \f
1207 /*
1208  *----------------------------------------------------------------------
1209  *
1210  * Tcl_OpenCommandChannel --
1211  *
1212  *      Opens an I/O channel to one or more subprocesses specified
1213  *      by argc and argv.  The flags argument determines the
1214  *      disposition of the stdio handles.  If the TCL_STDIN flag is
1215  *      set then the standard input for the first subprocess will
1216  *      be tied to the channel:  writing to the channel will provide
1217  *      input to the subprocess.  If TCL_STDIN is not set, then
1218  *      standard input for the first subprocess will be the same as
1219  *      this application's standard input.  If TCL_STDOUT is set then
1220  *      standard output from the last subprocess can be read from the
1221  *      channel;  otherwise it goes to this application's standard
1222  *      output.  If TCL_STDERR is set, standard error output for all
1223  *      subprocesses is returned to the channel and results in an error
1224  *      when the channel is closed;  otherwise it goes to this
1225  *      application's standard error.  If TCL_ENFORCE_MODE is not set,
1226  *      then argc and argv can redirect the stdio handles to override
1227  *      TCL_STDIN, TCL_STDOUT, and TCL_STDERR;  if it is set, then it
1228  *      is an error for argc and argv to override stdio channels for
1229  *      which TCL_STDIN, TCL_STDOUT, and TCL_STDERR have been set.
1230  *
1231  * Results:
1232  *      A new command channel, or NULL on failure with an error
1233  *      message left in interp.
1234  *
1235  * Side effects:
1236  *      Creates processes, opens pipes.
1237  *
1238  *----------------------------------------------------------------------
1239  */
1240
1241 Tcl_Channel
1242 Tcl_OpenCommandChannel(interp, argc, argv, flags)
1243     Tcl_Interp *interp;         /* Interpreter for error reporting. Can
1244                                  * NOT be NULL. */
1245     int argc;                   /* How many arguments. */
1246     char **argv;                /* Array of arguments for command pipe. */
1247     int flags;                  /* Or'ed combination of TCL_STDIN, TCL_STDOUT,
1248                                  * TCL_STDERR, and TCL_ENFORCE_MODE. */
1249 {
1250     Tcl_File *inPipePtr, *outPipePtr, *errFilePtr;
1251     Tcl_File inPipe, outPipe, errFile;
1252     int numPids;
1253     pid_t *pidPtr;
1254     Tcl_Channel channel;
1255
1256     inPipe = outPipe = errFile = NULL;
1257
1258     inPipePtr = (flags & TCL_STDIN) ? &inPipe : NULL;
1259     outPipePtr = (flags & TCL_STDOUT) ? &outPipe : NULL;
1260     errFilePtr = (flags & TCL_STDERR) ? &errFile : NULL;
1261
1262     numPids = TclCreatePipeline(interp, argc, argv, &pidPtr, inPipePtr,
1263             outPipePtr, errFilePtr);
1264
1265     if (numPids < 0) {
1266         goto error;
1267     }
1268
1269     /*
1270      * Verify that the pipes that were created satisfy the
1271      * readable/writable constraints.
1272      */
1273
1274     if (flags & TCL_ENFORCE_MODE) {
1275         if ((flags & TCL_STDOUT) && (outPipe == NULL)) {
1276             Tcl_AppendResult(interp, "can't read output from command:",
1277                     " standard output was redirected", (char *) NULL);
1278             goto error;
1279         }
1280         if ((flags & TCL_STDIN) && (inPipe == NULL)) {
1281             Tcl_AppendResult(interp, "can't write input to command:",
1282                     " standard input was redirected", (char *) NULL);
1283             goto error;
1284         }
1285     }
1286
1287     channel = TclCreateCommandChannel(outPipe, inPipe, errFile,
1288             numPids, pidPtr);
1289
1290     if (channel == (Tcl_Channel) NULL) {
1291         Tcl_AppendResult(interp, "pipe for command could not be created",
1292                 (char *) NULL);
1293         goto error;
1294     }
1295     return channel;
1296
1297 error:
1298     if (numPids > 0) {
1299         Tcl_DetachPids(numPids, pidPtr);
1300         ckfree((char *) pidPtr);
1301     }
1302     if (inPipe != NULL) {
1303         TclClosePipeFile(inPipe);
1304     }
1305     if (outPipe != NULL) {
1306         TclClosePipeFile(outPipe);
1307     }
1308     if (errFile != NULL) {
1309         TclClosePipeFile(errFile);
1310     }
1311     return NULL;
1312 }