home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / C / Applications / Tcl-Tk 8.0 / Pre-installed version / tcl8.0 / generic / tclIOUtil.c < prev    next >
Encoding:
C/C++ Source or Header  |  1997-08-15  |  10.4 KB  |  379 lines  |  [TEXT/CWIE]
  1. /* 
  2.  * tclIOUtil.c --
  3.  *
  4.  *    This file contains a collection of utility procedures that
  5.  *    are shared by the platform specific IO drivers.
  6.  *
  7.  *    Parts of this file are based on code contributed by Karl
  8.  *    Lehenbauer, Mark Diekhans and Peter da Silva.
  9.  *
  10.  * Copyright (c) 1991-1994 The Regents of the University of California.
  11.  * Copyright (c) 1994-1996 Sun Microsystems, Inc.
  12.  *
  13.  * See the file "license.terms" for information on usage and redistribution
  14.  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  15.  *
  16.  * SCCS: @(#) tclIOUtil.c 1.132 97/04/23 16:21:42
  17.  */
  18.  
  19. #include "tclInt.h"
  20. #include "tclPort.h"
  21.  
  22.  
  23. /*
  24.  *----------------------------------------------------------------------
  25.  *
  26.  * TclGetOpenMode --
  27.  *
  28.  * Description:
  29.  *    Computes a POSIX mode mask for opening a file, from a given string,
  30.  *    and also sets a flag to indicate whether the caller should seek to
  31.  *    EOF after opening the file.
  32.  *
  33.  * Results:
  34.  *    On success, returns mode to pass to "open". If an error occurs, the
  35.  *    returns -1 and if interp is not NULL, sets interp->result to an
  36.  *    error message.
  37.  *
  38.  * Side effects:
  39.  *    Sets the integer referenced by seekFlagPtr to 1 to tell the caller
  40.  *    to seek to EOF after opening the file.
  41.  *
  42.  * Special note:
  43.  *    This code is based on a prototype implementation contributed
  44.  *    by Mark Diekhans.
  45.  *
  46.  *----------------------------------------------------------------------
  47.  */
  48.  
  49. int
  50. TclGetOpenMode(interp, string, seekFlagPtr)
  51.     Tcl_Interp *interp;            /* Interpreter to use for error
  52.                      * reporting - may be NULL. */
  53.     char *string;            /* Mode string, e.g. "r+" or
  54.                      * "RDONLY CREAT". */
  55.     int *seekFlagPtr;            /* Set this to 1 if the caller
  56.                                          * should seek to EOF during the
  57.                                          * opening of the file. */
  58. {
  59.     int mode, modeArgc, c, i, gotRW;
  60.     char **modeArgv, *flag;
  61. #define RW_MODES (O_RDONLY|O_WRONLY|O_RDWR)
  62.  
  63.     /*
  64.      * Check for the simpler fopen-like access modes (e.g. "r").  They
  65.      * are distinguished from the POSIX access modes by the presence
  66.      * of a lower-case first letter.
  67.      */
  68.  
  69.     *seekFlagPtr = 0;
  70.     mode = 0;
  71.     if (islower(UCHAR(string[0]))) {
  72.     switch (string[0]) {
  73.         case 'r':
  74.         mode = O_RDONLY;
  75.         break;
  76.         case 'w':
  77.         mode = O_WRONLY|O_CREAT|O_TRUNC;
  78.         break;
  79.         case 'a':
  80.         mode = O_WRONLY|O_CREAT;
  81.                 *seekFlagPtr = 1;
  82.         break;
  83.         default:
  84.         error:
  85.                 if (interp != (Tcl_Interp *) NULL) {
  86.                     Tcl_AppendResult(interp,
  87.                             "illegal access mode \"", string, "\"",
  88.                             (char *) NULL);
  89.                 }
  90.         return -1;
  91.     }
  92.     if (string[1] == '+') {
  93.         mode &= ~(O_RDONLY|O_WRONLY);
  94.         mode |= O_RDWR;
  95.         if (string[2] != 0) {
  96.         goto error;
  97.         }
  98.     } else if (string[1] != 0) {
  99.         goto error;
  100.     }
  101.         return mode;
  102.     }
  103.  
  104.     /*
  105.      * The access modes are specified using a list of POSIX modes
  106.      * such as O_CREAT.
  107.      *
  108.      * IMPORTANT NOTE: We rely on Tcl_SplitList working correctly when
  109.      * a NULL interpreter is passed in.
  110.      */
  111.  
  112.     if (Tcl_SplitList(interp, string, &modeArgc, &modeArgv) != TCL_OK) {
  113.         if (interp != (Tcl_Interp *) NULL) {
  114.             Tcl_AddErrorInfo(interp,
  115.                     "\n    while processing open access modes \"");
  116.             Tcl_AddErrorInfo(interp, string);
  117.             Tcl_AddErrorInfo(interp, "\"");
  118.         }
  119.         return -1;
  120.     }
  121.     
  122.     gotRW = 0;
  123.     for (i = 0; i < modeArgc; i++) {
  124.     flag = modeArgv[i];
  125.     c = flag[0];
  126.     if ((c == 'R') && (strcmp(flag, "RDONLY") == 0)) {
  127.         mode = (mode & ~RW_MODES) | O_RDONLY;
  128.         gotRW = 1;
  129.     } else if ((c == 'W') && (strcmp(flag, "WRONLY") == 0)) {
  130.         mode = (mode & ~RW_MODES) | O_WRONLY;
  131.         gotRW = 1;
  132.     } else if ((c == 'R') && (strcmp(flag, "RDWR") == 0)) {
  133.         mode = (mode & ~RW_MODES) | O_RDWR;
  134.         gotRW = 1;
  135.     } else if ((c == 'A') && (strcmp(flag, "APPEND") == 0)) {
  136.         mode |= O_APPEND;
  137.             *seekFlagPtr = 1;
  138.     } else if ((c == 'C') && (strcmp(flag, "CREAT") == 0)) {
  139.         mode |= O_CREAT;
  140.     } else if ((c == 'E') && (strcmp(flag, "EXCL") == 0)) {
  141.         mode |= O_EXCL;
  142.     } else if ((c == 'N') && (strcmp(flag, "NOCTTY") == 0)) {
  143. #ifdef O_NOCTTY
  144.         mode |= O_NOCTTY;
  145. #else
  146.         if (interp != (Tcl_Interp *) NULL) {
  147.                 Tcl_AppendResult(interp, "access mode \"", flag,
  148.                         "\" not supported by this system", (char *) NULL);
  149.             }
  150.             ckfree((char *) modeArgv);
  151.         return -1;
  152. #endif
  153.     } else if ((c == 'N') && (strcmp(flag, "NONBLOCK") == 0)) {
  154. #if defined(O_NDELAY) || defined(O_NONBLOCK)
  155. #   ifdef O_NONBLOCK
  156.         mode |= O_NONBLOCK;
  157. #   else
  158.         mode |= O_NDELAY;
  159. #   endif
  160. #else
  161.             if (interp != (Tcl_Interp *) NULL) {
  162.                 Tcl_AppendResult(interp, "access mode \"", flag,
  163.                         "\" not supported by this system", (char *) NULL);
  164.             }
  165.             ckfree((char *) modeArgv);
  166.         return -1;
  167. #endif
  168.     } else if ((c == 'T') && (strcmp(flag, "TRUNC") == 0)) {
  169.         mode |= O_TRUNC;
  170.     } else {
  171.             if (interp != (Tcl_Interp *) NULL) {
  172.                 Tcl_AppendResult(interp, "invalid access mode \"", flag,
  173.                         "\": must be RDONLY, WRONLY, RDWR, APPEND, CREAT",
  174.                         " EXCL, NOCTTY, NONBLOCK, or TRUNC", (char *) NULL);
  175.             }
  176.         ckfree((char *) modeArgv);
  177.         return -1;
  178.     }
  179.     }
  180.     ckfree((char *) modeArgv);
  181.     if (!gotRW) {
  182.         if (interp != (Tcl_Interp *) NULL) {
  183.             Tcl_AppendResult(interp, "access mode must include either",
  184.                     " RDONLY, WRONLY, or RDWR", (char *) NULL);
  185.         }
  186.     return -1;
  187.     }
  188.     return mode;
  189. }
  190.  
  191. /*
  192.  *----------------------------------------------------------------------
  193.  *
  194.  * Tcl_EvalFile --
  195.  *
  196.  *    Read in a file and process the entire file as one gigantic
  197.  *    Tcl command.
  198.  *
  199.  * Results:
  200.  *    A standard Tcl result, which is either the result of executing
  201.  *    the file or an error indicating why the file couldn't be read.
  202.  *
  203.  * Side effects:
  204.  *    Depends on the commands in the file.
  205.  *
  206.  *----------------------------------------------------------------------
  207.  */
  208.  
  209. int
  210. Tcl_EvalFile(interp, fileName)
  211.     Tcl_Interp *interp;        /* Interpreter in which to process file. */
  212.     char *fileName;        /* Name of file to process.  Tilde-substitution
  213.                  * will be performed on this name. */
  214. {
  215.     int result;
  216.     struct stat statBuf;
  217.     char *cmdBuffer = (char *) NULL;
  218.     char *oldScriptFile;
  219.     Interp *iPtr = (Interp *) interp;
  220.     Tcl_DString buffer;
  221.     char *nativeName;
  222.     Tcl_Channel chan;
  223.  
  224.     Tcl_ResetResult(interp);
  225.     oldScriptFile = iPtr->scriptFile;
  226.     iPtr->scriptFile = fileName;
  227.     Tcl_DStringInit(&buffer);
  228.     nativeName = Tcl_TranslateFileName(interp, fileName, &buffer);
  229.     if (nativeName == NULL) {
  230.     goto error;
  231.     }
  232.  
  233.     /*
  234.      * If Tcl_TranslateFileName didn't already copy the file name, do it
  235.      * here.  This way we don't depend on fileName staying constant
  236.      * throughout the execution of the script (e.g., what if it happens
  237.      * to point to a Tcl variable that the script could change?).
  238.      */
  239.  
  240.     if (nativeName != Tcl_DStringValue(&buffer)) {
  241.     Tcl_DStringSetLength(&buffer, 0);
  242.     Tcl_DStringAppend(&buffer, nativeName, -1);
  243.     nativeName = Tcl_DStringValue(&buffer);
  244.     }
  245.     if (stat(nativeName, &statBuf) == -1) {
  246.         Tcl_SetErrno(errno);
  247.     Tcl_AppendResult(interp, "couldn't read file \"", fileName,
  248.         "\": ", Tcl_PosixError(interp), (char *) NULL);
  249.     goto error;
  250.     }
  251.     chan = Tcl_OpenFileChannel(interp, nativeName, "r", 0644);
  252.     if (chan == (Tcl_Channel) NULL) {
  253.         Tcl_ResetResult(interp);
  254.     Tcl_AppendResult(interp, "couldn't read file \"", fileName,
  255.         "\": ", Tcl_PosixError(interp), (char *) NULL);
  256.     goto error;
  257.     }
  258.     cmdBuffer = (char *) ckalloc((unsigned) statBuf.st_size+1);
  259.     result = Tcl_Read(chan, cmdBuffer, statBuf.st_size);
  260.     if (result < 0) {
  261.         Tcl_Close(interp, chan);
  262.     Tcl_AppendResult(interp, "couldn't read file \"", fileName,
  263.         "\": ", Tcl_PosixError(interp), (char *) NULL);
  264.     goto error;
  265.     }
  266.     cmdBuffer[result] = 0;
  267.     if (Tcl_Close(interp, chan) != TCL_OK) {
  268.         goto error;
  269.     }
  270.  
  271.     result = Tcl_Eval(interp, cmdBuffer);
  272.     if (result == TCL_RETURN) {
  273.     result = TclUpdateReturnInfo(iPtr);
  274.     } else if (result == TCL_ERROR) {
  275.     char msg[200];
  276.  
  277.     /*
  278.      * Record information telling where the error occurred.
  279.      */
  280.  
  281.     sprintf(msg, "\n    (file \"%.150s\" line %d)", fileName,
  282.         interp->errorLine);
  283.     Tcl_AddErrorInfo(interp, msg);
  284.     }
  285.     iPtr->scriptFile = oldScriptFile;
  286.     ckfree(cmdBuffer);
  287.     Tcl_DStringFree(&buffer);
  288.     return result;
  289.  
  290. error:
  291.     if (cmdBuffer != (char *) NULL) {
  292.         ckfree(cmdBuffer);
  293.     }
  294.     iPtr->scriptFile = oldScriptFile;
  295.     Tcl_DStringFree(&buffer);
  296.     return TCL_ERROR;
  297. }
  298.  
  299. /*
  300.  *----------------------------------------------------------------------
  301.  *
  302.  * Tcl_GetErrno --
  303.  *
  304.  *    Gets the current value of the Tcl error code variable. This is
  305.  *    currently the global variable "errno" but could in the future
  306.  *    change to something else.
  307.  *
  308.  * Results:
  309.  *    The value of the Tcl error code variable.
  310.  *
  311.  * Side effects:
  312.  *    None. Note that the value of the Tcl error code variable is
  313.  *    UNDEFINED if a call to Tcl_SetErrno did not precede this call.
  314.  *
  315.  *----------------------------------------------------------------------
  316.  */
  317.  
  318. int
  319. Tcl_GetErrno()
  320. {
  321.     return errno;
  322. }
  323.  
  324. /*
  325.  *----------------------------------------------------------------------
  326.  *
  327.  * Tcl_SetErrno --
  328.  *
  329.  *    Sets the Tcl error code variable to the supplied value.
  330.  *
  331.  * Results:
  332.  *    None.
  333.  *
  334.  * Side effects:
  335.  *    Modifies the value of the Tcl error code variable.
  336.  *
  337.  *----------------------------------------------------------------------
  338.  */
  339.  
  340. void
  341. Tcl_SetErrno(err)
  342.     int err;            /* The new value. */
  343. {
  344.     errno = err;
  345. }
  346.  
  347. /*
  348.  *----------------------------------------------------------------------
  349.  *
  350.  * Tcl_PosixError --
  351.  *
  352.  *    This procedure is typically called after UNIX kernel calls
  353.  *    return errors.  It stores machine-readable information about
  354.  *    the error in $errorCode returns an information string for
  355.  *    the caller's use.
  356.  *
  357.  * Results:
  358.  *    The return value is a human-readable string describing the
  359.  *    error.
  360.  *
  361.  * Side effects:
  362.  *    The global variable $errorCode is reset.
  363.  *
  364.  *----------------------------------------------------------------------
  365.  */
  366.  
  367. char *
  368. Tcl_PosixError(interp)
  369.     Tcl_Interp *interp;        /* Interpreter whose $errorCode variable
  370.                  * is to be changed. */
  371. {
  372.     char *id, *msg;
  373.  
  374.     msg = Tcl_ErrnoMsg(errno);
  375.     id = Tcl_ErrnoId();
  376.     Tcl_SetErrorCode(interp, "POSIX", id, msg, (char *) NULL);
  377.     return msg;
  378. }
  379.