shared_source/c_tcl_base_7_5_w_mods/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 */