diff options
Diffstat (limited to 'generic/tclTest.c')
| -rw-r--r-- | generic/tclTest.c | 5067 |
1 files changed, 2682 insertions, 2385 deletions
diff --git a/generic/tclTest.c b/generic/tclTest.c index db8d558..a27c95a 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -13,12 +13,15 @@ * * 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.100 2005/12/15 04:08:33 das Exp $ */ -#define TCL_TEST +#undef STATIC_BUILD +#ifndef USE_TCL_STUBS +# define USE_TCL_STUBS +#endif #include "tclInt.h" +#include "tclOO.h" +#include <math.h> /* * Required for Testregexp*Cmd @@ -40,6 +43,17 @@ */ /* + * TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the + * Tcltest_Init declaration is in the source file itself, which is only + * accessed when we are building a library. + */ + +#undef TCL_STORAGE_CLASS +#define TCL_STORAGE_CLASS DLLEXPORT +EXTERN int Tcltest_Init(Tcl_Interp *interp); +EXTERN int Tcltest_SafeInit(Tcl_Interp *interp); + +/* * Dynamic string shared by TestdcallCmd and DelCallbackProc; used to collect * the results of the various deletion callbacks. */ @@ -53,13 +67,16 @@ static Tcl_Interp *delInterp; */ typedef struct TestAsyncHandler { - int id; /* Identifier for this handler. */ - Tcl_AsyncHandler handler; /* Tcl's token for the handler. */ - char *command; /* Command to invoke when the handler - * is invoked. */ - struct TestAsyncHandler *nextPtr; /* Next is list of handlers. */ + int id; /* Identifier for this handler. */ + Tcl_AsyncHandler handler; /* Tcl's token for the handler. */ + char *command; /* Command to invoke when the handler is + * invoked. */ + struct TestAsyncHandler *nextPtr; + /* Next is list of handlers. */ } TestAsyncHandler; +TCL_DECLARE_MUTEX(asyncTestMutex) + static TestAsyncHandler *firstHandler = NULL; /* @@ -83,8 +100,8 @@ static Tcl_Trace cmdTrace; typedef struct DelCmd { Tcl_Interp *interp; /* Interpreter in which command exists. */ - char *deleteCmd; /* Script to execute when command is - * deleted. Malloc'ed. */ + char *deleteCmd; /* Script to execute when command is deleted. + * Malloc'ed. */ } DelCmd; /* @@ -117,30 +134,27 @@ static int exitMainLoop = 0; typedef struct TestEvent { Tcl_Event header; /* Header common to all events */ - Tcl_Interp* interp; /* Interpreter that will handle the event */ - Tcl_Obj* command; /* Command to evaluate when the event occurs */ - Tcl_Obj* tag; /* Tag for this event used to delete it */ + Tcl_Interp *interp; /* Interpreter that will handle the event */ + Tcl_Obj *command; /* Command to evaluate when the event occurs */ + Tcl_Obj *tag; /* Tag for this event used to delete it */ } TestEvent; - /* * Simple detach/attach facility for testchannel cut|splice. Allow testing of * channel transfer in core testsuite. */ typedef struct TestChannel { - Tcl_Channel chan; /* Detached channel */ - struct TestChannel* nextPtr; /* Next in pool of detached channels */ + Tcl_Channel chan; /* Detached channel */ + struct TestChannel *nextPtr;/* Next in detached channel pool */ } TestChannel; -static TestChannel* firstDetached; - +static TestChannel *firstDetached; /* * Forward declarations for procedures defined later in this file: */ -int Tcltest_Init(Tcl_Interp *interp); static int AsyncHandlerProc(ClientData clientData, Tcl_Interp *interp, int code); #ifdef TCL_THREADS @@ -151,138 +165,135 @@ static void CleanupTestSetassocdataTests( static void CmdDelProc1(ClientData clientData); static void CmdDelProc2(ClientData clientData); static int CmdProc1(ClientData clientData, - Tcl_Interp *interp, int argc, CONST char **argv); + Tcl_Interp *interp, int argc, const char **argv); static int CmdProc2(ClientData clientData, - Tcl_Interp *interp, int argc, CONST char **argv); + Tcl_Interp *interp, int argc, const char **argv); static void CmdTraceDeleteProc( ClientData clientData, Tcl_Interp *interp, int level, char *command, Tcl_CmdProc *cmdProc, ClientData cmdClientData, int argc, - char **argv); + const char *argv[]); static void CmdTraceProc(ClientData clientData, Tcl_Interp *interp, int level, char *command, Tcl_CmdProc *cmdProc, ClientData cmdClientData, - int argc, char **argv); + int argc, const char *argv[]); static int CreatedCommandProc( ClientData clientData, Tcl_Interp *interp, - int argc, CONST char **argv); + int argc, const char **argv); static int CreatedCommandProc2( ClientData clientData, Tcl_Interp *interp, - int argc, CONST char **argv); + int argc, const char **argv); static void DelCallbackProc(ClientData clientData, Tcl_Interp *interp); static int DelCmdProc(ClientData clientData, - Tcl_Interp *interp, int argc, CONST char **argv); + Tcl_Interp *interp, int argc, const char **argv); static void DelDeleteProc(ClientData clientData); static void EncodingFreeProc(ClientData clientData); static int EncodingToUtfProc(ClientData clientData, - CONST char *src, int srcLen, int flags, + const char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); static int EncodingFromUtfProc(ClientData clientData, - CONST char *src, int srcLen, int flags, + const char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); static void ExitProcEven(ClientData clientData); static void ExitProcOdd(ClientData clientData); -static int GetTimesCmd(ClientData clientData, - Tcl_Interp *interp, int argc, CONST char **argv); +static int GetTimesCmd(ClientData clientData, + Tcl_Interp *interp, int argc, const char **argv); static void MainLoop(void); -static int NoopCmd(ClientData clientData, - Tcl_Interp *interp, int argc, CONST char **argv); -static int NoopObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[]); +static int NoopCmd(ClientData clientData, + Tcl_Interp *interp, int argc, const char **argv); +static int NoopObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); static int ObjTraceProc(ClientData clientData, - Tcl_Interp* interp, int level, CONST char* command, + Tcl_Interp *interp, int level, const char *command, Tcl_Command commandToken, int objc, - Tcl_Obj *CONST objv[]); + Tcl_Obj *const objv[]); 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); -static int TestaccessprocCmd(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 int TestasyncCmd(ClientData dummy, - Tcl_Interp *interp, int argc, CONST char **argv); + Tcl_Interp *interp, int argc, const char **argv); static int TestcmdinfoCmd(ClientData dummy, - Tcl_Interp *interp, int argc, CONST char **argv); + Tcl_Interp *interp, int argc, const char **argv); static int TestcmdtokenCmd(ClientData dummy, - Tcl_Interp *interp, int argc, CONST char **argv); + Tcl_Interp *interp, int argc, const char **argv); static int TestcmdtraceCmd(ClientData dummy, - Tcl_Interp *interp, int argc, CONST char **argv); -static int TestchmodCmd(ClientData dummy, - Tcl_Interp *interp, int argc, CONST char **argv); + Tcl_Interp *interp, int argc, const char **argv); +static int TestconcatobjCmd(ClientData dummy, + Tcl_Interp *interp, int argc, const char **argv); static int TestcreatecommandCmd(ClientData dummy, - Tcl_Interp *interp, int argc, CONST char **argv); + Tcl_Interp *interp, int argc, const char **argv); static int TestdcallCmd(ClientData dummy, - Tcl_Interp *interp, int argc, CONST char **argv); + Tcl_Interp *interp, int argc, const char **argv); static int TestdelCmd(ClientData dummy, - Tcl_Interp *interp, int argc, CONST char **argv); + Tcl_Interp *interp, int argc, const char **argv); static int TestdelassocdataCmd(ClientData dummy, - Tcl_Interp *interp, int argc, CONST char **argv); + Tcl_Interp *interp, int argc, const char **argv); +static int TestdoubledigitsObjCmd(ClientData dummy, + Tcl_Interp* interp, + int objc, Tcl_Obj* const objv[]); static int TestdstringCmd(ClientData dummy, - Tcl_Interp *interp, int argc, CONST char **argv); + Tcl_Interp *interp, int argc, const char **argv); static int TestencodingObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[]); + Tcl_Obj *const objv[]); static int TestevalexObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[]); + Tcl_Obj *const objv[]); static int TestevalobjvObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[]); + Tcl_Obj *const objv[]); static int TesteventObjCmd(ClientData unused, - Tcl_Interp* interp, int argc, - Tcl_Obj *CONST objv[]); -static int TesteventProc(Tcl_Event* event, int flags); -static int TesteventDeleteProc(Tcl_Event* event, + Tcl_Interp *interp, int argc, + Tcl_Obj *const objv[]); +static int TesteventProc(Tcl_Event *event, int flags); +static int TesteventDeleteProc(Tcl_Event *event, ClientData clientData); static int TestexithandlerCmd(ClientData dummy, - Tcl_Interp *interp, int argc, CONST char **argv); + Tcl_Interp *interp, int argc, const char **argv); static int TestexprlongCmd(ClientData dummy, - Tcl_Interp *interp, int argc, CONST char **argv); + Tcl_Interp *interp, int argc, const char **argv); static int TestexprlongobjCmd(ClientData dummy, Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[]); + Tcl_Obj *const objv[]); static int TestexprdoubleCmd(ClientData dummy, - Tcl_Interp *interp, int argc, CONST char **argv); + Tcl_Interp *interp, int argc, const char **argv); static int TestexprdoubleobjCmd(ClientData dummy, Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[]); + Tcl_Obj *const objv[]); static int TestexprparserObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[]); + Tcl_Obj *const objv[]); static int TestexprstringCmd(ClientData dummy, - Tcl_Interp *interp, int argc, CONST char **argv); + Tcl_Interp *interp, int argc, const char **argv); static int TestfileCmd(ClientData dummy, - Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); + Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int TestfilelinkCmd(ClientData dummy, - Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); + Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int TestfeventCmd(ClientData dummy, - Tcl_Interp *interp, int argc, CONST char **argv); + Tcl_Interp *interp, int argc, const char **argv); static int TestgetassocdataCmd(ClientData dummy, - Tcl_Interp *interp, int argc, CONST char **argv); + Tcl_Interp *interp, int argc, const char **argv); static int TestgetintCmd(ClientData dummy, - Tcl_Interp *interp, int argc, CONST char **argv); + Tcl_Interp *interp, int argc, const char **argv); static int TestgetplatformCmd(ClientData dummy, - Tcl_Interp *interp, int argc, CONST char **argv); + Tcl_Interp *interp, int argc, const char **argv); static int TestgetvarfullnameCmd( ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[]); + int objc, Tcl_Obj *const objv[]); static int TestinterpdeleteCmd(ClientData dummy, - Tcl_Interp *interp, int argc, CONST char **argv); + Tcl_Interp *interp, int argc, const char **argv); static int TestlinkCmd(ClientData dummy, - Tcl_Interp *interp, int argc, CONST char **argv); + Tcl_Interp *interp, int argc, const char **argv); static int TestlocaleCmd(ClientData dummy, Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[]); + Tcl_Obj *const objv[]); static int TestMathFunc(ClientData clientData, Tcl_Interp *interp, Tcl_Value *args, Tcl_Value *resultPtr); @@ -290,190 +301,164 @@ static int TestMathFunc2(ClientData clientData, Tcl_Interp *interp, Tcl_Value *args, Tcl_Value *resultPtr); static int TestmainthreadCmd(ClientData dummy, - Tcl_Interp *interp, int argc, CONST char **argv); + Tcl_Interp *interp, int argc, const char **argv); static int TestsetmainloopCmd(ClientData dummy, - Tcl_Interp *interp, int argc, CONST char **argv); + Tcl_Interp *interp, int argc, const char **argv); static int TestexitmainloopCmd(ClientData dummy, - Tcl_Interp *interp, int argc, CONST char **argv); -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); + Tcl_Interp *interp, int argc, const char **argv); static int TestpanicCmd(ClientData dummy, - Tcl_Interp *interp, int argc, CONST char **argv); + Tcl_Interp *interp, int argc, const char **argv); +static int TestparseargsCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); static int TestparserObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[]); + Tcl_Obj *const objv[]); static int TestparsevarObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[]); + Tcl_Obj *const objv[]); static int TestparsevarnameObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[]); + Tcl_Obj *const objv[]); static int TestregexpObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[]); + Tcl_Obj *const objv[]); static int TestreturnObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[]); -static void TestregexpXflags(char *string, + Tcl_Obj *const objv[]); +static void TestregexpXflags(const char *string, int length, int *cflagsPtr, int *eflagsPtr); +#ifndef TCL_NO_DEPRECATED static int TestsaveresultCmd(ClientData dummy, Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[]); + Tcl_Obj *const objv[]); static void TestsaveresultFree(char *blockPtr); +#endif /* TCL_NO_DEPRECATED */ static int TestsetassocdataCmd(ClientData dummy, - Tcl_Interp *interp, int argc, CONST char **argv); + Tcl_Interp *interp, int argc, const char **argv); static int TestsetCmd(ClientData dummy, - Tcl_Interp *interp, int argc, CONST char **argv); + Tcl_Interp *interp, int argc, const char **argv); +static int Testset2Cmd(ClientData dummy, + Tcl_Interp *interp, int argc, const char **argv); static int TestseterrorcodeCmd(ClientData dummy, - Tcl_Interp *interp, int argc, CONST char **argv); + Tcl_Interp *interp, int argc, const char **argv); static int TestsetobjerrorcodeCmd( ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[]); -static int TestopenfilechannelprocCmd( - ClientData dummy, Tcl_Interp *interp, int argc, - CONST char **argv); + int objc, Tcl_Obj *const objv[]); static int TestsetplatformCmd(ClientData dummy, - Tcl_Interp *interp, int argc, CONST char **argv); + Tcl_Interp *interp, int argc, const char **argv); static int TeststaticpkgCmd(ClientData dummy, - Tcl_Interp *interp, int argc, CONST char **argv); -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); -static int TeststatprocCmd(ClientData dummy, - Tcl_Interp *interp, int argc, CONST char **argv); + Tcl_Interp *interp, int argc, const char **argv); static int TesttranslatefilenameCmd(ClientData dummy, - Tcl_Interp *interp, int argc, CONST char **argv); + Tcl_Interp *interp, int argc, const char **argv); static int TestupvarCmd(ClientData dummy, - Tcl_Interp *interp, int argc, CONST char **argv); -static int TestWrongNumArgsObjCmd( + Tcl_Interp *interp, int argc, const char **argv); +static int TestWrongNumArgsObjCmd( ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[]); -static int TestGetIndexFromObjStructObjCmd( + int objc, Tcl_Obj *const objv[]); +static int TestGetIndexFromObjStructObjCmd( ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[]); + int objc, Tcl_Obj *const objv[]); static int TestChannelCmd(ClientData clientData, - Tcl_Interp *interp, int argc, CONST char **argv); + Tcl_Interp *interp, int argc, const char **argv); static int TestChannelEventCmd(ClientData clientData, - Tcl_Interp *interp, int argc, CONST char **argv); + Tcl_Interp *interp, int argc, const char **argv); static int TestFilesystemObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[]); + Tcl_Obj *const objv[]); static int TestSimpleFilesystemObjCmd( ClientData dummy, Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[]); -static void TestReport(CONST char* cmd, Tcl_Obj* arg1, - Tcl_Obj* arg2); -static Tcl_Obj* TestReportGetNativePath(Tcl_Obj* pathPtr); -static int TestReportStat(Tcl_Obj *path, Tcl_StatBuf *buf); -static int TestReportAccess(Tcl_Obj *path, int mode); -static Tcl_Channel TestReportOpenFileChannel( - Tcl_Interp *interp, Tcl_Obj *fileName, - int mode, int permissions); -static int TestReportMatchInDirectory(Tcl_Interp *interp, - Tcl_Obj *resultPtr, Tcl_Obj *dirPtr, - CONST char *pattern, Tcl_GlobTypeData *types); -static int TestReportChdir(Tcl_Obj *dirName); -static int TestReportLstat(Tcl_Obj *path, Tcl_StatBuf *buf); -static int TestReportCopyFile(Tcl_Obj *src, Tcl_Obj *dst); -static int TestReportDeleteFile(Tcl_Obj *path); -static int TestReportRenameFile(Tcl_Obj *src, Tcl_Obj *dst); -static int TestReportCreateDirectory(Tcl_Obj *path); -static int TestReportCopyDirectory(Tcl_Obj *src, - Tcl_Obj *dst, Tcl_Obj **errorPtr); -static int TestReportRemoveDirectory(Tcl_Obj *path, - int recursive, Tcl_Obj **errorPtr); -static int TestReportLoadFile(Tcl_Interp *interp, - Tcl_Obj *fileName, Tcl_LoadHandle *handlePtr, - Tcl_FSUnloadFileProc **unloadProcPtr); -static Tcl_Obj * TestReportLink(Tcl_Obj *path, - Tcl_Obj *to, int linkType); -static CONST char** TestReportFileAttrStrings( - Tcl_Obj *fileName, Tcl_Obj **objPtrRef); -static int TestReportFileAttrsGet(Tcl_Interp *interp, - int index, Tcl_Obj *fileName, Tcl_Obj **objPtrRef); -static int TestReportFileAttrsSet(Tcl_Interp *interp, - int index, Tcl_Obj *fileName, Tcl_Obj *objPtr); -static int TestReportUtime(Tcl_Obj *fileName, - struct utimbuf *tval); -static int TestReportNormalizePath(Tcl_Interp *interp, - Tcl_Obj *pathPtr, int nextCheckpoint); -static int TestReportInFilesystem(Tcl_Obj *pathPtr, ClientData *clientDataPtr); -static void TestReportFreeInternalRep(ClientData clientData); -static ClientData TestReportDupInternalRep(ClientData clientData); - -static int SimpleStat(Tcl_Obj *path, Tcl_StatBuf *buf); -static int SimpleAccess(Tcl_Obj *path, int mode); -static Tcl_Channel SimpleOpenFileChannel(Tcl_Interp *interp, - Tcl_Obj *fileName, int mode, int permissions); -static Tcl_Obj* SimpleListVolumes(void); -static int SimplePathInFilesystem( - Tcl_Obj *pathPtr, ClientData *clientDataPtr); -static Tcl_Obj* SimpleRedirect(Tcl_Obj *pathPtr); -static int SimpleMatchInDirectory( - Tcl_Interp *interp, Tcl_Obj *resultPtr, - Tcl_Obj *dirPtr, CONST char *pattern, - Tcl_GlobTypeData *types); -static int TestNumUtfCharsCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[]); -static int TestHashSystemHashCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[]); - -static Tcl_Filesystem testReportingFilesystem = { + Tcl_Obj *const objv[]); +static void TestReport(const char *cmd, Tcl_Obj *arg1, + Tcl_Obj *arg2); +static Tcl_Obj * TestReportGetNativePath(Tcl_Obj *pathPtr); +static Tcl_FSStatProc TestReportStat; +static Tcl_FSAccessProc TestReportAccess; +static Tcl_FSOpenFileChannelProc TestReportOpenFileChannel; +static Tcl_FSMatchInDirectoryProc TestReportMatchInDirectory; +static Tcl_FSChdirProc TestReportChdir; +static Tcl_FSLstatProc TestReportLstat; +static Tcl_FSCopyFileProc TestReportCopyFile; +static Tcl_FSDeleteFileProc TestReportDeleteFile; +static Tcl_FSRenameFileProc TestReportRenameFile; +static Tcl_FSCreateDirectoryProc TestReportCreateDirectory; +static Tcl_FSCopyDirectoryProc TestReportCopyDirectory; +static Tcl_FSRemoveDirectoryProc TestReportRemoveDirectory; +static int TestReportLoadFile(Tcl_Interp *interp, Tcl_Obj *pathPtr, + Tcl_LoadHandle *handlePtr, Tcl_FSUnloadFileProc **unloadProcPtr); +static Tcl_FSLinkProc TestReportLink; +static Tcl_FSFileAttrStringsProc TestReportFileAttrStrings; +static Tcl_FSFileAttrsGetProc TestReportFileAttrsGet; +static Tcl_FSFileAttrsSetProc TestReportFileAttrsSet; +static Tcl_FSUtimeProc TestReportUtime; +static Tcl_FSNormalizePathProc TestReportNormalizePath; +static Tcl_FSPathInFilesystemProc TestReportInFilesystem; +static Tcl_FSFreeInternalRepProc TestReportFreeInternalRep; +static Tcl_FSDupInternalRepProc TestReportDupInternalRep; + +static Tcl_FSStatProc SimpleStat; +static Tcl_FSAccessProc SimpleAccess; +static Tcl_FSOpenFileChannelProc SimpleOpenFileChannel; +static Tcl_FSListVolumesProc SimpleListVolumes; +static Tcl_FSPathInFilesystemProc SimplePathInFilesystem; +static Tcl_Obj * SimpleRedirect(Tcl_Obj *pathPtr); +static Tcl_FSMatchInDirectoryProc SimpleMatchInDirectory; +static int TestNumUtfCharsCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static int TestHashSystemHashCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static int TestNRELevels(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static int TestInterpResolverCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +#if defined(HAVE_CPUID) || defined(_WIN32) +static int TestcpuidCmd(ClientData dummy, + Tcl_Interp* interp, int objc, + Tcl_Obj *const objv[]); +#endif + +static const Tcl_Filesystem testReportingFilesystem = { "reporting", sizeof(Tcl_Filesystem), TCL_FILESYSTEM_VERSION_1, - &TestReportInFilesystem, /* path in */ - &TestReportDupInternalRep, - &TestReportFreeInternalRep, + TestReportInFilesystem, /* path in */ + TestReportDupInternalRep, + TestReportFreeInternalRep, NULL, /* native to norm */ NULL, /* convert to native */ - &TestReportNormalizePath, + TestReportNormalizePath, NULL, /* path type */ NULL, /* separator */ - &TestReportStat, - &TestReportAccess, - &TestReportOpenFileChannel, - &TestReportMatchInDirectory, - &TestReportUtime, - &TestReportLink, + TestReportStat, + TestReportAccess, + TestReportOpenFileChannel, + TestReportMatchInDirectory, + TestReportUtime, + TestReportLink, NULL /* list volumes */, - &TestReportFileAttrStrings, - &TestReportFileAttrsGet, - &TestReportFileAttrsSet, - &TestReportCreateDirectory, - &TestReportRemoveDirectory, - &TestReportDeleteFile, - &TestReportCopyFile, - &TestReportRenameFile, - &TestReportCopyDirectory, - &TestReportLstat, - &TestReportLoadFile, + TestReportFileAttrStrings, + TestReportFileAttrsGet, + TestReportFileAttrsSet, + TestReportCreateDirectory, + TestReportRemoveDirectory, + TestReportDeleteFile, + TestReportCopyFile, + TestReportRenameFile, + TestReportCopyDirectory, + TestReportLstat, + (Tcl_FSLoadFileProc *) TestReportLoadFile, NULL /* cwd */, - &TestReportChdir + TestReportChdir }; -static Tcl_Filesystem simpleFilesystem = { +static const Tcl_Filesystem simpleFilesystem = { "simple", sizeof(Tcl_Filesystem), TCL_FILESYSTEM_VERSION_1, - &SimplePathInFilesystem, + SimplePathInFilesystem, NULL, NULL, /* No internal to normalized, since we don't create any @@ -487,14 +472,14 @@ static Tcl_Filesystem simpleFilesystem = { NULL, NULL, NULL, - &SimpleStat, - &SimpleAccess, - &SimpleOpenFileChannel, - &SimpleMatchInDirectory, + SimpleStat, + SimpleAccess, + SimpleOpenFileChannel, + SimpleMatchInDirectory, NULL, /* We choose not to support symbolic links inside our vfs's */ NULL, - &SimpleListVolumes, + SimpleListVolumes, NULL, NULL, NULL, @@ -518,15 +503,6 @@ static Tcl_Filesystem simpleFilesystem = { /* - * External (platform specific) initialization routine, these declarations - * explicitly don't use EXTERN since this code does not get compiled into the - * library: - */ - -extern int TclplatformtestInit(Tcl_Interp *interp); -extern int TclThread_Init(Tcl_Interp *interp); - -/* *---------------------------------------------------------------------- * * Tcltest_Init -- @@ -549,151 +525,184 @@ int Tcltest_Init( Tcl_Interp *interp) /* Interpreter for application. */ { +#ifndef TCL_NO_DEPRECATED Tcl_ValueType t3ArgTypes[2]; +#endif /* TCL_NO_DEPRECATED */ Tcl_Obj *listPtr; Tcl_Obj **objv; int objc, index; - static CONST char *specialOptions[] = { + static const char *const specialOptions[] = { "-appinitprocerror", "-appinitprocdeleteinterp", "-appinitprocclosestderr", "-appinitprocsetrcfile", NULL }; - if (Tcl_PkgProvide(interp, "Tcltest", TCL_VERSION) == TCL_ERROR) { - return TCL_ERROR; + if (Tcl_InitStubs(interp, "8.5", 0) == NULL) { + return TCL_ERROR; + } + if (Tcl_TomMath_InitStubs(interp, "8.5") == NULL) { + return TCL_ERROR; + } + if (Tcl_OOInitStubs(interp) == NULL) { + return TCL_ERROR; + } + /* TIP #268: Full patchlevel instead of just major.minor */ + + if (Tcl_PkgProvide(interp, "Tcltest", TCL_PATCH_LEVEL) == TCL_ERROR) { + return TCL_ERROR; } /* * Create additional commands and math functions for testing Tcl. */ - Tcl_CreateCommand(interp, "gettimes", GetTimesCmd, (ClientData) 0, NULL); - Tcl_CreateCommand(interp, "noop", NoopCmd, (ClientData) 0, NULL); - Tcl_CreateObjCommand(interp, "noop", NoopObjCmd, (ClientData) 0, NULL); + Tcl_CreateCommand(interp, "gettimes", GetTimesCmd, NULL, NULL); + Tcl_CreateCommand(interp, "noop", NoopCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "noop", NoopObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testwrongnumargs", TestWrongNumArgsObjCmd, - (ClientData) 0, NULL); + NULL, NULL); Tcl_CreateObjCommand(interp, "testfilesystem", TestFilesystemObjCmd, - (ClientData) 0, NULL); + NULL, NULL); Tcl_CreateObjCommand(interp, "testsimplefilesystem", TestSimpleFilesystemObjCmd, - (ClientData) 0, NULL); + NULL, NULL); Tcl_CreateObjCommand(interp, "testgetindexfromobjstruct", - TestGetIndexFromObjStructObjCmd, (ClientData) 0, NULL); - Tcl_CreateCommand(interp, "testaccessproc", TestaccessprocCmd, (ClientData) 0, - NULL); - Tcl_CreateCommand(interp, "testasync", TestasyncCmd, (ClientData) 0, NULL); + TestGetIndexFromObjStructObjCmd, NULL, NULL); + Tcl_CreateCommand(interp, "testasync", TestasyncCmd, NULL, NULL); Tcl_CreateCommand(interp, "testchannel", TestChannelCmd, - (ClientData) 0, NULL); + NULL, NULL); Tcl_CreateCommand(interp, "testchannelevent", TestChannelEventCmd, - (ClientData) 0, NULL); - Tcl_CreateCommand(interp, "testchmod", TestchmodCmd, - (ClientData) 0, NULL); - Tcl_CreateCommand(interp, "testcmdtoken", TestcmdtokenCmd, (ClientData) 0, + NULL, NULL); + Tcl_CreateCommand(interp, "testcmdtoken", TestcmdtokenCmd, NULL, NULL); - Tcl_CreateCommand(interp, "testcmdinfo", TestcmdinfoCmd, (ClientData) 0, + Tcl_CreateCommand(interp, "testcmdinfo", TestcmdinfoCmd, NULL, NULL); Tcl_CreateCommand(interp, "testcmdtrace", TestcmdtraceCmd, - (ClientData) 0, NULL); + NULL, NULL); + Tcl_CreateCommand(interp, "testconcatobj", TestconcatobjCmd, + NULL, NULL); Tcl_CreateCommand(interp, "testcreatecommand", TestcreatecommandCmd, - (ClientData) 0, NULL); - Tcl_CreateCommand(interp, "testdcall", TestdcallCmd, (ClientData) 0, NULL); - Tcl_CreateCommand(interp, "testdel", TestdelCmd, (ClientData) 0, NULL); + NULL, NULL); + Tcl_CreateCommand(interp, "testdcall", TestdcallCmd, NULL, NULL); + Tcl_CreateCommand(interp, "testdel", TestdelCmd, NULL, NULL); Tcl_CreateCommand(interp, "testdelassocdata", TestdelassocdataCmd, - (ClientData) 0, NULL); + NULL, NULL); + Tcl_CreateObjCommand(interp, "testdoubledigits", TestdoubledigitsObjCmd, + NULL, NULL); Tcl_DStringInit(&dstring); - Tcl_CreateCommand(interp, "testdstring", TestdstringCmd, (ClientData) 0, + Tcl_CreateCommand(interp, "testdstring", TestdstringCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testencoding", TestencodingObjCmd, (ClientData) 0, + Tcl_CreateObjCommand(interp, "testencoding", TestencodingObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testevalex", TestevalexObjCmd, - (ClientData) 0, NULL); + NULL, NULL); Tcl_CreateObjCommand(interp, "testevalobjv", TestevalobjvObjCmd, - (ClientData) 0, NULL); - Tcl_CreateObjCommand( interp, "testevent", TesteventObjCmd, - (ClientData) 0, NULL); + NULL, NULL); + Tcl_CreateObjCommand(interp, "testevent", TesteventObjCmd, + NULL, NULL); Tcl_CreateCommand(interp, "testexithandler", TestexithandlerCmd, - (ClientData) 0, NULL); + NULL, NULL); Tcl_CreateCommand(interp, "testexprlong", TestexprlongCmd, - (ClientData) 0, NULL); + NULL, NULL); Tcl_CreateObjCommand(interp, "testexprlongobj", TestexprlongobjCmd, - (ClientData) 0, NULL); + NULL, NULL); Tcl_CreateCommand(interp, "testexprdouble", TestexprdoubleCmd, - (ClientData) 0, NULL); + NULL, NULL); Tcl_CreateObjCommand(interp, "testexprdoubleobj", TestexprdoubleobjCmd, - (ClientData) 0, NULL); + NULL, NULL); Tcl_CreateObjCommand(interp, "testexprparser", TestexprparserObjCmd, - (ClientData) 0, NULL); + NULL, NULL); Tcl_CreateCommand(interp, "testexprstring", TestexprstringCmd, - (ClientData) 0, NULL); - Tcl_CreateCommand(interp, "testfevent", TestfeventCmd, (ClientData) 0, - NULL); + NULL, NULL); + Tcl_CreateCommand(interp, "testfevent", TestfeventCmd, NULL, + NULL); Tcl_CreateObjCommand(interp, "testfilelink", TestfilelinkCmd, - (ClientData) 0, NULL); + NULL, NULL); Tcl_CreateObjCommand(interp, "testfile", TestfileCmd, - (ClientData) 0, NULL); + NULL, NULL); Tcl_CreateObjCommand(interp, "testhashsystemhash", - TestHashSystemHashCmd, (ClientData) 0, NULL); + TestHashSystemHashCmd, NULL, NULL); Tcl_CreateCommand(interp, "testgetassocdata", TestgetassocdataCmd, - (ClientData) 0, NULL); + NULL, NULL); Tcl_CreateCommand(interp, "testgetint", TestgetintCmd, - (ClientData) 0, NULL); + NULL, NULL); Tcl_CreateCommand(interp, "testgetplatform", TestgetplatformCmd, - (ClientData) 0, NULL); + NULL, NULL); Tcl_CreateObjCommand(interp, "testgetvarfullname", - TestgetvarfullnameCmd, (ClientData) 0, NULL); + TestgetvarfullnameCmd, NULL, NULL); Tcl_CreateCommand(interp, "testinterpdelete", TestinterpdeleteCmd, - (ClientData) 0, NULL); - Tcl_CreateCommand(interp, "testlink", TestlinkCmd, (ClientData) 0, NULL); - Tcl_CreateObjCommand(interp, "testlocale", TestlocaleCmd, (ClientData) 0, + NULL, NULL); + Tcl_CreateCommand(interp, "testlink", TestlinkCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "testlocale", TestlocaleCmd, NULL, NULL); - Tcl_CreateCommand(interp, "testopenfilechannelproc", - TestopenfilechannelprocCmd, (ClientData) 0, NULL); - Tcl_CreateCommand(interp, "testpanic", TestpanicCmd, (ClientData) 0, NULL); + Tcl_CreateCommand(interp, "testpanic", TestpanicCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "testparseargs", TestparseargsCmd,NULL,NULL); Tcl_CreateObjCommand(interp, "testparser", TestparserObjCmd, - (ClientData) 0, NULL); + NULL, NULL); Tcl_CreateObjCommand(interp, "testparsevar", TestparsevarObjCmd, - (ClientData) 0, NULL); + NULL, NULL); Tcl_CreateObjCommand(interp, "testparsevarname", TestparsevarnameObjCmd, - (ClientData) 0, NULL); + NULL, NULL); Tcl_CreateObjCommand(interp, "testregexp", TestregexpObjCmd, - (ClientData) 0, NULL); + NULL, NULL); Tcl_CreateObjCommand(interp, "testreturn", TestreturnObjCmd, - (ClientData) 0, NULL); + NULL, NULL); +#ifndef TCL_NO_DEPRECATED Tcl_CreateObjCommand(interp, "testsaveresult", TestsaveresultCmd, - (ClientData) 0, NULL); + NULL, NULL); +#endif /* TCL_NO_DEPRECATED */ Tcl_CreateCommand(interp, "testsetassocdata", TestsetassocdataCmd, - (ClientData) 0, NULL); + NULL, NULL); Tcl_CreateCommand(interp, "testsetnoerr", TestsetCmd, - (ClientData) 0, NULL); + NULL, NULL); Tcl_CreateCommand(interp, "testseterr", TestsetCmd, - (ClientData) TCL_LEAVE_ERR_MSG, NULL); + (ClientData) TCL_LEAVE_ERR_MSG, NULL); + Tcl_CreateCommand(interp, "testset2", Testset2Cmd, + (ClientData) TCL_LEAVE_ERR_MSG, NULL); Tcl_CreateCommand(interp, "testseterrorcode", TestseterrorcodeCmd, - (ClientData) 0, NULL); + NULL, NULL); Tcl_CreateObjCommand(interp, "testsetobjerrorcode", - TestsetobjerrorcodeCmd, (ClientData) 0, NULL); + TestsetobjerrorcodeCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testnumutfchars", - TestNumUtfCharsCmd, (ClientData) 0, NULL); + TestNumUtfCharsCmd, NULL, NULL); Tcl_CreateCommand(interp, "testsetplatform", TestsetplatformCmd, - (ClientData) 0, NULL); + NULL, NULL); Tcl_CreateCommand(interp, "teststaticpkg", TeststaticpkgCmd, - (ClientData) 0, NULL); + NULL, NULL); Tcl_CreateCommand(interp, "testtranslatefilename", - TesttranslatefilenameCmd, (ClientData) 0, NULL); - Tcl_CreateCommand(interp, "testupvar", TestupvarCmd, (ClientData) 0, NULL); + TesttranslatefilenameCmd, NULL, NULL); + Tcl_CreateCommand(interp, "testupvar", TestupvarCmd, NULL, NULL); +#ifndef TCL_NO_DEPRECATED Tcl_CreateMathFunc(interp, "T1", 0, NULL, TestMathFunc, (ClientData) 123); Tcl_CreateMathFunc(interp, "T2", 0, NULL, TestMathFunc, (ClientData) 345); - Tcl_CreateCommand(interp, "teststatproc", TeststatprocCmd, (ClientData) 0, - NULL); - Tcl_CreateCommand(interp, "testmainthread", TestmainthreadCmd, (ClientData) 0, +#endif /* TCL_NO_DEPRECATED */ + Tcl_CreateCommand(interp, "testmainthread", TestmainthreadCmd, NULL, NULL); Tcl_CreateCommand(interp, "testsetmainloop", TestsetmainloopCmd, - (ClientData) NULL, NULL); + NULL, NULL); Tcl_CreateCommand(interp, "testexitmainloop", TestexitmainloopCmd, - (ClientData) NULL, NULL); + NULL, NULL); +#if defined(HAVE_CPUID) || defined(_WIN32) + Tcl_CreateObjCommand(interp, "testcpuid", TestcpuidCmd, + (ClientData) 0, NULL); +#endif +#ifndef TCL_NO_DEPRECATED t3ArgTypes[0] = TCL_EITHER; t3ArgTypes[1] = TCL_EITHER; Tcl_CreateMathFunc(interp, "T3", 2, t3ArgTypes, TestMathFunc2, - (ClientData) 0); + NULL); +#endif /* TCL_NO_DEPRECATED */ + + Tcl_CreateObjCommand(interp, "testnrelevels", TestNRELevels, + NULL, NULL); + Tcl_CreateObjCommand(interp, "testinterpresolver", TestInterpResolverCmd, + NULL, NULL); + if (TclObjTest_Init(interp) != TCL_OK) { + return TCL_ERROR; + } + if (Procbodytest_Init(interp) != TCL_OK) { + return TCL_ERROR; + } #ifdef TCL_THREADS if (TclThread_Init(interp) != TCL_OK) { return TCL_ERROR; @@ -706,10 +715,10 @@ Tcltest_Init( listPtr = Tcl_GetVar2Ex(interp, "argv", NULL, TCL_GLOBAL_ONLY); if (listPtr != NULL) { - if (Tcl_ListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) { + if (Tcl_ListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) { return TCL_ERROR; - } - if (objc && (Tcl_GetIndexFromObj(NULL, objv[0], specialOptions, NULL, + } + if (objc && (Tcl_GetIndexFromObj(NULL, objv[0], specialOptions, NULL, TCL_EXACT, &index) == TCL_OK)) { switch (index) { case 0: @@ -730,7 +739,7 @@ Tcltest_Init( } return TCL_ERROR; } - } + } } /* @@ -739,6 +748,35 @@ Tcltest_Init( return TclplatformtestInit(interp); } + +/* + *---------------------------------------------------------------------- + * + * Tcltest_SafeInit -- + * + * This procedure performs application-specific initialization. Most + * applications, especially those that incorporate additional packages, + * will have their own version of this procedure. + * + * Results: + * Returns a standard Tcl completion code, and leaves an error message in + * the interp's result if an error occurs. + * + * Side effects: + * Depends on the startup script. + * + *---------------------------------------------------------------------- + */ + +int +Tcltest_SafeInit( + Tcl_Interp *interp) /* Interpreter for application. */ +{ + if (Tcl_InitStubs(interp, "8.5", 0) == NULL) { + return TCL_ERROR; + } + return Procbodytest_SafeInit(interp); +} /* *---------------------------------------------------------------------- @@ -759,16 +797,15 @@ Tcltest_Init( /* ARGSUSED */ static int -TestasyncCmd(dummy, interp, argc, argv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - CONST char **argv; /* Argument strings. */ +TestasyncCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int argc, /* Number of arguments. */ + const char **argv) /* Argument strings. */ { TestAsyncHandler *asyncPtr, *prevPtr; int id, code; static int nextId = 1; - char buf[TCL_INTEGER_SPACE]; if (argc < 2) { wrongNumArgs: @@ -779,26 +816,29 @@ TestasyncCmd(dummy, interp, argc, argv) if (argc != 3) { goto wrongNumArgs; } - asyncPtr = (TestAsyncHandler *) ckalloc(sizeof(TestAsyncHandler)); + asyncPtr = ckalloc(sizeof(TestAsyncHandler)); + asyncPtr->command = ckalloc(strlen(argv[2]) + 1); + strcpy(asyncPtr->command, argv[2]); + Tcl_MutexLock(&asyncTestMutex); asyncPtr->id = nextId; nextId++; asyncPtr->handler = Tcl_AsyncCreate(AsyncHandlerProc, - (ClientData) asyncPtr); - asyncPtr->command = (char *) ckalloc((unsigned) (strlen(argv[2]) + 1)); - strcpy(asyncPtr->command, argv[2]); + INT2PTR(asyncPtr->id)); asyncPtr->nextPtr = firstHandler; firstHandler = asyncPtr; - TclFormatInt(buf, asyncPtr->id); - Tcl_SetResult(interp, buf, TCL_VOLATILE); + Tcl_MutexUnlock(&asyncTestMutex); + Tcl_SetObjResult(interp, Tcl_NewIntObj(asyncPtr->id)); } else if (strcmp(argv[1], "delete") == 0) { if (argc == 2) { + Tcl_MutexLock(&asyncTestMutex); while (firstHandler != NULL) { asyncPtr = firstHandler; firstHandler = asyncPtr->nextPtr; Tcl_AsyncDelete(asyncPtr->handler); ckfree(asyncPtr->command); - ckfree((char *) asyncPtr); + ckfree(asyncPtr); } + Tcl_MutexUnlock(&asyncTestMutex); return TCL_OK; } if (argc != 3) { @@ -807,6 +847,7 @@ TestasyncCmd(dummy, interp, argc, argv) if (Tcl_GetInt(interp, argv[2], &id) != TCL_OK) { return TCL_ERROR; } + Tcl_MutexLock(&asyncTestMutex); for (prevPtr = NULL, asyncPtr = firstHandler; asyncPtr != NULL; prevPtr = asyncPtr, asyncPtr = asyncPtr->nextPtr) { if (asyncPtr->id != id) { @@ -819,9 +860,10 @@ TestasyncCmd(dummy, interp, argc, argv) } Tcl_AsyncDelete(asyncPtr->handler); ckfree(asyncPtr->command); - ckfree((char *) asyncPtr); + ckfree(asyncPtr); break; } + Tcl_MutexUnlock(&asyncTestMutex); } else if (strcmp(argv[1], "mark") == 0) { if (argc != 5) { goto wrongNumArgs; @@ -830,6 +872,7 @@ TestasyncCmd(dummy, interp, argc, argv) || (Tcl_GetInt(interp, argv[4], &code) != TCL_OK)) { return TCL_ERROR; } + Tcl_MutexLock(&asyncTestMutex); for (asyncPtr = firstHandler; asyncPtr != NULL; asyncPtr = asyncPtr->nextPtr) { if (asyncPtr->id == id) { @@ -837,7 +880,8 @@ TestasyncCmd(dummy, interp, argc, argv) break; } } - Tcl_SetResult(interp, (char *)argv[3], TCL_VOLATILE); + Tcl_SetObjResult(interp, Tcl_NewStringObj(argv[3], -1)); + Tcl_MutexUnlock(&asyncTestMutex); return code; #ifdef TCL_THREADS } else if (strcmp(argv[1], "marklater") == 0) { @@ -847,19 +891,22 @@ TestasyncCmd(dummy, interp, argc, argv) if (Tcl_GetInt(interp, argv[2], &id) != TCL_OK) { return TCL_ERROR; } + Tcl_MutexLock(&asyncTestMutex); for (asyncPtr = firstHandler; asyncPtr != NULL; asyncPtr = asyncPtr->nextPtr) { if (asyncPtr->id == id) { Tcl_ThreadId threadID; if (Tcl_CreateThread(&threadID, AsyncThreadProc, - (ClientData) asyncPtr, TCL_THREAD_STACK_DEFAULT, + INT2PTR(id), TCL_THREAD_STACK_DEFAULT, TCL_THREAD_NOFLAGS) != TCL_OK) { Tcl_SetResult(interp, "can't create thread", TCL_STATIC); + Tcl_MutexUnlock(&asyncTestMutex); return TCL_ERROR; } break; } } + Tcl_MutexUnlock(&asyncTestMutex); } else { Tcl_AppendResult(interp, "bad option \"", argv[1], "\": must be create, delete, int, mark, or marklater", NULL); @@ -875,16 +922,30 @@ TestasyncCmd(dummy, interp, argc, argv) } static int -AsyncHandlerProc(clientData, interp, code) - ClientData clientData; /* Pointer to TestAsyncHandler structure. */ - Tcl_Interp *interp; /* Interpreter in which command was +AsyncHandlerProc( + ClientData clientData, /* If of TestAsyncHandler structure. + * in global list. */ + Tcl_Interp *interp, /* Interpreter in which command was * executed, or NULL. */ - int code; /* Current return code from command. */ + int code) /* Current return code from command. */ { - TestAsyncHandler *asyncPtr = (TestAsyncHandler *) clientData; - CONST char *listArgv[4], *cmd; + TestAsyncHandler *asyncPtr; + int id = PTR2INT(clientData); + const char *listArgv[4], *cmd; char string[TCL_INTEGER_SPACE]; + Tcl_MutexLock(&asyncTestMutex); + for (asyncPtr = firstHandler; asyncPtr != NULL; + asyncPtr = asyncPtr->nextPtr) { + if (asyncPtr->id == id) break; + } + Tcl_MutexUnlock(&asyncTestMutex); + + if (!asyncPtr) { + /* Woops - this one was deleted between the AsyncMark and now */ + return TCL_OK; + } + TclFormatInt(string, code); listArgv[0] = asyncPtr->command; listArgv[1] = Tcl_GetString(Tcl_GetObjResult(interp)); @@ -899,7 +960,7 @@ AsyncHandlerProc(clientData, interp, code) * invoked, it's possible. Better error checking is needed here. */ } - ckfree((char *)cmd); + ckfree(cmd); return code; } @@ -921,13 +982,23 @@ AsyncHandlerProc(clientData, interp, code) #ifdef TCL_THREADS static Tcl_ThreadCreateType -AsyncThreadProc(clientData) - ClientData clientData; /* Parameter is a pointer to a +AsyncThreadProc( + ClientData clientData) /* Parameter is the id of a * TestAsyncHandler, defined above. */ { - TestAsyncHandler* asyncPtr = clientData; + TestAsyncHandler *asyncPtr; + int id = PTR2INT(clientData); + Tcl_Sleep(1); - Tcl_AsyncMark(asyncPtr->handler); + Tcl_MutexLock(&asyncTestMutex); + for (asyncPtr = firstHandler; asyncPtr != NULL; + asyncPtr = asyncPtr->nextPtr) { + if (asyncPtr->id == id) { + Tcl_AsyncMark(asyncPtr->handler); + break; + } + } + Tcl_MutexUnlock(&asyncTestMutex); Tcl_ExitThread(TCL_OK); TCL_THREAD_CREATE_RETURN; } @@ -953,11 +1024,11 @@ AsyncThreadProc(clientData) /* ARGSUSED */ static int -TestcmdinfoCmd(dummy, interp, argc, argv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - CONST char **argv; /* Argument strings. */ +TestcmdinfoCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int argc, /* Number of arguments. */ + const char **argv) /* Argument strings. */ { Tcl_CmdInfo info; @@ -1006,13 +1077,13 @@ TestcmdinfoCmd(dummy, interp, argc, argv) info.proc = CmdProc2; info.clientData = (ClientData) "new_command_data"; info.objProc = NULL; - info.objClientData = (ClientData) NULL; + info.objClientData = NULL; info.deleteProc = CmdDelProc2; info.deleteData = (ClientData) "new_delete_data"; if (Tcl_SetCommandInfo(interp, argv[2], &info) == 0) { - Tcl_SetResult(interp, "0", TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); } else { - Tcl_SetResult(interp, "1", TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewIntObj(1)); } } else { Tcl_AppendResult(interp, "bad option \"", argv[1], @@ -1024,11 +1095,11 @@ TestcmdinfoCmd(dummy, interp, argc, argv) /*ARGSUSED*/ static int -CmdProc1(clientData, interp, argc, argv) - ClientData clientData; /* String to return. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - CONST char **argv; /* Argument strings. */ +CmdProc1( + ClientData clientData, /* String to return. */ + Tcl_Interp *interp, /* Current interpreter. */ + int argc, /* Number of arguments. */ + const char **argv) /* Argument strings. */ { Tcl_AppendResult(interp, "CmdProc1 ", (char *) clientData, NULL); return TCL_OK; @@ -1036,19 +1107,19 @@ CmdProc1(clientData, interp, argc, argv) /*ARGSUSED*/ static int -CmdProc2(clientData, interp, argc, argv) - ClientData clientData; /* String to return. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - CONST char **argv; /* Argument strings. */ +CmdProc2( + ClientData clientData, /* String to return. */ + Tcl_Interp *interp, /* Current interpreter. */ + int argc, /* Number of arguments. */ + const char **argv) /* Argument strings. */ { Tcl_AppendResult(interp, "CmdProc2 ", (char *) clientData, NULL); return TCL_OK; } static void -CmdDelProc1(clientData) - ClientData clientData; /* String to save. */ +CmdDelProc1( + ClientData clientData) /* String to save. */ { Tcl_DStringInit(&delString); Tcl_DStringAppend(&delString, "CmdDelProc1 ", -1); @@ -1056,8 +1127,8 @@ CmdDelProc1(clientData) } static void -CmdDelProc2(clientData) - ClientData clientData; /* String to save. */ +CmdDelProc2( + ClientData clientData) /* String to save. */ { Tcl_DStringInit(&delString); Tcl_DStringAppend(&delString, "CmdDelProc2 ", -1); @@ -1083,11 +1154,11 @@ CmdDelProc2(clientData) /* ARGSUSED */ static int -TestcmdtokenCmd(dummy, interp, argc, argv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - CONST char **argv; /* Argument strings. */ +TestcmdtokenCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int argc, /* Number of arguments. */ + const char **argv) /* Argument strings. */ { Tcl_Command token; int *l; @@ -1116,7 +1187,7 @@ TestcmdtokenCmd(dummy, interp, argc, argv) Tcl_GetCommandFullName(interp, (Tcl_Command) l, objPtr); Tcl_AppendElement(interp, - Tcl_GetCommandName(interp, (Tcl_Command) l)); + Tcl_GetCommandName(interp, (Tcl_Command) l)); Tcl_AppendElement(interp, Tcl_GetString(objPtr)); Tcl_DecrRefCount(objPtr); } else { @@ -1147,11 +1218,11 @@ TestcmdtokenCmd(dummy, interp, argc, argv) /* ARGSUSED */ static int -TestcmdtraceCmd(dummy, interp, argc, argv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - CONST char **argv; /* Argument strings. */ +TestcmdtraceCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int argc, /* Number of arguments. */ + const char **argv) /* Argument strings. */ { Tcl_DString buffer; int result; @@ -1164,8 +1235,7 @@ TestcmdtraceCmd(dummy, interp, argc, argv) if (strcmp(argv[1], "tracetest") == 0) { Tcl_DStringInit(&buffer); - cmdTrace = Tcl_CreateTrace(interp, 50000, - (Tcl_CmdTraceProc *) CmdTraceProc, (ClientData) &buffer); + cmdTrace = Tcl_CreateTrace(interp, 50000, CmdTraceProc, &buffer); result = Tcl_Eval(interp, argv[2]); if (result == TCL_OK) { Tcl_ResetResult(interp); @@ -1178,17 +1248,16 @@ TestcmdtraceCmd(dummy, interp, argc, argv) * Create a command trace then eval a script to check whether it is * called. Note that this trace procedure removes itself as a further * check of the robustness of the trace proc calling code in - * TclExecuteByteCode. + * TclNRExecuteByteCode. */ - cmdTrace = Tcl_CreateTrace(interp, 50000, - (Tcl_CmdTraceProc *) CmdTraceDeleteProc, (ClientData) NULL); + cmdTrace = Tcl_CreateTrace(interp, 50000, CmdTraceDeleteProc, NULL); Tcl_Eval(interp, argv[2]); } else if (strcmp(argv[1], "leveltest") == 0) { Interp *iPtr = (Interp *) interp; Tcl_DStringInit(&buffer); - cmdTrace = Tcl_CreateTrace(interp, iPtr->numLevels + 4, - (Tcl_CmdTraceProc *) CmdTraceProc, (ClientData) &buffer); + cmdTrace = Tcl_CreateTrace(interp, iPtr->numLevels + 4, CmdTraceProc, + &buffer); result = Tcl_Eval(interp, argv[2]); if (result == TCL_OK) { Tcl_ResetResult(interp); @@ -1196,47 +1265,61 @@ TestcmdtraceCmd(dummy, interp, argc, argv) } Tcl_DeleteTrace(interp, cmdTrace); Tcl_DStringFree(&buffer); - } else if ( strcmp(argv[1], "resulttest" ) == 0 ) { + } else if (strcmp(argv[1], "resulttest") == 0) { /* Create an object-based trace, then eval a script. This is used * to test return codes other than TCL_OK from the trace engine. */ + static int deleteCalled; + deleteCalled = 0; cmdTrace = Tcl_CreateObjTrace(interp, 50000, TCL_ALLOW_INLINE_COMPILATION, ObjTraceProc, (ClientData) &deleteCalled, ObjTraceDeleteProc); - result = Tcl_Eval( interp, argv[ 2 ] ); - Tcl_DeleteTrace( interp, cmdTrace ); - if ( !deleteCalled ) { - Tcl_SetResult( interp, "Delete wasn't called", TCL_STATIC ); + result = Tcl_Eval(interp, argv[2]); + Tcl_DeleteTrace(interp, cmdTrace); + if (!deleteCalled) { + Tcl_SetResult(interp, "Delete wasn't called", TCL_STATIC); return TCL_ERROR; } else { return result; } + } else if (strcmp(argv[1], "doubletest") == 0) { + Tcl_Trace t1, t2; + Tcl_DStringInit(&buffer); + t1 = Tcl_CreateTrace(interp, 1, CmdTraceProc, &buffer); + t2 = Tcl_CreateTrace(interp, 50000, CmdTraceProc, &buffer); + result = Tcl_Eval(interp, argv[2]); + if (result == TCL_OK) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, Tcl_DStringValue(&buffer), NULL); + } + Tcl_DeleteTrace(interp, t2); + Tcl_DeleteTrace(interp, t1); + Tcl_DStringFree(&buffer); } else { Tcl_AppendResult(interp, "bad option \"", argv[1], - "\": must be tracetest, deletetest or resulttest", NULL); + "\": must be tracetest, deletetest, doubletest or resulttest", NULL); return TCL_ERROR; } return TCL_OK; } static void -CmdTraceProc(clientData, interp, level, command, cmdProc, cmdClientData, - argc, argv) - ClientData clientData; /* Pointer to buffer in which the +CmdTraceProc( + ClientData clientData, /* Pointer to buffer in which the * command and arguments are appended. * Accumulates test result. */ - Tcl_Interp *interp; /* Current interpreter. */ - int level; /* Current trace level. */ - char *command; /* The command being traced (after + Tcl_Interp *interp, /* Current interpreter. */ + int level, /* Current trace level. */ + char *command, /* The command being traced (after * substitutions). */ - Tcl_CmdProc *cmdProc; /* Points to command's command procedure. */ - ClientData cmdClientData; /* Client data associated with command + Tcl_CmdProc *cmdProc, /* Points to command's command procedure. */ + ClientData cmdClientData, /* Client data associated with command * procedure. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + int argc, /* Number of arguments. */ + const char *argv[]) /* Argument strings. */ { Tcl_DString *bufPtr = (Tcl_DString *) clientData; int i; @@ -1251,22 +1334,21 @@ CmdTraceProc(clientData, interp, level, command, cmdProc, cmdClientData, } static void -CmdTraceDeleteProc(clientData, interp, level, command, cmdProc, - cmdClientData, argc, argv) - ClientData clientData; /* Unused. */ - Tcl_Interp *interp; /* Current interpreter. */ - int level; /* Current trace level. */ - char *command; /* The command being traced (after +CmdTraceDeleteProc( + ClientData clientData, /* Unused. */ + Tcl_Interp *interp, /* Current interpreter. */ + int level, /* Current trace level. */ + char *command, /* The command being traced (after * substitutions). */ - Tcl_CmdProc *cmdProc; /* Points to command's command procedure. */ - ClientData cmdClientData; /* Client data associated with command + Tcl_CmdProc *cmdProc, /* Points to command's command procedure. */ + ClientData cmdClientData, /* Client data associated with command * procedure. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + int argc, /* Number of arguments. */ + const char *argv[]) /* Argument strings. */ { /* * Remove ourselves to test whether calling Tcl_DeleteTrace within a trace - * callback causes the for loop in TclExecuteByteCode that calls traces to + * callback causes the for loop in TclNRExecuteByteCode that calls traces to * reference freed memory. */ @@ -1274,26 +1356,27 @@ CmdTraceDeleteProc(clientData, interp, level, command, cmdProc, } static int -ObjTraceProc( clientData, interp, level, command, token, objc, objv ) - ClientData clientData; /* unused */ - Tcl_Interp* interp; /* Tcl interpreter */ - int level; /* Execution level */ - CONST char* command; /* Command being executed */ - Tcl_Command token; /* Command information */ - int objc; /* Parameter count */ - Tcl_Obj *CONST objv[]; /* Parameter list */ -{ - CONST char* word = Tcl_GetString( objv[ 0 ] ); - if ( !strcmp( word, "Error" ) ) { - Tcl_SetObjResult( interp, Tcl_NewStringObj( command, -1 ) ); +ObjTraceProc( + ClientData clientData, /* unused */ + Tcl_Interp *interp, /* Tcl interpreter */ + int level, /* Execution level */ + const char *command, /* Command being executed */ + Tcl_Command token, /* Command information */ + int objc, /* Parameter count */ + Tcl_Obj *const objv[]) /* Parameter list */ +{ + const char *word = Tcl_GetString(objv[0]); + + if (!strcmp(word, "Error")) { + Tcl_SetObjResult(interp, Tcl_NewStringObj(command, -1)); return TCL_ERROR; - } else if ( !strcmp( word, "Break" ) ) { + } else if (!strcmp(word, "Break")) { return TCL_BREAK; - } else if ( !strcmp( word, "Continue" ) ) { + } else if (!strcmp(word, "Continue")) { return TCL_CONTINUE; - } else if ( !strcmp( word, "Return" ) ) { + } else if (!strcmp(word, "Return")) { return TCL_RETURN; - } else if ( !strcmp( word, "OtherStatus" ) ) { + } else if (!strcmp(word, "OtherStatus")) { return 6; } else { return TCL_OK; @@ -1301,10 +1384,10 @@ ObjTraceProc( clientData, interp, level, command, token, objc, objv ) } static void -ObjTraceDeleteProc( clientData ) - ClientData clientData; +ObjTraceDeleteProc( + ClientData clientData) { - int * intPtr = (int *) clientData; + int *intPtr = (int *) clientData; *intPtr = 1; /* Record that the trace was deleted */ } @@ -1330,11 +1413,11 @@ ObjTraceDeleteProc( clientData ) */ static int -TestcreatecommandCmd(dummy, interp, argc, argv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - CONST char **argv; /* Argument strings. */ +TestcreatecommandCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int argc, /* Number of arguments. */ + const char **argv) /* Argument strings. */ { if (argc != 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], @@ -1343,12 +1426,12 @@ TestcreatecommandCmd(dummy, interp, argc, argv) } if (strcmp(argv[1], "create") == 0) { Tcl_CreateCommand(interp, "test_ns_basic::createdcommand", - CreatedCommandProc, (ClientData) NULL, NULL); + CreatedCommandProc, NULL, NULL); } else if (strcmp(argv[1], "delete") == 0) { Tcl_DeleteCommand(interp, "test_ns_basic::createdcommand"); } else if (strcmp(argv[1], "create2") == 0) { Tcl_CreateCommand(interp, "value:at:", - CreatedCommandProc2, (ClientData) NULL, NULL); + CreatedCommandProc2, NULL, NULL); } else if (strcmp(argv[1], "delete2") == 0) { Tcl_DeleteCommand(interp, "value:at:"); } else { @@ -1360,11 +1443,11 @@ TestcreatecommandCmd(dummy, interp, argc, argv) } static int -CreatedCommandProc(clientData, interp, argc, argv) - ClientData clientData; /* String to return. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - CONST char **argv; /* Argument strings. */ +CreatedCommandProc( + ClientData clientData, /* String to return. */ + Tcl_Interp *interp, /* Current interpreter. */ + int argc, /* Number of arguments. */ + const char **argv) /* Argument strings. */ { Tcl_CmdInfo info; int found; @@ -1373,7 +1456,7 @@ CreatedCommandProc(clientData, interp, argc, argv) &info); if (!found) { Tcl_AppendResult(interp, "CreatedCommandProc could not get command info for test_ns_basic::createdcommand", - NULL); + NULL); return TCL_ERROR; } Tcl_AppendResult(interp, "CreatedCommandProc in ", @@ -1382,11 +1465,11 @@ CreatedCommandProc(clientData, interp, argc, argv) } static int -CreatedCommandProc2(clientData, interp, argc, argv) - ClientData clientData; /* String to return. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - CONST char **argv; /* Argument strings. */ +CreatedCommandProc2( + ClientData clientData, /* String to return. */ + Tcl_Interp *interp, /* Current interpreter. */ + int argc, /* Number of arguments. */ + const char **argv) /* Argument strings. */ { Tcl_CmdInfo info; int found; @@ -1394,7 +1477,7 @@ CreatedCommandProc2(clientData, interp, argc, argv) found = Tcl_GetCommandInfo(interp, "value:at:", &info); if (!found) { Tcl_AppendResult(interp, "CreatedCommandProc2 could not get command info for test_ns_basic::createdcommand", - NULL); + NULL); return TCL_ERROR; } Tcl_AppendResult(interp, "CreatedCommandProc2 in ", @@ -1421,11 +1504,11 @@ CreatedCommandProc2(clientData, interp, argc, argv) /* ARGSUSED */ static int -TestdcallCmd(dummy, interp, argc, argv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - CONST char **argv; /* Argument strings. */ +TestdcallCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int argc, /* Number of arguments. */ + const char **argv) /* Argument strings. */ { int i, id; @@ -1437,10 +1520,10 @@ TestdcallCmd(dummy, interp, argc, argv) } if (id < 0) { Tcl_DontCallWhenDeleted(delInterp, DelCallbackProc, - (ClientData) (-id)); + (ClientData) INT2PTR(-id)); } else { Tcl_CallWhenDeleted(delInterp, DelCallbackProc, - (ClientData) id); + (ClientData) INT2PTR(id)); } } Tcl_DeleteInterp(delInterp); @@ -1453,12 +1536,11 @@ TestdcallCmd(dummy, interp, argc, argv) */ static void -DelCallbackProc(clientData, interp) - ClientData clientData; /* Numerical value to append to - * delString. */ - Tcl_Interp *interp; /* Interpreter being deleted. */ +DelCallbackProc( + ClientData clientData, /* Numerical value to append to delString. */ + Tcl_Interp *interp) /* Interpreter being deleted. */ { - int id = (int) clientData; + int id = PTR2INT(clientData); char buffer[TCL_INTEGER_SPACE]; TclFormatInt(buffer, id); @@ -1473,25 +1555,25 @@ DelCallbackProc(clientData, interp) * * TestdelCmd -- * - * This procedure implements the "testdcall" command. It is used - * to test Tcl_CallWhenDeleted. + * This procedure implements the "testdel" command. It is used + * to test calling of command deletion callbacks. * * Results: * A standard Tcl result. * * Side effects: - * Creates and deletes interpreters. + * Creates a command. * *---------------------------------------------------------------------- */ /* ARGSUSED */ static int -TestdelCmd(dummy, interp, argc, argv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - CONST char **argv; /* Argument strings. */ +TestdelCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int argc, /* Number of arguments. */ + const char **argv) /* Argument strings. */ { DelCmd *dPtr; Tcl_Interp *slave; @@ -1506,9 +1588,9 @@ TestdelCmd(dummy, interp, argc, argv) return TCL_ERROR; } - dPtr = (DelCmd *) ckalloc(sizeof(DelCmd)); + dPtr = ckalloc(sizeof(DelCmd)); dPtr->interp = interp; - dPtr->deleteCmd = (char *) ckalloc((unsigned) (strlen(argv[3]) + 1)); + dPtr->deleteCmd = ckalloc(strlen(argv[3]) + 1); strcpy(dPtr->deleteCmd, argv[3]); Tcl_CreateCommand(slave, argv[2], DelCmdProc, (ClientData) dPtr, @@ -1517,30 +1599,30 @@ TestdelCmd(dummy, interp, argc, argv) } static int -DelCmdProc(clientData, interp, argc, argv) - ClientData clientData; /* String result to return. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - CONST char **argv; /* Argument strings. */ +DelCmdProc( + ClientData clientData, /* String result to return. */ + Tcl_Interp *interp, /* Current interpreter. */ + int argc, /* Number of arguments. */ + const char **argv) /* Argument strings. */ { DelCmd *dPtr = (DelCmd *) clientData; Tcl_AppendResult(interp, dPtr->deleteCmd, NULL); ckfree(dPtr->deleteCmd); - ckfree((char *) dPtr); + ckfree(dPtr); return TCL_OK; } static void -DelDeleteProc(clientData) - ClientData clientData; /* String command to evaluate. */ +DelDeleteProc( + ClientData clientData) /* String command to evaluate. */ { - DelCmd *dPtr = (DelCmd *) clientData; + DelCmd *dPtr = clientData; Tcl_Eval(dPtr->interp, dPtr->deleteCmd); Tcl_ResetResult(dPtr->interp); ckfree(dPtr->deleteCmd); - ckfree((char *) dPtr); + ckfree(dPtr); } /* @@ -1562,22 +1644,118 @@ DelDeleteProc(clientData) */ static int -TestdelassocdataCmd(clientData, interp, argc, argv) - ClientData clientData; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - CONST char **argv; /* Argument strings. */ +TestdelassocdataCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int argc, /* Number of arguments. */ + const char **argv) /* Argument strings. */ { if (argc != 2) { - Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], - " data_key\"", NULL); - return TCL_ERROR; + Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], + " data_key\"", NULL); + return TCL_ERROR; } Tcl_DeleteAssocData(interp, argv[1]); return TCL_OK; } /* + *----------------------------------------------------------------------------- + * + * TestdoubledigitsCmd -- + * + * This procedure implements the 'testdoubledigits' command. It is + * used to test the low-level floating-point formatting primitives + * in Tcl. + * + * Usage: + * testdoubledigits fpval ndigits type ?shorten" + * + * Parameters: + * fpval - Floating-point value to format. + * ndigits - Digit count to request from Tcl_DoubleDigits + * type - One of 'shortest', 'Steele', 'e', 'f' + * shorten - Indicates that the 'shorten' flag should be passed in. + * + *----------------------------------------------------------------------------- + */ + +static int +TestdoubledigitsObjCmd(ClientData unused, + /* NULL */ + Tcl_Interp* interp, + /* Tcl interpreter */ + int objc, + /* Parameter count */ + Tcl_Obj* const objv[]) + /* Parameter vector */ +{ + static const char* options[] = { + "shortest", + "Steele", + "e", + "f", + NULL + }; + static const int types[] = { + TCL_DD_SHORTEST, + TCL_DD_STEELE, + TCL_DD_E_FORMAT, + TCL_DD_F_FORMAT + }; + + const Tcl_ObjType* doubleType; + double d; + int status; + int ndigits; + int type; + int decpt; + int signum; + char* str; + char* endPtr; + Tcl_Obj* strObj; + Tcl_Obj* retval; + + if (objc < 4 || objc > 5) { + Tcl_WrongNumArgs(interp, 1, objv, "fpval ndigits type ?shorten?"); + return TCL_ERROR; + } + status = Tcl_GetDoubleFromObj(interp, objv[1], &d); + if (status != TCL_OK) { + doubleType = Tcl_GetObjType("double"); + if (objv[1]->typePtr == doubleType + || TclIsNaN(objv[1]->internalRep.doubleValue)) { + status = TCL_OK; + memcpy(&d, &(objv[1]->internalRep.doubleValue), sizeof(double)); + } + } + if (status != TCL_OK + || Tcl_GetIntFromObj(interp, objv[2], &ndigits) != TCL_OK + || Tcl_GetIndexFromObj(interp, objv[3], options, "conversion type", + TCL_EXACT, &type) != TCL_OK) { + fprintf(stderr, "bad value? %g\n", d); + return TCL_ERROR; + } + type = types[type]; + if (objc > 4) { + if (strcmp(Tcl_GetString(objv[4]), "shorten")) { + Tcl_SetObjResult(interp, Tcl_NewStringObj("bad flag", -1)); + return TCL_ERROR; + } + type |= TCL_DD_SHORTEN_FLAG; + } + str = TclDoubleDigits(d, ndigits, type, &decpt, &signum, &endPtr); + strObj = Tcl_NewStringObj(str, endPtr-str); + ckfree(str); + retval = Tcl_NewListObj(1, &strObj); + Tcl_ListObjAppendElement(NULL, retval, Tcl_NewIntObj(decpt)); + strObj = Tcl_NewStringObj(signum ? "-" : "+", 1); + Tcl_ListObjAppendElement(NULL, retval, strObj); + Tcl_SetObjResult(interp, retval); + return TCL_OK; +} + +/* *---------------------------------------------------------------------- * * TestdstringCmd -- @@ -1596,11 +1774,11 @@ TestdelassocdataCmd(clientData, interp, argc, argv) /* ARGSUSED */ static int -TestdstringCmd(dummy, interp, argc, argv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - CONST char **argv; /* Argument strings. */ +TestdstringCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int argc, /* Number of arguments. */ + const char **argv) /* Argument strings. */ { int count; @@ -1646,13 +1824,13 @@ TestdstringCmd(dummy, interp, argc, argv) } else if (strcmp(argv[2], "staticlarge") == 0) { Tcl_SetResult(interp, "first0 first1 first2 first3 first4 first5 first6 first7 first8 first9\nsecond0 second1 second2 second3 second4 second5 second6 second7 second8 second9\nthird0 third1 third2 third3 third4 third5 third6 third7 third8 third9\nfourth0 fourth1 fourth2 fourth3 fourth4 fourth5 fourth6 fourth7 fourth8 fourth9\nfifth0 fifth1 fifth2 fifth3 fifth4 fifth5 fifth6 fifth7 fifth8 fifth9\nsixth0 sixth1 sixth2 sixth3 sixth4 sixth5 sixth6 sixth7 sixth8 sixth9\nseventh0 seventh1 seventh2 seventh3 seventh4 seventh5 seventh6 seventh7 seventh8 seventh9\n", TCL_STATIC); } else if (strcmp(argv[2], "free") == 0) { - Tcl_SetResult(interp, (char *) ckalloc(100), TCL_DYNAMIC); - strcpy(interp->result, "This is a malloc-ed string"); + char *s = ckalloc(100); + strcpy(s, "This is a malloc-ed string"); + Tcl_SetResult(interp, s, TCL_DYNAMIC); } else if (strcmp(argv[2], "special") == 0) { - interp->result = (char *) ckalloc(100); - interp->result += 4; - interp->freeProc = SpecialFree; - strcpy(interp->result, "This is a specially-allocated string"); + char *s = (char*)ckalloc(100) + 16; + strcpy(s, "This is a specially-allocated string"); + Tcl_SetResult(interp, s, SpecialFree); } else { Tcl_AppendResult(interp, "bad gresult option \"", argv[2], "\": must be staticsmall, staticlarge, free, or special", @@ -1661,13 +1839,11 @@ TestdstringCmd(dummy, interp, argc, argv) } Tcl_DStringGetResult(interp, &dstring); } else if (strcmp(argv[1], "length") == 0) { - char buf[TCL_INTEGER_SPACE]; if (argc != 2) { goto wrongNumArgs; } - TclFormatInt(buf, Tcl_DStringLength(&dstring)); - Tcl_SetResult(interp, buf, TCL_VOLATILE); + Tcl_SetObjResult(interp, Tcl_NewIntObj(Tcl_DStringLength(&dstring))); } else if (strcmp(argv[1], "result") == 0) { if (argc != 2) { goto wrongNumArgs; @@ -1680,7 +1856,7 @@ TestdstringCmd(dummy, interp, argc, argv) if (Tcl_GetInt(interp, argv[2], &count) != TCL_OK) { return TCL_ERROR; } - Tcl_DStringTrunc(&dstring, count); + Tcl_DStringSetLength(&dstring, count); } else if (strcmp(argv[1], "start") == 0) { if (argc != 2) { goto wrongNumArgs; @@ -1688,7 +1864,7 @@ TestdstringCmd(dummy, interp, argc, argv) Tcl_DStringStartSublist(&dstring); } else { Tcl_AppendResult(interp, "bad option \"", argv[1], - "\": must be append, element, end, free, get, length, ", + "\": must be append, element, end, free, get, length, " "result, trunc, or start", NULL); return TCL_ERROR; } @@ -1703,7 +1879,7 @@ TestdstringCmd(dummy, interp, argc, argv) static void SpecialFree(blockPtr) char *blockPtr; /* Block to free. */ { - ckfree(blockPtr - 4); + ckfree(blockPtr - 16); } /* @@ -1725,22 +1901,21 @@ static void SpecialFree(blockPtr) /* ARGSUSED */ static int -TestencodingObjCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +TestencodingObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Encoding encoding; int index, length; - char *string; + const char *string; TclEncoding *encodingPtr; - static CONST char *optionStrings[] = { - "create", "delete", "path", - NULL + static const char *const optionStrings[] = { + "create", "delete", NULL }; enum options { - ENC_CREATE, ENC_DELETE, ENC_PATH + ENC_CREATE, ENC_DELETE }; if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0, @@ -1749,68 +1924,59 @@ TestencodingObjCmd(dummy, interp, objc, objv) } switch ((enum options) index) { - case ENC_CREATE: { - Tcl_EncodingType type; + case ENC_CREATE: { + Tcl_EncodingType type; - if (objc != 5) { - return TCL_ERROR; - } - encodingPtr = (TclEncoding *) ckalloc(sizeof(TclEncoding)); - encodingPtr->interp = interp; + if (objc != 5) { + return TCL_ERROR; + } + encodingPtr = ckalloc(sizeof(TclEncoding)); + encodingPtr->interp = interp; - string = Tcl_GetStringFromObj(objv[3], &length); - encodingPtr->toUtfCmd = (char *) ckalloc((unsigned) (length + 1)); - memcpy(encodingPtr->toUtfCmd, string, (unsigned) length + 1); + string = Tcl_GetStringFromObj(objv[3], &length); + encodingPtr->toUtfCmd = ckalloc(length + 1); + memcpy(encodingPtr->toUtfCmd, string, (unsigned) length + 1); - string = Tcl_GetStringFromObj(objv[4], &length); - encodingPtr->fromUtfCmd = (char *) ckalloc((unsigned) (length + 1)); - memcpy(encodingPtr->fromUtfCmd, string, (unsigned) (length + 1)); + string = Tcl_GetStringFromObj(objv[4], &length); + encodingPtr->fromUtfCmd = ckalloc(length + 1); + memcpy(encodingPtr->fromUtfCmd, string, (unsigned) (length + 1)); - string = Tcl_GetStringFromObj(objv[2], &length); + string = Tcl_GetStringFromObj(objv[2], &length); - type.encodingName = string; - type.toUtfProc = EncodingToUtfProc; - type.fromUtfProc = EncodingFromUtfProc; - type.freeProc = EncodingFreeProc; - type.clientData = (ClientData) encodingPtr; - type.nullSize = 1; + type.encodingName = string; + type.toUtfProc = EncodingToUtfProc; + type.fromUtfProc = EncodingFromUtfProc; + type.freeProc = EncodingFreeProc; + type.clientData = (ClientData) encodingPtr; + type.nullSize = 1; - Tcl_CreateEncoding(&type); - break; - } - case ENC_DELETE: { - if (objc != 3) { - return TCL_ERROR; - } - encoding = Tcl_GetEncoding(NULL, Tcl_GetString(objv[2])); - Tcl_FreeEncoding(encoding); - Tcl_FreeEncoding(encoding); - break; - } - case ENC_PATH: { - if (objc == 2) { - Tcl_SetObjResult(interp, TclGetEncodingSearchPath()); - } else { - TclSetEncodingSearchPath(objv[2]); - } - break; + Tcl_CreateEncoding(&type); + break; + } + case ENC_DELETE: + if (objc != 3) { + return TCL_ERROR; } + encoding = Tcl_GetEncoding(NULL, Tcl_GetString(objv[2])); + Tcl_FreeEncoding(encoding); + Tcl_FreeEncoding(encoding); + break; } return TCL_OK; } + static int -EncodingToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, - srcReadPtr, dstWrotePtr, dstCharsPtr) - ClientData clientData; /* TclEncoding structure. */ - CONST char *src; /* Source string in specified encoding. */ - int srcLen; /* Source string length in bytes. */ - int flags; /* Conversion control flags. */ - Tcl_EncodingState *statePtr;/* Current state. */ - char *dst; /* Output buffer. */ - int dstLen; /* The maximum length of output buffer. */ - int *srcReadPtr; /* Filled with number of bytes read. */ - int *dstWrotePtr; /* Filled with number of bytes stored. */ - int *dstCharsPtr; /* Filled with number of chars stored. */ +EncodingToUtfProc( + ClientData clientData, /* TclEncoding structure. */ + const char *src, /* Source string in specified encoding. */ + int srcLen, /* Source string length in bytes. */ + int flags, /* Conversion control flags. */ + Tcl_EncodingState *statePtr,/* Current state. */ + char *dst, /* Output buffer. */ + int dstLen, /* The maximum length of output buffer. */ + int *srcReadPtr, /* Filled with number of bytes read. */ + int *dstWrotePtr, /* Filled with number of bytes stored. */ + int *dstCharsPtr) /* Filled with number of chars stored. */ { int len; TclEncoding *encodingPtr; @@ -1830,19 +1996,19 @@ EncodingToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, *dstCharsPtr = len; return TCL_OK; } + static int -EncodingFromUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, - srcReadPtr, dstWrotePtr, dstCharsPtr) - ClientData clientData; /* TclEncoding structure. */ - CONST char *src; /* Source string in specified encoding. */ - int srcLen; /* Source string length in bytes. */ - int flags; /* Conversion control flags. */ - Tcl_EncodingState *statePtr;/* Current state. */ - char *dst; /* Output buffer. */ - int dstLen; /* The maximum length of output buffer. */ - int *srcReadPtr; /* Filled with number of bytes read. */ - int *dstWrotePtr; /* Filled with number of bytes stored. */ - int *dstCharsPtr; /* Filled with number of chars stored. */ +EncodingFromUtfProc( + ClientData clientData, /* TclEncoding structure. */ + const char *src, /* Source string in specified encoding. */ + int srcLen, /* Source string length in bytes. */ + int flags, /* Conversion control flags. */ + Tcl_EncodingState *statePtr,/* Current state. */ + char *dst, /* Output buffer. */ + int dstLen, /* The maximum length of output buffer. */ + int *srcReadPtr, /* Filled with number of bytes read. */ + int *dstWrotePtr, /* Filled with number of bytes stored. */ + int *dstCharsPtr) /* Filled with number of chars stored. */ { int len; TclEncoding *encodingPtr; @@ -1862,16 +2028,16 @@ EncodingFromUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, *dstCharsPtr = len; return TCL_OK; } + static void -EncodingFreeProc(clientData) - ClientData clientData; /* ClientData associated with type. */ +EncodingFreeProc( + ClientData clientData) /* ClientData associated with type. */ { - TclEncoding *encodingPtr; + TclEncoding *encodingPtr = clientData; - encodingPtr = (TclEncoding *) clientData; - ckfree((char *) encodingPtr->toUtfCmd); - ckfree((char *) encodingPtr->fromUtfCmd); - ckfree((char *) encodingPtr); + ckfree(encodingPtr->toUtfCmd); + ckfree(encodingPtr->fromUtfCmd); + ckfree(encodingPtr); } /* @@ -1892,18 +2058,18 @@ EncodingFreeProc(clientData) */ static int -TestevalexObjCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +TestevalexObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { int length, flags; - char *script; + const char *script; flags = 0; if (objc == 3) { - char *global = Tcl_GetStringFromObj(objv[2], &length); + const char *global = Tcl_GetStringFromObj(objv[2], &length); if (strcmp(global, "global") != 0) { Tcl_AppendResult(interp, "bad value \"", global, "\": must be global", NULL); @@ -1912,7 +2078,7 @@ TestevalexObjCmd(dummy, interp, objc, objv) flags = TCL_EVAL_GLOBAL; } else if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "script ?global?"); - return TCL_ERROR; + return TCL_ERROR; } script = Tcl_GetStringFromObj(objv[1], &length); @@ -1937,17 +2103,17 @@ TestevalexObjCmd(dummy, interp, objc, objv) */ static int -TestevalobjvObjCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +TestevalobjvObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { int evalGlobal; if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, "global word ?word ...?"); - return TCL_ERROR; + return TCL_ERROR; } if (Tcl_GetIntFromObj(interp, objv[1], &evalGlobal) != TCL_OK) { return TCL_ERROR; @@ -1986,74 +2152,67 @@ TestevalobjvObjCmd(dummy, interp, objc, objv) */ static int -TesteventObjCmd( ClientData unused, /* Not used */ - Tcl_Interp* interp, /* Tcl interpreter */ - int objc, /* Parameter count */ - Tcl_Obj *CONST objv[] ) /* Parameter vector */ -{ - - static CONST char* subcommands[] = { /* Possible subcommands */ - "queue", - "delete", - NULL +TesteventObjCmd( + ClientData unused, /* Not used */ + Tcl_Interp *interp, /* Tcl interpreter */ + int objc, /* Parameter count */ + Tcl_Obj *const objv[]) /* Parameter vector */ +{ + static const char *const subcommands[] = { /* Possible subcommands */ + "queue", "delete", NULL }; int subCmdIndex; /* Index of the chosen subcommand */ - static CONST char* positions[] = { /* Possible queue positions */ - "head", - "tail", - "mark", - NULL + static const char *const positions[] = { /* Possible queue positions */ + "head", "tail", "mark", NULL }; int posIndex; /* Index of the chosen position */ - static CONST Tcl_QueuePosition posNum[] = { + static const Tcl_QueuePosition posNum[] = { /* Interpretation of the chosen position */ TCL_QUEUE_HEAD, TCL_QUEUE_TAIL, TCL_QUEUE_MARK }; - TestEvent* ev; /* Event to be queued */ + TestEvent *ev; /* Event to be queued */ - if ( objc < 2 ) { - Tcl_WrongNumArgs( interp, 1, objv, "subcommand ?args?" ); + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?arg ...?"); return TCL_ERROR; } - if ( Tcl_GetIndexFromObj( interp, objv[1], subcommands, "subcommand", - TCL_EXACT, &subCmdIndex ) != TCL_OK ) { + if (Tcl_GetIndexFromObj(interp, objv[1], subcommands, "subcommand", + TCL_EXACT, &subCmdIndex) != TCL_OK) { return TCL_ERROR; } - switch ( subCmdIndex ) { + switch (subCmdIndex) { case 0: /* queue */ - if ( objc != 5 ) { - Tcl_WrongNumArgs( interp, 2, objv, "name position script" ); + if (objc != 5) { + Tcl_WrongNumArgs(interp, 2, objv, "name position script"); return TCL_ERROR; } - if ( Tcl_GetIndexFromObj( interp, objv[3], positions, - "position specifier", TCL_EXACT, - &posIndex ) != TCL_OK ) { + if (Tcl_GetIndexFromObj(interp, objv[3], positions, + "position specifier", TCL_EXACT, &posIndex) != TCL_OK) { return TCL_ERROR; } - ev = (TestEvent*) ckalloc( sizeof( TestEvent ) ); + ev = ckalloc(sizeof(TestEvent)); ev->header.proc = TesteventProc; ev->header.nextPtr = NULL; ev->interp = interp; - ev->command = objv[ 4 ]; - Tcl_IncrRefCount( ev->command ); - ev->tag = objv[ 2 ]; - Tcl_IncrRefCount( ev->tag ); - Tcl_QueueEvent( (Tcl_Event*) ev, posNum[ posIndex ] ); + ev->command = objv[4]; + Tcl_IncrRefCount(ev->command); + ev->tag = objv[2]; + Tcl_IncrRefCount(ev->tag); + Tcl_QueueEvent((Tcl_Event *) ev, posNum[posIndex]); break; case 1: /* delete */ - if ( objc != 3 ) { - Tcl_WrongNumArgs( interp, 2, objv, "name" ); + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "name"); return TCL_ERROR; } - Tcl_DeleteEvents( TesteventDeleteProc, objv[ 2 ] ); + Tcl_DeleteEvents(TesteventDeleteProc, objv[2]); break; } return TCL_OK; - } /* @@ -2077,31 +2236,33 @@ TesteventObjCmd( ClientData unused, /* Not used */ */ static int -TesteventProc( Tcl_Event* event, /* Event to deliver */ - int flags ) /* Current flags for Tcl_ServiceEvent */ +TesteventProc( + Tcl_Event *event, /* Event to deliver */ + int flags) /* Current flags for Tcl_ServiceEvent */ { - TestEvent * ev = (TestEvent *) event; - Tcl_Interp* interp = ev->interp; - Tcl_Obj* command = ev->command; + TestEvent *ev = (TestEvent *) event; + Tcl_Interp *interp = ev->interp; + Tcl_Obj *command = ev->command; int result = Tcl_EvalObjEx(interp, command, TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT); int retval; - if ( result != TCL_OK ) { - Tcl_AddErrorInfo( interp, - " (command bound to \"testevent\" callback)" ); - Tcl_BackgroundError( interp ); + + if (result != TCL_OK) { + Tcl_AddErrorInfo(interp, + " (command bound to \"testevent\" callback)"); + Tcl_BackgroundError(interp); return 1; /* Avoid looping on errors */ } if (Tcl_GetBooleanFromObj(interp, Tcl_GetObjResult(interp), &retval) != TCL_OK) { - Tcl_AddErrorInfo( interp, - " (return value from \"testevent\" callback)" ); - Tcl_BackgroundError( interp ); + Tcl_AddErrorInfo(interp, + " (return value from \"testevent\" callback)"); + Tcl_BackgroundError(interp); return 1; } - if ( retval ) { - Tcl_DecrRefCount( ev->tag ); - Tcl_DecrRefCount( ev->command ); + if (retval) { + Tcl_DecrRefCount(ev->tag); + Tcl_DecrRefCount(ev->command); } return retval; @@ -2126,25 +2287,26 @@ TesteventProc( Tcl_Event* event, /* Event to deliver */ */ static int -TesteventDeleteProc( Tcl_Event* event, /* Event to examine */ - ClientData clientData ) /* Tcl_Obj containing the name - * of the event(s) to remove */ +TesteventDeleteProc( + Tcl_Event *event, /* Event to examine */ + ClientData clientData) /* Tcl_Obj containing the name of the event(s) + * to remove */ { - TestEvent* ev; /* Event to examine */ - char* evNameStr; - Tcl_Obj* targetName; /* Name of the event(s) to delete */ - char* targetNameStr; + TestEvent *ev; /* Event to examine */ + const char *evNameStr; + Tcl_Obj *targetName; /* Name of the event(s) to delete */ + const char *targetNameStr; - if ( event->proc != TesteventProc ) { + if (event->proc != TesteventProc) { return 0; } - targetName = (Tcl_Obj*) clientData; - targetNameStr = (char*) Tcl_GetStringFromObj( targetName, NULL ); - ev = (TestEvent*) event; - evNameStr = Tcl_GetStringFromObj( ev->tag, NULL ); - if ( strcmp( evNameStr, targetNameStr ) == 0 ) { - Tcl_DecrRefCount( ev->tag ); - Tcl_DecrRefCount( ev->command ); + targetName = (Tcl_Obj *) clientData; + targetNameStr = (char *) Tcl_GetStringFromObj(targetName, NULL); + ev = (TestEvent *) event; + evNameStr = Tcl_GetStringFromObj(ev->tag, NULL); + if (strcmp(evNameStr, targetNameStr) == 0) { + Tcl_DecrRefCount(ev->tag); + Tcl_DecrRefCount(ev->command); return 1; } else { return 0; @@ -2169,28 +2331,28 @@ TesteventDeleteProc( Tcl_Event* event, /* Event to examine */ */ static int -TestexithandlerCmd(clientData, interp, argc, argv) - ClientData clientData; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - CONST char **argv; /* Argument strings. */ +TestexithandlerCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int argc, /* Number of arguments. */ + const char **argv) /* Argument strings. */ { int value; if (argc != 3) { Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], - " create|delete value\"", NULL); - return TCL_ERROR; + " create|delete value\"", NULL); + return TCL_ERROR; } if (Tcl_GetInt(interp, argv[2], &value) != TCL_OK) { return TCL_ERROR; } if (strcmp(argv[1], "create") == 0) { Tcl_CreateExitHandler((value & 1) ? ExitProcOdd : ExitProcEven, - (ClientData) value); + (ClientData) INT2PTR(value)); } else if (strcmp(argv[1], "delete") == 0) { Tcl_DeleteExitHandler((value & 1) ? ExitProcOdd : ExitProcEven, - (ClientData) value); + (ClientData) INT2PTR(value)); } else { Tcl_AppendResult(interp, "bad option \"", argv[1], "\": must be create or delete", NULL); @@ -2200,23 +2362,31 @@ TestexithandlerCmd(clientData, interp, argc, argv) } static void -ExitProcOdd(clientData) - ClientData clientData; /* Integer value to print. */ +ExitProcOdd( + ClientData clientData) /* Integer value to print. */ { char buf[16 + TCL_INTEGER_SPACE]; + size_t len; - sprintf(buf, "odd %d\n", (int) clientData); - write(1, buf, strlen(buf)); + sprintf(buf, "odd %d\n", PTR2INT(clientData)); + len = strlen(buf); + if (len != (size_t) write(1, buf, len)) { + Tcl_Panic("ExitProcOdd: unable to write to stdout"); + } } static void -ExitProcEven(clientData) - ClientData clientData; /* Integer value to print. */ +ExitProcEven( + ClientData clientData) /* Integer value to print. */ { char buf[16 + TCL_INTEGER_SPACE]; + size_t len; - sprintf(buf, "even %d\n", (int) clientData); - write(1, buf, strlen(buf)); + sprintf(buf, "even %d\n", PTR2INT(clientData)); + len = strlen(buf); + if (len != (size_t) write(1, buf, len)) { + Tcl_Panic("ExitProcEven: unable to write to stdout"); + } } /* @@ -2237,25 +2407,25 @@ ExitProcEven(clientData) */ static int -TestexprlongCmd(clientData, interp, argc, argv) - ClientData clientData; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - CONST char **argv; /* Argument strings. */ +TestexprlongCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int argc, /* Number of arguments. */ + const char **argv) /* Argument strings. */ { long exprResult; char buf[4 + TCL_INTEGER_SPACE]; int result; if (argc != 2) { - Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], - " expression\"", NULL); - return TCL_ERROR; + Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], + " expression\"", NULL); + return TCL_ERROR; } Tcl_SetResult(interp, "This is a result", TCL_STATIC); result = Tcl_ExprLong(interp, argv[1], &exprResult); if (result != TCL_OK) { - return result; + return result; } sprintf(buf, ": %ld", exprResult); Tcl_AppendResult(interp, buf, NULL); @@ -2280,11 +2450,11 @@ TestexprlongCmd(clientData, interp, argc, argv) */ static int -TestexprlongobjCmd(clientData, interp, objc, objv) - ClientData clientData; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST *objv; /* Argument objects. */ +TestexprlongobjCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const *objv) /* Argument objects. */ { long exprResult; char buf[4 + TCL_INTEGER_SPACE]; @@ -2297,7 +2467,7 @@ TestexprlongobjCmd(clientData, interp, objc, objv) Tcl_SetResult(interp, "This is a result", TCL_STATIC); result = Tcl_ExprLongObj(interp, objv[1], &exprResult); if (result != TCL_OK) { - return result; + return result; } sprintf(buf, ": %ld", exprResult); Tcl_AppendResult(interp, buf, NULL); @@ -2322,25 +2492,25 @@ TestexprlongobjCmd(clientData, interp, objc, objv) */ static int -TestexprdoubleCmd(clientData, interp, argc, argv) - ClientData clientData; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - CONST char **argv; /* Argument strings. */ +TestexprdoubleCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int argc, /* Number of arguments. */ + const char **argv) /* Argument strings. */ { double exprResult; char buf[4 + TCL_DOUBLE_SPACE]; int result; if (argc != 2) { - Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], - " expression\"", NULL); - return TCL_ERROR; + Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], + " expression\"", NULL); + return TCL_ERROR; } Tcl_SetResult(interp, "This is a result", TCL_STATIC); result = Tcl_ExprDouble(interp, argv[1], &exprResult); if (result != TCL_OK) { - return result; + return result; } strcpy(buf, ": "); Tcl_PrintDouble(interp, exprResult, buf+2); @@ -2366,11 +2536,11 @@ TestexprdoubleCmd(clientData, interp, argc, argv) */ static int -TestexprdoubleobjCmd(clientData, interp, objc, objv) - ClientData clientData; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST *objv; /* Argument objects. */ +TestexprdoubleobjCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const *objv) /* Argument objects. */ { double exprResult; char buf[4 + TCL_DOUBLE_SPACE]; @@ -2383,7 +2553,7 @@ TestexprdoubleobjCmd(clientData, interp, objc, objv) Tcl_SetResult(interp, "This is a result", TCL_STATIC); result = Tcl_ExprDoubleObj(interp, objv[1], &exprResult); if (result != TCL_OK) { - return result; + return result; } strcpy(buf, ": "); Tcl_PrintDouble(interp, exprResult, buf+2); @@ -2408,16 +2578,16 @@ TestexprdoubleobjCmd(clientData, interp, objc, objv) */ static int -TestexprstringCmd(clientData, interp, argc, argv) - ClientData clientData; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - CONST char **argv; /* Argument strings. */ +TestexprstringCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int argc, /* Number of arguments. */ + const char **argv) /* Argument strings. */ { if (argc != 2) { - Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], - " expression\"", NULL); - return TCL_ERROR; + Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], + " expression\"", NULL); + return TCL_ERROR; } return Tcl_ExprString(interp, argv[1]); } @@ -2440,11 +2610,11 @@ TestexprstringCmd(clientData, interp, argc, argv) */ static int -TestfilelinkCmd(clientData, interp, objc, objv) - ClientData clientData; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* The argument objects. */ +TestfilelinkCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* The argument objects. */ { Tcl_Obj *contents; @@ -2460,7 +2630,7 @@ TestfilelinkCmd(clientData, interp, objc, objv) if (objc == 3) { /* Create link from source to target */ contents = Tcl_FSLink(objv[1], objv[2], - TCL_CREATE_SYMBOLIC_LINK|TCL_CREATE_HARD_LINK); + TCL_CREATE_SYMBOLIC_LINK|TCL_CREATE_HARD_LINK); if (contents == NULL) { Tcl_AppendResult(interp, "could not create link from \"", Tcl_GetString(objv[1]), "\" to \"", @@ -2507,22 +2677,22 @@ TestfilelinkCmd(clientData, interp, objc, objv) */ static int -TestgetassocdataCmd(clientData, interp, argc, argv) - ClientData clientData; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - CONST char **argv; /* Argument strings. */ +TestgetassocdataCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int argc, /* Number of arguments. */ + const char **argv) /* Argument strings. */ { char *res; if (argc != 2) { - Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], - " data_key\"", NULL); - return TCL_ERROR; + Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], + " data_key\"", NULL); + return TCL_ERROR; } res = (char *) Tcl_GetAssocData(interp, argv[1], NULL); if (res != NULL) { - Tcl_AppendResult(interp, res, NULL); + Tcl_AppendResult(interp, res, NULL); } return TCL_OK; } @@ -2545,21 +2715,21 @@ TestgetassocdataCmd(clientData, interp, argc, argv) */ static int -TestgetplatformCmd(clientData, interp, argc, argv) - ClientData clientData; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - CONST char **argv; /* Argument strings. */ +TestgetplatformCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int argc, /* Number of arguments. */ + const char **argv) /* Argument strings. */ { - static CONST char *platformStrings[] = { "unix", "mac", "windows" }; + static const char *const platformStrings[] = { "unix", "mac", "windows" }; TclPlatformType *platform; platform = TclGetPlatform(); if (argc != 1) { - Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], + Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], NULL); - return TCL_ERROR; + return TCL_ERROR; } Tcl_AppendResult(interp, platformStrings[*platform], NULL); @@ -2586,22 +2756,22 @@ TestgetplatformCmd(clientData, interp, argc, argv) /* ARGSUSED */ static int -TestinterpdeleteCmd(dummy, interp, argc, argv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - CONST char **argv; /* Argument strings. */ +TestinterpdeleteCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int argc, /* Number of arguments. */ + const char **argv) /* Argument strings. */ { Tcl_Interp *slaveToDelete; if (argc != 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " path\"", NULL); - return TCL_ERROR; + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " path\"", NULL); + return TCL_ERROR; } slaveToDelete = Tcl_GetSlave(interp, argv[1]); if (slaveToDelete == NULL) { - return TCL_ERROR; + return TCL_ERROR; } Tcl_DeleteInterp(slaveToDelete); return TCL_OK; @@ -2627,11 +2797,11 @@ TestinterpdeleteCmd(dummy, interp, argc, argv) /* ARGSUSED */ static int -TestlinkCmd(dummy, interp, argc, argv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - CONST char **argv; /* Argument strings. */ +TestlinkCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int argc, /* Number of arguments. */ + const char **argv) /* Argument strings. */ { static int intVar = 43; static int boolVar = 4; @@ -2654,7 +2824,7 @@ TestlinkCmd(dummy, interp, argc, argv) if (argc < 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " option ?arg arg arg arg arg arg arg arg arg arg arg arg", + " option ?arg arg arg arg arg arg arg arg arg arg arg arg" " arg arg?\"", NULL); return TCL_ERROR; } @@ -2662,7 +2832,7 @@ TestlinkCmd(dummy, interp, argc, argv) if (argc != 16) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " ", argv[1], - " intRO realRO boolRO stringRO wideRO charRO ucharRO shortRO", + " intRO realRO boolRO stringRO wideRO charRO ucharRO shortRO" " ushortRO uintRO longRO ulongRO floatRO uwideRO\"", NULL); return TCL_ERROR; } @@ -2853,8 +3023,8 @@ TestlinkCmd(dummy, interp, argc, argv) if (argc != 16) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " ", argv[1], - " intValue realValue boolValue stringValue wideValue", - " charValue ucharValue shortValue ushortValue uintValue", + " intValue realValue boolValue stringValue wideValue" + " charValue ucharValue shortValue ushortValue uintValue" " longValue ulongValue floatValue uwideValue\"", NULL); return TCL_ERROR; } @@ -2880,7 +3050,7 @@ TestlinkCmd(dummy, interp, argc, argv) if (strcmp(argv[5], "-") == 0) { stringVar = NULL; } else { - stringVar = (char *) ckalloc((unsigned) (strlen(argv[5]) + 1)); + stringVar = ckalloc(strlen(argv[5]) + 1); strcpy(stringVar, argv[5]); } } @@ -2957,8 +3127,8 @@ TestlinkCmd(dummy, interp, argc, argv) if (argc != 16) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " ", argv[1], - " intValue realValue boolValue stringValue wideValue", - " charValue ucharValue shortValue ushortValue uintValue", + " intValue realValue boolValue stringValue wideValue" + " charValue ucharValue shortValue ushortValue uintValue" " longValue ulongValue floatValue uwideValue\"", NULL); return TCL_ERROR; } @@ -2987,7 +3157,7 @@ TestlinkCmd(dummy, interp, argc, argv) if (strcmp(argv[5], "-") == 0) { stringVar = NULL; } else { - stringVar = (char *) ckalloc((unsigned) (strlen(argv[5]) + 1)); + stringVar = ckalloc(strlen(argv[5]) + 1); strcpy(stringVar, argv[5]); } Tcl_UpdateLinkedVar(interp, "string"); @@ -3095,20 +3265,20 @@ TestlinkCmd(dummy, interp, argc, argv) */ static int -TestlocaleCmd(clientData, interp, objc, objv) - ClientData clientData; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* The argument objects. */ +TestlocaleCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* The argument objects. */ { int index; - char *locale; + const char *locale; - static CONST char *optionStrings[] = { - "ctype", "numeric", "time", "collate", "monetary", + static const char *const optionStrings[] = { + "ctype", "numeric", "time", "collate", "monetary", "all", NULL }; - static int lcTypes[] = { + static const int lcTypes[] = { LC_CTYPE, LC_NUMERIC, LC_TIME, LC_COLLATE, LC_MONETARY, LC_ALL }; @@ -3158,14 +3328,14 @@ TestlocaleCmd(clientData, interp, objc, objv) /* ARGSUSED */ static int -TestMathFunc(clientData, interp, args, resultPtr) - ClientData clientData; /* Integer value to return. */ - Tcl_Interp *interp; /* Not used. */ - Tcl_Value *args; /* Not used. */ - Tcl_Value *resultPtr; /* Where to store result. */ +TestMathFunc( + ClientData clientData, /* Integer value to return. */ + Tcl_Interp *interp, /* Not used. */ + Tcl_Value *args, /* Not used. */ + Tcl_Value *resultPtr) /* Where to store result. */ { resultPtr->type = TCL_INT; - resultPtr->intValue = (int) clientData; + resultPtr->intValue = PTR2INT(clientData); return TCL_OK; } @@ -3188,13 +3358,12 @@ TestMathFunc(clientData, interp, args, resultPtr) /* ARGSUSED */ static int -TestMathFunc2(clientData, interp, args, resultPtr) - ClientData clientData; /* Integer value to return. */ - Tcl_Interp *interp; /* Used to report errors. */ - Tcl_Value *args; /* Points to an array of two - * Tcl_Value structs for the - * two arguments. */ - Tcl_Value *resultPtr; /* Where to store the result. */ +TestMathFunc2( + ClientData clientData, /* Integer value to return. */ + Tcl_Interp *interp, /* Used to report errors. */ + Tcl_Value *args, /* Points to an array of two Tcl_Value structs + * for the two arguments. */ + Tcl_Value *resultPtr) /* Where to store the result. */ { int result = TCL_OK; @@ -3296,11 +3465,11 @@ TestMathFunc2(clientData, interp, args, resultPtr) */ /* ARGSUSED */ static void -CleanupTestSetassocdataTests(clientData, interp) - ClientData clientData; /* Data to be released. */ - Tcl_Interp *interp; /* Interpreter being deleted. */ +CleanupTestSetassocdataTests( + ClientData clientData, /* Data to be released. */ + Tcl_Interp *interp) /* Interpreter being deleted. */ { - ckfree((char *) clientData); + ckfree(clientData); } /* @@ -3321,13 +3490,13 @@ CleanupTestSetassocdataTests(clientData, interp) */ static int -TestparserObjCmd(clientData, interp, objc, objv) - ClientData clientData; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* The argument objects. */ +TestparserObjCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* The argument objects. */ { - char *script; + const char *script; int length, dummy; Tcl_Parse parse; @@ -3377,13 +3546,13 @@ TestparserObjCmd(clientData, interp, objc, objv) */ static int -TestexprparserObjCmd(clientData, interp, objc, objv) - ClientData clientData; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* The argument objects. */ +TestexprparserObjCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* The argument objects. */ { - char *script; + const char *script; int length, dummy; Tcl_Parse parse; @@ -3438,13 +3607,13 @@ TestexprparserObjCmd(clientData, interp, objc, objv) */ static void -PrintParse(interp, parsePtr) - Tcl_Interp *interp; /* Interpreter whose result is to be set to +PrintParse( + Tcl_Interp *interp, /* Interpreter whose result is to be set to * the contents of a parse structure. */ - Tcl_Parse *parsePtr; /* Parse structure to print out. */ + Tcl_Parse *parsePtr) /* Parse structure to print out. */ { Tcl_Obj *objPtr; - char *typeString; + const char *typeString; Tcl_Token *tokenPtr; int i; @@ -3463,36 +3632,36 @@ PrintParse(interp, parsePtr) for (i = 0; i < parsePtr->numTokens; i++) { tokenPtr = &parsePtr->tokenPtr[i]; switch (tokenPtr->type) { - case TCL_TOKEN_EXPAND_WORD: - typeString = "expand"; - break; - case TCL_TOKEN_WORD: - typeString = "word"; - break; - case TCL_TOKEN_SIMPLE_WORD: - typeString = "simple"; - break; - case TCL_TOKEN_TEXT: - typeString = "text"; - break; - case TCL_TOKEN_BS: - typeString = "backslash"; - break; - case TCL_TOKEN_COMMAND: - typeString = "command"; - break; - case TCL_TOKEN_VARIABLE: - typeString = "variable"; - break; - case TCL_TOKEN_SUB_EXPR: - typeString = "subexpr"; - break; - case TCL_TOKEN_OPERATOR: - typeString = "operator"; - break; - default: - typeString = "??"; - break; + case TCL_TOKEN_EXPAND_WORD: + typeString = "expand"; + break; + case TCL_TOKEN_WORD: + typeString = "word"; + break; + case TCL_TOKEN_SIMPLE_WORD: + typeString = "simple"; + break; + case TCL_TOKEN_TEXT: + typeString = "text"; + break; + case TCL_TOKEN_BS: + typeString = "backslash"; + break; + case TCL_TOKEN_COMMAND: + typeString = "command"; + break; + case TCL_TOKEN_VARIABLE: + typeString = "variable"; + break; + case TCL_TOKEN_SUB_EXPR: + typeString = "subexpr"; + break; + case TCL_TOKEN_OPERATOR: + typeString = "operator"; + break; + default: + typeString = "??"; + break; } Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewStringObj(typeString, -1)); @@ -3524,14 +3693,13 @@ PrintParse(interp, parsePtr) */ static int -TestparsevarObjCmd(clientData, interp, objc, objv) - ClientData clientData; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* The argument objects. */ +TestparsevarObjCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* The argument objects. */ { - CONST char *value; - CONST char *name, *termPtr; + const char *value, *name, *termPtr; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "varName"); @@ -3566,13 +3734,13 @@ TestparsevarObjCmd(clientData, interp, objc, objv) */ static int -TestparsevarnameObjCmd(clientData, interp, objc, objv) - ClientData clientData; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* The argument objects. */ +TestparsevarnameObjCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* The argument objects. */ { - char *script; + const char *script; int append, length, dummy; Tcl_Parse parse; @@ -3631,19 +3799,19 @@ TestparsevarnameObjCmd(clientData, interp, objc, objv) /* ARGSUSED */ static int -TestregexpObjCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +TestregexpObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { int i, ii, indices, stringLength, match, about; int hasxflags, cflags, eflags; Tcl_RegExp regExpr; - char *string; + const char *string; Tcl_Obj *objPtr; Tcl_RegExpInfo info; - static CONST char *options[] = { + static const char *const options[] = { "-indices", "-nocase", "-about", "-expanded", "-line", "-linestop", "-lineanchor", "-xflags", @@ -3663,7 +3831,7 @@ TestregexpObjCmd(dummy, interp, objc, objv) hasxflags = 0; for (i = 1; i < objc; i++) { - char *name; + const char *name; int index; name = Tcl_GetString(objv[i]); @@ -3675,49 +3843,40 @@ TestregexpObjCmd(dummy, interp, objc, objv) return TCL_ERROR; } switch ((enum options) index) { - case REGEXP_INDICES: { - indices = 1; - break; - } - case REGEXP_NOCASE: { - cflags |= REG_ICASE; - break; - } - case REGEXP_ABOUT: { - about = 1; - break; - } - case REGEXP_EXPANDED: { - cflags |= REG_EXPANDED; - break; - } - case REGEXP_MULTI: { - cflags |= REG_NEWLINE; - break; - } - case REGEXP_NOCROSS: { - cflags |= REG_NLSTOP; - break; - } - case REGEXP_NEWL: { - cflags |= REG_NLANCH; - break; - } - case REGEXP_XFLAGS: { - hasxflags = 1; - break; - } - case REGEXP_LAST: { - i++; - goto endOfForLoop; - } + case REGEXP_INDICES: + indices = 1; + break; + case REGEXP_NOCASE: + cflags |= REG_ICASE; + break; + case REGEXP_ABOUT: + about = 1; + break; + case REGEXP_EXPANDED: + cflags |= REG_EXPANDED; + break; + case REGEXP_MULTI: + cflags |= REG_NEWLINE; + break; + case REGEXP_NOCROSS: + cflags |= REG_NLSTOP; + break; + case REGEXP_NEWL: + cflags |= REG_NLANCH; + break; + case REGEXP_XFLAGS: + hasxflags = 1; + break; + case REGEXP_LAST: + i++; + goto endOfForLoop; } } - endOfForLoop: + endOfForLoop: if (objc - i < hasxflags + 2 - about) { Tcl_WrongNumArgs(interp, 1, objv, - "?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?"); + "?-switch ...? exp string ?matchVar? ?subMatchVar ...?"); return TCL_ERROR; } objc -= i; @@ -3734,7 +3893,6 @@ TestregexpObjCmd(dummy, interp, objc, objv) if (regExpr == NULL) { return TCL_ERROR; } - objPtr = objv[1]; if (about) { if (TclRegAbout(interp, regExpr) < 0) { @@ -3743,6 +3901,7 @@ TestregexpObjCmd(dummy, interp, objc, objv) return TCL_OK; } + objPtr = objv[1]; match = Tcl_RegExpExecObj(interp, regExpr, objPtr, 0 /* offset */, objc-2 /* nmatches */, eflags); @@ -3757,8 +3916,8 @@ TestregexpObjCmd(dummy, interp, objc, objv) Tcl_SetIntObj(Tcl_GetObjResult(interp), 0); if (objc > 2 && (cflags®_EXPECT) && indices) { - char *varName; - CONST char *value; + const char *varName; + const char *value; int start, end; char resinfo[TCL_INTEGER_SPACE * 2]; @@ -3772,8 +3931,8 @@ TestregexpObjCmd(dummy, interp, objc, objv) return TCL_ERROR; } } else if (cflags & TCL_REG_CANMATCH) { - char *varName; - CONST char *value; + const char *varName; + const char *value; char resinfo[TCL_INTEGER_SPACE * 2]; Tcl_RegExpGetInfo(regExpr, &info); @@ -3841,10 +4000,8 @@ TestregexpObjCmd(dummy, interp, objc, objv) info.matches[ii].end - 1); } } - valuePtr = Tcl_ObjSetVar2(interp, varPtr, NULL, newPtr, 0); + valuePtr = Tcl_ObjSetVar2(interp, varPtr, NULL, newPtr, TCL_LEAVE_ERR_MSG); if (valuePtr == NULL) { - Tcl_AppendResult(interp, "couldn't set variable \"", - Tcl_GetString(varPtr), "\"", NULL); return TCL_ERROR; } } @@ -3875,86 +4032,68 @@ TestregexpObjCmd(dummy, interp, objc, objv) */ static void -TestregexpXflags(string, length, cflagsPtr, eflagsPtr) - char *string; /* The string of flags. */ - int length; /* The length of the string in bytes. */ - int *cflagsPtr; /* compile flags word */ - int *eflagsPtr; /* exec flags word */ +TestregexpXflags( + const char *string, /* The string of flags. */ + int length, /* The length of the string in bytes. */ + int *cflagsPtr, /* compile flags word */ + int *eflagsPtr) /* exec flags word */ { - int i; - int cflags; - int eflags; + int i, cflags, eflags; cflags = *cflagsPtr; eflags = *eflagsPtr; for (i = 0; i < length; i++) { switch (string[i]) { - case 'a': { - cflags |= REG_ADVF; - break; - } - case 'b': { - cflags &= ~REG_ADVANCED; - break; - } - case 'c': { - cflags |= TCL_REG_CANMATCH; - break; - } - case 'e': { - cflags &= ~REG_ADVANCED; - cflags |= REG_EXTENDED; - break; - } - case 'q': { - cflags &= ~REG_ADVANCED; - cflags |= REG_QUOTE; - break; - } - case 'o': { /* o for opaque */ - cflags |= REG_NOSUB; - break; - } - case 's': { /* s for start */ - cflags |= REG_BOSONLY; - break; - } - case '+': { - cflags |= REG_FAKE; - break; - } - case ',': { - cflags |= REG_PROGRESS; - break; - } - case '.': { - cflags |= REG_DUMP; - break; - } - case ':': { - eflags |= REG_MTRACE; - break; - } - case ';': { - eflags |= REG_FTRACE; - break; - } - case '^': { - eflags |= REG_NOTBOL; - break; - } - case '$': { - eflags |= REG_NOTEOL; - break; - } - case 't': { - cflags |= REG_EXPECT; - break; - } - case '%': { - eflags |= REG_SMALL; - break; - } + case 'a': + cflags |= REG_ADVF; + break; + case 'b': + cflags &= ~REG_ADVANCED; + break; + case 'c': + cflags |= TCL_REG_CANMATCH; + break; + case 'e': + cflags &= ~REG_ADVANCED; + cflags |= REG_EXTENDED; + break; + case 'q': + cflags &= ~REG_ADVANCED; + cflags |= REG_QUOTE; + break; + case 'o': /* o for opaque */ + cflags |= REG_NOSUB; + break; + case 's': /* s for start */ + cflags |= REG_BOSONLY; + break; + case '+': + cflags |= REG_FAKE; + break; + case ',': + cflags |= REG_PROGRESS; + break; + case '.': + cflags |= REG_DUMP; + break; + case ':': + eflags |= REG_MTRACE; + break; + case ';': + eflags |= REG_FTRACE; + break; + case '^': + eflags |= REG_NOTBOL; + break; + case '$': + eflags |= REG_NOTEOL; + break; + case 't': + cflags |= REG_EXPECT; + break; + case '%': + eflags |= REG_SMALL; + break; } } @@ -3984,11 +4123,11 @@ TestregexpXflags(string, length, cflagsPtr, eflagsPtr) /* ARGSUSED */ static int -TestreturnObjCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +TestreturnObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { return TCL_RETURN; } @@ -4012,23 +4151,22 @@ TestreturnObjCmd(dummy, interp, objc, objv) */ static int -TestsetassocdataCmd(clientData, interp, argc, argv) - ClientData clientData; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - CONST char **argv; /* Argument strings. */ -{ - char *buf; - char *oldData; +TestsetassocdataCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int argc, /* Number of arguments. */ + const char **argv) /* Argument strings. */ +{ + char *buf, *oldData; Tcl_InterpDeleteProc *procPtr; if (argc != 3) { - Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], - " data_key data_item\"", NULL); - return TCL_ERROR; + Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], + " data_key data_item\"", NULL); + return TCL_ERROR; } - buf = ckalloc((unsigned) strlen(argv[2]) + 1); + buf = ckalloc(strlen(argv[2]) + 1); strcpy(buf, argv[2]); /* @@ -4065,11 +4203,11 @@ TestsetassocdataCmd(clientData, interp, argc, argv) */ static int -TestsetplatformCmd(clientData, interp, argc, argv) - ClientData clientData; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - CONST char **argv; /* Argument strings. */ +TestsetplatformCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int argc, /* Number of arguments. */ + const char **argv) /* Argument strings. */ { size_t length; TclPlatformType *platform; @@ -4077,9 +4215,9 @@ TestsetplatformCmd(clientData, interp, argc, argv) platform = TclGetPlatform(); if (argc != 2) { - Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], - " platform\"", NULL); - return TCL_ERROR; + Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], + " platform\"", NULL); + return TCL_ERROR; } length = strlen(argv[1]); @@ -4088,7 +4226,7 @@ TestsetplatformCmd(clientData, interp, argc, argv) } else if (strncmp(argv[1], "windows", length) == 0) { *platform = TCL_PLATFORM_WINDOWS; } else { - Tcl_AppendResult(interp, "unsupported platform: should be one of ", + Tcl_AppendResult(interp, "unsupported platform: should be one of " "unix, or windows", NULL); return TCL_ERROR; } @@ -4114,11 +4252,11 @@ TestsetplatformCmd(clientData, interp, argc, argv) */ static int -TeststaticpkgCmd(dummy, interp, argc, argv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - CONST char **argv; /* Argument strings. */ +TeststaticpkgCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int argc, /* Number of arguments. */ + const char **argv) /* Argument strings. */ { int safe, loaded; @@ -4133,15 +4271,15 @@ TeststaticpkgCmd(dummy, interp, argc, argv) if (Tcl_GetInt(interp, argv[3], &loaded) != TCL_OK) { return TCL_ERROR; } - Tcl_StaticPackage((loaded) ? interp : NULL, argv[1], StaticInitProc, - (safe) ? StaticInitProc : NULL); + tclStubsPtr->tcl_StaticPackage((loaded) ? interp : NULL, argv[1], + StaticInitProc, (safe) ? StaticInitProc : NULL); return TCL_OK; } static int -StaticInitProc(interp) - Tcl_Interp *interp; /* Interpreter in which package - * is supposedly being loaded. */ +StaticInitProc( + Tcl_Interp *interp) /* Interpreter in which package is supposedly + * being loaded. */ { Tcl_SetVar(interp, "x", "loaded", TCL_GLOBAL_ONLY); return TCL_OK; @@ -4165,14 +4303,14 @@ StaticInitProc(interp) */ static int -TesttranslatefilenameCmd(dummy, interp, argc, argv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - CONST char **argv; /* Argument strings. */ +TesttranslatefilenameCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int argc, /* Number of arguments. */ + const char **argv) /* Argument strings. */ { Tcl_DString buffer; - CONST char *result; + const char *result; if (argc != 2) { Tcl_AppendResult(interp, "wrong # arguments: should be \"", @@ -4207,11 +4345,11 @@ TesttranslatefilenameCmd(dummy, interp, argc, argv) /* ARGSUSED */ static int -TestupvarCmd(dummy, interp, argc, argv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - CONST char **argv; /* Argument strings. */ +TestupvarCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int argc, /* Number of arguments. */ + const char **argv) /* Argument strings. */ { int flags = 0; @@ -4260,18 +4398,36 @@ TestupvarCmd(dummy, interp, argc, argv) /* ARGSUSED */ static int -TestseterrorcodeCmd(dummy, interp, argc, argv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - CONST char **argv; /* Argument strings. */ +TestseterrorcodeCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int argc, /* Number of arguments. */ + const char **argv) /* Argument strings. */ { if (argc > 6) { Tcl_SetResult(interp, "too many args", TCL_STATIC); return TCL_ERROR; } - Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], argv[4], - argv[5], NULL); + switch (argc) { + case 1: + Tcl_SetErrorCode(interp, "NONE", NULL); + break; + case 2: + Tcl_SetErrorCode(interp, argv[1], NULL); + break; + case 3: + Tcl_SetErrorCode(interp, argv[1], argv[2], NULL); + break; + case 4: + Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], NULL); + break; + case 5: + Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], argv[4], NULL); + break; + case 6: + Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], argv[4], + argv[5], NULL); + } return TCL_ERROR; } @@ -4295,11 +4451,11 @@ TestseterrorcodeCmd(dummy, interp, argc, argv) /* ARGSUSED */ static int -TestsetobjerrorcodeCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* The argument objects. */ +TestsetobjerrorcodeCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* The argument objects. */ { Tcl_SetObjErrorCode(interp, Tcl_ConcatObj(objc - 1, objv + 1)); return TCL_ERROR; @@ -4324,11 +4480,11 @@ TestsetobjerrorcodeCmd(dummy, interp, objc, objv) /* ARGSUSED */ static int -TestfeventCmd(clientData, interp, argc, argv) - ClientData clientData; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - CONST char **argv; /* Argument strings. */ +TestfeventCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int argc, /* Number of arguments. */ + const char **argv) /* Argument strings. */ { static Tcl_Interp *interp2 = NULL; int code; @@ -4336,7 +4492,7 @@ TestfeventCmd(clientData, interp, argc, argv) if (argc < 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " option ?arg arg ...?", NULL); + " option ?arg ...?", NULL); return TCL_ERROR; } if (strcmp(argv[1], "cmd") == 0) { @@ -4345,35 +4501,35 @@ TestfeventCmd(clientData, interp, argc, argv) " cmd script", NULL); return TCL_ERROR; } - if (interp2 != NULL) { - code = Tcl_GlobalEval(interp2, argv[2]); + if (interp2 != NULL) { + code = Tcl_GlobalEval(interp2, argv[2]); Tcl_SetObjResult(interp, Tcl_GetObjResult(interp2)); - return code; - } else { - Tcl_AppendResult(interp, - "called \"testfevent code\" before \"testfevent create\"", - NULL); - return TCL_ERROR; - } + return code; + } else { + Tcl_AppendResult(interp, + "called \"testfevent code\" before \"testfevent create\"", + NULL); + return TCL_ERROR; + } } else if (strcmp(argv[1], "create") == 0) { if (interp2 != NULL) { - Tcl_DeleteInterp(interp2); + Tcl_DeleteInterp(interp2); } - interp2 = Tcl_CreateInterp(); + interp2 = Tcl_CreateInterp(); return Tcl_Init(interp2); } else if (strcmp(argv[1], "delete") == 0) { if (interp2 != NULL) { - Tcl_DeleteInterp(interp2); + Tcl_DeleteInterp(interp2); } interp2 = NULL; } else if (strcmp(argv[1], "share") == 0) { - if (interp2 != NULL) { - chan = Tcl_GetChannel(interp, argv[2], NULL); - if (chan == (Tcl_Channel) NULL) { - return TCL_ERROR; - } - Tcl_RegisterChannel(interp2, chan); - } + if (interp2 != NULL) { + chan = Tcl_GetChannel(interp, argv[2], NULL); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + Tcl_RegisterChannel(interp2, chan); + } } return TCL_OK; @@ -4387,7 +4543,7 @@ TestfeventCmd(clientData, interp, argc, argv) * Calls the panic routine. * * Results: - * Always returns TCL_OK. + * Always returns TCL_OK. * * Side effects: * May exit application. @@ -4396,13 +4552,13 @@ TestfeventCmd(clientData, interp, argc, argv) */ static int -TestpanicCmd(dummy, interp, argc, argv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - CONST char **argv; /* Argument strings. */ +TestpanicCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int argc, /* Number of arguments. */ + const char **argv) /* Argument strings. */ { - CONST char *argString; + const char *argString; /* * Put the arguments into a var args structure @@ -4410,81 +4566,22 @@ TestpanicCmd(dummy, interp, argc, argv) */ argString = Tcl_Merge(argc-1, argv+1); - Tcl_Panic(argString); - ckfree((char *)argString); + Tcl_Panic("%s", argString); + ckfree(argString); return TCL_OK; } -/* - *--------------------------------------------------------------------------- - * - * TestchmodCmd -- - * - * Implements the "testchmod" cmd. Used when testing "file" command. - * The only attribute used by the Windows platform is the user write - * flag; if this is not set, the file is made read-only. Otehrwise, the - * file is made read-write. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * Changes permissions of specified files. - * - *--------------------------------------------------------------------------- - */ - static int -TestchmodCmd(dummy, interp, argc, argv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - CONST char **argv; /* Argument strings. */ -{ - int i, mode; - char *rest; - - if (argc < 2) { - usage: - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " mode file ?file ...?", NULL); - return TCL_ERROR; - } - - mode = (int) strtol(argv[1], &rest, 8); - if ((rest == argv[1]) || (*rest != '\0')) { - goto usage; - } - - for (i = 2; i < argc; i++) { - Tcl_DString buffer; - CONST char *translated; - - translated = Tcl_TranslateFileName(interp, argv[i], &buffer); - if (translated == NULL) { - return TCL_ERROR; - } - if (chmod(translated, (unsigned) mode) != 0) { - Tcl_AppendResult(interp, translated, ": ", Tcl_PosixError(interp), - NULL); - return TCL_ERROR; - } - Tcl_DStringFree(&buffer); - } - return TCL_OK; -} - -static int -TestfileCmd(dummy, interp, argc, argv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - Tcl_Obj *CONST argv[]; /* The argument objects. */ +TestfileCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int argc, /* Number of arguments. */ + Tcl_Obj *const argv[]) /* The argument objects. */ { int force, i, j, result; Tcl_Obj *error = NULL; - char *subcmd; + const char *subcmd; if (argc < 3) { return TCL_ERROR; @@ -4493,7 +4590,7 @@ TestfileCmd(dummy, interp, argc, argv) force = 0; i = 2; if (strcmp(Tcl_GetString(argv[2]), "-force") == 0) { - force = 1; + force = 1; i = 3; } @@ -4502,7 +4599,7 @@ TestfileCmd(dummy, interp, argc, argv) } for (j = i; j < argc; j++) { - if (Tcl_FSGetNormalizedPath(interp, argv[j]) == NULL) { + if (Tcl_FSGetNormalizedPath(interp, argv[j]) == NULL) { return TCL_ERROR; } } @@ -4512,17 +4609,17 @@ TestfileCmd(dummy, interp, argc, argv) if (strcmp(subcmd, "mv") == 0) { result = TclpObjRenameFile(argv[i], argv[i + 1]); } else if (strcmp(subcmd, "cp") == 0) { - result = TclpObjCopyFile(argv[i], argv[i + 1]); + result = TclpObjCopyFile(argv[i], argv[i + 1]); } else if (strcmp(subcmd, "rm") == 0) { - result = TclpObjDeleteFile(argv[i]); + result = TclpObjDeleteFile(argv[i]); } else if (strcmp(subcmd, "mkdir") == 0) { - result = TclpObjCreateDirectory(argv[i]); + result = TclpObjCreateDirectory(argv[i]); } else if (strcmp(subcmd, "cpdir") == 0) { - result = TclpObjCopyDirectory(argv[i], argv[i + 1], &error); + result = TclpObjCopyDirectory(argv[i], argv[i + 1], &error); } else if (strcmp(subcmd, "rmdir") == 0) { - result = TclpObjRemoveDirectory(argv[i], force, &error); + result = TclpObjRemoveDirectory(argv[i], force, &error); } else { - result = TCL_ERROR; + result = TCL_ERROR; goto end; } @@ -4536,8 +4633,7 @@ TestfileCmd(dummy, interp, argc, argv) Tcl_AppendResult(interp, Tcl_ErrnoId(), NULL); } - end: - + end: return result; } @@ -4559,13 +4655,13 @@ TestfileCmd(dummy, interp, argc, argv) */ static int -TestgetvarfullnameCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* The argument objects. */ +TestgetvarfullnameCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* The argument objects. */ { - char *name, *arg; + const char *name, *arg; int flags = 0; Tcl_Namespace *namespacePtr; Tcl_CallFrame *framePtr; @@ -4574,7 +4670,7 @@ TestgetvarfullnameCmd(dummy, interp, objc, objv) if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "name scope"); - return TCL_ERROR; + return TCL_ERROR; } name = Tcl_GetString(objv[1]); @@ -4599,7 +4695,7 @@ TestgetvarfullnameCmd(dummy, interp, objc, objv) return TCL_ERROR; } result = TclPushStackFrame(interp, &framePtr, namespacePtr, - /*isProcCallFrame*/ 0); + /*isProcCallFrame*/ 0); if (result != TCL_OK) { return result; } @@ -4637,27 +4733,26 @@ TestgetvarfullnameCmd(dummy, interp, objc, objv) */ static int -GetTimesCmd(unused, interp, argc, argv) - ClientData unused; /* Unused. */ - Tcl_Interp *interp; /* The current interpreter. */ - int argc; /* The number of arguments. */ - CONST char **argv; /* The argument strings. */ +GetTimesCmd( + ClientData unused, /* Unused. */ + Tcl_Interp *interp, /* The current interpreter. */ + int argc, /* The number of arguments. */ + const char **argv) /* The argument strings. */ { Interp *iPtr = (Interp *) interp; int i, n; double timePer; Tcl_Time start, stop; - Tcl_Obj *objPtr; - Tcl_Obj **objv; - CONST char *s; + Tcl_Obj *objPtr, **objv; + const char *s; char newString[TCL_INTEGER_SPACE]; /* alloc & free 100000 times */ fprintf(stderr, "alloc & free 100000 6 word items\n"); Tcl_GetTime(&start); for (i = 0; i < 100000; i++) { - objPtr = (Tcl_Obj *) ckalloc(sizeof(Tcl_Obj)); - ckfree((char *) objPtr); + objPtr = ckalloc(sizeof(Tcl_Obj)); + ckfree(objPtr); } Tcl_GetTime(&stop); timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); @@ -4665,10 +4760,10 @@ GetTimesCmd(unused, interp, argc, argv) /* alloc 5000 times */ fprintf(stderr, "alloc 5000 6 word items\n"); - objv = (Tcl_Obj **) ckalloc(5000 * sizeof(Tcl_Obj *)); + objv = ckalloc(5000 * sizeof(Tcl_Obj *)); Tcl_GetTime(&start); for (i = 0; i < 5000; i++) { - objv[i] = (Tcl_Obj *) ckalloc(sizeof(Tcl_Obj)); + objv[i] = ckalloc(sizeof(Tcl_Obj)); } Tcl_GetTime(&stop); timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); @@ -4678,7 +4773,7 @@ GetTimesCmd(unused, interp, argc, argv) fprintf(stderr, "free 5000 6 word items\n"); Tcl_GetTime(&start); for (i = 0; i < 5000; i++) { - ckfree((char *) objv[i]); + ckfree(objv[i]); } Tcl_GetTime(&stop); timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); @@ -4704,7 +4799,7 @@ GetTimesCmd(unused, interp, argc, argv) Tcl_GetTime(&stop); timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); fprintf(stderr, " %.3f usec per Tcl_DecrRefCount\n", timePer/5000); - ckfree((char *) objv); + ckfree(objv); /* TclGetString 100000 times */ fprintf(stderr, "TclGetStringFromObj of \"12345\" 100000 times\n"); @@ -4817,11 +4912,11 @@ GetTimesCmd(unused, interp, argc, argv) */ static int -NoopCmd(unused, interp, argc, argv) - ClientData unused; /* Unused. */ - Tcl_Interp *interp; /* The current interpreter. */ - int argc; /* The number of arguments. */ - CONST char **argv; /* The argument strings. */ +NoopCmd( + ClientData unused, /* Unused. */ + Tcl_Interp *interp, /* The current interpreter. */ + int argc, /* The number of arguments. */ + const char **argv) /* The argument strings. */ { return TCL_OK; } @@ -4844,11 +4939,11 @@ NoopCmd(unused, interp, argc, argv) */ static int -NoopObjCmd(unused, interp, objc, objv) - ClientData unused; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* The argument objects. */ +NoopObjCmd( + ClientData unused, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* The argument objects. */ { return TCL_OK; } @@ -4872,29 +4967,29 @@ NoopObjCmd(unused, interp, objc, objv) /* ARGSUSED */ static int -TestsetCmd(data, interp, argc, argv) - ClientData data; /* Additional flags for Get/SetVar2. */ - register Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - CONST char **argv; /* Argument strings. */ +TestsetCmd( + ClientData data, /* Additional flags for Get/SetVar2. */ + register Tcl_Interp *interp,/* Current interpreter. */ + int argc, /* Number of arguments. */ + const char **argv) /* Argument strings. */ { - int flags = (int) data; - CONST char *value; + int flags = PTR2INT(data); + const char *value; if (argc == 2) { - Tcl_SetResult(interp, "before get", TCL_STATIC); + Tcl_SetResult(interp, "before get", TCL_STATIC); value = Tcl_GetVar2(interp, argv[1], NULL, flags); - if (value == NULL) { - return TCL_ERROR; - } + if (value == NULL) { + return TCL_ERROR; + } Tcl_AppendElement(interp, value); - return TCL_OK; + return TCL_OK; } else if (argc == 3) { Tcl_SetResult(interp, "before set", TCL_STATIC); - value = Tcl_SetVar2(interp, argv[1], NULL, argv[2], flags); - if (value == NULL) { - return TCL_ERROR; - } + value = Tcl_SetVar2(interp, argv[1], NULL, argv[2], flags); + if (value == NULL) { + return TCL_ERROR; + } Tcl_AppendElement(interp, value); return TCL_OK; } else { @@ -4903,7 +4998,40 @@ TestsetCmd(data, interp, argc, argv) return TCL_ERROR; } } +static int +Testset2Cmd( + ClientData data, /* Additional flags for Get/SetVar2. */ + register Tcl_Interp *interp,/* Current interpreter. */ + int argc, /* Number of arguments. */ + const char **argv) /* Argument strings. */ +{ + int flags = PTR2INT(data); + const char *value; + + if (argc == 3) { + Tcl_SetResult(interp, "before get", TCL_STATIC); + value = Tcl_GetVar2(interp, argv[1], argv[2], flags); + if (value == NULL) { + return TCL_ERROR; + } + Tcl_AppendElement(interp, value); + return TCL_OK; + } else if (argc == 4) { + Tcl_SetResult(interp, "before set", TCL_STATIC); + value = Tcl_SetVar2(interp, argv[1], argv[2], argv[3], flags); + if (value == NULL) { + return TCL_ERROR; + } + Tcl_AppendElement(interp, value); + return TCL_OK; + } else { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " varName elemName ?newValue?\"", NULL); + return TCL_ERROR; + } +} +#ifndef TCL_NO_DEPRECATED /* *---------------------------------------------------------------------- * @@ -4923,16 +5051,17 @@ TestsetCmd(data, interp, argc, argv) /* ARGSUSED */ static int -TestsaveresultCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - register Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* The argument objects. */ +TestsaveresultCmd( + ClientData dummy, /* Not used. */ + register Tcl_Interp *interp,/* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* The argument objects. */ { + Interp* iPtr = (Interp*) interp; int discard, result, index; Tcl_SavedResult state; Tcl_Obj *objPtr; - static CONST char *optionStrings[] = { + static const char *const optionStrings[] = { "append", "dynamic", "free", "object", "small", NULL }; enum options { @@ -4945,7 +5074,7 @@ TestsaveresultCmd(dummy, interp, objc, objv) if (objc != 4) { Tcl_WrongNumArgs(interp, 1, objv, "type script discard"); - return TCL_ERROR; + return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0, &index) != TCL_OK) { @@ -4957,25 +5086,26 @@ TestsaveresultCmd(dummy, interp, objc, objv) objPtr = NULL; /* Lint. */ switch ((enum options) index) { - case RESULT_SMALL: - Tcl_SetResult(interp, "small result", TCL_VOLATILE); - break; - case RESULT_APPEND: - Tcl_AppendResult(interp, "append result", NULL); - break; - case RESULT_FREE: { - char *buf = ckalloc(200); - strcpy(buf, "free result"); - Tcl_SetResult(interp, buf, TCL_DYNAMIC); - break; - } - case RESULT_DYNAMIC: - Tcl_SetResult(interp, "dynamic result", TestsaveresultFree); - break; - case RESULT_OBJECT: - objPtr = Tcl_NewStringObj("object result", -1); - Tcl_SetObjResult(interp, objPtr); - break; + case RESULT_SMALL: + Tcl_SetResult(interp, "small result", TCL_VOLATILE); + break; + case RESULT_APPEND: + Tcl_AppendResult(interp, "append result", NULL); + break; + case RESULT_FREE: { + char *buf = ckalloc(200); + + strcpy(buf, "free result"); + Tcl_SetResult(interp, buf, TCL_DYNAMIC); + break; + } + case RESULT_DYNAMIC: + Tcl_SetResult(interp, (char *)"dynamic result", TestsaveresultFree); + break; + case RESULT_OBJECT: + objPtr = Tcl_NewStringObj("object result", -1); + Tcl_SetObjResult(interp, objPtr); + break; } freeCount = 0; @@ -4995,19 +5125,20 @@ TestsaveresultCmd(dummy, interp, objc, objv) } switch ((enum options) index) { - case RESULT_DYNAMIC: { - int present = interp->freeProc == TestsaveresultFree; - int called = freeCount; - Tcl_AppendElement(interp, called ? "called" : "notCalled"); - Tcl_AppendElement(interp, present ? "present" : "missing"); - break; - } - case RESULT_OBJECT: - Tcl_AppendElement(interp, Tcl_GetObjResult(interp) == objPtr - ? "same" : "different"); - break; - default: - break; + case RESULT_DYNAMIC: { + int present = iPtr->freeProc == TestsaveresultFree; + int called = freeCount; + + Tcl_AppendElement(interp, called ? "called" : "notCalled"); + Tcl_AppendElement(interp, present ? "present" : "missing"); + break; + } + case RESULT_OBJECT: + Tcl_AppendElement(interp, Tcl_GetObjResult(interp) == objPtr + ? "same" : "different"); + break; + default: + break; } return result; } @@ -5029,19 +5160,20 @@ TestsaveresultCmd(dummy, interp, objc, objv) */ static void -TestsaveresultFree(blockPtr) - char *blockPtr; +TestsaveresultFree( + char *blockPtr) { freeCount++; } +#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- * - * TeststatprocCmd -- + * TestmainthreadCmd -- * - * Implements the "testTclStatProc" cmd that is used to test the - * 'TclStatInsertProc' & 'TclStatDeleteProc' C Apis. + * Implements the "testmainthread" cmd that is used to test the + * 'Tcl_GetCurrentThread' API. * * Results: * A standard Tcl result. @@ -5053,212 +5185,21 @@ TestsaveresultFree(blockPtr) */ static int -TeststatprocCmd (dummy, interp, argc, argv) - ClientData dummy; /* Not used. */ - register Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - CONST char **argv; /* Argument strings. */ +TestmainthreadCmd( + 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 (argc == 1) { + Tcl_Obj *idObj = Tcl_NewLongObj((long)(size_t)Tcl_GetCurrentThread()); - 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); + Tcl_SetObjResult(interp, idObj); + return TCL_OK; } else { - Tcl_AppendResult(interp, "bad option \"", argv[1], "\": ", - "must be insert or delete", NULL); + Tcl_SetResult(interp, "wrong # args", TCL_STATIC); return TCL_ERROR; } - - if (retVal == TCL_ERROR) { - Tcl_AppendResult(interp, "\"", argv[2], "\": ", - "could not be ", argv[1], "ed", NULL); - } - - return retVal; -} - -static int PretendTclpStat(path, buf) - 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(path, buf) - 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(path, buf) - 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(path, buf) - CONST char *path; - struct stat *buf; -{ - memset(buf, 0, sizeof(struct stat)); - buf->st_size = 3456; - return ((strstr(path, "testStat3%.fil") == NULL) ? -1 : 0); -} - -/* - *---------------------------------------------------------------------- - * - * TestmainthreadCmd -- - * - * Implements the "testmainthread" cmd that is used to test the - * 'Tcl_GetCurrentThread' API. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -TestmainthreadCmd (dummy, interp, argc, argv) - ClientData dummy; /* Not used. */ - register Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - CONST char **argv; /* Argument strings. */ -{ - if (argc == 1) { - Tcl_Obj *idObj = Tcl_NewLongObj((long)Tcl_GetCurrentThread()); - Tcl_SetObjResult(interp, idObj); - return TCL_OK; - } else { - Tcl_SetResult(interp, "wrong # args", TCL_STATIC); - return TCL_ERROR; - } } /* @@ -5269,7 +5210,7 @@ TestmainthreadCmd (dummy, interp, argc, argv) * A main loop set by TestsetmainloopCmd below. * * Results: - * None. + * None. * * Side effects: * Event handlers could do anything. @@ -5305,11 +5246,11 @@ MainLoop(void) */ static int -TestsetmainloopCmd (dummy, interp, argc, argv) - ClientData dummy; /* Not used. */ - register Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - CONST char **argv; /* Argument strings. */ +TestsetmainloopCmd( + ClientData dummy, /* Not used. */ + register Tcl_Interp *interp,/* Current interpreter. */ + int argc, /* Number of arguments. */ + const char **argv) /* Argument strings. */ { exitMainLoop = 0; Tcl_SetMainLoop(MainLoop); @@ -5334,11 +5275,11 @@ TestsetmainloopCmd (dummy, interp, argc, argv) */ static int -TestexitmainloopCmd (dummy, interp, argc, argv) - ClientData dummy; /* Not used. */ - register Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - CONST char **argv; /* Argument strings. */ +TestexitmainloopCmd( + ClientData dummy, /* Not used. */ + register Tcl_Interp *interp,/* Current interpreter. */ + int argc, /* Number of arguments. */ + const char **argv) /* Argument strings. */ { exitMainLoop = 1; return TCL_OK; @@ -5347,311 +5288,6 @@ TestexitmainloopCmd (dummy, interp, argc, argv) /* *---------------------------------------------------------------------- * - * 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 (dummy, interp, argc, argv) - 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(path, mode) - 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(path, mode) - CONST char *path; - int mode; -{ - return ((strstr(path, "testAccess1%.fil") == NULL) ? -1 : 0); -} - - -static int -TestAccessProc2(path, mode) - CONST char *path; - int mode; -{ - return ((strstr(path, "testAccess2%.fil") == NULL) ? -1 : 0); -} - - -static int -TestAccessProc3(path, mode) - 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 (dummy, interp, argc, argv) - 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(interp, fileName, modeString, permissions) - 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(interp, fileName, modeString, permissions) - 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(interp, fileName, modeString, permissions) - 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(interp, fileName, modeString, permissions) - 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); - } -} - -/* - *---------------------------------------------------------------------- - * * TestChannelCmd -- * * Implements the Tcl "testchannel" debugging command and its @@ -5668,13 +5304,13 @@ TestOpenFileChannelProc3(interp, fileName, modeString, permissions) /* ARGSUSED */ static int -TestChannelCmd(clientData, interp, argc, argv) - ClientData clientData; /* Not used. */ - Tcl_Interp *interp; /* Interpreter for result. */ - int argc; /* Count of additional args. */ - CONST char **argv; /* Additional arg strings. */ +TestChannelCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Interpreter for result. */ + int argc, /* Count of additional args. */ + const char **argv) /* Additional arg strings. */ { - CONST char *cmdName; /* Sub command. */ + const char *cmdName; /* Sub command. */ Tcl_HashTable *hTblPtr; /* Hash table of channels. */ Tcl_HashSearch hSearch; /* Search variable. */ Tcl_HashEntry *hPtr; /* Search variable. */ @@ -5687,9 +5323,9 @@ TestChannelCmd(clientData, interp, argc, argv) int mode; /* rw mode of the channel */ if (argc < 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " subcommand ?additional args..?\"", NULL); - return TCL_ERROR; + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " subcommand ?additional args..?\"", NULL); + return TCL_ERROR; } cmdName = argv[1]; len = strlen(cmdName); @@ -5697,24 +5333,23 @@ TestChannelCmd(clientData, interp, argc, argv) chanPtr = NULL; if (argc > 2) { - if ((cmdName[0] == 's') && (strncmp(cmdName, "splice", len) == 0)) { + if ((cmdName[0] == 's') && (strncmp(cmdName, "splice", len) == 0)) { /* For splice access the pool of detached channels. * Locate channel, remove from the list. */ - TestChannel** nextPtrPtr; - TestChannel* curPtr; + TestChannel **nextPtrPtr, *curPtr; chan = (Tcl_Channel) NULL; for (nextPtrPtr = &firstDetached, curPtr = firstDetached; curPtr != NULL; nextPtrPtr = &(curPtr->nextPtr), curPtr = curPtr->nextPtr) { - if (strcmp (argv[2], Tcl_GetChannelName (curPtr->chan)) == 0) { - *nextPtrPtr = curPtr->nextPtr; + if (strcmp(argv[2], Tcl_GetChannelName(curPtr->chan)) == 0) { + *nextPtrPtr = curPtr->nextPtr; curPtr->nextPtr = NULL; chan = curPtr->chan; - ckfree ((char*) curPtr); + ckfree(curPtr); break; } } @@ -5724,9 +5359,9 @@ TestChannelCmd(clientData, interp, argc, argv) if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; } - chanPtr = (Channel *) chan; + chanPtr = (Channel *) chan; statePtr = chanPtr->state; - chanPtr = statePtr->topChanPtr; + chanPtr = statePtr->topChanPtr; chan = (Tcl_Channel) chanPtr; } else { /* lint */ @@ -5736,28 +5371,28 @@ TestChannelCmd(clientData, interp, argc, argv) if ((cmdName[0] == 's') && (strncmp(cmdName, "setchannelerror", len) == 0)) { - Tcl_Obj* msg = Tcl_NewStringObj (argv [3],-1); + Tcl_Obj *msg = Tcl_NewStringObj(argv[3],-1); - Tcl_IncrRefCount (msg); - Tcl_SetChannelError (chan, msg); - Tcl_DecrRefCount (msg); + Tcl_IncrRefCount(msg); + Tcl_SetChannelError(chan, msg); + Tcl_DecrRefCount(msg); - Tcl_GetChannelError (chan, &msg); - Tcl_SetObjResult (interp, msg); - Tcl_DecrRefCount (msg); + Tcl_GetChannelError(chan, &msg); + Tcl_SetObjResult(interp, msg); + Tcl_DecrRefCount(msg); return TCL_OK; } if ((cmdName[0] == 's') && (strncmp(cmdName, "setchannelerrorinterp", len) == 0)) { - Tcl_Obj* msg = Tcl_NewStringObj (argv [3],-1); + Tcl_Obj *msg = Tcl_NewStringObj(argv[3],-1); - Tcl_IncrRefCount (msg); - Tcl_SetChannelErrorInterp (interp, msg); - Tcl_DecrRefCount (msg); + Tcl_IncrRefCount(msg); + Tcl_SetChannelErrorInterp(interp, msg); + Tcl_DecrRefCount(msg); - Tcl_GetChannelErrorInterp (interp, &msg); - Tcl_SetObjResult (interp, msg); - Tcl_DecrRefCount (msg); + Tcl_GetChannelErrorInterp(interp, &msg); + Tcl_SetObjResult(interp, msg); + Tcl_DecrRefCount(msg); return TCL_OK; } @@ -5769,153 +5404,153 @@ TestChannelCmd(clientData, interp, argc, argv) */ if ((cmdName[0] == 'c') && (strncmp(cmdName, "cut", len) == 0)) { - TestChannel* det; + TestChannel *det; - if (argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " cut channelName\"", NULL); - return TCL_ERROR; - } + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " cut channelName\"", NULL); + return TCL_ERROR; + } Tcl_RegisterChannel(NULL, chan); /* prevent closing */ Tcl_UnregisterChannel(interp, chan); - Tcl_CutChannel(chan); + Tcl_CutChannel(chan); /* Remember the channel in the pool of detached channels */ - det = (TestChannel*) ckalloc (sizeof(TestChannel)); + det = ckalloc(sizeof(TestChannel)); det->chan = chan; det->nextPtr = firstDetached; firstDetached = det; - return TCL_OK; + return TCL_OK; } if ((cmdName[0] == 'c') && (strncmp(cmdName, "clearchannelhandlers", len) == 0)) { - if (argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " clearchannelhandlers channelName\"", NULL); - return TCL_ERROR; - } - Tcl_ClearChannelHandlers(chan); - return TCL_OK; + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " clearchannelhandlers channelName\"", NULL); + return TCL_ERROR; + } + Tcl_ClearChannelHandlers(chan); + return TCL_OK; } if ((cmdName[0] == 'i') && (strncmp(cmdName, "info", len) == 0)) { - if (argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " info channelName\"", NULL); - return TCL_ERROR; - } - Tcl_AppendElement(interp, argv[2]); - Tcl_AppendElement(interp, Tcl_ChannelName(chanPtr->typePtr)); - if (statePtr->flags & TCL_READABLE) { - Tcl_AppendElement(interp, "read"); - } else { - Tcl_AppendElement(interp, ""); - } - if (statePtr->flags & TCL_WRITABLE) { - Tcl_AppendElement(interp, "write"); - } else { - Tcl_AppendElement(interp, ""); - } - if (statePtr->flags & CHANNEL_NONBLOCKING) { - Tcl_AppendElement(interp, "nonblocking"); - } else { - Tcl_AppendElement(interp, "blocking"); - } - if (statePtr->flags & CHANNEL_LINEBUFFERED) { - Tcl_AppendElement(interp, "line"); - } else if (statePtr->flags & CHANNEL_UNBUFFERED) { - Tcl_AppendElement(interp, "none"); - } else { - Tcl_AppendElement(interp, "full"); - } - if (statePtr->flags & BG_FLUSH_SCHEDULED) { - Tcl_AppendElement(interp, "async_flush"); - } else { - Tcl_AppendElement(interp, ""); - } - if (statePtr->flags & CHANNEL_EOF) { - Tcl_AppendElement(interp, "eof"); - } else { - Tcl_AppendElement(interp, ""); - } - if (statePtr->flags & CHANNEL_BLOCKED) { - Tcl_AppendElement(interp, "blocked"); - } else { - Tcl_AppendElement(interp, "unblocked"); - } - if (statePtr->inputTranslation == TCL_TRANSLATE_AUTO) { - Tcl_AppendElement(interp, "auto"); - if (statePtr->flags & INPUT_SAW_CR) { - Tcl_AppendElement(interp, "saw_cr"); - } else { - Tcl_AppendElement(interp, ""); - } - } else if (statePtr->inputTranslation == TCL_TRANSLATE_LF) { - Tcl_AppendElement(interp, "lf"); - Tcl_AppendElement(interp, ""); - } else if (statePtr->inputTranslation == TCL_TRANSLATE_CR) { - Tcl_AppendElement(interp, "cr"); - Tcl_AppendElement(interp, ""); - } else if (statePtr->inputTranslation == TCL_TRANSLATE_CRLF) { - Tcl_AppendElement(interp, "crlf"); - if (statePtr->flags & INPUT_SAW_CR) { - Tcl_AppendElement(interp, "queued_cr"); - } else { - Tcl_AppendElement(interp, ""); - } - } - if (statePtr->outputTranslation == TCL_TRANSLATE_AUTO) { - Tcl_AppendElement(interp, "auto"); - } else if (statePtr->outputTranslation == TCL_TRANSLATE_LF) { - Tcl_AppendElement(interp, "lf"); - } else if (statePtr->outputTranslation == TCL_TRANSLATE_CR) { - Tcl_AppendElement(interp, "cr"); - } else if (statePtr->outputTranslation == TCL_TRANSLATE_CRLF) { - Tcl_AppendElement(interp, "crlf"); - } - IOQueued = Tcl_InputBuffered(chan); - TclFormatInt(buf, IOQueued); - Tcl_AppendElement(interp, buf); + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " info channelName\"", NULL); + return TCL_ERROR; + } + Tcl_AppendElement(interp, argv[2]); + Tcl_AppendElement(interp, Tcl_ChannelName(chanPtr->typePtr)); + if (statePtr->flags & TCL_READABLE) { + Tcl_AppendElement(interp, "read"); + } else { + Tcl_AppendElement(interp, ""); + } + if (statePtr->flags & TCL_WRITABLE) { + Tcl_AppendElement(interp, "write"); + } else { + Tcl_AppendElement(interp, ""); + } + if (statePtr->flags & CHANNEL_NONBLOCKING) { + Tcl_AppendElement(interp, "nonblocking"); + } else { + Tcl_AppendElement(interp, "blocking"); + } + if (statePtr->flags & CHANNEL_LINEBUFFERED) { + Tcl_AppendElement(interp, "line"); + } else if (statePtr->flags & CHANNEL_UNBUFFERED) { + Tcl_AppendElement(interp, "none"); + } else { + Tcl_AppendElement(interp, "full"); + } + if (statePtr->flags & BG_FLUSH_SCHEDULED) { + Tcl_AppendElement(interp, "async_flush"); + } else { + Tcl_AppendElement(interp, ""); + } + if (statePtr->flags & CHANNEL_EOF) { + Tcl_AppendElement(interp, "eof"); + } else { + Tcl_AppendElement(interp, ""); + } + if (statePtr->flags & CHANNEL_BLOCKED) { + Tcl_AppendElement(interp, "blocked"); + } else { + Tcl_AppendElement(interp, "unblocked"); + } + if (statePtr->inputTranslation == TCL_TRANSLATE_AUTO) { + Tcl_AppendElement(interp, "auto"); + if (statePtr->flags & INPUT_SAW_CR) { + Tcl_AppendElement(interp, "saw_cr"); + } else { + Tcl_AppendElement(interp, ""); + } + } else if (statePtr->inputTranslation == TCL_TRANSLATE_LF) { + Tcl_AppendElement(interp, "lf"); + Tcl_AppendElement(interp, ""); + } else if (statePtr->inputTranslation == TCL_TRANSLATE_CR) { + Tcl_AppendElement(interp, "cr"); + Tcl_AppendElement(interp, ""); + } else if (statePtr->inputTranslation == TCL_TRANSLATE_CRLF) { + Tcl_AppendElement(interp, "crlf"); + if (statePtr->flags & INPUT_SAW_CR) { + Tcl_AppendElement(interp, "queued_cr"); + } else { + Tcl_AppendElement(interp, ""); + } + } + if (statePtr->outputTranslation == TCL_TRANSLATE_AUTO) { + Tcl_AppendElement(interp, "auto"); + } else if (statePtr->outputTranslation == TCL_TRANSLATE_LF) { + Tcl_AppendElement(interp, "lf"); + } else if (statePtr->outputTranslation == TCL_TRANSLATE_CR) { + Tcl_AppendElement(interp, "cr"); + } else if (statePtr->outputTranslation == TCL_TRANSLATE_CRLF) { + Tcl_AppendElement(interp, "crlf"); + } + IOQueued = Tcl_InputBuffered(chan); + TclFormatInt(buf, IOQueued); + Tcl_AppendElement(interp, buf); - IOQueued = Tcl_OutputBuffered(chan); - TclFormatInt(buf, IOQueued); - Tcl_AppendElement(interp, buf); + IOQueued = Tcl_OutputBuffered(chan); + TclFormatInt(buf, IOQueued); + Tcl_AppendElement(interp, buf); - TclFormatInt(buf, (int)Tcl_Tell(chan)); - Tcl_AppendElement(interp, buf); + TclFormatInt(buf, (int)Tcl_Tell(chan)); + Tcl_AppendElement(interp, buf); - TclFormatInt(buf, statePtr->refCount); - Tcl_AppendElement(interp, buf); + TclFormatInt(buf, statePtr->refCount); + Tcl_AppendElement(interp, buf); - return TCL_OK; + return TCL_OK; } if ((cmdName[0] == 'i') && - (strncmp(cmdName, "inputbuffered", len) == 0)) { - if (argc != 3) { - Tcl_AppendResult(interp, "channel name required", NULL); - return TCL_ERROR; - } - IOQueued = Tcl_InputBuffered(chan); - TclFormatInt(buf, IOQueued); - Tcl_AppendResult(interp, buf, NULL); - return TCL_OK; + (strncmp(cmdName, "inputbuffered", len) == 0)) { + if (argc != 3) { + Tcl_AppendResult(interp, "channel name required", NULL); + return TCL_ERROR; + } + IOQueued = Tcl_InputBuffered(chan); + TclFormatInt(buf, IOQueued); + Tcl_AppendResult(interp, buf, NULL); + return TCL_OK; } if ((cmdName[0] == 'i') && (strncmp(cmdName, "isshared", len) == 0)) { - if (argc != 3) { - Tcl_AppendResult(interp, "channel name required", NULL); - return TCL_ERROR; - } + if (argc != 3) { + Tcl_AppendResult(interp, "channel name required", NULL); + return TCL_ERROR; + } - TclFormatInt(buf, Tcl_IsChannelShared(chan)); - Tcl_AppendResult(interp, buf, NULL); - return TCL_OK; + TclFormatInt(buf, Tcl_IsChannelShared(chan)); + Tcl_AppendResult(interp, buf, NULL); + return TCL_OK; } if ((cmdName[0] == 'i') && (strncmp(cmdName, "isstandard", len) == 0)) { @@ -5930,108 +5565,108 @@ TestChannelCmd(clientData, interp, argc, argv) } if ((cmdName[0] == 'm') && (strncmp(cmdName, "mode", len) == 0)) { - if (argc != 3) { - Tcl_AppendResult(interp, "channel name required", NULL); - return TCL_ERROR; - } + if (argc != 3) { + Tcl_AppendResult(interp, "channel name required", NULL); + return TCL_ERROR; + } - if (statePtr->flags & TCL_READABLE) { - Tcl_AppendElement(interp, "read"); - } else { - Tcl_AppendElement(interp, ""); - } - if (statePtr->flags & TCL_WRITABLE) { - Tcl_AppendElement(interp, "write"); - } else { - Tcl_AppendElement(interp, ""); - } - return TCL_OK; + if (statePtr->flags & TCL_READABLE) { + Tcl_AppendElement(interp, "read"); + } else { + Tcl_AppendElement(interp, ""); + } + if (statePtr->flags & TCL_WRITABLE) { + Tcl_AppendElement(interp, "write"); + } else { + Tcl_AppendElement(interp, ""); + } + return TCL_OK; } if ((cmdName[0] == 'm') && (strncmp(cmdName, "mthread", len) == 0)) { - if (argc != 3) { - Tcl_AppendResult(interp, "channel name required", NULL); - return TCL_ERROR; - } + if (argc != 3) { + Tcl_AppendResult(interp, "channel name required", NULL); + return TCL_ERROR; + } - TclFormatInt(buf, (long) Tcl_GetChannelThread(chan)); - Tcl_AppendResult(interp, buf, NULL); - return TCL_OK; + TclFormatInt(buf, (size_t) Tcl_GetChannelThread(chan)); + Tcl_AppendResult(interp, buf, NULL); + return TCL_OK; } if ((cmdName[0] == 'n') && (strncmp(cmdName, "name", len) == 0)) { - if (argc != 3) { - Tcl_AppendResult(interp, "channel name required", NULL); - return TCL_ERROR; - } - Tcl_AppendResult(interp, statePtr->channelName, NULL); - return TCL_OK; + if (argc != 3) { + Tcl_AppendResult(interp, "channel name required", NULL); + return TCL_ERROR; + } + Tcl_AppendResult(interp, statePtr->channelName, NULL); + return TCL_OK; } if ((cmdName[0] == 'o') && (strncmp(cmdName, "open", len) == 0)) { - hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL); - if (hTblPtr == NULL) { - return TCL_OK; - } - for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); + hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL); + if (hTblPtr == NULL) { + return TCL_OK; + } + for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) { - Tcl_AppendElement(interp, Tcl_GetHashKey(hTblPtr, hPtr)); - } - return TCL_OK; + Tcl_AppendElement(interp, Tcl_GetHashKey(hTblPtr, hPtr)); + } + return TCL_OK; } if ((cmdName[0] == 'o') && - (strncmp(cmdName, "outputbuffered", len) == 0)) { - if (argc != 3) { - Tcl_AppendResult(interp, "channel name required", NULL); - return TCL_ERROR; - } + (strncmp(cmdName, "outputbuffered", len) == 0)) { + if (argc != 3) { + Tcl_AppendResult(interp, "channel name required", NULL); + return TCL_ERROR; + } - IOQueued = Tcl_OutputBuffered(chan); - TclFormatInt(buf, IOQueued); - Tcl_AppendResult(interp, buf, NULL); - return TCL_OK; + IOQueued = Tcl_OutputBuffered(chan); + TclFormatInt(buf, IOQueued); + Tcl_AppendResult(interp, buf, NULL); + return TCL_OK; } if ((cmdName[0] == 'q') && - (strncmp(cmdName, "queuedcr", len) == 0)) { - if (argc != 3) { - Tcl_AppendResult(interp, "channel name required", NULL); - return TCL_ERROR; - } + (strncmp(cmdName, "queuedcr", len) == 0)) { + if (argc != 3) { + Tcl_AppendResult(interp, "channel name required", NULL); + return TCL_ERROR; + } - Tcl_AppendResult(interp, - (statePtr->flags & INPUT_SAW_CR) ? "1" : "0", NULL); - return TCL_OK; + Tcl_AppendResult(interp, + (statePtr->flags & INPUT_SAW_CR) ? "1" : "0", NULL); + return TCL_OK; } if ((cmdName[0] == 'r') && (strncmp(cmdName, "readable", len) == 0)) { - hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL); - if (hTblPtr == NULL) { - return TCL_OK; - } - for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); + hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL); + if (hTblPtr == NULL) { + return TCL_OK; + } + for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) { - chanPtr = (Channel *) Tcl_GetHashValue(hPtr); + chanPtr = (Channel *) Tcl_GetHashValue(hPtr); statePtr = chanPtr->state; - if (statePtr->flags & TCL_READABLE) { - Tcl_AppendElement(interp, Tcl_GetHashKey(hTblPtr, hPtr)); - } - } - return TCL_OK; + if (statePtr->flags & TCL_READABLE) { + Tcl_AppendElement(interp, Tcl_GetHashKey(hTblPtr, hPtr)); + } + } + return TCL_OK; } if ((cmdName[0] == 'r') && (strncmp(cmdName, "refcount", len) == 0)) { - if (argc != 3) { - Tcl_AppendResult(interp, "channel name required", NULL); - return TCL_ERROR; - } + if (argc != 3) { + Tcl_AppendResult(interp, "channel name required", NULL); + return TCL_ERROR; + } - TclFormatInt(buf, statePtr->refCount); - Tcl_AppendResult(interp, buf, NULL); - return TCL_OK; + TclFormatInt(buf, statePtr->refCount); + Tcl_AppendResult(interp, buf, NULL); + return TCL_OK; } /* @@ -6042,43 +5677,42 @@ TestChannelCmd(clientData, interp, argc, argv) */ if ((cmdName[0] == 's') && (strncmp(cmdName, "splice", len) == 0)) { - if (argc != 3) { - Tcl_AppendResult(interp, "channel name required", NULL); - return TCL_ERROR; - } + if (argc != 3) { + Tcl_AppendResult(interp, "channel name required", NULL); + return TCL_ERROR; + } - Tcl_SpliceChannel(chan); + Tcl_SpliceChannel(chan); Tcl_RegisterChannel(interp, chan); Tcl_UnregisterChannel(NULL, chan); - return TCL_OK; + return TCL_OK; } if ((cmdName[0] == 't') && (strncmp(cmdName, "type", len) == 0)) { - if (argc != 3) { - Tcl_AppendResult(interp, "channel name required", NULL); - return TCL_ERROR; - } - Tcl_AppendResult(interp, Tcl_ChannelName(chanPtr->typePtr), NULL); - return TCL_OK; + if (argc != 3) { + Tcl_AppendResult(interp, "channel name required", NULL); + return TCL_ERROR; + } + Tcl_AppendResult(interp, Tcl_ChannelName(chanPtr->typePtr), NULL); + return TCL_OK; } if ((cmdName[0] == 'w') && (strncmp(cmdName, "writable", len) == 0)) { - hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL); - if (hTblPtr == NULL) { - return TCL_OK; - } - for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); - hPtr != NULL; - hPtr = Tcl_NextHashEntry(&hSearch)) { - chanPtr = (Channel *) Tcl_GetHashValue(hPtr); + hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL); + if (hTblPtr == NULL) { + return TCL_OK; + } + for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) { + chanPtr = (Channel *) Tcl_GetHashValue(hPtr); statePtr = chanPtr->state; - if (statePtr->flags & TCL_WRITABLE) { - Tcl_AppendElement(interp, Tcl_GetHashKey(hTblPtr, hPtr)); - } - } - return TCL_OK; + if (statePtr->flags & TCL_WRITABLE) { + Tcl_AppendElement(interp, Tcl_GetHashKey(hTblPtr, hPtr)); + } + } + return TCL_OK; } if ((cmdName[0] == 't') && (strncmp(cmdName, "transform", len) == 0)) { @@ -6086,11 +5720,11 @@ TestChannelCmd(clientData, interp, argc, argv) * Syntax: transform channel -command command */ - if (argc != 5) { + if (argc != 5) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " transform channelId -command cmd\"", NULL); - return TCL_ERROR; - } + return TCL_ERROR; + } if (strcmp(argv[3], "-command") != 0) { Tcl_AppendResult(interp, "bad argument \"", argv[3], "\": should be \"-command\"", NULL); @@ -6106,16 +5740,16 @@ TestChannelCmd(clientData, interp, argc, argv) * Syntax: unstack channel */ - if (argc != 3) { + if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " unstack channel\"", NULL); - return TCL_ERROR; - } + return TCL_ERROR; + } return Tcl_UnstackChannel(interp, chan); } - Tcl_AppendResult(interp, "bad option \"", cmdName, "\": should be ", - "cut, clearchannelhandlers, info, isshared, mode, open, " + Tcl_AppendResult(interp, "bad option \"", cmdName, "\": should be " + "cut, clearchannelhandlers, info, isshared, mode, open, " "readable, splice, writable, transform, unstack", NULL); return TCL_ERROR; } @@ -6139,198 +5773,197 @@ TestChannelCmd(clientData, interp, argc, argv) /* ARGSUSED */ static int -TestChannelEventCmd(dummy, interp, argc, argv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - CONST char **argv; /* Argument strings. */ +TestChannelEventCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int argc, /* Number of arguments. */ + const char **argv) /* Argument strings. */ { Tcl_Obj *resultListPtr; Channel *chanPtr; ChannelState *statePtr; /* state info for channel */ EventScriptRecord *esPtr, *prevEsPtr, *nextEsPtr; - CONST char *cmd; + const char *cmd; int index, i, mask, len; if ((argc < 3) || (argc > 5)) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " channelName cmd ?arg1? ?arg2?\"", NULL); - return TCL_ERROR; + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " channelName cmd ?arg1? ?arg2?\"", NULL); + return TCL_ERROR; } chanPtr = (Channel *) Tcl_GetChannel(interp, argv[1], NULL); if (chanPtr == NULL) { - return TCL_ERROR; + return TCL_ERROR; } statePtr = chanPtr->state; cmd = argv[2]; len = strlen(cmd); if ((cmd[0] == 'a') && (strncmp(cmd, "add", (unsigned) len) == 0)) { - if (argc != 5) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " channelName add eventSpec script\"", NULL); - return TCL_ERROR; - } - if (strcmp(argv[3], "readable") == 0) { - mask = TCL_READABLE; - } else if (strcmp(argv[3], "writable") == 0) { - mask = TCL_WRITABLE; - } else if (strcmp(argv[3], "none") == 0) { - mask = 0; + if (argc != 5) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " channelName add eventSpec script\"", NULL); + return TCL_ERROR; + } + if (strcmp(argv[3], "readable") == 0) { + mask = TCL_READABLE; + } else if (strcmp(argv[3], "writable") == 0) { + mask = TCL_WRITABLE; + } else if (strcmp(argv[3], "none") == 0) { + mask = 0; } else { - Tcl_AppendResult(interp, "bad event name \"", argv[3], - "\": must be readable, writable, or none", NULL); - return TCL_ERROR; - } + Tcl_AppendResult(interp, "bad event name \"", argv[3], + "\": must be readable, writable, or none", NULL); + return TCL_ERROR; + } - esPtr = (EventScriptRecord *) ckalloc((unsigned) - sizeof(EventScriptRecord)); - esPtr->nextPtr = statePtr->scriptRecordPtr; - statePtr->scriptRecordPtr = esPtr; + esPtr = ckalloc(sizeof(EventScriptRecord)); + esPtr->nextPtr = statePtr->scriptRecordPtr; + statePtr->scriptRecordPtr = esPtr; - esPtr->chanPtr = chanPtr; - esPtr->interp = interp; - esPtr->mask = mask; + esPtr->chanPtr = chanPtr; + esPtr->interp = interp; + esPtr->mask = mask; esPtr->scriptPtr = Tcl_NewStringObj(argv[4], -1); Tcl_IncrRefCount(esPtr->scriptPtr); - Tcl_CreateChannelHandler((Tcl_Channel) chanPtr, mask, - TclChannelEventScriptInvoker, (ClientData) esPtr); + Tcl_CreateChannelHandler((Tcl_Channel) chanPtr, mask, + TclChannelEventScriptInvoker, (ClientData) esPtr); - return TCL_OK; + return TCL_OK; } if ((cmd[0] == 'd') && (strncmp(cmd, "delete", (unsigned) len) == 0)) { - if (argc != 4) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " channelName delete index\"", NULL); - return TCL_ERROR; - } - if (Tcl_GetInt(interp, argv[3], &index) == TCL_ERROR) { - return TCL_ERROR; - } - if (index < 0) { - Tcl_AppendResult(interp, "bad event index: ", argv[3], - ": must be nonnegative", NULL); - return TCL_ERROR; - } - for (i = 0, esPtr = statePtr->scriptRecordPtr; + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " channelName delete index\"", NULL); + return TCL_ERROR; + } + if (Tcl_GetInt(interp, argv[3], &index) == TCL_ERROR) { + return TCL_ERROR; + } + if (index < 0) { + Tcl_AppendResult(interp, "bad event index: ", argv[3], + ": must be nonnegative", NULL); + return TCL_ERROR; + } + for (i = 0, esPtr = statePtr->scriptRecordPtr; (i < index) && (esPtr != NULL); i++, esPtr = esPtr->nextPtr) { /* Empty loop body. */ - } - if (esPtr == NULL) { - Tcl_AppendResult(interp, "bad event index ", argv[3], - ": out of range", NULL); - return TCL_ERROR; - } - if (esPtr == statePtr->scriptRecordPtr) { - statePtr->scriptRecordPtr = esPtr->nextPtr; - } else { - for (prevEsPtr = statePtr->scriptRecordPtr; + } + if (esPtr == NULL) { + Tcl_AppendResult(interp, "bad event index ", argv[3], + ": out of range", NULL); + return TCL_ERROR; + } + if (esPtr == statePtr->scriptRecordPtr) { + statePtr->scriptRecordPtr = esPtr->nextPtr; + } else { + for (prevEsPtr = statePtr->scriptRecordPtr; (prevEsPtr != NULL) && (prevEsPtr->nextPtr != esPtr); prevEsPtr = prevEsPtr->nextPtr) { - /* Empty loop body. */ - } - if (prevEsPtr == NULL) { - Tcl_Panic("TestChannelEventCmd: damaged event script list"); - } - prevEsPtr->nextPtr = esPtr->nextPtr; - } - Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr, - TclChannelEventScriptInvoker, (ClientData) esPtr); + /* Empty loop body. */ + } + if (prevEsPtr == NULL) { + Tcl_Panic("TestChannelEventCmd: damaged event script list"); + } + prevEsPtr->nextPtr = esPtr->nextPtr; + } + Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr, + TclChannelEventScriptInvoker, (ClientData) esPtr); Tcl_DecrRefCount(esPtr->scriptPtr); - ckfree((char *) esPtr); + ckfree(esPtr); - return TCL_OK; + return TCL_OK; } if ((cmd[0] == 'l') && (strncmp(cmd, "list", (unsigned) len) == 0)) { - if (argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " channelName list\"", NULL); - return TCL_ERROR; - } + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " channelName list\"", NULL); + return TCL_ERROR; + } resultListPtr = Tcl_GetObjResult(interp); - for (esPtr = statePtr->scriptRecordPtr; + for (esPtr = statePtr->scriptRecordPtr; esPtr != NULL; esPtr = esPtr->nextPtr) { if (esPtr->mask) { - Tcl_ListObjAppendElement(interp, resultListPtr, Tcl_NewStringObj( + Tcl_ListObjAppendElement(interp, resultListPtr, Tcl_NewStringObj( (esPtr->mask == TCL_READABLE) ? "readable" : "writable", -1)); - } else { - Tcl_ListObjAppendElement(interp, resultListPtr, + } else { + Tcl_ListObjAppendElement(interp, resultListPtr, Tcl_NewStringObj("none", -1)); } - Tcl_ListObjAppendElement(interp, resultListPtr, esPtr->scriptPtr); - } + Tcl_ListObjAppendElement(interp, resultListPtr, esPtr->scriptPtr); + } Tcl_SetObjResult(interp, resultListPtr); - return TCL_OK; + return TCL_OK; } if ((cmd[0] == 'r') && (strncmp(cmd, "removeall", (unsigned) len) == 0)) { - if (argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " channelName removeall\"", NULL); - return TCL_ERROR; - } - for (esPtr = statePtr->scriptRecordPtr; + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " channelName removeall\"", NULL); + return TCL_ERROR; + } + for (esPtr = statePtr->scriptRecordPtr; esPtr != NULL; esPtr = nextEsPtr) { - nextEsPtr = esPtr->nextPtr; - Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr, - TclChannelEventScriptInvoker, (ClientData) esPtr); + nextEsPtr = esPtr->nextPtr; + Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr, + TclChannelEventScriptInvoker, (ClientData) esPtr); Tcl_DecrRefCount(esPtr->scriptPtr); - ckfree((char *) esPtr); - } - statePtr->scriptRecordPtr = NULL; - return TCL_OK; + ckfree(esPtr); + } + statePtr->scriptRecordPtr = NULL; + return TCL_OK; } - if ((cmd[0] == 's') && (strncmp(cmd, "set", (unsigned) len) == 0)) { - if (argc != 5) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " channelName delete index event\"", NULL); - return TCL_ERROR; - } - if (Tcl_GetInt(interp, argv[3], &index) == TCL_ERROR) { - return TCL_ERROR; - } - if (index < 0) { - Tcl_AppendResult(interp, "bad event index: ", argv[3], - ": must be nonnegative", NULL); - return TCL_ERROR; - } - for (i = 0, esPtr = statePtr->scriptRecordPtr; + if ((cmd[0] == 's') && (strncmp(cmd, "set", (unsigned) len) == 0)) { + if (argc != 5) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " channelName delete index event\"", NULL); + return TCL_ERROR; + } + if (Tcl_GetInt(interp, argv[3], &index) == TCL_ERROR) { + return TCL_ERROR; + } + if (index < 0) { + Tcl_AppendResult(interp, "bad event index: ", argv[3], + ": must be nonnegative", NULL); + return TCL_ERROR; + } + for (i = 0, esPtr = statePtr->scriptRecordPtr; (i < index) && (esPtr != NULL); i++, esPtr = esPtr->nextPtr) { /* Empty loop body. */ - } - if (esPtr == NULL) { - Tcl_AppendResult(interp, "bad event index ", argv[3], - ": out of range", NULL); - return TCL_ERROR; - } + } + if (esPtr == NULL) { + Tcl_AppendResult(interp, "bad event index ", argv[3], + ": out of range", NULL); + return TCL_ERROR; + } - if (strcmp(argv[4], "readable") == 0) { - mask = TCL_READABLE; - } else if (strcmp(argv[4], "writable") == 0) { - mask = TCL_WRITABLE; - } else if (strcmp(argv[4], "none") == 0) { - mask = 0; + if (strcmp(argv[4], "readable") == 0) { + mask = TCL_READABLE; + } else if (strcmp(argv[4], "writable") == 0) { + mask = TCL_WRITABLE; + } else if (strcmp(argv[4], "none") == 0) { + mask = 0; } else { - Tcl_AppendResult(interp, "bad event name \"", argv[4], - "\": must be readable, writable, or none", NULL); - return TCL_ERROR; - } + Tcl_AppendResult(interp, "bad event name \"", argv[4], + "\": must be readable, writable, or none", NULL); + return TCL_ERROR; + } esPtr->mask = mask; - Tcl_CreateChannelHandler((Tcl_Channel) chanPtr, mask, - TclChannelEventScriptInvoker, (ClientData) esPtr); + Tcl_CreateChannelHandler((Tcl_Channel) chanPtr, mask, + TclChannelEventScriptInvoker, (ClientData) esPtr); return TCL_OK; } - Tcl_AppendResult(interp, "bad command ", cmd, ", must be one of ", - "add, delete, list, set, or removeall", NULL); + Tcl_AppendResult(interp, "bad command ", cmd, ", must be one of " + "add, delete, list, set, or removeall", NULL); return TCL_ERROR; } @@ -6351,14 +5984,14 @@ TestChannelEventCmd(dummy, interp, argc, argv) */ static int -TestWrongNumArgsObjCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +TestWrongNumArgsObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { int i, length; - char *msg; + const char *msg; if (objc < 3) { /* @@ -6407,13 +6040,13 @@ TestWrongNumArgsObjCmd(dummy, interp, objc, objv) */ static int -TestGetIndexFromObjStructObjCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +TestGetIndexFromObjStructObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { - char *ary[] = { + const char *const ary[] = { "a", "b", "c", "d", "e", "f", NULL, NULL }; int idx,target; @@ -6461,14 +6094,14 @@ TestGetIndexFromObjStructObjCmd(dummy, interp, objc, objv) */ static int -TestFilesystemObjCmd(dummy, interp, objc, objv) - ClientData dummy; - Tcl_Interp *interp; - int objc; - Tcl_Obj *CONST objv[]; +TestFilesystemObjCmd( + ClientData dummy, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) { int res, boolVal; - char *msg; + const char *msg; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "boolean"); @@ -6484,50 +6117,57 @@ TestFilesystemObjCmd(dummy, interp, objc, objv) res = Tcl_FSUnregister(&testReportingFilesystem); msg = (res == TCL_OK) ? "unregistered" : "failed"; } - Tcl_SetResult(interp, msg, TCL_VOLATILE); + Tcl_SetObjResult(interp, Tcl_NewStringObj(msg , -1)); return res; } static int -TestReportInFilesystem(Tcl_Obj *pathPtr, ClientData *clientDataPtr) +TestReportInFilesystem( + Tcl_Obj *pathPtr, + ClientData *clientDataPtr) { - static Tcl_Obj* lastPathPtr = NULL; + static Tcl_Obj *lastPathPtr = NULL; + Tcl_Obj *newPathPtr; if (pathPtr == lastPathPtr) { /* Reject all files second time around */ - return -1; - } else { - Tcl_Obj * newPathPtr; - /* Try to claim all files first time around */ - - newPathPtr = Tcl_DuplicateObj(pathPtr); - lastPathPtr = newPathPtr; - Tcl_IncrRefCount(newPathPtr); - if (Tcl_FSGetFileSystemForPath(newPathPtr) == NULL) { - /* Nothing claimed it. Therefore we don't either */ - Tcl_DecrRefCount(newPathPtr); - lastPathPtr = NULL; - return -1; - } else { - lastPathPtr = NULL; - *clientDataPtr = (ClientData) newPathPtr; - return TCL_OK; - } + return -1; + } + + /* Try to claim all files first time around */ + + newPathPtr = Tcl_DuplicateObj(pathPtr); + lastPathPtr = newPathPtr; + Tcl_IncrRefCount(newPathPtr); + if (Tcl_FSGetFileSystemForPath(newPathPtr) == NULL) { + /* Nothing claimed it. Therefore we don't either */ + Tcl_DecrRefCount(newPathPtr); + lastPathPtr = NULL; + return -1; } + lastPathPtr = NULL; + *clientDataPtr = (ClientData) newPathPtr; + return TCL_OK; } /* - * Simple helper function to extract the native vfs representation of a - * path object, or NULL if no such representation exists. + * Simple helper function to extract the native vfs representation of a path + * object, or NULL if no such representation exists. */ -static Tcl_Obj* -TestReportGetNativePath(Tcl_Obj* pathPtr) { + +static Tcl_Obj * +TestReportGetNativePath( + Tcl_Obj *pathPtr) +{ return (Tcl_Obj*) Tcl_FSGetInternalRep(pathPtr, &testReportingFilesystem); } static void -TestReportFreeInternalRep(ClientData clientData) { - Tcl_Obj *nativeRep = (Tcl_Obj*)clientData; +TestReportFreeInternalRep( + ClientData clientData) +{ + Tcl_Obj *nativeRep = (Tcl_Obj *) clientData; + if (nativeRep != NULL) { /* Free the path */ Tcl_DecrRefCount(nativeRep); @@ -6535,31 +6175,36 @@ TestReportFreeInternalRep(ClientData clientData) { } static ClientData -TestReportDupInternalRep(ClientData clientData) { - Tcl_Obj *original = (Tcl_Obj*)clientData; +TestReportDupInternalRep( + ClientData clientData) +{ + Tcl_Obj *original = (Tcl_Obj *) clientData; + Tcl_IncrRefCount(original); return clientData; } static void -TestReport(cmd, path, arg2) - CONST char* cmd; - Tcl_Obj* path; - Tcl_Obj* arg2; +TestReport( + const char *cmd, + Tcl_Obj *path, + Tcl_Obj *arg2) { - Tcl_Interp* interp = (Tcl_Interp*) Tcl_FSData(&testReportingFilesystem); + Tcl_Interp *interp = (Tcl_Interp *) Tcl_FSData(&testReportingFilesystem); + if (interp == NULL) { /* This is bad, but not much we can do about it */ } else { /* - * No idea why I decided to program this up using the - * old string-based API, but there you go. We should - * convert it to objects. + * No idea why I decided to program this up using the old string-based + * API, but there you go. We should convert it to objects. */ - Tcl_SavedResult savedResult; + + Tcl_Obj *savedResult; Tcl_DString ds; + Tcl_DStringInit(&ds); - Tcl_DStringAppend(&ds, "lappend filesystemReport ",-1); + Tcl_DStringAppend(&ds, "lappend filesystemReport ", -1); Tcl_DStringStartSublist(&ds); Tcl_DStringAppendElement(&ds, cmd); if (path != NULL) { @@ -6569,250 +6214,270 @@ TestReport(cmd, path, arg2) Tcl_DStringAppendElement(&ds, Tcl_GetString(arg2)); } Tcl_DStringEndSublist(&ds); - Tcl_SaveResult(interp, &savedResult); + savedResult = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(savedResult); + Tcl_SetObjResult(interp, Tcl_NewObj()); Tcl_Eval(interp, Tcl_DStringValue(&ds)); Tcl_DStringFree(&ds); - Tcl_RestoreResult(interp, &savedResult); - } + Tcl_ResetResult(interp); + Tcl_SetObjResult(interp, savedResult); + Tcl_DecrRefCount(savedResult); + } } static int -TestReportStat(path, buf) - Tcl_Obj *path; /* Path of file to stat (in current CP). */ - Tcl_StatBuf *buf; /* Filled with results of stat call. */ +TestReportStat( + Tcl_Obj *path, /* Path of file to stat (in current CP). */ + Tcl_StatBuf *buf) /* Filled with results of stat call. */ { - TestReport("stat",path, NULL); - return Tcl_FSStat(TestReportGetNativePath(path),buf); + TestReport("stat", path, NULL); + return Tcl_FSStat(TestReportGetNativePath(path), buf); } + static int -TestReportLstat(path, buf) - Tcl_Obj *path; /* Path of file to stat (in current CP). */ - Tcl_StatBuf *buf; /* Filled with results of stat call. */ +TestReportLstat( + Tcl_Obj *path, /* Path of file to stat (in current CP). */ + Tcl_StatBuf *buf) /* Filled with results of stat call. */ { - TestReport("lstat",path, NULL); - return Tcl_FSLstat(TestReportGetNativePath(path),buf); + TestReport("lstat", path, NULL); + return Tcl_FSLstat(TestReportGetNativePath(path), buf); } + static int -TestReportAccess(path, mode) - Tcl_Obj *path; /* Path of file to access (in current CP). */ - int mode; /* Permission setting. */ +TestReportAccess( + Tcl_Obj *path, /* Path of file to access (in current CP). */ + int mode) /* Permission setting. */ { - TestReport("access",path,NULL); - return Tcl_FSAccess(TestReportGetNativePath(path),mode); + TestReport("access", path, NULL); + return Tcl_FSAccess(TestReportGetNativePath(path), mode); } + static Tcl_Channel -TestReportOpenFileChannel(interp, fileName, mode, permissions) - Tcl_Interp *interp; /* Interpreter for error reporting; - * can be NULL. */ - Tcl_Obj *fileName; /* Name of file to open. */ - int mode; /* POSIX open mode. */ - int permissions; /* If the open involves creating a - * file, with what modes to create - * it? */ -{ - TestReport("open",fileName, NULL); +TestReportOpenFileChannel( + Tcl_Interp *interp, /* Interpreter for error reporting; can be + * NULL. */ + Tcl_Obj *fileName, /* Name of file to open. */ + int mode, /* POSIX open mode. */ + int permissions) /* If the open involves creating a file, with + * what modes to create it? */ +{ + TestReport("open", fileName, NULL); return TclpOpenFileChannel(interp, TestReportGetNativePath(fileName), - mode, permissions); + mode, permissions); } static int -TestReportMatchInDirectory(interp, resultPtr, dirPtr, pattern, types) - Tcl_Interp *interp; /* Interpreter for error - * messages. */ - Tcl_Obj *resultPtr; /* Object to lappend results. */ - Tcl_Obj *dirPtr; /* Contains path to directory to search. */ - CONST char *pattern; /* Pattern to match against. */ - Tcl_GlobTypeData *types; /* Object containing list of acceptable types. +TestReportMatchInDirectory( + Tcl_Interp *interp, /* Interpreter for error messages. */ + Tcl_Obj *resultPtr, /* Object to lappend results. */ + Tcl_Obj *dirPtr, /* Contains path to directory to search. */ + const char *pattern, /* Pattern to match against. */ + Tcl_GlobTypeData *types) /* Object containing list of acceptable types. * May be NULL. */ { if (types != NULL && types->type & TCL_GLOB_TYPE_MOUNT) { - TestReport("matchmounts",dirPtr, NULL); + TestReport("matchmounts", dirPtr, NULL); return TCL_OK; } else { - TestReport("matchindirectory",dirPtr, NULL); + TestReport("matchindirectory", dirPtr, NULL); return Tcl_FSMatchInDirectory(interp, resultPtr, - TestReportGetNativePath(dirPtr), pattern, - types); + TestReportGetNativePath(dirPtr), pattern, types); } } + static int -TestReportChdir(dirName) - Tcl_Obj *dirName; +TestReportChdir( + Tcl_Obj *dirName) { - TestReport("chdir",dirName,NULL); + TestReport("chdir", dirName, NULL); return Tcl_FSChdir(TestReportGetNativePath(dirName)); } + static int -TestReportLoadFile(interp, fileName, - handlePtr, unloadProcPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - Tcl_Obj *fileName; /* Name of the file containing the desired +TestReportLoadFile( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Obj *fileName, /* Name of the file containing the desired * code. */ - Tcl_LoadHandle *handlePtr; /* Filled with token for dynamically loaded + Tcl_LoadHandle *handlePtr, /* Filled with token for dynamically loaded * file which will be passed back to * (*unloadProcPtr)() to unload the file. */ - Tcl_FSUnloadFileProc **unloadProcPtr; + Tcl_FSUnloadFileProc **unloadProcPtr) /* Filled with address of Tcl_FSUnloadFileProc * function which should be used for * this file. */ { - TestReport("loadfile",fileName,NULL); - return Tcl_FSLoadFile(interp, TestReportGetNativePath(fileName), NULL, NULL, - NULL, NULL, handlePtr, unloadProcPtr); + TestReport("loadfile", fileName, NULL); + return Tcl_FSLoadFile(interp, TestReportGetNativePath(fileName), NULL, + NULL, NULL, NULL, handlePtr, unloadProcPtr); } + static Tcl_Obj * -TestReportLink(path, to, linkType) - Tcl_Obj *path; /* Path of file to readlink or link */ - Tcl_Obj *to; /* Path of file to link to, or NULL */ - int linkType; +TestReportLink( + Tcl_Obj *path, /* Path of file to readlink or link */ + Tcl_Obj *to, /* Path of file to link to, or NULL */ + int linkType) { - TestReport("link",path,to); + TestReport("link", path, to); return Tcl_FSLink(TestReportGetNativePath(path), to, linkType); } + static int -TestReportRenameFile(src, dst) - Tcl_Obj *src; /* Pathname of file or dir to be renamed +TestReportRenameFile( + Tcl_Obj *src, /* Pathname of file or dir to be renamed * (UTF-8). */ - Tcl_Obj *dst; /* New pathname of file or directory + Tcl_Obj *dst) /* New pathname of file or directory * (UTF-8). */ { - TestReport("renamefile",src,dst); + TestReport("renamefile", src, dst); return Tcl_FSRenameFile(TestReportGetNativePath(src), - TestReportGetNativePath(dst)); + TestReportGetNativePath(dst)); } + static int -TestReportCopyFile(src, dst) - Tcl_Obj *src; /* Pathname of file to be copied (UTF-8). */ - Tcl_Obj *dst; /* Pathname of file to copy to (UTF-8). */ +TestReportCopyFile( + Tcl_Obj *src, /* Pathname of file to be copied (UTF-8). */ + Tcl_Obj *dst) /* Pathname of file to copy to (UTF-8). */ { - TestReport("copyfile",src,dst); + TestReport("copyfile", src, dst); return Tcl_FSCopyFile(TestReportGetNativePath(src), - TestReportGetNativePath(dst)); + TestReportGetNativePath(dst)); } + static int -TestReportDeleteFile(path) - Tcl_Obj *path; /* Pathname of file to be removed (UTF-8). */ +TestReportDeleteFile( + Tcl_Obj *path) /* Pathname of file to be removed (UTF-8). */ { - TestReport("deletefile",path,NULL); + TestReport("deletefile", path, NULL); return Tcl_FSDeleteFile(TestReportGetNativePath(path)); } + static int -TestReportCreateDirectory(path) - Tcl_Obj *path; /* Pathname of directory to create (UTF-8). */ +TestReportCreateDirectory( + Tcl_Obj *path) /* Pathname of directory to create (UTF-8). */ { - TestReport("createdirectory",path,NULL); + TestReport("createdirectory", path, NULL); return Tcl_FSCreateDirectory(TestReportGetNativePath(path)); } + static int -TestReportCopyDirectory(src, dst, errorPtr) - Tcl_Obj *src; /* Pathname of directory to be copied +TestReportCopyDirectory( + Tcl_Obj *src, /* Pathname of directory to be copied * (UTF-8). */ - Tcl_Obj *dst; /* Pathname of target directory (UTF-8). */ - Tcl_Obj **errorPtr; /* If non-NULL, to be filled with UTF-8 name - * of file causing error. */ + Tcl_Obj *dst, /* Pathname of target directory (UTF-8). */ + Tcl_Obj **errorPtr) /* If non-NULL, to be filled with UTF-8 name + * of file causing error. */ { - TestReport("copydirectory",src,dst); + TestReport("copydirectory", src, dst); return Tcl_FSCopyDirectory(TestReportGetNativePath(src), - TestReportGetNativePath(dst), errorPtr); + TestReportGetNativePath(dst), errorPtr); } + static int -TestReportRemoveDirectory(path, recursive, errorPtr) - Tcl_Obj *path; /* Pathname of directory to be removed +TestReportRemoveDirectory( + Tcl_Obj *path, /* Pathname of directory to be removed * (UTF-8). */ - int recursive; /* If non-zero, removes directories that + int recursive, /* If non-zero, removes directories that * are nonempty. Otherwise, will only remove * empty directories. */ - Tcl_Obj **errorPtr; /* If non-NULL, to be filled with UTF-8 name - * of file causing error. */ + Tcl_Obj **errorPtr) /* If non-NULL, to be filled with UTF-8 name + * of file causing error. */ { - TestReport("removedirectory",path,NULL); + TestReport("removedirectory", path, NULL); return Tcl_FSRemoveDirectory(TestReportGetNativePath(path), recursive, - errorPtr); + errorPtr); } -static CONST char** -TestReportFileAttrStrings(fileName, objPtrRef) - Tcl_Obj* fileName; - Tcl_Obj** objPtrRef; + +static const char *const * +TestReportFileAttrStrings( + Tcl_Obj *fileName, + Tcl_Obj **objPtrRef) { - TestReport("fileattributestrings",fileName,NULL); + TestReport("fileattributestrings", fileName, NULL); return Tcl_FSFileAttrStrings(TestReportGetNativePath(fileName), objPtrRef); } + static int -TestReportFileAttrsGet(interp, index, fileName, objPtrRef) - Tcl_Interp *interp; /* The interpreter for error reporting. */ - int index; /* index of the attribute command. */ - Tcl_Obj *fileName; /* filename we are operating on. */ - Tcl_Obj **objPtrRef; /* for output. */ +TestReportFileAttrsGet( + Tcl_Interp *interp, /* The interpreter for error reporting. */ + int index, /* index of the attribute command. */ + Tcl_Obj *fileName, /* filename we are operating on. */ + Tcl_Obj **objPtrRef) /* for output. */ { - TestReport("fileattributesget",fileName,NULL); + TestReport("fileattributesget", fileName, NULL); return Tcl_FSFileAttrsGet(interp, index, - TestReportGetNativePath(fileName), objPtrRef); + TestReportGetNativePath(fileName), objPtrRef); } + static int -TestReportFileAttrsSet(interp, index, fileName, objPtr) - Tcl_Interp *interp; /* The interpreter for error reporting. */ - int index; /* index of the attribute command. */ - Tcl_Obj *fileName; /* filename we are operating on. */ - Tcl_Obj *objPtr; /* for input. */ +TestReportFileAttrsSet( + Tcl_Interp *interp, /* The interpreter for error reporting. */ + int index, /* index of the attribute command. */ + Tcl_Obj *fileName, /* filename we are operating on. */ + Tcl_Obj *objPtr) /* for input. */ { - TestReport("fileattributesset",fileName,objPtr); + TestReport("fileattributesset", fileName, objPtr); return Tcl_FSFileAttrsSet(interp, index, - TestReportGetNativePath(fileName), objPtr); + TestReportGetNativePath(fileName), objPtr); } + static int -TestReportUtime (fileName, tval) - Tcl_Obj* fileName; - struct utimbuf *tval; +TestReportUtime( + Tcl_Obj *fileName, + struct utimbuf *tval) { - TestReport("utime",fileName,NULL); + TestReport("utime", fileName, NULL); return Tcl_FSUtime(TestReportGetNativePath(fileName), tval); } + static int -TestReportNormalizePath(interp, pathPtr, nextCheckpoint) - Tcl_Interp *interp; - Tcl_Obj *pathPtr; - int nextCheckpoint; +TestReportNormalizePath( + Tcl_Interp *interp, + Tcl_Obj *pathPtr, + int nextCheckpoint) { - TestReport("normalizepath",pathPtr,NULL); + TestReport("normalizepath", pathPtr, NULL); return nextCheckpoint; } static int -SimplePathInFilesystem(Tcl_Obj *pathPtr, ClientData *clientDataPtr) { - CONST char *str = Tcl_GetString(pathPtr); - if (strncmp(str,"simplefs:/",10)) { +SimplePathInFilesystem( + Tcl_Obj *pathPtr, + ClientData *clientDataPtr) +{ + const char *str = Tcl_GetString(pathPtr); + + if (strncmp(str, "simplefs:/", 10)) { return -1; } return TCL_OK; } /* - * This is a slightly 'hacky' filesystem which is used just to test a - * few important features of the vfs code: (1) that you can load a - * shared library from a vfs, (2) that when copying files from one fs to - * another, the 'mtime' is preserved. (3) that recursive - * cross-filesystem directory copies have the correct behaviour - * with/without -force. - * - * It treats any file in 'simplefs:/' as a file, which it - * routes to the current directory. The real file it uses is - * whatever follows the trailing '/' (e.g. 'foo' in 'simplefs:/foo'), - * and that file exists or not according to what is in the native - * pwd. - * - * Please do not consider this filesystem a model of how - * things are to be done. It is quite the opposite! But, it - * does allow us to test some important features. + * This is a slightly 'hacky' filesystem which is used just to test a few + * important features of the vfs code: (1) that you can load a shared library + * from a vfs, (2) that when copying files from one fs to another, the 'mtime' + * is preserved. (3) that recursive cross-filesystem directory copies have the + * correct behaviour with/without -force. + * + * It treats any file in 'simplefs:/' as a file, which it routes to the + * current directory. The real file it uses is whatever follows the trailing + * '/' (e.g. 'foo' in 'simplefs:/foo'), and that file exists or not according + * to what is in the native pwd. + * + * Please do not consider this filesystem a model of how things are to be + * done. It is quite the opposite! But, it does allow us to test some + * important features. */ + static int -TestSimpleFilesystemObjCmd(dummy, interp, objc, objv) - ClientData dummy; - Tcl_Interp *interp; - int objc; - Tcl_Obj *CONST objv[]; +TestSimpleFilesystemObjCmd( + ClientData dummy, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) { int res, boolVal; - char *msg; + const char *msg; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "boolean"); @@ -6828,25 +6493,27 @@ TestSimpleFilesystemObjCmd(dummy, interp, objc, objv) res = Tcl_FSUnregister(&simpleFilesystem); msg = (res == TCL_OK) ? "unregistered" : "failed"; } - Tcl_SetResult(interp, msg, TCL_VOLATILE); + Tcl_SetObjResult(interp, Tcl_NewStringObj(msg , -1)); return res; } /* - * Treats a file name 'simplefs:/foo' by using the file 'foo' - * in the current (native) directory. + * Treats a file name 'simplefs:/foo' by using the file 'foo' in the current + * (native) directory. */ -static Tcl_Obj* -SimpleRedirect(pathPtr) - Tcl_Obj *pathPtr; /* Name of file to copy. */ + +static Tcl_Obj * +SimpleRedirect( + Tcl_Obj *pathPtr) /* Name of file to copy. */ { int len; - CONST char *str; + const char *str; Tcl_Obj *origPtr; /* * We assume the same name in the current directory is ok. */ + str = Tcl_GetStringFromObj(pathPtr, &len); if (len < 10 || strncmp(str, "simplefs:/", 10)) { /* Probably shouldn't ever reach here */ @@ -6859,13 +6526,13 @@ SimpleRedirect(pathPtr) } static int -SimpleMatchInDirectory(interp, resultPtr, dirPtr, pattern, types) - Tcl_Interp *interp; /* Interpreter for error +SimpleMatchInDirectory( + Tcl_Interp *interp, /* Interpreter for error * messages. */ - Tcl_Obj *resultPtr; /* Object to lappend results. */ - Tcl_Obj *dirPtr; /* Contains path to directory to search. */ - CONST char *pattern; /* Pattern to match against. */ - Tcl_GlobTypeData *types; /* Object containing list of acceptable types. + Tcl_Obj *resultPtr, /* Object to lappend results. */ + Tcl_Obj *dirPtr, /* Contains path to directory to search. */ + const char *pattern, /* Pattern to match against. */ + Tcl_GlobTypeData *types) /* Object containing list of acceptable types. * May be NULL. */ { int res; @@ -6883,7 +6550,6 @@ SimpleMatchInDirectory(interp, resultPtr, dirPtr, pattern, types) resPtr = Tcl_NewObj(); Tcl_IncrRefCount(resPtr); origPtr = SimpleRedirect(dirPtr); - Tcl_IncrRefCount(origPtr); res = Tcl_FSMatchInDirectory(interp, resPtr, origPtr, pattern, types); if (res == TCL_OK) { int gLength, j; @@ -6902,14 +6568,13 @@ SimpleMatchInDirectory(interp, resultPtr, dirPtr, pattern, types) } static Tcl_Channel -SimpleOpenFileChannel(interp, pathPtr, mode, permissions) - Tcl_Interp *interp; /* Interpreter for error reporting; - * can be NULL. */ - Tcl_Obj *pathPtr; /* Name of file to open. */ - int mode; /* POSIX open mode. */ - int permissions; /* If the open involves creating a - * file, with what modes to create - * it? */ +SimpleOpenFileChannel( + Tcl_Interp *interp, /* Interpreter for error reporting; can be + * NULL. */ + Tcl_Obj *pathPtr, /* Name of file to open. */ + int mode, /* POSIX open mode. */ + int permissions) /* If the open involves creating a file, with + * what modes to create it? */ { Tcl_Obj *tempPtr; Tcl_Channel chan; @@ -6920,44 +6585,42 @@ SimpleOpenFileChannel(interp, pathPtr, mode, permissions) } tempPtr = SimpleRedirect(pathPtr); - chan = Tcl_FSOpenFileChannel(interp, tempPtr, "r", permissions); - Tcl_DecrRefCount(tempPtr); return chan; } static int -SimpleAccess(pathPtr, mode) - Tcl_Obj *pathPtr; /* Path of file to access (in current CP). */ - int mode; /* Permission setting. */ +SimpleAccess( + Tcl_Obj *pathPtr, /* Path of file to access (in current CP). */ + int mode) /* Permission setting. */ { - int res; Tcl_Obj *tempPtr = SimpleRedirect(pathPtr); - res = Tcl_FSAccess(tempPtr, mode); + int res = Tcl_FSAccess(tempPtr, mode); + Tcl_DecrRefCount(tempPtr); return res; } static int -SimpleStat(pathPtr, bufPtr) - Tcl_Obj *pathPtr; /* Path of file to stat (in current CP). */ - Tcl_StatBuf *bufPtr; /* Filled with results of stat call. */ +SimpleStat( + Tcl_Obj *pathPtr, /* Path of file to stat (in current CP). */ + Tcl_StatBuf *bufPtr) /* Filled with results of stat call. */ { - int res; Tcl_Obj *tempPtr = SimpleRedirect(pathPtr); - res = Tcl_FSStat(tempPtr, bufPtr); + int res = Tcl_FSStat(tempPtr, bufPtr); + Tcl_DecrRefCount(tempPtr); return res; } -static Tcl_Obj* +static Tcl_Obj * SimpleListVolumes(void) { /* Add one new volume */ Tcl_Obj *retVal; - retVal = Tcl_NewStringObj("simplefs:/",-1); + retVal = Tcl_NewStringObj("simplefs:/", -1); Tcl_IncrRefCount(retVal); return retVal; } @@ -6965,15 +6628,17 @@ SimpleListVolumes(void) /* * Used to check correct string-length determining in Tcl_NumUtfChars */ + static int -TestNumUtfCharsCmd(clientData, interp, objc, objv) - ClientData clientData; - Tcl_Interp *interp; - int objc; - Tcl_Obj *CONST objv[]; +TestNumUtfCharsCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) { if (objc > 1) { int len = -1; + if (objc > 2) { (void) Tcl_GetStringFromObj(objv[1], &len); } @@ -6982,18 +6647,75 @@ TestNumUtfCharsCmd(clientData, interp, objc, objv) } return TCL_OK; } + +#if defined(HAVE_CPUID) || defined(_WIN32) +/* + *---------------------------------------------------------------------- + * + * TestcpuidCmd -- + * + * Retrieves CPU ID information. + * + * Usage: + * testwincpuid <eax> + * + * Parameters: + * eax - The value to pass in the EAX register to a CPUID instruction. + * + * Results: + * Returns a four-element list containing the values from the EAX, EBX, + * ECX and EDX registers returned from the CPUID instruction. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestcpuidCmd( + ClientData dummy, + Tcl_Interp* interp, /* Tcl interpreter */ + int objc, /* Parameter count */ + Tcl_Obj *const * objv) /* Parameter vector */ +{ + int status, index, i; + unsigned int regs[4]; + Tcl_Obj *regsObjs[4]; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "eax"); + return TCL_ERROR; + } + if (Tcl_GetIntFromObj(interp, objv[1], &index) != TCL_OK) { + return TCL_ERROR; + } + status = TclWinCPUID((unsigned) index, regs); + if (status != TCL_OK) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("operation not available", -1)); + return status; + } + for (i=0 ; i<4 ; ++i) { + regsObjs[i] = Tcl_NewIntObj((int) regs[i]); + } + Tcl_SetObjResult(interp, Tcl_NewListObj(4, regsObjs)); + return TCL_OK; +} +#endif /* * Used to do basic checks of the TCL_HASH_KEY_SYSTEM_HASH flag */ + static int -TestHashSystemHashCmd(clientData, interp, objc, objv) - ClientData clientData; - Tcl_Interp *interp; - int objc; - Tcl_Obj *CONST objv[]; +TestHashSystemHashCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) { - static Tcl_HashKeyType hkType = { + static const Tcl_HashKeyType hkType = { TCL_HASH_KEY_TYPE_VERSION, TCL_HASH_KEY_SYSTEM_HASH, NULL, NULL, NULL, NULL }; @@ -7014,14 +6736,14 @@ TestHashSystemHashCmd(clientData, interp, objc, objv) } for (i=0 ; i<limit ; i++) { - hPtr = Tcl_CreateHashEntry(&hash, (char *)i, &isNew); + hPtr = Tcl_CreateHashEntry(&hash, INT2PTR(i), &isNew); if (!isNew) { Tcl_SetObjResult(interp, Tcl_NewIntObj(i)); Tcl_AppendToObj(Tcl_GetObjResult(interp)," creation problem",-1); Tcl_DeleteHashTable(&hash); return TCL_ERROR; } - Tcl_SetHashValue(hPtr, (ClientData) (i+42)); + Tcl_SetHashValue(hPtr, INT2PTR(i+42)); } if (hash.numEntries != limit) { @@ -7031,14 +6753,14 @@ TestHashSystemHashCmd(clientData, interp, objc, objv) } for (i=0 ; i<limit ; i++) { - hPtr = Tcl_FindHashEntry(&hash, (char *)i); + hPtr = Tcl_FindHashEntry(&hash, (char *) INT2PTR(i)); if (hPtr == NULL) { Tcl_SetObjResult(interp, Tcl_NewIntObj(i)); Tcl_AppendToObj(Tcl_GetObjResult(interp)," lookup problem",-1); Tcl_DeleteHashTable(&hash); return TCL_ERROR; } - if ((int)(Tcl_GetHashValue(hPtr)) != i+42) { + if (PTR2INT(Tcl_GetHashValue(hPtr)) != i+42) { Tcl_SetObjResult(interp, Tcl_NewIntObj(i)); Tcl_AppendToObj(Tcl_GetObjResult(interp)," value problem",-1); Tcl_DeleteHashTable(&hash); @@ -7063,18 +6785,17 @@ TestHashSystemHashCmd(clientData, interp, objc, objv) * core very much. */ static int -TestgetintCmd(dummy, interp, argc, argv) - ClientData dummy; - Tcl_Interp *interp; - int argc; - CONST char **argv; +TestgetintCmd( + ClientData dummy, + Tcl_Interp *interp, + int argc, + const char **argv) { if (argc < 2) { Tcl_SetResult(interp, "wrong # args", TCL_STATIC); return TCL_ERROR; } else { - int val,i,total=0; - char buf[TCL_INTEGER_SPACE]; + int val, i, total=0; for (i=1 ; i<argc ; i++) { if (Tcl_GetInt(interp, argv[i], &val) != TCL_OK) { @@ -7082,16 +6803,592 @@ TestgetintCmd(dummy, interp, argc, argv) } total += val; } - TclFormatInt(buf, total); - Tcl_SetResult(interp, buf, TCL_VOLATILE); + Tcl_SetObjResult(interp, Tcl_NewIntObj(total)); return TCL_OK; } } +static int +TestNRELevels( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Interp *iPtr = (Interp *) interp; + static ptrdiff_t *refDepth = NULL; + ptrdiff_t depth; + Tcl_Obj *levels[6]; + int i = 0; + NRE_callback *cbPtr = iPtr->execEnvPtr->callbackPtr; + + if (refDepth == NULL) { + refDepth = &depth; + } + + depth = (refDepth - &depth); + + levels[0] = Tcl_NewIntObj(depth); + levels[1] = Tcl_NewIntObj(iPtr->numLevels); + levels[2] = Tcl_NewIntObj(iPtr->cmdFramePtr->level); + levels[3] = Tcl_NewIntObj(iPtr->varFramePtr->level); + levels[4] = Tcl_NewIntObj(iPtr->execEnvPtr->execStackPtr->tosPtr + - iPtr->execEnvPtr->execStackPtr->stackWords); + + while (cbPtr) { + i++; + cbPtr = cbPtr->nextPtr; + } + levels[5] = Tcl_NewIntObj(i); + + Tcl_SetObjResult(interp, Tcl_NewListObj(6, levels)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestconcatobjCmd -- + * + * This procedure implements the "testconcatobj" command. It is used + * to test that Tcl_ConcatObj does indeed return a fresh Tcl_Obj in all + * cases and thet it never corrupts its arguments. In other words, that + * [Bug 1447328] was fixed properly. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestconcatobjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int argc, /* Number of arguments. */ + const char **argv) /* Argument strings. */ +{ + Tcl_Obj *list1Ptr, *list2Ptr, *emptyPtr, *concatPtr, *tmpPtr; + int result = TCL_OK, len; + Tcl_Obj *objv[3]; + + /* + * Set the start of the error message as obj result; it will be cleared at + * the end if no errors were found. + */ + + Tcl_SetObjResult(interp, + Tcl_NewStringObj("Tcl_ConcatObj is unsafe:", -1)); + + emptyPtr = Tcl_NewObj(); + + list1Ptr = Tcl_NewStringObj("foo bar sum", -1); + Tcl_ListObjLength(NULL, list1Ptr, &len); + if (list1Ptr->bytes != NULL) { + ckfree(list1Ptr->bytes); + list1Ptr->bytes = NULL; + } + + list2Ptr = Tcl_NewStringObj("eeny meeny", -1); + Tcl_ListObjLength(NULL, list2Ptr, &len); + if (list2Ptr->bytes != NULL) { + ckfree(list2Ptr->bytes); + list2Ptr->bytes = NULL; + } + + /* + * Verify that concat'ing a list obj with one or more empty strings does + * return a fresh Tcl_Obj (see also [Bug 2055782]). + */ + + tmpPtr = Tcl_DuplicateObj(list1Ptr); + + objv[0] = tmpPtr; + objv[1] = emptyPtr; + concatPtr = Tcl_ConcatObj(2, objv); + if (concatPtr->refCount != 0) { + result = TCL_ERROR; + Tcl_AppendResult(interp, + "\n\t* (a) concatObj does not have refCount 0", NULL); + } + if (concatPtr == tmpPtr) { + result = TCL_ERROR; + Tcl_AppendResult(interp, "\n\t* (a) concatObj is not a new obj ", + NULL); + switch (tmpPtr->refCount) { + case 0: + Tcl_AppendResult(interp, "(no new refCount)", NULL); + break; + case 1: + Tcl_AppendResult(interp, "(refCount added)", NULL); + break; + default: + Tcl_AppendResult(interp, "(more than one refCount added!)", NULL); + Tcl_Panic("extremely unsafe behaviour by Tcl_ConcatObj()"); + } + tmpPtr = Tcl_DuplicateObj(list1Ptr); + objv[0] = tmpPtr; + } + Tcl_DecrRefCount(concatPtr); + + Tcl_IncrRefCount(tmpPtr); + concatPtr = Tcl_ConcatObj(2, objv); + if (concatPtr->refCount != 0) { + result = TCL_ERROR; + Tcl_AppendResult(interp, + "\n\t* (b) concatObj does not have refCount 0", NULL); + } + if (concatPtr == tmpPtr) { + result = TCL_ERROR; + Tcl_AppendResult(interp, "\n\t* (b) concatObj is not a new obj ", + NULL); + switch (tmpPtr->refCount) { + case 0: + Tcl_AppendResult(interp, "(refCount removed?)", NULL); + Tcl_Panic("extremely unsafe behaviour by Tcl_ConcatObj()"); + break; + case 1: + Tcl_AppendResult(interp, "(no new refCount)", NULL); + break; + case 2: + Tcl_AppendResult(interp, "(refCount added)", NULL); + Tcl_DecrRefCount(tmpPtr); + break; + default: + Tcl_AppendResult(interp, "(more than one refCount added!)", NULL); + Tcl_Panic("extremely unsafe behaviour by Tcl_ConcatObj()"); + } + tmpPtr = Tcl_DuplicateObj(list1Ptr); + objv[0] = tmpPtr; + } + Tcl_DecrRefCount(concatPtr); + + objv[0] = emptyPtr; + objv[1] = tmpPtr; + objv[2] = emptyPtr; + concatPtr = Tcl_ConcatObj(3, objv); + if (concatPtr->refCount != 0) { + result = TCL_ERROR; + Tcl_AppendResult(interp, + "\n\t* (c) concatObj does not have refCount 0", NULL); + } + if (concatPtr == tmpPtr) { + result = TCL_ERROR; + Tcl_AppendResult(interp, "\n\t* (c) concatObj is not a new obj ", + NULL); + switch (tmpPtr->refCount) { + case 0: + Tcl_AppendResult(interp, "(no new refCount)", NULL); + break; + case 1: + Tcl_AppendResult(interp, "(refCount added)", NULL); + break; + default: + Tcl_AppendResult(interp, "(more than one refCount added!)", NULL); + Tcl_Panic("extremely unsafe behaviour by Tcl_ConcatObj()"); + } + tmpPtr = Tcl_DuplicateObj(list1Ptr); + objv[1] = tmpPtr; + } + Tcl_DecrRefCount(concatPtr); + + Tcl_IncrRefCount(tmpPtr); + concatPtr = Tcl_ConcatObj(3, objv); + if (concatPtr->refCount != 0) { + result = TCL_ERROR; + Tcl_AppendResult(interp, + "\n\t* (d) concatObj does not have refCount 0", NULL); + } + if (concatPtr == tmpPtr) { + result = TCL_ERROR; + Tcl_AppendResult(interp, "\n\t* (d) concatObj is not a new obj ", + NULL); + switch (tmpPtr->refCount) { + case 0: + Tcl_AppendResult(interp, "(refCount removed?)", NULL); + Tcl_Panic("extremely unsafe behaviour by Tcl_ConcatObj()"); + break; + case 1: + Tcl_AppendResult(interp, "(no new refCount)", NULL); + break; + case 2: + Tcl_AppendResult(interp, "(refCount added)", NULL); + Tcl_DecrRefCount(tmpPtr); + break; + default: + Tcl_AppendResult(interp, "(more than one refCount added!)", NULL); + Tcl_Panic("extremely unsafe behaviour by Tcl_ConcatObj()"); + } + tmpPtr = Tcl_DuplicateObj(list1Ptr); + objv[1] = tmpPtr; + } + Tcl_DecrRefCount(concatPtr); + + /* + * Verify that an unshared list is not corrupted when concat'ing things to + * it. + */ + + objv[0] = tmpPtr; + objv[1] = list2Ptr; + concatPtr = Tcl_ConcatObj(2, objv); + if (concatPtr->refCount != 0) { + result = TCL_ERROR; + Tcl_AppendResult(interp, + "\n\t* (e) concatObj does not have refCount 0", NULL); + } + if (concatPtr == tmpPtr) { + int len; + + result = TCL_ERROR; + Tcl_AppendResult(interp, "\n\t* (e) concatObj is not a new obj ", + NULL); + + (void) Tcl_ListObjLength(NULL, concatPtr, &len); + switch (tmpPtr->refCount) { + case 3: + Tcl_AppendResult(interp, "(failed to concat)", NULL); + break; + default: + Tcl_AppendResult(interp, "(corrupted input!)", NULL); + } + if (Tcl_IsShared(tmpPtr)) { + Tcl_DecrRefCount(tmpPtr); + } + tmpPtr = Tcl_DuplicateObj(list1Ptr); + objv[0] = tmpPtr; + } + Tcl_DecrRefCount(concatPtr); + + objv[0] = tmpPtr; + objv[1] = list2Ptr; + Tcl_IncrRefCount(tmpPtr); + concatPtr = Tcl_ConcatObj(2, objv); + if (concatPtr->refCount != 0) { + result = TCL_ERROR; + Tcl_AppendResult(interp, + "\n\t* (f) concatObj does not have refCount 0", NULL); + } + if (concatPtr == tmpPtr) { + int len; + + result = TCL_ERROR; + Tcl_AppendResult(interp, "\n\t* (f) concatObj is not a new obj ", + NULL); + + (void) Tcl_ListObjLength(NULL, concatPtr, &len); + switch (tmpPtr->refCount) { + case 3: + Tcl_AppendResult(interp, "(failed to concat)", NULL); + break; + default: + Tcl_AppendResult(interp, "(corrupted input!)", NULL); + } + if (Tcl_IsShared(tmpPtr)) { + Tcl_DecrRefCount(tmpPtr); + } + tmpPtr = Tcl_DuplicateObj(list1Ptr); + objv[0] = tmpPtr; + } + Tcl_DecrRefCount(concatPtr); + + objv[0] = tmpPtr; + objv[1] = list2Ptr; + Tcl_IncrRefCount(tmpPtr); + Tcl_IncrRefCount(tmpPtr); + concatPtr = Tcl_ConcatObj(2, objv); + if (concatPtr->refCount != 0) { + result = TCL_ERROR; + Tcl_AppendResult(interp, + "\n\t* (g) concatObj does not have refCount 0", NULL); + } + if (concatPtr == tmpPtr) { + int len; + + result = TCL_ERROR; + Tcl_AppendResult(interp, "\n\t* (g) concatObj is not a new obj ", + NULL); + + (void) Tcl_ListObjLength(NULL, concatPtr, &len); + switch (tmpPtr->refCount) { + case 3: + Tcl_AppendResult(interp, "(failed to concat)", NULL); + break; + default: + Tcl_AppendResult(interp, "(corrupted input!)", NULL); + } + Tcl_DecrRefCount(tmpPtr); + if (Tcl_IsShared(tmpPtr)) { + Tcl_DecrRefCount(tmpPtr); + } + tmpPtr = Tcl_DuplicateObj(list1Ptr); + objv[0] = tmpPtr; + } + Tcl_DecrRefCount(concatPtr); + + /* + * Clean everything up. Note that we don't actually know how many + * references there are to tmpPtr here; in the no-error case, it should be + * five... [Bug 2895367] + */ + + Tcl_DecrRefCount(list1Ptr); + Tcl_DecrRefCount(list2Ptr); + Tcl_DecrRefCount(emptyPtr); + while (tmpPtr->refCount > 1) { + Tcl_DecrRefCount(tmpPtr); + } + Tcl_DecrRefCount(tmpPtr); + + if (result == TCL_OK) { + Tcl_ResetResult(interp); + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TestparseargsCmd -- + * + * This procedure implements the "testparseargs" command. It is used to + * test that Tcl_ParseArgsObjv does indeed return the right number of + * arguments. In other words, that [Bug 3413857] was fixed properly. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestparseargsCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Arguments. */ +{ + static int foo = 0; + int count = objc; + Tcl_Obj **remObjv, *result[3]; + Tcl_ArgvInfo argTable[] = { + {TCL_ARGV_CONSTANT, "-bool", INT2PTR(1), &foo, "booltest", NULL}, + TCL_ARGV_AUTO_REST, TCL_ARGV_AUTO_HELP, TCL_ARGV_TABLE_END + }; + + foo = 0; + if (Tcl_ParseArgsObjv(interp, argTable, &count, objv, &remObjv)!=TCL_OK) { + return TCL_ERROR; + } + result[0] = Tcl_NewIntObj(foo); + result[1] = Tcl_NewIntObj(count); + result[2] = Tcl_NewListObj(count, remObjv); + Tcl_SetObjResult(interp, Tcl_NewListObj(3, result)); + ckfree(remObjv); + return TCL_OK; +} + +/** + * Test harness for command and variable resolvers. + */ + +static int +InterpCmdResolver( + Tcl_Interp *interp, + const char *name, + Tcl_Namespace *context, + int flags, + Tcl_Command *rPtr) +{ + Interp *iPtr = (Interp *) interp; + CallFrame *varFramePtr = iPtr->varFramePtr; + Proc *procPtr = (varFramePtr->isProcCallFrame & FRAME_IS_PROC) ? + varFramePtr->procPtr : NULL; + Namespace *ns2NsPtr = (Namespace *) + Tcl_FindNamespace(interp, "::ns2", NULL, 0); + + if (procPtr && (procPtr->cmdPtr->nsPtr == iPtr->globalNsPtr + || (ns2NsPtr && procPtr->cmdPtr->nsPtr == ns2NsPtr))) { + const char *callingCmdName = + Tcl_GetCommandName(interp, (Tcl_Command) procPtr->cmdPtr); + + if ((callingCmdName[0] == 'x') && (callingCmdName[1] == '\0') + && (name[0] == 'z') && (name[1] == '\0')) { + Tcl_Command sourceCmdPtr = Tcl_FindCommand(interp, "y", NULL, + TCL_GLOBAL_ONLY); + + if (sourceCmdPtr != NULL) { + *rPtr = sourceCmdPtr; + return TCL_OK; + } + } + } + return TCL_CONTINUE; +} + +static int +InterpVarResolver( + Tcl_Interp *interp, + const char *name, + Tcl_Namespace *context, + int flags, + Tcl_Var *rPtr) +{ + /* + * Don't resolve the variable; use standard rules. + */ + + return TCL_CONTINUE; +} + +typedef struct MyResolvedVarInfo { + Tcl_ResolvedVarInfo vInfo; /* This must be the first element. */ + Tcl_Var var; + Tcl_Obj *nameObj; +} MyResolvedVarInfo; + +static inline void +HashVarFree( + Tcl_Var var) +{ + if (VarHashRefCount(var) < 2) { + ckfree(var); + } else { + VarHashRefCount(var)--; + } +} + +static void +MyCompiledVarFree( + Tcl_ResolvedVarInfo *vInfoPtr) +{ + MyResolvedVarInfo *resVarInfo = (MyResolvedVarInfo *) vInfoPtr; + + Tcl_DecrRefCount(resVarInfo->nameObj); + if (resVarInfo->var) { + HashVarFree(resVarInfo->var); + } + ckfree(vInfoPtr); +} + +#define TclVarHashGetValue(hPtr) \ + ((Var *) ((char *)hPtr - TclOffset(VarInHash, entry))) + +static Tcl_Var +MyCompiledVarFetch( + Tcl_Interp *interp, + Tcl_ResolvedVarInfo *vinfoPtr) +{ + MyResolvedVarInfo *resVarInfo = (MyResolvedVarInfo *) vinfoPtr; + Tcl_Var var = resVarInfo->var; + int isNewVar; + Interp *iPtr = (Interp *) interp; + Tcl_HashEntry *hPtr; + + if (var != NULL) { + if (!(((Var *) var)->flags & VAR_DEAD_HASH)) { + /* + * The cached variable is valid, return it. + */ + + return var; + } + + /* + * The variable is not valid anymore. Clean it up. + */ + + HashVarFree(var); + } + + hPtr = Tcl_CreateHashEntry((Tcl_HashTable *) &iPtr->globalNsPtr->varTable, + (char *) resVarInfo->nameObj, &isNewVar); + if (hPtr) { + var = (Tcl_Var) TclVarHashGetValue(hPtr); + } else { + var = NULL; + } + resVarInfo->var = var; + + /* + * Increment the reference counter to avoid ckfree() of the variable in + * Tcl's FreeVarEntry(); for cleanup, we provide our own HashVarFree(); + */ + + VarHashRefCount(var)++; + return var; +} + +static int +InterpCompiledVarResolver( + Tcl_Interp *interp, + const char *name, + int length, + Tcl_Namespace *context, + Tcl_ResolvedVarInfo **rPtr) +{ + if (*name == 'T') { + MyResolvedVarInfo *resVarInfo = ckalloc(sizeof(MyResolvedVarInfo)); + + resVarInfo->vInfo.fetchProc = MyCompiledVarFetch; + resVarInfo->vInfo.deleteProc = MyCompiledVarFree; + resVarInfo->var = NULL; + resVarInfo->nameObj = Tcl_NewStringObj(name, -1); + Tcl_IncrRefCount(resVarInfo->nameObj); + *rPtr = &resVarInfo->vInfo; + return TCL_OK; + } + return TCL_CONTINUE; +} + +static int +TestInterpResolverCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + static const char *const table[] = { + "down", "up", NULL + }; + int idx; +#define RESOLVER_KEY "testInterpResolver" + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "up|down"); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[1], table, "operation", TCL_EXACT, + &idx) != TCL_OK) { + return TCL_ERROR; + } + switch (idx) { + case 1: /* up */ + Tcl_AddInterpResolvers(interp, RESOLVER_KEY, InterpCmdResolver, + InterpVarResolver, InterpCompiledVarResolver); + break; + case 0: /*down*/ + if (!Tcl_RemoveInterpResolvers(interp, RESOLVER_KEY)) { + Tcl_AppendResult(interp, "could not remove the resolver scheme", + NULL); + return TCL_ERROR; + } + } + return TCL_OK; +} + /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 + * tab-width: 8 + * indent-tabs-mode: nil * End: */ |