/[dtapublic]/projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclioutil.c

Diff of /projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclioutil.c

Parent Directory | Revision Log | View Patch Patch

-revision 70 by dashley,
Sun Oct 30 21:57:38 2016 UTC
+revision 71 by dashley,
Sat Nov  5 11:07:06 2016 UTC
 Line 1
  /* $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 */

 Legend:



Removed from v.70
 


changed lines


 
Added in v.71
 Legend:



Removed from v.70
 


changed lines


 
Added in v.71
-Removed from v.70
+Added in v.71

dashley@gmail.com	ViewVC Help
Powered by ViewVC 1.1.25