summaryrefslogtreecommitdiffstats
path: root/generic/tclIOUtil.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclIOUtil.c')
-rw-r--r--generic/tclIOUtil.c392
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;
+}