diff options
| -rw-r--r-- | ChangeLog | 11 | ||||
| -rw-r--r-- | generic/tclIOUtil.c | 492 | ||||
| -rw-r--r-- | generic/tclTest.c | 536 | ||||
| -rw-r--r-- | tests/ioCmd.test | 23 | ||||
| -rw-r--r-- | tests/ioUtil.test | 333 |
5 files changed, 34 insertions, 1361 deletions
@@ -1,9 +1,18 @@ +2008-04-21 Don Porter <dgp@users.sourceforge.net> + + * generic/tclIOUtil.c: Removed all code delimited by + * generic/tclTest.c: USE_OBSOLETE_FS_HOOKS, completing + * tests/ioCmd.test: the deprecation path for these + * tests/ioUtil.test (removed): obsolete interfaces. (Code was active + in Tcl 8.4, present but enabled only by customized compile switch in + Tcl 8.5, and now completely gone for Tcl 8.6). Also removed all tests + relevant only to the removed interfaces. + 2008-04-19 George Peter Staplin <georgeps@xmission.com> * doc/Ensemble.3: Fix a typo: s/defiend/defined/ Thanks to hat0 for spotting this. - 2008-04-16 Daniel Steffen <das@users.sourceforge.net> * generic/tclInt.h: make stubs tables 'static const' and diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index 745ba6b..778eaa6 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -17,7 +17,7 @@ * 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.151 2008/02/27 03:35:49 jenglish Exp $ + * RCS: @(#) $Id: tclIOUtil.c,v 1.152 2008/04/21 16:26:37 dgp Exp $ */ #include "tclInt.h" @@ -245,56 +245,7 @@ Tcl_EvalFile( * support, I suggest all these hooks are removed. */ -#undef USE_OBSOLETE_FS_HOOKS -#ifdef USE_OBSOLETE_FS_HOOKS - -/* - * 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 (obsolete) 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 obsoleteFsHookMutex. - */ - -static StatProc *statProcList = NULL; -static AccessProc *accessProcList = NULL; -static OpenFileChannelProc *openFileChannelProcList = NULL; - -TCL_DECLARE_MUTEX(obsoleteFsHookMutex) - -#endif /* USE_OBSOLETE_FS_HOOKS */ /* * Declare the native filesystem support. These functions should be considered @@ -814,11 +765,6 @@ TclFinalizeFilesystem(void) * filesystem is likely to fail. */ -#ifdef USE_OBSOLETE_FS_HOOKS - statProcList = NULL; - accessProcList = NULL; - openFileChannelProcList = NULL; -#endif #ifdef __WIN32__ TclWinEncodingsCleanup(); #endif @@ -1959,62 +1905,6 @@ Tcl_FSStat( Tcl_StatBuf *buf) /* Filled with results of stat call. */ { const Tcl_Filesystem *fsPtr; -#ifdef USE_OBSOLETE_FS_HOOKS - struct stat oldStyleStatBuffer; - 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(&obsoleteFsHookMutex); - - if (statProcList != NULL) { - StatProc *statProcPtr; - char *path; - Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr); - if (transPtr == NULL) { - path = NULL; - } else { - path = Tcl_GetString(transPtr); - } - - statProcPtr = statProcList; - while ((retVal == -1) && (statProcPtr != NULL)) { - retVal = (*statProcPtr->proc)(path, &oldStyleStatBuffer); - statProcPtr = statProcPtr->nextPtr; - } - if (transPtr != NULL) { - Tcl_DecrRefCount(transPtr); - } - } - - Tcl_MutexUnlock(&obsoleteFsHookMutex); - if (retVal != -1) { - /* - * Note that EOVERFLOW is not a problem here, and these assignments - * should all be widening (if not identity.) - */ - - buf->st_mode = oldStyleStatBuffer.st_mode; - buf->st_ino = oldStyleStatBuffer.st_ino; - buf->st_dev = oldStyleStatBuffer.st_dev; - buf->st_rdev = oldStyleStatBuffer.st_rdev; - buf->st_nlink = oldStyleStatBuffer.st_nlink; - buf->st_uid = oldStyleStatBuffer.st_uid; - buf->st_gid = oldStyleStatBuffer.st_gid; - buf->st_size = Tcl_LongAsWide(oldStyleStatBuffer.st_size); - buf->st_atime = oldStyleStatBuffer.st_atime; - buf->st_mtime = oldStyleStatBuffer.st_mtime; - buf->st_ctime = oldStyleStatBuffer.st_ctime; -#ifdef HAVE_ST_BLOCKS - buf->st_blksize = oldStyleStatBuffer.st_blksize; - buf->st_blocks = Tcl_LongAsWide(oldStyleStatBuffer.st_blocks); -#endif - return retVal; - } -#endif /* USE_OBSOLETE_FS_HOOKS */ fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); if (fsPtr != NULL) { @@ -2090,41 +1980,6 @@ Tcl_FSAccess( int mode) /* Permission setting. */ { const Tcl_Filesystem *fsPtr; -#ifdef USE_OBSOLETE_FS_HOOKS - 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(&obsoleteFsHookMutex); - - if (accessProcList != NULL) { - AccessProc *accessProcPtr; - char *path; - Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr); - if (transPtr == NULL) { - path = NULL; - } else { - path = Tcl_GetString(transPtr); - } - - accessProcPtr = accessProcList; - while ((retVal == -1) && (accessProcPtr != NULL)) { - retVal = (*accessProcPtr->proc)(path, mode); - accessProcPtr = accessProcPtr->nextPtr; - } - if (transPtr != NULL) { - Tcl_DecrRefCount(transPtr); - } - } - - Tcl_MutexUnlock(&obsoleteFsHookMutex); - if (retVal != -1) { - return retVal; - } -#endif /* USE_OBSOLETE_FS_HOOKS */ fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); if (fsPtr != NULL) { @@ -2169,40 +2024,6 @@ Tcl_FSOpenFileChannel( const Tcl_Filesystem *fsPtr; Tcl_Channel retVal = NULL; -#ifdef USE_OBSOLETE_FS_HOOKS - /* - * Call each of the "Tcl_OpenFileChannel" functions in succession. A - * non-NULL return value indicates the particular function has succeeded. - */ - - Tcl_MutexLock(&obsoleteFsHookMutex); - if (openFileChannelProcList != NULL) { - OpenFileChannelProc *openFileChannelProcPtr; - char *path; - Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(interp, pathPtr); - - if (transPtr == NULL) { - path = NULL; - } else { - path = Tcl_GetString(transPtr); - } - - openFileChannelProcPtr = openFileChannelProcList; - - while ((retVal == NULL) && (openFileChannelProcPtr != NULL)) { - retVal = (*openFileChannelProcPtr->proc)(interp, path, - modeString, permissions); - openFileChannelProcPtr = openFileChannelProcPtr->nextPtr; - } - if (transPtr != NULL) { - Tcl_DecrRefCount(transPtr); - } - } - Tcl_MutexUnlock(&obsoleteFsHookMutex); - if (retVal != NULL) { - return retVal; - } -#endif /* USE_OBSOLETE_FS_HOOKS */ /* * We need this just to ensure we return the correct error messages under @@ -4623,317 +4444,6 @@ NativeFilesystemSeparator( return Tcl_NewStringObj(separator,1); } -/* Everything from here on is contained in this obsolete ifdef */ -#ifdef USE_OBSOLETE_FS_HOOKS - -/* - *---------------------------------------------------------------------- - * - * TclStatInsertProc -- - * - * Insert the passed function pointer at the head of the list of - * functions which are used during a call to 'TclStat(...)'. The passed - * function should behave exactly like 'TclStat' when called during that - * time (see 'TclStat(...)' for more information). 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 allocated and modifies the link list for 'TclStat' functions. - * - *---------------------------------------------------------------------- - */ - -int -TclStatInsertProc( - TclStatProc_ *proc) -{ - int retVal = TCL_ERROR; - - if (proc != NULL) { - StatProc *newStatProcPtr; - - newStatProcPtr = (StatProc *)ckalloc(sizeof(StatProc)); - - if (newStatProcPtr != NULL) { - newStatProcPtr->proc = proc; - Tcl_MutexLock(&obsoleteFsHookMutex); - newStatProcPtr->nextPtr = statProcList; - statProcList = newStatProcPtr; - Tcl_MutexUnlock(&obsoleteFsHookMutex); - - 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 removable. - * - * Results: - * TCL_OK if the function pointer was successfully removed, TCL_ERROR - * otherwise. - * - * Side effects: - * Memory is deallocated and the respective list updated. - * - *---------------------------------------------------------------------- - */ - -int -TclStatDeleteProc( - TclStatProc_ *proc) -{ - int retVal = TCL_ERROR; - StatProc *tmpStatProcPtr; - StatProc *prevStatProcPtr = NULL; - - Tcl_MutexLock(&obsoleteFsHookMutex); - 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 != NULL)) { - if (tmpStatProcPtr->proc == proc) { - if (prevStatProcPtr == NULL) { - statProcList = tmpStatProcPtr->nextPtr; - } else { - prevStatProcPtr->nextPtr = tmpStatProcPtr->nextPtr; - } - - ckfree((char *)tmpStatProcPtr); - - retVal = TCL_OK; - } else { - prevStatProcPtr = tmpStatProcPtr; - tmpStatProcPtr = tmpStatProcPtr->nextPtr; - } - } - - Tcl_MutexUnlock(&obsoleteFsHookMutex); - - return retVal; -} - -/* - *---------------------------------------------------------------------- - * - * TclAccessInsertProc -- - * - * Insert the passed function pointer at the head of the list of - * functions which are used during a call to 'TclAccess(...)'. The passed - * function should behave exactly like 'TclAccess' when called during - * that time (see 'TclAccess(...)' for more information). 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 allocated and modifies the link list for 'TclAccess' functions. - * - *---------------------------------------------------------------------- - */ - -int -TclAccessInsertProc( - TclAccessProc_ *proc) -{ - int retVal = TCL_ERROR; - - if (proc != NULL) { - AccessProc *newAccessProcPtr; - - newAccessProcPtr = (AccessProc *)ckalloc(sizeof(AccessProc)); - - if (newAccessProcPtr != NULL) { - newAccessProcPtr->proc = proc; - Tcl_MutexLock(&obsoleteFsHookMutex); - newAccessProcPtr->nextPtr = accessProcList; - accessProcList = newAccessProcPtr; - Tcl_MutexUnlock(&obsoleteFsHookMutex); - - 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 removable. - * - * Results: - * TCL_OK if the function pointer was successfully removed, TCL_ERROR - * otherwise. - * - * Side effects: - * Memory is deallocated and the respective list updated. - * - *---------------------------------------------------------------------- - */ - -int -TclAccessDeleteProc( - 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(&obsoleteFsHookMutex); - tmpAccessProcPtr = accessProcList; - while ((retVal == TCL_ERROR) && (tmpAccessProcPtr != NULL)) { - if (tmpAccessProcPtr->proc == proc) { - if (prevAccessProcPtr == NULL) { - accessProcList = tmpAccessProcPtr->nextPtr; - } else { - prevAccessProcPtr->nextPtr = tmpAccessProcPtr->nextPtr; - } - - ckfree((char *)tmpAccessProcPtr); - - retVal = TCL_OK; - } else { - prevAccessProcPtr = tmpAccessProcPtr; - tmpAccessProcPtr = tmpAccessProcPtr->nextPtr; - } - } - Tcl_MutexUnlock(&obsoleteFsHookMutex); - - return retVal; -} - -/* - *---------------------------------------------------------------------- - * - * TclOpenFileChannelInsertProc -- - * - * Insert the passed function pointer at the head of the list of - * functions which are used during a call to 'Tcl_OpenFileChannel(...)'. - * The passed function should behave exactly like 'Tcl_OpenFileChannel' - * when called during that time (see 'Tcl_OpenFileChannel(...)' for more - * information). 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 allocated and modifies the link list for 'Tcl_OpenFileChannel' - * functions. - * - *---------------------------------------------------------------------- - */ - -int -TclOpenFileChannelInsertProc( - TclOpenFileChannelProc_ *proc) -{ - int retVal = TCL_ERROR; - - if (proc != NULL) { - OpenFileChannelProc *newOpenFileChannelProcPtr; - - newOpenFileChannelProcPtr = (OpenFileChannelProc *) - ckalloc(sizeof(OpenFileChannelProc)); - - newOpenFileChannelProcPtr->proc = proc; - Tcl_MutexLock(&obsoleteFsHookMutex); - newOpenFileChannelProcPtr->nextPtr = openFileChannelProcList; - openFileChannelProcList = newOpenFileChannelProcPtr; - Tcl_MutexUnlock(&obsoleteFsHookMutex); - - 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 removable. - * - * Results: - * TCL_OK if the function pointer was successfully removed, TCL_ERROR - * otherwise. - * - * Side effects: - * Memory is deallocated and the respective list updated. - * - *---------------------------------------------------------------------- - */ - -int -TclOpenFileChannelDeleteProc( - 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. - */ - - Tcl_MutexLock(&obsoleteFsHookMutex); - tmpOpenFileChannelProcPtr = openFileChannelProcList; - while ((retVal == TCL_ERROR) && - (tmpOpenFileChannelProcPtr != NULL)) { - if (tmpOpenFileChannelProcPtr->proc == proc) { - if (prevOpenFileChannelProcPtr == NULL) { - openFileChannelProcList = tmpOpenFileChannelProcPtr->nextPtr; - } else { - prevOpenFileChannelProcPtr->nextPtr = - tmpOpenFileChannelProcPtr->nextPtr; - } - - ckfree((char *) tmpOpenFileChannelProcPtr); - - retVal = TCL_OK; - } else { - prevOpenFileChannelProcPtr = tmpOpenFileChannelProcPtr; - tmpOpenFileChannelProcPtr = tmpOpenFileChannelProcPtr->nextPtr; - } - } - Tcl_MutexUnlock(&obsoleteFsHookMutex); - - return retVal; -} -#endif /* USE_OBSOLETE_FS_HOOKS */ /* * Local Variables: diff --git a/generic/tclTest.c b/generic/tclTest.c index 7f48903..a810a55 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -14,7 +14,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclTest.c,v 1.114 2008/03/14 16:32:52 rmax Exp $ + * RCS: @(#) $Id: tclTest.c,v 1.115 2008/04/21 16:26:38 dgp Exp $ */ #define TCL_TEST @@ -202,36 +202,6 @@ static void ObjTraceDeleteProc(ClientData clientData); static void PrintParse(Tcl_Interp *interp, Tcl_Parse *parsePtr); static void SpecialFree(char *blockPtr); static int StaticInitProc(Tcl_Interp *interp); -#undef USE_OBSOLETE_FS_HOOKS -#ifdef USE_OBSOLETE_FS_HOOKS -static int TestaccessprocCmd(ClientData dummy, - Tcl_Interp *interp, int argc, const char **argv); -static int TestopenfilechannelprocCmd( - ClientData dummy, Tcl_Interp *interp, int argc, - const char **argv); -static int TeststatprocCmd(ClientData dummy, - Tcl_Interp *interp, int argc, const char **argv); -static int PretendTclpAccess(const char *path, int mode); -static int TestAccessProc1(const char *path, int mode); -static int TestAccessProc2(const char *path, int mode); -static int TestAccessProc3(const char *path, int mode); -static Tcl_Channel PretendTclpOpenFileChannel( - Tcl_Interp *interp, const char *fileName, - const char *modeString, int permissions); -static Tcl_Channel TestOpenFileChannelProc1( - Tcl_Interp *interp, const char *fileName, - const char *modeString, int permissions); -static Tcl_Channel TestOpenFileChannelProc2( - Tcl_Interp *interp, const char *fileName, - const char *modeString, int permissions); -static Tcl_Channel TestOpenFileChannelProc3( - Tcl_Interp *interp, const char *fileName, - const char *modeString, int permissions); -static int PretendTclpStat(const char *path, struct stat *buf); -static int TestStatProc1(const char *path, struct stat *buf); -static int TestStatProc2(const char *path, struct stat *buf); -static int TestStatProc3(const char *path, struct stat *buf); -#endif static int TestasyncCmd(ClientData dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestcmdinfoCmd(ClientData dummy, @@ -578,14 +548,6 @@ Tcltest_Init( (ClientData) 0, NULL); Tcl_CreateObjCommand(interp, "testgetindexfromobjstruct", TestGetIndexFromObjStructObjCmd, (ClientData) 0, NULL); -#ifdef USE_OBSOLETE_FS_HOOKS - Tcl_CreateCommand(interp, "testaccessproc", TestaccessprocCmd, (ClientData) 0, - NULL); - Tcl_CreateCommand(interp, "testopenfilechannelproc", - TestopenfilechannelprocCmd, (ClientData) 0, NULL); - Tcl_CreateCommand(interp, "teststatproc", TeststatprocCmd, (ClientData) 0, - NULL); -#endif Tcl_CreateCommand(interp, "testasync", TestasyncCmd, (ClientData) 0, NULL); Tcl_CreateCommand(interp, "testchannel", TestChannelCmd, (ClientData) 0, NULL); @@ -4981,199 +4943,6 @@ TestsaveresultFree( { freeCount++; } -#ifdef USE_OBSOLETE_FS_HOOKS - -/* - *---------------------------------------------------------------------- - * - * TeststatprocCmd -- - * - * Implements the "testTclStatProc" cmd that is used to test the - * 'TclStatInsertProc' & 'TclStatDeleteProc' C Apis. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -TeststatprocCmd( - ClientData dummy, /* Not used. */ - register Tcl_Interp *interp,/* Current interpreter. */ - int argc, /* Number of arguments. */ - const char **argv) /* Argument strings. */ -{ - TclStatProc_ *proc; - int retVal; - - if (argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " option arg\"", NULL); - return TCL_ERROR; - } - - if (strcmp(argv[2], "TclpStat") == 0) { - proc = PretendTclpStat; - } else if (strcmp(argv[2], "TestStatProc1") == 0) { - proc = TestStatProc1; - } else if (strcmp(argv[2], "TestStatProc2") == 0) { - proc = TestStatProc2; - } else if (strcmp(argv[2], "TestStatProc3") == 0) { - proc = TestStatProc3; - } else { - Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": " - "must be TclpStat, " - "TestStatProc1, TestStatProc2, or TestStatProc3", NULL); - return TCL_ERROR; - } - - if (strcmp(argv[1], "insert") == 0) { - if (proc == PretendTclpStat) { - Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": " - "must be " - "TestStatProc1, TestStatProc2, or TestStatProc3", NULL); - return TCL_ERROR; - } - retVal = TclStatInsertProc(proc); - } else if (strcmp(argv[1], "delete") == 0) { - retVal = TclStatDeleteProc(proc); - } else { - Tcl_AppendResult(interp, "bad option \"", argv[1], "\": " - "must be insert or delete", NULL); - return TCL_ERROR; - } - - if (retVal == TCL_ERROR) { - Tcl_AppendResult(interp, "\"", argv[2], "\": " - "could not be ", argv[1], "ed", NULL); - } - - return retVal; -} - -static int -PretendTclpStat( - const char *path, - struct stat *buf) -{ - int ret; - Tcl_Obj *pathPtr = Tcl_NewStringObj(path, -1); -#ifdef TCL_WIDE_INT_IS_LONG - Tcl_IncrRefCount(pathPtr); - ret = TclpObjStat(pathPtr, buf); - Tcl_DecrRefCount(pathPtr); - return ret; -#else /* TCL_WIDE_INT_IS_LONG */ - Tcl_StatBuf realBuf; - Tcl_IncrRefCount(pathPtr); - ret = TclpObjStat(pathPtr, &realBuf); - Tcl_DecrRefCount(pathPtr); - if (ret != -1) { -# define OUT_OF_RANGE(x) \ - (((Tcl_WideInt)(x)) < Tcl_LongAsWide(LONG_MIN) || \ - ((Tcl_WideInt)(x)) > Tcl_LongAsWide(LONG_MAX)) -#if defined(__GNUC__) && __GNUC__ >= 2 -/* - * Workaround gcc warning of "comparison is always false due to limited range of - * data type" in this macro by checking max type size, and when necessary ANDing - * with the complement of ULONG_MAX instead of the comparison: - */ -# define OUT_OF_URANGE(x) \ - ((((Tcl_WideUInt)(~ (__typeof__(x)) 0)) > (Tcl_WideUInt)ULONG_MAX) && \ - (((Tcl_WideUInt)(x)) & ~(Tcl_WideUInt)ULONG_MAX)) -#else -# define OUT_OF_URANGE(x) \ - (((Tcl_WideUInt)(x)) > (Tcl_WideUInt)ULONG_MAX) -#endif - - /* - * Perform the result-buffer overflow check manually. - * - * Note that ino_t/ino64_t is unsigned... - */ - - if (OUT_OF_URANGE(realBuf.st_ino) || OUT_OF_RANGE(realBuf.st_size) -# ifdef HAVE_ST_BLOCKS - || OUT_OF_RANGE(realBuf.st_blocks) -# endif - ) { -# ifdef EOVERFLOW - errno = EOVERFLOW; -# else -# ifdef EFBIG - errno = EFBIG; -# else -# error "what error should be returned for a value out of range?" -# endif -# endif - return -1; - } - -# undef OUT_OF_RANGE -# undef OUT_OF_URANGE - - /* - * Copy across all supported fields, with possible type coercions on - * those fields that change between the normal and lf64 versions of - * the stat structure (on Solaris at least.) This is slow when the - * structure sizes coincide, but that's what you get for mixing - * interfaces... - */ - - buf->st_mode = realBuf.st_mode; - buf->st_ino = (ino_t) realBuf.st_ino; - buf->st_dev = realBuf.st_dev; - buf->st_rdev = realBuf.st_rdev; - buf->st_nlink = realBuf.st_nlink; - buf->st_uid = realBuf.st_uid; - buf->st_gid = realBuf.st_gid; - buf->st_size = (off_t) realBuf.st_size; - buf->st_atime = realBuf.st_atime; - buf->st_mtime = realBuf.st_mtime; - buf->st_ctime = realBuf.st_ctime; -# ifdef HAVE_ST_BLOCKS - buf->st_blksize = realBuf.st_blksize; - buf->st_blocks = (blkcnt_t) realBuf.st_blocks; -# endif - } - return ret; -#endif /* TCL_WIDE_INT_IS_LONG */ -} - -static int -TestStatProc1( - const char *path, - struct stat *buf) -{ - memset(buf, 0, sizeof(struct stat)); - buf->st_size = 1234; - return ((strstr(path, "testStat1%.fil") == NULL) ? -1 : 0); -} - -static int -TestStatProc2( - const char *path, - struct stat *buf) -{ - memset(buf, 0, sizeof(struct stat)); - buf->st_size = 2345; - return ((strstr(path, "testStat2%.fil") == NULL) ? -1 : 0); -} - -static int -TestStatProc3( - const char *path, - struct stat *buf) -{ - memset(buf, 0, sizeof(struct stat)); - buf->st_size = 3456; - return ((strstr(path, "testStat3%.fil") == NULL) ? -1 : 0); -} -#endif /* *---------------------------------------------------------------------- @@ -5291,309 +5060,6 @@ TestexitmainloopCmd( exitMainLoop = 1; return TCL_OK; } -#ifdef USE_OBSOLETE_FS_HOOKS - -/* - *---------------------------------------------------------------------- - * - * TestaccessprocCmd -- - * - * Implements the "testTclAccessProc" cmd that is used to test the - * 'TclAccessInsertProc' & 'TclAccessDeleteProc' C Apis. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -TestaccessprocCmd( - ClientData dummy, /* Not used. */ - register Tcl_Interp *interp,/* Current interpreter. */ - int argc, /* Number of arguments. */ - const char **argv) /* Argument strings. */ -{ - TclAccessProc_ *proc; - int retVal; - - if (argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " option arg\"", NULL); - return TCL_ERROR; - } - - if (strcmp(argv[2], "TclpAccess") == 0) { - proc = PretendTclpAccess; - } else if (strcmp(argv[2], "TestAccessProc1") == 0) { - proc = TestAccessProc1; - } else if (strcmp(argv[2], "TestAccessProc2") == 0) { - proc = TestAccessProc2; - } else if (strcmp(argv[2], "TestAccessProc3") == 0) { - proc = TestAccessProc3; - } else { - Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": " - "must be TclpAccess, " - "TestAccessProc1, TestAccessProc2, or TestAccessProc3", NULL); - return TCL_ERROR; - } - - if (strcmp(argv[1], "insert") == 0) { - if (proc == PretendTclpAccess) { - Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": must be " - "TestAccessProc1, TestAccessProc2, or TestAccessProc3" - NULL); - return TCL_ERROR; - } - retVal = TclAccessInsertProc(proc); - } else if (strcmp(argv[1], "delete") == 0) { - retVal = TclAccessDeleteProc(proc); - } else { - Tcl_AppendResult(interp, "bad option \"", argv[1], "\": " - "must be insert or delete", NULL); - return TCL_ERROR; - } - - if (retVal == TCL_ERROR) { - Tcl_AppendResult(interp, "\"", argv[2], "\": " - "could not be ", argv[1], "ed", NULL); - } - - return retVal; -} - -static int -PretendTclpAccess( - const char *path, - int mode) -{ - int ret; - Tcl_Obj *pathPtr = Tcl_NewStringObj(path, -1); - Tcl_IncrRefCount(pathPtr); - ret = TclpObjAccess(pathPtr, mode); - Tcl_DecrRefCount(pathPtr); - return ret; -} - -static int -TestAccessProc1( - const char *path, - int mode) -{ - return ((strstr(path, "testAccess1%.fil") == NULL) ? -1 : 0); -} - -static int -TestAccessProc2( - const char *path, - int mode) -{ - return ((strstr(path, "testAccess2%.fil") == NULL) ? -1 : 0); -} - -static int -TestAccessProc3( - const char *path, - int mode) -{ - return ((strstr(path, "testAccess3%.fil") == NULL) ? -1 : 0); -} - -/* - *---------------------------------------------------------------------- - * - * TestopenfilechannelprocCmd -- - * - * Implements the "testTclOpenFileChannelProc" cmd that is used to test - * the 'TclOpenFileChannelInsertProc' & 'TclOpenFileChannelDeleteProc' C - * Apis. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -TestopenfilechannelprocCmd( - ClientData dummy, /* Not used. */ - register Tcl_Interp *interp,/* Current interpreter. */ - int argc, /* Number of arguments. */ - const char **argv) /* Argument strings. */ -{ - TclOpenFileChannelProc_ *proc; - int retVal; - - if (argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " option arg\"", NULL); - return TCL_ERROR; - } - - if (strcmp(argv[2], "TclpOpenFileChannel") == 0) { - proc = PretendTclpOpenFileChannel; - } else if (strcmp(argv[2], "TestOpenFileChannelProc1") == 0) { - proc = TestOpenFileChannelProc1; - } else if (strcmp(argv[2], "TestOpenFileChannelProc2") == 0) { - proc = TestOpenFileChannelProc2; - } else if (strcmp(argv[2], "TestOpenFileChannelProc3") == 0) { - proc = TestOpenFileChannelProc3; - } else { - Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": " - "must be TclpOpenFileChannel, " - "TestOpenFileChannelProc1, TestOpenFileChannelProc2, or " - "TestOpenFileChannelProc3", NULL); - return TCL_ERROR; - } - - if (strcmp(argv[1], "insert") == 0) { - if (proc == PretendTclpOpenFileChannel) { - Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": " - "must be " - "TestOpenFileChannelProc1, TestOpenFileChannelProc2, or " - "TestOpenFileChannelProc3", NULL); - return TCL_ERROR; - } - retVal = TclOpenFileChannelInsertProc(proc); - } else if (strcmp(argv[1], "delete") == 0) { - retVal = TclOpenFileChannelDeleteProc(proc); - } else { - Tcl_AppendResult(interp, "bad option \"", argv[1], "\": " - "must be insert or delete", NULL); - return TCL_ERROR; - } - - if (retVal == TCL_ERROR) { - Tcl_AppendResult(interp, "\"", argv[2], "\": " - "could not be ", argv[1], "ed", NULL); - } - - return retVal; -} - -static Tcl_Channel -PretendTclpOpenFileChannel( - Tcl_Interp *interp, /* Interpreter for error reporting; can be - * NULL. */ - const char *fileName, /* Name of file to open. */ - const 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? */ -{ - Tcl_Channel ret; - int mode, seekFlag; - Tcl_Obj *pathPtr; - mode = TclGetOpenMode(interp, modeString, &seekFlag); - if (mode == -1) { - return NULL; - } - pathPtr = Tcl_NewStringObj(fileName, -1); - Tcl_IncrRefCount(pathPtr); - ret = TclpOpenFileChannel(interp, pathPtr, mode, permissions); - Tcl_DecrRefCount(pathPtr); - if (ret != NULL) { - if (seekFlag) { - if (Tcl_Seek(ret, (Tcl_WideInt)0, SEEK_END) < (Tcl_WideInt)0) { - if (interp != NULL) { - Tcl_AppendResult(interp, - "could not seek to end of file while opening \"", - fileName, "\": ", Tcl_PosixError(interp), NULL); - } - Tcl_Close(NULL, ret); - return NULL; - } - } - } - return ret; -} - -static Tcl_Channel -TestOpenFileChannelProc1( - Tcl_Interp *interp, /* Interpreter for error reporting; can be - * NULL. */ - const char *fileName, /* Name of file to open. */ - const 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? */ -{ - const char *expectname = "testOpenFileChannel1%.fil"; - Tcl_DString ds; - - Tcl_DStringInit(&ds); - Tcl_JoinPath(1, &expectname, &ds); - - if (!strcmp(Tcl_DStringValue(&ds), fileName)) { - Tcl_DStringFree(&ds); - return (PretendTclpOpenFileChannel(interp, - "__testOpenFileChannel1%__.fil", - modeString, permissions)); - } else { - Tcl_DStringFree(&ds); - return NULL; - } -} - -static Tcl_Channel -TestOpenFileChannelProc2( - Tcl_Interp *interp, /* Interpreter for error reporting; can be - * NULL. */ - const char *fileName, /* Name of file to open. */ - const 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? */ -{ - const char *expectname = "testOpenFileChannel2%.fil"; - Tcl_DString ds; - - Tcl_DStringInit(&ds); - Tcl_JoinPath(1, &expectname, &ds); - - if (!strcmp(Tcl_DStringValue(&ds), fileName)) { - Tcl_DStringFree(&ds); - return (PretendTclpOpenFileChannel(interp, - "__testOpenFileChannel2%__.fil", - modeString, permissions)); - } else { - Tcl_DStringFree(&ds); - return (NULL); - } -} - -static Tcl_Channel -TestOpenFileChannelProc3( - Tcl_Interp *interp, /* Interpreter for error reporting; can be - * NULL. */ - const char *fileName, /* Name of file to open. */ - const 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? */ -{ - const char *expectname = "testOpenFileChannel3%.fil"; - Tcl_DString ds; - - Tcl_DStringInit(&ds); - Tcl_JoinPath(1, &expectname, &ds); - - if (!strcmp(Tcl_DStringValue(&ds), fileName)) { - Tcl_DStringFree(&ds); - return (PretendTclpOpenFileChannel(interp, "__testOpenFileChannel3%__.fil", - modeString, permissions)); - } else { - Tcl_DStringFree(&ds); - return (NULL); - } -} -#endif /* *---------------------------------------------------------------------- diff --git a/tests/ioCmd.test b/tests/ioCmd.test index c3bde34..5a0d1ba 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -13,7 +13,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: ioCmd.test,v 1.40 2008/04/10 20:58:59 andreas_kupries Exp $ +# RCS: @(#) $Id: ioCmd.test,v 1.41 2008/04/21 16:26:39 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -526,6 +526,27 @@ test iocmd-13.10.2 {open for append, O_APPEND} -setup { # Ensure that channels are gone, even if body failed to do so foreach ch $chans {catch {close $ch}} } -result {0 1 2 3 4 5 6 7 8 9} +test ioCmd-13.11 {open ... a+ must not use O_APPEND: Bug 1773127} -setup { + set f [makeFile {} ioutil41.tmp] + set fid [open $f wb] + puts -nonewline $fid 123 + close $fid +} -body { + set fid [open $f ab+] + puts -nonewline $fid 456 + seek $fid 2 + set d [read $fid 2] + seek $fid 4 + puts -nonewline $fid x + close $fid + set fid [open $f rb] + append d [read $fid] + close $fid + return $d +} -cleanup { + removeFile $f +} -result 341234x6 + test iocmd-14.1 {file id parsing errors} { list [catch {eof gorp} msg] $msg $::errorCode diff --git a/tests/ioUtil.test b/tests/ioUtil.test deleted file mode 100644 index 0f0d2fc..0000000 --- a/tests/ioUtil.test +++ /dev/null @@ -1,333 +0,0 @@ -# This file (ioUtil.test) tests the hookable TclStat(), TclAccess(), -# and Tcl_OpenFileChannel, routines in the file generic/tclIOUtils.c. -# Sourcing this file into Tcl runs the tests and generates output for -# errors. No output means no errors were found. -# -# Copyright (c) 1998-1999 by Scriptics Corporation. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: ioUtil.test,v 1.19 2007/12/13 15:26:06 dgp Exp $ - -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 - namespace import -force ::tcltest::* -} - -testConstraint testopenfilechannelproc \ - [llength [info commands testopenfilechannelproc]] -testConstraint testaccessproc [llength [info commands testaccessproc]] -testConstraint teststatproc [llength [info commands teststatproc]] - -set unsetScript { - catch {unset testStat1(size)} - catch {unset testStat2(size)} - catch {unset testStat3(size)} -} - -test ioUtil-1.1 {TclStat: Check that none of the test procs are there.} {} { - catch {file stat testStat1%.fil testStat1} err1 - catch {file stat testStat2%.fil testStat2} err2 - catch {file stat testStat3%.fil testStat3} err3 - list $err1 $err2 $err3 -} {{could not read "testStat1%.fil": no such file or directory} {could not read "testStat2%.fil": no such file or directory} {could not read "testStat3%.fil": no such file or directory}} - -test ioUtil-1.2 {TclStatInsertProc: Insert the 3 test TclStat_ procedures.} {teststatproc} { - catch {teststatproc insert TclpStat} err1 - teststatproc insert TestStatProc1 - teststatproc insert TestStatProc2 - teststatproc insert TestStatProc3 - set err1 -} {bad arg "insert": must be TestStatProc1, TestStatProc2, or TestStatProc3} - -test ioUtil-1.3 {TclStat: Use "file stat ?" to invoke each procedure.} {teststatproc} { - file stat testStat2%.fil testStat2 - file stat testStat1%.fil testStat1 - file stat testStat3%.fil testStat3 - - list $testStat2(size) $testStat1(size) $testStat3(size) -} {2345 1234 3456} - -eval $unsetScript - -test ioUtil-1.4 {TclStatDeleteProc: "TclpStat" function should not be deletable.} {teststatproc} { - catch {teststatproc delete TclpStat} err2 - set err2 -} {"TclpStat": could not be deleteed} - -test ioUtil-1.5 {TclStatDeleteProc: Delete the 2nd TclStat procedure.} {teststatproc} { - # Delete the 2nd procedure and test that it longer exists but that - # the others do actually return a result. - - teststatproc delete TestStatProc2 - file stat testStat1%.fil testStat1 - catch {file stat testStat2%.fil testStat2} err3 - file stat testStat3%.fil testStat3 - - list $testStat1(size) $err3 $testStat3(size) -} {1234 {could not read "testStat2%.fil": no such file or directory} 3456} - -eval $unsetScript - -test ioUtil-1.6 {TclStatDeleteProc: Delete the 1st TclStat procedure.} {teststatproc} { - # Next delete the 1st procedure and test that only the 3rd procedure - # is the only one that exists. - - teststatproc delete TestStatProc1 - catch {file stat testStat1%.fil testStat1} err4 - catch {file stat testStat2%.fil testStat2} err5 - file stat testStat3%.fil testStat3 - - list $err4 $err5 $testStat3(size) -} {{could not read "testStat1%.fil": no such file or directory} {could not read "testStat2%.fil": no such file or directory} 3456} - -eval $unsetScript - -test ioUtil-1.7 {TclStatDeleteProc: Delete the 3rd procedure & verify all are gone.} {teststatproc} { - # Finally delete the 3rd procedure and check that none of the - # procedures exist. - - teststatproc delete TestStatProc3 - catch {file stat testStat1%.fil testStat1} err6 - catch {file stat testStat2%.fil testStat2} err7 - catch {file stat testStat3%.fil testStat3} err8 - - list $err6 $err7 $err8 -} {{could not read "testStat1%.fil": no such file or directory} {could not read "testStat2%.fil": no such file or directory} {could not read "testStat3%.fil": no such file or directory}} - -eval $unsetScript - -test ioUtil-1.8 {TclStatDeleteProc: Verify that all procs have been deleted.} {teststatproc} { - # Attempt to delete all the Stat procs. again to ensure they no longer - # exist and an error is returned. - - catch {teststatproc delete TestStatProc1} err9 - catch {teststatproc delete TestStatProc2} err10 - catch {teststatproc delete TestStatProc3} err11 - - list $err9 $err10 $err11 -} {{"TestStatProc1": could not be deleteed} {"TestStatProc2": could not be deleteed} {"TestStatProc3": could not be deleteed}} - -eval $unsetScript - -test ioUtil-1.9 {TclAccess: Check that none of the test procs are there.} { - catch {file exists testAccess1%.fil} err1 - catch {file exists testAccess2%.fil} err2 - catch {file exists testAccess3%.fil} err3 - list $err1 $err2 $err3 -} {0 0 0} - -test ioUtil-1.10 {TclAccessInsertProc: Insert the 3 test TclAccess_ procedures.} {testaccessproc} { - catch {testaccessproc insert TclpAccess} err1 - testaccessproc insert TestAccessProc1 - testaccessproc insert TestAccessProc2 - testaccessproc insert TestAccessProc3 - set err1 -} {bad arg "insert": must be TestAccessProc1, TestAccessProc2, or TestAccessProc3} - -test ioUtil-2.3 {TclAccess: Use "file access ?" to invoke each procedure.} {testaccessproc} { - list [file exists testAccess2%.fil] \ - [file exists testAccess1%.fil] \ - [file exists testAccess3%.fil] -} {1 1 1} - -test ioUtil-2.4 {TclAccessDeleteProc: "TclpAccess" function should not be deletable.} {testaccessproc} { - catch {testaccessproc delete TclpAccess} err2 - set err2 -} {"TclpAccess": could not be deleteed} - -test ioUtil-2.5 {TclAccessDeleteProc: Delete the 2nd TclAccess procedure.} {testaccessproc} { - # Delete the 2nd procedure and test that it longer exists but that - # the others do actually return a result. - - testaccessproc delete TestAccessProc2 - set res1 [file exists testAccess1%.fil] - catch {file exists testAccess2%.fil} err3 - set res2 [file exists testAccess3%.fil] - - list $res1 $err3 $res2 -} {1 0 1} - -test ioUtil-2.6 {TclAccessDeleteProc: Delete the 1st TclAccess procedure.} {testaccessproc} { - # Next delete the 1st procedure and test that only the 3rd procedure - # is the only one that exists. - - testaccessproc delete TestAccessProc1 - catch {file exists testAccess1%.fil} err4 - catch {file exists testAccess2%.fil} err5 - set res3 [file exists testAccess3%.fil] - - list $err4 $err5 $res3 -} {0 0 1} - -test ioUtil-2.7 {TclAccessDeleteProc: Delete the 3rd procedure & verify all are gone.} {testaccessproc} { - # Finally delete the 3rd procedure and check that none of the - # procedures exist. - - testaccessproc delete TestAccessProc3 - catch {file exists testAccess1%.fil} err6 - catch {file exists testAccess2%.fil} err7 - catch {file exists testAccess3%.fil} err8 - - list $err6 $err7 $err8 -} {0 0 0} - -test ioUtil-2.8 {TclAccessDeleteProc: Verify that all procs have been deleted.} {testaccessproc} { - # Attempt to delete all the Access procs. again to ensure they no longer - # exist and an error is returned. - - catch {testaccessproc delete TestAccessProc1} err9 - catch {testaccessproc delete TestAccessProc2} err10 - catch {testaccessproc delete TestAccessProc3} err11 - - list $err9 $err10 $err11 -} {{"TestAccessProc1": could not be deleteed} {"TestAccessProc2": could not be deleteed} {"TestAccessProc3": could not be deleteed}} - -# Some of the following tests require a writable current directory -set oldpwd [pwd] -cd [temporaryDirectory] - -test ioUtil-3.1 {TclOpenFileChannel: Check that none of the test procs are there.} {testopenfilechannelproc} { - catch {file delete -force {*}[glob *testOpenFileChannel*]} - catch {file exists testOpenFileChannel1%.fil} err1 - catch {file exists testOpenFileChannel2%.fil} err2 - catch {file exists testOpenFileChannel3%.fil} err3 - catch {file exists __testOpenFileChannel1%__.fil} err4 - catch {file exists __testOpenFileChannel2%__.fil} err5 - catch {file exists __testOpenFileChannel3%__.fil} err6 - list $err1 $err2 $err3 $err4 $err5 $err6 -} {0 0 0 0 0 0} - -test ioUtil-3.2 {TclOpenFileChannelInsertProc: Insert the 3 test TclOpenFileChannel_ procedures.} {testopenfilechannelproc} { - catch {testopenfilechannelproc insert TclpOpenFileChannel} err1 - testopenfilechannelproc insert TestOpenFileChannelProc1 - testopenfilechannelproc insert TestOpenFileChannelProc2 - testopenfilechannelproc insert TestOpenFileChannelProc3 - set err1 -} {bad arg "insert": must be TestOpenFileChannelProc1, TestOpenFileChannelProc2, or TestOpenFileChannelProc3} - -test ioUtil-3.3 {TclOpenFileChannel: Use "file openfilechannel ?" to invoke each procedure.} {testopenfilechannelproc} { - close [open __testOpenFileChannel1%__.fil w] - close [open __testOpenFileChannel2%__.fil w] - close [open __testOpenFileChannel3%__.fil w] - - catch { - close [open testOpenFileChannel1%.fil r] - close [open testOpenFileChannel2%.fil r] - close [open testOpenFileChannel3%.fil r] - } err - - file delete __testOpenFileChannel1%__.fil - file delete __testOpenFileChannel2%__.fil - file delete __testOpenFileChannel3%__.fil - - set err -} {} - -test ioUtil-3.4 {TclOpenFileChannelDeleteProc: "TclpOpenFileChannel" function should not be deletable.} {testopenfilechannelproc} { - catch {testopenfilechannelproc delete TclpOpenFileChannel} err2 - set err2 -} {"TclpOpenFileChannel": could not be deleteed} - -test ioUtil-3.5 {TclOpenFileChannelDeleteProc: Delete the 2nd TclOpenFileChannel procedure.} {testopenfilechannelproc} { - # Delete the 2nd procedure and test that it longer exists but that - # the others do actually return a result. - - testopenfilechannelproc delete TestOpenFileChannelProc2 - - close [open __testOpenFileChannel1%__.fil w] - close [open __testOpenFileChannel3%__.fil w] - - catch { - close [open testOpenFileChannel1%.fil r] - catch {close [open testOpenFileChannel2%.fil r]} msg1 - close [open testOpenFileChannel3%.fil r] - } err3 - - file delete __testOpenFileChannel1%__.fil - file delete __testOpenFileChannel3%__.fil - - list $err3 $msg1 -} {{} {couldn't open "testOpenFileChannel2%.fil": no such file or directory}} - -test ioUtil-3.6 {TclOpenFileChannelDeleteProc: Delete the 1st TclOpenFileChannel procedure.} {testopenfilechannelproc} { - # Next delete the 1st procedure and test that only the 3rd procedure - # is the only one that exists. - - testopenfilechannelproc delete TestOpenFileChannelProc1 - - close [open __testOpenFileChannel3%__.fil w] - - catch { - catch {close [open testOpenFileChannel1%.fil r]} msg2 - catch {close [open testOpenFileChannel2%.fil r]} msg3 - close [open testOpenFileChannel3%.fil r] - } err4 - - file delete __testOpenFileChannel3%__.fil - - list $err4 $msg2 $msg3 -} [list {} \ - {couldn't open "testOpenFileChannel1%.fil": no such file or directory}\ - {couldn't open "testOpenFileChannel2%.fil": no such file or directory}] - -test ioUtil-3.7 {TclOpenFileChannelDeleteProc: Delete the 3rd procedure & verify all are gone.} {testopenfilechannelproc} { - # Finally delete the 3rd procedure and check that none of the - # procedures exist. - - testopenfilechannelproc delete TestOpenFileChannelProc3 - catch { - catch {close [open testOpenFileChannel1%.fil r]} msg4 - catch {close [open testOpenFileChannel2%.fil r]} msg5 - catch {close [open testOpenFileChannel3%.fil r]} msg6 - } err5 - - list $err5 $msg4 $msg5 $msg6 -} [list 1 \ - {couldn't open "testOpenFileChannel1%.fil": no such file or directory}\ - {couldn't open "testOpenFileChannel2%.fil": no such file or directory}\ - {couldn't open "testOpenFileChannel3%.fil": no such file or directory}] - -test ioUtil-3.8 {TclOpenFileChannelDeleteProc: Verify that all procs have been deleted.} {testopenfilechannelproc} { - - # Attempt to delete all the OpenFileChannel procs. again to ensure they no - # longer exist and an error is returned. - - catch {testopenfilechannelproc delete TestOpenFileChannelProc1} err9 - catch {testopenfilechannelproc delete TestOpenFileChannelProc2} err10 - catch {testopenfilechannelproc delete TestOpenFileChannelProc3} err11 - - list $err9 $err10 $err11 -} {{"TestOpenFileChannelProc1": could not be deleteed} {"TestOpenFileChannelProc2": could not be deleteed} {"TestOpenFileChannelProc3": could not be deleteed}} - -test ioUtil-4.1 {open ... a+ must not use O_APPEND: Bug 1773127} -setup { - set f [tcltest::makeFile {} ioutil41.tmp] - set fid [open $f wb] - puts -nonewline $fid 123 - close $fid -} -body { - set fid [open $f ab+] - puts -nonewline $fid 456 - seek $fid 2 - set d [read $fid 2] - seek $fid 4 - puts -nonewline $fid x - close $fid - set fid [open $f rb] - append d [read $fid] - close $fid - return $d -} -cleanup { - tcltest::removeFile $f -} -result 341234x6 - -cd $oldpwd - -# cleanup -::tcltest::cleanupTests -return - -# Local Variables: -# mode: tcl -# End: |