diff options
Diffstat (limited to 'generic/tclTest.c')
| -rw-r--r-- | generic/tclTest.c | 4897 |
1 files changed, 1846 insertions, 3051 deletions
diff --git a/generic/tclTest.c b/generic/tclTest.c index e656985..1d92ff5 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -6,34 +6,18 @@ * commands are not normally included in Tcl applications; they're only * used for testing. * - * Copyright © 1993-1994 The Regents of the University of California. - * Copyright © 1994-1997 Sun Microsystems, Inc. - * Copyright © 1998-2000 Ajuba Solutions. - * Copyright © 2003 Kevin B. Kenny. All rights reserved. + * Copyright (c) 1993-1994 The Regents of the University of California. + * Copyright (c) 1994-1997 Sun Microsystems, Inc. + * Copyright (c) 1998-2000 Ajuba Solutions. + * Copyright (c) 2003 by Kevin B. Kenny. All rights reserved. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ -#undef STATIC_BUILD -#undef BUILD_tcl -#ifndef USE_TCL_STUBS -# define USE_TCL_STUBS -#endif -#undef TCL_UTF_MAX -#ifdef TCL_NO_DEPRECATED -# define TCL_UTF_MAX 4 -#else -# define TCL_NO_DEPRECATED -# define TCL_UTF_MAX 3 -#endif +#define TCL_TEST #include "tclInt.h" -#ifdef TCL_WITH_EXTERNAL_TOMMATH -# include "tommath.h" -#else -# include "tclTomMath.h" -#endif -#include "tclOO.h" + #include <math.h> /* @@ -42,17 +26,18 @@ #include "tclRegexp.h" /* + * Required for TestlocaleCmd + */ +#include <locale.h> + +/* * Required for the TestChannelCmd and TestChannelEventCmd */ #include "tclIO.h" -#include "tclUuid.h" - /* * Declare external functions used in Windows tests. */ -DLLEXPORT int Tcltest_Init(Tcl_Interp *interp); -DLLEXPORT int Tcltest_SafeInit(Tcl_Interp *interp); /* * Dynamic string shared by TestdcallCmd and DelCallbackProc; used to collect @@ -63,22 +48,6 @@ static Tcl_DString delString; static Tcl_Interp *delInterp; /* - * One of the following structures exists for each command created by the - * "testcmdtoken" command. - */ - -typedef struct TestCommandTokenRef { - int id; /* Identifier for this reference. */ - Tcl_Command token; /* Tcl's token for the command. */ - const char *value; - struct TestCommandTokenRef *nextPtr; - /* Next in list of references. */ -} TestCommandTokenRef; - -static TestCommandTokenRef *firstCommandTokenRef = NULL; -static int nextCommandTokenRefId = 1; - -/* * One of the following structures exists for each asynchronous handler * created by the "testasync" command". */ @@ -92,18 +61,7 @@ typedef struct TestAsyncHandler { /* Next is list of handlers. */ } TestAsyncHandler; -/* - * Start of the socket driver state structure to acces field testFlags - */ - -typedef struct TcpState TcpState; - -struct TcpState { - Tcl_Channel channel; /* Channel associated with this socket. */ - int flags; /* ORed combination of various bitfields. */ -}; - -TCL_DECLARE_MUTEX(asyncTestMutex) +TCL_DECLARE_MUTEX(asyncTestMutex); static TestAsyncHandler *firstHandler = NULL; @@ -126,7 +84,7 @@ static Tcl_Trace cmdTrace; * TestdelCmd: */ -typedef struct { +typedef struct DelCmd { Tcl_Interp *interp; /* Interpreter in which command exists. */ char *deleteCmd; /* Script to execute when command is deleted. * Malloc'ed. */ @@ -137,7 +95,7 @@ typedef struct { * command. */ -typedef struct { +typedef struct TclEncoding { Tcl_Interp *interp; char *toUtfCmd; char *fromUtfCmd; @@ -148,9 +106,7 @@ typedef struct { * was called for a result. */ -#ifndef TCL_NO_DEPRECATED static int freeCount; -#endif /* TCL_NO_DEPRECATED */ /* * Boolean flag used by the "testsetmainloop" and "testexitmainloop" commands. @@ -162,7 +118,7 @@ static int exitMainLoop = 0; * Event structure used in testing the event queue management procedures. */ -typedef struct { +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 */ @@ -181,235 +137,353 @@ typedef struct TestChannel { static TestChannel *firstDetached; -#ifdef __GNUC__ -/* - * The rest of this file shouldn't warn about deprecated functions; they're - * there because we intend them to be so and know that this file is OK to - * touch those fields. - */ -#pragma GCC diagnostic ignored "-Wdeprecated-declarations" -#endif - /* * Forward declarations for procedures defined later in this file: */ -static int AsyncHandlerProc(void *clientData, +int Tcltest_Init(Tcl_Interp *interp); +static int AsyncHandlerProc(ClientData clientData, Tcl_Interp *interp, int code); -static Tcl_ThreadCreateType AsyncThreadProc(void *); +#ifdef TCL_THREADS +static Tcl_ThreadCreateType AsyncThreadProc(ClientData); +#endif static void CleanupTestSetassocdataTests( - void *clientData, Tcl_Interp *interp); -static void CmdDelProc1(void *clientData); -static void CmdDelProc2(void *clientData); -static Tcl_CmdProc CmdProc1; -static Tcl_CmdProc CmdProc2; + ClientData clientData, Tcl_Interp *interp); +static void CmdDelProc1(ClientData clientData); +static void CmdDelProc2(ClientData clientData); +static int CmdProc1(ClientData clientData, + Tcl_Interp *interp, int argc, const char **argv); +static int CmdProc2(ClientData clientData, + Tcl_Interp *interp, int argc, const char **argv); static void CmdTraceDeleteProc( - void *clientData, Tcl_Interp *interp, + ClientData clientData, Tcl_Interp *interp, int level, char *command, Tcl_CmdProc *cmdProc, - void *cmdClientData, int argc, - const char *argv[]); -static void CmdTraceProc(void *clientData, + ClientData cmdClientData, int argc, + char **argv); +static void CmdTraceProc(ClientData clientData, Tcl_Interp *interp, int level, char *command, - Tcl_CmdProc *cmdProc, void *cmdClientData, - int argc, const char *argv[]); -static Tcl_CmdProc CreatedCommandProc; -static Tcl_CmdProc CreatedCommandProc2; -static void DelCallbackProc(void *clientData, + Tcl_CmdProc *cmdProc, ClientData cmdClientData, + int argc, char **argv); +static int CreatedCommandProc( + ClientData clientData, Tcl_Interp *interp, + int argc, const char **argv); +static int CreatedCommandProc2( + ClientData clientData, Tcl_Interp *interp, + int argc, const char **argv); +static void DelCallbackProc(ClientData clientData, Tcl_Interp *interp); -static Tcl_CmdProc DelCmdProc; -static void DelDeleteProc(void *clientData); -static void EncodingFreeProc(void *clientData); -static int EncodingToUtfProc(void *clientData, +static int DelCmdProc(ClientData clientData, + 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, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); -static int EncodingFromUtfProc(void *clientData, +static int EncodingFromUtfProc(ClientData clientData, const char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); -static void ExitProcEven(void *clientData); -static void ExitProcOdd(void *clientData); -static Tcl_ObjCmdProc GetTimesObjCmd; -static Tcl_ResolveCompiledVarProc InterpCompiledVarResolver; +static void ExitProcEven(ClientData clientData); +static void ExitProcOdd(ClientData clientData); +static int GetTimesCmd(ClientData clientData, + Tcl_Interp *interp, int argc, const char **argv); static void MainLoop(void); -static Tcl_CmdProc NoopCmd; -static Tcl_ObjCmdProc NoopObjCmd; -static Tcl_CmdObjTraceProc2 ObjTraceProc; -static void ObjTraceDeleteProc(void *clientData); +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_Command commandToken, int objc, + Tcl_Obj *const objv[]); +static void ObjTraceDeleteProc(ClientData clientData); static void PrintParse(Tcl_Interp *interp, Tcl_Parse *parsePtr); -static Tcl_FreeProc SpecialFree; +static void SpecialFree(char *blockPtr); static int StaticInitProc(Tcl_Interp *interp); -static Tcl_CmdProc TestasyncCmd; -static Tcl_ObjCmdProc TestbumpinterpepochObjCmd; -static Tcl_ObjCmdProc TestbytestringObjCmd; -static Tcl_ObjCmdProc TestsetbytearraylengthObjCmd; -static Tcl_ObjCmdProc TestpurebytesobjObjCmd; -static Tcl_ObjCmdProc TeststringbytesObjCmd; -static Tcl_ObjCmdProc Testutf16stringObjCmd; -static Tcl_ObjCmdProc TestcmdinfoObjCmd; -static Tcl_CmdProc TestcmdtokenCmd; -static Tcl_CmdProc TestcmdtraceCmd; -static Tcl_CmdProc TestconcatobjCmd; -static Tcl_CmdProc TestcreatecommandCmd; -static Tcl_CmdProc TestdcallCmd; -static Tcl_CmdProc TestdelCmd; -static Tcl_CmdProc TestdelassocdataCmd; -static Tcl_ObjCmdProc TestdoubledigitsObjCmd; -static Tcl_CmdProc TestdstringCmd; -static Tcl_ObjCmdProc TestencodingObjCmd; -static Tcl_ObjCmdProc TestevalexObjCmd; -static Tcl_ObjCmdProc TestevalobjvObjCmd; -static Tcl_ObjCmdProc TesteventObjCmd; +#undef USE_OBSOLETE_FS_HOOKS +#ifdef USE_OBSOLETE_FS_HOOKS +static int TestaccessprocCmd(ClientData dummy, + Tcl_Interp *interp, int argc, const char **argv); +static int TestopenfilechannelprocCmd( + ClientData dummy, Tcl_Interp *interp, int argc, + const char **argv); +static int TeststatprocCmd(ClientData dummy, + Tcl_Interp *interp, int argc, const char **argv); +static int PretendTclpAccess(const char *path, int mode); +static int TestAccessProc1(const char *path, int mode); +static int TestAccessProc2(const char *path, int mode); +static int TestAccessProc3(const char *path, int mode); +static Tcl_Channel PretendTclpOpenFileChannel( + Tcl_Interp *interp, const char *fileName, + const char *modeString, int permissions); +static Tcl_Channel TestOpenFileChannelProc1( + Tcl_Interp *interp, const char *fileName, + const char *modeString, int permissions); +static Tcl_Channel TestOpenFileChannelProc2( + Tcl_Interp *interp, const char *fileName, + const char *modeString, int permissions); +static Tcl_Channel TestOpenFileChannelProc3( + Tcl_Interp *interp, const char *fileName, + const char *modeString, int permissions); +static int PretendTclpStat(const char *path, struct stat *buf); +static int TestStatProc1(const char *path, struct stat *buf); +static int TestStatProc2(const char *path, struct stat *buf); +static int TestStatProc3(const char *path, struct stat *buf); +#endif +static int TestasyncCmd(ClientData dummy, + Tcl_Interp *interp, int argc, const char **argv); +static int TestcmdinfoCmd(ClientData dummy, + Tcl_Interp *interp, int argc, const char **argv); +static int TestcmdtokenCmd(ClientData dummy, + Tcl_Interp *interp, int argc, const char **argv); +static int TestcmdtraceCmd(ClientData dummy, + 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); +static int TestdcallCmd(ClientData dummy, + Tcl_Interp *interp, int argc, const char **argv); +static int TestdelCmd(ClientData dummy, + Tcl_Interp *interp, int argc, const char **argv); +static int TestdelassocdataCmd(ClientData dummy, + 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); +static int TestencodingObjCmd(ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static int TestevalexObjCmd(ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static int TestevalobjvObjCmd(ClientData dummy, + Tcl_Interp *interp, int objc, + 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, - void *clientData); -static Tcl_CmdProc TestexithandlerCmd; -static Tcl_CmdProc TestexprlongCmd; -static Tcl_ObjCmdProc TestexprlongobjCmd; -static Tcl_CmdProc TestexprdoubleCmd; -static Tcl_ObjCmdProc TestexprdoubleobjCmd; -static Tcl_ObjCmdProc TestexprparserObjCmd; -static Tcl_CmdProc TestexprstringCmd; -static Tcl_ObjCmdProc TestfileCmd; -static Tcl_ObjCmdProc TestfilelinkCmd; -static Tcl_CmdProc TestfeventCmd; -static Tcl_CmdProc TestgetassocdataCmd; -static Tcl_CmdProc TestgetintCmd; -static Tcl_CmdProc TestlongsizeCmd; -static Tcl_CmdProc TestgetplatformCmd; -static Tcl_ObjCmdProc TestgetvarfullnameCmd; -static Tcl_CmdProc TestinterpdeleteCmd; -static Tcl_CmdProc TestlinkCmd; -static Tcl_ObjCmdProc TestlinkarrayCmd; -static Tcl_ObjCmdProc TestlistrepCmd; -static Tcl_ObjCmdProc TestlocaleCmd; -static Tcl_CmdProc TestmainthreadCmd; -static Tcl_CmdProc TestsetmainloopCmd; -static Tcl_CmdProc TestexitmainloopCmd; -static Tcl_CmdProc TestpanicCmd; -static Tcl_ObjCmdProc TestparseargsCmd; -static Tcl_ObjCmdProc TestparserObjCmd; -static Tcl_ObjCmdProc TestparsevarObjCmd; -static Tcl_ObjCmdProc TestparsevarnameObjCmd; -static Tcl_ObjCmdProc TestpreferstableObjCmd; -static Tcl_ObjCmdProc TestprintObjCmd; -static Tcl_ObjCmdProc TestregexpObjCmd; -static Tcl_ObjCmdProc TestreturnObjCmd; -static void TestregexpXflags(const char *string, - size_t length, int *cflagsPtr, int *eflagsPtr); -#ifndef TCL_NO_DEPRECATED -static Tcl_ObjCmdProc TestsaveresultCmd; -static Tcl_FreeProc TestsaveresultFree; -#endif /* TCL_NO_DEPRECATED */ -static Tcl_CmdProc TestsetassocdataCmd; -static Tcl_CmdProc TestsetCmd; -static Tcl_CmdProc Testset2Cmd; -static Tcl_CmdProc TestseterrorcodeCmd; -static Tcl_ObjCmdProc TestsetobjerrorcodeCmd; -static Tcl_CmdProc TestsetplatformCmd; -static Tcl_CmdProc TeststaticlibraryCmd; -static Tcl_CmdProc TesttranslatefilenameCmd; -static Tcl_CmdProc TestupvarCmd; -static Tcl_ObjCmdProc2 TestWrongNumArgsObjCmd; -static Tcl_ObjCmdProc TestGetIndexFromObjStructObjCmd; -static Tcl_CmdProc TestChannelCmd; -static Tcl_CmdProc TestChannelEventCmd; -static Tcl_CmdProc TestSocketCmd; -static Tcl_ObjCmdProc TestFilesystemObjCmd; -static Tcl_ObjCmdProc TestSimpleFilesystemObjCmd; + ClientData clientData); +static int TestexithandlerCmd(ClientData dummy, + Tcl_Interp *interp, int argc, const char **argv); +static int TestexprlongCmd(ClientData dummy, + Tcl_Interp *interp, int argc, const char **argv); +static int TestexprlongobjCmd(ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static int TestexprdoubleCmd(ClientData dummy, + Tcl_Interp *interp, int argc, const char **argv); +static int TestexprdoubleobjCmd(ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static int TestexprparserObjCmd(ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static int TestexprstringCmd(ClientData dummy, + Tcl_Interp *interp, int argc, const char **argv); +static int TestfileCmd(ClientData dummy, + Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); +static int TestfilelinkCmd(ClientData dummy, + Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); +static int TestfeventCmd(ClientData dummy, + Tcl_Interp *interp, int argc, const char **argv); +static int TestgetassocdataCmd(ClientData dummy, + Tcl_Interp *interp, int argc, const char **argv); +static int TestgetintCmd(ClientData dummy, + Tcl_Interp *interp, int argc, const char **argv); +static int TestgetplatformCmd(ClientData dummy, + Tcl_Interp *interp, int argc, const char **argv); +static int TestgetvarfullnameCmd( + ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +static int TestinterpdeleteCmd(ClientData dummy, + Tcl_Interp *interp, int argc, const char **argv); +static int TestlinkCmd(ClientData dummy, + Tcl_Interp *interp, int argc, const char **argv); +static int TestlocaleCmd(ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static int TestMathFunc(ClientData clientData, + Tcl_Interp *interp, Tcl_Value *args, + Tcl_Value *resultPtr); +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); +static int TestsetmainloopCmd(ClientData dummy, + Tcl_Interp *interp, int argc, const char **argv); +static int TestexitmainloopCmd(ClientData dummy, + Tcl_Interp *interp, int argc, const char **argv); +static int TestpanicCmd(ClientData dummy, + Tcl_Interp *interp, int argc, const char **argv); +static int TestparserObjCmd(ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static int TestparsevarObjCmd(ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static int TestparsevarnameObjCmd(ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static int TestregexpObjCmd(ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static int TestreturnObjCmd(ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static void TestregexpXflags(char *string, + int length, int *cflagsPtr, int *eflagsPtr); +static int TestsaveresultCmd(ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static void TestsaveresultFree(char *blockPtr); +static int TestsetassocdataCmd(ClientData dummy, + Tcl_Interp *interp, int argc, const char **argv); +static int TestsetCmd(ClientData dummy, + 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); +static int TestsetobjerrorcodeCmd( + ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +static int TestsetplatformCmd(ClientData dummy, + Tcl_Interp *interp, int argc, const char **argv); +static int TeststaticpkgCmd(ClientData dummy, + Tcl_Interp *interp, int argc, const char **argv); +static int TesttranslatefilenameCmd(ClientData dummy, + Tcl_Interp *interp, int argc, const char **argv); +static int TestupvarCmd(ClientData dummy, + 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( + ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +static int TestChannelCmd(ClientData clientData, + Tcl_Interp *interp, int argc, const char **argv); +static int TestChannelEventCmd(ClientData clientData, + Tcl_Interp *interp, int argc, const char **argv); +static int TestFilesystemObjCmd(ClientData dummy, + Tcl_Interp *interp, int objc, + 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 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_CmdProc TestServiceModeCmd; -static Tcl_FSStatProc SimpleStat; -static Tcl_FSAccessProc SimpleAccess; -static Tcl_FSOpenFileChannelProc SimpleOpenFileChannel; -static Tcl_FSListVolumesProc SimpleListVolumes; -static Tcl_FSPathInFilesystemProc SimplePathInFilesystem; +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 Tcl_FSMatchInDirectoryProc SimpleMatchInDirectory; -static Tcl_ObjCmdProc TestUtfNextCmd; -static Tcl_ObjCmdProc TestUtfPrevCmd; -static Tcl_ObjCmdProc TestNumUtfCharsCmd; -static Tcl_ObjCmdProc TestGetUniCharCmd; -static Tcl_ObjCmdProc TestFindFirstCmd; -static Tcl_ObjCmdProc TestFindLastCmd; -static Tcl_ObjCmdProc TestHashSystemHashCmd; -static Tcl_ObjCmdProc TestGetIntForIndexCmd; - -static Tcl_NRPostProc NREUnwind_callback; -static Tcl_ObjCmdProc TestNREUnwind; -static Tcl_ObjCmdProc TestNRELevels; -static Tcl_ObjCmdProc TestInterpResolverCmd; -#if defined(HAVE_CPUID) && !defined(MAC_OSX_TCL) -static Tcl_ObjCmdProc TestcpuidCmd; +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[]); +#if defined(HAVE_CPUID) || defined(__WIN32__) +static int TestcpuidCmd (ClientData dummy, + Tcl_Interp* interp, int objc, + Tcl_Obj *CONST objv[]); #endif -static Tcl_ObjCmdProc TestApplyLambdaObjCmd; -static const Tcl_Filesystem testReportingFilesystem = { +static 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, - (Tcl_FSLoadFileProc *) TestReportLoadFile, + &TestReportFileAttrStrings, + &TestReportFileAttrsGet, + &TestReportFileAttrsSet, + &TestReportCreateDirectory, + &TestReportRemoveDirectory, + &TestReportDeleteFile, + &TestReportCopyFile, + &TestReportRenameFile, + &TestReportCopyDirectory, + &TestReportLstat, + (Tcl_FSLoadFileProc *) &TestReportLoadFile, NULL /* cwd */, - TestReportChdir + &TestReportChdir }; -static const Tcl_Filesystem simpleFilesystem = { +static 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 @@ -423,14 +497,14 @@ static const 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, @@ -454,6 +528,15 @@ static const 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 -- @@ -472,112 +555,23 @@ static const Tcl_Filesystem simpleFilesystem = { *---------------------------------------------------------------------- */ -#ifndef STRINGIFY -# define STRINGIFY(x) STRINGIFY1(x) -# define STRINGIFY1(x) #x -#endif - -static const char version[] = TCL_PATCH_LEVEL "+" STRINGIFY(TCL_VERSION_UUID) -#if defined(__clang__) && defined(__clang_major__) - ".clang-" STRINGIFY(__clang_major__) -#if __clang_minor__ < 10 - "0" -#endif - STRINGIFY(__clang_minor__) -#endif -#ifdef TCL_COMPILE_DEBUG - ".compiledebug" -#endif -#ifdef TCL_COMPILE_STATS - ".compilestats" -#endif -#if defined(__cplusplus) && !defined(__OBJC__) - ".cplusplus" -#endif -#ifndef NDEBUG - ".debug" -#endif -#if !defined(__clang__) && !defined(__INTEL_COMPILER) && defined(__GNUC__) - ".gcc-" STRINGIFY(__GNUC__) -#if __GNUC_MINOR__ < 10 - "0" -#endif - STRINGIFY(__GNUC_MINOR__) -#endif -#ifdef __INTEL_COMPILER - ".icc-" STRINGIFY(__INTEL_COMPILER) -#endif -#if (defined(_WIN32) && !defined(_WIN64)) || (ULONG_MAX == 0xffffffffUL) - ".ilp32" -#endif -#ifdef TCL_MEM_DEBUG - ".memdebug" -#endif -#if defined(_MSC_VER) - ".msvc-" STRINGIFY(_MSC_VER) -#endif -#ifdef USE_NMAKE - ".nmake" -#endif -#if !TCL_THREADS - ".no-thread" -#endif -#ifndef TCL_CFG_OPTIMIZED - ".no-optimize" -#endif -#ifdef __OBJC__ - ".objective-c" -#if defined(__cplusplus) - "plusplus" -#endif -#endif -#ifdef TCL_CFG_PROFILED - ".profile" -#endif -#ifdef PURIFY - ".purify" -#endif -#ifdef STATIC_BUILD - ".static" -#endif -; - int Tcltest_Init( Tcl_Interp *interp) /* Interpreter for application. */ { - Tcl_CmdInfo info; - Tcl_Obj **objv, *objPtr; - Tcl_Size objc; - int index; - static const char *const specialOptions[] = { + Tcl_ValueType t3ArgTypes[2]; + + Tcl_Obj *listPtr; + Tcl_Obj **objv; + int objc, index; + static const char *specialOptions[] = { "-appinitprocerror", "-appinitprocdeleteinterp", "-appinitprocclosestderr", "-appinitprocsetrcfile", NULL }; - if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) { - return TCL_ERROR; - } -#ifndef TCL_WITH_EXTERNAL_TOMMATH - if (Tcl_TomMath_InitStubs(interp, "8.5-") == NULL) { - return TCL_ERROR; - } -#endif - if (Tcl_OOInitStubs(interp) == NULL) { - return TCL_ERROR; - } + /* TIP #268: Full patchlevel instead of just major.minor */ - if (Tcl_GetCommandInfo(interp, "::tcl::build-info", &info)) { -#if TCL_MAJOR_VERSION > 8 - if (info.isNativeObjectProc == 2) { - Tcl_CreateObjCommand2(interp, "::tcl::test::build-info", - info.objProc2, (void *)version, NULL); - } else -#endif - Tcl_CreateObjCommand(interp, "::tcl::test::build-info", - info.objProc, (void *)version, NULL); - } - if (Tcl_PkgProvideEx(interp, "tcl::test", TCL_PATCH_LEVEL, NULL) == TCL_ERROR) { + if (Tcl_PkgProvide(interp, "Tcltest", TCL_PATCH_LEVEL) == TCL_ERROR) { return TCL_ERROR; } @@ -585,178 +579,144 @@ Tcltest_Init( * Create additional commands and math functions for testing Tcl. */ - Tcl_CreateObjCommand(interp, "gettimes", GetTimesObjCmd, NULL, NULL); - Tcl_CreateCommand(interp, "noop", NoopCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "noop", NoopObjCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testpurebytesobj", TestpurebytesobjObjCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testsetbytearraylength", TestsetbytearraylengthObjCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testbytestring", TestbytestringObjCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "teststringbytes", TeststringbytesObjCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testutf16string", Testutf16stringObjCmd, NULL, NULL); - Tcl_CreateObjCommand2(interp, "testwrongnumargs", TestWrongNumArgsObjCmd, - NULL, NULL); + 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_CreateObjCommand(interp, "testwrongnumargs", TestWrongNumArgsObjCmd, + (ClientData) 0, NULL); Tcl_CreateObjCommand(interp, "testfilesystem", TestFilesystemObjCmd, - NULL, NULL); + (ClientData) 0, NULL); Tcl_CreateObjCommand(interp, "testsimplefilesystem", TestSimpleFilesystemObjCmd, - NULL, NULL); + (ClientData) 0, NULL); Tcl_CreateObjCommand(interp, "testgetindexfromobjstruct", - TestGetIndexFromObjStructObjCmd, NULL, NULL); - Tcl_CreateCommand(interp, "testasync", TestasyncCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testbumpinterpepoch", - TestbumpinterpepochObjCmd, NULL, NULL); + TestGetIndexFromObjStructObjCmd, (ClientData) 0, NULL); +#ifdef USE_OBSOLETE_FS_HOOKS + Tcl_CreateCommand(interp, "testaccessproc", TestaccessprocCmd, (ClientData) 0, + NULL); + Tcl_CreateCommand(interp, "testopenfilechannelproc", + TestopenfilechannelprocCmd, (ClientData) 0, NULL); + Tcl_CreateCommand(interp, "teststatproc", TeststatprocCmd, (ClientData) 0, + NULL); +#endif + Tcl_CreateCommand(interp, "testasync", TestasyncCmd, (ClientData) 0, NULL); Tcl_CreateCommand(interp, "testchannel", TestChannelCmd, - NULL, NULL); + (ClientData) 0, NULL); Tcl_CreateCommand(interp, "testchannelevent", TestChannelEventCmd, - NULL, NULL); - Tcl_CreateCommand(interp, "testcmdtoken", TestcmdtokenCmd, NULL, + (ClientData) 0, NULL); + Tcl_CreateCommand(interp, "testcmdtoken", TestcmdtokenCmd, (ClientData) 0, NULL); - Tcl_CreateObjCommand(interp, "testcmdinfo", TestcmdinfoObjCmd, NULL, + Tcl_CreateCommand(interp, "testcmdinfo", TestcmdinfoCmd, (ClientData) 0, NULL); Tcl_CreateCommand(interp, "testcmdtrace", TestcmdtraceCmd, - NULL, NULL); + (ClientData) 0, NULL); Tcl_CreateCommand(interp, "testconcatobj", TestconcatobjCmd, - NULL, NULL); + (ClientData) 0, NULL); Tcl_CreateCommand(interp, "testcreatecommand", TestcreatecommandCmd, - NULL, NULL); - Tcl_CreateCommand(interp, "testdcall", TestdcallCmd, NULL, NULL); - Tcl_CreateCommand(interp, "testdel", TestdelCmd, NULL, NULL); + (ClientData) 0, NULL); + Tcl_CreateCommand(interp, "testdcall", TestdcallCmd, (ClientData) 0, NULL); + Tcl_CreateCommand(interp, "testdel", TestdelCmd, (ClientData) 0, NULL); Tcl_CreateCommand(interp, "testdelassocdata", TestdelassocdataCmd, - NULL, NULL); + (ClientData) 0, NULL); Tcl_CreateObjCommand(interp, "testdoubledigits", TestdoubledigitsObjCmd, NULL, NULL); Tcl_DStringInit(&dstring); - Tcl_CreateCommand(interp, "testdstring", TestdstringCmd, NULL, + Tcl_CreateCommand(interp, "testdstring", TestdstringCmd, (ClientData) 0, NULL); - Tcl_CreateObjCommand(interp, "testencoding", TestencodingObjCmd, NULL, + Tcl_CreateObjCommand(interp, "testencoding", TestencodingObjCmd, (ClientData) 0, NULL); Tcl_CreateObjCommand(interp, "testevalex", TestevalexObjCmd, - NULL, NULL); + (ClientData) 0, NULL); Tcl_CreateObjCommand(interp, "testevalobjv", TestevalobjvObjCmd, - NULL, NULL); + (ClientData) 0, NULL); Tcl_CreateObjCommand(interp, "testevent", TesteventObjCmd, - NULL, NULL); + (ClientData) 0, NULL); Tcl_CreateCommand(interp, "testexithandler", TestexithandlerCmd, - NULL, NULL); + (ClientData) 0, NULL); Tcl_CreateCommand(interp, "testexprlong", TestexprlongCmd, - NULL, NULL); + (ClientData) 0, NULL); Tcl_CreateObjCommand(interp, "testexprlongobj", TestexprlongobjCmd, - NULL, NULL); + (ClientData) 0, NULL); Tcl_CreateCommand(interp, "testexprdouble", TestexprdoubleCmd, - NULL, NULL); + (ClientData) 0, NULL); Tcl_CreateObjCommand(interp, "testexprdoubleobj", TestexprdoubleobjCmd, - NULL, NULL); + (ClientData) 0, NULL); Tcl_CreateObjCommand(interp, "testexprparser", TestexprparserObjCmd, - NULL, NULL); + (ClientData) 0, NULL); Tcl_CreateCommand(interp, "testexprstring", TestexprstringCmd, - NULL, NULL); - Tcl_CreateCommand(interp, "testfevent", TestfeventCmd, NULL, + (ClientData) 0, NULL); + Tcl_CreateCommand(interp, "testfevent", TestfeventCmd, (ClientData) 0, NULL); Tcl_CreateObjCommand(interp, "testfilelink", TestfilelinkCmd, - NULL, NULL); + (ClientData) 0, NULL); Tcl_CreateObjCommand(interp, "testfile", TestfileCmd, - NULL, NULL); + (ClientData) 0, NULL); Tcl_CreateObjCommand(interp, "testhashsystemhash", - TestHashSystemHashCmd, NULL, NULL); + TestHashSystemHashCmd, (ClientData) 0, NULL); Tcl_CreateCommand(interp, "testgetassocdata", TestgetassocdataCmd, - NULL, NULL); + (ClientData) 0, NULL); Tcl_CreateCommand(interp, "testgetint", TestgetintCmd, - NULL, NULL); - Tcl_CreateCommand(interp, "testlongsize", TestlongsizeCmd, - NULL, NULL); + (ClientData) 0, NULL); Tcl_CreateCommand(interp, "testgetplatform", TestgetplatformCmd, - NULL, NULL); + (ClientData) 0, NULL); Tcl_CreateObjCommand(interp, "testgetvarfullname", - TestgetvarfullnameCmd, NULL, NULL); + TestgetvarfullnameCmd, (ClientData) 0, NULL); Tcl_CreateCommand(interp, "testinterpdelete", TestinterpdeleteCmd, - NULL, NULL); - Tcl_CreateCommand(interp, "testlink", TestlinkCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testlinkarray", TestlinkarrayCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testlistrep", TestlistrepCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testlocale", TestlocaleCmd, NULL, + (ClientData) 0, NULL); + Tcl_CreateCommand(interp, "testlink", TestlinkCmd, (ClientData) 0, NULL); + Tcl_CreateObjCommand(interp, "testlocale", TestlocaleCmd, (ClientData) 0, NULL); - Tcl_CreateCommand(interp, "testpanic", TestpanicCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testparseargs", TestparseargsCmd,NULL,NULL); + Tcl_CreateCommand(interp, "testpanic", TestpanicCmd, (ClientData) 0, NULL); Tcl_CreateObjCommand(interp, "testparser", TestparserObjCmd, - NULL, NULL); + (ClientData) 0, NULL); Tcl_CreateObjCommand(interp, "testparsevar", TestparsevarObjCmd, - NULL, NULL); + (ClientData) 0, NULL); Tcl_CreateObjCommand(interp, "testparsevarname", TestparsevarnameObjCmd, - NULL, NULL); - Tcl_CreateObjCommand(interp, "testpreferstable", TestpreferstableObjCmd, - NULL, NULL); - Tcl_CreateObjCommand(interp, "testprint", TestprintObjCmd, - NULL, NULL); + (ClientData) 0, NULL); Tcl_CreateObjCommand(interp, "testregexp", TestregexpObjCmd, - NULL, NULL); + (ClientData) 0, NULL); Tcl_CreateObjCommand(interp, "testreturn", TestreturnObjCmd, - NULL, NULL); -#ifndef TCL_NO_DEPRECATED + (ClientData) 0, NULL); Tcl_CreateObjCommand(interp, "testsaveresult", TestsaveresultCmd, - NULL, NULL); -#endif - Tcl_CreateCommand(interp, "testservicemode", TestServiceModeCmd, - NULL, NULL); + (ClientData) 0, NULL); Tcl_CreateCommand(interp, "testsetassocdata", TestsetassocdataCmd, - NULL, NULL); + (ClientData) 0, NULL); Tcl_CreateCommand(interp, "testsetnoerr", TestsetCmd, - NULL, NULL); + (ClientData) 0, NULL); Tcl_CreateCommand(interp, "testseterr", TestsetCmd, - INT2PTR(TCL_LEAVE_ERR_MSG), NULL); + (ClientData) TCL_LEAVE_ERR_MSG, NULL); Tcl_CreateCommand(interp, "testset2", Testset2Cmd, - INT2PTR(TCL_LEAVE_ERR_MSG), NULL); + (ClientData) TCL_LEAVE_ERR_MSG, NULL); Tcl_CreateCommand(interp, "testseterrorcode", TestseterrorcodeCmd, - NULL, NULL); + (ClientData) 0, NULL); Tcl_CreateObjCommand(interp, "testsetobjerrorcode", - TestsetobjerrorcodeCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testutfnext", - TestUtfNextCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testutfprev", - TestUtfPrevCmd, NULL, NULL); + TestsetobjerrorcodeCmd, (ClientData) 0, NULL); Tcl_CreateObjCommand(interp, "testnumutfchars", - TestNumUtfCharsCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testgetunichar", - TestGetUniCharCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testfindfirst", - TestFindFirstCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testfindlast", - TestFindLastCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testgetintforindex", - TestGetIntForIndexCmd, NULL, NULL); + TestNumUtfCharsCmd, (ClientData) 0, NULL); Tcl_CreateCommand(interp, "testsetplatform", TestsetplatformCmd, - NULL, NULL); - Tcl_CreateCommand(interp, "testsocket", TestSocketCmd, - NULL, NULL); - Tcl_CreateCommand(interp, "teststaticlibrary", TeststaticlibraryCmd, - NULL, NULL); + (ClientData) 0, NULL); + Tcl_CreateCommand(interp, "teststaticpkg", TeststaticpkgCmd, + (ClientData) 0, NULL); Tcl_CreateCommand(interp, "testtranslatefilename", - TesttranslatefilenameCmd, NULL, NULL); - Tcl_CreateCommand(interp, "testupvar", TestupvarCmd, NULL, NULL); - Tcl_CreateCommand(interp, "testmainthread", TestmainthreadCmd, NULL, + TesttranslatefilenameCmd, (ClientData) 0, NULL); + Tcl_CreateCommand(interp, "testupvar", TestupvarCmd, (ClientData) 0, NULL); + Tcl_CreateMathFunc(interp, "T1", 0, NULL, TestMathFunc, (ClientData) 123); + Tcl_CreateMathFunc(interp, "T2", 0, NULL, TestMathFunc, (ClientData) 345); + Tcl_CreateCommand(interp, "testmainthread", TestmainthreadCmd, (ClientData) 0, NULL); Tcl_CreateCommand(interp, "testsetmainloop", TestsetmainloopCmd, - NULL, NULL); + (ClientData) NULL, NULL); Tcl_CreateCommand(interp, "testexitmainloop", TestexitmainloopCmd, - NULL, NULL); -#if defined(HAVE_CPUID) && !defined(MAC_OSX_TCL) + (ClientData) NULL, NULL); +#if defined(HAVE_CPUID) || defined(__WIN32__) Tcl_CreateObjCommand(interp, "testcpuid", TestcpuidCmd, - NULL, NULL); + (ClientData) 0, NULL); #endif - Tcl_CreateObjCommand(interp, "testnreunwind", TestNREUnwind, - NULL, NULL); - Tcl_CreateObjCommand(interp, "testnrelevels", TestNRELevels, - NULL, NULL); - Tcl_CreateObjCommand(interp, "testinterpresolver", TestInterpResolverCmd, - NULL, NULL); - Tcl_CreateObjCommand(interp, "testapplylambda", TestApplyLambdaObjCmd, - NULL, NULL); - - if (TclObjTest_Init(interp) != TCL_OK) { - return TCL_ERROR; - } - if (Procbodytest_Init(interp) != TCL_OK) { - return TCL_ERROR; - } -#if TCL_THREADS + t3ArgTypes[0] = TCL_EITHER; + t3ArgTypes[1] = TCL_EITHER; + Tcl_CreateMathFunc(interp, "T3", 2, t3ArgTypes, TestMathFunc2, + (ClientData) 0); + +#ifdef TCL_THREADS if (TclThread_Init(interp) != TCL_OK) { return TCL_ERROR; } @@ -766,9 +726,9 @@ Tcltest_Init( * Check for special options used in ../tests/main.test */ - objPtr = Tcl_GetVar2Ex(interp, "argv", NULL, TCL_GLOBAL_ONLY); - if (objPtr != NULL) { - if (Tcl_ListObjGetElements(interp, objPtr, &objc, &objv) != TCL_OK) { + listPtr = Tcl_GetVar2Ex(interp, "argv", NULL, TCL_GLOBAL_ONLY); + if (listPtr != NULL) { + if (Tcl_ListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) { return TCL_ERROR; } if (objc && (Tcl_GetIndexFromObj(NULL, objv[0], specialOptions, NULL, @@ -786,7 +746,7 @@ Tcltest_Init( return TCL_ERROR; } case 3: - if (objc > 1) { + if (objc-1) { Tcl_SetVar2Ex(interp, "tcl_rcFileName", NULL, objv[1], TCL_GLOBAL_ONLY); } @@ -801,50 +761,6 @@ 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. */ -{ - Tcl_CmdInfo info; - - if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) { - return TCL_ERROR; - } - if (Tcl_GetCommandInfo(interp, "::tcl::build-info", &info)) { -#if TCL_MAJOR_VERSION > 8 - if (info.isNativeObjectProc == 2) { - Tcl_CreateObjCommand2(interp, "::tcl::test::build-info", - info.objProc2, (void *)version, NULL); - } else -#endif - Tcl_CreateObjCommand(interp, "::tcl::test::build-info", - info.objProc, (void *)version, NULL); - } - if (Tcl_PkgProvideEx(interp, "tcl::test", TCL_PATCH_LEVEL, NULL) == TCL_ERROR) { - return TCL_ERROR; - } - return Procbodytest_SafeInit(interp); -} /* *---------------------------------------------------------------------- @@ -863,9 +779,10 @@ Tcltest_SafeInit( *---------------------------------------------------------------------- */ + /* ARGSUSED */ static int TestasyncCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -873,18 +790,19 @@ TestasyncCmd( TestAsyncHandler *asyncPtr, *prevPtr; int id, code; static int nextId = 1; + char buf[TCL_INTEGER_SPACE]; if (argc < 2) { wrongNumArgs: - Tcl_AppendResult(interp, "wrong # args", (void *)NULL); + Tcl_SetResult(interp, "wrong # args", TCL_STATIC); return TCL_ERROR; } if (strcmp(argv[1], "create") == 0) { if (argc != 3) { goto wrongNumArgs; } - asyncPtr = (TestAsyncHandler *)ckalloc(sizeof(TestAsyncHandler)); - asyncPtr->command = (char *)ckalloc(strlen(argv[2]) + 1); + asyncPtr = (TestAsyncHandler *) ckalloc(sizeof(TestAsyncHandler)); + asyncPtr->command = ckalloc(strlen(argv[2]) + 1); strcpy(asyncPtr->command, argv[2]); Tcl_MutexLock(&asyncTestMutex); asyncPtr->id = nextId; @@ -894,7 +812,8 @@ TestasyncCmd( asyncPtr->nextPtr = firstHandler; firstHandler = asyncPtr; Tcl_MutexUnlock(&asyncTestMutex); - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(asyncPtr->id)); + TclFormatInt(buf, asyncPtr->id); + Tcl_SetResult(interp, buf, TCL_VOLATILE); } else if (strcmp(argv[1], "delete") == 0) { if (argc == 2) { Tcl_MutexLock(&asyncTestMutex); @@ -903,7 +822,7 @@ TestasyncCmd( firstHandler = asyncPtr->nextPtr; Tcl_AsyncDelete(asyncPtr->handler); ckfree(asyncPtr->command); - ckfree(asyncPtr); + ckfree((char *) asyncPtr); } Tcl_MutexUnlock(&asyncTestMutex); return TCL_OK; @@ -927,7 +846,7 @@ TestasyncCmd( } Tcl_AsyncDelete(asyncPtr->handler); ckfree(asyncPtr->command); - ckfree(asyncPtr); + ckfree((char *) asyncPtr); break; } Tcl_MutexUnlock(&asyncTestMutex); @@ -939,7 +858,7 @@ TestasyncCmd( || (Tcl_GetInt(interp, argv[4], &code) != TCL_OK)) { return TCL_ERROR; } - Tcl_MutexLock(&asyncTestMutex); + Tcl_MutexLock(&asyncTestMutex); for (asyncPtr = firstHandler; asyncPtr != NULL; asyncPtr = asyncPtr->nextPtr) { if (asyncPtr->id == id) { @@ -947,9 +866,10 @@ TestasyncCmd( break; } } - Tcl_SetObjResult(interp, Tcl_NewStringObj(argv[3], -1)); - Tcl_MutexUnlock(&asyncTestMutex); + Tcl_MutexUnlock(&asyncTestMutex); + Tcl_SetResult(interp, (char *)argv[3], TCL_VOLATILE); return code; +#ifdef TCL_THREADS } else if (strcmp(argv[1], "marklater") == 0) { if (argc != 3) { goto wrongNumArgs; @@ -963,9 +883,9 @@ TestasyncCmd( if (asyncPtr->id == id) { Tcl_ThreadId threadID; if (Tcl_CreateThread(&threadID, AsyncThreadProc, - INT2PTR(id), TCL_THREAD_STACK_DEFAULT, + (ClientData) INT2PTR(id), TCL_THREAD_STACK_DEFAULT, TCL_THREAD_NOFLAGS) != TCL_OK) { - Tcl_AppendResult(interp, "can't create thread", (void *)NULL); + Tcl_SetResult(interp, "can't create thread", TCL_STATIC); Tcl_MutexUnlock(&asyncTestMutex); return TCL_ERROR; } @@ -975,15 +895,21 @@ TestasyncCmd( Tcl_MutexUnlock(&asyncTestMutex); } else { Tcl_AppendResult(interp, "bad option \"", argv[1], - "\": must be create, delete, int, mark, or marklater", (void *)NULL); + "\": must be create, delete, int, mark, or marklater", NULL); return TCL_ERROR; +#else /* !TCL_THREADS */ + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be create, delete, int, or mark", NULL); + return TCL_ERROR; +#endif } return TCL_OK; } static int AsyncHandlerProc( - void *clientData, /* If of TestAsyncHandler structure. + ClientData clientData, /* If of TestAsyncHandler structure. * in global list. */ Tcl_Interp *interp, /* Interpreter in which command was * executed, or NULL. */ @@ -991,16 +917,13 @@ AsyncHandlerProc( { TestAsyncHandler *asyncPtr; int id = PTR2INT(clientData); - const char *listArgv[4]; - char *cmd; + 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; - } + asyncPtr = asyncPtr->nextPtr) { + if (asyncPtr->id == id) break; } Tcl_MutexUnlock(&asyncTestMutex); @@ -1011,19 +934,19 @@ AsyncHandlerProc( TclFormatInt(string, code); listArgv[0] = asyncPtr->command; - listArgv[1] = Tcl_GetStringResult(interp); + listArgv[1] = Tcl_GetString(Tcl_GetObjResult(interp)); listArgv[2] = string; listArgv[3] = NULL; cmd = Tcl_Merge(3, listArgv); if (interp != NULL) { - code = Tcl_EvalEx(interp, cmd, TCL_INDEX_NONE, 0); + code = Tcl_Eval(interp, cmd); } else { /* * this should not happen, but by definition of how async handlers are * invoked, it's possible. Better error checking is needed here. */ } - ckfree(cmd); + ckfree((char *)cmd); return code; } @@ -1043,9 +966,10 @@ AsyncHandlerProc( *---------------------------------------------------------------------- */ +#ifdef TCL_THREADS static Tcl_ThreadCreateType AsyncThreadProc( - void *clientData) /* Parameter is the id of a + ClientData clientData) /* Parameter is the id of a * TestAsyncHandler, defined above. */ { TestAsyncHandler *asyncPtr; @@ -1064,28 +988,12 @@ AsyncThreadProc( Tcl_ExitThread(TCL_OK); TCL_THREAD_CREATE_RETURN; } - -static int -TestbumpinterpepochObjCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - Interp *iPtr = (Interp *)interp; - - if (objc != 1) { - Tcl_WrongNumArgs(interp, 1, objv, ""); - return TCL_ERROR; - } - iPtr->compileEpoch++; - return TCL_OK; -} +#endif /* *---------------------------------------------------------------------- * - * TestcmdinfoObjCmd -- + * TestcmdinfoCmd -- * * This procedure implements the "testcmdinfo" command. It is used to * test Tcl_GetCommandInfo, Tcl_SetCommandInfo, and command creation and @@ -1100,155 +1008,104 @@ TestbumpinterpepochObjCmd( *---------------------------------------------------------------------- */ + /* ARGSUSED */ static int -TestcmdinfoObjCmd( - TCL_UNUSED(void *), +TestcmdinfoCmd( + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ + int argc, /* Number of arguments. */ + const char **argv) /* Argument strings. */ { - static const char *const subcmds[] = { - "create", "delete", "get", "modify", NULL - }; - enum options { - CMDINFO_CREATE, CMDINFO_DELETE, CMDINFO_GET, CMDINFO_MODIFY - } idx; Tcl_CmdInfo info; - if (objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "command arg"); - return TCL_ERROR; - } - if (Tcl_GetIndexFromObj(interp, objv[1], subcmds, "option", 0, - &idx) != TCL_OK) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " option cmdName\"", NULL); return TCL_ERROR; } - switch (idx) { - case CMDINFO_CREATE: - Tcl_CreateCommand(interp, Tcl_GetString(objv[2]), CmdProc1, - (void *)"original", CmdDelProc1); - break; - case CMDINFO_DELETE: + if (strcmp(argv[1], "create") == 0) { + Tcl_CreateCommand(interp, argv[2], CmdProc1, (ClientData) "original", + CmdDelProc1); + } else if (strcmp(argv[1], "delete") == 0) { Tcl_DStringInit(&delString); - Tcl_DeleteCommand(interp, Tcl_GetString(objv[2])); + Tcl_DeleteCommand(interp, argv[2]); Tcl_DStringResult(interp, &delString); - break; - case CMDINFO_GET: - if (Tcl_GetCommandInfo(interp, Tcl_GetString(objv[2]), &info) ==0) { - Tcl_AppendResult(interp, "??", (void *)NULL); + } else if (strcmp(argv[1], "get") == 0) { + if (Tcl_GetCommandInfo(interp, argv[2], &info) ==0) { + Tcl_SetResult(interp, "??", TCL_STATIC); return TCL_OK; } if (info.proc == CmdProc1) { Tcl_AppendResult(interp, "CmdProc1", " ", - (char *) info.clientData, (void *)NULL); + (char *) info.clientData, NULL); } else if (info.proc == CmdProc2) { Tcl_AppendResult(interp, "CmdProc2", " ", - (char *) info.clientData, (void *)NULL); + (char *) info.clientData, NULL); } else { - Tcl_AppendResult(interp, "unknown", (void *)NULL); + Tcl_AppendResult(interp, "unknown", NULL); } if (info.deleteProc == CmdDelProc1) { Tcl_AppendResult(interp, " CmdDelProc1", " ", - (char *) info.deleteData, (void *)NULL); + (char *) info.deleteData, NULL); } else if (info.deleteProc == CmdDelProc2) { Tcl_AppendResult(interp, " CmdDelProc2", " ", - (char *) info.deleteData, (void *)NULL); + (char *) info.deleteData, NULL); } else { - Tcl_AppendResult(interp, " unknown", (void *)NULL); - } - Tcl_AppendResult(interp, " ", info.namespacePtr->fullName, (void *)NULL); - if (info.isNativeObjectProc == 0) { - Tcl_AppendResult(interp, " stringProc", (void *)NULL); - } else if (info.isNativeObjectProc == 1) { - Tcl_AppendResult(interp, " nativeObjectProc", (void *)NULL); - } else if (info.isNativeObjectProc == 2) { - Tcl_AppendResult(interp, " nativeObjectProc2", (void *)NULL); + Tcl_AppendResult(interp, " unknown", NULL); + } + Tcl_AppendResult(interp, " ", info.namespacePtr->fullName, NULL); + if (info.isNativeObjectProc) { + Tcl_AppendResult(interp, " nativeObjectProc", NULL); } else { - Tcl_SetObjResult(interp, Tcl_ObjPrintf("Invalid isNativeObjectProc value %d", - info.isNativeObjectProc)); - return TCL_ERROR; + Tcl_AppendResult(interp, " stringProc", NULL); } - break; - case CMDINFO_MODIFY: + } else if (strcmp(argv[1], "modify") == 0) { info.proc = CmdProc2; - info.clientData = (void *) "new_command_data"; + info.clientData = (ClientData) "new_command_data"; info.objProc = NULL; - info.objClientData = NULL; + info.objClientData = (ClientData) NULL; info.deleteProc = CmdDelProc2; - info.deleteData = (void *) "new_delete_data"; - info.namespacePtr = NULL; - info.objProc2 = NULL; - info.objClientData2 = NULL; - if (Tcl_SetCommandInfo(interp, Tcl_GetString(objv[2]), &info) == 0) { - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(0)); + info.deleteData = (ClientData) "new_delete_data"; + if (Tcl_SetCommandInfo(interp, argv[2], &info) == 0) { + Tcl_SetResult(interp, "0", TCL_STATIC); } else { - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(1)); + Tcl_SetResult(interp, "1", TCL_STATIC); } - break; + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be create, delete, get, or modify", NULL); + return TCL_ERROR; } - - return TCL_OK; -} - -static int -CmdProc0( - void *clientData, /* String to return. */ - Tcl_Interp *interp, /* Current interpreter. */ - TCL_UNUSED(int) /*argc*/, - TCL_UNUSED(const char **) /*argv*/) -{ - TestCommandTokenRef *refPtr = (TestCommandTokenRef *) clientData; - Tcl_AppendResult(interp, "CmdProc1 ", refPtr->value, (void *)NULL); return TCL_OK; } + /*ARGSUSED*/ static int CmdProc1( - void *clientData, /* String to return. */ + ClientData clientData, /* String to return. */ Tcl_Interp *interp, /* Current interpreter. */ - TCL_UNUSED(int) /*argc*/, - TCL_UNUSED(const char **) /*argv*/) + int argc, /* Number of arguments. */ + const char **argv) /* Argument strings. */ { - Tcl_AppendResult(interp, "CmdProc1 ", (char *) clientData, (void *)NULL); + Tcl_AppendResult(interp, "CmdProc1 ", (char *) clientData, NULL); return TCL_OK; } + /*ARGSUSED*/ static int CmdProc2( - void *clientData, /* String to return. */ + ClientData clientData, /* String to return. */ Tcl_Interp *interp, /* Current interpreter. */ - TCL_UNUSED(int) /*argc*/, - TCL_UNUSED(const char **) /*argv*/) + int argc, /* Number of arguments. */ + const char **argv) /* Argument strings. */ { - Tcl_AppendResult(interp, "CmdProc2 ", (char *) clientData, (void *)NULL); + Tcl_AppendResult(interp, "CmdProc2 ", (char *) clientData, NULL); return TCL_OK; } static void -CmdDelProc0( - void *clientData) /* String to save. */ -{ - TestCommandTokenRef *thisRefPtr, *prevRefPtr = NULL; - TestCommandTokenRef *refPtr = (TestCommandTokenRef *) clientData; - int id = refPtr->id; - for (thisRefPtr = firstCommandTokenRef; refPtr != NULL; - thisRefPtr = thisRefPtr->nextPtr) { - if (thisRefPtr->id == id) { - if (prevRefPtr != NULL) { - prevRefPtr->nextPtr = thisRefPtr->nextPtr; - } else { - firstCommandTokenRef = thisRefPtr->nextPtr; - } - break; - } - prevRefPtr = thisRefPtr; - } - ckfree(refPtr); -} - -static void CmdDelProc1( - void *clientData) /* String to save. */ + ClientData clientData) /* String to save. */ { Tcl_DStringInit(&delString); Tcl_DStringAppend(&delString, "CmdDelProc1 ", -1); @@ -1257,7 +1114,7 @@ CmdDelProc1( static void CmdDelProc2( - void *clientData) /* String to save. */ + ClientData clientData) /* String to save. */ { Tcl_DStringInit(&delString); Tcl_DStringAppend(&delString, "CmdDelProc2 ", -1); @@ -1281,70 +1138,49 @@ CmdDelProc2( *---------------------------------------------------------------------- */ + /* ARGSUSED */ static int TestcmdtokenCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { - TestCommandTokenRef *refPtr; - int id; + Tcl_Command token; + int *l; char buf[30]; if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " option arg\"", (void *)NULL); + " option arg\"", NULL); return TCL_ERROR; } if (strcmp(argv[1], "create") == 0) { - refPtr = (TestCommandTokenRef *)ckalloc(sizeof(TestCommandTokenRef)); - refPtr->token = Tcl_CreateCommand(interp, argv[2], CmdProc0, - refPtr, CmdDelProc0); - refPtr->id = nextCommandTokenRefId; - refPtr->value = "original"; - nextCommandTokenRefId++; - refPtr->nextPtr = firstCommandTokenRef; - firstCommandTokenRef = refPtr; - snprintf(buf, sizeof(buf), "%d", refPtr->id); - Tcl_AppendResult(interp, buf, (void *)NULL); - } else { - if (sscanf(argv[2], "%d", &id) != 1) { + token = Tcl_CreateCommand(interp, argv[2], CmdProc1, + (ClientData) "original", NULL); + sprintf(buf, "%p", (void *)token); + Tcl_SetResult(interp, buf, TCL_VOLATILE); + } else if (strcmp(argv[1], "name") == 0) { + Tcl_Obj *objPtr; + + if (sscanf(argv[2], "%p", &l) != 1) { Tcl_AppendResult(interp, "bad command token \"", argv[2], - "\"", (void *)NULL); + "\"", NULL); return TCL_ERROR; } - for (refPtr = firstCommandTokenRef; refPtr != NULL; - refPtr = refPtr->nextPtr) { - if (refPtr->id == id) { - break; - } - } + objPtr = Tcl_NewObj(); + Tcl_GetCommandFullName(interp, (Tcl_Command) l, objPtr); - if (refPtr == NULL) { - Tcl_AppendResult(interp, "bad command token \"", argv[2], - "\"", (void *)NULL); - return TCL_ERROR; - } - - if (strcmp(argv[1], "name") == 0) { - Tcl_Obj *objPtr; - - objPtr = Tcl_NewObj(); - Tcl_GetCommandFullName(interp, refPtr->token, objPtr); - - Tcl_AppendElement(interp, - Tcl_GetCommandName(interp, refPtr->token)); - Tcl_AppendElement(interp, Tcl_GetString(objPtr)); - Tcl_DecrRefCount(objPtr); - } else { - Tcl_AppendResult(interp, "bad option \"", argv[1], - "\": must be create, name, or free", (void *)NULL); - return TCL_ERROR; - } + Tcl_AppendElement(interp, + Tcl_GetCommandName(interp, (Tcl_Command) l)); + Tcl_AppendElement(interp, Tcl_GetString(objPtr)); + Tcl_DecrRefCount(objPtr); + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be create or name", NULL); + return TCL_ERROR; } - return TCL_OK; } @@ -1366,9 +1202,10 @@ TestcmdtokenCmd( *---------------------------------------------------------------------- */ + /* ARGSUSED */ static int TestcmdtraceCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -1378,17 +1215,18 @@ TestcmdtraceCmd( if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " option script\"", (void *)NULL); + " option script\"", NULL); return TCL_ERROR; } if (strcmp(argv[1], "tracetest") == 0) { Tcl_DStringInit(&buffer); - cmdTrace = Tcl_CreateTrace(interp, 50000, CmdTraceProc, &buffer); - result = Tcl_EvalEx(interp, argv[2], TCL_INDEX_NONE, 0); + cmdTrace = Tcl_CreateTrace(interp, 50000, + (Tcl_CmdTraceProc *) CmdTraceProc, (ClientData) &buffer); + result = Tcl_Eval(interp, argv[2]); if (result == TCL_OK) { Tcl_ResetResult(interp); - Tcl_AppendResult(interp, Tcl_DStringValue(&buffer), (void *)NULL); + Tcl_AppendResult(interp, Tcl_DStringValue(&buffer), NULL); } Tcl_DeleteTrace(interp, cmdTrace); Tcl_DStringFree(&buffer); @@ -1397,20 +1235,21 @@ TestcmdtraceCmd( * 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 - * TclNRExecuteByteCode. + * TclExecuteByteCode. */ - cmdTrace = Tcl_CreateTrace(interp, 50000, CmdTraceDeleteProc, NULL); - Tcl_EvalEx(interp, argv[2], TCL_INDEX_NONE, 0); + cmdTrace = Tcl_CreateTrace(interp, 50000, + (Tcl_CmdTraceProc *) CmdTraceDeleteProc, (ClientData) 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, CmdTraceProc, - &buffer); - result = Tcl_EvalEx(interp, argv[2], TCL_INDEX_NONE, 0); + cmdTrace = Tcl_CreateTrace(interp, iPtr->numLevels + 4, + (Tcl_CmdTraceProc *) CmdTraceProc, (ClientData) &buffer); + result = Tcl_Eval(interp, argv[2]); if (result == TCL_OK) { Tcl_ResetResult(interp); - Tcl_AppendResult(interp, Tcl_DStringValue(&buffer), (void *)NULL); + Tcl_AppendResult(interp, Tcl_DStringValue(&buffer), NULL); } Tcl_DeleteTrace(interp, cmdTrace); Tcl_DStringFree(&buffer); @@ -1422,13 +1261,13 @@ TestcmdtraceCmd( static int deleteCalled; deleteCalled = 0; - cmdTrace = Tcl_CreateObjTrace2(interp, 50000, + cmdTrace = Tcl_CreateObjTrace(interp, 50000, TCL_ALLOW_INLINE_COMPILATION, ObjTraceProc, - &deleteCalled, ObjTraceDeleteProc); - result = Tcl_EvalEx(interp, argv[2], TCL_INDEX_NONE, 0); + (ClientData) &deleteCalled, ObjTraceDeleteProc); + result = Tcl_Eval(interp, argv[2]); Tcl_DeleteTrace(interp, cmdTrace); if (!deleteCalled) { - Tcl_AppendResult(interp, "Delete wasn't called", (void *)NULL); + Tcl_SetResult(interp, "Delete wasn't called", TCL_STATIC); return TCL_ERROR; } else { return result; @@ -1437,19 +1276,21 @@ TestcmdtraceCmd( Tcl_Trace t1, t2; Tcl_DStringInit(&buffer); - t1 = Tcl_CreateTrace(interp, 1, CmdTraceProc, &buffer); - t2 = Tcl_CreateTrace(interp, 50000, CmdTraceProc, &buffer); - result = Tcl_EvalEx(interp, argv[2], TCL_INDEX_NONE, 0); + t1 = Tcl_CreateTrace(interp, 1, + (Tcl_CmdTraceProc *) CmdTraceProc, (ClientData) &buffer); + t2 = Tcl_CreateTrace(interp, 50000, + (Tcl_CmdTraceProc *) CmdTraceProc, (ClientData) &buffer); + result = Tcl_Eval(interp, argv[2]); if (result == TCL_OK) { Tcl_ResetResult(interp); - Tcl_AppendResult(interp, Tcl_DStringValue(&buffer), (void *)NULL); + 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, doubletest or resulttest", (void *)NULL); + "\": must be tracetest, deletetest, doubletest or resulttest", NULL); return TCL_ERROR; } return TCL_OK; @@ -1457,17 +1298,18 @@ TestcmdtraceCmd( static void CmdTraceProc( - void *clientData, /* Pointer to buffer in which the + ClientData clientData, /* Pointer to buffer in which the * command and arguments are appended. * Accumulates test result. */ - TCL_UNUSED(Tcl_Interp *), - TCL_UNUSED(int) /*level*/, + Tcl_Interp *interp, /* Current interpreter. */ + int level, /* Current trace level. */ char *command, /* The command being traced (after * substitutions). */ - TCL_UNUSED(Tcl_CmdProc *) /*cmdProc*/, - TCL_UNUSED(void *), + Tcl_CmdProc *cmdProc, /* Points to command's command procedure. */ + ClientData cmdClientData, /* Client data associated with command + * procedure. */ int argc, /* Number of arguments. */ - const char *argv[]) /* Argument strings. */ + char **argv) /* Argument strings. */ { Tcl_DString *bufPtr = (Tcl_DString *) clientData; int i; @@ -1483,18 +1325,20 @@ CmdTraceProc( static void CmdTraceDeleteProc( - TCL_UNUSED(void *), + ClientData clientData, /* Unused. */ Tcl_Interp *interp, /* Current interpreter. */ - TCL_UNUSED(int) /*level*/, - TCL_UNUSED(char *) /*command*/, - TCL_UNUSED(Tcl_CmdProc *), - TCL_UNUSED(void *), - TCL_UNUSED(int) /*argc*/, - TCL_UNUSED(const char **) /*argv*/) + 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 + * procedure. */ + int argc, /* Number of arguments. */ + char **argv) /* Argument strings. */ { /* * Remove ourselves to test whether calling Tcl_DeleteTrace within a trace - * callback causes the for loop in TclNRExecuteByteCode that calls traces to + * callback causes the for loop in TclExecuteByteCode that calls traces to * reference freed memory. */ @@ -1503,13 +1347,13 @@ CmdTraceDeleteProc( static int ObjTraceProc( - TCL_UNUSED(void *), + ClientData clientData, /* unused */ Tcl_Interp *interp, /* Tcl interpreter */ - TCL_UNUSED(Tcl_Size) /* level */, - const char *command, - TCL_UNUSED(Tcl_Command), - TCL_UNUSED(Tcl_Size) /*objc*/, - Tcl_Obj *const objv[]) /* Argument objects. */ + 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]); @@ -1531,7 +1375,7 @@ ObjTraceProc( static void ObjTraceDeleteProc( - void *clientData) + ClientData clientData) { int *intPtr = (int *) clientData; *intPtr = 1; /* Record that the trace was deleted */ @@ -1560,29 +1404,29 @@ ObjTraceDeleteProc( static int TestcreatecommandCmd( - TCL_UNUSED(void *), + 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], - " option\"", (void *)NULL); + " option\"", NULL); return TCL_ERROR; } if (strcmp(argv[1], "create") == 0) { Tcl_CreateCommand(interp, "test_ns_basic::createdcommand", - CreatedCommandProc, NULL, NULL); + CreatedCommandProc, (ClientData) 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, NULL, NULL); + CreatedCommandProc2, (ClientData) NULL, NULL); } else if (strcmp(argv[1], "delete2") == 0) { Tcl_DeleteCommand(interp, "value:at:"); } else { Tcl_AppendResult(interp, "bad option \"", argv[1], - "\": must be create, delete, create2, or delete2", (void *)NULL); + "\": must be create, delete, create2, or delete2", NULL); return TCL_ERROR; } return TCL_OK; @@ -1590,10 +1434,10 @@ TestcreatecommandCmd( static int CreatedCommandProc( - TCL_UNUSED(void *), + ClientData clientData, /* String to return. */ Tcl_Interp *interp, /* Current interpreter. */ - TCL_UNUSED(int) /*argc*/, - TCL_UNUSED(const char **) /*argv*/) + int argc, /* Number of arguments. */ + const char **argv) /* Argument strings. */ { Tcl_CmdInfo info; int found; @@ -1602,20 +1446,20 @@ CreatedCommandProc( &info); if (!found) { Tcl_AppendResult(interp, "CreatedCommandProc could not get command info for test_ns_basic::createdcommand", - (void *)NULL); + NULL); return TCL_ERROR; } Tcl_AppendResult(interp, "CreatedCommandProc in ", - info.namespacePtr->fullName, (void *)NULL); + info.namespacePtr->fullName, NULL); return TCL_OK; } static int CreatedCommandProc2( - TCL_UNUSED(void *), + ClientData clientData, /* String to return. */ Tcl_Interp *interp, /* Current interpreter. */ - TCL_UNUSED(int) /*argc*/, - TCL_UNUSED(const char **) /*argv*/) + int argc, /* Number of arguments. */ + const char **argv) /* Argument strings. */ { Tcl_CmdInfo info; int found; @@ -1623,11 +1467,11 @@ CreatedCommandProc2( found = Tcl_GetCommandInfo(interp, "value:at:", &info); if (!found) { Tcl_AppendResult(interp, "CreatedCommandProc2 could not get command info for test_ns_basic::createdcommand", - (void *)NULL); + NULL); return TCL_ERROR; } Tcl_AppendResult(interp, "CreatedCommandProc2 in ", - info.namespacePtr->fullName, (void *)NULL); + info.namespacePtr->fullName, NULL); return TCL_OK; } @@ -1648,9 +1492,10 @@ CreatedCommandProc2( *---------------------------------------------------------------------- */ + /* ARGSUSED */ static int TestdcallCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -1665,10 +1510,10 @@ TestdcallCmd( } if (id < 0) { Tcl_DontCallWhenDeleted(delInterp, DelCallbackProc, - INT2PTR(-id)); + (ClientData) INT2PTR(-id)); } else { Tcl_CallWhenDeleted(delInterp, DelCallbackProc, - INT2PTR(id)); + (ClientData) INT2PTR(id)); } } Tcl_DeleteInterp(delInterp); @@ -1682,7 +1527,7 @@ TestdcallCmd( static void DelCallbackProc( - void *clientData, /* Numerical value to append to delString. */ + ClientData clientData, /* Numerical value to append to delString. */ Tcl_Interp *interp) /* Interpreter being deleted. */ { int id = PTR2INT(clientData); @@ -1712,61 +1557,62 @@ DelCallbackProc( *---------------------------------------------------------------------- */ + /* ARGSUSED */ static int TestdelCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { DelCmd *dPtr; - Tcl_Interp *child; + Tcl_Interp *slave; if (argc != 4) { - Tcl_AppendResult(interp, "wrong # args", (void *)NULL); + Tcl_SetResult(interp, "wrong # args", TCL_STATIC); return TCL_ERROR; } - child = Tcl_GetChild(interp, argv[1]); - if (child == NULL) { + slave = Tcl_GetSlave(interp, argv[1]); + if (slave == NULL) { return TCL_ERROR; } - dPtr = (DelCmd *)ckalloc(sizeof(DelCmd)); + dPtr = (DelCmd *) ckalloc(sizeof(DelCmd)); dPtr->interp = interp; - dPtr->deleteCmd = (char *)ckalloc(strlen(argv[3]) + 1); + dPtr->deleteCmd = (char *) ckalloc((unsigned) (strlen(argv[3]) + 1)); strcpy(dPtr->deleteCmd, argv[3]); - Tcl_CreateCommand(child, argv[2], DelCmdProc, dPtr, + Tcl_CreateCommand(slave, argv[2], DelCmdProc, (ClientData) dPtr, DelDeleteProc); return TCL_OK; } static int DelCmdProc( - void *clientData, /* String result to return. */ + ClientData clientData, /* String result to return. */ Tcl_Interp *interp, /* Current interpreter. */ - TCL_UNUSED(int) /*argc*/, - TCL_UNUSED(const char **) /*argv*/) + int argc, /* Number of arguments. */ + const char **argv) /* Argument strings. */ { DelCmd *dPtr = (DelCmd *) clientData; - Tcl_AppendResult(interp, dPtr->deleteCmd, (void *)NULL); + Tcl_AppendResult(interp, dPtr->deleteCmd, NULL); ckfree(dPtr->deleteCmd); - ckfree(dPtr); + ckfree((char *) dPtr); return TCL_OK; } static void DelDeleteProc( - void *clientData) /* String command to evaluate. */ + ClientData clientData) /* String command to evaluate. */ { - DelCmd *dPtr = (DelCmd *)clientData; + DelCmd *dPtr = (DelCmd *) clientData; - Tcl_EvalEx(dPtr->interp, dPtr->deleteCmd, TCL_INDEX_NONE, 0); + Tcl_Eval(dPtr->interp, dPtr->deleteCmd); Tcl_ResetResult(dPtr->interp); ckfree(dPtr->deleteCmd); - ckfree(dPtr); + ckfree((char *) dPtr); } /* @@ -1789,14 +1635,14 @@ DelDeleteProc( static int TestdelassocdataCmd( - TCL_UNUSED(void *), + 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\"", (void *)NULL); + " data_key\"", NULL); return TCL_ERROR; } Tcl_DeleteAssocData(interp, argv[1]); @@ -1818,27 +1664,32 @@ TestdelassocdataCmd( * Parameters: * fpval - Floating-point value to format. * ndigits - Digit count to request from Tcl_DoubleDigits - * type - One of 'shortest', 'e', 'f' + * type - One of 'shortest', 'Steele', 'e', 'f' * shorten - Indicates that the 'shorten' flag should be passed in. * *----------------------------------------------------------------------------- */ static int -TestdoubledigitsObjCmd( - TCL_UNUSED(void *), - Tcl_Interp* interp, /* Tcl interpreter */ - int objc, /* Parameter count */ - Tcl_Obj* const objv[]) /* Parameter vector */ -{ - static const char *options[] = { +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 }; @@ -1850,8 +1701,8 @@ TestdoubledigitsObjCmd( int type; int decpt; int signum; - char *str; - char *endPtr; + char* str; + char* endPtr; Tcl_Obj* strObj; Tcl_Obj* retval; @@ -1862,8 +1713,8 @@ TestdoubledigitsObjCmd( status = Tcl_GetDoubleFromObj(interp, objv[1], &d); if (status != TCL_OK) { doubleType = Tcl_GetObjType("double"); - if (Tcl_FetchInternalRep(objv[1], doubleType) - && isnan(objv[1]->internalRep.doubleValue)) { + if (objv[1]->typePtr == doubleType + || TclIsNaN(objv[1]->internalRep.doubleValue)) { status = TCL_OK; memcpy(&d, &(objv[1]->internalRep.doubleValue), sizeof(double)); } @@ -1881,13 +1732,13 @@ TestdoubledigitsObjCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj("bad flag", -1)); return TCL_ERROR; } - type |= TCL_DD_SHORTEST; + 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_NewWideIntObj(decpt)); + Tcl_ListObjAppendElement(NULL, retval, Tcl_NewIntObj(decpt)); strObj = Tcl_NewStringObj(signum ? "-" : "+", 1); Tcl_ListObjAppendElement(NULL, retval, strObj); Tcl_SetObjResult(interp, retval); @@ -1911,9 +1762,10 @@ TestdoubledigitsObjCmd( *---------------------------------------------------------------------- */ + /* ARGSUSED */ static int TestdstringCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -1922,7 +1774,7 @@ TestdstringCmd( if (argc < 2) { wrongNumArgs: - Tcl_AppendResult(interp, "wrong # args", (void *)NULL); + Tcl_SetResult(interp, "wrong # args", TCL_STATIC); return TCL_ERROR; } if (strcmp(argv[1], "append") == 0) { @@ -1958,40 +1810,37 @@ TestdstringCmd( goto wrongNumArgs; } if (strcmp(argv[2], "staticsmall") == 0) { - Tcl_AppendResult(interp, "short", (void *)NULL); + Tcl_SetResult(interp, "short", TCL_STATIC); } else if (strcmp(argv[2], "staticlarge") == 0) { - Tcl_AppendResult(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", (void *)NULL); + 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) { - char *s = (char *)ckalloc(100); - strcpy(s, "This is a malloc-ed string"); - Tcl_SetResult(interp, s, TCL_DYNAMIC); + Tcl_SetResult(interp, (char *) ckalloc(100), TCL_DYNAMIC); + strcpy(interp->result, "This is a malloc-ed string"); } else if (strcmp(argv[2], "special") == 0) { - char *s = (char *)ckalloc(100) + 16; - strcpy(s, "This is a specially-allocated string"); - Tcl_SetResult(interp, s, SpecialFree); + interp->result = (char *) ckalloc(100); + interp->result += 4; + interp->freeProc = SpecialFree; + strcpy(interp->result, "This is a specially-allocated string"); } else { Tcl_AppendResult(interp, "bad gresult option \"", argv[2], "\": must be staticsmall, staticlarge, free, or special", - (void *)NULL); + NULL); return TCL_ERROR; } Tcl_DStringGetResult(interp, &dstring); } else if (strcmp(argv[1], "length") == 0) { + char buf[TCL_INTEGER_SPACE]; if (argc != 2) { goto wrongNumArgs; } - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(Tcl_DStringLength(&dstring))); + TclFormatInt(buf, Tcl_DStringLength(&dstring)); + Tcl_SetResult(interp, buf, TCL_VOLATILE); } else if (strcmp(argv[1], "result") == 0) { if (argc != 2) { goto wrongNumArgs; } Tcl_DStringResult(interp, &dstring); - } else if (strcmp(argv[1], "toobj") == 0) { - if (argc != 2) { - goto wrongNumArgs; - } - Tcl_SetObjResult(interp, Tcl_DStringToObj(&dstring)); } else if (strcmp(argv[1], "trunc") == 0) { if (argc != 3) { goto wrongNumArgs; @@ -2007,8 +1856,8 @@ TestdstringCmd( Tcl_DStringStartSublist(&dstring); } else { Tcl_AppendResult(interp, "bad option \"", argv[1], - "\": must be append, element, end, free, get, gresult, length, " - "result, start, toobj, or trunc", (void *)NULL); + "\": must be append, element, end, free, get, length, " + "result, trunc, or start", NULL); return TCL_ERROR; } return TCL_OK; @@ -2019,244 +1868,10 @@ TestdstringCmd( * Tcl_DStringGetResult handles freeProc's other than free. */ -static void SpecialFree( -#if TCL_MAJOR_VERSION > 8 - void *blockPtr /* Block to free. */ -#else - char *blockPtr /* Block to free. */ -#endif -) { - ckfree((char *)blockPtr - 16); -} - -/* - *------------------------------------------------------------------------ - * - * UtfTransformFn -- - * - * Implements a direct call into Tcl_UtfToExternal and Tcl_ExternalToUtf - * as otherwise there is no script level command that directly exercises - * these functions (i/o command cannot test all combinations) - * The arguments at the script level are roughly those of the above - * functions: - * encodingname srcbytes flags state dstlen ?srcreadvar? ?dstwrotevar? ?dstcharsvar? - * - * Results: - * TCL_OK or TCL_ERROR. This any errors running the test, NOT the - * result of Tcl_UtfToExternal or Tcl_ExternalToUtf. - * - * Side effects: - * - * The result in the interpreter is a list of the return code from the - * Tcl_UtfToExternal/Tcl_ExternalToUtf functions, the encoding state, and - * an encoded binary string of length dstLen. Note the string is the - * entire output buffer, not just the part containing the decoded - * portion. This allows for additional checks at test script level. - * - * If any of the srcreadvar, dstwrotevar and - * dstcharsvar are specified and not empty, they are treated as names - * of variables where the *srcRead, *dstWrote and *dstChars output - * from the functions are stored. - * - * The function also checks internally whether nuls are correctly - * appended as requested but the TCL_ENCODING_NO_TERMINATE flag - * and that no buffer overflows occur. - *------------------------------------------------------------------------ - */ -typedef int -UtfTransformFn(Tcl_Interp *interp, Tcl_Encoding encoding, const char *src, Tcl_Size srcLen, int flags, Tcl_EncodingState *statePtr, - char *dst, Tcl_Size dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); -static int UtfExtWrapper( - Tcl_Interp *interp, UtfTransformFn *transformer, int objc, Tcl_Obj *const objv[]) +static void SpecialFree(blockPtr) + char *blockPtr; /* Block to free. */ { - Tcl_Encoding encoding; - Tcl_EncodingState encState, *encStatePtr; - Tcl_Size srcLen, bufLen; - const unsigned char *bytes; - unsigned char *bufPtr; - int srcRead, dstLen, dstWrote, dstChars; - Tcl_Obj *srcReadVar, *dstWroteVar, *dstCharsVar; - int result; - int flags; - Tcl_Obj **flagObjs; - Tcl_Size nflags; - static const struct { - const char *flagKey; - int flag; - } flagMap[] = { - {"start", TCL_ENCODING_START}, - {"end", TCL_ENCODING_END}, - {"noterminate", TCL_ENCODING_NO_TERMINATE}, - {"charlimit", TCL_ENCODING_CHAR_LIMIT}, - {"profiletcl8", TCL_ENCODING_PROFILE_TCL8}, - {"profilestrict", TCL_ENCODING_PROFILE_STRICT}, - {"profilereplace", TCL_ENCODING_PROFILE_REPLACE}, - {NULL, 0} - }; - Tcl_Size i; - Tcl_WideInt wide; - - if (objc < 7 || objc > 10) { - Tcl_WrongNumArgs(interp, - 2, - objv, - "encoding srcbytes flags state dstlen ?srcreadvar? ?dstwrotevar? ?dstcharsvar?"); - return TCL_ERROR; - } - if (Tcl_GetEncodingFromObj(interp, objv[2], &encoding) != TCL_OK) { - return TCL_ERROR; - } - - /* Flags may be specified as list of integers and keywords */ - flags = 0; - if (Tcl_ListObjGetElements(interp, objv[4], &nflags, &flagObjs) != TCL_OK) { - return TCL_ERROR; - } - - for (i = 0; i < nflags; ++i) { - int flag; - if (Tcl_GetIntFromObj(NULL, flagObjs[i], &flag) == TCL_OK) { - flags |= flag; - } else { - int idx; - if (Tcl_GetIndexFromObjStruct(interp, - flagObjs[i], - flagMap, - sizeof(flagMap[0]), - "flag", - 0, - &idx) != TCL_OK) { - return TCL_ERROR; - } - flags |= flagMap[idx].flag; - } - } - - /* Assumes state is integer if not "" */ - if (Tcl_GetWideIntFromObj(interp, objv[5], &wide) == TCL_OK) { - encState = (Tcl_EncodingState)(size_t)wide; - encStatePtr = &encState; - } else if (Tcl_GetCharLength(objv[5]) == 0) { - encStatePtr = NULL; - } else { - return TCL_ERROR; - } - - if (Tcl_GetIntFromObj(interp, objv[6], &dstLen) != TCL_OK) { - return TCL_ERROR; - } - srcReadVar = NULL; - dstWroteVar = NULL; - dstCharsVar = NULL; - if (objc > 7) { - /* Has caller requested srcRead? */ - if (Tcl_GetCharLength(objv[7])) { - srcReadVar = objv[7]; - } - if (objc > 8) { - /* Ditto for dstWrote */ - if (Tcl_GetCharLength(objv[8])) { - dstWroteVar = objv[8]; - } - if (objc > 9) { - if (Tcl_GetCharLength(objv[9])) { - dstCharsVar = objv[9]; - } - } - } - } - if (flags & TCL_ENCODING_CHAR_LIMIT) { - /* Caller should have specified the dest char limit */ - Tcl_Obj *valueObj; - if (dstCharsVar == NULL || - (valueObj = Tcl_ObjGetVar2(interp, dstCharsVar, NULL, 0)) == NULL - ) { - Tcl_SetResult(interp, - "dstCharsVar must be specified with integer value if " - "TCL_ENCODING_CHAR_LIMIT set in flags.", TCL_STATIC); - return TCL_ERROR; - } - if (Tcl_GetIntFromObj(interp, valueObj, &dstChars) != TCL_OK) { - return TCL_ERROR; - } - } else { - dstChars = 0; /* Only used for output */ - } - - bufLen = dstLen + 4; /* 4 -> overflow detection */ - bufPtr = (unsigned char *) ckalloc(bufLen); - memset(bufPtr, 0xFF, dstLen); /* Need to check nul terminator */ - memmove(bufPtr + dstLen, "\xAB\xCD\xEF\xAB", 4); /* overflow detection */ - bytes = Tcl_GetByteArrayFromObj(objv[3], &srcLen); /* Last! to avoid shimmering */ - result = (*transformer)(interp, encoding, (const char *)bytes, srcLen, flags, - encStatePtr, (char *) bufPtr, dstLen, - srcReadVar ? &srcRead : NULL, - &dstWrote, - dstCharsVar ? &dstChars : NULL); - if (memcmp(bufPtr + bufLen - 4, "\xAB\xCD\xEF\xAB", 4)) { - Tcl_SetResult(interp, - "Tcl_ExternalToUtf wrote past output buffer", - TCL_STATIC); - result = TCL_ERROR; - } else if (result != TCL_ERROR) { - Tcl_Obj *resultObjs[3]; - switch (result) { - case TCL_OK: - resultObjs[0] = Tcl_NewStringObj("ok", TCL_INDEX_NONE); - break; - case TCL_CONVERT_MULTIBYTE: - resultObjs[0] = Tcl_NewStringObj("multibyte", TCL_INDEX_NONE); - break; - case TCL_CONVERT_SYNTAX: - resultObjs[0] = Tcl_NewStringObj("syntax", TCL_INDEX_NONE); - break; - case TCL_CONVERT_UNKNOWN: - resultObjs[0] = Tcl_NewStringObj("unknown", TCL_INDEX_NONE); - break; - case TCL_CONVERT_NOSPACE: - resultObjs[0] = Tcl_NewStringObj("nospace", TCL_INDEX_NONE); - break; - default: - resultObjs[0] = Tcl_NewIntObj(result); - break; - } - result = TCL_OK; - resultObjs[1] = - encStatePtr ? Tcl_NewWideIntObj((Tcl_WideInt)(size_t)encState) : Tcl_NewObj(); - resultObjs[2] = Tcl_NewByteArrayObj(bufPtr, dstLen); - if (srcReadVar) { - if (Tcl_ObjSetVar2(interp, - srcReadVar, - NULL, - Tcl_NewIntObj(srcRead), - TCL_LEAVE_ERR_MSG) == NULL) { - result = TCL_ERROR; - } - } - if (dstWroteVar) { - if (Tcl_ObjSetVar2(interp, - dstWroteVar, - NULL, - Tcl_NewIntObj(dstWrote), - TCL_LEAVE_ERR_MSG) == NULL) { - result = TCL_ERROR; - } - } - if (dstCharsVar) { - if (Tcl_ObjSetVar2(interp, - dstCharsVar, - NULL, - Tcl_NewIntObj(dstChars), - TCL_LEAVE_ERR_MSG) == NULL) { - result = TCL_ERROR; - } - } - Tcl_SetObjResult(interp, Tcl_NewListObj(3, resultObjs)); - } - - ckfree(bufPtr); - Tcl_FreeEncoding(encoding); /* Free returned reference */ - return result; + ckfree(blockPtr - 4); } /* @@ -2276,29 +1891,24 @@ static int UtfExtWrapper( *---------------------------------------------------------------------- */ + /* ARGSUSED */ static int TestencodingObjCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Encoding encoding; - Tcl_Size length; - const char *string; + int index, length; + char *string; TclEncoding *encodingPtr; - static const char *const optionStrings[] = { - "create", "delete", "nullength", "Tcl_ExternalToUtf", "Tcl_UtfToExternal", NULL + static const char *optionStrings[] = { + "create", "delete", NULL }; enum options { - ENC_CREATE, ENC_DELETE, ENC_NULLENGTH, ENC_EXTTOUTF, ENC_UTFTOEXT + ENC_CREATE, ENC_DELETE }; - int index; - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "command ?args?"); - return TCL_ERROR; - } if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0, &index) != TCL_OK) { @@ -2310,19 +1920,18 @@ TestencodingObjCmd( Tcl_EncodingType type; if (objc != 5) { - Tcl_WrongNumArgs(interp, 2, objv, "name toutfcmd fromutfcmd"); return TCL_ERROR; } - encodingPtr = (TclEncoding *)ckalloc(sizeof(TclEncoding)); + encodingPtr = (TclEncoding *) ckalloc(sizeof(TclEncoding)); encodingPtr->interp = interp; string = Tcl_GetStringFromObj(objv[3], &length); - encodingPtr->toUtfCmd = (char *)ckalloc(length + 1); - memcpy(encodingPtr->toUtfCmd, string, length + 1); + encodingPtr->toUtfCmd = (char *) ckalloc((unsigned) (length + 1)); + memcpy(encodingPtr->toUtfCmd, string, (unsigned) length + 1); string = Tcl_GetStringFromObj(objv[4], &length); - encodingPtr->fromUtfCmd = (char *)ckalloc(length + 1); - memcpy(encodingPtr->fromUtfCmd, string, length + 1); + encodingPtr->fromUtfCmd = (char *) ckalloc((unsigned) (length + 1)); + memcpy(encodingPtr->fromUtfCmd, string, (unsigned) (length + 1)); string = Tcl_GetStringFromObj(objv[2], &length); @@ -2330,7 +1939,7 @@ TestencodingObjCmd( type.toUtfProc = EncodingToUtfProc; type.fromUtfProc = EncodingFromUtfProc; type.freeProc = EncodingFreeProc; - type.clientData = encodingPtr; + type.clientData = (ClientData) encodingPtr; type.nullSize = 1; Tcl_CreateEncoding(&type); @@ -2340,43 +1949,21 @@ TestencodingObjCmd( if (objc != 3) { return TCL_ERROR; } - if (TCL_OK != Tcl_GetEncodingFromObj(interp, objv[2], &encoding)) { - return TCL_ERROR; - } - Tcl_FreeEncoding(encoding); /* Free returned reference */ - Tcl_FreeEncoding(encoding); /* Free to match CREATE */ - TclFreeInternalRep(objv[2]); /* Free the cached ref */ - break; - - case ENC_NULLENGTH: - if (objc > 3) { - Tcl_WrongNumArgs(interp, 2, objv, "?encoding?"); - return TCL_ERROR; - } - encoding = - Tcl_GetEncoding(interp, objc == 2 ? NULL : Tcl_GetString(objv[2])); - if (encoding == NULL) { - return TCL_ERROR; - } - Tcl_SetObjResult(interp, - Tcl_NewIntObj(Tcl_GetEncodingNulLength(encoding))); + encoding = Tcl_GetEncoding(NULL, Tcl_GetString(objv[2])); + Tcl_FreeEncoding(encoding); Tcl_FreeEncoding(encoding); - break; - case ENC_EXTTOUTF: - return UtfExtWrapper(interp,Tcl_ExternalToUtf,objc,objv); - case ENC_UTFTOEXT: - return UtfExtWrapper(interp,Tcl_UtfToExternal,objc,objv); + break; } return TCL_OK; } static int EncodingToUtfProc( - void *clientData, /* TclEncoding structure. */ - TCL_UNUSED(const char *) /*src*/, + ClientData clientData, /* TclEncoding structure. */ + const char *src, /* Source string in specified encoding. */ int srcLen, /* Source string length in bytes. */ - TCL_UNUSED(int) /*flags*/, - TCL_UNUSED(Tcl_EncodingState *), + 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. */ @@ -2387,13 +1974,13 @@ EncodingToUtfProc( TclEncoding *encodingPtr; encodingPtr = (TclEncoding *) clientData; - Tcl_EvalEx(encodingPtr->interp, encodingPtr->toUtfCmd, TCL_INDEX_NONE, TCL_EVAL_GLOBAL); + Tcl_GlobalEval(encodingPtr->interp, encodingPtr->toUtfCmd); len = strlen(Tcl_GetStringResult(encodingPtr->interp)); if (len > dstLen) { len = dstLen; } - memcpy(dst, Tcl_GetStringResult(encodingPtr->interp), len); + memcpy(dst, Tcl_GetStringResult(encodingPtr->interp), (unsigned) len); Tcl_ResetResult(encodingPtr->interp); *srcReadPtr = srcLen; @@ -2404,11 +1991,11 @@ EncodingToUtfProc( static int EncodingFromUtfProc( - void *clientData, /* TclEncoding structure. */ - TCL_UNUSED(const char *) /*src*/, + ClientData clientData, /* TclEncoding structure. */ + const char *src, /* Source string in specified encoding. */ int srcLen, /* Source string length in bytes. */ - TCL_UNUSED(int) /*flags*/, - TCL_UNUSED(Tcl_EncodingState *), + 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. */ @@ -2419,13 +2006,13 @@ EncodingFromUtfProc( TclEncoding *encodingPtr; encodingPtr = (TclEncoding *) clientData; - Tcl_EvalEx(encodingPtr->interp, encodingPtr->fromUtfCmd, TCL_INDEX_NONE, TCL_EVAL_GLOBAL); + Tcl_GlobalEval(encodingPtr->interp, encodingPtr->fromUtfCmd); len = strlen(Tcl_GetStringResult(encodingPtr->interp)); if (len > dstLen) { len = dstLen; } - memcpy(dst, Tcl_GetStringResult(encodingPtr->interp), len); + memcpy(dst, Tcl_GetStringResult(encodingPtr->interp), (unsigned) len); Tcl_ResetResult(encodingPtr->interp); *srcReadPtr = srcLen; @@ -2436,13 +2023,14 @@ EncodingFromUtfProc( static void EncodingFreeProc( - void *clientData) /* ClientData associated with type. */ + ClientData clientData) /* ClientData associated with type. */ { - TclEncoding *encodingPtr = (TclEncoding *)clientData; + TclEncoding *encodingPtr; - ckfree(encodingPtr->toUtfCmd); - ckfree(encodingPtr->fromUtfCmd); - ckfree(encodingPtr); + encodingPtr = (TclEncoding *) clientData; + ckfree((char *) encodingPtr->toUtfCmd); + ckfree((char *) encodingPtr->fromUtfCmd); + ckfree((char *) encodingPtr); } /* @@ -2464,21 +2052,20 @@ EncodingFreeProc( static int TestevalexObjCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int flags; - Tcl_Size length; - const char *script; + int length, flags; + char *script; flags = 0; if (objc == 3) { - const char *global = Tcl_GetString(objv[2]); + char *global = Tcl_GetStringFromObj(objv[2], &length); if (strcmp(global, "global") != 0) { Tcl_AppendResult(interp, "bad value \"", global, - "\": must be global", (void *)NULL); + "\": must be global", NULL); return TCL_ERROR; } flags = TCL_EVAL_GLOBAL; @@ -2510,7 +2097,7 @@ TestevalexObjCmd( static int TestevalobjvObjCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -2559,20 +2146,20 @@ TestevalobjvObjCmd( static int TesteventObjCmd( - TCL_UNUSED(void *), + 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 */ + static const char *subcommands[] = { /* Possible subcommands */ "queue", "delete", NULL }; int subCmdIndex; /* Index of the chosen subcommand */ - static const char *const positions[] = { /* Possible queue positions */ + static const char *positions[] = { /* Possible queue positions */ "head", "tail", "mark", NULL }; int posIndex; /* Index of the chosen position */ - static const int posNum[] = { + static const Tcl_QueuePosition posNum[] = { /* Interpretation of the chosen position */ TCL_QUEUE_HEAD, TCL_QUEUE_TAIL, @@ -2581,7 +2168,7 @@ TesteventObjCmd( TestEvent *ev; /* Event to be queued */ if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?arg ...?"); + Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?args?"); return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[1], subcommands, "subcommand", @@ -2598,7 +2185,7 @@ TesteventObjCmd( "position specifier", TCL_EXACT, &posIndex) != TCL_OK) { return TCL_ERROR; } - ev = (TestEvent *)ckalloc(sizeof(TestEvent)); + ev = (TestEvent *) ckalloc(sizeof(TestEvent)); ev->header.proc = TesteventProc; ev->header.nextPtr = NULL; ev->interp = interp; @@ -2644,7 +2231,7 @@ TesteventObjCmd( static int TesteventProc( Tcl_Event *event, /* Event to deliver */ - TCL_UNUSED(int) /*flags*/) + int flags) /* Current flags for Tcl_ServiceEvent */ { TestEvent *ev = (TestEvent *) event; Tcl_Interp *interp = ev->interp; @@ -2656,14 +2243,14 @@ TesteventProc( if (result != TCL_OK) { Tcl_AddErrorInfo(interp, " (command bound to \"testevent\" callback)"); - Tcl_BackgroundException(interp, TCL_ERROR); + 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_BackgroundException(interp, TCL_ERROR); + Tcl_BackgroundError(interp); return 1; } if (retval) { @@ -2695,21 +2282,21 @@ TesteventProc( static int TesteventDeleteProc( Tcl_Event *event, /* Event to examine */ - void *clientData) /* Tcl_Obj containing the name of the event(s) + ClientData clientData) /* Tcl_Obj containing the name of the event(s) * to remove */ { TestEvent *ev; /* Event to examine */ - const char *evNameStr; + char *evNameStr; Tcl_Obj *targetName; /* Name of the event(s) to delete */ - const char *targetNameStr; + char *targetNameStr; if (event->proc != TesteventProc) { return 0; } targetName = (Tcl_Obj *) clientData; - targetNameStr = (char *) Tcl_GetString(targetName); + targetNameStr = (char *) Tcl_GetStringFromObj(targetName, NULL); ev = (TestEvent *) event; - evNameStr = Tcl_GetString(ev->tag); + evNameStr = Tcl_GetStringFromObj(ev->tag, NULL); if (strcmp(evNameStr, targetNameStr) == 0) { Tcl_DecrRefCount(ev->tag); Tcl_DecrRefCount(ev->command); @@ -2738,7 +2325,7 @@ TesteventDeleteProc( static int TestexithandlerCmd( - TCL_UNUSED(void *), + ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -2747,7 +2334,7 @@ TestexithandlerCmd( if (argc != 3) { Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], - " create|delete value\"", (void *)NULL); + " create|delete value\"", NULL); return TCL_ERROR; } if (Tcl_GetInt(interp, argv[2], &value) != TCL_OK) { @@ -2755,13 +2342,13 @@ TestexithandlerCmd( } if (strcmp(argv[1], "create") == 0) { Tcl_CreateExitHandler((value & 1) ? ExitProcOdd : ExitProcEven, - INT2PTR(value)); + (ClientData) INT2PTR(value)); } else if (strcmp(argv[1], "delete") == 0) { Tcl_DeleteExitHandler((value & 1) ? ExitProcOdd : ExitProcEven, - INT2PTR(value)); + (ClientData) INT2PTR(value)); } else { Tcl_AppendResult(interp, "bad option \"", argv[1], - "\": must be create or delete", (void *)NULL); + "\": must be create or delete", NULL); return TCL_ERROR; } return TCL_OK; @@ -2769,28 +2356,28 @@ TestexithandlerCmd( static void ExitProcOdd( - void *clientData) /* Integer value to print. */ + ClientData clientData) /* Integer value to print. */ { char buf[16 + TCL_INTEGER_SPACE]; - int len; + size_t len; - snprintf(buf, sizeof(buf), "odd %d\n", (int)PTR2INT(clientData)); + sprintf(buf, "odd %d\n", PTR2INT(clientData)); len = strlen(buf); - if (len != (int) write(1, buf, len)) { + if (len != (size_t) write(1, buf, len)) { Tcl_Panic("ExitProcOdd: unable to write to stdout"); } } static void ExitProcEven( - void *clientData) /* Integer value to print. */ + ClientData clientData) /* Integer value to print. */ { char buf[16 + TCL_INTEGER_SPACE]; - int len; + size_t len; - snprintf(buf, sizeof(buf), "even %d\n", (int)PTR2INT(clientData)); + sprintf(buf, "even %d\n", PTR2INT(clientData)); len = strlen(buf); - if (len != (int) write(1, buf, len)) { + if (len != (size_t) write(1, buf, len)) { Tcl_Panic("ExitProcEven: unable to write to stdout"); } } @@ -2814,7 +2401,7 @@ ExitProcEven( static int TestexprlongCmd( - TCL_UNUSED(void *), + ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -2825,16 +2412,16 @@ TestexprlongCmd( if (argc != 2) { Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], - " expression\"", (void *)NULL); + " expression\"", NULL); return TCL_ERROR; } - Tcl_AppendResult(interp, "This is a result", (void *)NULL); + Tcl_SetResult(interp, "This is a result", TCL_STATIC); result = Tcl_ExprLong(interp, argv[1], &exprResult); if (result != TCL_OK) { return result; } - snprintf(buf, sizeof(buf), ": %ld", exprResult); - Tcl_AppendResult(interp, buf, (void *)NULL); + sprintf(buf, ": %ld", exprResult); + Tcl_AppendResult(interp, buf, NULL); return TCL_OK; } @@ -2857,7 +2444,7 @@ TestexprlongCmd( static int TestexprlongobjCmd( - TCL_UNUSED(void *), + ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const *objv) /* Argument objects. */ @@ -2870,13 +2457,13 @@ TestexprlongobjCmd( Tcl_WrongNumArgs(interp, 1, objv, "expression"); return TCL_ERROR; } - Tcl_AppendResult(interp, "This is a result", (void *)NULL); + Tcl_SetResult(interp, "This is a result", TCL_STATIC); result = Tcl_ExprLongObj(interp, objv[1], &exprResult); if (result != TCL_OK) { return result; } - snprintf(buf, sizeof(buf), ": %ld", exprResult); - Tcl_AppendResult(interp, buf, (void *)NULL); + sprintf(buf, ": %ld", exprResult); + Tcl_AppendResult(interp, buf, NULL); return TCL_OK; } @@ -2899,7 +2486,7 @@ TestexprlongobjCmd( static int TestexprdoubleCmd( - TCL_UNUSED(void *), + ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -2910,17 +2497,17 @@ TestexprdoubleCmd( if (argc != 2) { Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], - " expression\"", (void *)NULL); + " expression\"", NULL); return TCL_ERROR; } - Tcl_AppendResult(interp, "This is a result", (void *)NULL); + Tcl_SetResult(interp, "This is a result", TCL_STATIC); result = Tcl_ExprDouble(interp, argv[1], &exprResult); if (result != TCL_OK) { return result; } strcpy(buf, ": "); Tcl_PrintDouble(interp, exprResult, buf+2); - Tcl_AppendResult(interp, buf, (void *)NULL); + Tcl_AppendResult(interp, buf, NULL); return TCL_OK; } @@ -2943,7 +2530,7 @@ TestexprdoubleCmd( static int TestexprdoubleobjCmd( - TCL_UNUSED(void *), + ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const *objv) /* Argument objects. */ @@ -2956,14 +2543,14 @@ TestexprdoubleobjCmd( Tcl_WrongNumArgs(interp, 1, objv, "expression"); return TCL_ERROR; } - Tcl_AppendResult(interp, "This is a result", (void *)NULL); + Tcl_SetResult(interp, "This is a result", TCL_STATIC); result = Tcl_ExprDoubleObj(interp, objv[1], &exprResult); if (result != TCL_OK) { return result; } strcpy(buf, ": "); Tcl_PrintDouble(interp, exprResult, buf+2); - Tcl_AppendResult(interp, buf, (void *)NULL); + Tcl_AppendResult(interp, buf, NULL); return TCL_OK; } @@ -2985,14 +2572,14 @@ TestexprdoubleobjCmd( static int TestexprstringCmd( - TCL_UNUSED(void *), + 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\"", (void *)NULL); + " expression\"", NULL); return TCL_ERROR; } return Tcl_ExprString(interp, argv[1]); @@ -3017,7 +2604,7 @@ TestexprstringCmd( static int TestfilelinkCmd( - TCL_UNUSED(void *), + ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ @@ -3041,7 +2628,7 @@ TestfilelinkCmd( Tcl_AppendResult(interp, "could not create link from \"", Tcl_GetString(objv[1]), "\" to \"", Tcl_GetString(objv[2]), "\": ", - Tcl_PosixError(interp), (void *)NULL); + Tcl_PosixError(interp), NULL); return TCL_ERROR; } } else { @@ -3050,7 +2637,7 @@ TestfilelinkCmd( if (contents == NULL) { Tcl_AppendResult(interp, "could not read link \"", Tcl_GetString(objv[1]), "\": ", - Tcl_PosixError(interp), (void *)NULL); + Tcl_PosixError(interp), NULL); return TCL_ERROR; } } @@ -3084,7 +2671,7 @@ TestfilelinkCmd( static int TestgetassocdataCmd( - TCL_UNUSED(void *), + ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -3093,12 +2680,12 @@ TestgetassocdataCmd( if (argc != 2) { Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], - " data_key\"", (void *)NULL); + " data_key\"", NULL); return TCL_ERROR; } res = (char *) Tcl_GetAssocData(interp, argv[1], NULL); if (res != NULL) { - Tcl_AppendResult(interp, res, (void *)NULL); + Tcl_AppendResult(interp, res, NULL); } return TCL_OK; } @@ -3109,7 +2696,7 @@ TestgetassocdataCmd( * TestgetplatformCmd -- * * This procedure implements the "testgetplatform" command. It is - * used to retrieve the value of the tclPlatform global variable. + * used to retrievel the value of the tclPlatform global variable. * * Results: * A standard Tcl result. @@ -3122,23 +2709,23 @@ TestgetassocdataCmd( static int TestgetplatformCmd( - TCL_UNUSED(void *), + ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { - static const char *const platformStrings[] = { "unix", "mac", "windows" }; + static const char *platformStrings[] = { "unix", "mac", "windows" }; TclPlatformType *platform; platform = TclGetPlatform(); if (argc != 1) { Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], - (void *)NULL); + NULL); return TCL_ERROR; } - Tcl_AppendResult(interp, platformStrings[*platform], (void *)NULL); + Tcl_AppendResult(interp, platformStrings[*platform], NULL); return TCL_OK; } @@ -3160,25 +2747,26 @@ TestgetplatformCmd( *---------------------------------------------------------------------- */ + /* ARGSUSED */ static int TestinterpdeleteCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { - Tcl_Interp *childToDelete; + Tcl_Interp *slaveToDelete; if (argc != 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " path\"", (void *)NULL); + " path\"", NULL); return TCL_ERROR; } - childToDelete = Tcl_GetChild(interp, argv[1]); - if (childToDelete == NULL) { + slaveToDelete = Tcl_GetSlave(interp, argv[1]); + if (slaveToDelete == NULL) { return TCL_ERROR; } - Tcl_DeleteInterp(childToDelete); + Tcl_DeleteInterp(slaveToDelete); return TCL_OK; } @@ -3200,9 +2788,10 @@ TestinterpdeleteCmd( *---------------------------------------------------------------------- */ + /* ARGSUSED */ static int TestlinkCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -3210,17 +2799,17 @@ TestlinkCmd( static int intVar = 43; static int boolVar = 4; static double realVar = 1.23; - static Tcl_WideInt wideVar = 79; + static Tcl_WideInt wideVar = Tcl_LongAsWide(79); static char *stringVar = NULL; static char charVar = '@'; static unsigned char ucharVar = 130; static short shortVar = 3000; static unsigned short ushortVar = 60000; - static unsigned int uintVar = 0xBEEFFEED; + static unsigned int uintVar = 0xbeeffeed; static long longVar = 123456789L; static unsigned long ulongVar = 3456789012UL; static float floatVar = 4.5; - static Tcl_WideUInt uwideVar = 123; + static Tcl_WideUInt uwideVar = (Tcl_WideUInt) Tcl_LongAsWide(123); static int created = 0; char buffer[2*TCL_DOUBLE_SPACE]; int writable, flag; @@ -3229,7 +2818,7 @@ TestlinkCmd( 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" - " arg arg?\"", (void *)NULL); + " arg arg?\"", NULL); return TCL_ERROR; } if (strcmp(argv[1], "create") == 0) { @@ -3237,7 +2826,7 @@ TestlinkCmd( Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " ", argv[1], " intRO realRO boolRO stringRO wideRO charRO ucharRO shortRO" - " ushortRO uintRO longRO ulongRO floatRO uwideRO\"", (void *)NULL); + " ushortRO uintRO longRO ulongRO floatRO uwideRO\"", NULL); return TCL_ERROR; } if (created) { @@ -3260,112 +2849,112 @@ TestlinkCmd( if (Tcl_GetBoolean(interp, argv[2], &writable) != TCL_OK) { return TCL_ERROR; } - flag = writable ? 0 : TCL_LINK_READ_ONLY; - if (Tcl_LinkVar(interp, "int", &intVar, + flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + if (Tcl_LinkVar(interp, "int", (char *) &intVar, TCL_LINK_INT | flag) != TCL_OK) { return TCL_ERROR; } if (Tcl_GetBoolean(interp, argv[3], &writable) != TCL_OK) { return TCL_ERROR; } - flag = writable ? 0 : TCL_LINK_READ_ONLY; - if (Tcl_LinkVar(interp, "real", &realVar, + flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + if (Tcl_LinkVar(interp, "real", (char *) &realVar, TCL_LINK_DOUBLE | flag) != TCL_OK) { return TCL_ERROR; } if (Tcl_GetBoolean(interp, argv[4], &writable) != TCL_OK) { return TCL_ERROR; } - flag = writable ? 0 : TCL_LINK_READ_ONLY; - if (Tcl_LinkVar(interp, "bool", &boolVar, + flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + if (Tcl_LinkVar(interp, "bool", (char *) &boolVar, TCL_LINK_BOOLEAN | flag) != TCL_OK) { return TCL_ERROR; } if (Tcl_GetBoolean(interp, argv[5], &writable) != TCL_OK) { return TCL_ERROR; } - flag = writable ? 0 : TCL_LINK_READ_ONLY; - if (Tcl_LinkVar(interp, "string", &stringVar, + flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + if (Tcl_LinkVar(interp, "string", (char *) &stringVar, TCL_LINK_STRING | flag) != TCL_OK) { return TCL_ERROR; } if (Tcl_GetBoolean(interp, argv[6], &writable) != TCL_OK) { return TCL_ERROR; } - flag = writable ? 0 : TCL_LINK_READ_ONLY; - if (Tcl_LinkVar(interp, "wide", &wideVar, + flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + if (Tcl_LinkVar(interp, "wide", (char *) &wideVar, TCL_LINK_WIDE_INT | flag) != TCL_OK) { return TCL_ERROR; } if (Tcl_GetBoolean(interp, argv[7], &writable) != TCL_OK) { return TCL_ERROR; } - flag = writable ? 0 : TCL_LINK_READ_ONLY; - if (Tcl_LinkVar(interp, "char", &charVar, + flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + if (Tcl_LinkVar(interp, "char", (char *) &charVar, TCL_LINK_CHAR | flag) != TCL_OK) { return TCL_ERROR; } if (Tcl_GetBoolean(interp, argv[8], &writable) != TCL_OK) { return TCL_ERROR; } - flag = writable ? 0 : TCL_LINK_READ_ONLY; - if (Tcl_LinkVar(interp, "uchar", &ucharVar, + flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + if (Tcl_LinkVar(interp, "uchar", (char *) &ucharVar, TCL_LINK_UCHAR | flag) != TCL_OK) { return TCL_ERROR; } if (Tcl_GetBoolean(interp, argv[9], &writable) != TCL_OK) { return TCL_ERROR; } - flag = writable ? 0 : TCL_LINK_READ_ONLY; - if (Tcl_LinkVar(interp, "short", &shortVar, + flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + if (Tcl_LinkVar(interp, "short", (char *) &shortVar, TCL_LINK_SHORT | flag) != TCL_OK) { return TCL_ERROR; } if (Tcl_GetBoolean(interp, argv[10], &writable) != TCL_OK) { return TCL_ERROR; } - flag = writable ? 0 : TCL_LINK_READ_ONLY; - if (Tcl_LinkVar(interp, "ushort", &ushortVar, + flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + if (Tcl_LinkVar(interp, "ushort", (char *) &ushortVar, TCL_LINK_USHORT | flag) != TCL_OK) { return TCL_ERROR; } if (Tcl_GetBoolean(interp, argv[11], &writable) != TCL_OK) { return TCL_ERROR; } - flag = writable ? 0 : TCL_LINK_READ_ONLY; - if (Tcl_LinkVar(interp, "uint", &uintVar, + flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + if (Tcl_LinkVar(interp, "uint", (char *) &uintVar, TCL_LINK_UINT | flag) != TCL_OK) { return TCL_ERROR; } if (Tcl_GetBoolean(interp, argv[12], &writable) != TCL_OK) { return TCL_ERROR; } - flag = writable ? 0 : TCL_LINK_READ_ONLY; - if (Tcl_LinkVar(interp, "long", &longVar, + flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + if (Tcl_LinkVar(interp, "long", (char *) &longVar, TCL_LINK_LONG | flag) != TCL_OK) { return TCL_ERROR; } if (Tcl_GetBoolean(interp, argv[13], &writable) != TCL_OK) { return TCL_ERROR; } - flag = writable ? 0 : TCL_LINK_READ_ONLY; - if (Tcl_LinkVar(interp, "ulong", &ulongVar, + flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + if (Tcl_LinkVar(interp, "ulong", (char *) &ulongVar, TCL_LINK_ULONG | flag) != TCL_OK) { return TCL_ERROR; } if (Tcl_GetBoolean(interp, argv[14], &writable) != TCL_OK) { return TCL_ERROR; } - flag = writable ? 0 : TCL_LINK_READ_ONLY; - if (Tcl_LinkVar(interp, "float", &floatVar, + flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + if (Tcl_LinkVar(interp, "float", (char *) &floatVar, TCL_LINK_FLOAT | flag) != TCL_OK) { return TCL_ERROR; } if (Tcl_GetBoolean(interp, argv[15], &writable) != TCL_OK) { return TCL_ERROR; } - flag = writable ? 0 : TCL_LINK_READ_ONLY; - if (Tcl_LinkVar(interp, "uwide", &uwideVar, + flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + if (Tcl_LinkVar(interp, "uwide", (char *) &uwideVar, TCL_LINK_WIDE_UINT | flag) != TCL_OK) { return TCL_ERROR; } @@ -3410,32 +2999,15 @@ TestlinkCmd( Tcl_AppendElement(interp, buffer); TclFormatInt(buffer, (int) uintVar); Tcl_AppendElement(interp, buffer); - tmp = Tcl_NewWideIntObj(longVar); + tmp = Tcl_NewLongObj(longVar); Tcl_AppendElement(interp, Tcl_GetString(tmp)); Tcl_DecrRefCount(tmp); -#ifdef TCL_WIDE_INT_IS_LONG - if (ulongVar > WIDE_MAX) { - mp_int bignumValue; - if (mp_init_u64(&bignumValue, ulongVar) != MP_OKAY) { - Tcl_Panic("%s: memory overflow", "Tcl_SetWideUIntObj"); - } - tmp = Tcl_NewBignumObj(&bignumValue); - } else -#endif /* TCL_WIDE_INT_IS_LONG */ - tmp = Tcl_NewWideIntObj((Tcl_WideInt)ulongVar); + tmp = Tcl_NewLongObj((long)ulongVar); Tcl_AppendElement(interp, Tcl_GetString(tmp)); Tcl_DecrRefCount(tmp); Tcl_PrintDouble(NULL, (double)floatVar, buffer); Tcl_AppendElement(interp, buffer); - if (uwideVar > WIDE_MAX) { - mp_int bignumValue; - if (mp_init_u64(&bignumValue, uwideVar) != MP_OKAY) { - Tcl_Panic("%s: memory overflow", "Tcl_SetWideUIntObj"); - } - tmp = Tcl_NewBignumObj(&bignumValue); - } else { - tmp = Tcl_NewWideIntObj((Tcl_WideInt)uwideVar); - } + tmp = Tcl_NewWideIntObj((Tcl_WideInt)uwideVar); Tcl_AppendElement(interp, Tcl_GetString(tmp)); Tcl_DecrRefCount(tmp); } else if (strcmp(argv[1], "set") == 0) { @@ -3446,7 +3018,7 @@ TestlinkCmd( argv[0], " ", argv[1], " intValue realValue boolValue stringValue wideValue" " charValue ucharValue shortValue ushortValue uintValue" - " longValue ulongValue floatValue uwideValue\"", (void *)NULL); + " longValue ulongValue floatValue uwideValue\"", NULL); return TCL_ERROR; } if (argv[2][0] != 0) { @@ -3471,7 +3043,7 @@ TestlinkCmd( if (strcmp(argv[5], "-") == 0) { stringVar = NULL; } else { - stringVar = (char *)ckalloc(strlen(argv[5]) + 1); + stringVar = (char *) ckalloc((unsigned) (strlen(argv[5]) + 1)); strcpy(stringVar, argv[5]); } } @@ -3550,7 +3122,7 @@ TestlinkCmd( argv[0], " ", argv[1], " intValue realValue boolValue stringValue wideValue" " charValue ucharValue shortValue ushortValue uintValue" - " longValue ulongValue floatValue uwideValue\"", (void *)NULL); + " longValue ulongValue floatValue uwideValue\"", NULL); return TCL_ERROR; } if (argv[2][0] != 0) { @@ -3578,7 +3150,7 @@ TestlinkCmd( if (strcmp(argv[5], "-") == 0) { stringVar = NULL; } else { - stringVar = (char *)ckalloc(strlen(argv[5]) + 1); + stringVar = (char *) ckalloc((unsigned) (strlen(argv[5]) + 1)); strcpy(stringVar, argv[5]); } Tcl_UpdateLinkedVar(interp, "string"); @@ -3662,7 +3234,7 @@ TestlinkCmd( } } else { Tcl_AppendResult(interp, "bad option \"", argv[1], - "\": should be create, delete, get, set, or update", (void *)NULL); + "\": should be create, delete, get, set, or update", NULL); return TCL_ERROR; } return TCL_OK; @@ -3671,132 +3243,75 @@ TestlinkCmd( /* *---------------------------------------------------------------------- * - * TestlinkarrayCmd -- + * TestlocaleCmd -- * - * This function is invoked to process the "testlinkarray" Tcl command. - * It is used to test the 'Tcl_LinkArray' function. + * This procedure implements the "testlocale" command. It is used + * to test the effects of setting different locales in Tcl. * * Results: - * A standard Tcl result. + * A standard Tcl result. * * Side effects: - * Creates, deletes, and invokes variable links. + * Modifies the current C locale. * *---------------------------------------------------------------------- */ static int -TestlinkarrayCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - static const char *LinkOption[] = { - "update", "remove", "create", NULL - }; - enum LinkOptionEnum { LINK_UPDATE, LINK_REMOVE, LINK_CREATE }; - static const char *LinkType[] = { - "char", "uchar", "short", "ushort", "int", "uint", "long", "ulong", - "wide", "uwide", "float", "double", "string", "char*", "binary", NULL +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; + + static const char *optionStrings[] = { + "ctype", "numeric", "time", "collate", "monetary", + "all", NULL }; - /* all values after TCL_LINK_CHARS_ARRAY are used as arrays (see below) */ - static int LinkTypes[] = { - TCL_LINK_CHAR, TCL_LINK_UCHAR, - TCL_LINK_SHORT, TCL_LINK_USHORT, TCL_LINK_INT, TCL_LINK_UINT, - TCL_LINK_LONG, TCL_LINK_ULONG, TCL_LINK_WIDE_INT, TCL_LINK_WIDE_UINT, - TCL_LINK_FLOAT, TCL_LINK_DOUBLE, TCL_LINK_STRING, TCL_LINK_CHARS, - TCL_LINK_BINARY + static CONST int lcTypes[] = { + LC_CTYPE, LC_NUMERIC, LC_TIME, LC_COLLATE, LC_MONETARY, + LC_ALL }; - int optionIndex, typeIndex, readonly, i, size; - Tcl_Size length; - char *name, *arg; - Tcl_WideInt addr; - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "option args"); + /* + * LC_CTYPE, etc. correspond to the indices for the strings. + */ + + if (objc < 2 || objc > 3) { + Tcl_WrongNumArgs(interp, 1, objv, "category ?locale?"); return TCL_ERROR; } - if (Tcl_GetIndexFromObj(interp, objv[1], LinkOption, "option", 0, - &optionIndex) != TCL_OK) { + + if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0, + &index) != TCL_OK) { return TCL_ERROR; } - switch ((enum LinkOptionEnum) optionIndex) { - case LINK_UPDATE: - for (i=2; i<objc; i++) { - Tcl_UpdateLinkedVar(interp, Tcl_GetString(objv[i])); - } - return TCL_OK; - case LINK_REMOVE: - for (i=2; i<objc; i++) { - Tcl_UnlinkVar(interp, Tcl_GetString(objv[i])); - } - return TCL_OK; - case LINK_CREATE: - if (objc < 4) { - goto wrongArgs; - } - readonly = 0; - i = 2; - - /* - * test on switch -r... - */ - arg = Tcl_GetStringFromObj(objv[i], &length); - if (length < 2) { - goto wrongArgs; - } - if (arg[0] == '-') { - if (arg[1] != 'r') { - goto wrongArgs; - } - readonly = TCL_LINK_READ_ONLY; - i++; - } - if (Tcl_GetIndexFromObj(interp, objv[i++], LinkType, "type", 0, - &typeIndex) != TCL_OK) { - return TCL_ERROR; - } - if (Tcl_GetIntFromObj(interp, objv[i++], &size) == TCL_ERROR) { - Tcl_SetObjResult(interp, Tcl_NewStringObj("wrong size value", -1)); - return TCL_ERROR; - } - name = Tcl_GetString(objv[i++]); - - /* - * If no address is given request one in the underlying function - */ - - if (i < objc) { - if (Tcl_GetWideIntFromObj(interp, objv[i], &addr) == TCL_ERROR) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "wrong address value", -1)); - return TCL_ERROR; - } - } else { - addr = 0; - } - return Tcl_LinkArray(interp, name, INT2PTR(addr), - LinkTypes[typeIndex] | readonly, size); + if (objc == 3) { + locale = Tcl_GetString(objv[2]); + } else { + locale = NULL; + } + locale = setlocale(lcTypes[index], locale); + if (locale) { + Tcl_SetStringObj(Tcl_GetObjResult(interp), locale, -1); } return TCL_OK; - - wrongArgs: - Tcl_WrongNumArgs(interp, 2, objv, "?-readonly? type size name ?address?"); - return TCL_ERROR; } /* *---------------------------------------------------------------------- * - * TestlistrepCmd -- + * TestMathFunc -- * - * This function is invoked to generate a list object with a specific - * internal representation. + * This is a user-defined math procedure to test out math procedures + * with no arguments. * * Results: - * A standard Tcl result. + * A normal Tcl completion code. * * Side effects: * None. @@ -3804,204 +3319,125 @@ TestlinkarrayCmd( *---------------------------------------------------------------------- */ + /* ARGSUSED */ static int -TestlistrepCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - /* Subcommands supported by this command */ - static const char *const subcommands[] = { - "new", - "describe", - "config", - "validate", - NULL - }; - enum { - LISTREP_NEW, - LISTREP_DESCRIBE, - LISTREP_CONFIG, - LISTREP_VALIDATE - } cmdIndex; - Tcl_Obj *resultObj = NULL; - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "command ?arg ...?"); - return TCL_ERROR; - } - if (Tcl_GetIndexFromObj( - interp, objv[1], subcommands, "command", 0, &cmdIndex) - != TCL_OK) { - return TCL_ERROR; - } - switch (cmdIndex) { - case LISTREP_NEW: - if (objc < 3 || objc > 5) { - Tcl_WrongNumArgs(interp, 2, objv, "length ?leadSpace endSpace?"); - return TCL_ERROR; - } else { - Tcl_WideUInt length; - Tcl_WideUInt leadSpace = 0; - Tcl_WideUInt endSpace = 0; - if (Tcl_GetWideUIntFromObj(interp, objv[2], &length) != TCL_OK) { - return TCL_ERROR; - } - if (objc > 3) { - if (Tcl_GetWideUIntFromObj(interp, objv[3], &leadSpace) != TCL_OK) { - return TCL_ERROR; - } - if (objc > 4) { - if (Tcl_GetWideUIntFromObj(interp, objv[4], &endSpace) - != TCL_OK) { - return TCL_ERROR; - } - } - } - resultObj = TclListTestObj(length, leadSpace, endSpace); - if (resultObj == NULL) { - Tcl_AppendResult(interp, "List capacity exceeded", (void *)NULL); - return TCL_ERROR; - } - } - break; - - case LISTREP_DESCRIBE: -#define APPEND_FIELD(targetObj_, structPtr_, fld_) \ - do { \ - Tcl_ListObjAppendElement( \ - interp, (targetObj_), Tcl_NewStringObj(#fld_, -1)); \ - Tcl_ListObjAppendElement( \ - interp, (targetObj_), Tcl_NewWideIntObj((structPtr_)->fld_)); \ - } while (0) - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "object"); - return TCL_ERROR; - } else { - Tcl_Obj **objs; - Tcl_Size nobjs; - ListRep listRep; - Tcl_Obj *listRepObjs[4]; - - /* Force list representation */ - if (Tcl_ListObjGetElements(interp, objv[2], &nobjs, &objs) != TCL_OK) { - return TCL_ERROR; - } - ListObjGetRep(objv[2], &listRep); - listRepObjs[0] = Tcl_NewStringObj("store", -1); - listRepObjs[1] = Tcl_NewListObj(12, NULL); - Tcl_ListObjAppendElement( - interp, listRepObjs[1], Tcl_NewStringObj("memoryAddress", -1)); - Tcl_ListObjAppendElement( - interp, listRepObjs[1], Tcl_ObjPrintf("%p", listRep.storePtr)); - APPEND_FIELD(listRepObjs[1], listRep.storePtr, firstUsed); - APPEND_FIELD(listRepObjs[1], listRep.storePtr, numUsed); - APPEND_FIELD(listRepObjs[1], listRep.storePtr, numAllocated); - APPEND_FIELD(listRepObjs[1], listRep.storePtr, refCount); - APPEND_FIELD(listRepObjs[1], listRep.storePtr, flags); - if (listRep.spanPtr) { - listRepObjs[2] = Tcl_NewStringObj("span", -1); - listRepObjs[3] = Tcl_NewListObj(8, NULL); - Tcl_ListObjAppendElement(interp, - listRepObjs[3], - Tcl_NewStringObj("memoryAddress", -1)); - Tcl_ListObjAppendElement( - interp, listRepObjs[3], Tcl_ObjPrintf("%p", listRep.spanPtr)); - APPEND_FIELD(listRepObjs[3], listRep.spanPtr, spanStart); - APPEND_FIELD( - listRepObjs[3], listRep.spanPtr, spanLength); - APPEND_FIELD(listRepObjs[3], listRep.spanPtr, refCount); - } - resultObj = Tcl_NewListObj(listRep.spanPtr ? 4 : 2, listRepObjs); - } -#undef APPEND_FIELD - break; - - case LISTREP_CONFIG: - if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, "object"); - return TCL_ERROR; - } - resultObj = Tcl_NewListObj(2, NULL); - Tcl_ListObjAppendElement( - NULL, resultObj, Tcl_NewStringObj("LIST_SPAN_THRESHOLD", -1)); - Tcl_ListObjAppendElement( - NULL, resultObj, Tcl_NewWideIntObj(LIST_SPAN_THRESHOLD)); - break; - - case LISTREP_VALIDATE: - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "object"); - return TCL_ERROR; - } - TclListObjValidate(interp, objv[2]); /* Panics if invalid */ - resultObj = Tcl_NewObj(); - break; - } - Tcl_SetObjResult(interp, resultObj); +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 = PTR2INT(clientData); return TCL_OK; } /* *---------------------------------------------------------------------- * - * TestlocaleCmd -- + * TestMathFunc2 -- * - * This procedure implements the "testlocale" command. It is used - * to test the effects of setting different locales in Tcl. + * This is a user-defined math procedure to test out math procedures + * that do have arguments, in this case 2. * * Results: - * A standard Tcl result. + * A normal Tcl completion code. * * Side effects: - * Modifies the current C locale. + * None. * *---------------------------------------------------------------------- */ + /* ARGSUSED */ static int -TestlocaleCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* The argument objects. */ +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 index; - const char *locale; - static const char *const optionStrings[] = { - "ctype", "numeric", "time", "collate", "monetary", - "all", NULL - }; - static const int lcTypes[] = { - LC_CTYPE, LC_NUMERIC, LC_TIME, LC_COLLATE, LC_MONETARY, - LC_ALL - }; + int result = TCL_OK; /* - * LC_CTYPE, etc. correspond to the indices for the strings. + * Return the maximum of the two arguments with the correct type. */ - if (objc < 2 || objc > 3) { - Tcl_WrongNumArgs(interp, 1, objv, "category ?locale?"); - return TCL_ERROR; - } + if (args[0].type == TCL_INT) { + int i0 = args[0].intValue; - if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0, - &index) != TCL_OK) { - return TCL_ERROR; - } + if (args[1].type == TCL_INT) { + int i1 = args[1].intValue; - if (objc == 3) { - locale = Tcl_GetString(objv[2]); + resultPtr->type = TCL_INT; + resultPtr->intValue = ((i0 > i1)? i0 : i1); + } else if (args[1].type == TCL_DOUBLE) { + double d0 = i0; + double d1 = args[1].doubleValue; + + resultPtr->type = TCL_DOUBLE; + resultPtr->doubleValue = ((d0 > d1)? d0 : d1); + } else if (args[1].type == TCL_WIDE_INT) { + Tcl_WideInt w0 = Tcl_LongAsWide(i0); + Tcl_WideInt w1 = args[1].wideValue; + + resultPtr->type = TCL_WIDE_INT; + resultPtr->wideValue = ((w0 > w1)? w0 : w1); + } else { + Tcl_SetResult(interp, "T3: wrong type for arg 2", TCL_STATIC); + result = TCL_ERROR; + } + } else if (args[0].type == TCL_DOUBLE) { + double d0 = args[0].doubleValue; + + if (args[1].type == TCL_INT) { + double d1 = args[1].intValue; + + resultPtr->type = TCL_DOUBLE; + resultPtr->doubleValue = ((d0 > d1)? d0 : d1); + } else if (args[1].type == TCL_DOUBLE) { + double d1 = args[1].doubleValue; + + resultPtr->type = TCL_DOUBLE; + resultPtr->doubleValue = ((d0 > d1)? d0 : d1); + } else if (args[1].type == TCL_WIDE_INT) { + double d1 = Tcl_WideAsDouble(args[1].wideValue); + + resultPtr->type = TCL_DOUBLE; + resultPtr->doubleValue = ((d0 > d1)? d0 : d1); + } else { + Tcl_SetResult(interp, "T3: wrong type for arg 2", TCL_STATIC); + result = TCL_ERROR; + } + } else if (args[0].type == TCL_WIDE_INT) { + Tcl_WideInt w0 = args[0].wideValue; + + if (args[1].type == TCL_INT) { + Tcl_WideInt w1 = Tcl_LongAsWide(args[1].intValue); + + resultPtr->type = TCL_WIDE_INT; + resultPtr->wideValue = ((w0 > w1)? w0 : w1); + } else if (args[1].type == TCL_DOUBLE) { + double d0 = Tcl_WideAsDouble(w0); + double d1 = args[1].doubleValue; + + resultPtr->type = TCL_DOUBLE; + resultPtr->doubleValue = ((d0 > d1)? d0 : d1); + } else if (args[1].type == TCL_WIDE_INT) { + Tcl_WideInt w1 = args[1].wideValue; + + resultPtr->type = TCL_WIDE_INT; + resultPtr->wideValue = ((w0 > w1)? w0 : w1); + } else { + Tcl_SetResult(interp, "T3: wrong type for arg 2", TCL_STATIC); + result = TCL_ERROR; + } } else { - locale = NULL; - } - locale = setlocale(lcTypes[index], locale); - if (locale) { - Tcl_SetStringObj(Tcl_GetObjResult(interp), locale, -1); + Tcl_SetResult(interp, "T3: wrong type for arg 1", TCL_STATIC); + result = TCL_ERROR; } - return TCL_OK; + return result; } /* @@ -4020,13 +3456,13 @@ TestlocaleCmd( * *---------------------------------------------------------------------- */ - + /* ARGSUSED */ static void CleanupTestSetassocdataTests( - void *clientData, /* Data to be released. */ - TCL_UNUSED(Tcl_Interp *)) + ClientData clientData, /* Data to be released. */ + Tcl_Interp *interp) /* Interpreter being deleted. */ { - ckfree(clientData); + ckfree((char *) clientData); } /* @@ -4048,14 +3484,13 @@ CleanupTestSetassocdataTests( static int TestparserObjCmd( - TCL_UNUSED(void *), + ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ { - const char *script; - Tcl_Size dummy; - int length; + char *script; + int length, dummy; Tcl_Parse parse; if (objc != 3) { @@ -4105,14 +3540,13 @@ TestparserObjCmd( static int TestexprparserObjCmd( - TCL_UNUSED(void *), + ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ { - const char *script; - Tcl_Size dummy; - int length; + char *script; + int length, dummy; Tcl_Parse parse; if (objc != 3) { @@ -4174,7 +3608,7 @@ PrintParse( Tcl_Obj *objPtr; const char *typeString; Tcl_Token *tokenPtr; - Tcl_Size i; + int i; objPtr = Tcl_GetObjResult(interp); if (parsePtr->commentSize > 0) { @@ -4187,7 +3621,7 @@ PrintParse( Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewStringObj(parsePtr->commandStart, parsePtr->commandSize)); Tcl_ListObjAppendElement(NULL, objPtr, - Tcl_NewWideIntObj(parsePtr->numWords)); + Tcl_NewIntObj(parsePtr->numWords)); for (i = 0; i < parsePtr->numTokens; i++) { tokenPtr = &parsePtr->tokenPtr[i]; switch (tokenPtr->type) { @@ -4227,12 +3661,11 @@ PrintParse( Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewStringObj(tokenPtr->start, tokenPtr->size)); Tcl_ListObjAppendElement(NULL, objPtr, - Tcl_NewWideIntObj(tokenPtr->numComponents)); + Tcl_NewIntObj(tokenPtr->numComponents)); } Tcl_ListObjAppendElement(NULL, objPtr, - parsePtr->commandStart ? Tcl_NewStringObj(parsePtr->commandStart + parsePtr->commandSize, - TCL_INDEX_NONE) : Tcl_NewObj()); + -1)); } /* @@ -4254,7 +3687,7 @@ PrintParse( static int TestparsevarObjCmd( - TCL_UNUSED(void *), + ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ @@ -4295,14 +3728,13 @@ TestparsevarObjCmd( static int TestparsevarnameObjCmd( - TCL_UNUSED(void *), + ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ { - const char *script; - int length, append; - Tcl_Size dummy; + char *script; + int append, length, dummy; Tcl_Parse parse; if (objc != 4) { @@ -4342,77 +3774,6 @@ TestparsevarnameObjCmd( /* *---------------------------------------------------------------------- * - * TestpreferstableObjCmd -- - * - * This procedure implements the "testpreferstable" command. It is - * used for being able to test the "package" command even when the - * environment variable TCL_PKG_PREFER_LATEST is set in your environment. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -TestpreferstableObjCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, /* Current interpreter. */ - TCL_UNUSED(int) /*objc*/, - TCL_UNUSED(Tcl_Obj *const *) /*objv*/) -{ - Interp *iPtr = (Interp *) interp; - - iPtr->packagePrefer = PKG_PREFER_STABLE; - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TestprintObjCmd -- - * - * This procedure implements the "testprint" command. It is - * used for being able to test the Tcl_ObjPrintf() function. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -TestprintObjCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* The argument objects. */ -{ - Tcl_WideInt argv1 = 0; - size_t argv2; - long argv3; - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "format wideint"); - return TCL_OK; - } - - Tcl_GetWideIntFromObj(interp, objv[2], &argv1); - argv2 = (size_t)argv1; - argv3 = (long)argv1; - Tcl_SetObjResult(interp, Tcl_ObjPrintf(Tcl_GetString(objv[1]), argv1, argv2, argv3, argv3)); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * * TestregexpObjCmd -- * * This procedure implements the "testregexp" command. It is used to give @@ -4429,33 +3790,32 @@ TestprintObjCmd( *---------------------------------------------------------------------- */ + /* ARGSUSED */ static int TestregexpObjCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int i, indices, match, about; - Tcl_Size stringLength, ii; + int i, ii, indices, stringLength, match, about; int hasxflags, cflags, eflags; Tcl_RegExp regExpr; - const char *string; + char *string; Tcl_Obj *objPtr; Tcl_RegExpInfo info; - static const char *const options[] = { + static const char *options[] = { "-indices", "-nocase", "-about", "-expanded", "-line", "-linestop", "-lineanchor", "-xflags", "--", NULL }; - enum optionsEnum { + enum options { REGEXP_INDICES, REGEXP_NOCASE, REGEXP_ABOUT, REGEXP_EXPANDED, REGEXP_MULTI, REGEXP_NOCROSS, REGEXP_NEWL, REGEXP_XFLAGS, REGEXP_LAST }; - int index; indices = 0; about = 0; @@ -4464,7 +3824,8 @@ TestregexpObjCmd( hasxflags = 0; for (i = 1; i < objc; i++) { - const char *name; + char *name; + int index; name = Tcl_GetString(objv[i]); if (name[0] != '-') { @@ -4474,7 +3835,7 @@ TestregexpObjCmd( &index) != TCL_OK) { return TCL_ERROR; } - switch ((enum optionsEnum) index) { + switch ((enum options) index) { case REGEXP_INDICES: indices = 1; break; @@ -4508,7 +3869,7 @@ TestregexpObjCmd( endOfForLoop: if (objc - i < hasxflags + 2 - about) { Tcl_WrongNumArgs(interp, 1, objv, - "?-switch ...? exp string ?matchVar? ?subMatchVar ...?"); + "?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?"); return TCL_ERROR; } objc -= i; @@ -4546,34 +3907,34 @@ TestregexpObjCmd( * value 0. */ - Tcl_SetWideIntObj(Tcl_GetObjResult(interp), 0); + Tcl_SetIntObj(Tcl_GetObjResult(interp), 0); if (objc > 2 && (cflags®_EXPECT) && indices) { - const char *varName; + char *varName; const char *value; - Tcl_Size start, end; + int start, end; char resinfo[TCL_INTEGER_SPACE * 2]; varName = Tcl_GetString(objv[2]); - TclRegExpRangeUniChar(regExpr, TCL_INDEX_NONE, &start, &end); - snprintf(resinfo, sizeof(resinfo), "%d %d", start, end-1); - value = Tcl_SetVar2(interp, varName, NULL, resinfo, 0); + TclRegExpRangeUniChar(regExpr, -1, &start, &end); + sprintf(resinfo, "%d %d", start, end-1); + value = Tcl_SetVar(interp, varName, resinfo, 0); if (value == NULL) { Tcl_AppendResult(interp, "couldn't set variable \"", - varName, "\"", (void *)NULL); + varName, "\"", NULL); return TCL_ERROR; } } else if (cflags & TCL_REG_CANMATCH) { - const char *varName; + char *varName; const char *value; char resinfo[TCL_INTEGER_SPACE * 2]; Tcl_RegExpGetInfo(regExpr, &info); varName = Tcl_GetString(objv[2]); - snprintf(resinfo, sizeof(resinfo), "%ld", info.extendStart); - value = Tcl_SetVar2(interp, varName, NULL, resinfo, 0); + sprintf(resinfo, "%ld", info.extendStart); + value = Tcl_SetVar(interp, varName, resinfo, 0); if (value == NULL) { Tcl_AppendResult(interp, "couldn't set variable \"", - varName, "\"", (void *)NULL); + varName, "\"", NULL); return TCL_ERROR; } } @@ -4590,19 +3951,19 @@ TestregexpObjCmd( Tcl_RegExpGetInfo(regExpr, &info); for (i = 0; i < objc; i++) { - Tcl_Size start, end; + int start, end; Tcl_Obj *newPtr, *varPtr, *valuePtr; varPtr = objv[i]; - ii = ((cflags®_EXPECT) && i == objc-1) ? TCL_INDEX_NONE : (Tcl_Size)i; + ii = ((cflags®_EXPECT) && i == objc-1) ? -1 : i; if (indices) { Tcl_Obj *objs[2]; - if (ii == TCL_INDEX_NONE) { + if (ii == -1) { TclRegExpRangeUniChar(regExpr, ii, &start, &end); } else if (ii > info.nsubs) { - start = TCL_INDEX_NONE; - end = TCL_INDEX_NONE; + start = -1; + end = -1; } else { start = info.matches[ii].start; end = info.matches[ii].end; @@ -4617,23 +3978,25 @@ TestregexpObjCmd( end--; } - objs[0] = Tcl_NewWideIntObj(start); - objs[1] = Tcl_NewWideIntObj(end); + objs[0] = Tcl_NewLongObj(start); + objs[1] = Tcl_NewLongObj(end); newPtr = Tcl_NewListObj(2, objs); } else { - if (ii == TCL_INDEX_NONE) { + if (ii == -1) { TclRegExpRangeUniChar(regExpr, ii, &start, &end); - newPtr = TclGetRange(objPtr, start, end); - } else if (ii > info.nsubs || info.matches[ii].end <= 0) { + newPtr = Tcl_GetRange(objPtr, start, end); + } else if (ii > info.nsubs) { newPtr = Tcl_NewObj(); } else { - newPtr = TclGetRange(objPtr, info.matches[ii].start, + newPtr = Tcl_GetRange(objPtr, info.matches[ii].start, info.matches[ii].end - 1); } } - valuePtr = Tcl_ObjSetVar2(interp, varPtr, NULL, newPtr, TCL_LEAVE_ERR_MSG); + valuePtr = Tcl_ObjSetVar2(interp, varPtr, NULL, newPtr, 0); if (valuePtr == NULL) { + Tcl_AppendResult(interp, "couldn't set variable \"", + Tcl_GetString(varPtr), "\"", NULL); return TCL_ERROR; } } @@ -4642,7 +4005,7 @@ TestregexpObjCmd( * Set the interpreter's object result to an integer object w/ value 1. */ - Tcl_SetWideIntObj(Tcl_GetObjResult(interp), 1); + Tcl_SetIntObj(Tcl_GetObjResult(interp), 1); return TCL_OK; } @@ -4665,13 +4028,12 @@ TestregexpObjCmd( static void TestregexpXflags( - const char *string, /* The string of flags. */ - size_t length, /* The length of the string in bytes. */ + 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 */ { - size_t i; - int cflags, eflags; + int i, cflags, eflags; cflags = *cflagsPtr; eflags = *eflagsPtr; @@ -4754,12 +4116,13 @@ TestregexpXflags( *---------------------------------------------------------------------- */ + /* ARGSUSED */ static int TestreturnObjCmd( - TCL_UNUSED(void *), - TCL_UNUSED(Tcl_Interp *), - TCL_UNUSED(int) /*objc*/, - TCL_UNUSED(Tcl_Obj *const *) /*objv*/) + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { return TCL_RETURN; } @@ -4784,7 +4147,7 @@ TestreturnObjCmd( static int TestsetassocdataCmd( - TCL_UNUSED(void *), + ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -4794,11 +4157,11 @@ TestsetassocdataCmd( if (argc != 3) { Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], - " data_key data_item\"", (void *)NULL); + " data_key data_item\"", NULL); return TCL_ERROR; } - buf = (char *)ckalloc(strlen(argv[2]) + 1); + buf = ckalloc((unsigned) strlen(argv[2]) + 1); strcpy(buf, argv[2]); /* @@ -4811,7 +4174,8 @@ TestsetassocdataCmd( ckfree(oldData); } - Tcl_SetAssocData(interp, argv[1], CleanupTestSetassocdataTests, buf); + Tcl_SetAssocData(interp, argv[1], CleanupTestSetassocdataTests, + (ClientData) buf); return TCL_OK; } @@ -4835,7 +4199,7 @@ TestsetassocdataCmd( static int TestsetplatformCmd( - TCL_UNUSED(void *), + ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -4847,7 +4211,7 @@ TestsetplatformCmd( if (argc != 2) { Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], - " platform\"", (void *)NULL); + " platform\"", NULL); return TCL_ERROR; } @@ -4858,7 +4222,7 @@ TestsetplatformCmd( *platform = TCL_PLATFORM_WINDOWS; } else { Tcl_AppendResult(interp, "unsupported platform: should be one of " - "unix, or windows", (void *)NULL); + "unix, or windows", NULL); return TCL_ERROR; } return TCL_OK; @@ -4867,24 +4231,24 @@ TestsetplatformCmd( /* *---------------------------------------------------------------------- * - * TeststaticlibraryCmd -- + * TeststaticpkgCmd -- * - * This procedure implements the "teststaticlibrary" command. - * It is used to test the procedure Tcl_StaticLibrary. + * This procedure implements the "teststaticpkg" command. + * It is used to test the procedure Tcl_StaticPackage. * * Results: * A standard Tcl result. * * Side effects: - * When the package given by argv[1] is loaded into an interpreter, + * When the packge given by argv[1] is loaded into an interpeter, * variable "x" in that interpreter is set to "loaded". * *---------------------------------------------------------------------- */ static int -TeststaticlibraryCmd( - TCL_UNUSED(void *), +TeststaticpkgCmd( + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -4893,7 +4257,7 @@ TeststaticlibraryCmd( if (argc != 4) { Tcl_AppendResult(interp, "wrong # arguments: should be \"", - argv[0], " prefix safe loaded\"", (void *)NULL); + argv[0], " pkgName safe loaded\"", NULL); return TCL_ERROR; } if (Tcl_GetInt(interp, argv[2], &safe) != TCL_OK) { @@ -4902,8 +4266,8 @@ TeststaticlibraryCmd( if (Tcl_GetInt(interp, argv[3], &loaded) != TCL_OK) { return TCL_ERROR; } - Tcl_StaticLibrary((loaded) ? interp : NULL, argv[1], - StaticInitProc, (safe) ? StaticInitProc : NULL); + Tcl_StaticPackage((loaded) ? interp : NULL, argv[1], StaticInitProc, + (safe) ? StaticInitProc : NULL); return TCL_OK; } @@ -4912,7 +4276,7 @@ StaticInitProc( Tcl_Interp *interp) /* Interpreter in which package is supposedly * being loaded. */ { - Tcl_SetVar2(interp, "x", NULL, "loaded", TCL_GLOBAL_ONLY); + Tcl_SetVar(interp, "x", "loaded", TCL_GLOBAL_ONLY); return TCL_OK; } @@ -4935,7 +4299,7 @@ StaticInitProc( static int TesttranslatefilenameCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -4945,14 +4309,14 @@ TesttranslatefilenameCmd( if (argc != 2) { Tcl_AppendResult(interp, "wrong # arguments: should be \"", - argv[0], " path\"", (void *)NULL); + argv[0], " path\"", NULL); return TCL_ERROR; } result = Tcl_TranslateFileName(interp, argv[1], &buffer); if (result == NULL) { return TCL_ERROR; } - Tcl_AppendResult(interp, result, (void *)NULL); + Tcl_AppendResult(interp, result, NULL); Tcl_DStringFree(&buffer); return TCL_OK; } @@ -4962,7 +4326,7 @@ TesttranslatefilenameCmd( * * TestupvarCmd -- * - * This procedure implements the "testupvar" command. It is used + * This procedure implements the "testupvar2" command. It is used * to test Tcl_UpVar and Tcl_UpVar2. * * Results: @@ -4974,9 +4338,10 @@ TesttranslatefilenameCmd( *---------------------------------------------------------------------- */ + /* ARGSUSED */ static int TestupvarCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -4985,7 +4350,7 @@ TestupvarCmd( if ((argc != 5) && (argc != 6)) { Tcl_AppendResult(interp, "wrong # arguments: should be \"", - argv[0], " level name ?name2? dest global\"", (void *)NULL); + argv[0], " level name ?name2? dest global\"", NULL); return TCL_ERROR; } @@ -4995,7 +4360,7 @@ TestupvarCmd( } else if (strcmp(argv[4], "namespace") == 0) { flags = TCL_NAMESPACE_ONLY; } - return Tcl_UpVar2(interp, argv[1], argv[2], NULL, argv[3], flags); + return Tcl_UpVar(interp, argv[1], argv[2], argv[3], flags); } else { if (strcmp(argv[5], "global") == 0) { flags = TCL_GLOBAL_ONLY; @@ -5026,37 +4391,20 @@ TestupvarCmd( *---------------------------------------------------------------------- */ + /* ARGSUSED */ static int TestseterrorcodeCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { if (argc > 6) { - Tcl_AppendResult(interp, "too many args", (void *)NULL); + Tcl_SetResult(interp, "too many args", TCL_STATIC); return TCL_ERROR; } - switch (argc) { - case 1: - Tcl_SetErrorCode(interp, "NONE", (void *)NULL); - break; - case 2: - Tcl_SetErrorCode(interp, argv[1], (void *)NULL); - break; - case 3: - Tcl_SetErrorCode(interp, argv[1], argv[2], (void *)NULL); - break; - case 4: - Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], (void *)NULL); - break; - case 5: - Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], argv[4], (void *)NULL); - break; - case 6: - Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], argv[4], - argv[5], (void *)NULL); - } + Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], argv[4], + argv[5], NULL); return TCL_ERROR; } @@ -5078,9 +4426,10 @@ TestseterrorcodeCmd( *---------------------------------------------------------------------- */ + /* ARGSUSED */ static int TestsetobjerrorcodeCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ @@ -5106,9 +4455,10 @@ TestsetobjerrorcodeCmd( *---------------------------------------------------------------------- */ + /* ARGSUSED */ static int TestfeventCmd( - TCL_UNUSED(void *), + ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -5119,23 +4469,23 @@ TestfeventCmd( if (argc < 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " option ?arg ...?", (void *)NULL); + " option ?arg arg ...?", NULL); return TCL_ERROR; } if (strcmp(argv[1], "cmd") == 0) { if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " cmd script", (void *)NULL); + " cmd script", NULL); return TCL_ERROR; } if (interp2 != NULL) { - code = Tcl_EvalEx(interp2, argv[2], TCL_INDEX_NONE, TCL_EVAL_GLOBAL); + code = Tcl_GlobalEval(interp2, argv[2]); Tcl_SetObjResult(interp, Tcl_GetObjResult(interp2)); return code; } else { Tcl_AppendResult(interp, "called \"testfevent code\" before \"testfevent create\"", - (void *)NULL); + NULL); return TCL_ERROR; } } else if (strcmp(argv[1], "create") == 0) { @@ -5180,33 +4530,35 @@ TestfeventCmd( static int TestpanicCmd( - TCL_UNUSED(void *), - TCL_UNUSED(Tcl_Interp *), + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { + const char *argString; + /* * Put the arguments into a var args structure * Append all of the arguments together separated by spaces */ - char *argString = Tcl_Merge(argc-1, argv+1); + argString = Tcl_Merge(argc-1, argv+1); Tcl_Panic("%s", argString); - ckfree(argString); + ckfree((char *)argString); return TCL_OK; } - + static int TestfileCmd( - TCL_UNUSED(void *), + 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; - const char *subcmd; + char *subcmd; if (argc < 3) { return TCL_ERROR; @@ -5251,11 +4603,11 @@ TestfileCmd( if (result != TCL_OK) { if (error != NULL) { if (Tcl_GetString(error)[0] != '\0') { - Tcl_AppendResult(interp, Tcl_GetString(error), " ", (void *)NULL); + Tcl_AppendResult(interp, Tcl_GetString(error), " ", NULL); } Tcl_DecrRefCount(error); } - Tcl_AppendResult(interp, Tcl_ErrnoId(), (void *)NULL); + Tcl_AppendResult(interp, Tcl_ErrnoId(), NULL); } end: @@ -5281,16 +4633,17 @@ TestfileCmd( static int TestgetvarfullnameCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ { - const char *name, *arg; + char *name, *arg; int flags = 0; Tcl_Namespace *namespacePtr; Tcl_CallFrame *framePtr; Tcl_Var variable; + int result; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "name scope"); @@ -5318,8 +4671,11 @@ TestgetvarfullnameCmd( if (namespacePtr == NULL) { return TCL_ERROR; } - (void) TclPushStackFrame(interp, &framePtr, namespacePtr, + result = TclPushStackFrame(interp, &framePtr, namespacePtr, /*isProcCallFrame*/ 0); + if (result != TCL_OK) { + return result; + } } variable = Tcl_FindNamespaceVar(interp, name, NULL, @@ -5338,11 +4694,11 @@ TestgetvarfullnameCmd( /* *---------------------------------------------------------------------- * - * GetTimesObjCmd -- + * GetTimesCmd -- * * This procedure implements the "gettimes" command. It is used for * computing the time needed for various basic operations such as reading - * variables, allocating memory, snprintf, converting variables, etc. + * variables, allocating memory, sprintf, converting variables, etc. * * Results: * A standard Tcl result. @@ -5354,11 +4710,11 @@ TestgetvarfullnameCmd( */ static int -GetTimesObjCmd( - TCL_UNUSED(void *), +GetTimesCmd( + ClientData unused, /* Unused. */ Tcl_Interp *interp, /* The current interpreter. */ - TCL_UNUSED(int) /*cobjc*/, - TCL_UNUSED(Tcl_Obj *const *) /*cobjv*/) + int argc, /* The number of arguments. */ + const char **argv) /* The argument strings. */ { Interp *iPtr = (Interp *) interp; int i, n; @@ -5372,8 +4728,8 @@ GetTimesObjCmd( 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(objPtr); + objPtr = (Tcl_Obj *) ckalloc(sizeof(Tcl_Obj)); + ckfree((char *) objPtr); } Tcl_GetTime(&stop); timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); @@ -5381,10 +4737,10 @@ GetTimesObjCmd( /* alloc 5000 times */ fprintf(stderr, "alloc 5000 6 word items\n"); - objv = (Tcl_Obj **)ckalloc(5000 * sizeof(Tcl_Obj *)); + objv = (Tcl_Obj **) ckalloc(5000 * sizeof(Tcl_Obj *)); Tcl_GetTime(&start); for (i = 0; i < 5000; i++) { - objv[i] = (Tcl_Obj *)ckalloc(sizeof(Tcl_Obj)); + objv[i] = (Tcl_Obj *) ckalloc(sizeof(Tcl_Obj)); } Tcl_GetTime(&stop); timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); @@ -5394,7 +4750,7 @@ GetTimesObjCmd( fprintf(stderr, "free 5000 6 word items\n"); Tcl_GetTime(&start); for (i = 0; i < 5000; i++) { - ckfree(objv[i]); + ckfree((char *) objv[i]); } Tcl_GetTime(&stop); timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); @@ -5420,10 +4776,10 @@ GetTimesObjCmd( Tcl_GetTime(&stop); timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); fprintf(stderr, " %.3f usec per Tcl_DecrRefCount\n", timePer/5000); - ckfree(objv); + ckfree((char *) objv); /* TclGetString 100000 times */ - fprintf(stderr, "Tcl_GetStringFromObj of \"12345\" 100000 times\n"); + fprintf(stderr, "TclGetStringFromObj of \"12345\" 100000 times\n"); objPtr = Tcl_NewStringObj("12345", -1); Tcl_GetTime(&start); for (i = 0; i < 100000; i++) { @@ -5431,7 +4787,7 @@ GetTimesObjCmd( } Tcl_GetTime(&stop); timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); - fprintf(stderr, " %.3f usec per Tcl_GetStringFromObj of \"12345\"\n", + fprintf(stderr, " %.3f usec per TclGetStringFromObj of \"12345\"\n", timePer/100000); /* Tcl_GetIntFromObj 100000 times */ @@ -5461,15 +4817,15 @@ GetTimesObjCmd( fprintf(stderr, " %.3f usec per Tcl_GetInt of \"12345\"\n", timePer/100000); - /* snprintf 100000 times */ - fprintf(stderr, "snprintf of 12345 100000 times\n"); + /* sprintf 100000 times */ + fprintf(stderr, "sprintf of 12345 100000 times\n"); Tcl_GetTime(&start); for (i = 0; i < 100000; i++) { - snprintf(newString, sizeof(newString), "%d", 12345); + sprintf(newString, "%d", 12345); } Tcl_GetTime(&stop); timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); - fprintf(stderr, " %.3f usec per snprintf of 12345\n", + fprintf(stderr, " %.3f usec per sprintf of 12345\n", timePer/100000); /* hashtable lookup 100000 times */ @@ -5484,10 +4840,10 @@ GetTimesObjCmd( timePer/100000); /* Tcl_SetVar 100000 times */ - fprintf(stderr, "Tcl_SetVar2 of \"12345\" 100000 times\n"); + fprintf(stderr, "Tcl_SetVar of \"12345\" 100000 times\n"); Tcl_GetTime(&start); for (i = 0; i < 100000; i++) { - s = Tcl_SetVar2(interp, "a", NULL, "12345", TCL_LEAVE_ERR_MSG); + s = Tcl_SetVar(interp, "a", "12345", TCL_LEAVE_ERR_MSG); if (s == NULL) { return TCL_ERROR; } @@ -5501,7 +4857,7 @@ GetTimesObjCmd( fprintf(stderr, "Tcl_GetVar of a==\"12345\" 100000 times\n"); Tcl_GetTime(&start); for (i = 0; i < 100000; i++) { - s = Tcl_GetVar2(interp, "a", NULL, TCL_LEAVE_ERR_MSG); + s = Tcl_GetVar(interp, "a", TCL_LEAVE_ERR_MSG); if (s == NULL) { return TCL_ERROR; } @@ -5534,10 +4890,10 @@ GetTimesObjCmd( static int NoopCmd( - TCL_UNUSED(void *), - TCL_UNUSED(Tcl_Interp *), - TCL_UNUSED(int) /*argc*/, - TCL_UNUSED(const char **) /*argv*/) + ClientData unused, /* Unused. */ + Tcl_Interp *interp, /* The current interpreter. */ + int argc, /* The number of arguments. */ + const char **argv) /* The argument strings. */ { return TCL_OK; } @@ -5561,229 +4917,11 @@ NoopCmd( static int NoopObjCmd( - TCL_UNUSED(void *), - TCL_UNUSED(Tcl_Interp *), - TCL_UNUSED(int) /*objc*/, - TCL_UNUSED(Tcl_Obj *const *) /*objv*/) -{ - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TeststringbytesObjCmd -- - * Returns bytearray value of the bytes in argument string rep - * - * Results: - * Returns the TCL_OK result code. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -TeststringbytesObjCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* The argument objects. */ -{ - Tcl_Size n; - const unsigned char *p; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "value"); - return TCL_ERROR; - } - p = (const unsigned char *)Tcl_GetStringFromObj(objv[1], &n); - Tcl_SetObjResult(interp, Tcl_NewByteArrayObj(p, n)); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TestpurebytesobjObjCmd -- - * - * This object-based procedure constructs a pure bytes object - * without type and with internal representation containing NULL's. - * - * If no argument supplied it returns empty object with tclEmptyStringRep, - * otherwise it returns this as pure bytes object with bytes value equal - * string. - * - * Results: - * Returns the TCL_OK result code. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -TestpurebytesobjObjCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* The argument objects. */ -{ - Tcl_Obj *objPtr; - - if (objc > 2) { - Tcl_WrongNumArgs(interp, 1, objv, "?string?"); - return TCL_ERROR; - } - objPtr = Tcl_NewObj(); - /* - objPtr->internalRep.twoPtrValue.ptr1 = NULL; - objPtr->internalRep.twoPtrValue.ptr2 = NULL; - */ - memset(&objPtr->internalRep, 0, sizeof(objPtr->internalRep)); - if (objc == 2) { - const char *s = Tcl_GetString(objv[1]); - objPtr->length = objv[1]->length; - objPtr->bytes = (char *)ckalloc(objPtr->length + 1); - memcpy(objPtr->bytes, s, objPtr->length); - objPtr->bytes[objPtr->length] = 0; - } - Tcl_SetObjResult(interp, objPtr); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TestsetbytearraylengthObjCmd -- - * - * Testing command 'testsetbytearraylength` used to test the public - * interface routine Tcl_SetByteArrayLength(). - * - * Results: - * Returns the TCL_OK result code. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -TestsetbytearraylengthObjCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* The argument objects. */ -{ - int n; - Tcl_Obj *obj = NULL; - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "value length"); - return TCL_ERROR; - } - if (TCL_OK != Tcl_GetIntFromObj(interp, objv[2], &n)) { - return TCL_ERROR; - } - obj = objv[1]; - if (Tcl_IsShared(obj)) { - obj = Tcl_DuplicateObj(obj); - } - if (Tcl_SetByteArrayLength(obj, n) == NULL) { - if (obj != objv[1]) { - Tcl_DecrRefCount(obj); - } - Tcl_AppendResult(interp, "expected bytes", (void *)NULL); - return TCL_ERROR; - } - Tcl_SetObjResult(interp, obj); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TestbytestringObjCmd -- - * - * This object-based procedure constructs a string which can - * possibly contain invalid UTF-8 bytes. - * - * Results: - * Returns the TCL_OK result code. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -TestbytestringObjCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* The argument objects. */ -{ - struct { - Tcl_Size n; - int m; /* This variable should not be overwritten */ - } x = {0, 1}; - const char *p; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "bytearray"); - return TCL_ERROR; - } - - p = (const char *)Tcl_GetBytesFromObj(interp, objv[1], &x.n); - if (p == NULL) { - return TCL_ERROR; - } - if (x.m != 1) { - Tcl_AppendResult(interp, "Tcl_GetBytesFromObj() overwrites variable", (void *)NULL); - return TCL_ERROR; - } - Tcl_SetObjResult(interp, Tcl_NewStringObj(p, x.n)); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Testutf16stringObjCmd -- - * - * This specifically tests the Tcl_GetUnicode and Tcl_NewUnicodeObj - * C functions which broke in Tcl 8.7 and were undetected by the - * existing test suite. Bug [b79df322a9] - * - * Results: - * Returns the TCL_OK result code. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -Testutf16stringObjCmd( - TCL_UNUSED(void *), + ClientData unused, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ { - const unsigned short *p; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "string"); - return TCL_ERROR; - } - - p = Tcl_GetUnicode(objv[1]); - Tcl_SetObjResult(interp, Tcl_NewUnicodeObj(p, TCL_INDEX_NONE)); return TCL_OK; } @@ -5804,10 +4942,11 @@ Testutf16stringObjCmd( *---------------------------------------------------------------------- */ + /* ARGSUSED */ static int TestsetCmd( - void *data, /* Additional flags for Get/SetVar2. */ - Tcl_Interp *interp,/* Current interpreter. */ + ClientData data, /* Additional flags for Get/SetVar2. */ + register Tcl_Interp *interp,/* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { @@ -5815,7 +4954,7 @@ TestsetCmd( const char *value; if (argc == 2) { - Tcl_AppendResult(interp, "before get", (void *)NULL); + Tcl_SetResult(interp, "before get", TCL_STATIC); value = Tcl_GetVar2(interp, argv[1], NULL, flags); if (value == NULL) { return TCL_ERROR; @@ -5823,7 +4962,7 @@ TestsetCmd( Tcl_AppendElement(interp, value); return TCL_OK; } else if (argc == 3) { - Tcl_AppendResult(interp, "before set", (void *)NULL); + Tcl_SetResult(interp, "before set", TCL_STATIC); value = Tcl_SetVar2(interp, argv[1], NULL, argv[2], flags); if (value == NULL) { return TCL_ERROR; @@ -5832,14 +4971,14 @@ TestsetCmd( return TCL_OK; } else { Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " varName ?newValue?\"", (void *)NULL); + argv[0], " varName ?newValue?\"", NULL); return TCL_ERROR; } } static int Testset2Cmd( - void *data, /* Additional flags for Get/SetVar2. */ - Tcl_Interp *interp,/* Current interpreter. */ + ClientData data, /* Additional flags for Get/SetVar2. */ + register Tcl_Interp *interp,/* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { @@ -5847,7 +4986,7 @@ Testset2Cmd( const char *value; if (argc == 3) { - Tcl_AppendResult(interp, "before get", (void *)NULL); + Tcl_SetResult(interp, "before get", TCL_STATIC); value = Tcl_GetVar2(interp, argv[1], argv[2], flags); if (value == NULL) { return TCL_ERROR; @@ -5855,7 +4994,7 @@ Testset2Cmd( Tcl_AppendElement(interp, value); return TCL_OK; } else if (argc == 4) { - Tcl_AppendResult(interp, "before set", (void *)NULL); + Tcl_SetResult(interp, "before set", TCL_STATIC); value = Tcl_SetVar2(interp, argv[1], argv[2], argv[3], flags); if (value == NULL) { return TCL_ERROR; @@ -5864,7 +5003,7 @@ Testset2Cmd( return TCL_OK; } else { Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " varName elemName ?newValue?\"", (void *)NULL); + argv[0], " varName elemName ?newValue?\"", NULL); return TCL_ERROR; } } @@ -5886,19 +5025,18 @@ Testset2Cmd( *---------------------------------------------------------------------- */ -#ifndef TCL_NO_DEPRECATED + /* ARGSUSED */ static int TestsaveresultCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp,/* Current interpreter. */ + 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 *const optionStrings[] = { + static const char *optionStrings[] = { "append", "dynamic", "free", "object", "small", NULL }; enum options { @@ -5921,37 +5059,37 @@ TestsaveresultCmd( return TCL_ERROR; } - freeCount = 0; - objPtr = NULL; + objPtr = NULL; /* Lint. */ switch ((enum options) index) { case RESULT_SMALL: - Tcl_AppendResult(interp, "small result", (void *)NULL); + Tcl_SetResult(interp, "small result", TCL_VOLATILE); break; case RESULT_APPEND: - Tcl_AppendResult(interp, "append result", (void *)NULL); + Tcl_AppendResult(interp, "append result", NULL); break; case RESULT_FREE: { - char *buf = (char *)ckalloc(200); + 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); + Tcl_SetResult(interp, "dynamic result", TestsaveresultFree); break; case RESULT_OBJECT: - objPtr = Tcl_NewStringObj("object result", TCL_INDEX_NONE); + objPtr = Tcl_NewStringObj("object result", -1); Tcl_SetObjResult(interp, objPtr); break; } + freeCount = 0; Tcl_SaveResult(interp, &state); if (((enum options) index) == RESULT_OBJECT) { result = Tcl_EvalObjEx(interp, objv[2], 0); } else { - result = Tcl_EvalEx(interp, Tcl_GetString(objv[2]), TCL_INDEX_NONE, 0); + result = Tcl_Eval(interp, Tcl_GetString(objv[2])); } if (discard) { @@ -5963,9 +5101,11 @@ TestsaveresultCmd( switch ((enum options) index) { case RESULT_DYNAMIC: { - int presentOrFreed = (iPtr->freeProc == TestsaveresultFree) ^ freeCount; + int present = interp->freeProc == TestsaveresultFree; + int called = freeCount; - Tcl_AppendElement(interp, presentOrFreed ? "presentOrFreed" : "missingOrLeak"); + Tcl_AppendElement(interp, called ? "called" : "notCalled"); + Tcl_AppendElement(interp, present ? "present" : "missing"); break; } case RESULT_OBJECT: @@ -5996,15 +5136,205 @@ TestsaveresultCmd( static void TestsaveresultFree( -#if TCL_MAJOR_VERSION > 8 - TCL_UNUSED(void *)) + char *blockPtr) +{ + freeCount++; +} +#ifdef USE_OBSOLETE_FS_HOOKS + +/* + *---------------------------------------------------------------------- + * + * TeststatprocCmd -- + * + * Implements the "testTclStatProc" cmd that is used to test the + * 'TclStatInsertProc' & 'TclStatDeleteProc' C Apis. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TeststatprocCmd( + ClientData dummy, /* Not used. */ + register Tcl_Interp *interp,/* Current interpreter. */ + int argc, /* Number of arguments. */ + const char **argv) /* Argument strings. */ +{ + TclStatProc_ *proc; + int retVal; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " option arg\"", NULL); + return TCL_ERROR; + } + + if (strcmp(argv[2], "TclpStat") == 0) { + proc = PretendTclpStat; + } else if (strcmp(argv[2], "TestStatProc1") == 0) { + proc = TestStatProc1; + } else if (strcmp(argv[2], "TestStatProc2") == 0) { + proc = TestStatProc2; + } else if (strcmp(argv[2], "TestStatProc3") == 0) { + proc = TestStatProc3; + } else { + Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": " + "must be TclpStat, " + "TestStatProc1, TestStatProc2, or TestStatProc3", NULL); + return TCL_ERROR; + } + + if (strcmp(argv[1], "insert") == 0) { + if (proc == PretendTclpStat) { + Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": " + "must be " + "TestStatProc1, TestStatProc2, or TestStatProc3", NULL); + return TCL_ERROR; + } + retVal = TclStatInsertProc(proc); + } else if (strcmp(argv[1], "delete") == 0) { + retVal = TclStatDeleteProc(proc); + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], "\": " + "must be insert or delete", NULL); + return TCL_ERROR; + } + + if (retVal == TCL_ERROR) { + Tcl_AppendResult(interp, "\"", argv[2], "\": " + "could not be ", argv[1], "ed", NULL); + } + + return retVal; +} + +static int +PretendTclpStat( + const char *path, + struct stat *buf) +{ + int ret; + Tcl_Obj *pathPtr = Tcl_NewStringObj(path, -1); +#ifdef TCL_WIDE_INT_IS_LONG + Tcl_IncrRefCount(pathPtr); + ret = TclpObjStat(pathPtr, buf); + Tcl_DecrRefCount(pathPtr); + return ret; +#else /* TCL_WIDE_INT_IS_LONG */ + Tcl_StatBuf realBuf; + Tcl_IncrRefCount(pathPtr); + ret = TclpObjStat(pathPtr, &realBuf); + Tcl_DecrRefCount(pathPtr); + if (ret != -1) { +# define OUT_OF_RANGE(x) \ + (((Tcl_WideInt)(x)) < Tcl_LongAsWide(LONG_MIN) || \ + ((Tcl_WideInt)(x)) > Tcl_LongAsWide(LONG_MAX)) +#if defined(__GNUC__) && __GNUC__ >= 2 +/* + * Workaround gcc warning of "comparison is always false due to limited range of + * data type" in this macro by checking max type size, and when necessary ANDing + * with the complement of ULONG_MAX instead of the comparison: + */ +# define OUT_OF_URANGE(x) \ + ((((Tcl_WideUInt)(~ (__typeof__(x)) 0)) > (Tcl_WideUInt)ULONG_MAX) && \ + (((Tcl_WideUInt)(x)) & ~(Tcl_WideUInt)ULONG_MAX)) #else - TCL_UNUSED(char *)) +# 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_STRUCT_STAT_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_STRUCT_STAT_ST_BLKSIZE + buf->st_blksize = realBuf.st_blksize; +# endif +# ifdef HAVE_STRUCT_STAT_ST_BLOCKS + buf->st_blocks = (blkcnt_t) realBuf.st_blocks; +# endif + } + return ret; +#endif /* TCL_WIDE_INT_IS_LONG */ +} + +static int +TestStatProc1( + const char *path, + struct stat *buf) { - freeCount++; + memset(buf, 0, sizeof(struct stat)); + buf->st_size = 1234; + return ((strstr(path, "testStat1%.fil") == NULL) ? -1 : 0); +} + +static int +TestStatProc2( + const char *path, + struct stat *buf) +{ + memset(buf, 0, sizeof(struct stat)); + buf->st_size = 2345; + return ((strstr(path, "testStat2%.fil") == NULL) ? -1 : 0); +} + +static int +TestStatProc3( + const char *path, + struct stat *buf) +{ + memset(buf, 0, sizeof(struct stat)); + buf->st_size = 3456; + return ((strstr(path, "testStat3%.fil") == NULL) ? -1 : 0); } -#endif /* TCL_NO_DEPRECATED */ +#endif /* *---------------------------------------------------------------------- @@ -6025,20 +5355,19 @@ TestsaveresultFree( static int TestmainthreadCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp,/* Current interpreter. */ + ClientData dummy, /* Not used. */ + register Tcl_Interp *interp,/* Current interpreter. */ int argc, /* Number of arguments. */ - TCL_UNUSED(const char **) /*argv*/) + const char **argv) /* Argument strings. */ { - if (argc == 1) { - Tcl_Obj *idObj = Tcl_NewWideIntObj((Tcl_WideInt)(size_t)Tcl_GetCurrentThread()); - - Tcl_SetObjResult(interp, idObj); - return TCL_OK; - } else { - Tcl_AppendResult(interp, "wrong # args", (void *)NULL); - return TCL_ERROR; - } + if (argc == 1) { + Tcl_Obj *idObj = Tcl_NewLongObj((long)(size_t)Tcl_GetCurrentThread()); + Tcl_SetObjResult(interp, idObj); + return TCL_OK; + } else { + Tcl_SetResult(interp, "wrong # args", TCL_STATIC); + return TCL_ERROR; + } } /* @@ -6049,7 +5378,7 @@ TestmainthreadCmd( * A main loop set by TestsetmainloopCmd below. * * Results: - * None. + * None. * * Side effects: * Event handlers could do anything. @@ -6086,14 +5415,14 @@ MainLoop(void) static int TestsetmainloopCmd( - TCL_UNUSED(void *), - TCL_UNUSED(Tcl_Interp *), - TCL_UNUSED(int) /*argc*/, - TCL_UNUSED(const char **) /*argv*/) + 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); - return TCL_OK; + exitMainLoop = 0; + Tcl_SetMainLoop(MainLoop); + return TCL_OK; } /* @@ -6115,14 +5444,317 @@ TestsetmainloopCmd( static int TestexitmainloopCmd( - TCL_UNUSED(void *), - TCL_UNUSED(Tcl_Interp *), - TCL_UNUSED(int) /*argc*/, - TCL_UNUSED(const char **) /*argv*/) + 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; + exitMainLoop = 1; + return TCL_OK; +} +#ifdef USE_OBSOLETE_FS_HOOKS + +/* + *---------------------------------------------------------------------- + * + * TestaccessprocCmd -- + * + * Implements the "testTclAccessProc" cmd that is used to test the + * 'TclAccessInsertProc' & 'TclAccessDeleteProc' C Apis. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestaccessprocCmd( + ClientData dummy, /* Not used. */ + register Tcl_Interp *interp,/* Current interpreter. */ + int argc, /* Number of arguments. */ + const char **argv) /* Argument strings. */ +{ + TclAccessProc_ *proc; + int retVal; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " option arg\"", NULL); + return TCL_ERROR; + } + + if (strcmp(argv[2], "TclpAccess") == 0) { + proc = PretendTclpAccess; + } else if (strcmp(argv[2], "TestAccessProc1") == 0) { + proc = TestAccessProc1; + } else if (strcmp(argv[2], "TestAccessProc2") == 0) { + proc = TestAccessProc2; + } else if (strcmp(argv[2], "TestAccessProc3") == 0) { + proc = TestAccessProc3; + } else { + Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": " + "must be TclpAccess, " + "TestAccessProc1, TestAccessProc2, or TestAccessProc3", NULL); + return TCL_ERROR; + } + + if (strcmp(argv[1], "insert") == 0) { + if (proc == PretendTclpAccess) { + Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": must be " + "TestAccessProc1, TestAccessProc2, or TestAccessProc3" + NULL); + return TCL_ERROR; + } + retVal = TclAccessInsertProc(proc); + } else if (strcmp(argv[1], "delete") == 0) { + retVal = TclAccessDeleteProc(proc); + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], "\": " + "must be insert or delete", NULL); + return TCL_ERROR; + } + + if (retVal == TCL_ERROR) { + Tcl_AppendResult(interp, "\"", argv[2], "\": " + "could not be ", argv[1], "ed", NULL); + } + + return retVal; +} + +static int +PretendTclpAccess( + const char *path, + int mode) +{ + int ret; + Tcl_Obj *pathPtr = Tcl_NewStringObj(path, -1); + Tcl_IncrRefCount(pathPtr); + ret = TclpObjAccess(pathPtr, mode); + Tcl_DecrRefCount(pathPtr); + return ret; +} + +static int +TestAccessProc1( + const char *path, + int mode) +{ + return ((strstr(path, "testAccess1%.fil") == NULL) ? -1 : 0); +} + +static int +TestAccessProc2( + const char *path, + int mode) +{ + return ((strstr(path, "testAccess2%.fil") == NULL) ? -1 : 0); +} + +static int +TestAccessProc3( + const char *path, + int mode) +{ + return ((strstr(path, "testAccess3%.fil") == NULL) ? -1 : 0); +} + +/* + *---------------------------------------------------------------------- + * + * TestopenfilechannelprocCmd -- + * + * Implements the "testTclOpenFileChannelProc" cmd that is used to test + * the 'TclOpenFileChannelInsertProc' & 'TclOpenFileChannelDeleteProc' C + * Apis. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestopenfilechannelprocCmd( + ClientData dummy, /* Not used. */ + register Tcl_Interp *interp,/* Current interpreter. */ + int argc, /* Number of arguments. */ + const char **argv) /* Argument strings. */ +{ + TclOpenFileChannelProc_ *proc; + int retVal; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " option arg\"", NULL); + return TCL_ERROR; + } + + if (strcmp(argv[2], "TclpOpenFileChannel") == 0) { + proc = PretendTclpOpenFileChannel; + } else if (strcmp(argv[2], "TestOpenFileChannelProc1") == 0) { + proc = TestOpenFileChannelProc1; + } else if (strcmp(argv[2], "TestOpenFileChannelProc2") == 0) { + proc = TestOpenFileChannelProc2; + } else if (strcmp(argv[2], "TestOpenFileChannelProc3") == 0) { + proc = TestOpenFileChannelProc3; + } else { + Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": " + "must be TclpOpenFileChannel, " + "TestOpenFileChannelProc1, TestOpenFileChannelProc2, or " + "TestOpenFileChannelProc3", NULL); + return TCL_ERROR; + } + + if (strcmp(argv[1], "insert") == 0) { + if (proc == PretendTclpOpenFileChannel) { + Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": " + "must be " + "TestOpenFileChannelProc1, TestOpenFileChannelProc2, or " + "TestOpenFileChannelProc3", NULL); + return TCL_ERROR; + } + retVal = TclOpenFileChannelInsertProc(proc); + } else if (strcmp(argv[1], "delete") == 0) { + retVal = TclOpenFileChannelDeleteProc(proc); + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], "\": " + "must be insert or delete", NULL); + return TCL_ERROR; + } + + if (retVal == TCL_ERROR) { + Tcl_AppendResult(interp, "\"", argv[2], "\": " + "could not be ", argv[1], "ed", NULL); + } + + return retVal; +} + +static Tcl_Channel +PretendTclpOpenFileChannel( + Tcl_Interp *interp, /* Interpreter for error reporting; can be + * NULL. */ + const char *fileName, /* Name of file to open. */ + const char *modeString, /* A list of POSIX open modes or + * a string such as "rw". */ + int permissions) /* If the open involves creating a file, with + * what modes to create it? */ +{ + Tcl_Channel ret; + int mode, seekFlag; + Tcl_Obj *pathPtr; + mode = TclGetOpenMode(interp, modeString, &seekFlag); + if (mode == -1) { + return NULL; + } + pathPtr = Tcl_NewStringObj(fileName, -1); + Tcl_IncrRefCount(pathPtr); + ret = TclpOpenFileChannel(interp, pathPtr, mode, permissions); + Tcl_DecrRefCount(pathPtr); + if (ret != NULL) { + if (seekFlag) { + if (Tcl_Seek(ret, (Tcl_WideInt)0, SEEK_END) < (Tcl_WideInt)0) { + if (interp != NULL) { + Tcl_AppendResult(interp, + "could not seek to end of file while opening \"", + fileName, "\": ", Tcl_PosixError(interp), NULL); + } + Tcl_Close(NULL, ret); + return NULL; + } + } + } + return ret; +} + +static Tcl_Channel +TestOpenFileChannelProc1( + Tcl_Interp *interp, /* Interpreter for error reporting; can be + * NULL. */ + const char *fileName, /* Name of file to open. */ + const char *modeString, /* A list of POSIX open modes or + * a string such as "rw". */ + int permissions) /* If the open involves creating a file, with + * what modes to create it? */ +{ + const char *expectname = "testOpenFileChannel1%.fil"; + Tcl_DString ds; + + Tcl_DStringInit(&ds); + Tcl_JoinPath(1, &expectname, &ds); + + if (!strcmp(Tcl_DStringValue(&ds), fileName)) { + Tcl_DStringFree(&ds); + return (PretendTclpOpenFileChannel(interp, + "__testOpenFileChannel1%__.fil", + modeString, permissions)); + } else { + Tcl_DStringFree(&ds); + return NULL; + } } + +static Tcl_Channel +TestOpenFileChannelProc2( + Tcl_Interp *interp, /* Interpreter for error reporting; can be + * NULL. */ + const char *fileName, /* Name of file to open. */ + const char *modeString, /* A list of POSIX open modes or + * a string such as "rw". */ + int permissions) /* If the open involves creating a file, with + * what modes to create it? */ +{ + const char *expectname = "testOpenFileChannel2%.fil"; + Tcl_DString ds; + + Tcl_DStringInit(&ds); + Tcl_JoinPath(1, &expectname, &ds); + + if (!strcmp(Tcl_DStringValue(&ds), fileName)) { + Tcl_DStringFree(&ds); + return (PretendTclpOpenFileChannel(interp, + "__testOpenFileChannel2%__.fil", + modeString, permissions)); + } else { + Tcl_DStringFree(&ds); + return (NULL); + } +} + +static Tcl_Channel +TestOpenFileChannelProc3( + Tcl_Interp *interp, /* Interpreter for error reporting; can be + * NULL. */ + const char *fileName, /* Name of file to open. */ + const char *modeString, /* A list of POSIX open modes or a string such + * as "rw". */ + int permissions) /* If the open involves creating a file, with + * what modes to create it? */ +{ + const char *expectname = "testOpenFileChannel3%.fil"; + Tcl_DString ds; + + Tcl_DStringInit(&ds); + Tcl_JoinPath(1, &expectname, &ds); + + if (!strcmp(Tcl_DStringValue(&ds), fileName)) { + Tcl_DStringFree(&ds); + return (PretendTclpOpenFileChannel(interp, "__testOpenFileChannel3%__.fil", + modeString, permissions)); + } else { + Tcl_DStringFree(&ds); + return (NULL); + } +} +#endif /* *---------------------------------------------------------------------- @@ -6141,9 +5773,10 @@ TestexitmainloopCmd( *---------------------------------------------------------------------- */ + /* ARGSUSED */ static int TestChannelCmd( - TCL_UNUSED(void *), + ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Interpreter for result. */ int argc, /* Count of additional args. */ const char **argv) /* Additional arg strings. */ @@ -6157,12 +5790,12 @@ TestChannelCmd( Tcl_Channel chan; /* The opaque type. */ size_t len; /* Length of subcommand string. */ int IOQueued; /* How much IO is queued inside channel? */ - char buf[TCL_INTEGER_SPACE];/* For snprintf. */ + char buf[TCL_INTEGER_SPACE];/* For sprintf. */ int mode; /* rw mode of the channel */ if (argc < 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " subcommand ?additional args..?\"", (void *)NULL); + " subcommand ?additional args..?\"", NULL); return TCL_ERROR; } cmdName = argv[1]; @@ -6187,7 +5820,7 @@ TestChannelCmd( *nextPtrPtr = curPtr->nextPtr; curPtr->nextPtr = NULL; chan = curPtr->chan; - ckfree(curPtr); + ckfree((char *) curPtr); break; } } @@ -6202,13 +5835,14 @@ TestChannelCmd( chanPtr = statePtr->topChanPtr; chan = (Tcl_Channel) chanPtr; } else { + /* lint */ statePtr = NULL; chan = NULL; } 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); @@ -6221,7 +5855,7 @@ TestChannelCmd( } 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); @@ -6245,7 +5879,7 @@ TestChannelCmd( if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " cut channelName\"", (void *)NULL); + " cut channelName\"", NULL); return TCL_ERROR; } @@ -6256,7 +5890,7 @@ TestChannelCmd( /* Remember the channel in the pool of detached channels */ - det = (TestChannel *)ckalloc(sizeof(TestChannel)); + det = (TestChannel *) ckalloc(sizeof(TestChannel)); det->chan = chan; det->nextPtr = firstDetached; firstDetached = det; @@ -6268,7 +5902,7 @@ TestChannelCmd( (strncmp(cmdName, "clearchannelhandlers", len) == 0)) { if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " clearchannelhandlers channelName\"", (void *)NULL); + " clearchannelhandlers channelName\"", NULL); return TCL_ERROR; } Tcl_ClearChannelHandlers(chan); @@ -6278,7 +5912,7 @@ TestChannelCmd( if ((cmdName[0] == 'i') && (strncmp(cmdName, "info", len) == 0)) { if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " info channelName\"", (void *)NULL); + " info channelName\"", NULL); return TCL_ERROR; } Tcl_AppendElement(interp, argv[2]); @@ -6370,40 +6004,40 @@ TestChannelCmd( if ((cmdName[0] == 'i') && (strncmp(cmdName, "inputbuffered", len) == 0)) { if (argc != 3) { - Tcl_AppendResult(interp, "channel name required", (void *)NULL); + Tcl_AppendResult(interp, "channel name required", NULL); return TCL_ERROR; } IOQueued = Tcl_InputBuffered(chan); TclFormatInt(buf, IOQueued); - Tcl_AppendResult(interp, buf, (void *)NULL); + 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", (void *)NULL); + Tcl_AppendResult(interp, "channel name required", NULL); return TCL_ERROR; } TclFormatInt(buf, Tcl_IsChannelShared(chan)); - Tcl_AppendResult(interp, buf, (void *)NULL); + Tcl_AppendResult(interp, buf, NULL); return TCL_OK; } if ((cmdName[0] == 'i') && (strncmp(cmdName, "isstandard", len) == 0)) { if (argc != 3) { - Tcl_AppendResult(interp, "channel name required", (void *)NULL); + Tcl_AppendResult(interp, "channel name required", NULL); return TCL_ERROR; } TclFormatInt(buf, Tcl_IsStandardChannel(chan)); - Tcl_AppendResult(interp, buf, (void *)NULL); + Tcl_AppendResult(interp, buf, NULL); return TCL_OK; } if ((cmdName[0] == 'm') && (strncmp(cmdName, "mode", len) == 0)) { if (argc != 3) { - Tcl_AppendResult(interp, "channel name required", (void *)NULL); + Tcl_AppendResult(interp, "channel name required", NULL); return TCL_ERROR; } @@ -6420,60 +6054,23 @@ TestChannelCmd( return TCL_OK; } - if ((cmdName[0] == 'm') && (strncmp(cmdName, "maxmode", len) == 0)) { - if (argc != 3) { - Tcl_AppendResult(interp, "channel name required", (void *)NULL); - return TCL_ERROR; - } - - if (statePtr->maxPerms & TCL_READABLE) { - Tcl_AppendElement(interp, "read"); - } else { - Tcl_AppendElement(interp, ""); - } - if (statePtr->maxPerms & TCL_WRITABLE) { - Tcl_AppendElement(interp, "write"); - } else { - Tcl_AppendElement(interp, ""); - } - return TCL_OK; - } - - if ((cmdName[0] == 'm') && (strncmp(cmdName, "mremove-rd", len) == 0)) { - if (argc != 3) { - Tcl_AppendResult(interp, "channel name required", (void *)NULL); - return TCL_ERROR; - } - - return Tcl_RemoveChannelMode(interp, chan, TCL_READABLE); - } - - if ((cmdName[0] == 'm') && (strncmp(cmdName, "mremove-wr", len) == 0)) { - if (argc != 3) { - Tcl_AppendResult(interp, "channel name required", (void *)NULL); - return TCL_ERROR; - } - - return Tcl_RemoveChannelMode(interp, chan, TCL_WRITABLE); - } - if ((cmdName[0] == 'm') && (strncmp(cmdName, "mthread", len) == 0)) { if (argc != 3) { - Tcl_AppendResult(interp, "channel name required", (void *)NULL); + Tcl_AppendResult(interp, "channel name required", NULL); return TCL_ERROR; } - Tcl_SetObjResult(interp, Tcl_NewWideIntObj( - (Tcl_WideInt) (size_t) Tcl_GetChannelThread(chan))); + TclFormatInt(buf, (long)(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", (void *)NULL); + Tcl_AppendResult(interp, "channel name required", NULL); return TCL_ERROR; } - Tcl_AppendResult(interp, statePtr->channelName, (void *)NULL); + Tcl_AppendResult(interp, statePtr->channelName, NULL); return TCL_OK; } @@ -6485,7 +6082,7 @@ TestChannelCmd( for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) { - Tcl_AppendElement(interp, (char *)Tcl_GetHashKey(hTblPtr, hPtr)); + Tcl_AppendElement(interp, Tcl_GetHashKey(hTblPtr, hPtr)); } return TCL_OK; } @@ -6493,25 +6090,25 @@ TestChannelCmd( if ((cmdName[0] == 'o') && (strncmp(cmdName, "outputbuffered", len) == 0)) { if (argc != 3) { - Tcl_AppendResult(interp, "channel name required", (void *)NULL); + Tcl_AppendResult(interp, "channel name required", NULL); return TCL_ERROR; } IOQueued = Tcl_OutputBuffered(chan); TclFormatInt(buf, IOQueued); - Tcl_AppendResult(interp, buf, (void *)NULL); + 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", (void *)NULL); + Tcl_AppendResult(interp, "channel name required", NULL); return TCL_ERROR; } Tcl_AppendResult(interp, - (statePtr->flags & INPUT_SAW_CR) ? "1" : "0", (void *)NULL); + (statePtr->flags & INPUT_SAW_CR) ? "1" : "0", NULL); return TCL_OK; } @@ -6526,7 +6123,7 @@ TestChannelCmd( chanPtr = (Channel *) Tcl_GetHashValue(hPtr); statePtr = chanPtr->state; if (statePtr->flags & TCL_READABLE) { - Tcl_AppendElement(interp, (char *)Tcl_GetHashKey(hTblPtr, hPtr)); + Tcl_AppendElement(interp, Tcl_GetHashKey(hTblPtr, hPtr)); } } return TCL_OK; @@ -6534,12 +6131,12 @@ TestChannelCmd( if ((cmdName[0] == 'r') && (strncmp(cmdName, "refcount", len) == 0)) { if (argc != 3) { - Tcl_AppendResult(interp, "channel name required", (void *)NULL); + Tcl_AppendResult(interp, "channel name required", NULL); return TCL_ERROR; } TclFormatInt(buf, statePtr->refCount); - Tcl_AppendResult(interp, buf, (void *)NULL); + Tcl_AppendResult(interp, buf, NULL); return TCL_OK; } @@ -6552,7 +6149,7 @@ TestChannelCmd( if ((cmdName[0] == 's') && (strncmp(cmdName, "splice", len) == 0)) { if (argc != 3) { - Tcl_AppendResult(interp, "channel name required", (void *)NULL); + Tcl_AppendResult(interp, "channel name required", NULL); return TCL_ERROR; } @@ -6566,10 +6163,10 @@ TestChannelCmd( if ((cmdName[0] == 't') && (strncmp(cmdName, "type", len) == 0)) { if (argc != 3) { - Tcl_AppendResult(interp, "channel name required", (void *)NULL); + Tcl_AppendResult(interp, "channel name required", NULL); return TCL_ERROR; } - Tcl_AppendResult(interp, Tcl_ChannelName(chanPtr->typePtr), (void *)NULL); + Tcl_AppendResult(interp, Tcl_ChannelName(chanPtr->typePtr), NULL); return TCL_OK; } @@ -6583,7 +6180,7 @@ TestChannelCmd( chanPtr = (Channel *) Tcl_GetHashValue(hPtr); statePtr = chanPtr->state; if (statePtr->flags & TCL_WRITABLE) { - Tcl_AppendElement(interp, (char *)Tcl_GetHashKey(hTblPtr, hPtr)); + Tcl_AppendElement(interp, Tcl_GetHashKey(hTblPtr, hPtr)); } } return TCL_OK; @@ -6596,12 +6193,12 @@ TestChannelCmd( if (argc != 5) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " transform channelId -command cmd\"", (void *)NULL); + " transform channelId -command cmd\"", NULL); return TCL_ERROR; } if (strcmp(argv[3], "-command") != 0) { Tcl_AppendResult(interp, "bad argument \"", argv[3], - "\": should be \"-command\"", (void *)NULL); + "\": should be \"-command\"", NULL); return TCL_ERROR; } @@ -6616,7 +6213,7 @@ TestChannelCmd( if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " unstack channel\"", (void *)NULL); + " unstack channel\"", NULL); return TCL_ERROR; } return Tcl_UnstackChannel(interp, chan); @@ -6624,7 +6221,7 @@ TestChannelCmd( Tcl_AppendResult(interp, "bad option \"", cmdName, "\": should be " "cut, clearchannelhandlers, info, isshared, mode, open, " - "readable, splice, writable, transform, unstack", (void *)NULL); + "readable, splice, writable, transform, unstack", NULL); return TCL_ERROR; } @@ -6645,9 +6242,10 @@ TestChannelCmd( *---------------------------------------------------------------------- */ + /* ARGSUSED */ static int TestChannelEventCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -6661,7 +6259,7 @@ TestChannelEventCmd( if ((argc < 3) || (argc > 5)) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " channelName cmd ?arg1? ?arg2?\"", (void *)NULL); + " channelName cmd ?arg1? ?arg2?\"", NULL); return TCL_ERROR; } chanPtr = (Channel *) Tcl_GetChannel(interp, argv[1], NULL); @@ -6672,10 +6270,10 @@ TestChannelEventCmd( cmd = argv[2]; len = strlen(cmd); - if ((cmd[0] == 'a') && (strncmp(cmd, "add", len) == 0)) { + 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\"", (void *)NULL); + " channelName add eventSpec script\"", NULL); return TCL_ERROR; } if (strcmp(argv[3], "readable") == 0) { @@ -6686,11 +6284,12 @@ TestChannelEventCmd( mask = 0; } else { Tcl_AppendResult(interp, "bad event name \"", argv[3], - "\": must be readable, writable, or none", (void *)NULL); + "\": must be readable, writable, or none", NULL); return TCL_ERROR; } - esPtr = (EventScriptRecord *)ckalloc(sizeof(EventScriptRecord)); + esPtr = (EventScriptRecord *) ckalloc((unsigned) + sizeof(EventScriptRecord)); esPtr->nextPtr = statePtr->scriptRecordPtr; statePtr->scriptRecordPtr = esPtr; @@ -6701,15 +6300,15 @@ TestChannelEventCmd( Tcl_IncrRefCount(esPtr->scriptPtr); Tcl_CreateChannelHandler((Tcl_Channel) chanPtr, mask, - TclChannelEventScriptInvoker, esPtr); + TclChannelEventScriptInvoker, (ClientData) esPtr); return TCL_OK; } - if ((cmd[0] == 'd') && (strncmp(cmd, "delete", len) == 0)) { + 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\"", (void *)NULL); + " channelName delete index\"", NULL); return TCL_ERROR; } if (Tcl_GetInt(interp, argv[3], &index) == TCL_ERROR) { @@ -6717,7 +6316,7 @@ TestChannelEventCmd( } if (index < 0) { Tcl_AppendResult(interp, "bad event index: ", argv[3], - ": must be nonnegative", (void *)NULL); + ": must be nonnegative", NULL); return TCL_ERROR; } for (i = 0, esPtr = statePtr->scriptRecordPtr; @@ -6727,7 +6326,7 @@ TestChannelEventCmd( } if (esPtr == NULL) { Tcl_AppendResult(interp, "bad event index ", argv[3], - ": out of range", (void *)NULL); + ": out of range", NULL); return TCL_ERROR; } if (esPtr == statePtr->scriptRecordPtr) { @@ -6745,17 +6344,17 @@ TestChannelEventCmd( prevEsPtr->nextPtr = esPtr->nextPtr; } Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr, - TclChannelEventScriptInvoker, esPtr); + TclChannelEventScriptInvoker, (ClientData) esPtr); Tcl_DecrRefCount(esPtr->scriptPtr); - ckfree(esPtr); + ckfree((char *) esPtr); return TCL_OK; } - if ((cmd[0] == 'l') && (strncmp(cmd, "list", len) == 0)) { + if ((cmd[0] == 'l') && (strncmp(cmd, "list", (unsigned) len) == 0)) { if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " channelName list\"", (void *)NULL); + " channelName list\"", NULL); return TCL_ERROR; } resultListPtr = Tcl_GetObjResult(interp); @@ -6775,10 +6374,10 @@ TestChannelEventCmd( return TCL_OK; } - if ((cmd[0] == 'r') && (strncmp(cmd, "removeall", len) == 0)) { + if ((cmd[0] == 'r') && (strncmp(cmd, "removeall", (unsigned) len) == 0)) { if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " channelName removeall\"", (void *)NULL); + " channelName removeall\"", NULL); return TCL_ERROR; } for (esPtr = statePtr->scriptRecordPtr; @@ -6786,18 +6385,18 @@ TestChannelEventCmd( esPtr = nextEsPtr) { nextEsPtr = esPtr->nextPtr; Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr, - TclChannelEventScriptInvoker, esPtr); + TclChannelEventScriptInvoker, (ClientData) esPtr); Tcl_DecrRefCount(esPtr->scriptPtr); - ckfree(esPtr); + ckfree((char *) esPtr); } statePtr->scriptRecordPtr = NULL; return TCL_OK; } - if ((cmd[0] == 's') && (strncmp(cmd, "set", len) == 0)) { + 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\"", (void *)NULL); + " channelName delete index event\"", NULL); return TCL_ERROR; } if (Tcl_GetInt(interp, argv[3], &index) == TCL_ERROR) { @@ -6805,7 +6404,7 @@ TestChannelEventCmd( } if (index < 0) { Tcl_AppendResult(interp, "bad event index: ", argv[3], - ": must be nonnegative", (void *)NULL); + ": must be nonnegative", NULL); return TCL_ERROR; } for (i = 0, esPtr = statePtr->scriptRecordPtr; @@ -6815,7 +6414,7 @@ TestChannelEventCmd( } if (esPtr == NULL) { Tcl_AppendResult(interp, "bad event index ", argv[3], - ": out of range", (void *)NULL); + ": out of range", NULL); return TCL_ERROR; } @@ -6827,150 +6426,22 @@ TestChannelEventCmd( mask = 0; } else { Tcl_AppendResult(interp, "bad event name \"", argv[4], - "\": must be readable, writable, or none", (void *)NULL); + "\": must be readable, writable, or none", NULL); return TCL_ERROR; } esPtr->mask = mask; Tcl_CreateChannelHandler((Tcl_Channel) chanPtr, mask, - TclChannelEventScriptInvoker, esPtr); + TclChannelEventScriptInvoker, (ClientData) esPtr); return TCL_OK; } Tcl_AppendResult(interp, "bad command ", cmd, ", must be one of " - "add, delete, list, set, or removeall", (void *)NULL); - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * TestSocketCmd -- - * - * Implements the Tcl "testsocket" debugging command and its - * subcommands. This is part of the testing environment. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -#define TCP_ASYNC_TEST_MODE (1<<8) /* Async testing activated. Do not - * automatically continue connection - * process. */ - -static int -TestSocketCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, /* Interpreter for result. */ - int argc, /* Count of additional args. */ - const char **argv) /* Additional arg strings. */ -{ - const char *cmdName; /* Sub command. */ - size_t len; /* Length of subcommand string. */ - - if (argc < 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " subcommand ?additional args..?\"", (void *)NULL); - return TCL_ERROR; - } - cmdName = argv[1]; - len = strlen(cmdName); - - if ((cmdName[0] == 't') && (strncmp(cmdName, "testflags", len) == 0)) { - Tcl_Channel hChannel; - int modePtr; - int testMode; - TcpState *statePtr; - /* Set test value in the socket driver - */ - /* Check for argument "channel name" - */ - if (argc < 4) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " testflags channel flags\"", (void *)NULL); - return TCL_ERROR; - } - hChannel = Tcl_GetChannel(interp, argv[2], &modePtr); - if ( NULL == hChannel ) { - Tcl_AppendResult(interp, "unknown channel:", argv[2], (void *)NULL); - return TCL_ERROR; - } - statePtr = (TcpState *)Tcl_GetChannelInstanceData(hChannel); - if ( NULL == statePtr) { - Tcl_AppendResult(interp, "No channel instance data:", argv[2], - (void *)NULL); - return TCL_ERROR; - } - if (Tcl_GetBoolean(interp, argv[3], &testMode) != TCL_OK) { - return TCL_ERROR; - } - if (testMode) { - statePtr->flags |= TCP_ASYNC_TEST_MODE; - } else { - statePtr->flags &= ~TCP_ASYNC_TEST_MODE; - } - return TCL_OK; - } - - Tcl_AppendResult(interp, "bad option \"", cmdName, "\": should be " - "testflags", (void *)NULL); + "add, delete, list, set, or removeall", NULL); return TCL_ERROR; } /* *---------------------------------------------------------------------- * - * TestServiceModeCmd -- - * - * This procedure implements the "testservicemode" command which gets or - * sets the current Tcl ServiceMode. There are several tests which open - * a file and assign various handlers to it. For these tests to be - * deterministic it is important that file events not be processed until - * all of the handlers are in place. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * May change the ServiceMode setting. - * - *---------------------------------------------------------------------- - */ - -static int -TestServiceModeCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - const char **argv) /* Argument strings. */ -{ - int newmode, oldmode; - if (argc > 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " ?newmode?\"", (void *)NULL); - return TCL_ERROR; - } - oldmode = (Tcl_GetServiceMode() != TCL_SERVICE_NONE); - if (argc == 2) { - if (Tcl_GetInt(interp, argv[1], &newmode) == TCL_ERROR) { - return TCL_ERROR; - } - if (newmode == 0) { - Tcl_SetServiceMode(TCL_SERVICE_NONE); - } else { - Tcl_SetServiceMode(TCL_SERVICE_ALL); - } - } - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(oldmode)); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * * TestWrongNumArgsObjCmd -- * * Test the Tcl_WrongNumArgs function. @@ -6986,19 +6457,24 @@ TestServiceModeCmd( static int TestWrongNumArgsObjCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ - Tcl_Size objc, /* Number of arguments. */ + int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_Size i, length; - const char *msg; + int i, length; + char *msg; if (objc < 3) { - goto insufArgs; + /* + * Don't use Tcl_WrongNumArgs here, as that is the function + * we want to test! + */ + Tcl_SetResult(interp, "insufficient arguments", TCL_STATIC); + return TCL_ERROR; } - if (Tcl_GetIntForIndex(interp, objv[1], TCL_INDEX_NONE, &i) != TCL_OK) { + if (Tcl_GetIntFromObj(interp, objv[1], &i) != TCL_OK) { return TCL_ERROR; } @@ -7011,8 +6487,7 @@ TestWrongNumArgsObjCmd( /* * Asked for more arguments than were given. */ - insufArgs: - Tcl_AppendResult(interp, "insufficient arguments", (void *)NULL); + Tcl_SetResult(interp, "insufficient arguments", TCL_STATIC); return TCL_ERROR; } @@ -7038,45 +6513,37 @@ TestWrongNumArgsObjCmd( static int TestGetIndexFromObjStructObjCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - const char *const ary[] = { - "a", "b", "c", "d", "ee", "ff", NULL, NULL + const char *ary[] = { + "a", "b", "c", "d", "e", "f", NULL, NULL }; - int target, flags = 0; - signed char idx[8]; + int idx,target; - if (objc != 3 && objc != 4) { - Tcl_WrongNumArgs(interp, 1, objv, "argument targetvalue ?flags?"); - return TCL_ERROR; - } - if (Tcl_GetIntFromObj(interp, objv[2], &target) != TCL_OK) { + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "argument targetvalue"); return TCL_ERROR; } - if ((objc > 3) && (Tcl_GetIntFromObj(interp, objv[3], &flags) != TCL_OK)) { + if (Tcl_GetIndexFromObjStruct(interp, objv[1], ary, 2*sizeof(char *), + "dummy", 0, &idx) != TCL_OK) { return TCL_ERROR; } - memset(idx, 85, sizeof(idx)); - if (Tcl_GetIndexFromObjStruct(interp, (Tcl_GetString(objv[1])[0] ? objv[1] : NULL), ary, 2*sizeof(char *), - "dummy", flags, &idx[1]) != TCL_OK) { + if (Tcl_GetIntFromObj(interp, objv[2], &target) != TCL_OK) { return TCL_ERROR; } - if (idx[0] != 85 || idx[2] != 85) { - Tcl_AppendResult(interp, "Tcl_GetIndexFromObjStruct overwrites bytes near index variable", (void *)NULL); - return TCL_ERROR; - } else if (idx[1] != target) { + if (idx != target) { char buffer[64]; - snprintf(buffer, sizeof(buffer), "%d", idx[1]); + sprintf(buffer, "%d", idx); Tcl_AppendResult(interp, "index value comparison failed: got ", - buffer, (void *)NULL); - snprintf(buffer, sizeof(buffer), "%d", target); - Tcl_AppendResult(interp, " when ", buffer, " expected", (void *)NULL); + buffer, NULL); + sprintf(buffer, "%d", target); + Tcl_AppendResult(interp, " when ", buffer, " expected", NULL); return TCL_ERROR; } - Tcl_WrongNumArgs(interp, objc, objv, NULL); + Tcl_WrongNumArgs(interp, 3, objv, NULL); return TCL_OK; } @@ -7100,13 +6567,13 @@ TestGetIndexFromObjStructObjCmd( static int TestFilesystemObjCmd( - TCL_UNUSED(void *), + ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { int res, boolVal; - const char *msg; + char *msg; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "boolean"); @@ -7116,20 +6583,20 @@ TestFilesystemObjCmd( return TCL_ERROR; } if (boolVal) { - res = Tcl_FSRegister(interp, &testReportingFilesystem); + res = Tcl_FSRegister((ClientData)interp, &testReportingFilesystem); msg = (res == TCL_OK) ? "registered" : "failed"; } else { res = Tcl_FSUnregister(&testReportingFilesystem); msg = (res == TCL_OK) ? "unregistered" : "failed"; } - Tcl_SetObjResult(interp, Tcl_NewStringObj(msg , -1)); + Tcl_SetResult(interp, msg, TCL_VOLATILE); return res; } static int TestReportInFilesystem( Tcl_Obj *pathPtr, - void **clientDataPtr) + ClientData *clientDataPtr) { static Tcl_Obj *lastPathPtr = NULL; Tcl_Obj *newPathPtr; @@ -7151,7 +6618,7 @@ TestReportInFilesystem( return -1; } lastPathPtr = NULL; - *clientDataPtr = newPathPtr; + *clientDataPtr = (ClientData) newPathPtr; return TCL_OK; } @@ -7169,7 +6636,7 @@ TestReportGetNativePath( static void TestReportFreeInternalRep( - void *clientData) + ClientData clientData) { Tcl_Obj *nativeRep = (Tcl_Obj *) clientData; @@ -7179,9 +6646,9 @@ TestReportFreeInternalRep( } } -static void * +static ClientData TestReportDupInternalRep( - void *clientData) + ClientData clientData) { Tcl_Obj *original = (Tcl_Obj *) clientData; @@ -7200,7 +6667,12 @@ TestReport( if (interp == NULL) { /* This is bad, but not much we can do about it */ } else { - Tcl_Obj *savedResult; + /* + * 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_DString ds; Tcl_DStringInit(&ds); @@ -7214,15 +6686,11 @@ TestReport( Tcl_DStringAppendElement(&ds, Tcl_GetString(arg2)); } Tcl_DStringEndSublist(&ds); - savedResult = Tcl_GetObjResult(interp); - Tcl_IncrRefCount(savedResult); - Tcl_SetObjResult(interp, Tcl_NewObj()); - Tcl_EvalEx(interp, Tcl_DStringValue(&ds), TCL_INDEX_NONE, 0); + Tcl_SaveResult(interp, &savedResult); + Tcl_Eval(interp, Tcl_DStringValue(&ds)); Tcl_DStringFree(&ds); - Tcl_ResetResult(interp); - Tcl_SetObjResult(interp, savedResult); - Tcl_DecrRefCount(savedResult); - } + Tcl_RestoreResult(interp, &savedResult); + } } static int @@ -7387,7 +6855,7 @@ TestReportRemoveDirectory( errorPtr); } -static const char *const * +static const char ** TestReportFileAttrStrings( Tcl_Obj *fileName, Tcl_Obj **objPtrRef) @@ -7431,7 +6899,7 @@ TestReportUtime( static int TestReportNormalizePath( - TCL_UNUSED(Tcl_Interp *), + Tcl_Interp *interp, Tcl_Obj *pathPtr, int nextCheckpoint) { @@ -7442,7 +6910,7 @@ TestReportNormalizePath( static int SimplePathInFilesystem( Tcl_Obj *pathPtr, - TCL_UNUSED(void **)) + ClientData *clientDataPtr) { const char *str = Tcl_GetString(pathPtr); @@ -7471,13 +6939,13 @@ SimplePathInFilesystem( static int TestSimpleFilesystemObjCmd( - TCL_UNUSED(void *), + ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { int res, boolVal; - const char *msg; + char *msg; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "boolean"); @@ -7487,13 +6955,13 @@ TestSimpleFilesystemObjCmd( return TCL_ERROR; } if (boolVal) { - res = Tcl_FSRegister(interp, &simpleFilesystem); + res = Tcl_FSRegister((ClientData)interp, &simpleFilesystem); msg = (res == TCL_OK) ? "registered" : "failed"; } else { res = Tcl_FSUnregister(&simpleFilesystem); msg = (res == TCL_OK) ? "unregistered" : "failed"; } - Tcl_SetObjResult(interp, Tcl_NewStringObj(msg , -1)); + Tcl_SetResult(interp, msg, TCL_VOLATILE); return res; } @@ -7506,7 +6974,7 @@ static Tcl_Obj * SimpleRedirect( Tcl_Obj *pathPtr) /* Name of file to copy. */ { - Tcl_Size len; + int len; const char *str; Tcl_Obj *origPtr; @@ -7520,7 +6988,7 @@ SimpleRedirect( Tcl_IncrRefCount(pathPtr); return pathPtr; } - origPtr = Tcl_NewStringObj(str+10, -1); + origPtr = Tcl_NewStringObj(str+10,-1); Tcl_IncrRefCount(origPtr); return origPtr; } @@ -7552,7 +7020,7 @@ SimpleMatchInDirectory( origPtr = SimpleRedirect(dirPtr); res = Tcl_FSMatchInDirectory(interp, resPtr, origPtr, pattern, types); if (res == TCL_OK) { - Tcl_Size gLength, j; + int gLength, j; Tcl_ListObjLength(NULL, resPtr, &gLength); for (j = 0; j < gLength; j++) { Tcl_Obj *gElt, *nElt; @@ -7580,7 +7048,7 @@ SimpleOpenFileChannel( Tcl_Channel chan; if ((mode != 0) && !(mode & O_RDONLY)) { - Tcl_AppendResult(interp, "read-only", (void *)NULL); + Tcl_AppendResult(interp, "read-only", NULL); return NULL; } @@ -7626,194 +7094,12 @@ SimpleListVolumes(void) } /* - * Used to check operations of Tcl_UtfNext. - * - * Usage: testutfnext -bytestring $bytes - */ - -static int -TestUtfNextCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Tcl_Size numBytes; - char *bytes; - const char *result, *first; - char buffer[32]; - static const char tobetested[] = "A\xA0\xC0\xC1\xC2\xD0\xE0\xE8\xF2\xF7\xF8\xFE\xFF"; - const char *p = tobetested; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "?-bytestring? bytes"); - return TCL_ERROR; - } - bytes = Tcl_GetStringFromObj(objv[1], &numBytes); - - if ((size_t)numBytes > sizeof(buffer) - 4) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "\"testutfnext\" can only handle %" TCL_Z_MODIFIER "u bytes", - sizeof(buffer) - 4)); - return TCL_ERROR; - } - - memcpy(buffer + 1, bytes, numBytes); - buffer[0] = buffer[numBytes + 1] = buffer[numBytes + 2] = buffer[numBytes + 3] = '\xA0'; - - first = result = Tcl_UtfNext(buffer + 1); - while ((buffer[0] = *p++) != '\0') { - /* Run Tcl_UtfNext with many more possible bytes at src[-1], all should give the same result */ - result = Tcl_UtfNext(buffer + 1); - if (first != result) { - Tcl_AppendResult(interp, "Tcl_UtfNext is not supposed to read src[-1]", (void *)NULL); - return TCL_ERROR; - } - } - p = tobetested; - while ((buffer[numBytes + 1] = *p++) != '\0') { - /* Run Tcl_UtfNext with many more possible bytes at src[end], all should give the same result */ - result = Tcl_UtfNext(buffer + 1); - if (first != result) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "Tcl_UtfNext is not supposed to read src[end]\n" - "Different result when src[end] is %#x", UCHAR(p[-1]))); - return TCL_ERROR; - } - } - - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(first - buffer - 1)); - - return TCL_OK; -} -/* - * Used to check operations of Tcl_UtfPrev. - * - * Usage: testutfprev $bytes $offset - */ - -static int -TestUtfPrevCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Tcl_Size numBytes, offset; - char *bytes; - const char *result; - - if (objc < 2 || objc > 3) { - Tcl_WrongNumArgs(interp, 1, objv, "bytes ?offset?"); - return TCL_ERROR; - } - - bytes = Tcl_GetStringFromObj(objv[1], &numBytes); - - if (objc == 3) { - if (TCL_OK != Tcl_GetIntForIndex(interp, objv[2], numBytes, &offset)) { - return TCL_ERROR; - } - if (offset < 0) { - offset = 0; - } - if (offset > numBytes) { - offset = numBytes; - } - } else { - offset = numBytes; - } - result = Tcl_UtfPrev(bytes + offset, bytes); - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(result - bytes)); - return TCL_OK; -} - -/* * Used to check correct string-length determining in Tcl_NumUtfChars */ static int TestNumUtfCharsCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - if (objc > 1) { - Tcl_Size numBytes, len, limit = TCL_INDEX_NONE; - const char *bytes = Tcl_GetStringFromObj(objv[1], &numBytes); - - if (objc > 2) { - if (Tcl_GetIntForIndex(interp, objv[2], numBytes, &limit) != TCL_OK) { - return TCL_ERROR; - } - if (limit > numBytes + 1) { - limit = numBytes + 1; - } - } - len = Tcl_NumUtfChars(bytes, limit); - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(len)); - } - return TCL_OK; -} - - -/* - * Used to check correct operation of Tcl_GetUniChar - * testgetunichar STRING INDEX - * This differs from just using "string index" in being a direct - * call to Tcl_GetUniChar without any prior range checking. - */ -static int -TestGetUniCharCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, /* Current interpreter */ - int objc, /* Number of arguments */ - Tcl_Obj *const objv[] /* Argument strings */ - ) -{ - int index; - int c ; - if (objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "STRING INDEX"); - return TCL_ERROR; - } - Tcl_GetIntFromObj(interp, objv[2], &index); - c = Tcl_GetUniChar(objv[1], index); - Tcl_SetObjResult(interp, Tcl_NewIntObj(c)); - - return TCL_OK; -} - -/* - * Used to check correct operation of Tcl_UtfFindFirst - */ - -static int -TestFindFirstCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - if (objc > 1) { - int len = -1; - - if (objc > 2) { - (void) Tcl_GetIntFromObj(interp, objv[2], &len); - } - Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_UtfFindFirst(Tcl_GetString(objv[1]), len), -1)); - } - return TCL_OK; -} - -/* - * Used to check correct operation of Tcl_UtfFindLast - */ - -static int -TestFindLastCmd( - TCL_UNUSED(void *), + ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -7822,41 +7108,15 @@ TestFindLastCmd( int len = -1; if (objc > 2) { - (void) Tcl_GetIntFromObj(interp, objv[2], &len); + (void) Tcl_GetStringFromObj(objv[1], &len); } - Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_UtfFindLast(Tcl_GetString(objv[1]), len), -1)); + len = Tcl_NumUtfChars(Tcl_GetString(objv[1]), len); + Tcl_SetObjResult(interp, Tcl_NewIntObj(len)); } return TCL_OK; } -static int -TestGetIntForIndexCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Tcl_Size result; - Tcl_WideInt endvalue; - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "index endvalue"); - return TCL_ERROR; - } - - if (Tcl_GetWideIntFromObj(interp, objv[2], &endvalue) != TCL_OK) { - return TCL_ERROR; - } - if (Tcl_GetIntForIndex(interp, objv[1], endvalue, &result) != TCL_OK) { - return TCL_ERROR; - } - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(result)); - return TCL_OK; -} - - - -#if defined(HAVE_CPUID) && !defined(MAC_OSX_TCL) +#if defined(HAVE_CPUID) || defined(__WIN32__) /* *---------------------------------------------------------------------- * @@ -7882,13 +7142,13 @@ TestGetIntForIndexCmd( static int TestcpuidCmd( - TCL_UNUSED(void *), + ClientData dummy, Tcl_Interp* interp, /* Tcl interpreter */ int objc, /* Parameter count */ Tcl_Obj *const * objv) /* Parameter vector */ { int status, index, i; - int regs[4]; + unsigned int regs[4]; Tcl_Obj *regsObjs[4]; if (objc != 2) { @@ -7898,14 +7158,14 @@ TestcpuidCmd( if (Tcl_GetIntFromObj(interp, objv[1], &index) != TCL_OK) { return TCL_ERROR; } - status = TclWinCPUID(index, regs); + 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_NewWideIntObj(regs[i]); + regsObjs[i] = Tcl_NewIntObj((int) regs[i]); } Tcl_SetObjResult(interp, Tcl_NewListObj(4, regsObjs)); return TCL_OK; @@ -7918,12 +7178,12 @@ TestcpuidCmd( static int TestHashSystemHashCmd( - TCL_UNUSED(void *), + ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { - static const Tcl_HashKeyType hkType = { + static Tcl_HashKeyType hkType = { TCL_HASH_KEY_TYPE_VERSION, TCL_HASH_KEY_SYSTEM_HASH, NULL, NULL, NULL, NULL }; @@ -7938,24 +7198,24 @@ TestHashSystemHashCmd( Tcl_InitCustomHashTable(&hash, TCL_CUSTOM_TYPE_KEYS, &hkType); if (hash.numEntries != 0) { - Tcl_AppendResult(interp, "non-zero initial size", (void *)NULL); + Tcl_AppendResult(interp, "non-zero initial size", NULL); Tcl_DeleteHashTable(&hash); return TCL_ERROR; } for (i=0 ; i<limit ; i++) { - hPtr = Tcl_CreateHashEntry(&hash, INT2PTR(i), &isNew); + hPtr = Tcl_CreateHashEntry(&hash, (char *) INT2PTR(i), &isNew); if (!isNew) { - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(i)); - Tcl_AppendToObj(Tcl_GetObjResult(interp)," creation problem", -1); + Tcl_SetObjResult(interp, Tcl_NewIntObj(i)); + Tcl_AppendToObj(Tcl_GetObjResult(interp)," creation problem",-1); Tcl_DeleteHashTable(&hash); return TCL_ERROR; } - Tcl_SetHashValue(hPtr, INT2PTR(i+42)); + Tcl_SetHashValue(hPtr, (ClientData) INT2PTR(i+42)); } - if (hash.numEntries != (Tcl_Size)limit) { - Tcl_AppendResult(interp, "unexpected maximal size", (void *)NULL); + if (hash.numEntries != limit) { + Tcl_AppendResult(interp, "unexpected maximal size", NULL); Tcl_DeleteHashTable(&hash); return TCL_ERROR; } @@ -7963,14 +7223,14 @@ TestHashSystemHashCmd( for (i=0 ; i<limit ; i++) { hPtr = Tcl_FindHashEntry(&hash, (char *) INT2PTR(i)); if (hPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(i)); - Tcl_AppendToObj(Tcl_GetObjResult(interp)," lookup problem", -1); + Tcl_SetObjResult(interp, Tcl_NewIntObj(i)); + Tcl_AppendToObj(Tcl_GetObjResult(interp)," lookup problem",-1); Tcl_DeleteHashTable(&hash); return TCL_ERROR; } if (PTR2INT(Tcl_GetHashValue(hPtr)) != i+42) { - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(i)); - Tcl_AppendToObj(Tcl_GetObjResult(interp)," value problem", -1); + Tcl_SetObjResult(interp, Tcl_NewIntObj(i)); + Tcl_AppendToObj(Tcl_GetObjResult(interp)," value problem",-1); Tcl_DeleteHashTable(&hash); return TCL_ERROR; } @@ -7978,13 +7238,13 @@ TestHashSystemHashCmd( } if (hash.numEntries != 0) { - Tcl_AppendResult(interp, "non-zero final size", (void *)NULL); + Tcl_AppendResult(interp, "non-zero final size", NULL); Tcl_DeleteHashTable(&hash); return TCL_ERROR; } Tcl_DeleteHashTable(&hash); - Tcl_AppendResult(interp, "OK", (void *)NULL); + Tcl_AppendResult(interp, "OK", NULL); return TCL_OK; } @@ -7994,16 +7254,17 @@ TestHashSystemHashCmd( */ static int TestgetintCmd( - TCL_UNUSED(void *), + ClientData dummy, Tcl_Interp *interp, int argc, const char **argv) { if (argc < 2) { - Tcl_AppendResult(interp, "wrong # args", (void *)NULL); + Tcl_SetResult(interp, "wrong # args", TCL_STATIC); return TCL_ERROR; } else { int val, i, total=0; + char buf[TCL_INTEGER_SPACE]; for (i=1 ; i<argc ; i++) { if (Tcl_GetInt(interp, argv[i], &val) != TCL_OK) { @@ -8011,119 +7272,20 @@ TestgetintCmd( } total += val; } - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(total)); + TclFormatInt(buf, total); + Tcl_SetResult(interp, buf, TCL_VOLATILE); return TCL_OK; } } /* - * Used for determining sizeof(long) at script level. - */ -static int -TestlongsizeCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, - int argc, - TCL_UNUSED(const char **) /*argv*/) -{ - if (argc != 1) { - Tcl_AppendResult(interp, "wrong # args", (void *)NULL); - return TCL_ERROR; - } - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(sizeof(long))); - return TCL_OK; -} - -static int -NREUnwind_callback( - void *data[], - Tcl_Interp *interp, - TCL_UNUSED(int) /*result*/) -{ - void *cStackPtr = TclGetCStackPtr(); - - if (data[0] == INT2PTR(-1)) { - Tcl_NRAddCallback(interp, NREUnwind_callback, cStackPtr, INT2PTR(-1), - INT2PTR(-1), NULL); - } else if (data[1] == INT2PTR(-1)) { - Tcl_NRAddCallback(interp, NREUnwind_callback, data[0], cStackPtr, - INT2PTR(-1), NULL); - } else if (data[2] == INT2PTR(-1)) { - Tcl_NRAddCallback(interp, NREUnwind_callback, data[0], data[1], - cStackPtr, NULL); - } else { - Tcl_Obj *idata[3]; - idata[0] = Tcl_NewWideIntObj(((char *) data[1] - (char *) data[0])); - idata[1] = Tcl_NewWideIntObj(((char *) data[2] - (char *) data[0])); - idata[2] = Tcl_NewWideIntObj(((char *) cStackPtr - (char *) data[0])); - Tcl_SetObjResult(interp, Tcl_NewListObj(3, idata)); - } - return TCL_OK; -} - -static int -TestNREUnwind( - TCL_UNUSED(void *), - Tcl_Interp *interp, - TCL_UNUSED(int) /*objc*/, - TCL_UNUSED(Tcl_Obj *const *) /*objv*/) -{ - /* - * Insure that callbacks effectively run at the proper level during the - * unwinding of the NRE stack. - */ - - Tcl_NRAddCallback(interp, NREUnwind_callback, INT2PTR(-1), INT2PTR(-1), - INT2PTR(-1), NULL); - return TCL_OK; -} - - -static int -TestNRELevels( - TCL_UNUSED(void *), - Tcl_Interp *interp, - TCL_UNUSED(int) /*objc*/, - TCL_UNUSED(Tcl_Obj *const *) /*objv*/) -{ - Interp *iPtr = (Interp *) interp; - static ptrdiff_t *refDepth = NULL; - ptrdiff_t depth; - Tcl_Obj *levels[6]; - Tcl_Size i = 0; - NRE_callback *cbPtr = iPtr->execEnvPtr->callbackPtr; - - if (refDepth == NULL) { - refDepth = (ptrdiff_t *)TclGetCStackPtr(); - } - - depth = (refDepth - (ptrdiff_t *)TclGetCStackPtr()); - - levels[0] = Tcl_NewWideIntObj(depth); - levels[1] = Tcl_NewWideIntObj(iPtr->numLevels); - levels[2] = Tcl_NewWideIntObj(iPtr->cmdFramePtr->level); - levels[3] = Tcl_NewWideIntObj(iPtr->varFramePtr->level); - levels[4] = Tcl_NewWideIntObj(iPtr->execEnvPtr->execStackPtr->tosPtr - - iPtr->execEnvPtr->execStackPtr->stackWords); - - while (cbPtr) { - i++; - cbPtr = cbPtr->nextPtr; - } - levels[5] = Tcl_NewWideIntObj(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 that it never corrupts its arguments. In other words, that + * cases and thet it never corrupts its arguments. In other words, that * [Bug 1447328] was fixed properly. * * Results: @@ -8137,14 +7299,13 @@ TestNRELevels( static int TestconcatobjCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ - TCL_UNUSED(int) /*argc*/, - TCL_UNUSED(const char **) /*argv*/) + int argc, /* Number of arguments. */ + const char **argv) /* Argument strings. */ { Tcl_Obj *list1Ptr, *list2Ptr, *emptyPtr, *concatPtr, *tmpPtr; - int result = TCL_OK; - Tcl_Size len; + int result = TCL_OK, len; Tcl_Obj *objv[3]; /* @@ -8159,11 +7320,17 @@ TestconcatobjCmd( list1Ptr = Tcl_NewStringObj("foo bar sum", -1); Tcl_ListObjLength(NULL, list1Ptr, &len); - Tcl_InvalidateStringRep(list1Ptr); + if (list1Ptr->bytes != NULL) { + ckfree((char *) list1Ptr->bytes); + list1Ptr->bytes = NULL; + } list2Ptr = Tcl_NewStringObj("eeny meeny", -1); Tcl_ListObjLength(NULL, list2Ptr, &len); - Tcl_InvalidateStringRep(list2Ptr); + if (list2Ptr->bytes != NULL) { + ckfree((char *) list2Ptr->bytes); + list2Ptr->bytes = NULL; + } /* * Verify that concat'ing a list obj with one or more empty strings does @@ -8178,21 +7345,21 @@ TestconcatobjCmd( if (concatPtr->refCount != 0) { result = TCL_ERROR; Tcl_AppendResult(interp, - "\n\t* (a) concatObj does not have refCount 0", (void *)NULL); + "\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 ", - (void *)NULL); + NULL); switch (tmpPtr->refCount) { case 0: - Tcl_AppendResult(interp, "(no new refCount)", (void *)NULL); + Tcl_AppendResult(interp, "(no new refCount)", NULL); break; case 1: - Tcl_AppendResult(interp, "(refCount added)", (void *)NULL); + Tcl_AppendResult(interp, "(refCount added)", NULL); break; default: - Tcl_AppendResult(interp, "(more than one refCount added!)", (void *)NULL); + Tcl_AppendResult(interp, "(more than one refCount added!)", NULL); Tcl_Panic("extremely unsafe behaviour by Tcl_ConcatObj()"); } tmpPtr = Tcl_DuplicateObj(list1Ptr); @@ -8205,26 +7372,26 @@ TestconcatobjCmd( if (concatPtr->refCount != 0) { result = TCL_ERROR; Tcl_AppendResult(interp, - "\n\t* (b) concatObj does not have refCount 0", (void *)NULL); + "\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 ", - (void *)NULL); + NULL); switch (tmpPtr->refCount) { case 0: - Tcl_AppendResult(interp, "(refCount removed?)", (void *)NULL); + Tcl_AppendResult(interp, "(refCount removed?)", NULL); Tcl_Panic("extremely unsafe behaviour by Tcl_ConcatObj()"); break; case 1: - Tcl_AppendResult(interp, "(no new refCount)", (void *)NULL); + Tcl_AppendResult(interp, "(no new refCount)", NULL); break; case 2: - Tcl_AppendResult(interp, "(refCount added)", (void *)NULL); + Tcl_AppendResult(interp, "(refCount added)", NULL); Tcl_DecrRefCount(tmpPtr); break; default: - Tcl_AppendResult(interp, "(more than one refCount added!)", (void *)NULL); + Tcl_AppendResult(interp, "(more than one refCount added!)", NULL); Tcl_Panic("extremely unsafe behaviour by Tcl_ConcatObj()"); } tmpPtr = Tcl_DuplicateObj(list1Ptr); @@ -8239,21 +7406,21 @@ TestconcatobjCmd( if (concatPtr->refCount != 0) { result = TCL_ERROR; Tcl_AppendResult(interp, - "\n\t* (c) concatObj does not have refCount 0", (void *)NULL); + "\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 ", - (void *)NULL); + NULL); switch (tmpPtr->refCount) { case 0: - Tcl_AppendResult(interp, "(no new refCount)", (void *)NULL); + Tcl_AppendResult(interp, "(no new refCount)", NULL); break; case 1: - Tcl_AppendResult(interp, "(refCount added)", (void *)NULL); + Tcl_AppendResult(interp, "(refCount added)", NULL); break; default: - Tcl_AppendResult(interp, "(more than one refCount added!)", (void *)NULL); + Tcl_AppendResult(interp, "(more than one refCount added!)", NULL); Tcl_Panic("extremely unsafe behaviour by Tcl_ConcatObj()"); } tmpPtr = Tcl_DuplicateObj(list1Ptr); @@ -8266,26 +7433,26 @@ TestconcatobjCmd( if (concatPtr->refCount != 0) { result = TCL_ERROR; Tcl_AppendResult(interp, - "\n\t* (d) concatObj does not have refCount 0", (void *)NULL); + "\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 ", - (void *)NULL); + NULL); switch (tmpPtr->refCount) { case 0: - Tcl_AppendResult(interp, "(refCount removed?)", (void *)NULL); + Tcl_AppendResult(interp, "(refCount removed?)", NULL); Tcl_Panic("extremely unsafe behaviour by Tcl_ConcatObj()"); break; case 1: - Tcl_AppendResult(interp, "(no new refCount)", (void *)NULL); + Tcl_AppendResult(interp, "(no new refCount)", NULL); break; case 2: - Tcl_AppendResult(interp, "(refCount added)", (void *)NULL); + Tcl_AppendResult(interp, "(refCount added)", NULL); Tcl_DecrRefCount(tmpPtr); break; default: - Tcl_AppendResult(interp, "(more than one refCount added!)", (void *)NULL); + Tcl_AppendResult(interp, "(more than one refCount added!)", NULL); Tcl_Panic("extremely unsafe behaviour by Tcl_ConcatObj()"); } tmpPtr = Tcl_DuplicateObj(list1Ptr); @@ -8304,20 +7471,22 @@ TestconcatobjCmd( if (concatPtr->refCount != 0) { result = TCL_ERROR; Tcl_AppendResult(interp, - "\n\t* (e) concatObj does not have refCount 0", (void *)NULL); + "\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 ", - (void *)NULL); + NULL); (void) Tcl_ListObjLength(NULL, concatPtr, &len); switch (tmpPtr->refCount) { case 3: - Tcl_AppendResult(interp, "(failed to concat)", (void *)NULL); + Tcl_AppendResult(interp, "(failed to concat)", NULL); break; default: - Tcl_AppendResult(interp, "(corrupted input!)", (void *)NULL); + Tcl_AppendResult(interp, "(corrupted input!)", NULL); } if (Tcl_IsShared(tmpPtr)) { Tcl_DecrRefCount(tmpPtr); @@ -8334,20 +7503,22 @@ TestconcatobjCmd( if (concatPtr->refCount != 0) { result = TCL_ERROR; Tcl_AppendResult(interp, - "\n\t* (f) concatObj does not have refCount 0", (void *)NULL); + "\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 ", - (void *)NULL); + NULL); (void) Tcl_ListObjLength(NULL, concatPtr, &len); switch (tmpPtr->refCount) { case 3: - Tcl_AppendResult(interp, "(failed to concat)", (void *)NULL); + Tcl_AppendResult(interp, "(failed to concat)", NULL); break; default: - Tcl_AppendResult(interp, "(corrupted input!)", (void *)NULL); + Tcl_AppendResult(interp, "(corrupted input!)", NULL); } if (Tcl_IsShared(tmpPtr)) { Tcl_DecrRefCount(tmpPtr); @@ -8365,20 +7536,22 @@ TestconcatobjCmd( if (concatPtr->refCount != 0) { result = TCL_ERROR; Tcl_AppendResult(interp, - "\n\t* (g) concatObj does not have refCount 0", (void *)NULL); + "\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 ", - (void *)NULL); + NULL); (void) Tcl_ListObjLength(NULL, concatPtr, &len); switch (tmpPtr->refCount) { case 3: - Tcl_AppendResult(interp, "(failed to concat)", (void *)NULL); + Tcl_AppendResult(interp, "(failed to concat)", NULL); break; default: - Tcl_AppendResult(interp, "(corrupted input!)", (void *)NULL); + Tcl_AppendResult(interp, "(corrupted input!)", NULL); } Tcl_DecrRefCount(tmpPtr); if (Tcl_IsShared(tmpPtr)) { @@ -8410,384 +7583,6 @@ TestconcatobjCmd( } /* - *---------------------------------------------------------------------- - * - * 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( - TCL_UNUSED(void *), - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Arguments. */ -{ - static int foo = 0; - Tcl_Size count = objc; - Tcl_Obj **remObjv, *result[3]; - const 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_NewWideIntObj(foo); - result[1] = Tcl_NewWideIntObj(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_UNUSED(Tcl_Namespace *), - TCL_UNUSED(int) /* flags */, - Tcl_Command *rPtr) -{ - Interp *iPtr = (Interp *) interp; - CallFrame *varFramePtr = iPtr->varFramePtr; - Proc *procPtr = (varFramePtr->isProcCallFrame & FRAME_IS_PROC) ? - varFramePtr->procPtr : NULL; - Namespace *callerNsPtr = varFramePtr->nsPtr; - Tcl_Command resolvedCmdPtr = NULL; - - /* - * Just do something special on a cmd literal "z" in two cases: - * A) when the caller is a proc "x", and the proc is either in "::" or in "::ns2". - * B) the caller's namespace is "ctx1" or "ctx2" - */ - if ( (name[0] == 'z') && (name[1] == '\0') ) { - Namespace *ns2NsPtr = (Namespace *) Tcl_FindNamespace(interp, "::ns2", NULL, 0); - - if (procPtr != NULL - && ((procPtr->cmdPtr->nsPtr == iPtr->globalNsPtr) - || (ns2NsPtr != NULL && procPtr->cmdPtr->nsPtr == ns2NsPtr) - ) - ) { - /* - * Case A) - * - * - The context, in which this resolver becomes active, is - * determined by the name of the caller proc, which has to be - * named "x". - * - * - To determine the name of the caller proc, the proc is taken - * from the topmost stack frame. - * - * - Note that the context is NOT provided during byte-code - * compilation (e.g. in TclProcCompileProc) - * - * When these conditions hold, this function resolves the - * passed-in cmd literal into a cmd "y", which is taken from the - * the global namespace (for simplicity). - */ - - const char *callingCmdName = - Tcl_GetCommandName(interp, (Tcl_Command) procPtr->cmdPtr); - - if ( callingCmdName[0] == 'x' && callingCmdName[1] == '\0' ) { - resolvedCmdPtr = Tcl_FindCommand(interp, "y", NULL, TCL_GLOBAL_ONLY); - } - } else if (callerNsPtr != NULL) { - /* - * Case B) - * - * - The context, in which this resolver becomes active, is - * determined by the name of the parent namespace, which has - * to be named "ctx1" or "ctx2". - * - * - To determine the name of the parent namesace, it is taken - * from the 2nd highest stack frame. - * - * - Note that the context can be provided during byte-code - * compilation (e.g. in TclProcCompileProc) - * - * When these conditions hold, this function resolves the - * passed-in cmd literal into a cmd "y" or "Y" depending on the - * context. The resolved procs are taken from the the global - * namespace (for simplicity). - */ - - CallFrame *parentFramePtr = varFramePtr->callerPtr; - const char *context = parentFramePtr != NULL ? parentFramePtr->nsPtr->name : "(NULL)"; - - if (strcmp(context, "ctx1") == 0 && (name[0] == 'z') && (name[1] == '\0')) { - resolvedCmdPtr = Tcl_FindCommand(interp, "y", NULL, TCL_GLOBAL_ONLY); - /* fprintf(stderr, "... y ==> %p\n", resolvedCmdPtr);*/ - - } else if (strcmp(context, "ctx2") == 0 && (name[0] == 'z') && (name[1] == '\0')) { - resolvedCmdPtr = Tcl_FindCommand(interp, "Y", NULL, TCL_GLOBAL_ONLY); - /*fprintf(stderr, "... Y ==> %p\n", resolvedCmdPtr);*/ - } - } - - if (resolvedCmdPtr != NULL) { - *rPtr = resolvedCmdPtr; - return TCL_OK; - } - } - return TCL_CONTINUE; -} - -static int -InterpVarResolver( - TCL_UNUSED(Tcl_Interp *), - TCL_UNUSED(const char *), - TCL_UNUSED(Tcl_Namespace *), - TCL_UNUSED(int), - TCL_UNUSED(Tcl_Var *)) -{ - /* - * 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 - offsetof(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_UNUSED(Tcl_Interp *), - const char *name, - TCL_UNUSED(Tcl_Size) /* length */, - TCL_UNUSED(Tcl_Namespace *), - Tcl_ResolvedVarInfo **rPtr) -{ - if (*name == 'T') { - MyResolvedVarInfo *resVarInfo = (MyResolvedVarInfo *)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( - TCL_UNUSED(void *), - 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) || (objc > 3)) { - Tcl_WrongNumArgs(interp, 1, objv, "up|down ?interp?"); - return TCL_ERROR; - } - if (objc == 3) { - interp = Tcl_GetChild(interp, Tcl_GetString(objv[2])); - if (interp == NULL) { - Tcl_AppendResult(interp, "provided interpreter not found", (void *)NULL); - 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", - (void *)NULL); - return TCL_ERROR; - } - } - return TCL_OK; -} - -/* - *------------------------------------------------------------------------ - * - * TestApplyLambdaObjCmd -- - * - * Implements the Tcl command testapplylambda. This tests the apply - * implementation handling of a lambda where the lambda has a list - * internal representation where the second element's internal - * representation is already a byte code object. - * - * Results: - * TCL_OK - Success. Caller should check result is 42 - * TCL_ERROR - Error. - * - * Side effects: - * In the presence of the apply bug, may panic. Otherwise - * Interpreter result holds result or error message. - * - *------------------------------------------------------------------------ - */ -int TestApplyLambdaObjCmd ( - TCL_UNUSED(void*), - Tcl_Interp *interp, /* Current interpreter. */ - TCL_UNUSED(int), /* objc. */ - TCL_UNUSED(Tcl_Obj *const *)) /* objv. */ -{ - Tcl_Obj *lambdaObjs[2]; - Tcl_Obj *evalObjs[2]; - Tcl_Obj *lambdaObj; - int result; - - /* Create a lambda {{} {set a 42}} */ - lambdaObjs[0] = Tcl_NewObj(); /* No parameters */ - lambdaObjs[1] = Tcl_NewStringObj("set a 42", -1); /* Body */ - lambdaObj = Tcl_NewListObj(2, lambdaObjs); - Tcl_IncrRefCount(lambdaObj); - - /* Create the command "apply {{} {set a 42}" */ - evalObjs[0] = Tcl_NewStringObj("apply", -1); - Tcl_IncrRefCount(evalObjs[0]); - /* - * NOTE: IMPORTANT TO EXHIBIT THE BUG. We duplicate the lambda because - * it will get shimmered to a Lambda internal representation but we - * want to hold on to our list representation. - */ - evalObjs[1] = Tcl_DuplicateObj(lambdaObj); - Tcl_IncrRefCount(evalObjs[1]); - - /* Evaluate it */ - result = Tcl_EvalObjv(interp, 2, evalObjs, TCL_EVAL_GLOBAL); - if (result != TCL_OK) { - Tcl_DecrRefCount(evalObjs[0]); - Tcl_DecrRefCount(evalObjs[1]); - return result; - } - /* - * So far so good. At this point, - * - evalObjs[1] has an internal representation of Lambda - * - lambdaObj[1] ({set a 42}) has been shimmered to - * an internal representation of ByteCode. - */ - Tcl_DecrRefCount(evalObjs[1]); /* Don't need this anymore */ - /* - * The bug trigger. Repeating the command but: - * - we are calling apply with a lambda that is a list (as BEFORE), - * BUT - * - The body of the lambda (lambdaObjs[1]) ALREADY has internal - * representation of ByteCode and thus will not be compiled again - */ - evalObjs[1] = lambdaObj; /* lambdaObj already has a ref count so - no need for IncrRef */ - result = Tcl_EvalObjv(interp, 2, evalObjs, TCL_EVAL_GLOBAL); - Tcl_DecrRefCount(evalObjs[0]); - Tcl_DecrRefCount(lambdaObj); - - return result; -} - -/* * Local Variables: * mode: c * c-basic-offset: 4 |