From 7346f5c47fd9b46f12a26714b5dde16148a5b932 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 21 Apr 2008 16:26:36 +0000 Subject: * 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. --- ChangeLog | 11 +- generic/tclIOUtil.c | 492 +---------------------------------------------- generic/tclTest.c | 536 +--------------------------------------------------- tests/ioCmd.test | 23 ++- tests/ioUtil.test | 333 -------------------------------- 5 files changed, 34 insertions(+), 1361 deletions(-) delete mode 100644 tests/ioUtil.test diff --git a/ChangeLog b/ChangeLog index aeb57e6..cc7b769 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,9 +1,18 @@ +2008-04-21 Don Porter + + * 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 * doc/Ensemble.3: Fix a typo: s/defiend/defined/ Thanks to hat0 for spotting this. - 2008-04-16 Daniel Steffen * 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: -- cgit v0.12