tcl/generic/tclIOUtil.c

   1 /*
   2  * tclIOUtil.c --
   3  *
   4  *      This file contains a collection of utility procedures that
   5  *      are shared by the platform specific IO drivers.
   6  *
   7  *      Parts of this file are based on code contributed by Karl
   8  *      Lehenbauer, Mark Diekhans and Peter da Silva.
   9  *
  10  * Copyright (c) 1991-1994 The Regents of the University of California.
  11  * Copyright (c) 1994-1997 Sun Microsystems, Inc.
  12  *
  13  * See the file "license.terms" for information on usage and redistribution
  14  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  15  *
  16  * RCS: @(#) $Id$
  17  */
  18
  19 #include "tclInt.h"
  20 #include "tclPort.h"
  21 \f
  22 /*
  23  * The following typedef declarations allow for hooking into the chain
  24  * of functions maintained for 'Tcl_Stat(...)', 'Tcl_Access(...)' &
  25  * 'Tcl_OpenFileChannel(...)'.  Basically for each hookable function
  26  * a linked list is defined.
  27  */
  28
  29 typedef struct StatProc {
  30     TclStatProc_ *proc;          /* Function to process a 'stat()' call */
  31     struct StatProc *nextPtr;    /* The next 'stat()' function to call */
  32 } StatProc;
  33
  34 typedef struct AccessProc {
  35     TclAccessProc_ *proc;        /* Function to process a 'access()' call */
  36     struct AccessProc *nextPtr;  /* The next 'access()' function to call */
  37 } AccessProc;
  38
  39 typedef struct OpenFileChannelProc {
  40     TclOpenFileChannelProc_ *proc;  /* Function to process a
  41                                      * 'Tcl_OpenFileChannel()' call */
  42     struct OpenFileChannelProc *nextPtr;
  43                                     /* The next 'Tcl_OpenFileChannel()'
  44                                      * function to call */
  45 } OpenFileChannelProc;
  46
  47 /*
  48  * For each type of hookable function, a static node is declared to
  49  * hold the function pointer for the "built-in" routine (e.g.
  50  * 'TclpStat(...)') and the respective list is initialized as a pointer
  51  * to that node.
  52  *
  53  * The "delete" functions (e.g. 'TclStatDeleteProc(...)') ensure that
  54  * these statically declared list entry cannot be inadvertently removed.
  55  *
  56  * This method avoids the need to call any sort of "initialization"
  57  * function.
  58  *
  59  * All three lists are protected by a global hookMutex.
  60  */
  61
  62 static StatProc defaultStatProc = {
  63     &TclpStat, NULL
  64 };
  65 static StatProc *statProcList = &defaultStatProc;
  66
  67 static AccessProc defaultAccessProc = {
  68     &TclpAccess, NULL
  69 };
  70 static AccessProc *accessProcList = &defaultAccessProc;
  71
  72 static OpenFileChannelProc defaultOpenFileChannelProc = {
  73     &TclpOpenFileChannel, NULL
  74 };
  75 static OpenFileChannelProc *openFileChannelProcList =
  76         &defaultOpenFileChannelProc;
  77
  78 TCL_DECLARE_MUTEX(hookMutex)
  79 \f
  80 /*
  81  *---------------------------------------------------------------------------
  82  *
  83  * TclGetOpenMode --
  84  *
  85  * Description:
  86  *      Computes a POSIX mode mask for opening a file, from a given string,
  87  *      and also sets a flag to indicate whether the caller should seek to
  88  *      EOF after opening the file.
  89  *
  90  * Results:
  91  *      On success, returns mode to pass to "open". If an error occurs, the
  92  *      return value is -1 and if interp is not NULL, sets interp's result
  93  *      object to an error message.
  94  *
  95  * Side effects:
  96  *      Sets the integer referenced by seekFlagPtr to 1 to tell the caller
  97  *      to seek to EOF after opening the file.
  98  *
  99  * Special note:
 100  *      This code is based on a prototype implementation contributed
 101  *      by Mark Diekhans.
 102  *
 103  *---------------------------------------------------------------------------
 104  */
 105
 106 int
 107 TclGetOpenMode(interp, string, seekFlagPtr)
 108     Tcl_Interp *interp;                 /* Interpreter to use for error
 109                                          * reporting - may be NULL. */
 110     char *string;                       /* Mode string, e.g. "r+" or
 111                                          * "RDONLY CREAT". */
 112     int *seekFlagPtr;                   /* Set this to 1 if the caller
 113                                          * should seek to EOF during the
 114                                          * opening of the file. */
 115 {
 116     int mode, modeArgc, c, i, gotRW;
 117     char **modeArgv, *flag;
 118 #define RW_MODES (O_RDONLY|O_WRONLY|O_RDWR)
 119
 120     /*
 121      * Check for the simpler fopen-like access modes (e.g. "r").  They
 122      * are distinguished from the POSIX access modes by the presence
 123      * of a lower-case first letter.
 124      */
 125
 126     *seekFlagPtr = 0;
 127     mode = 0;
 128
 129     /*
 130      * Guard against international characters before using byte oriented
 131      * routines.
 132      */
 133
 134     if (!(string[0] & 0x80)
 135             && islower(UCHAR(string[0]))) { /* INTL: ISO only. */
 136         switch (string[0]) {
 137             case 'r':
 138                 mode = O_RDONLY;
 139                 break;
 140             case 'w':
 141                 mode = O_WRONLY|O_CREAT|O_TRUNC;
 142                 break;
 143             case 'a':
 144                 mode = O_WRONLY|O_CREAT;
 145                 *seekFlagPtr = 1;
 146                 break;
 147             default:
 148                 error:
 149                 if (interp != (Tcl_Interp *) NULL) {
 150                     Tcl_AppendResult(interp,
 151                             "illegal access mode \"", string, "\"",
 152                             (char *) NULL);
 153                 }
 154                 return -1;
 155         }
 156         if (string[1] == '+') {
 157             mode &= ~(O_RDONLY|O_WRONLY);
 158             mode |= O_RDWR;
 159             if (string[2] != 0) {
 160                 goto error;
 161             }
 162         } else if (string[1] != 0) {
 163             goto error;
 164         }
 165         return mode;
 166     }
 167
 168     /*
 169      * The access modes are specified using a list of POSIX modes
 170      * such as O_CREAT.
 171      *
 172      * IMPORTANT NOTE: We rely on Tcl_SplitList working correctly when
 173      * a NULL interpreter is passed in.
 174      */
 175
 176     if (Tcl_SplitList(interp, string, &modeArgc, &modeArgv) != TCL_OK) {
 177         if (interp != (Tcl_Interp *) NULL) {
 178             Tcl_AddErrorInfo(interp,
 179                     "\n    while processing open access modes \"");
 180             Tcl_AddErrorInfo(interp, string);
 181             Tcl_AddErrorInfo(interp, "\"");
 182         }
 183         return -1;
 184     }
 185
 186     gotRW = 0;
 187     for (i = 0; i < modeArgc; i++) {
 188         flag = modeArgv[i];
 189         c = flag[0];
 190         if ((c == 'R') && (strcmp(flag, "RDONLY") == 0)) {
 191             mode = (mode & ~RW_MODES) | O_RDONLY;
 192             gotRW = 1;
 193         } else if ((c == 'W') && (strcmp(flag, "WRONLY") == 0)) {
 194             mode = (mode & ~RW_MODES) | O_WRONLY;
 195             gotRW = 1;
 196         } else if ((c == 'R') && (strcmp(flag, "RDWR") == 0)) {
 197             mode = (mode & ~RW_MODES) | O_RDWR;
 198             gotRW = 1;
 199         } else if ((c == 'A') && (strcmp(flag, "APPEND") == 0)) {
 200             mode |= O_APPEND;
 201             *seekFlagPtr = 1;
 202         } else if ((c == 'C') && (strcmp(flag, "CREAT") == 0)) {
 203             mode |= O_CREAT;
 204         } else if ((c == 'E') && (strcmp(flag, "EXCL") == 0)) {
 205             mode |= O_EXCL;
 206         } else if ((c == 'N') && (strcmp(flag, "NOCTTY") == 0)) {
 207 #ifdef O_NOCTTY
 208             mode |= O_NOCTTY;
 209 #else
 210             if (interp != (Tcl_Interp *) NULL) {
 211                 Tcl_AppendResult(interp, "access mode \"", flag,
 212                         "\" not supported by this system", (char *) NULL);
 213             }
 214             ckfree((char *) modeArgv);
 215             return -1;
 216 #endif
 217         } else if ((c == 'N') && (strcmp(flag, "NONBLOCK") == 0)) {
 218 #if defined(O_NDELAY) || defined(O_NONBLOCK)
 219 #   ifdef O_NONBLOCK
 220             mode |= O_NONBLOCK;
 221 #   else
 222             mode |= O_NDELAY;
 223 #   endif
 224 #else
 225             if (interp != (Tcl_Interp *) NULL) {
 226                 Tcl_AppendResult(interp, "access mode \"", flag,
 227                         "\" not supported by this system", (char *) NULL);
 228             }
 229             ckfree((char *) modeArgv);
 230             return -1;
 231 #endif
 232         } else if ((c == 'T') && (strcmp(flag, "TRUNC") == 0)) {
 233             mode |= O_TRUNC;
 234         } else {
 235             if (interp != (Tcl_Interp *) NULL) {
 236                 Tcl_AppendResult(interp, "invalid access mode \"", flag,
 237                         "\": must be RDONLY, WRONLY, RDWR, APPEND, CREAT",
 238                         " EXCL, NOCTTY, NONBLOCK, or TRUNC", (char *) NULL);
 239             }
 240             ckfree((char *) modeArgv);
 241             return -1;
 242         }
 243     }
 244     ckfree((char *) modeArgv);
 245     if (!gotRW) {
 246         if (interp != (Tcl_Interp *) NULL) {
 247             Tcl_AppendResult(interp, "access mode must include either",
 248                     " RDONLY, WRONLY, or RDWR", (char *) NULL);
 249         }
 250         return -1;
 251     }
 252     return mode;
 253 }
 254 \f
 255 /*
 256  *----------------------------------------------------------------------
 257  *
 258  * Tcl_EvalFile --
 259  *
 260  *      Read in a file and process the entire file as one gigantic
 261  *      Tcl command.
 262  *
 263  * Results:
 264  *      A standard Tcl result, which is either the result of executing
 265  *      the file or an error indicating why the file couldn't be read.
 266  *
 267  * Side effects:
 268  *      Depends on the commands in the file.
 269  *
 270  *----------------------------------------------------------------------
 271  */
 272
 273 int
 274 Tcl_EvalFile(interp, fileName)
 275     Tcl_Interp *interp;         /* Interpreter in which to process file. */
 276     char *fileName;             /* Name of file to process.  Tilde-substitution
 277                                  * will be performed on this name. */
 278 {
 279     int result, length;
 280     struct stat statBuf;
 281     char *oldScriptFile;
 282     Interp *iPtr;
 283     Tcl_DString nameString;
 284     char *name, *string;
 285     Tcl_Channel chan;
 286     Tcl_Obj *objPtr;
 287
 288     name = Tcl_TranslateFileName(interp, fileName, &nameString);
 289     if (name == NULL) {
 290         return TCL_ERROR;
 291     }
 292
 293     result = TCL_ERROR;
 294     objPtr = Tcl_NewObj();
 295
 296     if (TclStat(name, &statBuf) == -1) {
 297         Tcl_SetErrno(errno);
 298         Tcl_AppendResult(interp, "couldn't read file \"", fileName,
 299                 "\": ", Tcl_PosixError(interp), (char *) NULL);
 300         goto end;
 301     }
 302     chan = Tcl_OpenFileChannel(interp, name, "r", 0644);
 303     if (chan == (Tcl_Channel) NULL) {
 304         Tcl_ResetResult(interp);
 305         Tcl_AppendResult(interp, "couldn't read file \"", fileName,
 306                 "\": ", Tcl_PosixError(interp), (char *) NULL);
 307         goto end;
 308     }
 309     if (Tcl_ReadChars(chan, objPtr, -1, 0) < 0) {
 310         Tcl_Close(interp, chan);
 311         Tcl_AppendResult(interp, "couldn't read file \"", fileName,
 312                 "\": ", Tcl_PosixError(interp), (char *) NULL);
 313         goto end;
 314     }
 315     if (Tcl_Close(interp, chan) != TCL_OK) {
 316         goto end;
 317     }
 318
 319     iPtr = (Interp *) interp;
 320     oldScriptFile = iPtr->scriptFile;
 321     iPtr->scriptFile = fileName;
 322     string = Tcl_GetStringFromObj(objPtr, &length);
 323     result = Tcl_EvalEx(interp, string, length, 0);
 324     iPtr->scriptFile = oldScriptFile;
 325
 326     if (result == TCL_RETURN) {
 327         result = TclUpdateReturnInfo(iPtr);
 328     } else if (result == TCL_ERROR) {
 329         char msg[200 + TCL_INTEGER_SPACE];
 330
 331         /*
 332          * Record information telling where the error occurred.
 333          */
 334
 335         sprintf(msg, "\n    (file \"%.150s\" line %d)", fileName,
 336                 interp->errorLine);
 337         Tcl_AddErrorInfo(interp, msg);
 338     }
 339
 340     end:
 341     Tcl_DecrRefCount(objPtr);
 342     Tcl_DStringFree(&nameString);
 343     return result;
 344 }
 345 \f
 346 /*
 347  *----------------------------------------------------------------------
 348  *
 349  * Tcl_GetErrno --
 350  *
 351  *      Gets the current value of the Tcl error code variable. This is
 352  *      currently the global variable "errno" but could in the future
 353  *      change to something else.
 354  *
 355  * Results:
 356  *      The value of the Tcl error code variable.
 357  *
 358  * Side effects:
 359  *      None. Note that the value of the Tcl error code variable is
 360  *      UNDEFINED if a call to Tcl_SetErrno did not precede this call.
 361  *
 362  *----------------------------------------------------------------------
 363  */
 364
 365 int
 366 Tcl_GetErrno()
 367 {
 368     return errno;
 369 }
 370 \f
 371 /*
 372  *----------------------------------------------------------------------
 373  *
 374  * Tcl_SetErrno --
 375  *
 376  *      Sets the Tcl error code variable to the supplied value.
 377  *
 378  * Results:
 379  *      None.
 380  *
 381  * Side effects:
 382  *      Modifies the value of the Tcl error code variable.
 383  *
 384  *----------------------------------------------------------------------
 385  */
 386
 387 void
 388 Tcl_SetErrno(err)
 389     int err;                    /* The new value. */
 390 {
 391     errno = err;
 392 }
 393 \f
 394 /*
 395  *----------------------------------------------------------------------
 396  *
 397  * Tcl_PosixError --
 398  *
 399  *      This procedure is typically called after UNIX kernel calls
 400  *      return errors.  It stores machine-readable information about
 401  *      the error in $errorCode returns an information string for
 402  *      the caller's use.
 403  *
 404  * Results:
 405  *      The return value is a human-readable string describing the
 406  *      error.
 407  *
 408  * Side effects:
 409  *      The global variable $errorCode is reset.
 410  *
 411  *----------------------------------------------------------------------
 412  */
 413
 414 char *
 415 Tcl_PosixError(interp)
 416     Tcl_Interp *interp;         /* Interpreter whose $errorCode variable
 417                                  * is to be changed. */
 418 {
 419     char *id, *msg;
 420
 421     msg = Tcl_ErrnoMsg(errno);
 422     id = Tcl_ErrnoId();
 423     Tcl_SetErrorCode(interp, "POSIX", id, msg, (char *) NULL);
 424     return msg;
 425 }
 426 \f
 427 /*
 428  *----------------------------------------------------------------------
 429  *
 430  * TclStat --
 431  *
 432  *      This procedure replaces the library version of stat and lsat.
 433  *      The chain of functions that have been "inserted" into the
 434  *      'statProcList' will be called in succession until either
 435  *      a value of zero is returned, or the entire list is visited.
 436  *
 437  * Results:
 438  *      See stat documentation.
 439  *
 440  * Side effects:
 441  *      See stat documentation.
 442  *
 443  *----------------------------------------------------------------------
 444  */
 445
 446 int
 447 TclStat(path, buf)
 448     CONST char *path;           /* Path of file to stat (in current CP). */
 449     struct stat *buf;           /* Filled with results of stat call. */
 450 {
 451     StatProc *statProcPtr;
 452     int retVal = -1;
 453
 454     /*
 455      * Call each of the "stat" function in succession.  A non-return
 456      * value of -1 indicates the particular function has succeeded.
 457      */
 458
 459     Tcl_MutexLock(&hookMutex);
 460     statProcPtr = statProcList;
 461     while ((retVal == -1) && (statProcPtr != NULL)) {
 462         retVal = (*statProcPtr->proc)(path, buf);
 463         statProcPtr = statProcPtr->nextPtr;
 464     }
 465     Tcl_MutexUnlock(&hookMutex);
 466
 467     return (retVal);
 468 }
 469 \f
 470 /*
 471  *----------------------------------------------------------------------
 472  *
 473  * TclAccess --
 474  *
 475  *      This procedure replaces the library version of access.
 476  *      The chain of functions that have been "inserted" into the
 477  *      'accessProcList' will be called in succession until either
 478  *      a value of zero is returned, or the entire list is visited.
 479  *
 480  * Results:
 481  *      See access documentation.
 482  *
 483  * Side effects:
 484  *      See access documentation.
 485  *
 486  *----------------------------------------------------------------------
 487  */
 488
 489 int
 490 TclAccess(path, mode)
 491     CONST char *path;           /* Path of file to access (in current CP). */
 492     int mode;                   /* Permission setting. */
 493 {
 494     AccessProc *accessProcPtr;
 495     int retVal = -1;
 496
 497     /*
 498      * Call each of the "access" function in succession.  A non-return
 499      * value of -1 indicates the particular function has succeeded.
 500      */
 501
 502     Tcl_MutexLock(&hookMutex);
 503     accessProcPtr = accessProcList;
 504     while ((retVal == -1) && (accessProcPtr != NULL)) {
 505         retVal = (*accessProcPtr->proc)(path, mode);
 506         accessProcPtr = accessProcPtr->nextPtr;
 507     }
 508     Tcl_MutexUnlock(&hookMutex);
 509
 510     return (retVal);
 511 }
 512 \f
 513 /*
 514  *----------------------------------------------------------------------
 515  *
 516  * Tcl_OpenFileChannel --
 517  *
 518  *      The chain of functions that have been "inserted" into the
 519  *      'openFileChannelProcList' will be called in succession until
 520  *      either a valid file channel is returned, or the entire list is
 521  *      visited.
 522  *
 523  * Results:
 524  *      The new channel or NULL, if the named file could not be opened.
 525  *
 526  * Side effects:
 527  *      May open the channel and may cause creation of a file on the
 528  *      file system.
 529  *
 530  *----------------------------------------------------------------------
 531  */
 532
 533 Tcl_Channel
 534 Tcl_OpenFileChannel(interp, fileName, modeString, permissions)
 535     Tcl_Interp *interp;                 /* Interpreter for error reporting;
 536                                          * can be NULL. */
 537     char *fileName;                     /* Name of file to open. */
 538     char *modeString;                   /* A list of POSIX open modes or
 539                                          * a string such as "rw". */
 540     int permissions;                    /* If the open involves creating a
 541                                          * file, with what modes to create
 542                                          * it? */
 543 {
 544     OpenFileChannelProc *openFileChannelProcPtr;
 545     Tcl_Channel retVal = NULL;
 546
 547     /*
 548      * Call each of the "Tcl_OpenFileChannel" function in succession.
 549      * A non-NULL return value indicates the particular function has
 550      * succeeded.
 551      */
 552
 553     Tcl_MutexLock(&hookMutex);
 554     openFileChannelProcPtr = openFileChannelProcList;
 555     while ((retVal == NULL) && (openFileChannelProcPtr != NULL)) {
 556         retVal = (*openFileChannelProcPtr->proc)(interp, fileName,
 557                 modeString, permissions);
 558         openFileChannelProcPtr = openFileChannelProcPtr->nextPtr;
 559     }
 560     Tcl_MutexUnlock(&hookMutex);
 561
 562     return (retVal);
 563 }
 564 \f
 565 /*
 566  *----------------------------------------------------------------------
 567  *
 568  * TclStatInsertProc --
 569  *
 570  *      Insert the passed procedure pointer at the head of the list of
 571  *      functions which are used during a call to 'TclStat(...)'. The
 572  *      passed function should be have exactly like 'TclStat' when called
 573  *      during that time (see 'TclStat(...)' for more informatin).
 574  *      The function will be added even if it already in the list.
 575  *
 576  * Results:
 577  *      Normally TCL_OK; TCL_ERROR if memory for a new node in the list
 578  *      could not be allocated.
 579  *
 580  * Side effects:
 581  *      Memory allocataed and modifies the link list for 'TclStat'
 582  *      functions.
 583  *
 584  *----------------------------------------------------------------------
 585  */
 586
 587 int
 588 TclStatInsertProc (proc)
 589     TclStatProc_ *proc;
 590 {
 591     int retVal = TCL_ERROR;
 592
 593     if (proc != NULL) {
 594         StatProc *newStatProcPtr;
 595
 596         newStatProcPtr = (StatProc *)ckalloc(sizeof(StatProc));
 597
 598         if (newStatProcPtr != NULL) {
 599             newStatProcPtr->proc = proc;
 600             Tcl_MutexLock(&hookMutex);
 601             newStatProcPtr->nextPtr = statProcList;
 602             statProcList = newStatProcPtr;
 603             Tcl_MutexUnlock(&hookMutex);
 604
 605             retVal = TCL_OK;
 606         }
 607     }
 608
 609     return (retVal);
 610 }
 611 \f
 612 /*
 613  *----------------------------------------------------------------------
 614  *
 615  * TclStatDeleteProc --
 616  *
 617  *      Removed the passed function pointer from the list of 'TclStat'
 618  *      functions.  Ensures that the built-in stat function is not
 619  *      removvable.
 620  *
 621  * Results:
 622  *      TCL_OK if the procedure pointer was successfully removed,
 623  *      TCL_ERROR otherwise.
 624  *
 625  * Side effects:
 626  *      Memory is deallocated and the respective list updated.
 627  *
 628  *----------------------------------------------------------------------
 629  */
 630
 631 int
 632 TclStatDeleteProc (proc)
 633     TclStatProc_ *proc;
 634 {
 635     int retVal = TCL_ERROR;
 636     StatProc *tmpStatProcPtr;
 637     StatProc *prevStatProcPtr = NULL;
 638
 639     Tcl_MutexLock(&hookMutex);
 640     tmpStatProcPtr = statProcList;
 641     /*
 642      * Traverse the 'statProcList' looking for the particular node
 643      * whose 'proc' member matches 'proc' and remove that one from
 644      * the list.  Ensure that the "default" node cannot be removed.
 645      */
 646
 647     while ((retVal == TCL_ERROR) && (tmpStatProcPtr != &defaultStatProc)) {
 648         if (tmpStatProcPtr->proc == proc) {
 649             if (prevStatProcPtr == NULL) {
 650                 statProcList = tmpStatProcPtr->nextPtr;
 651             } else {
 652                 prevStatProcPtr->nextPtr = tmpStatProcPtr->nextPtr;
 653             }
 654
 655             Tcl_Free((char *)tmpStatProcPtr);
 656
 657             retVal = TCL_OK;
 658         } else {
 659             prevStatProcPtr = tmpStatProcPtr;
 660             tmpStatProcPtr = tmpStatProcPtr->nextPtr;
 661         }
 662     }
 663
 664     Tcl_MutexUnlock(&hookMutex);
 665     return (retVal);
 666 }
 667 \f
 668 /*
 669  *----------------------------------------------------------------------
 670  *
 671  * TclAccessInsertProc --
 672  *
 673  *      Insert the passed procedure pointer at the head of the list of
 674  *      functions which are used during a call to 'TclAccess(...)'. The
 675  *      passed function should be have exactly like 'TclAccess' when
 676  *      called during that time (see 'TclAccess(...)' for more informatin).
 677  *      The function will be added even if it already in the list.
 678  *
 679  * Results:
 680  *      Normally TCL_OK; TCL_ERROR if memory for a new node in the list
 681  *      could not be allocated.
 682  *
 683  * Side effects:
 684  *      Memory allocataed and modifies the link list for 'TclAccess'
 685  *      functions.
 686  *
 687  *----------------------------------------------------------------------
 688  */
 689
 690 int
 691 TclAccessInsertProc(proc)
 692     TclAccessProc_ *proc;
 693 {
 694     int retVal = TCL_ERROR;
 695
 696     if (proc != NULL) {
 697         AccessProc *newAccessProcPtr;
 698
 699         newAccessProcPtr = (AccessProc *)ckalloc(sizeof(AccessProc));
 700
 701         if (newAccessProcPtr != NULL) {
 702             newAccessProcPtr->proc = proc;
 703             Tcl_MutexLock(&hookMutex);
 704             newAccessProcPtr->nextPtr = accessProcList;
 705             accessProcList = newAccessProcPtr;
 706             Tcl_MutexUnlock(&hookMutex);
 707
 708             retVal = TCL_OK;
 709         }
 710     }
 711
 712     return (retVal);
 713 }
 714 \f
 715 /*
 716  *----------------------------------------------------------------------
 717  *
 718  * TclAccessDeleteProc --
 719  *
 720  *      Removed the passed function pointer from the list of 'TclAccess'
 721  *      functions.  Ensures that the built-in access function is not
 722  *      removvable.
 723  *
 724  * Results:
 725  *      TCL_OK if the procedure pointer was successfully removed,
 726  *      TCL_ERROR otherwise.
 727  *
 728  * Side effects:
 729  *      Memory is deallocated and the respective list updated.
 730  *
 731  *----------------------------------------------------------------------
 732  */
 733
 734 int
 735 TclAccessDeleteProc(proc)
 736     TclAccessProc_ *proc;
 737 {
 738     int retVal = TCL_ERROR;
 739     AccessProc *tmpAccessProcPtr;
 740     AccessProc *prevAccessProcPtr = NULL;
 741
 742     /*
 743      * Traverse the 'accessProcList' looking for the particular node
 744      * whose 'proc' member matches 'proc' and remove that one from
 745      * the list.  Ensure that the "default" node cannot be removed.
 746      */
 747
 748     Tcl_MutexLock(&hookMutex);
 749     tmpAccessProcPtr = accessProcList;
 750     while ((retVal == TCL_ERROR) && (tmpAccessProcPtr != &defaultAccessProc)) {
 751         if (tmpAccessProcPtr->proc == proc) {
 752             if (prevAccessProcPtr == NULL) {
 753                 accessProcList = tmpAccessProcPtr->nextPtr;
 754             } else {
 755                 prevAccessProcPtr->nextPtr = tmpAccessProcPtr->nextPtr;
 756             }
 757
 758             Tcl_Free((char *)tmpAccessProcPtr);
 759
 760             retVal = TCL_OK;
 761         } else {
 762             prevAccessProcPtr = tmpAccessProcPtr;
 763             tmpAccessProcPtr = tmpAccessProcPtr->nextPtr;
 764         }
 765     }
 766     Tcl_MutexUnlock(&hookMutex);
 767
 768     return (retVal);
 769 }
 770 \f
 771 /*
 772  *----------------------------------------------------------------------
 773  *
 774  * TclOpenFileChannelInsertProc --
 775  *
 776  *      Insert the passed procedure pointer at the head of the list of
 777  *      functions which are used during a call to
 778  *      'Tcl_OpenFileChannel(...)'. The passed function should be have
 779  *      exactly like 'Tcl_OpenFileChannel' when called during that time
 780  *      (see 'Tcl_OpenFileChannel(...)' for more informatin). The
 781  *      function will be added even if it already in the list.
 782  *
 783  * Results:
 784  *      Normally TCL_OK; TCL_ERROR if memory for a new node in the list
 785  *      could not be allocated.
 786  *
 787  * Side effects:
 788  *      Memory allocataed and modifies the link list for
 789  *      'Tcl_OpenFileChannel' functions.
 790  *
 791  *----------------------------------------------------------------------
 792  */
 793
 794 int
 795 TclOpenFileChannelInsertProc(proc)
 796     TclOpenFileChannelProc_ *proc;
 797 {
 798     int retVal = TCL_ERROR;
 799
 800     if (proc != NULL) {
 801         OpenFileChannelProc *newOpenFileChannelProcPtr;
 802
 803         newOpenFileChannelProcPtr =
 804                 (OpenFileChannelProc *)ckalloc(sizeof(OpenFileChannelProc));
 805
 806         if (newOpenFileChannelProcPtr != NULL) {
 807             newOpenFileChannelProcPtr->proc = proc;
 808             Tcl_MutexLock(&hookMutex);
 809             newOpenFileChannelProcPtr->nextPtr = openFileChannelProcList;
 810             openFileChannelProcList = newOpenFileChannelProcPtr;
 811             Tcl_MutexUnlock(&hookMutex);
 812
 813             retVal = TCL_OK;
 814         }
 815     }
 816
 817     return (retVal);
 818 }
 819 \f
 820 /*
 821  *----------------------------------------------------------------------
 822  *
 823  * TclOpenFileChannelDeleteProc --
 824  *
 825  *      Removed the passed function pointer from the list of
 826  *      'Tcl_OpenFileChannel' functions.  Ensures that the built-in
 827  *      open file channel function is not removvable.
 828  *
 829  * Results:
 830  *      TCL_OK if the procedure pointer was successfully removed,
 831  *      TCL_ERROR otherwise.
 832  *
 833  * Side effects:
 834  *      Memory is deallocated and the respective list updated.
 835  *
 836  *----------------------------------------------------------------------
 837  */
 838
 839 int
 840 TclOpenFileChannelDeleteProc(proc)
 841     TclOpenFileChannelProc_ *proc;
 842 {
 843     int retVal = TCL_ERROR;
 844     OpenFileChannelProc *tmpOpenFileChannelProcPtr = openFileChannelProcList;
 845     OpenFileChannelProc *prevOpenFileChannelProcPtr = NULL;
 846
 847     /*
 848      * Traverse the 'openFileChannelProcList' looking for the particular
 849      * node whose 'proc' member matches 'proc' and remove that one from
 850      * the list.  Ensure that the "default" node cannot be removed.
 851      */
 852
 853     Tcl_MutexLock(&hookMutex);
 854     tmpOpenFileChannelProcPtr = openFileChannelProcList;
 855     while ((retVal == TCL_ERROR) &&
 856             (tmpOpenFileChannelProcPtr != &defaultOpenFileChannelProc)) {
 857         if (tmpOpenFileChannelProcPtr->proc == proc) {
 858             if (prevOpenFileChannelProcPtr == NULL) {
 859                 openFileChannelProcList = tmpOpenFileChannelProcPtr->nextPtr;
 860             } else {
 861                 prevOpenFileChannelProcPtr->nextPtr =
 862                         tmpOpenFileChannelProcPtr->nextPtr;
 863             }
 864
 865             Tcl_Free((char *)tmpOpenFileChannelProcPtr);
 866
 867             retVal = TCL_OK;
 868         } else {
 869             prevOpenFileChannelProcPtr = tmpOpenFileChannelProcPtr;
 870             tmpOpenFileChannelProcPtr = tmpOpenFileChannelProcPtr->nextPtr;
 871         }
 872     }
 873     Tcl_MutexUnlock(&hookMutex);
 874
 875     return (retVal);
 876 }