aboutsummaryrefslogtreecommitdiff
path: root/contrib/tcl/generic/tclIOUtil.c
diff options
context:
space:
mode:
Diffstat (limited to 'contrib/tcl/generic/tclIOUtil.c')
-rw-r--r--contrib/tcl/generic/tclIOUtil.c392
1 files changed, 0 insertions, 392 deletions
diff --git a/contrib/tcl/generic/tclIOUtil.c b/contrib/tcl/generic/tclIOUtil.c
deleted file mode 100644
index 7d4cff869e88..000000000000
--- a/contrib/tcl/generic/tclIOUtil.c
+++ /dev/null
@@ -1,392 +0,0 @@
-/*
- * 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;
-}
generated by cgit v1.2.3 (git 2.25.1) at 2025-04-10 09:25:19 +0000