diff options
Diffstat (limited to 'generic/tclIOUtil.c')
| -rw-r--r-- | generic/tclIOUtil.c | 392 |
1 files changed, 392 insertions, 0 deletions
diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c new file mode 100644 index 0000000..7d4cff8 --- /dev/null +++ b/generic/tclIOUtil.c @@ -0,0 +1,392 @@ +/* + * 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; +} |