--- projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclioutil.c 2016/10/30 04:21:11 64 +++ projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclioutil.c 2016/11/05 11:07:06 71 @@ -1,879 +1,879 @@ -/*$Header$ */ -/* - * 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); -} - -/* End of tclioutil.c */ +/* $Header$ */ +/* + * 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); +} + +/* End of tclioutil.c */