/* $Header: /cvsroot/esrg/sfesrg/esrgpcpj/shared/tcl_base/tclioutil.c,v 1.1.1.1 2001/06/13 04:42:24 dtashley Exp $ */ /* * 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-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclioutil.c,v 1.1.1.1 2001/06/13 04:42:24 dtashley Exp $ */ #include "tclInt.h" #include "tclPort.h" /* * The following typedef declarations allow for hooking into the chain * of functions maintained for 'Tcl_Stat(...)', 'Tcl_Access(...)' & * 'Tcl_OpenFileChannel(...)'. Basically for each hookable function * a linked list is defined. */ typedef struct StatProc { TclStatProc_ *proc; /* Function to process a 'stat()' call */ struct StatProc *nextPtr; /* The next 'stat()' function to call */ } StatProc; typedef struct AccessProc { TclAccessProc_ *proc; /* Function to process a 'access()' call */ struct AccessProc *nextPtr; /* The next 'access()' function to call */ } AccessProc; typedef struct OpenFileChannelProc { TclOpenFileChannelProc_ *proc; /* Function to process a * 'Tcl_OpenFileChannel()' call */ struct OpenFileChannelProc *nextPtr; /* The next 'Tcl_OpenFileChannel()' * function to call */ } OpenFileChannelProc; /* * For each type of hookable function, a static node is declared to * hold the function pointer for the "built-in" routine (e.g. * 'TclpStat(...)') and the respective list is initialized as a pointer * to that node. * * The "delete" functions (e.g. 'TclStatDeleteProc(...)') ensure that * these statically declared list entry cannot be inadvertently removed. * * This method avoids the need to call any sort of "initialization" * function. * * All three lists are protected by a global hookMutex. */ static StatProc defaultStatProc = { &TclpStat, NULL }; static StatProc *statProcList = &defaultStatProc; static AccessProc defaultAccessProc = { &TclpAccess, NULL }; static AccessProc *accessProcList = &defaultAccessProc; static OpenFileChannelProc defaultOpenFileChannelProc = { &TclpOpenFileChannel, NULL }; static OpenFileChannelProc *openFileChannelProcList = &defaultOpenFileChannelProc; TCL_DECLARE_MUTEX(hookMutex) /* *--------------------------------------------------------------------------- * * 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 * return value is -1 and if interp is not NULL, sets interp's result * object 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; /* * Guard against international characters before using byte oriented * routines. */ if (!(string[0] & 0x80) && islower(UCHAR(string[0]))) { /* INTL: ISO only. */ 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, length; struct stat statBuf; char *oldScriptFile; Interp *iPtr; Tcl_DString nameString; char *name, *string; Tcl_Channel chan; Tcl_Obj *objPtr; name = Tcl_TranslateFileName(interp, fileName, &nameString); if (name == NULL) { return TCL_ERROR; } result = TCL_ERROR; objPtr = Tcl_NewObj(); if (TclStat(name, &statBuf) == -1) { Tcl_SetErrno(errno); Tcl_AppendResult(interp, "couldn't read file \"", fileName, "\": ", Tcl_PosixError(interp), (char *) NULL); goto end; } chan = Tcl_OpenFileChannel(interp, name, "r", 0644); if (chan == (Tcl_Channel) NULL) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "couldn't read file \"", fileName, "\": ", Tcl_PosixError(interp), (char *) NULL); goto end; } if (Tcl_ReadChars(chan, objPtr, -1, 0) < 0) { Tcl_Close(interp, chan); Tcl_AppendResult(interp, "couldn't read file \"", fileName, "\": ", Tcl_PosixError(interp), (char *) NULL); goto end; } if (Tcl_Close(interp, chan) != TCL_OK) { goto end; } iPtr = (Interp *) interp; oldScriptFile = iPtr->scriptFile; iPtr->scriptFile = fileName; string = Tcl_GetStringFromObj(objPtr, &length); result = Tcl_EvalEx(interp, string, length, 0); iPtr->scriptFile = oldScriptFile; if (result == TCL_RETURN) { result = TclUpdateReturnInfo(iPtr); } else if (result == TCL_ERROR) { char msg[200 + TCL_INTEGER_SPACE]; /* * Record information telling where the error occurred. */ sprintf(msg, "\n (file \"%.150s\" line %d)", fileName, interp->errorLine); Tcl_AddErrorInfo(interp, msg); } end: Tcl_DecrRefCount(objPtr); Tcl_DStringFree(&nameString); return result; } /* *---------------------------------------------------------------------- * * 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; } /* *---------------------------------------------------------------------- * * TclStat -- * * This procedure replaces the library version of stat and lsat. * The chain of functions that have been "inserted" into the * 'statProcList' will be called in succession until either * a value of zero is returned, or the entire list is visited. * * Results: * See stat documentation. * * Side effects: * See stat documentation. * *---------------------------------------------------------------------- */ int TclStat(path, buf) CONST char *path; /* Path of file to stat (in current CP). */ struct stat *buf; /* Filled with results of stat call. */ { StatProc *statProcPtr; int retVal = -1; /* * Call each of the "stat" function in succession. A non-return * value of -1 indicates the particular function has succeeded. */ Tcl_MutexLock(&hookMutex); statProcPtr = statProcList; while ((retVal == -1) && (statProcPtr != NULL)) { retVal = (*statProcPtr->proc)(path, buf); statProcPtr = statProcPtr->nextPtr; } Tcl_MutexUnlock(&hookMutex); return (retVal); } /* *---------------------------------------------------------------------- * * TclAccess -- * * This procedure replaces the library version of access. * The chain of functions that have been "inserted" into the * 'accessProcList' will be called in succession until either * a value of zero is returned, or the entire list is visited. * * Results: * See access documentation. * * Side effects: * See access documentation. * *---------------------------------------------------------------------- */ int TclAccess(path, mode) CONST char *path; /* Path of file to access (in current CP). */ int mode; /* Permission setting. */ { AccessProc *accessProcPtr; int retVal = -1; /* * Call each of the "access" function in succession. A non-return * value of -1 indicates the particular function has succeeded. */ Tcl_MutexLock(&hookMutex); accessProcPtr = accessProcList; while ((retVal == -1) && (accessProcPtr != NULL)) { retVal = (*accessProcPtr->proc)(path, mode); accessProcPtr = accessProcPtr->nextPtr; } Tcl_MutexUnlock(&hookMutex); return (retVal); } /* *---------------------------------------------------------------------- * * Tcl_OpenFileChannel -- * * The chain of functions that have been "inserted" into the * 'openFileChannelProcList' will be called in succession until * either a valid file channel is returned, or the entire list is * visited. * * Results: * The new channel or NULL, if the named file could not be opened. * * Side effects: * May open the channel and may cause creation of a file on the * file system. * *---------------------------------------------------------------------- */ Tcl_Channel Tcl_OpenFileChannel(interp, fileName, modeString, permissions) Tcl_Interp *interp; /* Interpreter for error reporting; * can be NULL. */ char *fileName; /* Name of file to open. */ char *modeString; /* A list of POSIX open modes or * a string such as "rw". */ int permissions; /* If the open involves creating a * file, with what modes to create * it? */ { OpenFileChannelProc *openFileChannelProcPtr; Tcl_Channel retVal = NULL; /* * Call each of the "Tcl_OpenFileChannel" function in succession. * A non-NULL return value indicates the particular function has * succeeded. */ Tcl_MutexLock(&hookMutex); openFileChannelProcPtr = openFileChannelProcList; while ((retVal == NULL) && (openFileChannelProcPtr != NULL)) { retVal = (*openFileChannelProcPtr->proc)(interp, fileName, modeString, permissions); openFileChannelProcPtr = openFileChannelProcPtr->nextPtr; } Tcl_MutexUnlock(&hookMutex); return (retVal); } /* *---------------------------------------------------------------------- * * TclStatInsertProc -- * * Insert the passed procedure pointer at the head of the list of * functions which are used during a call to 'TclStat(...)'. The * passed function should be have exactly like 'TclStat' when called * during that time (see 'TclStat(...)' for more informatin). * The function will be added even if it already in the list. * * Results: * Normally TCL_OK; TCL_ERROR if memory for a new node in the list * could not be allocated. * * Side effects: * Memory allocataed and modifies the link list for 'TclStat' * functions. * *---------------------------------------------------------------------- */ int TclStatInsertProc (proc) TclStatProc_ *proc; { int retVal = TCL_ERROR; if (proc != NULL) { StatProc *newStatProcPtr; newStatProcPtr = (StatProc *)ckalloc(sizeof(StatProc)); if (newStatProcPtr != NULL) { newStatProcPtr->proc = proc; Tcl_MutexLock(&hookMutex); newStatProcPtr->nextPtr = statProcList; statProcList = newStatProcPtr; Tcl_MutexUnlock(&hookMutex); retVal = TCL_OK; } } return (retVal); } /* *---------------------------------------------------------------------- * * TclStatDeleteProc -- * * Removed the passed function pointer from the list of 'TclStat' * functions. Ensures that the built-in stat function is not * removvable. * * Results: * TCL_OK if the procedure pointer was successfully removed, * TCL_ERROR otherwise. * * Side effects: * Memory is deallocated and the respective list updated. * *---------------------------------------------------------------------- */ int TclStatDeleteProc (proc) TclStatProc_ *proc; { int retVal = TCL_ERROR; StatProc *tmpStatProcPtr; StatProc *prevStatProcPtr = NULL; Tcl_MutexLock(&hookMutex); tmpStatProcPtr = statProcList; /* * Traverse the 'statProcList' looking for the particular node * whose 'proc' member matches 'proc' and remove that one from * the list. Ensure that the "default" node cannot be removed. */ while ((retVal == TCL_ERROR) && (tmpStatProcPtr != &defaultStatProc)) { if (tmpStatProcPtr->proc == proc) { if (prevStatProcPtr == NULL) { statProcList = tmpStatProcPtr->nextPtr; } else { prevStatProcPtr->nextPtr = tmpStatProcPtr->nextPtr; } Tcl_Free((char *)tmpStatProcPtr); retVal = TCL_OK; } else { prevStatProcPtr = tmpStatProcPtr; tmpStatProcPtr = tmpStatProcPtr->nextPtr; } } Tcl_MutexUnlock(&hookMutex); return (retVal); } /* *---------------------------------------------------------------------- * * TclAccessInsertProc -- * * Insert the passed procedure pointer at the head of the list of * functions which are used during a call to 'TclAccess(...)'. The * passed function should be have exactly like 'TclAccess' when * called during that time (see 'TclAccess(...)' for more informatin). * The function will be added even if it already in the list. * * Results: * Normally TCL_OK; TCL_ERROR if memory for a new node in the list * could not be allocated. * * Side effects: * Memory allocataed and modifies the link list for 'TclAccess' * functions. * *---------------------------------------------------------------------- */ int TclAccessInsertProc(proc) TclAccessProc_ *proc; { int retVal = TCL_ERROR; if (proc != NULL) { AccessProc *newAccessProcPtr; newAccessProcPtr = (AccessProc *)ckalloc(sizeof(AccessProc)); if (newAccessProcPtr != NULL) { newAccessProcPtr->proc = proc; Tcl_MutexLock(&hookMutex); newAccessProcPtr->nextPtr = accessProcList; accessProcList = newAccessProcPtr; Tcl_MutexUnlock(&hookMutex); retVal = TCL_OK; } } return (retVal); } /* *---------------------------------------------------------------------- * * TclAccessDeleteProc -- * * Removed the passed function pointer from the list of 'TclAccess' * functions. Ensures that the built-in access function is not * removvable. * * Results: * TCL_OK if the procedure pointer was successfully removed, * TCL_ERROR otherwise. * * Side effects: * Memory is deallocated and the respective list updated. * *---------------------------------------------------------------------- */ int TclAccessDeleteProc(proc) TclAccessProc_ *proc; { int retVal = TCL_ERROR; AccessProc *tmpAccessProcPtr; AccessProc *prevAccessProcPtr = NULL; /* * Traverse the 'accessProcList' looking for the particular node * whose 'proc' member matches 'proc' and remove that one from * the list. Ensure that the "default" node cannot be removed. */ Tcl_MutexLock(&hookMutex); tmpAccessProcPtr = accessProcList; while ((retVal == TCL_ERROR) && (tmpAccessProcPtr != &defaultAccessProc)) { if (tmpAccessProcPtr->proc == proc) { if (prevAccessProcPtr == NULL) { accessProcList = tmpAccessProcPtr->nextPtr; } else { prevAccessProcPtr->nextPtr = tmpAccessProcPtr->nextPtr; } Tcl_Free((char *)tmpAccessProcPtr); retVal = TCL_OK; } else { prevAccessProcPtr = tmpAccessProcPtr; tmpAccessProcPtr = tmpAccessProcPtr->nextPtr; } } Tcl_MutexUnlock(&hookMutex); return (retVal); } /* *---------------------------------------------------------------------- * * TclOpenFileChannelInsertProc -- * * Insert the passed procedure pointer at the head of the list of * functions which are used during a call to * 'Tcl_OpenFileChannel(...)'. The passed function should be have * exactly like 'Tcl_OpenFileChannel' when called during that time * (see 'Tcl_OpenFileChannel(...)' for more informatin). The * function will be added even if it already in the list. * * Results: * Normally TCL_OK; TCL_ERROR if memory for a new node in the list * could not be allocated. * * Side effects: * Memory allocataed and modifies the link list for * 'Tcl_OpenFileChannel' functions. * *---------------------------------------------------------------------- */ int TclOpenFileChannelInsertProc(proc) TclOpenFileChannelProc_ *proc; { int retVal = TCL_ERROR; if (proc != NULL) { OpenFileChannelProc *newOpenFileChannelProcPtr; newOpenFileChannelProcPtr = (OpenFileChannelProc *)ckalloc(sizeof(OpenFileChannelProc)); if (newOpenFileChannelProcPtr != NULL) { newOpenFileChannelProcPtr->proc = proc; Tcl_MutexLock(&hookMutex); newOpenFileChannelProcPtr->nextPtr = openFileChannelProcList; openFileChannelProcList = newOpenFileChannelProcPtr; Tcl_MutexUnlock(&hookMutex); retVal = TCL_OK; } } return (retVal); } /* *---------------------------------------------------------------------- * * TclOpenFileChannelDeleteProc -- * * Removed the passed function pointer from the list of * 'Tcl_OpenFileChannel' functions. Ensures that the built-in * open file channel function is not removvable. * * Results: * TCL_OK if the procedure pointer was successfully removed, * TCL_ERROR otherwise. * * Side effects: * Memory is deallocated and the respective list updated. * *---------------------------------------------------------------------- */ int TclOpenFileChannelDeleteProc(proc) TclOpenFileChannelProc_ *proc; { int retVal = TCL_ERROR; OpenFileChannelProc *tmpOpenFileChannelProcPtr = openFileChannelProcList; OpenFileChannelProc *prevOpenFileChannelProcPtr = NULL; /* * Traverse the 'openFileChannelProcList' looking for the particular * node whose 'proc' member matches 'proc' and remove that one from * the list. Ensure that the "default" node cannot be removed. */ Tcl_MutexLock(&hookMutex); tmpOpenFileChannelProcPtr = openFileChannelProcList; while ((retVal == TCL_ERROR) && (tmpOpenFileChannelProcPtr != &defaultOpenFileChannelProc)) { if (tmpOpenFileChannelProcPtr->proc == proc) { if (prevOpenFileChannelProcPtr == NULL) { openFileChannelProcList = tmpOpenFileChannelProcPtr->nextPtr; } else { prevOpenFileChannelProcPtr->nextPtr = tmpOpenFileChannelProcPtr->nextPtr; } Tcl_Free((char *)tmpOpenFileChannelProcPtr); retVal = TCL_OK; } else { prevOpenFileChannelProcPtr = tmpOpenFileChannelProcPtr; tmpOpenFileChannelProcPtr = tmpOpenFileChannelProcPtr->nextPtr; } } Tcl_MutexUnlock(&hookMutex); return (retVal); } /* $History: tclioutil.c $ * * ***************** Version 1 ***************** * User: Dtashley Date: 1/02/01 Time: 1:33a * Created in $/IjuScripter, IjuConsole/Source/Tcl Base * Initial check-in. */ /* End of TCLIOUTIL.C */