/* * tclIOUtil.c -- * * This file contains a collection of utility procedures that * are shared by the platform specific IO drivers. * * Parts of this file are based on code contributed by Karl * Lehenbauer, Mark Diekhans and Peter da Silva. * * Copyright (c) 1991-1994 The Regents of the University of California. * Copyright (c) 1994-1996 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * SCCS: @(#) tclIOUtil.c 1.133 97/09/24 16:38:57 */ #include "tclInt.h" #include "tclPort.h" /* *---------------------------------------------------------------------- * * TclGetOpenMode -- * * Description: * Computes a POSIX mode mask for opening a file, from a given string, * and also sets a flag to indicate whether the caller should seek to * EOF after opening the file. * * Results: * On success, returns mode to pass to "open". If an error occurs, the * returns -1 and if interp is not NULL, sets interp->result to an * error message. * * Side effects: * Sets the integer referenced by seekFlagPtr to 1 to tell the caller * to seek to EOF after opening the file. * * Special note: * This code is based on a prototype implementation contributed * by Mark Diekhans. * *---------------------------------------------------------------------- */ int TclGetOpenMode(interp, string, seekFlagPtr) Tcl_Interp *interp; /* Interpreter to use for error * reporting - may be NULL. */ char *string; /* Mode string, e.g. "r+" or * "RDONLY CREAT". */ int *seekFlagPtr; /* Set this to 1 if the caller * should seek to EOF during the * opening of the file. */ { int mode, modeArgc, c, i, gotRW; char **modeArgv, *flag; #define RW_MODES (O_RDONLY|O_WRONLY|O_RDWR) /* * Check for the simpler fopen-like access modes (e.g. "r"). They * are distinguished from the POSIX access modes by the presence * of a lower-case first letter. */ *seekFlagPtr = 0; mode = 0; if (islower(UCHAR(string[0]))) { switch (string[0]) { case 'r': mode = O_RDONLY; break; case 'w': mode = O_WRONLY|O_CREAT|O_TRUNC; break; case 'a': mode = O_WRONLY|O_CREAT; *seekFlagPtr = 1; break; default: error: if (interp != (Tcl_Interp *) NULL) { Tcl_AppendResult(interp, "illegal access mode \"", string, "\"", (char *) NULL); } return -1; } if (string[1] == '+') { mode &= ~(O_RDONLY|O_WRONLY); mode |= O_RDWR; if (string[2] != 0) { goto error; } } else if (string[1] != 0) { goto error; } return mode; } /* * The access modes are specified using a list of POSIX modes * such as O_CREAT. * * IMPORTANT NOTE: We rely on Tcl_SplitList working correctly when * a NULL interpreter is passed in. */ if (Tcl_SplitList(interp, string, &modeArgc, &modeArgv) != TCL_OK) { if (interp != (Tcl_Interp *) NULL) { Tcl_AddErrorInfo(interp, "\n while processing open access modes \""); Tcl_AddErrorInfo(interp, string); Tcl_AddErrorInfo(interp, "\""); } return -1; } gotRW = 0; for (i = 0; i < modeArgc; i++) { flag = modeArgv[i]; c = flag[0]; if ((c == 'R') && (strcmp(flag, "RDONLY") == 0)) { mode = (mode & ~RW_MODES) | O_RDONLY; gotRW = 1; } else if ((c == 'W') && (strcmp(flag, "WRONLY") == 0)) { mode = (mode & ~RW_MODES) | O_WRONLY; gotRW = 1; } else if ((c == 'R') && (strcmp(flag, "RDWR") == 0)) { mode = (mode & ~RW_MODES) | O_RDWR; gotRW = 1; } else if ((c == 'A') && (strcmp(flag, "APPEND") == 0)) { mode |= O_APPEND; *seekFlagPtr = 1; } else if ((c == 'C') && (strcmp(flag, "CREAT") == 0)) { mode |= O_CREAT; } else if ((c == 'E') && (strcmp(flag, "EXCL") == 0)) { mode |= O_EXCL; } else if ((c == 'N') && (strcmp(flag, "NOCTTY") == 0)) { #ifdef O_NOCTTY mode |= O_NOCTTY; #else if (interp != (Tcl_Interp *) NULL) { Tcl_AppendResult(interp, "access mode \"", flag, "\" not supported by this system", (char *) NULL); } ckfree((char *) modeArgv); return -1; #endif } else if ((c == 'N') && (strcmp(flag, "NONBLOCK") == 0)) { #if defined(O_NDELAY) || defined(O_NONBLOCK) # ifdef O_NONBLOCK mode |= O_NONBLOCK; # else mode |= O_NDELAY; # endif #else if (interp != (Tcl_Interp *) NULL) { Tcl_AppendResult(interp, "access mode \"", flag, "\" not supported by this system", (char *) NULL); } ckfree((char *) modeArgv); return -1; #endif } else if ((c == 'T') && (strcmp(flag, "TRUNC") == 0)) { mode |= O_TRUNC; } else { if (interp != (Tcl_Interp *) NULL) { Tcl_AppendResult(interp, "invalid access mode \"", flag, "\": must be RDONLY, WRONLY, RDWR, APPEND, CREAT", " EXCL, NOCTTY, NONBLOCK, or TRUNC", (char *) NULL); } ckfree((char *) modeArgv); return -1; } } ckfree((char *) modeArgv); if (!gotRW) { if (interp != (Tcl_Interp *) NULL) { Tcl_AppendResult(interp, "access mode must include either", " RDONLY, WRONLY, or RDWR", (char *) NULL); } return -1; } return mode; } /* *---------------------------------------------------------------------- * * Tcl_EvalFile -- * * Read in a file and process the entire file as one gigantic * Tcl command. * * Results: * A standard Tcl result, which is either the result of executing * the file or an error indicating why the file couldn't be read. * * Side effects: * Depends on the commands in the file. * *---------------------------------------------------------------------- */ int Tcl_EvalFile(interp, fileName) Tcl_Interp *interp; /* Interpreter in which to process file. */ char *fileName; /* Name of file to process. Tilde-substitution * will be performed on this name. */ { int result; struct stat statBuf; char *cmdBuffer = (char *) NULL; char *oldScriptFile; Interp *iPtr = (Interp *) interp; Tcl_DString buffer; char *nativeName; Tcl_Channel chan; Tcl_Obj *cmdObjPtr; Tcl_ResetResult(interp); oldScriptFile = iPtr->scriptFile; iPtr->scriptFile = fileName; Tcl_DStringInit(&buffer); nativeName = Tcl_TranslateFileName(interp, fileName, &buffer); if (nativeName == NULL) { goto error; } /* * If Tcl_TranslateFileName didn't already copy the file name, do it * here. This way we don't depend on fileName staying constant * throughout the execution of the script (e.g., what if it happens * to point to a Tcl variable that the script could change?). */ if (nativeName != Tcl_DStringValue(&buffer)) { Tcl_DStringSetLength(&buffer, 0); Tcl_DStringAppend(&buffer, nativeName, -1); nativeName = Tcl_DStringValue(&buffer); } if (stat(nativeName, &statBuf) == -1) { Tcl_SetErrno(errno); Tcl_AppendResult(interp, "couldn't read file \"", fileName, "\": ", Tcl_PosixError(interp), (char *) NULL); goto error; } chan = Tcl_OpenFileChannel(interp, nativeName, "r", 0644); if (chan == (Tcl_Channel) NULL) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "couldn't read file \"", fileName, "\": ", Tcl_PosixError(interp), (char *) NULL); goto error; } cmdBuffer = (char *) ckalloc((unsigned) statBuf.st_size+1); result = Tcl_Read(chan, cmdBuffer, statBuf.st_size); if (result < 0) { Tcl_Close(interp, chan); Tcl_AppendResult(interp, "couldn't read file \"", fileName, "\": ", Tcl_PosixError(interp), (char *) NULL); goto error; } cmdBuffer[result] = 0; if (Tcl_Close(interp, chan) != TCL_OK) { goto error; } /* * Transfer the buffer memory allocated above to the object system. * Tcl_EvalObj will own this new string object if needed, * so past the Tcl_EvalObj point, we must not ckfree(cmdBuffer) * but rather use the reference counting mechanism. * (Nb: and we must not thus not use goto error after this point) */ cmdObjPtr = Tcl_NewObj(); cmdObjPtr->bytes = cmdBuffer; cmdObjPtr->length = result; Tcl_IncrRefCount(cmdObjPtr); result = Tcl_EvalObj(interp, cmdObjPtr); Tcl_DecrRefCount(cmdObjPtr); if (result == TCL_RETURN) { result = TclUpdateReturnInfo(iPtr); } else if (result == TCL_ERROR) { char msg[200]; /* * Record information telling where the error occurred. */ sprintf(msg, "\n (file \"%.150s\" line %d)", fileName, interp->errorLine); Tcl_AddErrorInfo(interp, msg); } iPtr->scriptFile = oldScriptFile; Tcl_DStringFree(&buffer); return result; error: if (cmdBuffer != (char *) NULL) { ckfree(cmdBuffer); } iPtr->scriptFile = oldScriptFile; Tcl_DStringFree(&buffer); return TCL_ERROR; } /* *---------------------------------------------------------------------- * * Tcl_GetErrno -- * * Gets the current value of the Tcl error code variable. This is * currently the global variable "errno" but could in the future * change to something else. * * Results: * The value of the Tcl error code variable. * * Side effects: * None. Note that the value of the Tcl error code variable is * UNDEFINED if a call to Tcl_SetErrno did not precede this call. * *---------------------------------------------------------------------- */ int Tcl_GetErrno() { return errno; } /* *---------------------------------------------------------------------- * * Tcl_SetErrno -- * * Sets the Tcl error code variable to the supplied value. * * Results: * None. * * Side effects: * Modifies the value of the Tcl error code variable. * *---------------------------------------------------------------------- */ void Tcl_SetErrno(err) int err; /* The new value. */ { errno = err; } /* *---------------------------------------------------------------------- * * Tcl_PosixError -- * * This procedure is typically called after UNIX kernel calls * return errors. It stores machine-readable information about * the error in $errorCode returns an information string for * the caller's use. * * Results: * The return value is a human-readable string describing the * error. * * Side effects: * The global variable $errorCode is reset. * *---------------------------------------------------------------------- */ char * Tcl_PosixError(interp) Tcl_Interp *interp; /* Interpreter whose $errorCode variable * is to be changed. */ { char *id, *msg; msg = Tcl_ErrnoMsg(errno); id = Tcl_ErrnoId(); Tcl_SetErrorCode(interp, "POSIX", id, msg, (char *) NULL); return msg; }