summaryrefslogtreecommitdiffstats
path: root/generic/tclTest.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclTest.c')
-rw-r--r--generic/tclTest.c5720
1 files changed, 3349 insertions, 2371 deletions
diff --git a/generic/tclTest.c b/generic/tclTest.c
index e870236..98208af 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -1,24 +1,24 @@
-/*
+/*
* tclTest.c --
*
- * This file contains C command procedures for a bunch of additional
- * Tcl commands that are used for testing out Tcl's C interfaces.
- * These commands are not normally included in Tcl applications;
- * they're only used for testing.
+ * This file contains C command functions for a bunch of additional Tcl
+ * commands that are used for testing out Tcl's C interfaces. These
+ * commands are not normally included in Tcl applications; they're only
+ * used for testing.
*
* 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.
+ * See the file "license.terms" for information on usage and redistribution of
+ * this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#define TCL_TEST
-#include <sys/stat.h>
#include "tclInt.h"
-#include "tclPort.h"
+
+#include <math.h>
/*
* Required for Testregexp*Cmd
@@ -40,56 +40,59 @@
*/
/*
- * Dynamic string shared by TestdcallCmd and DelCallbackProc; used
- * to collect the results of the various deletion callbacks.
+ * Dynamic string shared by TestdcallCmd and DelCallbackProc; used to collect
+ * the results of the various deletion callbacks.
*/
static Tcl_DString delString;
static Tcl_Interp *delInterp;
/*
- * One of the following structures exists for each asynchronous
- * handler created by the "testasync" command".
+ * One of the following structures exists for each asynchronous handler
+ * created by the "testasync" command".
*/
typedef struct TestAsyncHandler {
- int id; /* Identifier for this handler. */
- Tcl_AsyncHandler handler; /* Tcl's token for the handler. */
- char *command; /* Command to invoke when the
- * handler is invoked. */
- struct TestAsyncHandler *nextPtr; /* Next is list of handlers. */
+ int id; /* Identifier for this handler. */
+ Tcl_AsyncHandler handler; /* Tcl's token for the handler. */
+ char *command; /* Command to invoke when the handler is
+ * invoked. */
+ struct TestAsyncHandler *nextPtr;
+ /* Next is list of handlers. */
} TestAsyncHandler;
+TCL_DECLARE_MUTEX(asyncTestMutex);
+
static TestAsyncHandler *firstHandler = NULL;
/*
- * The dynamic string below is used by the "testdstring" command
- * to test the dynamic string facilities.
+ * The dynamic string below is used by the "testdstring" command to test the
+ * dynamic string facilities.
*/
static Tcl_DString dstring;
/*
- * The command trace below is used by the "testcmdtraceCmd" command
- * to test the command tracing facilities.
+ * The command trace below is used by the "testcmdtraceCmd" command to test
+ * the command tracing facilities.
*/
static Tcl_Trace cmdTrace;
/*
- * One of the following structures exists for each command created
- * by TestdelCmd:
+ * One of the following structures exists for each command created by
+ * TestdelCmd:
*/
typedef struct DelCmd {
Tcl_Interp *interp; /* Interpreter in which command exists. */
- char *deleteCmd; /* Script to execute when command is
- * deleted. Malloc'ed. */
+ char *deleteCmd; /* Script to execute when command is deleted.
+ * Malloc'ed. */
} DelCmd;
/*
* The following is used to keep track of an encoding that invokes a Tcl
- * command.
+ * command.
*/
typedef struct TclEncoding {
@@ -99,332 +102,343 @@ typedef struct TclEncoding {
} TclEncoding;
/*
- * The counter below is used to determine if the TestsaveresultFree
- * routine was called for a result.
+ * The counter below is used to determine if the TestsaveresultFree routine
+ * was called for a result.
*/
static int freeCount;
/*
- * Boolean flag used by the "testsetmainloop" and "testexitmainloop"
- * commands.
+ * Boolean flag used by the "testsetmainloop" and "testexitmainloop" commands.
*/
+
static int exitMainLoop = 0;
/*
* Event structure used in testing the event queue management procedures.
*/
+
typedef struct TestEvent {
Tcl_Event header; /* Header common to all events */
- Tcl_Interp* interp; /* Interpreter that will handle the event */
- Tcl_Obj* command; /* Command to evaluate when the event occurs */
- Tcl_Obj* tag; /* Tag for this event used to delete it */
+ Tcl_Interp *interp; /* Interpreter that will handle the event */
+ Tcl_Obj *command; /* Command to evaluate when the event occurs */
+ Tcl_Obj *tag; /* Tag for this event used to delete it */
} TestEvent;
/*
+ * Simple detach/attach facility for testchannel cut|splice. Allow testing of
+ * channel transfer in core testsuite.
+ */
+
+typedef struct TestChannel {
+ Tcl_Channel chan; /* Detached channel */
+ struct TestChannel *nextPtr;/* Next in detached channel pool */
+} TestChannel;
+
+static TestChannel *firstDetached;
+
+/*
* Forward declarations for procedures defined later in this file:
*/
-int Tcltest_Init _ANSI_ARGS_((Tcl_Interp *interp));
-static int AsyncHandlerProc _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int code));
-static void CleanupTestSetassocdataTests _ANSI_ARGS_((
- ClientData clientData, Tcl_Interp *interp));
-static void CmdDelProc1 _ANSI_ARGS_((ClientData clientData));
-static void CmdDelProc2 _ANSI_ARGS_((ClientData clientData));
-static int CmdProc1 _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int argc, CONST char **argv));
-static int CmdProc2 _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int argc, CONST char **argv));
-static void CmdTraceDeleteProc _ANSI_ARGS_((
+int Tcltest_Init(Tcl_Interp *interp);
+static int AsyncHandlerProc(ClientData clientData,
+ Tcl_Interp *interp, int code);
+#ifdef TCL_THREADS
+static Tcl_ThreadCreateType AsyncThreadProc(ClientData);
+#endif
+static void CleanupTestSetassocdataTests(
+ 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(
ClientData clientData, Tcl_Interp *interp,
int level, char *command, Tcl_CmdProc *cmdProc,
ClientData cmdClientData, int argc,
- char **argv));
-static void CmdTraceProc _ANSI_ARGS_((ClientData clientData,
+ char **argv);
+static void CmdTraceProc(ClientData clientData,
Tcl_Interp *interp, int level, char *command,
Tcl_CmdProc *cmdProc, ClientData cmdClientData,
- int argc, char **argv));
-static int CreatedCommandProc _ANSI_ARGS_((
+ int argc, char **argv);
+static int CreatedCommandProc(
ClientData clientData, Tcl_Interp *interp,
- int argc, CONST char **argv));
-static int CreatedCommandProc2 _ANSI_ARGS_((
+ int argc, const char **argv);
+static int CreatedCommandProc2(
ClientData clientData, Tcl_Interp *interp,
- int argc, CONST char **argv));
-static void DelCallbackProc _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp));
-static int DelCmdProc _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int argc, CONST char **argv));
-static void DelDeleteProc _ANSI_ARGS_((ClientData clientData));
-static void EncodingFreeProc _ANSI_ARGS_((ClientData clientData));
-static int EncodingToUtfProc _ANSI_ARGS_((ClientData clientData,
- CONST char *src, int srcLen, int flags,
+ int argc, const char **argv);
+static void DelCallbackProc(ClientData clientData,
+ Tcl_Interp *interp);
+static int DelCmdProc(ClientData clientData,
+ Tcl_Interp *interp, int argc, const char **argv);
+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 _ANSI_ARGS_((ClientData clientData,
- CONST char *src, int srcLen, int flags,
+ int *dstCharsPtr);
+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 _ANSI_ARGS_((ClientData clientData));
-static void ExitProcOdd _ANSI_ARGS_((ClientData clientData));
-static int GetTimesCmd _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int argc, CONST char **argv));
-static void MainLoop _ANSI_ARGS_((void));
-static int NoopCmd _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int argc, CONST char **argv));
-static int NoopObjCmd _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *CONST objv[]));
-static int ObjTraceProc _ANSI_ARGS_(( ClientData clientData,
- Tcl_Interp* interp,
- int level,
- CONST char* command,
- Tcl_Command commandToken,
- int objc,
- Tcl_Obj *CONST objv[] ));
-static void ObjTraceDeleteProc _ANSI_ARGS_(( ClientData ));
-static void PrintParse _ANSI_ARGS_((Tcl_Interp *interp,
- Tcl_Parse *parsePtr));
-static void SpecialFree _ANSI_ARGS_((char *blockPtr));
-static int StaticInitProc _ANSI_ARGS_((Tcl_Interp *interp));
-static int TestaccessprocCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int argc, CONST char **argv));
-static int PretendTclpAccess _ANSI_ARGS_((CONST char *path,
- int mode));
-static int TestAccessProc1 _ANSI_ARGS_((CONST char *path,
- int mode));
-static int TestAccessProc2 _ANSI_ARGS_((CONST char *path,
- int mode));
-static int TestAccessProc3 _ANSI_ARGS_((CONST char *path,
- int mode));
-static int TestasyncCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int argc, CONST char **argv));
-static int TestcmdinfoCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int argc, CONST char **argv));
-static int TestcmdtokenCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int argc, CONST char **argv));
-static int TestcmdtraceCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int argc, CONST char **argv));
-static int TestcreatecommandCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int argc, CONST char **argv));
-static int TestdcallCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int argc, CONST char **argv));
-static int TestdelCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int argc, CONST char **argv));
-static int TestdelassocdataCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int argc, CONST char **argv));
-static int TestdstringCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int argc, CONST char **argv));
-static int TestencodingObjCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *CONST objv[]));
-static int TestevalexObjCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *CONST objv[]));
-static int TestevalobjvObjCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *CONST objv[]));
-static int TesteventObjCmd _ANSI_ARGS_((ClientData unused,
- Tcl_Interp* interp,
- int argc,
- Tcl_Obj *CONST objv[]));
-static int TesteventProc _ANSI_ARGS_((Tcl_Event* event,
- int flags));
-static int TesteventDeleteProc _ANSI_ARGS_((
- Tcl_Event* event,
- ClientData clientData));
-static int TestexithandlerCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int argc, CONST char **argv));
-static int TestexprlongCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int argc, CONST char **argv));
-static int TestexprlongobjCmd _ANSI_ARGS_((ClientData dummy,
+ int *dstCharsPtr);
+static void ExitProcEven(ClientData clientData);
+static void ExitProcOdd(ClientData clientData);
+static int GetTimesCmd(ClientData clientData,
+ Tcl_Interp *interp, int argc, const char **argv);
+static void MainLoop(void);
+static int NoopCmd(ClientData clientData,
+ Tcl_Interp *interp, int argc, const char **argv);
+static int NoopObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+static int 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 void SpecialFree(char *blockPtr);
+static int StaticInitProc(Tcl_Interp *interp);
+#undef USE_OBSOLETE_FS_HOOKS
+#ifdef USE_OBSOLETE_FS_HOOKS
+static int TestaccessprocCmd(ClientData dummy,
+ Tcl_Interp *interp, int argc, const char **argv);
+static int TestopenfilechannelprocCmd(
+ ClientData dummy, Tcl_Interp *interp, int argc,
+ const char **argv);
+static int TeststatprocCmd(ClientData dummy,
+ Tcl_Interp *interp, int argc, const char **argv);
+static int PretendTclpAccess(const char *path, int mode);
+static int TestAccessProc1(const char *path, int mode);
+static int TestAccessProc2(const char *path, int mode);
+static int TestAccessProc3(const char *path, int mode);
+static Tcl_Channel PretendTclpOpenFileChannel(
+ Tcl_Interp *interp, const char *fileName,
+ const char *modeString, int permissions);
+static Tcl_Channel TestOpenFileChannelProc1(
+ Tcl_Interp *interp, const char *fileName,
+ const char *modeString, int permissions);
+static Tcl_Channel TestOpenFileChannelProc2(
+ Tcl_Interp *interp, const char *fileName,
+ const char *modeString, int permissions);
+static Tcl_Channel TestOpenFileChannelProc3(
+ Tcl_Interp *interp, const char *fileName,
+ const char *modeString, int permissions);
+static int PretendTclpStat(const char *path, struct stat *buf);
+static int TestStatProc1(const char *path, struct stat *buf);
+static int TestStatProc2(const char *path, struct stat *buf);
+static int TestStatProc3(const char *path, struct stat *buf);
+#endif
+static int TestasyncCmd(ClientData dummy,
+ Tcl_Interp *interp, int argc, const char **argv);
+static int TestcmdinfoCmd(ClientData dummy,
+ 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,
+ 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 _ANSI_ARGS_((ClientData dummy,
+ Tcl_Obj *const objv[]);
+static int TestexprparserObjCmd(ClientData dummy,
Tcl_Interp *interp, int objc,
- Tcl_Obj *CONST objv[]));
-static int TestexprstringCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int argc, CONST char **argv));
-static int TestfileCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
-static int TestfilelinkCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
-static int TestfeventCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int argc, CONST char **argv));
-static int TestgetassocdataCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int argc, CONST char **argv));
-static int TestgetplatformCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int argc, CONST char **argv));
-static int TestgetvarfullnameCmd _ANSI_ARGS_((
+ 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 _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int argc, CONST char **argv));
-static int TestlinkCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int argc, CONST char **argv));
-static int TestlocaleCmd _ANSI_ARGS_((ClientData dummy,
+ 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 _ANSI_ARGS_((ClientData clientData,
+ Tcl_Obj *const objv[]);
+static int TestMathFunc(ClientData clientData,
Tcl_Interp *interp, Tcl_Value *args,
- Tcl_Value *resultPtr));
-static int TestMathFunc2 _ANSI_ARGS_((ClientData clientData,
+ Tcl_Value *resultPtr);
+static int TestMathFunc2(ClientData clientData,
Tcl_Interp *interp, Tcl_Value *args,
- Tcl_Value *resultPtr));
-static int TestmainthreadCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int argc, CONST char **argv));
-static int TestsetmainloopCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int argc, CONST char **argv));
-static int TestexitmainloopCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int argc, CONST char **argv));
-static Tcl_Channel PretendTclpOpenFileChannel _ANSI_ARGS_((
- Tcl_Interp *interp, CONST char *fileName,
- CONST char *modeString, int permissions));
-static Tcl_Channel TestOpenFileChannelProc1 _ANSI_ARGS_((
- Tcl_Interp *interp, CONST char *fileName,
- CONST char *modeString, int permissions));
-static Tcl_Channel TestOpenFileChannelProc2 _ANSI_ARGS_((
- Tcl_Interp *interp, CONST char *fileName,
- CONST char *modeString, int permissions));
-static Tcl_Channel TestOpenFileChannelProc3 _ANSI_ARGS_((
- Tcl_Interp *interp, CONST char *fileName,
- CONST char *modeString, int permissions));
-static int TestpanicCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int argc, CONST char **argv));
-static int TestparserObjCmd _ANSI_ARGS_((ClientData dummy,
+ 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 _ANSI_ARGS_((ClientData dummy,
+ Tcl_Obj *const objv[]);
+static int TestparsevarObjCmd(ClientData dummy,
Tcl_Interp *interp, int objc,
- Tcl_Obj *CONST objv[]));
-static int TestparsevarnameObjCmd _ANSI_ARGS_((ClientData dummy,
+ Tcl_Obj *const objv[]);
+static int TestparsevarnameObjCmd(ClientData dummy,
Tcl_Interp *interp, int objc,
- Tcl_Obj *CONST objv[]));
-static int TestregexpObjCmd _ANSI_ARGS_((ClientData dummy,
+ Tcl_Obj *const objv[]);
+static int TestregexpObjCmd(ClientData dummy,
Tcl_Interp *interp, int objc,
- Tcl_Obj *CONST objv[]));
-static void TestregexpXflags _ANSI_ARGS_((char *string,
- int length, int *cflagsPtr, int *eflagsPtr));
-static int TestsaveresultCmd _ANSI_ARGS_((ClientData dummy,
+ Tcl_Obj *const objv[]);
+static int TestreturnObjCmd(ClientData dummy,
Tcl_Interp *interp, int objc,
- Tcl_Obj *CONST objv[]));
-static void TestsaveresultFree _ANSI_ARGS_((char *blockPtr));
-static int TestsetassocdataCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int argc, CONST char **argv));
-static int TestsetCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int argc, CONST char **argv));
-static int TestseterrorcodeCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int argc, CONST char **argv));
-static int TestsetobjerrorcodeCmd _ANSI_ARGS_((
+ 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 TestopenfilechannelprocCmd _ANSI_ARGS_((
- ClientData dummy, Tcl_Interp *interp, int argc,
- CONST char **argv));
-static int TestsetplatformCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int argc, CONST char **argv));
-static int TeststaticpkgCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int argc, CONST char **argv));
-static int PretendTclpStat _ANSI_ARGS_((CONST char *path,
- Tcl_StatBuf *buf));
-static int TestStatProc1 _ANSI_ARGS_((CONST char *path,
- Tcl_StatBuf *buf));
-static int TestStatProc2 _ANSI_ARGS_((CONST char *path,
- Tcl_StatBuf *buf));
-static int TestStatProc3 _ANSI_ARGS_((CONST char *path,
- Tcl_StatBuf *buf));
-static int TeststatprocCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int argc, CONST char **argv));
-static int TesttranslatefilenameCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int argc, CONST char **argv));
-static int TestupvarCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int argc, CONST char **argv));
-static int TestWrongNumArgsObjCmd _ANSI_ARGS_((
+ 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 _ANSI_ARGS_((
+ int objc, Tcl_Obj *const objv[]);
+static int TestGetIndexFromObjStructObjCmd(
ClientData clientData, Tcl_Interp *interp,
- int objc, Tcl_Obj *CONST objv[]));
-static int TestChannelCmd _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int argc, CONST char **argv));
-static int TestChannelEventCmd _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int argc, CONST char **argv));
-/* Filesystem testing */
-
-static int TestFilesystemObjCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *CONST objv[]));
-static int TestSimpleFilesystemObjCmd _ANSI_ARGS_((
- ClientData dummy, Tcl_Interp *interp, int objc,
- Tcl_Obj *CONST objv[]));
-
-static void TestReport _ANSI_ARGS_ ((CONST char* cmd, Tcl_Obj* arg1,
- Tcl_Obj* arg2));
-
-static Tcl_Obj* TestReportGetNativePath _ANSI_ARGS_ ((
- Tcl_Obj* pathObjPtr));
-
-static int TestReportStat _ANSI_ARGS_ ((Tcl_Obj *path,
- Tcl_StatBuf *buf));
-static int TestReportAccess _ANSI_ARGS_ ((Tcl_Obj *path,
- int mode));
-static Tcl_Channel TestReportOpenFileChannel _ANSI_ARGS_ ((
+ 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 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 _ANSI_ARGS_ ((
+ int mode, int permissions);
+static int TestReportMatchInDirectory(Tcl_Interp *interp,
+ Tcl_Obj *resultPtr, Tcl_Obj *dirPtr,
+ const char *pattern, Tcl_GlobTypeData *types);
+static int TestReportChdir(Tcl_Obj *dirName);
+static int TestReportLstat(Tcl_Obj *path, Tcl_StatBuf *buf);
+static int TestReportCopyFile(Tcl_Obj *src, Tcl_Obj *dst);
+static int TestReportDeleteFile(Tcl_Obj *path);
+static int TestReportRenameFile(Tcl_Obj *src, Tcl_Obj *dst);
+static int TestReportCreateDirectory(Tcl_Obj *path);
+static int TestReportCopyDirectory(Tcl_Obj *src,
+ Tcl_Obj *dst, Tcl_Obj **errorPtr);
+static int TestReportRemoveDirectory(Tcl_Obj *path,
+ int recursive, Tcl_Obj **errorPtr);
+static int TestReportLoadFile(Tcl_Interp *interp,
+ Tcl_Obj *fileName, Tcl_LoadHandle *handlePtr,
+ Tcl_FSUnloadFileProc **unloadProcPtr);
+static Tcl_Obj * TestReportLink(Tcl_Obj *path,
+ Tcl_Obj *to, int linkType);
+static const char ** TestReportFileAttrStrings(
+ Tcl_Obj *fileName, Tcl_Obj **objPtrRef);
+static int TestReportFileAttrsGet(Tcl_Interp *interp,
+ int index, Tcl_Obj *fileName, Tcl_Obj **objPtrRef);
+static int TestReportFileAttrsSet(Tcl_Interp *interp,
+ int index, Tcl_Obj *fileName, Tcl_Obj *objPtr);
+static int TestReportUtime(Tcl_Obj *fileName,
+ struct utimbuf *tval);
+static int TestReportNormalizePath(Tcl_Interp *interp,
+ Tcl_Obj *pathPtr, int nextCheckpoint);
+static int TestReportInFilesystem(Tcl_Obj *pathPtr, ClientData *clientDataPtr);
+static void TestReportFreeInternalRep(ClientData clientData);
+static ClientData TestReportDupInternalRep(ClientData clientData);
+
+static int SimpleStat(Tcl_Obj *path, Tcl_StatBuf *buf);
+static int SimpleAccess(Tcl_Obj *path, int mode);
+static Tcl_Channel SimpleOpenFileChannel(Tcl_Interp *interp,
+ Tcl_Obj *fileName, int mode, int permissions);
+static Tcl_Obj * SimpleListVolumes(void);
+static int SimplePathInFilesystem(
+ Tcl_Obj *pathPtr, ClientData *clientDataPtr);
+static Tcl_Obj * SimpleRedirect(Tcl_Obj *pathPtr);
+static int SimpleMatchInDirectory(
Tcl_Interp *interp, Tcl_Obj *resultPtr,
- Tcl_Obj *dirPtr, CONST char *pattern,
- Tcl_GlobTypeData *types));
-static int TestReportChdir _ANSI_ARGS_ ((Tcl_Obj *dirName));
-static int TestReportLstat _ANSI_ARGS_ ((Tcl_Obj *path,
- Tcl_StatBuf *buf));
-static int TestReportCopyFile _ANSI_ARGS_ ((Tcl_Obj *src,
- Tcl_Obj *dst));
-static int TestReportDeleteFile _ANSI_ARGS_ ((Tcl_Obj *path));
-static int TestReportRenameFile _ANSI_ARGS_ ((Tcl_Obj *src,
- Tcl_Obj *dst));
-static int TestReportCreateDirectory _ANSI_ARGS_ ((Tcl_Obj *path));
-static int TestReportCopyDirectory _ANSI_ARGS_ ((Tcl_Obj *src,
- Tcl_Obj *dst, Tcl_Obj **errorPtr));
-static int TestReportRemoveDirectory _ANSI_ARGS_ ((Tcl_Obj *path,
- int recursive, Tcl_Obj **errorPtr));
-static int TestReportLoadFile _ANSI_ARGS_ ((Tcl_Interp *interp,
- Tcl_Obj *fileName,
- Tcl_LoadHandle *handlePtr,
- Tcl_FSUnloadFileProc **unloadProcPtr));
-static Tcl_Obj * TestReportLink _ANSI_ARGS_ ((Tcl_Obj *path,
- Tcl_Obj *to, int linkType));
-static CONST char** TestReportFileAttrStrings _ANSI_ARGS_ ((
- Tcl_Obj *fileName, Tcl_Obj **objPtrRef));
-static int TestReportFileAttrsGet _ANSI_ARGS_ ((Tcl_Interp *interp,
- int index, Tcl_Obj *fileName, Tcl_Obj **objPtrRef));
-static int TestReportFileAttrsSet _ANSI_ARGS_ ((Tcl_Interp *interp,
- int index, Tcl_Obj *fileName, Tcl_Obj *objPtr));
-static int TestReportUtime _ANSI_ARGS_ ((Tcl_Obj *fileName,
- struct utimbuf *tval));
-static int TestReportNormalizePath _ANSI_ARGS_ ((
- Tcl_Interp *interp, Tcl_Obj *pathPtr,
- int nextCheckpoint));
-static int TestReportInFilesystem _ANSI_ARGS_ ((Tcl_Obj *pathPtr, ClientData *clientDataPtr));
-static void TestReportFreeInternalRep _ANSI_ARGS_ ((ClientData clientData));
-static ClientData TestReportDupInternalRep _ANSI_ARGS_ ((ClientData clientData));
-
-static int SimpleStat _ANSI_ARGS_ ((Tcl_Obj *path,
- Tcl_StatBuf *buf));
-static int SimpleAccess _ANSI_ARGS_ ((Tcl_Obj *path,
- int mode));
-static Tcl_Channel SimpleOpenFileChannel _ANSI_ARGS_ ((
- Tcl_Interp *interp, Tcl_Obj *fileName,
- int mode, int permissions));
-static Tcl_Obj* SimpleListVolumes _ANSI_ARGS_ ((void));
-static int SimplePathInFilesystem _ANSI_ARGS_ ((
- Tcl_Obj *pathPtr, ClientData *clientDataPtr));
-static Tcl_Obj* SimpleCopy _ANSI_ARGS_ ((Tcl_Obj *pathPtr));
-static int TestNumUtfCharsCmd _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *CONST objv[]));
+ Tcl_Obj *dirPtr, const char *pattern,
+ Tcl_GlobTypeData *types);
+static int TestNumUtfCharsCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+static int TestHashSystemHashCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
static Tcl_Filesystem testReportingFilesystem = {
"reporting",
@@ -449,11 +463,11 @@ static Tcl_Filesystem testReportingFilesystem = {
&TestReportFileAttrsGet,
&TestReportFileAttrsSet,
&TestReportCreateDirectory,
- &TestReportRemoveDirectory,
+ &TestReportRemoveDirectory,
&TestReportDeleteFile,
&TestReportCopyFile,
&TestReportRenameFile,
- &TestReportCopyDirectory,
+ &TestReportCopyDirectory,
&TestReportLstat,
&TestReportLoadFile,
NULL /* cwd */,
@@ -481,7 +495,7 @@ static Tcl_Filesystem simpleFilesystem = {
&SimpleStat,
&SimpleAccess,
&SimpleOpenFileChannel,
- NULL,
+ &SimpleMatchInDirectory,
NULL,
/* We choose not to support symbolic links inside our vfs's */
NULL,
@@ -490,14 +504,14 @@ static Tcl_Filesystem simpleFilesystem = {
NULL,
NULL,
NULL,
- NULL,
+ NULL,
NULL,
/* No copy file - fallback will occur at Tcl level */
NULL,
/* No rename file - fallback will occur at Tcl level */
NULL,
/* No copy directory - fallback will occur at Tcl level */
- NULL,
+ NULL,
/* Use stat for lstat */
NULL,
/* No load - fallback on core implementation */
@@ -510,25 +524,25 @@ static Tcl_Filesystem simpleFilesystem = {
/*
* External (platform specific) initialization routine, these declarations
- * explicitly don't use EXTERN since this code does not get compiled
- * into the library:
+ * explicitly don't use EXTERN since this code does not get compiled into the
+ * library:
*/
-extern int TclplatformtestInit _ANSI_ARGS_((Tcl_Interp *interp));
-extern int TclThread_Init _ANSI_ARGS_((Tcl_Interp *interp));
+extern int TclplatformtestInit(Tcl_Interp *interp);
+extern int TclThread_Init(Tcl_Interp *interp);
/*
*----------------------------------------------------------------------
*
* Tcltest_Init --
*
- * This procedure performs application-specific initialization.
- * Most applications, especially those that incorporate additional
- * packages, will have their own version of this procedure.
+ * 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.
+ * 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.
@@ -537,159 +551,157 @@ extern int TclThread_Init _ANSI_ARGS_((Tcl_Interp *interp));
*/
int
-Tcltest_Init(interp)
- Tcl_Interp *interp; /* Interpreter for application. */
+Tcltest_Init(
+ Tcl_Interp *interp) /* Interpreter for application. */
{
Tcl_ValueType t3ArgTypes[2];
Tcl_Obj *listPtr;
Tcl_Obj **objv;
int objc, index;
- static CONST char *specialOptions[] = {
+ static const char *specialOptions[] = {
"-appinitprocerror", "-appinitprocdeleteinterp",
- "-appinitprocclosestderr", "-appinitprocsetrcfile", (char *) NULL
+ "-appinitprocclosestderr", "-appinitprocsetrcfile", NULL
};
-#ifndef TCL_TIP268
- if (Tcl_PkgProvide(interp, "Tcltest", TCL_VERSION) == TCL_ERROR) {
-#else
/* TIP #268: Full patchlevel instead of just major.minor */
+
if (Tcl_PkgProvide(interp, "Tcltest", TCL_PATCH_LEVEL) == TCL_ERROR) {
-#endif
- return TCL_ERROR;
+ return TCL_ERROR;
}
/*
* Create additional commands and math functions for testing Tcl.
*/
- Tcl_CreateCommand(interp, "gettimes", GetTimesCmd, (ClientData) 0,
- (Tcl_CmdDeleteProc *) NULL);
- Tcl_CreateCommand(interp, "noop", NoopCmd, (ClientData) 0,
- (Tcl_CmdDeleteProc *) NULL);
- Tcl_CreateObjCommand(interp, "noop", NoopObjCmd, (ClientData) 0,
- (Tcl_CmdDeleteProc *) 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, (Tcl_CmdDeleteProc *) NULL);
- Tcl_CreateObjCommand(interp, "testfilesystem", TestFilesystemObjCmd,
- (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
- Tcl_CreateObjCommand(interp, "testsimplefilesystem", TestSimpleFilesystemObjCmd,
- (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+ (ClientData) 0, NULL);
+ Tcl_CreateObjCommand(interp, "testfilesystem", TestFilesystemObjCmd,
+ (ClientData) 0, NULL);
+ Tcl_CreateObjCommand(interp, "testsimplefilesystem", TestSimpleFilesystemObjCmd,
+ (ClientData) 0, NULL);
Tcl_CreateObjCommand(interp, "testgetindexfromobjstruct",
- TestGetIndexFromObjStructObjCmd, (ClientData) 0,
- (Tcl_CmdDeleteProc *) NULL);
+ TestGetIndexFromObjStructObjCmd, (ClientData) 0, NULL);
+#ifdef USE_OBSOLETE_FS_HOOKS
Tcl_CreateCommand(interp, "testaccessproc", TestaccessprocCmd, (ClientData) 0,
- (Tcl_CmdDeleteProc *) NULL);
- Tcl_CreateCommand(interp, "testasync", TestasyncCmd, (ClientData) 0,
- (Tcl_CmdDeleteProc *) NULL);
+ NULL);
+ Tcl_CreateCommand(interp, "testopenfilechannelproc",
+ TestopenfilechannelprocCmd, (ClientData) 0, NULL);
+ Tcl_CreateCommand(interp, "teststatproc", TeststatprocCmd, (ClientData) 0,
+ NULL);
+#endif
+ Tcl_CreateCommand(interp, "testasync", TestasyncCmd, (ClientData) 0, NULL);
Tcl_CreateCommand(interp, "testchannel", TestChannelCmd,
- (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+ (ClientData) 0, NULL);
Tcl_CreateCommand(interp, "testchannelevent", TestChannelEventCmd,
- (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+ (ClientData) 0, NULL);
Tcl_CreateCommand(interp, "testcmdtoken", TestcmdtokenCmd, (ClientData) 0,
- (Tcl_CmdDeleteProc *) NULL);
+ NULL);
Tcl_CreateCommand(interp, "testcmdinfo", TestcmdinfoCmd, (ClientData) 0,
- (Tcl_CmdDeleteProc *) NULL);
+ NULL);
Tcl_CreateCommand(interp, "testcmdtrace", TestcmdtraceCmd,
- (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+ (ClientData) 0, NULL);
+ Tcl_CreateCommand(interp, "testconcatobj", TestconcatobjCmd,
+ (ClientData) 0, NULL);
Tcl_CreateCommand(interp, "testcreatecommand", TestcreatecommandCmd,
- (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
- Tcl_CreateCommand(interp, "testdcall", TestdcallCmd, (ClientData) 0,
- (Tcl_CmdDeleteProc *) NULL);
- Tcl_CreateCommand(interp, "testdel", TestdelCmd, (ClientData) 0,
- (Tcl_CmdDeleteProc *) 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,
- (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+ (ClientData) 0, NULL);
+ Tcl_CreateObjCommand(interp, "testdoubledigits", TestdoubledigitsObjCmd,
+ NULL, NULL);
Tcl_DStringInit(&dstring);
Tcl_CreateCommand(interp, "testdstring", TestdstringCmd, (ClientData) 0,
- (Tcl_CmdDeleteProc *) NULL);
+ NULL);
Tcl_CreateObjCommand(interp, "testencoding", TestencodingObjCmd, (ClientData) 0,
- (Tcl_CmdDeleteProc *) NULL);
+ NULL);
Tcl_CreateObjCommand(interp, "testevalex", TestevalexObjCmd,
- (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+ (ClientData) 0, NULL);
Tcl_CreateObjCommand(interp, "testevalobjv", TestevalobjvObjCmd,
- (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
- Tcl_CreateObjCommand( interp, "testevent", TesteventObjCmd,
- (ClientData) 0, (Tcl_CmdDeleteProc*) NULL );
+ (ClientData) 0, NULL);
+ Tcl_CreateObjCommand(interp, "testevent", TesteventObjCmd,
+ (ClientData) 0, NULL);
Tcl_CreateCommand(interp, "testexithandler", TestexithandlerCmd,
- (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+ (ClientData) 0, NULL);
Tcl_CreateCommand(interp, "testexprlong", TestexprlongCmd,
- (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+ (ClientData) 0, NULL);
Tcl_CreateObjCommand(interp, "testexprlongobj", TestexprlongobjCmd,
- (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+ (ClientData) 0, NULL);
+ Tcl_CreateCommand(interp, "testexprdouble", TestexprdoubleCmd,
+ (ClientData) 0, NULL);
+ Tcl_CreateObjCommand(interp, "testexprdoubleobj", TestexprdoubleobjCmd,
+ (ClientData) 0, NULL);
Tcl_CreateObjCommand(interp, "testexprparser", TestexprparserObjCmd,
- (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+ (ClientData) 0, NULL);
Tcl_CreateCommand(interp, "testexprstring", TestexprstringCmd,
- (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+ (ClientData) 0, NULL);
Tcl_CreateCommand(interp, "testfevent", TestfeventCmd, (ClientData) 0,
- (Tcl_CmdDeleteProc *) NULL);
- Tcl_CreateObjCommand(interp, "testfilelink", TestfilelinkCmd,
- (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+ NULL);
+ Tcl_CreateObjCommand(interp, "testfilelink", TestfilelinkCmd,
+ (ClientData) 0, NULL);
Tcl_CreateObjCommand(interp, "testfile", TestfileCmd,
- (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+ (ClientData) 0, NULL);
+ Tcl_CreateObjCommand(interp, "testhashsystemhash",
+ TestHashSystemHashCmd, (ClientData) 0, NULL);
Tcl_CreateCommand(interp, "testgetassocdata", TestgetassocdataCmd,
- (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+ (ClientData) 0, NULL);
+ Tcl_CreateCommand(interp, "testgetint", TestgetintCmd,
+ (ClientData) 0, NULL);
Tcl_CreateCommand(interp, "testgetplatform", TestgetplatformCmd,
- (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+ (ClientData) 0, NULL);
Tcl_CreateObjCommand(interp, "testgetvarfullname",
- TestgetvarfullnameCmd, (ClientData) 0,
- (Tcl_CmdDeleteProc *) NULL);
+ TestgetvarfullnameCmd, (ClientData) 0, NULL);
Tcl_CreateCommand(interp, "testinterpdelete", TestinterpdeleteCmd,
- (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
- Tcl_CreateCommand(interp, "testlink", TestlinkCmd, (ClientData) 0,
- (Tcl_CmdDeleteProc *) NULL);
+ (ClientData) 0, NULL);
+ Tcl_CreateCommand(interp, "testlink", TestlinkCmd, (ClientData) 0, NULL);
Tcl_CreateObjCommand(interp, "testlocale", TestlocaleCmd, (ClientData) 0,
- (Tcl_CmdDeleteProc *) NULL);
- Tcl_CreateCommand(interp, "testopenfilechannelproc",
- TestopenfilechannelprocCmd, (ClientData) 0,
- (Tcl_CmdDeleteProc *) NULL);
- Tcl_CreateCommand(interp, "testpanic", TestpanicCmd, (ClientData) 0,
- (Tcl_CmdDeleteProc *) NULL);
+ NULL);
+ Tcl_CreateCommand(interp, "testpanic", TestpanicCmd, (ClientData) 0, NULL);
Tcl_CreateObjCommand(interp, "testparser", TestparserObjCmd,
- (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+ (ClientData) 0, NULL);
Tcl_CreateObjCommand(interp, "testparsevar", TestparsevarObjCmd,
- (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+ (ClientData) 0, NULL);
Tcl_CreateObjCommand(interp, "testparsevarname", TestparsevarnameObjCmd,
- (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+ (ClientData) 0, NULL);
Tcl_CreateObjCommand(interp, "testregexp", TestregexpObjCmd,
- (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+ (ClientData) 0, NULL);
+ Tcl_CreateObjCommand(interp, "testreturn", TestreturnObjCmd,
+ (ClientData) 0, NULL);
Tcl_CreateObjCommand(interp, "testsaveresult", TestsaveresultCmd,
- (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+ (ClientData) 0, NULL);
Tcl_CreateCommand(interp, "testsetassocdata", TestsetassocdataCmd,
- (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+ (ClientData) 0, NULL);
Tcl_CreateCommand(interp, "testsetnoerr", TestsetCmd,
- (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+ (ClientData) 0, NULL);
Tcl_CreateCommand(interp, "testseterr", TestsetCmd,
- (ClientData) TCL_LEAVE_ERR_MSG, (Tcl_CmdDeleteProc *) NULL);
+ (ClientData) TCL_LEAVE_ERR_MSG, NULL);
+ Tcl_CreateCommand(interp, "testset2", Testset2Cmd,
+ (ClientData) TCL_LEAVE_ERR_MSG, NULL);
Tcl_CreateCommand(interp, "testseterrorcode", TestseterrorcodeCmd,
- (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
- Tcl_CreateObjCommand(interp, "testsetobjerrorcode",
- TestsetobjerrorcodeCmd, (ClientData) 0,
- (Tcl_CmdDeleteProc *) NULL);
+ (ClientData) 0, NULL);
+ Tcl_CreateObjCommand(interp, "testsetobjerrorcode",
+ TestsetobjerrorcodeCmd, (ClientData) 0, NULL);
Tcl_CreateObjCommand(interp, "testnumutfchars",
- TestNumUtfCharsCmd, (ClientData) 0,
- (Tcl_CmdDeleteProc *) NULL);
+ TestNumUtfCharsCmd, (ClientData) 0, NULL);
Tcl_CreateCommand(interp, "testsetplatform", TestsetplatformCmd,
- (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+ (ClientData) 0, NULL);
Tcl_CreateCommand(interp, "teststaticpkg", TeststaticpkgCmd,
- (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+ (ClientData) 0, NULL);
Tcl_CreateCommand(interp, "testtranslatefilename",
- TesttranslatefilenameCmd, (ClientData) 0,
- (Tcl_CmdDeleteProc *) NULL);
- Tcl_CreateCommand(interp, "testupvar", TestupvarCmd, (ClientData) 0,
- (Tcl_CmdDeleteProc *) NULL);
- Tcl_CreateMathFunc(interp, "T1", 0, (Tcl_ValueType *) NULL, TestMathFunc,
- (ClientData) 123);
- Tcl_CreateMathFunc(interp, "T2", 0, (Tcl_ValueType *) NULL, TestMathFunc,
- (ClientData) 345);
- Tcl_CreateCommand(interp, "teststatproc", TeststatprocCmd, (ClientData) 0,
- (Tcl_CmdDeleteProc *) 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,
- (Tcl_CmdDeleteProc *) NULL);
+ NULL);
Tcl_CreateCommand(interp, "testsetmainloop", TestsetmainloopCmd,
- (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);
+ (ClientData) NULL, NULL);
Tcl_CreateCommand(interp, "testexitmainloop", TestexitmainloopCmd,
- (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);
+ (ClientData) NULL, NULL);
t3ArgTypes[0] = TCL_EITHER;
t3ArgTypes[1] = TCL_EITHER;
Tcl_CreateMathFunc(interp, "T3", 2, t3ArgTypes, TestMathFunc2,
@@ -707,40 +719,37 @@ Tcltest_Init(interp)
listPtr = Tcl_GetVar2Ex(interp, "argv", NULL, TCL_GLOBAL_ONLY);
if (listPtr != NULL) {
- if (Tcl_ListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) {
+ if (Tcl_ListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) {
return TCL_ERROR;
- }
- if (objc && (Tcl_GetIndexFromObj(NULL, objv[0], specialOptions, NULL,
+ }
+ if (objc && (Tcl_GetIndexFromObj(NULL, objv[0], specialOptions, NULL,
TCL_EXACT, &index) == TCL_OK)) {
switch (index) {
- case 0: {
- return TCL_ERROR;
- }
- case 1: {
- Tcl_DeleteInterp(interp);
- return TCL_ERROR;
- }
- case 2: {
- int mode;
- Tcl_UnregisterChannel(interp,
- Tcl_GetChannel(interp, "stderr", &mode));
- return TCL_ERROR;
- }
- case 3: {
- if (objc-1) {
- Tcl_SetVar2Ex(interp, "tcl_rcFileName", NULL,
- objv[1], TCL_GLOBAL_ONLY);
- }
- return TCL_ERROR;
- }
+ case 0:
+ return TCL_ERROR;
+ case 1:
+ Tcl_DeleteInterp(interp);
+ return TCL_ERROR;
+ case 2: {
+ int mode;
+ Tcl_UnregisterChannel(interp,
+ Tcl_GetChannel(interp, "stderr", &mode));
+ return TCL_ERROR;
}
- }
+ case 3:
+ if (objc-1) {
+ Tcl_SetVar2Ex(interp, "tcl_rcFileName", NULL, objv[1],
+ TCL_GLOBAL_ONLY);
+ }
+ return TCL_ERROR;
+ }
+ }
}
-
+
/*
* And finally add any platform specific test commands.
*/
-
+
return TclplatformtestInit(interp);
}
@@ -763,11 +772,11 @@ Tcltest_Init(interp)
/* ARGSUSED */
static int
-TestasyncCmd(dummy, interp, argc, argv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- CONST char **argv; /* Argument strings. */
+TestasyncCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int argc, /* Number of arguments. */
+ const char **argv) /* Argument strings. */
{
TestAsyncHandler *asyncPtr, *prevPtr;
int id, code;
@@ -784,14 +793,16 @@ TestasyncCmd(dummy, interp, argc, argv)
goto wrongNumArgs;
}
asyncPtr = (TestAsyncHandler *) ckalloc(sizeof(TestAsyncHandler));
+ asyncPtr->command = ckalloc(strlen(argv[2]) + 1);
+ strcpy(asyncPtr->command, argv[2]);
+ Tcl_MutexLock(&asyncTestMutex);
asyncPtr->id = nextId;
nextId++;
asyncPtr->handler = Tcl_AsyncCreate(AsyncHandlerProc,
- (ClientData) asyncPtr);
- asyncPtr->command = (char *) ckalloc((unsigned) (strlen(argv[2]) + 1));
- strcpy(asyncPtr->command, argv[2]);
+ INT2PTR(asyncPtr->id));
asyncPtr->nextPtr = firstHandler;
firstHandler = asyncPtr;
+ Tcl_MutexUnlock(&asyncTestMutex);
TclFormatInt(buf, asyncPtr->id);
Tcl_SetResult(interp, buf, TCL_VOLATILE);
} else if (strcmp(argv[1], "delete") == 0) {
@@ -826,6 +837,7 @@ TestasyncCmd(dummy, interp, argc, argv)
ckfree((char *) asyncPtr);
break;
}
+ Tcl_MutexUnlock(&asyncTestMutex);
} else if (strcmp(argv[1], "mark") == 0) {
if (argc != 5) {
goto wrongNumArgs;
@@ -843,26 +855,66 @@ TestasyncCmd(dummy, interp, argc, argv)
}
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;
+ }
+ if (Tcl_GetInt(interp, argv[2], &id) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ for (asyncPtr = firstHandler; asyncPtr != NULL;
+ asyncPtr = asyncPtr->nextPtr) {
+ if (asyncPtr->id == id) {
+ Tcl_ThreadId threadID;
+ if (Tcl_CreateThread(&threadID, AsyncThreadProc,
+ (ClientData) INT2PTR(id), TCL_THREAD_STACK_DEFAULT,
+ TCL_THREAD_NOFLAGS) != TCL_OK) {
+ Tcl_SetResult(interp, "can't create thread", TCL_STATIC);
+ return TCL_ERROR;
+ }
+ break;
+ }
+ }
} else {
Tcl_AppendResult(interp, "bad option \"", argv[1],
- "\": must be create, delete, int, or mark",
- (char *) 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(clientData, interp, code)
- ClientData clientData; /* Pointer to TestAsyncHandler structure. */
- Tcl_Interp *interp; /* Interpreter in which command was
+AsyncHandlerProc(
+ ClientData clientData, /* If of TestAsyncHandler structure.
+ * in global list. */
+ Tcl_Interp *interp, /* Interpreter in which command was
* executed, or NULL. */
- int code; /* Current return code from command. */
+ int code) /* Current return code from command. */
{
- TestAsyncHandler *asyncPtr = (TestAsyncHandler *) clientData;
- CONST char *listArgv[4], *cmd;
+ TestAsyncHandler *asyncPtr;
+ int id = PTR2INT(clientData);
+ const char *listArgv[4], *cmd;
char string[TCL_INTEGER_SPACE];
+ Tcl_MutexLock(&asyncTestMutex);
+ for (asyncPtr = firstHandler; asyncPtr != NULL;
+ asyncPtr = asyncPtr->nextPtr) {
+ if (asyncPtr->id == id) break;
+ }
+ Tcl_MutexUnlock(&asyncTestMutex);
+
+ if (!asyncPtr) {
+ /* Woops - this one was deleted between the AsyncMark and now */
+ return TCL_OK;
+ }
+
TclFormatInt(string, code);
listArgv[0] = asyncPtr->command;
listArgv[1] = Tcl_GetString(Tcl_GetObjResult(interp));
@@ -873,9 +925,8 @@ AsyncHandlerProc(clientData, interp, code)
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.
+ * this should not happen, but by definition of how async handlers are
+ * invoked, it's possible. Better error checking is needed here.
*/
}
ckfree((char *)cmd);
@@ -885,11 +936,51 @@ AsyncHandlerProc(clientData, interp, code)
/*
*----------------------------------------------------------------------
*
+ * AsyncThreadProc --
+ *
+ * Delivers an asynchronous event to a handler in another thread.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Invokes Tcl_AsyncMark on the handler
+ *
+ *----------------------------------------------------------------------
+ */
+
+#ifdef TCL_THREADS
+static Tcl_ThreadCreateType
+AsyncThreadProc(
+ ClientData clientData) /* Parameter is the id of a
+ * TestAsyncHandler, defined above. */
+{
+ TestAsyncHandler *asyncPtr;
+ int id = PTR2INT(clientData);
+
+ Tcl_Sleep(1);
+ Tcl_MutexLock(&asyncTestMutex);
+ for (asyncPtr = firstHandler; asyncPtr != NULL;
+ asyncPtr = asyncPtr->nextPtr) {
+ if (asyncPtr->id == id) {
+ Tcl_AsyncMark(asyncPtr->handler);
+ break;
+ }
+ }
+ Tcl_MutexUnlock(&asyncTestMutex);
+ Tcl_ExitThread(TCL_OK);
+ TCL_THREAD_CREATE_RETURN;
+}
+#endif
+
+/*
+ *----------------------------------------------------------------------
+ *
* TestcmdinfoCmd --
*
- * This procedure implements the "testcmdinfo" command. It is used
- * to test Tcl_GetCommandInfo, Tcl_SetCommandInfo, and command creation
- * and deletion.
+ * This procedure implements the "testcmdinfo" command. It is used to
+ * test Tcl_GetCommandInfo, Tcl_SetCommandInfo, and command creation and
+ * deletion.
*
* Results:
* A standard Tcl result.
@@ -902,17 +993,17 @@ AsyncHandlerProc(clientData, interp, code)
/* ARGSUSED */
static int
-TestcmdinfoCmd(dummy, interp, argc, argv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- CONST char **argv; /* Argument strings. */
+TestcmdinfoCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int argc, /* Number of arguments. */
+ const char **argv) /* Argument strings. */
{
Tcl_CmdInfo info;
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " option cmdName\"", (char *) NULL);
+ " option cmdName\"", NULL);
return TCL_ERROR;
}
if (strcmp(argv[1], "create") == 0) {
@@ -929,34 +1020,33 @@ TestcmdinfoCmd(dummy, interp, argc, argv)
}
if (info.proc == CmdProc1) {
Tcl_AppendResult(interp, "CmdProc1", " ",
- (char *) info.clientData, (char *) NULL);
+ (char *) info.clientData, NULL);
} else if (info.proc == CmdProc2) {
Tcl_AppendResult(interp, "CmdProc2", " ",
- (char *) info.clientData, (char *) NULL);
+ (char *) info.clientData, NULL);
} else {
- Tcl_AppendResult(interp, "unknown", (char *) NULL);
+ Tcl_AppendResult(interp, "unknown", NULL);
}
if (info.deleteProc == CmdDelProc1) {
Tcl_AppendResult(interp, " CmdDelProc1", " ",
- (char *) info.deleteData, (char *) NULL);
+ (char *) info.deleteData, NULL);
} else if (info.deleteProc == CmdDelProc2) {
Tcl_AppendResult(interp, " CmdDelProc2", " ",
- (char *) info.deleteData, (char *) NULL);
+ (char *) info.deleteData, NULL);
} else {
- Tcl_AppendResult(interp, " unknown", (char *) NULL);
+ Tcl_AppendResult(interp, " unknown", NULL);
}
- Tcl_AppendResult(interp, " ", info.namespacePtr->fullName,
- (char *) NULL);
+ Tcl_AppendResult(interp, " ", info.namespacePtr->fullName, NULL);
if (info.isNativeObjectProc) {
- Tcl_AppendResult(interp, " nativeObjectProc", (char *) NULL);
+ Tcl_AppendResult(interp, " nativeObjectProc", NULL);
} else {
- Tcl_AppendResult(interp, " stringProc", (char *) NULL);
+ Tcl_AppendResult(interp, " stringProc", NULL);
}
} else if (strcmp(argv[1], "modify") == 0) {
info.proc = CmdProc2;
info.clientData = (ClientData) "new_command_data";
info.objProc = NULL;
- info.objClientData = (ClientData) NULL;
+ info.objClientData = (ClientData) NULL;
info.deleteProc = CmdDelProc2;
info.deleteData = (ClientData) "new_delete_data";
if (Tcl_SetCommandInfo(interp, argv[2], &info) == 0) {
@@ -966,8 +1056,7 @@ TestcmdinfoCmd(dummy, interp, argc, argv)
}
} else {
Tcl_AppendResult(interp, "bad option \"", argv[1],
- "\": must be create, delete, get, or modify",
- (char *) NULL);
+ "\": must be create, delete, get, or modify", NULL);
return TCL_ERROR;
}
return TCL_OK;
@@ -975,33 +1064,31 @@ TestcmdinfoCmd(dummy, interp, argc, argv)
/*ARGSUSED*/
static int
-CmdProc1(clientData, interp, argc, argv)
- ClientData clientData; /* String to return. */
- Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- CONST char **argv; /* Argument strings. */
-{
- Tcl_AppendResult(interp, "CmdProc1 ", (char *) clientData,
- (char *) NULL);
+CmdProc1(
+ ClientData clientData, /* String to return. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int argc, /* Number of arguments. */
+ const char **argv) /* Argument strings. */
+{
+ Tcl_AppendResult(interp, "CmdProc1 ", (char *) clientData, NULL);
return TCL_OK;
}
/*ARGSUSED*/
static int
-CmdProc2(clientData, interp, argc, argv)
- ClientData clientData; /* String to return. */
- Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- CONST char **argv; /* Argument strings. */
-{
- Tcl_AppendResult(interp, "CmdProc2 ", (char *) clientData,
- (char *) NULL);
+CmdProc2(
+ ClientData clientData, /* String to return. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int argc, /* Number of arguments. */
+ const char **argv) /* Argument strings. */
+{
+ Tcl_AppendResult(interp, "CmdProc2 ", (char *) clientData, NULL);
return TCL_OK;
}
static void
-CmdDelProc1(clientData)
- ClientData clientData; /* String to save. */
+CmdDelProc1(
+ ClientData clientData) /* String to save. */
{
Tcl_DStringInit(&delString);
Tcl_DStringAppend(&delString, "CmdDelProc1 ", -1);
@@ -1009,8 +1096,8 @@ CmdDelProc1(clientData)
}
static void
-CmdDelProc2(clientData)
- ClientData clientData; /* String to save. */
+CmdDelProc2(
+ ClientData clientData) /* String to save. */
{
Tcl_DStringInit(&delString);
Tcl_DStringAppend(&delString, "CmdDelProc2 ", -1);
@@ -1022,9 +1109,8 @@ CmdDelProc2(clientData)
*
* TestcmdtokenCmd --
*
- * This procedure implements the "testcmdtoken" command. It is used
- * to test Tcl_Command tokens and procedures such as
- * Tcl_GetCommandFullName.
+ * This procedure implements the "testcmdtoken" command. It is used to
+ * test Tcl_Command tokens and procedures such as Tcl_GetCommandFullName.
*
* Results:
* A standard Tcl result.
@@ -1037,11 +1123,11 @@ CmdDelProc2(clientData)
/* ARGSUSED */
static int
-TestcmdtokenCmd(dummy, interp, argc, argv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- CONST char **argv; /* Argument strings. */
+TestcmdtokenCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int argc, /* Number of arguments. */
+ const char **argv) /* Argument strings. */
{
Tcl_Command token;
int *l;
@@ -1049,20 +1135,20 @@ TestcmdtokenCmd(dummy, interp, argc, argv)
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " option arg\"", (char *) NULL);
+ " option arg\"", NULL);
return TCL_ERROR;
}
if (strcmp(argv[1], "create") == 0) {
token = Tcl_CreateCommand(interp, argv[2], CmdProc1,
- (ClientData) "original", (Tcl_CmdDeleteProc *) NULL);
- sprintf(buf, "%p", (VOID *)token);
+ (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],
- "\"", (char *) NULL);
+ "\"", NULL);
return TCL_ERROR;
}
@@ -1070,12 +1156,12 @@ TestcmdtokenCmd(dummy, interp, argc, argv)
Tcl_GetCommandFullName(interp, (Tcl_Command) l, objPtr);
Tcl_AppendElement(interp,
- Tcl_GetCommandName(interp, (Tcl_Command) l));
+ Tcl_GetCommandName(interp, (Tcl_Command) l));
Tcl_AppendElement(interp, Tcl_GetString(objPtr));
Tcl_DecrRefCount(objPtr);
} else {
Tcl_AppendResult(interp, "bad option \"", argv[1],
- "\": must be create or name", (char *) NULL);
+ "\": must be create or name", NULL);
return TCL_ERROR;
}
return TCL_OK;
@@ -1101,25 +1187,25 @@ TestcmdtokenCmd(dummy, interp, argc, argv)
/* ARGSUSED */
static int
-TestcmdtraceCmd(dummy, interp, argc, argv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- CONST char **argv; /* Argument strings. */
+TestcmdtraceCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int argc, /* Number of arguments. */
+ const char **argv) /* Argument strings. */
{
Tcl_DString buffer;
int result;
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " option script\"", (char *) NULL);
+ " option script\"", NULL);
return TCL_ERROR;
}
if (strcmp(argv[1], "tracetest") == 0) {
Tcl_DStringInit(&buffer);
cmdTrace = Tcl_CreateTrace(interp, 50000,
- (Tcl_CmdTraceProc *) CmdTraceProc, (ClientData) &buffer);
+ (Tcl_CmdTraceProc *) CmdTraceProc, (ClientData) &buffer);
result = Tcl_Eval(interp, argv[2]);
if (result == TCL_OK) {
Tcl_ResetResult(interp);
@@ -1130,13 +1216,13 @@ TestcmdtraceCmd(dummy, interp, argc, argv)
} else if (strcmp(argv[1], "deletetest") == 0) {
/*
* 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
+ * called. Note that this trace procedure removes itself as a further
+ * check of the robustness of the trace proc calling code in
* TclExecuteByteCode.
*/
-
+
cmdTrace = Tcl_CreateTrace(interp, 50000,
- (Tcl_CmdTraceProc *) CmdTraceDeleteProc, (ClientData) NULL);
+ (Tcl_CmdTraceProc *) CmdTraceDeleteProc, (ClientData) NULL);
Tcl_Eval(interp, argv[2]);
} else if (strcmp(argv[1], "leveltest") == 0) {
Interp *iPtr = (Interp *) interp;
@@ -1150,26 +1236,26 @@ TestcmdtraceCmd(dummy, interp, argc, argv)
}
Tcl_DeleteTrace(interp, cmdTrace);
Tcl_DStringFree(&buffer);
- } else if ( strcmp(argv[1], "resulttest" ) == 0 ) {
+ } else if (strcmp(argv[1], "resulttest") == 0) {
/* Create an object-based trace, then eval a script. This is used
* to test return codes other than TCL_OK from the trace engine.
*/
+
static int deleteCalled;
+
deleteCalled = 0;
- cmdTrace = Tcl_CreateObjTrace( interp, 50000,
- TCL_ALLOW_INLINE_COMPILATION,
- ObjTraceProc,
- (ClientData) &deleteCalled,
- ObjTraceDeleteProc );
- result = Tcl_Eval( interp, argv[ 2 ] );
- Tcl_DeleteTrace( interp, cmdTrace );
- if ( !deleteCalled ) {
- Tcl_SetResult( interp, "Delete wasn't called", TCL_STATIC );
+ cmdTrace = Tcl_CreateObjTrace(interp, 50000,
+ TCL_ALLOW_INLINE_COMPILATION, ObjTraceProc,
+ (ClientData) &deleteCalled, ObjTraceDeleteProc);
+ result = Tcl_Eval(interp, argv[2]);
+ Tcl_DeleteTrace(interp, cmdTrace);
+ if (!deleteCalled) {
+ Tcl_SetResult(interp, "Delete wasn't called", TCL_STATIC);
return TCL_ERROR;
} else {
return result;
}
- } else if ( strcmp(argv[1], "doubletest" ) == 0 ) {
+ } else if (strcmp(argv[1], "doubletest") == 0) {
Tcl_Trace t1, t2;
Tcl_DStringInit(&buffer);
@@ -1187,28 +1273,26 @@ TestcmdtraceCmd(dummy, interp, argc, argv)
Tcl_DStringFree(&buffer);
} else {
Tcl_AppendResult(interp, "bad option \"", argv[1],
- "\": must be tracetest, deletetest, doubletest or resulttest",
- (char *) NULL);
+ "\": must be tracetest, deletetest, doubletest or resulttest", NULL);
return TCL_ERROR;
}
return TCL_OK;
}
static void
-CmdTraceProc(clientData, interp, level, command, cmdProc, cmdClientData,
- argc, argv)
- ClientData clientData; /* Pointer to buffer in which the
+CmdTraceProc(
+ ClientData clientData, /* Pointer to buffer in which the
* command and arguments are appended.
* Accumulates test result. */
- Tcl_Interp *interp; /* Current interpreter. */
- int level; /* Current trace level. */
- char *command; /* The command being traced (after
+ Tcl_Interp *interp, /* Current interpreter. */
+ int level, /* Current trace level. */
+ char *command, /* The command being traced (after
* substitutions). */
- Tcl_CmdProc *cmdProc; /* Points to command's command procedure. */
- ClientData cmdClientData; /* Client data associated with command
+ Tcl_CmdProc *cmdProc, /* Points to command's command procedure. */
+ ClientData cmdClientData, /* Client data associated with command
* procedure. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ int argc, /* Number of arguments. */
+ char **argv) /* Argument strings. */
{
Tcl_DString *bufPtr = (Tcl_DString *) clientData;
int i;
@@ -1223,49 +1307,49 @@ CmdTraceProc(clientData, interp, level, command, cmdProc, cmdClientData,
}
static void
-CmdTraceDeleteProc(clientData, interp, level, command, cmdProc,
- cmdClientData, argc, argv)
- ClientData clientData; /* Unused. */
- Tcl_Interp *interp; /* Current interpreter. */
- int level; /* Current trace level. */
- char *command; /* The command being traced (after
+CmdTraceDeleteProc(
+ ClientData clientData, /* Unused. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int level, /* Current trace level. */
+ char *command, /* The command being traced (after
* substitutions). */
- Tcl_CmdProc *cmdProc; /* Points to command's command procedure. */
- ClientData cmdClientData; /* Client data associated with command
+ Tcl_CmdProc *cmdProc, /* Points to command's command procedure. */
+ ClientData cmdClientData, /* Client data associated with command
* procedure. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ int argc, /* Number of arguments. */
+ char **argv) /* Argument strings. */
{
/*
- * Remove ourselves to test whether calling Tcl_DeleteTrace within
- * a trace callback causes the for loop in TclExecuteByteCode that
- * calls traces to reference freed memory.
+ * Remove ourselves to test whether calling Tcl_DeleteTrace within a trace
+ * callback causes the for loop in TclExecuteByteCode that calls traces to
+ * reference freed memory.
*/
-
+
Tcl_DeleteTrace(interp, cmdTrace);
}
static int
-ObjTraceProc( clientData, interp, level, command, token, objc, objv )
- ClientData clientData; /* unused */
- Tcl_Interp* interp; /* Tcl interpreter */
- int level; /* Execution level */
- CONST char* command; /* Command being executed */
- Tcl_Command token; /* Command information */
- int objc; /* Parameter count */
- Tcl_Obj *CONST objv[]; /* Parameter list */
-{
- CONST char* word = Tcl_GetString( objv[ 0 ] );
- if ( !strcmp( word, "Error" ) ) {
- Tcl_SetObjResult( interp, Tcl_NewStringObj( command, -1 ) );
+ObjTraceProc(
+ ClientData clientData, /* unused */
+ Tcl_Interp *interp, /* Tcl interpreter */
+ int level, /* Execution level */
+ const char *command, /* Command being executed */
+ Tcl_Command token, /* Command information */
+ int objc, /* Parameter count */
+ Tcl_Obj *const objv[]) /* Parameter list */
+{
+ const char *word = Tcl_GetString(objv[0]);
+
+ if (!strcmp(word, "Error")) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(command, -1));
return TCL_ERROR;
- } else if ( !strcmp( word, "Break" ) ) {
+ } else if (!strcmp(word, "Break")) {
return TCL_BREAK;
- } else if ( !strcmp( word, "Continue" ) ) {
+ } else if (!strcmp(word, "Continue")) {
return TCL_CONTINUE;
- } else if ( !strcmp( word, "Return" ) ) {
+ } else if (!strcmp(word, "Return")) {
return TCL_RETURN;
- } else if ( !strcmp( word, "OtherStatus" ) ) {
+ } else if (!strcmp(word, "OtherStatus")) {
return 6;
} else {
return TCL_OK;
@@ -1273,10 +1357,10 @@ ObjTraceProc( clientData, interp, level, command, token, objc, objv )
}
static void
-ObjTraceDeleteProc( clientData )
- ClientData clientData;
+ObjTraceDeleteProc(
+ ClientData clientData)
{
- int * intPtr = (int *) clientData;
+ int *intPtr = (int *) clientData;
*intPtr = 1; /* Record that the trace was deleted */
}
@@ -1285,11 +1369,11 @@ ObjTraceDeleteProc( clientData )
*
* TestcreatecommandCmd --
*
- * This procedure implements the "testcreatecommand" command. It is
- * used to test that the Tcl_CreateCommand creates a new command in
- * the namespace specified as part of its name, if any. It also
- * checks that the namespace code ignore single ":"s in the middle
- * or end of a command name.
+ * This procedure implements the "testcreatecommand" command. It is used
+ * to test that the Tcl_CreateCommand creates a new command in the
+ * namespace specified as part of its name, if any. It also checks that
+ * the namespace code ignore single ":"s in the middle or end of a
+ * command name.
*
* Results:
* A standard Tcl result.
@@ -1302,44 +1386,41 @@ ObjTraceDeleteProc( clientData )
*/
static int
-TestcreatecommandCmd(dummy, interp, argc, argv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- CONST char **argv; /* Argument strings. */
+TestcreatecommandCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int argc, /* Number of arguments. */
+ const char **argv) /* Argument strings. */
{
if (argc != 2) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " option\"", (char *) NULL);
+ " option\"", NULL);
return TCL_ERROR;
}
if (strcmp(argv[1], "create") == 0) {
Tcl_CreateCommand(interp, "test_ns_basic::createdcommand",
- CreatedCommandProc, (ClientData) NULL,
- (Tcl_CmdDeleteProc *) 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, (ClientData) NULL,
- (Tcl_CmdDeleteProc *) 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",
- (char *) NULL);
+ "\": must be create, delete, create2, or delete2", NULL);
return TCL_ERROR;
}
return TCL_OK;
}
static int
-CreatedCommandProc(clientData, interp, argc, argv)
- ClientData clientData; /* String to return. */
- Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- CONST char **argv; /* Argument strings. */
+CreatedCommandProc(
+ ClientData clientData, /* String to return. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int argc, /* Number of arguments. */
+ const char **argv) /* Argument strings. */
{
Tcl_CmdInfo info;
int found;
@@ -1348,20 +1429,20 @@ CreatedCommandProc(clientData, interp, argc, argv)
&info);
if (!found) {
Tcl_AppendResult(interp, "CreatedCommandProc could not get command info for test_ns_basic::createdcommand",
- (char *) NULL);
+ NULL);
return TCL_ERROR;
}
Tcl_AppendResult(interp, "CreatedCommandProc in ",
- info.namespacePtr->fullName, (char *) NULL);
+ info.namespacePtr->fullName, NULL);
return TCL_OK;
}
static int
-CreatedCommandProc2(clientData, interp, argc, argv)
- ClientData clientData; /* String to return. */
- Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- CONST char **argv; /* Argument strings. */
+CreatedCommandProc2(
+ ClientData clientData, /* String to return. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int argc, /* Number of arguments. */
+ const char **argv) /* Argument strings. */
{
Tcl_CmdInfo info;
int found;
@@ -1369,11 +1450,11 @@ CreatedCommandProc2(clientData, interp, argc, argv)
found = Tcl_GetCommandInfo(interp, "value:at:", &info);
if (!found) {
Tcl_AppendResult(interp, "CreatedCommandProc2 could not get command info for test_ns_basic::createdcommand",
- (char *) NULL);
+ NULL);
return TCL_ERROR;
}
Tcl_AppendResult(interp, "CreatedCommandProc2 in ",
- info.namespacePtr->fullName, (char *) NULL);
+ info.namespacePtr->fullName, NULL);
return TCL_OK;
}
@@ -1396,11 +1477,11 @@ CreatedCommandProc2(clientData, interp, argc, argv)
/* ARGSUSED */
static int
-TestdcallCmd(dummy, interp, argc, argv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- CONST char **argv; /* Argument strings. */
+TestdcallCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int argc, /* Number of arguments. */
+ const char **argv) /* Argument strings. */
{
int i, id;
@@ -1412,10 +1493,10 @@ TestdcallCmd(dummy, interp, argc, argv)
}
if (id < 0) {
Tcl_DontCallWhenDeleted(delInterp, DelCallbackProc,
- (ClientData) (-id));
+ (ClientData) INT2PTR(-id));
} else {
Tcl_CallWhenDeleted(delInterp, DelCallbackProc,
- (ClientData) id);
+ (ClientData) INT2PTR(id));
}
}
Tcl_DeleteInterp(delInterp);
@@ -1428,12 +1509,11 @@ TestdcallCmd(dummy, interp, argc, argv)
*/
static void
-DelCallbackProc(clientData, interp)
- ClientData clientData; /* Numerical value to append to
- * delString. */
- Tcl_Interp *interp; /* Interpreter being deleted. */
+DelCallbackProc(
+ ClientData clientData, /* Numerical value to append to delString. */
+ Tcl_Interp *interp) /* Interpreter being deleted. */
{
- int id = (int) clientData;
+ int id = PTR2INT(clientData);
char buffer[TCL_INTEGER_SPACE];
TclFormatInt(buffer, id);
@@ -1462,11 +1542,11 @@ DelCallbackProc(clientData, interp)
/* ARGSUSED */
static int
-TestdelCmd(dummy, interp, argc, argv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- CONST char **argv; /* Argument strings. */
+TestdelCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int argc, /* Number of arguments. */
+ const char **argv) /* Argument strings. */
{
DelCmd *dPtr;
Tcl_Interp *slave;
@@ -1492,23 +1572,23 @@ TestdelCmd(dummy, interp, argc, argv)
}
static int
-DelCmdProc(clientData, interp, argc, argv)
- ClientData clientData; /* String result to return. */
- Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- CONST char **argv; /* Argument strings. */
+DelCmdProc(
+ ClientData clientData, /* String result to return. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int argc, /* Number of arguments. */
+ const char **argv) /* Argument strings. */
{
DelCmd *dPtr = (DelCmd *) clientData;
- Tcl_AppendResult(interp, dPtr->deleteCmd, (char *) NULL);
+ Tcl_AppendResult(interp, dPtr->deleteCmd, NULL);
ckfree(dPtr->deleteCmd);
ckfree((char *) dPtr);
return TCL_OK;
}
static void
-DelDeleteProc(clientData)
- ClientData clientData; /* String command to evaluate. */
+DelDeleteProc(
+ ClientData clientData) /* String command to evaluate. */
{
DelCmd *dPtr = (DelCmd *) clientData;
@@ -1537,22 +1617,118 @@ DelDeleteProc(clientData)
*/
static int
-TestdelassocdataCmd(clientData, interp, argc, argv)
- ClientData clientData; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- CONST char **argv; /* Argument strings. */
+TestdelassocdataCmd(
+ ClientData clientData, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int argc, /* Number of arguments. */
+ const char **argv) /* Argument strings. */
{
if (argc != 2) {
- Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
- " data_key\"", (char *) NULL);
- return TCL_ERROR;
+ Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
+ " data_key\"", NULL);
+ return TCL_ERROR;
}
Tcl_DeleteAssocData(interp, argv[1]);
return TCL_OK;
}
/*
+ *-----------------------------------------------------------------------------
+ *
+ * TestdoubledigitsCmd --
+ *
+ * This procedure implements the 'testdoubledigits' command. It is
+ * used to test the low-level floating-point formatting primitives
+ * in Tcl.
+ *
+ * Usage:
+ * testdoubledigits fpval ndigits type ?shorten"
+ *
+ * Parameters:
+ * fpval - Floating-point value to format.
+ * ndigits - Digit count to request from Tcl_DoubleDigits
+ * type - One of 'shortest', 'Steele', 'e', 'f'
+ * shorten - Indicates that the 'shorten' flag should be passed in.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+static int
+TestdoubledigitsObjCmd(ClientData unused,
+ /* NULL */
+ Tcl_Interp* interp,
+ /* Tcl interpreter */
+ int objc,
+ /* Parameter count */
+ Tcl_Obj* const objv[])
+ /* Parameter vector */
+{
+ static const char* options[] = {
+ "shortest",
+ "Steele",
+ "e",
+ "f",
+ NULL
+ };
+ static const int types[] = {
+ TCL_DD_SHORTEST,
+ TCL_DD_STEELE,
+ TCL_DD_E_FORMAT,
+ TCL_DD_F_FORMAT
+ };
+
+ const Tcl_ObjType* doubleType;
+ double d;
+ int status;
+ int ndigits;
+ int type;
+ int decpt;
+ int signum;
+ char* str;
+ char* endPtr;
+ Tcl_Obj* strObj;
+ Tcl_Obj* retval;
+
+ if (objc < 4 || objc > 5) {
+ Tcl_WrongNumArgs(interp, 1, objv, "fpval ndigits type ?shorten?");
+ return TCL_ERROR;
+ }
+ status = Tcl_GetDoubleFromObj(interp, objv[1], &d);
+ if (status != TCL_OK) {
+ doubleType = Tcl_GetObjType("double");
+ if (objv[1]->typePtr == doubleType
+ || TclIsNaN(objv[1]->internalRep.doubleValue)) {
+ status = TCL_OK;
+ memcpy(&d, &(objv[1]->internalRep.doubleValue), sizeof(double));
+ }
+ }
+ if (status != TCL_OK
+ || Tcl_GetIntFromObj(interp, objv[2], &ndigits) != TCL_OK
+ || Tcl_GetIndexFromObj(interp, objv[3], options, "conversion type",
+ TCL_EXACT, &type) != TCL_OK) {
+ fprintf(stderr, "bad value? %g\n", d);
+ return TCL_ERROR;
+ }
+ type = types[type];
+ if (objc > 4) {
+ if (strcmp(Tcl_GetString(objv[4]), "shorten")) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("bad flag", -1));
+ return TCL_ERROR;
+ }
+ type |= TCL_DD_SHORTEN_FLAG;
+ }
+ str = TclDoubleDigits(d, ndigits, type, &decpt, &signum, &endPtr);
+ strObj = Tcl_NewStringObj(str, endPtr-str);
+ ckfree(str);
+ retval = Tcl_NewListObj(1, &strObj);
+ Tcl_ListObjAppendElement(NULL, retval, Tcl_NewIntObj(decpt));
+ strObj = Tcl_NewStringObj(signum ? "-" : "+", 1);
+ Tcl_ListObjAppendElement(NULL, retval, strObj);
+ Tcl_SetObjResult(interp, retval);
+ return TCL_OK;
+}
+
+/*
*----------------------------------------------------------------------
*
* TestdstringCmd --
@@ -1571,11 +1747,11 @@ TestdelassocdataCmd(clientData, interp, argc, argv)
/* ARGSUSED */
static int
-TestdstringCmd(dummy, interp, argc, argv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- CONST char **argv; /* Argument strings. */
+TestdstringCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int argc, /* Number of arguments. */
+ const char **argv) /* Argument strings. */
{
int count;
@@ -1631,13 +1807,13 @@ TestdstringCmd(dummy, interp, argc, argv)
} else {
Tcl_AppendResult(interp, "bad gresult option \"", argv[2],
"\": must be staticsmall, staticlarge, free, or special",
- (char *) 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;
}
@@ -1663,8 +1839,8 @@ TestdstringCmd(dummy, interp, argc, argv)
Tcl_DStringStartSublist(&dstring);
} else {
Tcl_AppendResult(interp, "bad option \"", argv[1],
- "\": must be append, element, end, free, get, length, ",
- "result, trunc, or start", (char *) NULL);
+ "\": must be append, element, end, free, get, length, "
+ "result, trunc, or start", NULL);
return TCL_ERROR;
}
return TCL_OK;
@@ -1700,92 +1876,82 @@ static void SpecialFree(blockPtr)
/* ARGSUSED */
static int
-TestencodingObjCmd(dummy, interp, objc, objv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* Argument objects. */
+TestencodingObjCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Encoding encoding;
int index, length;
char *string;
TclEncoding *encodingPtr;
- static CONST char *optionStrings[] = {
- "create", "delete", "path",
- NULL
+ static const char *optionStrings[] = {
+ "create", "delete", NULL
};
enum options {
- ENC_CREATE, ENC_DELETE, ENC_PATH
+ ENC_CREATE, ENC_DELETE
};
-
+
if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum options) index) {
- case ENC_CREATE: {
- Tcl_EncodingType type;
+ case ENC_CREATE: {
+ Tcl_EncodingType type;
- if (objc != 5) {
- return TCL_ERROR;
- }
- encodingPtr = (TclEncoding *) ckalloc(sizeof(TclEncoding));
- encodingPtr->interp = interp;
+ if (objc != 5) {
+ return TCL_ERROR;
+ }
+ encodingPtr = (TclEncoding *) ckalloc(sizeof(TclEncoding));
+ encodingPtr->interp = interp;
- string = Tcl_GetStringFromObj(objv[3], &length);
- encodingPtr->toUtfCmd = (char *) ckalloc((unsigned) (length + 1));
- memcpy(encodingPtr->toUtfCmd, string, (unsigned) length + 1);
+ string = Tcl_GetStringFromObj(objv[3], &length);
+ encodingPtr->toUtfCmd = (char *) ckalloc((unsigned) (length + 1));
+ memcpy(encodingPtr->toUtfCmd, string, (unsigned) length + 1);
- string = Tcl_GetStringFromObj(objv[4], &length);
- encodingPtr->fromUtfCmd = (char *) ckalloc((unsigned) (length + 1));
- memcpy(encodingPtr->fromUtfCmd, string, (unsigned) (length + 1));
+ string = Tcl_GetStringFromObj(objv[4], &length);
+ encodingPtr->fromUtfCmd = (char *) ckalloc((unsigned) (length + 1));
+ memcpy(encodingPtr->fromUtfCmd, string, (unsigned) (length + 1));
- string = Tcl_GetStringFromObj(objv[2], &length);
+ string = Tcl_GetStringFromObj(objv[2], &length);
- type.encodingName = string;
- type.toUtfProc = EncodingToUtfProc;
- type.fromUtfProc = EncodingFromUtfProc;
- type.freeProc = EncodingFreeProc;
- type.clientData = (ClientData) encodingPtr;
- type.nullSize = 1;
+ type.encodingName = string;
+ type.toUtfProc = EncodingToUtfProc;
+ type.fromUtfProc = EncodingFromUtfProc;
+ type.freeProc = EncodingFreeProc;
+ type.clientData = (ClientData) encodingPtr;
+ type.nullSize = 1;
- Tcl_CreateEncoding(&type);
- break;
- }
- case ENC_DELETE: {
- if (objc != 3) {
- return TCL_ERROR;
- }
- encoding = Tcl_GetEncoding(NULL, Tcl_GetString(objv[2]));
- Tcl_FreeEncoding(encoding);
- Tcl_FreeEncoding(encoding);
- break;
- }
- case ENC_PATH: {
- if (objc == 2) {
- Tcl_SetObjResult(interp, TclGetLibraryPath());
- } else {
- TclSetLibraryPath(objv[2]);
- }
- break;
+ Tcl_CreateEncoding(&type);
+ break;
+ }
+ case ENC_DELETE:
+ if (objc != 3) {
+ return TCL_ERROR;
}
+ encoding = Tcl_GetEncoding(NULL, Tcl_GetString(objv[2]));
+ Tcl_FreeEncoding(encoding);
+ Tcl_FreeEncoding(encoding);
+ break;
}
return TCL_OK;
}
-static int
-EncodingToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen,
- srcReadPtr, dstWrotePtr, dstCharsPtr)
- ClientData clientData; /* TclEncoding structure. */
- CONST char *src; /* Source string in specified encoding. */
- int srcLen; /* Source string length in bytes. */
- int flags; /* Conversion control flags. */
- Tcl_EncodingState *statePtr;/* Current state. */
- char *dst; /* Output buffer. */
- int dstLen; /* The maximum length of output buffer. */
- int *srcReadPtr; /* Filled with number of bytes read. */
- int *dstWrotePtr; /* Filled with number of bytes stored. */
- int *dstCharsPtr; /* Filled with number of chars stored. */
+
+static int
+EncodingToUtfProc(
+ ClientData clientData, /* TclEncoding structure. */
+ const char *src, /* Source string in specified encoding. */
+ int srcLen, /* Source string length in bytes. */
+ int flags, /* Conversion control flags. */
+ Tcl_EncodingState *statePtr,/* Current state. */
+ char *dst, /* Output buffer. */
+ int dstLen, /* The maximum length of output buffer. */
+ int *srcReadPtr, /* Filled with number of bytes read. */
+ int *dstWrotePtr, /* Filled with number of bytes stored. */
+ int *dstCharsPtr) /* Filled with number of chars stored. */
{
int len;
TclEncoding *encodingPtr;
@@ -1805,19 +1971,19 @@ EncodingToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen,
*dstCharsPtr = len;
return TCL_OK;
}
-static int
-EncodingFromUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen,
- srcReadPtr, dstWrotePtr, dstCharsPtr)
- ClientData clientData; /* TclEncoding structure. */
- CONST char *src; /* Source string in specified encoding. */
- int srcLen; /* Source string length in bytes. */
- int flags; /* Conversion control flags. */
- Tcl_EncodingState *statePtr;/* Current state. */
- char *dst; /* Output buffer. */
- int dstLen; /* The maximum length of output buffer. */
- int *srcReadPtr; /* Filled with number of bytes read. */
- int *dstWrotePtr; /* Filled with number of bytes stored. */
- int *dstCharsPtr; /* Filled with number of chars stored. */
+
+static int
+EncodingFromUtfProc(
+ ClientData clientData, /* TclEncoding structure. */
+ const char *src, /* Source string in specified encoding. */
+ int srcLen, /* Source string length in bytes. */
+ int flags, /* Conversion control flags. */
+ Tcl_EncodingState *statePtr,/* Current state. */
+ char *dst, /* Output buffer. */
+ int dstLen, /* The maximum length of output buffer. */
+ int *srcReadPtr, /* Filled with number of bytes read. */
+ int *dstWrotePtr, /* Filled with number of bytes stored. */
+ int *dstCharsPtr) /* Filled with number of chars stored. */
{
int len;
TclEncoding *encodingPtr;
@@ -1837,9 +2003,10 @@ EncodingFromUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen,
*dstCharsPtr = len;
return TCL_OK;
}
+
static void
-EncodingFreeProc(clientData)
- ClientData clientData; /* ClientData associated with type. */
+EncodingFreeProc(
+ ClientData clientData) /* ClientData associated with type. */
{
TclEncoding *encodingPtr;
@@ -1867,60 +2034,31 @@ EncodingFreeProc(clientData)
*/
static int
-TestevalexObjCmd(dummy, interp, objc, objv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* Argument objects. */
+TestevalexObjCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
- Interp *iPtr = (Interp *) interp;
- int code, oldFlags, length, flags;
- char *string;
-
- if (objc == 1) {
- /*
- * The command was invoked with no arguments, so just toggle
- * the flag that determines whether we use Tcl_EvalEx.
- */
-
- if (iPtr->flags & USE_EVAL_DIRECT) {
- iPtr->flags &= ~USE_EVAL_DIRECT;
- Tcl_SetResult(interp, "disabling direct evaluation", TCL_STATIC);
- } else {
- iPtr->flags |= USE_EVAL_DIRECT;
- Tcl_SetResult(interp, "enabling direct evaluation", TCL_STATIC);
- }
- return TCL_OK;
- }
+ int length, flags;
+ char *script;
flags = 0;
if (objc == 3) {
- string = Tcl_GetStringFromObj(objv[2], &length);
- if (strcmp(string, "global") != 0) {
- Tcl_AppendResult(interp, "bad value \"", string,
- "\": must be global", (char *) NULL);
+ char *global = Tcl_GetStringFromObj(objv[2], &length);
+ if (strcmp(global, "global") != 0) {
+ Tcl_AppendResult(interp, "bad value \"", global,
+ "\": must be global", NULL);
return TCL_ERROR;
}
flags = TCL_EVAL_GLOBAL;
} else if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "script ?global?");
- return TCL_ERROR;
+ return TCL_ERROR;
}
- Tcl_SetResult(interp, "xxx", TCL_STATIC);
- /*
- * Note, we have to set the USE_EVAL_DIRECT flag in the interpreter
- * in addition to calling Tcl_EvalEx. This is needed so that even nested
- * commands are evaluated directly.
- */
-
- oldFlags = iPtr->flags;
- iPtr->flags |= USE_EVAL_DIRECT;
- string = Tcl_GetStringFromObj(objv[1], &length);
- code = Tcl_EvalEx(interp, string, length, flags);
- iPtr->flags = (iPtr->flags & ~USE_EVAL_DIRECT)
- | (oldFlags & USE_EVAL_DIRECT);
- return code;
+ script = Tcl_GetStringFromObj(objv[1], &length);
+ return Tcl_EvalEx(interp, script, length, flags);
}
/*
@@ -1941,17 +2079,17 @@ TestevalexObjCmd(dummy, interp, objc, objv)
*/
static int
-TestevalobjvObjCmd(dummy, interp, objc, objv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* Argument objects. */
+TestevalobjvObjCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
int evalGlobal;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv, "global word ?word ...?");
- return TCL_ERROR;
+ return TCL_ERROR;
}
if (Tcl_GetIntFromObj(interp, objv[1], &evalGlobal) != TCL_OK) {
return TCL_ERROR;
@@ -1990,74 +2128,67 @@ TestevalobjvObjCmd(dummy, interp, objc, objv)
*/
static int
-TesteventObjCmd( ClientData unused, /* Not used */
- Tcl_Interp* interp, /* Tcl interpreter */
- int objc, /* Parameter count */
- Tcl_Obj *CONST objv[] ) /* Parameter vector */
-{
-
- static CONST char* subcommands[] = { /* Possible subcommands */
- "queue",
- "delete",
- NULL
+TesteventObjCmd(
+ ClientData unused, /* Not used */
+ Tcl_Interp *interp, /* Tcl interpreter */
+ int objc, /* Parameter count */
+ Tcl_Obj *const objv[]) /* Parameter vector */
+{
+ static const char *subcommands[] = { /* Possible subcommands */
+ "queue", "delete", NULL
};
int subCmdIndex; /* Index of the chosen subcommand */
- static CONST char* positions[] = { /* Possible queue positions */
- "head",
- "tail",
- "mark",
- NULL
+ static const char *positions[] = { /* Possible queue positions */
+ "head", "tail", "mark", NULL
};
int posIndex; /* Index of the chosen position */
- static CONST Tcl_QueuePosition posNum[] = {
- /* Interpretation of the chosen position */
+ static const Tcl_QueuePosition posNum[] = {
+ /* Interpretation of the chosen position */
TCL_QUEUE_HEAD,
TCL_QUEUE_TAIL,
TCL_QUEUE_MARK
};
- TestEvent* ev; /* Event to be queued */
+ TestEvent *ev; /* Event to be queued */
- if ( objc < 2 ) {
- Tcl_WrongNumArgs( interp, 1, objv, "subcommand ?args?" );
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?args?");
return TCL_ERROR;
}
- if ( Tcl_GetIndexFromObj( interp, objv[1], subcommands, "subcommand",
- TCL_EXACT, &subCmdIndex ) != TCL_OK ) {
+ if (Tcl_GetIndexFromObj(interp, objv[1], subcommands, "subcommand",
+ TCL_EXACT, &subCmdIndex) != TCL_OK) {
return TCL_ERROR;
}
- switch ( subCmdIndex ) {
+ switch (subCmdIndex) {
case 0: /* queue */
- if ( objc != 5 ) {
- Tcl_WrongNumArgs( interp, 2, objv, "name position script" );
+ if (objc != 5) {
+ Tcl_WrongNumArgs(interp, 2, objv, "name position script");
return TCL_ERROR;
}
- if ( Tcl_GetIndexFromObj( interp, objv[3], positions,
- "position specifier", TCL_EXACT,
- &posIndex ) != TCL_OK ) {
+ if (Tcl_GetIndexFromObj(interp, objv[3], positions,
+ "position specifier", TCL_EXACT, &posIndex) != TCL_OK) {
return TCL_ERROR;
}
- ev = (TestEvent*) ckalloc( sizeof( TestEvent ) );
+ ev = (TestEvent *) ckalloc(sizeof(TestEvent));
ev->header.proc = TesteventProc;
ev->header.nextPtr = NULL;
ev->interp = interp;
- ev->command = objv[ 4 ];
- Tcl_IncrRefCount( ev->command );
- ev->tag = objv[ 2 ];
- Tcl_IncrRefCount( ev->tag );
- Tcl_QueueEvent( (Tcl_Event*) ev, posNum[ posIndex ] );
+ ev->command = objv[4];
+ Tcl_IncrRefCount(ev->command);
+ ev->tag = objv[2];
+ Tcl_IncrRefCount(ev->tag);
+ Tcl_QueueEvent((Tcl_Event *) ev, posNum[posIndex]);
break;
case 1: /* delete */
- if ( objc != 3 ) {
- Tcl_WrongNumArgs( interp, 2, objv, "name" );
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "name");
return TCL_ERROR;
}
- Tcl_DeleteEvents( TesteventDeleteProc, objv[ 2 ] );
+ Tcl_DeleteEvents(TesteventDeleteProc, objv[2]);
break;
}
return TCL_OK;
-
}
/*
@@ -2067,49 +2198,49 @@ TesteventObjCmd( ClientData unused, /* Not used */
*
* Delivers a test event to the Tcl interpreter as part of event
* queue testing.
- *
+ *
* Results:
* Returns 1 if the event has been serviced, 0 otherwise.
*
* Side effects:
- * Evaluates the event's callback script, so has whatever
- * side effects the callback has. The return value of the
- * callback script becomes the return value of this function.
- * If the callback script reports an error, it is reported as
- * a background error.
+ * Evaluates the event's callback script, so has whatever side effects
+ * the callback has. The return value of the callback script becomes the
+ * return value of this function. If the callback script reports an
+ * error, it is reported as a background error.
*
*----------------------------------------------------------------------
*/
static int
-TesteventProc( Tcl_Event* event, /* Event to deliver */
- int flags ) /* Current flags for Tcl_ServiceEvent */
-{
- TestEvent * ev = (TestEvent *) event;
- Tcl_Interp* interp = ev->interp;
- Tcl_Obj* command = ev->command;
- int result = Tcl_EvalObjEx( interp, command,
- TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT );
+TesteventProc(
+ Tcl_Event *event, /* Event to deliver */
+ int flags) /* Current flags for Tcl_ServiceEvent */
+{
+ TestEvent *ev = (TestEvent *) event;
+ Tcl_Interp *interp = ev->interp;
+ Tcl_Obj *command = ev->command;
+ int result = Tcl_EvalObjEx(interp, command,
+ TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT);
int retval;
- if ( result != TCL_OK ) {
- Tcl_AddErrorInfo( interp,
- " (command bound to \"testevent\" callback)" );
- Tcl_BackgroundError( interp );
+
+ if (result != TCL_OK) {
+ Tcl_AddErrorInfo(interp,
+ " (command bound to \"testevent\" callback)");
+ Tcl_BackgroundError(interp);
return 1; /* Avoid looping on errors */
}
- if ( Tcl_GetBooleanFromObj( interp,
- Tcl_GetObjResult( interp ),
- &retval ) != TCL_OK ) {
- Tcl_AddErrorInfo( interp,
- " (return value from \"testevent\" callback)" );
- Tcl_BackgroundError( interp );
+ if (Tcl_GetBooleanFromObj(interp, Tcl_GetObjResult(interp),
+ &retval) != TCL_OK) {
+ Tcl_AddErrorInfo(interp,
+ " (return value from \"testevent\" callback)");
+ Tcl_BackgroundError(interp);
return 1;
}
- if ( retval ) {
- Tcl_DecrRefCount( ev->tag );
- Tcl_DecrRefCount( ev->command );
+ if (retval) {
+ Tcl_DecrRefCount(ev->tag);
+ Tcl_DecrRefCount(ev->command);
}
-
+
return retval;
}
@@ -2132,25 +2263,26 @@ TesteventProc( Tcl_Event* event, /* Event to deliver */
*/
static int
-TesteventDeleteProc( Tcl_Event* event, /* Event to examine */
- ClientData clientData ) /* Tcl_Obj containing the name
- * of the event(s) to remove */
+TesteventDeleteProc(
+ Tcl_Event *event, /* Event to examine */
+ ClientData clientData) /* Tcl_Obj containing the name of the event(s)
+ * to remove */
{
- TestEvent* ev; /* Event to examine */
- char* evNameStr;
- Tcl_Obj* targetName; /* Name of the event(s) to delete */
- char* targetNameStr;
+ TestEvent *ev; /* Event to examine */
+ char *evNameStr;
+ Tcl_Obj *targetName; /* Name of the event(s) to delete */
+ char *targetNameStr;
- if ( event->proc != TesteventProc ) {
+ if (event->proc != TesteventProc) {
return 0;
}
- targetName = (Tcl_Obj*) clientData;
- targetNameStr = (char*) Tcl_GetStringFromObj( targetName, NULL );
- ev = (TestEvent*) event;
- evNameStr = Tcl_GetStringFromObj( ev->tag, NULL );
- if ( strcmp( evNameStr, targetNameStr ) == 0 ) {
- Tcl_DecrRefCount( ev->tag );
- Tcl_DecrRefCount( ev->command );
+ targetName = (Tcl_Obj *) clientData;
+ targetNameStr = (char *) Tcl_GetStringFromObj(targetName, NULL);
+ ev = (TestEvent *) event;
+ evNameStr = Tcl_GetStringFromObj(ev->tag, NULL);
+ if (strcmp(evNameStr, targetNameStr) == 0) {
+ Tcl_DecrRefCount(ev->tag);
+ Tcl_DecrRefCount(ev->command);
return 1;
} else {
return 0;
@@ -2175,54 +2307,62 @@ TesteventDeleteProc( Tcl_Event* event, /* Event to examine */
*/
static int
-TestexithandlerCmd(clientData, interp, argc, argv)
- ClientData clientData; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- CONST char **argv; /* Argument strings. */
+TestexithandlerCmd(
+ ClientData clientData, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int argc, /* Number of arguments. */
+ const char **argv) /* Argument strings. */
{
int value;
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
- " create|delete value\"", (char *) NULL);
- return TCL_ERROR;
+ " create|delete value\"", NULL);
+ return TCL_ERROR;
}
if (Tcl_GetInt(interp, argv[2], &value) != TCL_OK) {
return TCL_ERROR;
}
if (strcmp(argv[1], "create") == 0) {
Tcl_CreateExitHandler((value & 1) ? ExitProcOdd : ExitProcEven,
- (ClientData) value);
+ (ClientData) INT2PTR(value));
} else if (strcmp(argv[1], "delete") == 0) {
Tcl_DeleteExitHandler((value & 1) ? ExitProcOdd : ExitProcEven,
- (ClientData) value);
+ (ClientData) INT2PTR(value));
} else {
Tcl_AppendResult(interp, "bad option \"", argv[1],
- "\": must be create or delete", (char *) NULL);
+ "\": must be create or delete", NULL);
return TCL_ERROR;
}
return TCL_OK;
}
static void
-ExitProcOdd(clientData)
- ClientData clientData; /* Integer value to print. */
+ExitProcOdd(
+ ClientData clientData) /* Integer value to print. */
{
char buf[16 + TCL_INTEGER_SPACE];
+ size_t len;
- sprintf(buf, "odd %d\n", (int) clientData);
- write(1, buf, strlen(buf));
+ sprintf(buf, "odd %d\n", PTR2INT(clientData));
+ len = strlen(buf);
+ if (len != (size_t) write(1, buf, len)) {
+ Tcl_Panic("ExitProcOdd: unable to write to stdout");
+ }
}
static void
-ExitProcEven(clientData)
- ClientData clientData; /* Integer value to print. */
+ExitProcEven(
+ ClientData clientData) /* Integer value to print. */
{
char buf[16 + TCL_INTEGER_SPACE];
+ size_t len;
- sprintf(buf, "even %d\n", (int) clientData);
- write(1, buf, strlen(buf));
+ sprintf(buf, "even %d\n", PTR2INT(clientData));
+ len = strlen(buf);
+ if (len != (size_t) write(1, buf, len)) {
+ Tcl_Panic("ExitProcEven: unable to write to stdout");
+ }
}
/*
@@ -2243,20 +2383,25 @@ ExitProcEven(clientData)
*/
static int
-TestexprlongCmd(clientData, interp, argc, argv)
- ClientData clientData; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- CONST char **argv; /* Argument strings. */
+TestexprlongCmd(
+ ClientData clientData, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int argc, /* Number of arguments. */
+ const char **argv) /* Argument strings. */
{
long exprResult;
char buf[4 + TCL_INTEGER_SPACE];
int result;
-
+
+ if (argc != 2) {
+ Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
+ " expression\"", NULL);
+ return TCL_ERROR;
+ }
Tcl_SetResult(interp, "This is a result", TCL_STATIC);
- result = Tcl_ExprLong(interp, "4+1", &exprResult);
+ result = Tcl_ExprLong(interp, argv[1], &exprResult);
if (result != TCL_OK) {
- return result;
+ return result;
}
sprintf(buf, ": %ld", exprResult);
Tcl_AppendResult(interp, buf, NULL);
@@ -2281,11 +2426,11 @@ TestexprlongCmd(clientData, interp, argc, argv)
*/
static int
-TestexprlongobjCmd(clientData, interp, objc, objv)
- ClientData clientData; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST *objv; /* Argument objects. */
+TestexprlongobjCmd(
+ ClientData clientData, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const *objv) /* Argument objects. */
{
long exprResult;
char buf[4 + TCL_INTEGER_SPACE];
@@ -2298,7 +2443,7 @@ TestexprlongobjCmd(clientData, interp, objc, objv)
Tcl_SetResult(interp, "This is a result", TCL_STATIC);
result = Tcl_ExprLongObj(interp, objv[1], &exprResult);
if (result != TCL_OK) {
- return result;
+ return result;
}
sprintf(buf, ": %ld", exprResult);
Tcl_AppendResult(interp, buf, NULL);
@@ -2308,6 +2453,93 @@ TestexprlongobjCmd(clientData, interp, objc, objv)
/*
*----------------------------------------------------------------------
*
+ * TestexprdoubleCmd --
+ *
+ * This procedure verifies that Tcl_ExprDouble does not modify the
+ * interpreter result if there is no error.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TestexprdoubleCmd(
+ ClientData clientData, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int argc, /* Number of arguments. */
+ const char **argv) /* Argument strings. */
+{
+ double exprResult;
+ char buf[4 + TCL_DOUBLE_SPACE];
+ int result;
+
+ if (argc != 2) {
+ Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
+ " expression\"", NULL);
+ return TCL_ERROR;
+ }
+ Tcl_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, NULL);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TestexprdoubleobjCmd --
+ *
+ * This procedure verifies that Tcl_ExprLongObj does not modify the
+ * interpreter result if there is no error.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TestexprdoubleobjCmd(
+ ClientData clientData, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const *objv) /* Argument objects. */
+{
+ double exprResult;
+ char buf[4 + TCL_DOUBLE_SPACE];
+ int result;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "expression");
+ return TCL_ERROR;
+ }
+ 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, NULL);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TestexprstringCmd --
*
* This procedure tests the basic operation of Tcl_ExprString.
@@ -2322,16 +2554,16 @@ TestexprlongobjCmd(clientData, interp, objc, objv)
*/
static int
-TestexprstringCmd(clientData, interp, argc, argv)
- ClientData clientData; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- CONST char **argv; /* Argument strings. */
+TestexprstringCmd(
+ ClientData clientData, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int argc, /* Number of arguments. */
+ const char **argv) /* Argument strings. */
{
if (argc != 2) {
- Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
- " expression\"", (char *) NULL);
- return TCL_ERROR;
+ Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
+ " expression\"", NULL);
+ return TCL_ERROR;
}
return Tcl_ExprString(interp, argv[1]);
}
@@ -2341,9 +2573,8 @@ TestexprstringCmd(clientData, interp, argc, argv)
*
* TestfilelinkCmd --
*
- * This procedure implements the "testfilelink" command. It is used
- * to test the effects of creating and manipulating filesystem links
- * in Tcl.
+ * This procedure implements the "testfilelink" command. It is used to
+ * test the effects of creating and manipulating filesystem links in Tcl.
*
* Results:
* A standard Tcl result.
@@ -2355,11 +2586,11 @@ TestexprstringCmd(clientData, interp, argc, argv)
*/
static int
-TestfilelinkCmd(clientData, interp, objc, objv)
- ClientData clientData; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* The argument objects. */
+TestfilelinkCmd(
+ ClientData clientData, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* The argument objects. */
{
Tcl_Obj *contents;
@@ -2367,35 +2598,35 @@ TestfilelinkCmd(clientData, interp, objc, objv)
Tcl_WrongNumArgs(interp, 1, objv, "source ?target?");
return TCL_ERROR;
}
-
+
if (Tcl_FSConvertToPathType(interp, objv[1]) != TCL_OK) {
return TCL_ERROR;
}
-
+
if (objc == 3) {
/* Create link from source to target */
- contents = Tcl_FSLink(objv[1], objv[2],
- TCL_CREATE_SYMBOLIC_LINK|TCL_CREATE_HARD_LINK);
+ contents = Tcl_FSLink(objv[1], objv[2],
+ TCL_CREATE_SYMBOLIC_LINK|TCL_CREATE_HARD_LINK);
if (contents == NULL) {
- Tcl_AppendResult(interp, "could not create link from \"",
- Tcl_GetString(objv[1]), "\" to \"",
- Tcl_GetString(objv[2]), "\": ",
- Tcl_PosixError(interp), (char *) NULL);
+ Tcl_AppendResult(interp, "could not create link from \"",
+ Tcl_GetString(objv[1]), "\" to \"",
+ Tcl_GetString(objv[2]), "\": ",
+ Tcl_PosixError(interp), NULL);
return TCL_ERROR;
}
} else {
/* Read link */
contents = Tcl_FSLink(objv[1], NULL, 0);
if (contents == NULL) {
- Tcl_AppendResult(interp, "could not read link \"",
- Tcl_GetString(objv[1]), "\": ",
- Tcl_PosixError(interp), (char *) NULL);
+ Tcl_AppendResult(interp, "could not read link \"",
+ Tcl_GetString(objv[1]), "\": ",
+ Tcl_PosixError(interp), NULL);
return TCL_ERROR;
}
}
Tcl_SetObjResult(interp, contents);
if (objc == 2) {
- /*
+ /*
* If we are creating a link, this will actually just
* be objv[3], and we don't own it
*/
@@ -2422,22 +2653,22 @@ TestfilelinkCmd(clientData, interp, objc, objv)
*/
static int
-TestgetassocdataCmd(clientData, interp, argc, argv)
- ClientData clientData; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- CONST char **argv; /* Argument strings. */
+TestgetassocdataCmd(
+ ClientData clientData, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int argc, /* Number of arguments. */
+ const char **argv) /* Argument strings. */
{
char *res;
-
+
if (argc != 2) {
- Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
- " data_key\"", (char *) NULL);
- return TCL_ERROR;
+ Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
+ " data_key\"", NULL);
+ return TCL_ERROR;
}
res = (char *) Tcl_GetAssocData(interp, argv[1], NULL);
if (res != NULL) {
- Tcl_AppendResult(interp, res, NULL);
+ Tcl_AppendResult(interp, res, NULL);
}
return TCL_OK;
}
@@ -2460,25 +2691,21 @@ TestgetassocdataCmd(clientData, interp, argc, argv)
*/
static int
-TestgetplatformCmd(clientData, interp, argc, argv)
- ClientData clientData; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- CONST char **argv; /* Argument strings. */
+TestgetplatformCmd(
+ ClientData clientData, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int argc, /* Number of arguments. */
+ const char **argv) /* Argument strings. */
{
- static CONST char *platformStrings[] = { "unix", "mac", "windows" };
+ static const char *platformStrings[] = { "unix", "mac", "windows" };
TclPlatformType *platform;
-#ifdef __WIN32__
- platform = TclWinGetPlatform();
-#else
- platform = &tclPlatform;
-#endif
-
+ platform = TclGetPlatform();
+
if (argc != 1) {
- Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
- (char *) NULL);
- return TCL_ERROR;
+ Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
+ NULL);
+ return TCL_ERROR;
}
Tcl_AppendResult(interp, platformStrings[*platform], NULL);
@@ -2505,22 +2732,22 @@ TestgetplatformCmd(clientData, interp, argc, argv)
/* ARGSUSED */
static int
-TestinterpdeleteCmd(dummy, interp, argc, argv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- CONST char **argv; /* Argument strings. */
+TestinterpdeleteCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int argc, /* Number of arguments. */
+ const char **argv) /* Argument strings. */
{
Tcl_Interp *slaveToDelete;
if (argc != 2) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " path\"", (char *) NULL);
- return TCL_ERROR;
+ Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
+ " path\"", NULL);
+ return TCL_ERROR;
}
slaveToDelete = Tcl_GetSlave(interp, argv[1]);
- if (slaveToDelete == (Tcl_Interp *) NULL) {
- return TCL_ERROR;
+ if (slaveToDelete == NULL) {
+ return TCL_ERROR;
}
Tcl_DeleteInterp(slaveToDelete);
return TCL_OK;
@@ -2546,17 +2773,26 @@ TestinterpdeleteCmd(dummy, interp, argc, argv)
/* ARGSUSED */
static int
-TestlinkCmd(dummy, interp, argc, argv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- CONST char **argv; /* Argument strings. */
+TestlinkCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int argc, /* Number of arguments. */
+ const char **argv) /* Argument strings. */
{
static int intVar = 43;
static int boolVar = 4;
static double realVar = 1.23;
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 long longVar = 123456789L;
+ static unsigned long ulongVar = 3456789012UL;
+ static float floatVar = 4.5;
+ static Tcl_WideUInt uwideVar = (Tcl_WideUInt) Tcl_LongAsWide(123);
static int created = 0;
char buffer[2*TCL_DOUBLE_SPACE];
int writable, flag;
@@ -2564,14 +2800,16 @@ TestlinkCmd(dummy, interp, argc, argv)
if (argc < 2) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " option ?arg arg arg arg arg?\"", (char *) NULL);
+ " option ?arg arg arg arg arg arg arg arg arg arg arg arg"
+ " arg arg?\"", NULL);
return TCL_ERROR;
}
if (strcmp(argv[1], "create") == 0) {
- if (argc != 7) {
+ if (argc != 16) {
Tcl_AppendResult(interp, "wrong # args: should be \"",
argv[0], " ", argv[1],
- " intRO realRO boolRO stringRO wideRO\"", (char *) NULL);
+ " intRO realRO boolRO stringRO wideRO charRO ucharRO shortRO"
+ " ushortRO uintRO longRO ulongRO floatRO uwideRO\"", NULL);
return TCL_ERROR;
}
if (created) {
@@ -2580,6 +2818,15 @@ TestlinkCmd(dummy, interp, argc, argv)
Tcl_UnlinkVar(interp, "bool");
Tcl_UnlinkVar(interp, "string");
Tcl_UnlinkVar(interp, "wide");
+ Tcl_UnlinkVar(interp, "char");
+ Tcl_UnlinkVar(interp, "uchar");
+ Tcl_UnlinkVar(interp, "short");
+ Tcl_UnlinkVar(interp, "ushort");
+ Tcl_UnlinkVar(interp, "uint");
+ Tcl_UnlinkVar(interp, "long");
+ Tcl_UnlinkVar(interp, "ulong");
+ Tcl_UnlinkVar(interp, "float");
+ Tcl_UnlinkVar(interp, "uwide");
}
created = 1;
if (Tcl_GetBoolean(interp, argv[2], &writable) != TCL_OK) {
@@ -2622,17 +2869,99 @@ TestlinkCmd(dummy, interp, argc, argv)
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) ? 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) ? 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) ? 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) ? 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) ? 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) ? 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) ? 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) ? 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) ? 0 : TCL_LINK_READ_ONLY;
+ if (Tcl_LinkVar(interp, "uwide", (char *) &uwideVar,
+ TCL_LINK_WIDE_UINT | flag) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
} else if (strcmp(argv[1], "delete") == 0) {
Tcl_UnlinkVar(interp, "int");
Tcl_UnlinkVar(interp, "real");
Tcl_UnlinkVar(interp, "bool");
Tcl_UnlinkVar(interp, "string");
Tcl_UnlinkVar(interp, "wide");
+ Tcl_UnlinkVar(interp, "char");
+ Tcl_UnlinkVar(interp, "uchar");
+ Tcl_UnlinkVar(interp, "short");
+ Tcl_UnlinkVar(interp, "ushort");
+ Tcl_UnlinkVar(interp, "uint");
+ Tcl_UnlinkVar(interp, "long");
+ Tcl_UnlinkVar(interp, "ulong");
+ Tcl_UnlinkVar(interp, "float");
+ Tcl_UnlinkVar(interp, "uwide");
created = 0;
} else if (strcmp(argv[1], "get") == 0) {
TclFormatInt(buffer, intVar);
Tcl_AppendElement(interp, buffer);
- Tcl_PrintDouble((Tcl_Interp *) NULL, realVar, buffer);
+ Tcl_PrintDouble(NULL, realVar, buffer);
Tcl_AppendElement(interp, buffer);
TclFormatInt(buffer, boolVar);
Tcl_AppendElement(interp, buffer);
@@ -2643,12 +2972,36 @@ TestlinkCmd(dummy, interp, argc, argv)
tmp = Tcl_NewWideIntObj(wideVar);
Tcl_AppendElement(interp, Tcl_GetString(tmp));
Tcl_DecrRefCount(tmp);
+ TclFormatInt(buffer, (int) charVar);
+ Tcl_AppendElement(interp, buffer);
+ TclFormatInt(buffer, (int) ucharVar);
+ Tcl_AppendElement(interp, buffer);
+ TclFormatInt(buffer, (int) shortVar);
+ Tcl_AppendElement(interp, buffer);
+ TclFormatInt(buffer, (int) ushortVar);
+ Tcl_AppendElement(interp, buffer);
+ TclFormatInt(buffer, (int) uintVar);
+ Tcl_AppendElement(interp, buffer);
+ tmp = Tcl_NewLongObj(longVar);
+ Tcl_AppendElement(interp, Tcl_GetString(tmp));
+ Tcl_DecrRefCount(tmp);
+ tmp = Tcl_NewLongObj((long)ulongVar);
+ Tcl_AppendElement(interp, Tcl_GetString(tmp));
+ Tcl_DecrRefCount(tmp);
+ Tcl_PrintDouble(NULL, (double)floatVar, buffer);
+ Tcl_AppendElement(interp, buffer);
+ tmp = Tcl_NewWideIntObj((Tcl_WideInt)uwideVar);
+ Tcl_AppendElement(interp, Tcl_GetString(tmp));
+ Tcl_DecrRefCount(tmp);
} else if (strcmp(argv[1], "set") == 0) {
- if (argc != 7) {
+ int v;
+
+ if (argc != 16) {
Tcl_AppendResult(interp, "wrong # args: should be \"",
argv[0], " ", argv[1],
- " intValue realValue boolValue stringValue wideValue\"",
- (char *) NULL);
+ " intValue realValue boolValue stringValue wideValue"
+ " charValue ucharValue shortValue ushortValue uintValue"
+ " longValue ulongValue floatValue uwideValue\"", NULL);
return TCL_ERROR;
}
if (argv[2][0] != 0) {
@@ -2685,12 +3038,74 @@ TestlinkCmd(dummy, interp, argc, argv)
}
Tcl_DecrRefCount(tmp);
}
+ if (argv[7][0]) {
+ if (Tcl_GetInt(interp, argv[7], &v) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ charVar = (char) v;
+ }
+ if (argv[8][0]) {
+ if (Tcl_GetInt(interp, argv[8], &v) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ ucharVar = (unsigned char) v;
+ }
+ if (argv[9][0]) {
+ if (Tcl_GetInt(interp, argv[9], &v) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ shortVar = (short) v;
+ }
+ if (argv[10][0]) {
+ if (Tcl_GetInt(interp, argv[10], &v) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ ushortVar = (unsigned short) v;
+ }
+ if (argv[11][0]) {
+ if (Tcl_GetInt(interp, argv[11], &v) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ uintVar = (unsigned int) v;
+ }
+ if (argv[12][0]) {
+ if (Tcl_GetInt(interp, argv[12], &v) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ longVar = (long) v;
+ }
+ if (argv[13][0]) {
+ if (Tcl_GetInt(interp, argv[13], &v) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ ulongVar = (unsigned long) v;
+ }
+ if (argv[14][0]) {
+ double d;
+ if (Tcl_GetDouble(interp, argv[14], &d) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ floatVar = (float) d;
+ }
+ if (argv[15][0]) {
+ Tcl_WideInt w;
+ tmp = Tcl_NewStringObj(argv[15], -1);
+ if (Tcl_GetWideIntFromObj(interp, tmp, &w) != TCL_OK) {
+ Tcl_DecrRefCount(tmp);
+ return TCL_ERROR;
+ }
+ Tcl_DecrRefCount(tmp);
+ uwideVar = (Tcl_WideUInt) w;
+ }
} else if (strcmp(argv[1], "update") == 0) {
- if (argc != 7) {
+ int v;
+
+ if (argc != 16) {
Tcl_AppendResult(interp, "wrong # args: should be \"",
argv[0], " ", argv[1],
- "intValue realValue boolValue stringValue wideValue\"",
- (char *) NULL);
+ " intValue realValue boolValue stringValue wideValue"
+ " charValue ucharValue shortValue ushortValue uintValue"
+ " longValue ulongValue floatValue uwideValue\"", NULL);
return TCL_ERROR;
}
if (argv[2][0] != 0) {
@@ -2732,10 +3147,77 @@ TestlinkCmd(dummy, interp, argc, argv)
Tcl_DecrRefCount(tmp);
Tcl_UpdateLinkedVar(interp, "wide");
}
+ if (argv[7][0]) {
+ if (Tcl_GetInt(interp, argv[7], &v) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ charVar = (char) v;
+ Tcl_UpdateLinkedVar(interp, "char");
+ }
+ if (argv[8][0]) {
+ if (Tcl_GetInt(interp, argv[8], &v) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ ucharVar = (unsigned char) v;
+ Tcl_UpdateLinkedVar(interp, "uchar");
+ }
+ if (argv[9][0]) {
+ if (Tcl_GetInt(interp, argv[9], &v) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ shortVar = (short) v;
+ Tcl_UpdateLinkedVar(interp, "short");
+ }
+ if (argv[10][0]) {
+ if (Tcl_GetInt(interp, argv[10], &v) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ ushortVar = (unsigned short) v;
+ Tcl_UpdateLinkedVar(interp, "ushort");
+ }
+ if (argv[11][0]) {
+ if (Tcl_GetInt(interp, argv[11], &v) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ uintVar = (unsigned int) v;
+ Tcl_UpdateLinkedVar(interp, "uint");
+ }
+ if (argv[12][0]) {
+ if (Tcl_GetInt(interp, argv[12], &v) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ longVar = (long) v;
+ Tcl_UpdateLinkedVar(interp, "long");
+ }
+ if (argv[13][0]) {
+ if (Tcl_GetInt(interp, argv[13], &v) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ ulongVar = (unsigned long) v;
+ Tcl_UpdateLinkedVar(interp, "ulong");
+ }
+ if (argv[14][0]) {
+ double d;
+ if (Tcl_GetDouble(interp, argv[14], &d) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ floatVar = (float) d;
+ Tcl_UpdateLinkedVar(interp, "float");
+ }
+ if (argv[15][0]) {
+ Tcl_WideInt w;
+ tmp = Tcl_NewStringObj(argv[15], -1);
+ if (Tcl_GetWideIntFromObj(interp, tmp, &w) != TCL_OK) {
+ Tcl_DecrRefCount(tmp);
+ return TCL_ERROR;
+ }
+ Tcl_DecrRefCount(tmp);
+ uwideVar = (Tcl_WideUInt) w;
+ Tcl_UpdateLinkedVar(interp, "uwide");
+ }
} else {
Tcl_AppendResult(interp, "bad option \"", argv[1],
- "\": should be create, delete, get, set, or update",
- (char *) NULL);
+ "\": should be create, delete, get, set, or update", NULL);
return TCL_ERROR;
}
return TCL_OK;
@@ -2759,17 +3241,17 @@ TestlinkCmd(dummy, interp, argc, argv)
*/
static int
-TestlocaleCmd(clientData, interp, objc, objv)
- ClientData clientData; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* The argument objects. */
+TestlocaleCmd(
+ ClientData clientData, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* The argument objects. */
{
int index;
char *locale;
- static CONST char *optionStrings[] = {
- "ctype", "numeric", "time", "collate", "monetary",
+ static const char *optionStrings[] = {
+ "ctype", "numeric", "time", "collate", "monetary",
"all", NULL
};
static int lcTypes[] = {
@@ -2785,7 +3267,7 @@ TestlocaleCmd(clientData, interp, objc, objv)
Tcl_WrongNumArgs(interp, 1, objv, "category ?locale?");
return TCL_ERROR;
}
-
+
if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0,
&index) != TCL_OK) {
return TCL_ERROR;
@@ -2822,14 +3304,14 @@ TestlocaleCmd(clientData, interp, objc, objv)
/* ARGSUSED */
static int
-TestMathFunc(clientData, interp, args, resultPtr)
- ClientData clientData; /* Integer value to return. */
- Tcl_Interp *interp; /* Not used. */
- Tcl_Value *args; /* Not used. */
- Tcl_Value *resultPtr; /* Where to store result. */
+TestMathFunc(
+ ClientData clientData, /* Integer value to return. */
+ Tcl_Interp *interp, /* Not used. */
+ Tcl_Value *args, /* Not used. */
+ Tcl_Value *resultPtr) /* Where to store result. */
{
resultPtr->type = TCL_INT;
- resultPtr->intValue = (int) clientData;
+ resultPtr->intValue = PTR2INT(clientData);
return TCL_OK;
}
@@ -2852,26 +3334,25 @@ TestMathFunc(clientData, interp, args, resultPtr)
/* ARGSUSED */
static int
-TestMathFunc2(clientData, interp, args, resultPtr)
- ClientData clientData; /* Integer value to return. */
- Tcl_Interp *interp; /* Used to report errors. */
- Tcl_Value *args; /* Points to an array of two
- * Tcl_Value structs for the
- * two arguments. */
- Tcl_Value *resultPtr; /* Where to store the result. */
+TestMathFunc2(
+ ClientData clientData, /* Integer value to return. */
+ Tcl_Interp *interp, /* Used to report errors. */
+ Tcl_Value *args, /* Points to an array of two Tcl_Value structs
+ * for the two arguments. */
+ Tcl_Value *resultPtr) /* Where to store the result. */
{
int result = TCL_OK;
-
+
/*
* Return the maximum of the two arguments with the correct type.
*/
-
+
if (args[0].type == TCL_INT) {
int i0 = args[0].intValue;
-
+
if (args[1].type == TCL_INT) {
int i1 = args[1].intValue;
-
+
resultPtr->type = TCL_INT;
resultPtr->intValue = ((i0 > i1)? i0 : i1);
} else if (args[1].type == TCL_DOUBLE) {
@@ -2892,10 +3373,10 @@ TestMathFunc2(clientData, interp, args, resultPtr)
}
} 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) {
@@ -2914,10 +3395,10 @@ TestMathFunc2(clientData, interp, args, resultPtr)
}
} 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) {
@@ -2960,9 +3441,9 @@ TestMathFunc2(clientData, interp, args, resultPtr)
*/
/* ARGSUSED */
static void
-CleanupTestSetassocdataTests(clientData, interp)
- ClientData clientData; /* Data to be released. */
- Tcl_Interp *interp; /* Interpreter being deleted. */
+CleanupTestSetassocdataTests(
+ ClientData clientData, /* Data to be released. */
+ Tcl_Interp *interp) /* Interpreter being deleted. */
{
ckfree((char *) clientData);
}
@@ -2985,11 +3466,11 @@ CleanupTestSetassocdataTests(clientData, interp)
*/
static int
-TestparserObjCmd(clientData, interp, objc, objv)
- ClientData clientData; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* The argument objects. */
+TestparserObjCmd(
+ ClientData clientData, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* The argument objects. */
{
char *script;
int length, dummy;
@@ -3041,11 +3522,11 @@ TestparserObjCmd(clientData, interp, objc, objv)
*/
static int
-TestexprparserObjCmd(clientData, interp, objc, objv)
- ClientData clientData; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* The argument objects. */
+TestexprparserObjCmd(
+ ClientData clientData, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* The argument objects. */
{
char *script;
int length, dummy;
@@ -3062,6 +3543,10 @@ TestexprparserObjCmd(clientData, interp, objc, objv)
if (length == 0) {
length = dummy;
}
+ parse.commentStart = NULL;
+ parse.commentSize = 0;
+ parse.commandStart = NULL;
+ parse.commandSize = 0;
if (Tcl_ParseExpr(interp, script, length, &parse) != TCL_OK) {
Tcl_AddErrorInfo(interp, "\n (remainder of expr: \"");
Tcl_AddErrorInfo(interp, parse.term);
@@ -3098,10 +3583,10 @@ TestexprparserObjCmd(clientData, interp, objc, objv)
*/
static void
-PrintParse(interp, parsePtr)
- Tcl_Interp *interp; /* Interpreter whose result is to be set to
+PrintParse(
+ Tcl_Interp *interp, /* Interpreter whose result is to be set to
* the contents of a parse structure. */
- Tcl_Parse *parsePtr; /* Parse structure to print out. */
+ Tcl_Parse *parsePtr) /* Parse structure to print out. */
{
Tcl_Obj *objPtr;
char *typeString;
@@ -3110,56 +3595,58 @@ PrintParse(interp, parsePtr)
objPtr = Tcl_GetObjResult(interp);
if (parsePtr->commentSize > 0) {
- Tcl_ListObjAppendElement((Tcl_Interp *) NULL, objPtr,
+ Tcl_ListObjAppendElement(NULL, objPtr,
Tcl_NewStringObj(parsePtr->commentStart,
parsePtr->commentSize));
} else {
- Tcl_ListObjAppendElement((Tcl_Interp *) NULL, objPtr,
- Tcl_NewStringObj("-", 1));
+ Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewStringObj("-", 1));
}
- Tcl_ListObjAppendElement((Tcl_Interp *) NULL, objPtr,
+ Tcl_ListObjAppendElement(NULL, objPtr,
Tcl_NewStringObj(parsePtr->commandStart, parsePtr->commandSize));
- Tcl_ListObjAppendElement((Tcl_Interp *) NULL, objPtr,
+ Tcl_ListObjAppendElement(NULL, objPtr,
Tcl_NewIntObj(parsePtr->numWords));
for (i = 0; i < parsePtr->numTokens; i++) {
tokenPtr = &parsePtr->tokenPtr[i];
switch (tokenPtr->type) {
- case TCL_TOKEN_WORD:
- typeString = "word";
- break;
- case TCL_TOKEN_SIMPLE_WORD:
- typeString = "simple";
- break;
- case TCL_TOKEN_TEXT:
- typeString = "text";
- break;
- case TCL_TOKEN_BS:
- typeString = "backslash";
- break;
- case TCL_TOKEN_COMMAND:
- typeString = "command";
- break;
- case TCL_TOKEN_VARIABLE:
- typeString = "variable";
- break;
- case TCL_TOKEN_SUB_EXPR:
- typeString = "subexpr";
- break;
- case TCL_TOKEN_OPERATOR:
- typeString = "operator";
- break;
- default:
- typeString = "??";
- break;
+ case TCL_TOKEN_EXPAND_WORD:
+ typeString = "expand";
+ break;
+ case TCL_TOKEN_WORD:
+ typeString = "word";
+ break;
+ case TCL_TOKEN_SIMPLE_WORD:
+ typeString = "simple";
+ break;
+ case TCL_TOKEN_TEXT:
+ typeString = "text";
+ break;
+ case TCL_TOKEN_BS:
+ typeString = "backslash";
+ break;
+ case TCL_TOKEN_COMMAND:
+ typeString = "command";
+ break;
+ case TCL_TOKEN_VARIABLE:
+ typeString = "variable";
+ break;
+ case TCL_TOKEN_SUB_EXPR:
+ typeString = "subexpr";
+ break;
+ case TCL_TOKEN_OPERATOR:
+ typeString = "operator";
+ break;
+ default:
+ typeString = "??";
+ break;
}
- Tcl_ListObjAppendElement((Tcl_Interp *) NULL, objPtr,
+ Tcl_ListObjAppendElement(NULL, objPtr,
Tcl_NewStringObj(typeString, -1));
- Tcl_ListObjAppendElement((Tcl_Interp *) NULL, objPtr,
+ Tcl_ListObjAppendElement(NULL, objPtr,
Tcl_NewStringObj(tokenPtr->start, tokenPtr->size));
- Tcl_ListObjAppendElement((Tcl_Interp *) NULL, objPtr,
+ Tcl_ListObjAppendElement(NULL, objPtr,
Tcl_NewIntObj(tokenPtr->numComponents));
}
- Tcl_ListObjAppendElement((Tcl_Interp *) NULL, objPtr,
+ Tcl_ListObjAppendElement(NULL, objPtr,
Tcl_NewStringObj(parsePtr->commandStart + parsePtr->commandSize,
-1));
}
@@ -3182,14 +3669,13 @@ PrintParse(interp, parsePtr)
*/
static int
-TestparsevarObjCmd(clientData, interp, objc, objv)
- ClientData clientData; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* The argument objects. */
+TestparsevarObjCmd(
+ ClientData clientData, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* The argument objects. */
{
- CONST char *value;
- CONST char *name, *termPtr;
+ const char *value, *name, *termPtr;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "varName");
@@ -3224,11 +3710,11 @@ TestparsevarObjCmd(clientData, interp, objc, objv)
*/
static int
-TestparsevarnameObjCmd(clientData, interp, objc, objv)
- ClientData clientData; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* The argument objects. */
+TestparsevarnameObjCmd(
+ ClientData clientData, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* The argument objects. */
{
char *script;
int append, length, dummy;
@@ -3273,10 +3759,10 @@ TestparsevarnameObjCmd(clientData, interp, objc, objv)
*
* TestregexpObjCmd --
*
- * This procedure implements the "testregexp" command. It is
- * used to give a direct interface for regexp flags. It's identical
- * to Tcl_RegexpObjCmd except for the -xflags option, and the
- * consequences thereof (including the REG_EXPECT kludge).
+ * This procedure implements the "testregexp" command. It is used to give
+ * a direct interface for regexp flags. It's identical to
+ * Tcl_RegexpObjCmd except for the -xflags option, and the consequences
+ * thereof (including the REG_EXPECT kludge).
*
* Results:
* A standard Tcl result.
@@ -3289,11 +3775,11 @@ TestparsevarnameObjCmd(clientData, interp, objc, objv)
/* ARGSUSED */
static int
-TestregexpObjCmd(dummy, interp, objc, objv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* Argument objects. */
+TestregexpObjCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
int i, ii, indices, stringLength, match, about;
int hasxflags, cflags, eflags;
@@ -3301,11 +3787,11 @@ TestregexpObjCmd(dummy, interp, objc, objv)
char *string;
Tcl_Obj *objPtr;
Tcl_RegExpInfo info;
- static CONST char *options[] = {
+ static const char *options[] = {
"-indices", "-nocase", "-about", "-expanded",
"-line", "-linestop", "-lineanchor",
"-xflags",
- "--", (char *) NULL
+ "--", NULL
};
enum options {
REGEXP_INDICES, REGEXP_NOCASE, REGEXP_ABOUT, REGEXP_EXPANDED,
@@ -3319,7 +3805,7 @@ TestregexpObjCmd(dummy, interp, objc, objv)
cflags = REG_ADVANCED;
eflags = 0;
hasxflags = 0;
-
+
for (i = 1; i < objc; i++) {
char *name;
int index;
@@ -3333,46 +3819,37 @@ TestregexpObjCmd(dummy, interp, objc, objv)
return TCL_ERROR;
}
switch ((enum options) index) {
- case REGEXP_INDICES: {
- indices = 1;
- break;
- }
- case REGEXP_NOCASE: {
- cflags |= REG_ICASE;
- break;
- }
- case REGEXP_ABOUT: {
- about = 1;
- break;
- }
- case REGEXP_EXPANDED: {
- cflags |= REG_EXPANDED;
- break;
- }
- case REGEXP_MULTI: {
- cflags |= REG_NEWLINE;
- break;
- }
- case REGEXP_NOCROSS: {
- cflags |= REG_NLSTOP;
- break;
- }
- case REGEXP_NEWL: {
- cflags |= REG_NLANCH;
- break;
- }
- case REGEXP_XFLAGS: {
- hasxflags = 1;
- break;
- }
- case REGEXP_LAST: {
- i++;
- goto endOfForLoop;
- }
+ case REGEXP_INDICES:
+ indices = 1;
+ break;
+ case REGEXP_NOCASE:
+ cflags |= REG_ICASE;
+ break;
+ case REGEXP_ABOUT:
+ about = 1;
+ break;
+ case REGEXP_EXPANDED:
+ cflags |= REG_EXPANDED;
+ break;
+ case REGEXP_MULTI:
+ cflags |= REG_NEWLINE;
+ break;
+ case REGEXP_NOCROSS:
+ cflags |= REG_NLSTOP;
+ break;
+ case REGEXP_NEWL:
+ cflags |= REG_NLANCH;
+ break;
+ case REGEXP_XFLAGS:
+ hasxflags = 1;
+ break;
+ case REGEXP_LAST:
+ i++;
+ goto endOfForLoop;
}
}
- endOfForLoop:
+ endOfForLoop:
if (objc - i < hasxflags + 2 - about) {
Tcl_WrongNumArgs(interp, 1, objv,
"?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?");
@@ -3392,7 +3869,6 @@ TestregexpObjCmd(dummy, interp, objc, objv)
if (regExpr == NULL) {
return TCL_ERROR;
}
- objPtr = objv[1];
if (about) {
if (TclRegAbout(interp, regExpr) < 0) {
@@ -3401,6 +3877,7 @@ TestregexpObjCmd(dummy, interp, objc, objv)
return TCL_OK;
}
+ objPtr = objv[1];
match = Tcl_RegExpExecObj(interp, regExpr, objPtr, 0 /* offset */,
objc-2 /* nmatches */, eflags);
@@ -3410,13 +3887,13 @@ TestregexpObjCmd(dummy, interp, objc, objv)
if (match == 0) {
/*
* Set the interpreter's object result to an integer object w/
- * value 0.
+ * value 0.
*/
-
+
Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
if (objc > 2 && (cflags&REG_EXPECT) && indices) {
char *varName;
- CONST char *value;
+ const char *value;
int start, end;
char resinfo[TCL_INTEGER_SPACE * 2];
@@ -3426,12 +3903,12 @@ TestregexpObjCmd(dummy, interp, objc, objv)
value = Tcl_SetVar(interp, varName, resinfo, 0);
if (value == NULL) {
Tcl_AppendResult(interp, "couldn't set variable \"",
- varName, "\"", (char *) NULL);
+ varName, "\"", NULL);
return TCL_ERROR;
}
} else if (cflags & TCL_REG_CANMATCH) {
char *varName;
- CONST char *value;
+ const char *value;
char resinfo[TCL_INTEGER_SPACE * 2];
Tcl_RegExpGetInfo(regExpr, &info);
@@ -3440,7 +3917,7 @@ TestregexpObjCmd(dummy, interp, objc, objv)
value = Tcl_SetVar(interp, varName, resinfo, 0);
if (value == NULL) {
Tcl_AppendResult(interp, "couldn't set variable \"",
- varName, "\"", (char *) NULL);
+ varName, "\"", NULL);
return TCL_ERROR;
}
}
@@ -3459,7 +3936,7 @@ TestregexpObjCmd(dummy, interp, objc, objv)
for (i = 0; i < objc; i++) {
int start, end;
Tcl_Obj *newPtr, *varPtr, *valuePtr;
-
+
varPtr = objv[i];
ii = ((cflags&REG_EXPECT) && i == objc-1) ? -1 : i;
if (indices) {
@@ -3476,10 +3953,10 @@ TestregexpObjCmd(dummy, interp, objc, objv)
}
/*
- * Adjust index so it refers to the last character in the
- * match instead of the first character after the match.
+ * Adjust index so it refers to the last character in the match
+ * instead of the first character after the match.
*/
-
+
if (end >= 0) {
end--;
}
@@ -3499,20 +3976,18 @@ TestregexpObjCmd(dummy, interp, objc, objv)
info.matches[ii].end - 1);
}
}
- Tcl_IncrRefCount(newPtr);
valuePtr = Tcl_ObjSetVar2(interp, varPtr, NULL, newPtr, 0);
- Tcl_DecrRefCount(newPtr);
if (valuePtr == NULL) {
Tcl_AppendResult(interp, "couldn't set variable \"",
- Tcl_GetString(varPtr), "\"", (char *) NULL);
+ Tcl_GetString(varPtr), "\"", NULL);
return TCL_ERROR;
}
}
/*
- * Set the interpreter's object result to an integer object w/ value 1.
+ * Set the interpreter's object result to an integer object w/ value 1.
*/
-
+
Tcl_SetIntObj(Tcl_GetObjResult(interp), 1);
return TCL_OK;
}
@@ -3535,86 +4010,68 @@ TestregexpObjCmd(dummy, interp, objc, objv)
*/
static void
-TestregexpXflags(string, length, cflagsPtr, eflagsPtr)
- char *string; /* The string of flags. */
- int length; /* The length of the string in bytes. */
- int *cflagsPtr; /* compile flags word */
- int *eflagsPtr; /* exec flags word */
+TestregexpXflags(
+ char *string, /* The string of flags. */
+ int length, /* The length of the string in bytes. */
+ int *cflagsPtr, /* compile flags word */
+ int *eflagsPtr) /* exec flags word */
{
- int i;
- int cflags;
- int eflags;
+ int i, cflags, eflags;
cflags = *cflagsPtr;
eflags = *eflagsPtr;
for (i = 0; i < length; i++) {
switch (string[i]) {
- case 'a': {
- cflags |= REG_ADVF;
- break;
- }
- case 'b': {
- cflags &= ~REG_ADVANCED;
- break;
- }
- case 'c': {
- cflags |= TCL_REG_CANMATCH;
- break;
- }
- case 'e': {
- cflags &= ~REG_ADVANCED;
- cflags |= REG_EXTENDED;
- break;
- }
- case 'q': {
- cflags &= ~REG_ADVANCED;
- cflags |= REG_QUOTE;
- break;
- }
- case 'o': { /* o for opaque */
- cflags |= REG_NOSUB;
- break;
- }
- case 's': { /* s for start */
- cflags |= REG_BOSONLY;
- break;
- }
- case '+': {
- cflags |= REG_FAKE;
- break;
- }
- case ',': {
- cflags |= REG_PROGRESS;
- break;
- }
- case '.': {
- cflags |= REG_DUMP;
- break;
- }
- case ':': {
- eflags |= REG_MTRACE;
- break;
- }
- case ';': {
- eflags |= REG_FTRACE;
- break;
- }
- case '^': {
- eflags |= REG_NOTBOL;
- break;
- }
- case '$': {
- eflags |= REG_NOTEOL;
- break;
- }
- case 't': {
- cflags |= REG_EXPECT;
- break;
- }
- case '%': {
- eflags |= REG_SMALL;
- break;
- }
+ case 'a':
+ cflags |= REG_ADVF;
+ break;
+ case 'b':
+ cflags &= ~REG_ADVANCED;
+ break;
+ case 'c':
+ cflags |= TCL_REG_CANMATCH;
+ break;
+ case 'e':
+ cflags &= ~REG_ADVANCED;
+ cflags |= REG_EXTENDED;
+ break;
+ case 'q':
+ cflags &= ~REG_ADVANCED;
+ cflags |= REG_QUOTE;
+ break;
+ case 'o': /* o for opaque */
+ cflags |= REG_NOSUB;
+ break;
+ case 's': /* s for start */
+ cflags |= REG_BOSONLY;
+ break;
+ case '+':
+ cflags |= REG_FAKE;
+ break;
+ case ',':
+ cflags |= REG_PROGRESS;
+ break;
+ case '.':
+ cflags |= REG_DUMP;
+ break;
+ case ':':
+ eflags |= REG_MTRACE;
+ break;
+ case ';':
+ eflags |= REG_FTRACE;
+ break;
+ case '^':
+ eflags |= REG_NOTBOL;
+ break;
+ case '$':
+ eflags |= REG_NOTEOL;
+ break;
+ case 't':
+ cflags |= REG_EXPECT;
+ break;
+ case '%':
+ eflags |= REG_SMALL;
+ break;
}
}
@@ -3625,6 +4082,37 @@ TestregexpXflags(string, length, cflagsPtr, eflagsPtr)
/*
*----------------------------------------------------------------------
*
+ * TestreturnObjCmd --
+ *
+ * This procedure implements the "testreturn" command. It is
+ * used to verify that a
+ * return TCL_RETURN;
+ * has same behavior as
+ * return Tcl_SetReturnOptions(interp, Tcl_NewObj());
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+ /* ARGSUSED */
+static int
+TestreturnObjCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ return TCL_RETURN;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TestsetassocdataCmd --
*
* This procedure implements the "testsetassocdata" command. It is used
@@ -3641,20 +4129,19 @@ TestregexpXflags(string, length, cflagsPtr, eflagsPtr)
*/
static int
-TestsetassocdataCmd(clientData, interp, argc, argv)
- ClientData clientData; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- CONST char **argv; /* Argument strings. */
-{
- char *buf;
- char *oldData;
+TestsetassocdataCmd(
+ ClientData clientData, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int argc, /* Number of arguments. */
+ const char **argv) /* Argument strings. */
+{
+ char *buf, *oldData;
Tcl_InterpDeleteProc *procPtr;
-
+
if (argc != 3) {
- Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
- " data_key data_item\"", (char *) NULL);
- return TCL_ERROR;
+ Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
+ " data_key data_item\"", NULL);
+ return TCL_ERROR;
}
buf = ckalloc((unsigned) strlen(argv[2]) + 1);
@@ -3669,8 +4156,8 @@ TestsetassocdataCmd(clientData, interp, argc, argv)
if ((oldData != NULL) && (procPtr == CleanupTestSetassocdataTests)) {
ckfree(oldData);
}
-
- Tcl_SetAssocData(interp, argv[1], CleanupTestSetassocdataTests,
+
+ Tcl_SetAssocData(interp, argv[1], CleanupTestSetassocdataTests,
(ClientData) buf);
return TCL_OK;
}
@@ -3694,37 +4181,31 @@ TestsetassocdataCmd(clientData, interp, argc, argv)
*/
static int
-TestsetplatformCmd(clientData, interp, argc, argv)
- ClientData clientData; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- CONST char **argv; /* Argument strings. */
+TestsetplatformCmd(
+ ClientData clientData, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int argc, /* Number of arguments. */
+ const char **argv) /* Argument strings. */
{
size_t length;
TclPlatformType *platform;
-#ifdef __WIN32__
- platform = TclWinGetPlatform();
-#else
- platform = &tclPlatform;
-#endif
-
+ platform = TclGetPlatform();
+
if (argc != 2) {
- Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
- " platform\"", (char *) NULL);
- return TCL_ERROR;
+ Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
+ " platform\"", NULL);
+ return TCL_ERROR;
}
length = strlen(argv[1]);
if (strncmp(argv[1], "unix", length) == 0) {
*platform = TCL_PLATFORM_UNIX;
- } else if (strncmp(argv[1], "mac", length) == 0) {
- *platform = TCL_PLATFORM_MAC;
} else if (strncmp(argv[1], "windows", length) == 0) {
*platform = TCL_PLATFORM_WINDOWS;
} else {
- Tcl_AppendResult(interp, "unsupported platform: should be one of ",
- "unix, mac, or windows", (char *) NULL);
+ Tcl_AppendResult(interp, "unsupported platform: should be one of "
+ "unix, or windows", NULL);
return TCL_ERROR;
}
return TCL_OK;
@@ -3749,17 +4230,17 @@ TestsetplatformCmd(clientData, interp, argc, argv)
*/
static int
-TeststaticpkgCmd(dummy, interp, argc, argv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- CONST char **argv; /* Argument strings. */
+TeststaticpkgCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int argc, /* Number of arguments. */
+ const char **argv) /* Argument strings. */
{
int safe, loaded;
if (argc != 4) {
Tcl_AppendResult(interp, "wrong # arguments: should be \"",
- argv[0], " pkgName safe loaded\"", (char *) NULL);
+ argv[0], " pkgName safe loaded\"", NULL);
return TCL_ERROR;
}
if (Tcl_GetInt(interp, argv[2], &safe) != TCL_OK) {
@@ -3774,9 +4255,9 @@ TeststaticpkgCmd(dummy, interp, argc, argv)
}
static int
-StaticInitProc(interp)
- Tcl_Interp *interp; /* Interpreter in which package
- * is supposedly being loaded. */
+StaticInitProc(
+ Tcl_Interp *interp) /* Interpreter in which package is supposedly
+ * being loaded. */
{
Tcl_SetVar(interp, "x", "loaded", TCL_GLOBAL_ONLY);
return TCL_OK;
@@ -3800,18 +4281,18 @@ StaticInitProc(interp)
*/
static int
-TesttranslatefilenameCmd(dummy, interp, argc, argv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- CONST char **argv; /* Argument strings. */
+TesttranslatefilenameCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int argc, /* Number of arguments. */
+ const char **argv) /* Argument strings. */
{
Tcl_DString buffer;
- CONST char *result;
+ const char *result;
if (argc != 2) {
Tcl_AppendResult(interp, "wrong # arguments: should be \"",
- argv[0], " path\"", (char *) NULL);
+ argv[0], " path\"", NULL);
return TCL_ERROR;
}
result = Tcl_TranslateFileName(interp, argv[1], &buffer);
@@ -3842,17 +4323,17 @@ TesttranslatefilenameCmd(dummy, interp, argc, argv)
/* ARGSUSED */
static int
-TestupvarCmd(dummy, interp, argc, argv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- CONST char **argv; /* Argument strings. */
+TestupvarCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int argc, /* Number of arguments. */
+ const char **argv) /* Argument strings. */
{
int flags = 0;
-
+
if ((argc != 5) && (argc != 6)) {
Tcl_AppendResult(interp, "wrong # arguments: should be \"",
- argv[0], " level name ?name2? dest global\"", (char *) NULL);
+ argv[0], " level name ?name2? dest global\"", NULL);
return TCL_ERROR;
}
@@ -3869,8 +4350,8 @@ TestupvarCmd(dummy, interp, argc, argv)
} else if (strcmp(argv[5], "namespace") == 0) {
flags = TCL_NAMESPACE_ONLY;
}
- return Tcl_UpVar2(interp, argv[1], argv[2],
- (argv[3][0] == 0) ? (char *) NULL : argv[3], argv[4],
+ return Tcl_UpVar2(interp, argv[1], argv[2],
+ (argv[3][0] == 0) ? NULL : argv[3], argv[4],
flags);
}
}
@@ -3880,9 +4361,8 @@ TestupvarCmd(dummy, interp, argc, argv)
*
* TestseterrorcodeCmd --
*
- * This procedure implements the "testseterrorcodeCmd".
- * This tests up to five elements passed to the
- * Tcl_SetErrorCode command.
+ * This procedure implements the "testseterrorcodeCmd". This tests up to
+ * five elements passed to the Tcl_SetErrorCode command.
*
* Results:
* A standard Tcl result. Always returns TCL_ERROR so that
@@ -3896,11 +4376,11 @@ TestupvarCmd(dummy, interp, argc, argv)
/* ARGSUSED */
static int
-TestseterrorcodeCmd(dummy, interp, argc, argv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- CONST char **argv; /* Argument strings. */
+TestseterrorcodeCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int argc, /* Number of arguments. */
+ const char **argv) /* Argument strings. */
{
if (argc > 6) {
Tcl_SetResult(interp, "too many args", TCL_STATIC);
@@ -3931,22 +4411,13 @@ TestseterrorcodeCmd(dummy, interp, argc, argv)
/* ARGSUSED */
static int
-TestsetobjerrorcodeCmd(dummy, interp, objc, objv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* The argument objects. */
+TestsetobjerrorcodeCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* The argument objects. */
{
- Tcl_Obj *listObjPtr;
-
- if (objc > 1) {
- listObjPtr = Tcl_ConcatObj(objc - 1, objv + 1);
- } else {
- listObjPtr = Tcl_NewObj();
- }
- Tcl_IncrRefCount(listObjPtr);
- Tcl_SetObjErrorCode(interp, listObjPtr);
- Tcl_DecrRefCount(listObjPtr);
+ Tcl_SetObjErrorCode(interp, Tcl_ConcatObj(objc - 1, objv + 1));
return TCL_ERROR;
}
@@ -3969,11 +4440,11 @@ TestsetobjerrorcodeCmd(dummy, interp, objc, objv)
/* ARGSUSED */
static int
-TestfeventCmd(clientData, interp, argc, argv)
- ClientData clientData; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- CONST char **argv; /* Argument strings. */
+TestfeventCmd(
+ ClientData clientData, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int argc, /* Number of arguments. */
+ const char **argv) /* Argument strings. */
{
static Tcl_Interp *interp2 = NULL;
int code;
@@ -3981,46 +4452,46 @@ TestfeventCmd(clientData, interp, argc, argv)
if (argc < 2) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " option ?arg arg ...?", (char *) 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", (char *) NULL);
+ " cmd script", NULL);
return TCL_ERROR;
}
- if (interp2 != (Tcl_Interp *) NULL) {
- code = Tcl_GlobalEval(interp2, argv[2]);
+ if (interp2 != NULL) {
+ code = Tcl_GlobalEval(interp2, argv[2]);
Tcl_SetObjResult(interp, Tcl_GetObjResult(interp2));
- return code;
- } else {
- Tcl_AppendResult(interp,
- "called \"testfevent code\" before \"testfevent create\"",
- (char *) NULL);
- return TCL_ERROR;
- }
+ return code;
+ } else {
+ Tcl_AppendResult(interp,
+ "called \"testfevent code\" before \"testfevent create\"",
+ NULL);
+ return TCL_ERROR;
+ }
} else if (strcmp(argv[1], "create") == 0) {
if (interp2 != NULL) {
- Tcl_DeleteInterp(interp2);
+ Tcl_DeleteInterp(interp2);
}
- interp2 = Tcl_CreateInterp();
+ interp2 = Tcl_CreateInterp();
return Tcl_Init(interp2);
} else if (strcmp(argv[1], "delete") == 0) {
if (interp2 != NULL) {
- Tcl_DeleteInterp(interp2);
+ Tcl_DeleteInterp(interp2);
}
interp2 = NULL;
} else if (strcmp(argv[1], "share") == 0) {
- if (interp2 != NULL) {
- chan = Tcl_GetChannel(interp, argv[2], NULL);
- if (chan == (Tcl_Channel) NULL) {
- return TCL_ERROR;
- }
- Tcl_RegisterChannel(interp2, chan);
- }
+ if (interp2 != NULL) {
+ chan = Tcl_GetChannel(interp, argv[2], NULL);
+ if (chan == (Tcl_Channel) NULL) {
+ return TCL_ERROR;
+ }
+ Tcl_RegisterChannel(interp2, chan);
+ }
}
-
+
return TCL_OK;
}
@@ -4032,7 +4503,7 @@ TestfeventCmd(clientData, interp, argc, argv)
* Calls the panic routine.
*
* Results:
- * Always returns TCL_OK.
+ * Always returns TCL_OK.
*
* Side effects:
* May exit application.
@@ -4041,37 +4512,37 @@ TestfeventCmd(clientData, interp, argc, argv)
*/
static int
-TestpanicCmd(dummy, interp, argc, argv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- CONST char **argv; /* Argument strings. */
-{
- CONST char *argString;
-
+TestpanicCmd(
+ 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
*/
argString = Tcl_Merge(argc-1, argv+1);
- panic(argString);
+ Tcl_Panic("%s", argString);
ckfree((char *)argString);
-
+
return TCL_OK;
}
-
+
static int
-TestfileCmd(dummy, interp, argc, argv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- Tcl_Obj *CONST argv[]; /* The argument objects. */
+TestfileCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int argc, /* Number of arguments. */
+ Tcl_Obj *const argv[]) /* The argument objects. */
{
int force, i, j, result;
Tcl_Obj *error = NULL;
char *subcmd;
-
+
if (argc < 3) {
return TCL_ERROR;
}
@@ -4079,7 +4550,7 @@ TestfileCmd(dummy, interp, argc, argv)
force = 0;
i = 2;
if (strcmp(Tcl_GetString(argv[2]), "-force") == 0) {
- force = 1;
+ force = 1;
i = 3;
}
@@ -4088,30 +4559,30 @@ TestfileCmd(dummy, interp, argc, argv)
}
for (j = i; j < argc; j++) {
- if (Tcl_FSGetNormalizedPath(interp, argv[j]) == NULL) {
+ if (Tcl_FSGetNormalizedPath(interp, argv[j]) == NULL) {
return TCL_ERROR;
}
}
subcmd = Tcl_GetString(argv[1]);
-
+
if (strcmp(subcmd, "mv") == 0) {
result = TclpObjRenameFile(argv[i], argv[i + 1]);
} else if (strcmp(subcmd, "cp") == 0) {
- result = TclpObjCopyFile(argv[i], argv[i + 1]);
+ result = TclpObjCopyFile(argv[i], argv[i + 1]);
} else if (strcmp(subcmd, "rm") == 0) {
- result = TclpObjDeleteFile(argv[i]);
+ result = TclpObjDeleteFile(argv[i]);
} else if (strcmp(subcmd, "mkdir") == 0) {
- result = TclpObjCreateDirectory(argv[i]);
+ result = TclpObjCreateDirectory(argv[i]);
} else if (strcmp(subcmd, "cpdir") == 0) {
- result = TclpObjCopyDirectory(argv[i], argv[i + 1], &error);
+ result = TclpObjCopyDirectory(argv[i], argv[i + 1], &error);
} else if (strcmp(subcmd, "rmdir") == 0) {
- result = TclpObjRemoveDirectory(argv[i], force, &error);
+ result = TclpObjRemoveDirectory(argv[i], force, &error);
} else {
- result = TCL_ERROR;
+ result = TCL_ERROR;
goto end;
}
-
+
if (result != TCL_OK) {
if (error != NULL) {
if (Tcl_GetString(error)[0] != '\0') {
@@ -4119,11 +4590,10 @@ TestfileCmd(dummy, interp, argc, argv)
}
Tcl_DecrRefCount(error);
}
- Tcl_AppendResult(interp, Tcl_ErrnoId(), (char *) NULL);
+ Tcl_AppendResult(interp, Tcl_ErrnoId(), NULL);
}
- end:
-
+ end:
return result;
}
@@ -4145,24 +4615,24 @@ TestfileCmd(dummy, interp, argc, argv)
*/
static int
-TestgetvarfullnameCmd(dummy, interp, objc, objv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* The argument objects. */
+TestgetvarfullnameCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* The argument objects. */
{
char *name, *arg;
int flags = 0;
Tcl_Namespace *namespacePtr;
- Tcl_CallFrame frame;
+ Tcl_CallFrame *framePtr;
Tcl_Var variable;
int result;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "name scope");
- return TCL_ERROR;
+ return TCL_ERROR;
}
-
+
name = Tcl_GetString(objv[1]);
arg = Tcl_GetString(objv[2]);
@@ -4173,30 +4643,29 @@ TestgetvarfullnameCmd(dummy, interp, objc, objv)
}
/*
- * This command, like any other created with Tcl_Create[Obj]Command,
- * runs in the global namespace. As a "namespace-aware" command that
- * needs to run in a particular namespace, it must activate that
- * namespace itself.
+ * This command, like any other created with Tcl_Create[Obj]Command, runs
+ * in the global namespace. As a "namespace-aware" command that needs to
+ * run in a particular namespace, it must activate that namespace itself.
*/
if (flags == TCL_NAMESPACE_ONLY) {
- namespacePtr = Tcl_FindNamespace(interp, "::test_ns_var",
- (Tcl_Namespace *) NULL, TCL_LEAVE_ERR_MSG);
+ namespacePtr = Tcl_FindNamespace(interp, "::test_ns_var", NULL,
+ TCL_LEAVE_ERR_MSG);
if (namespacePtr == NULL) {
return TCL_ERROR;
}
- result = Tcl_PushCallFrame(interp, &frame, namespacePtr,
- /*isProcCallFrame*/ 0);
+ result = TclPushStackFrame(interp, &framePtr, namespacePtr,
+ /*isProcCallFrame*/ 0);
if (result != TCL_OK) {
return result;
}
}
-
- variable = Tcl_FindNamespaceVar(interp, name, (Tcl_Namespace *) NULL,
+
+ variable = Tcl_FindNamespaceVar(interp, name, NULL,
(flags | TCL_LEAVE_ERR_MSG));
if (flags == TCL_NAMESPACE_ONLY) {
- Tcl_PopCallFrame(interp);
+ TclPopStackFrame(interp);
}
if (variable == (Tcl_Var) NULL) {
return TCL_ERROR;
@@ -4210,10 +4679,9 @@ TestgetvarfullnameCmd(dummy, interp, objc, objv)
*
* 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, sprintf, converting
- * variables, etc.
+ * This procedure implements the "gettimes" command. It is used for
+ * computing the time needed for various basic operations such as reading
+ * variables, allocating memory, sprintf, converting variables, etc.
*
* Results:
* A standard Tcl result.
@@ -4225,19 +4693,18 @@ TestgetvarfullnameCmd(dummy, interp, objc, objv)
*/
static int
-GetTimesCmd(unused, interp, argc, argv)
- ClientData unused; /* Unused. */
- Tcl_Interp *interp; /* The current interpreter. */
- int argc; /* The number of arguments. */
- CONST char **argv; /* The argument strings. */
+GetTimesCmd(
+ ClientData unused, /* Unused. */
+ Tcl_Interp *interp, /* The current interpreter. */
+ int argc, /* The number of arguments. */
+ const char **argv) /* The argument strings. */
{
Interp *iPtr = (Interp *) interp;
int i, n;
double timePer;
Tcl_Time start, stop;
- Tcl_Obj *objPtr;
- Tcl_Obj **objv;
- CONST char *s;
+ Tcl_Obj *objPtr, **objv;
+ const char *s;
char newString[TCL_INTEGER_SPACE];
/* alloc & free 100000 times */
@@ -4250,7 +4717,7 @@ GetTimesCmd(unused, interp, argc, argv)
Tcl_GetTime(&stop);
timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
fprintf(stderr, " %.3f usec per alloc+free\n", timePer/100000);
-
+
/* alloc 5000 times */
fprintf(stderr, "alloc 5000 6 word items\n");
objv = (Tcl_Obj **) ckalloc(5000 * sizeof(Tcl_Obj *));
@@ -4261,7 +4728,7 @@ GetTimesCmd(unused, interp, argc, argv)
Tcl_GetTime(&stop);
timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
fprintf(stderr, " %.3f usec per alloc\n", timePer/5000);
-
+
/* free 5000 times */
fprintf(stderr, "free 5000 6 word items\n");
Tcl_GetTime(&start);
@@ -4281,7 +4748,7 @@ GetTimesCmd(unused, interp, argc, argv)
Tcl_GetTime(&stop);
timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
fprintf(stderr, " %.3f usec per Tcl_NewObj\n", timePer/5000);
-
+
/* Tcl_DecrRefCount 5000 times */
fprintf(stderr, "Tcl_DecrRefCount 5000 times\n");
Tcl_GetTime(&start);
@@ -4319,7 +4786,7 @@ GetTimesCmd(unused, interp, argc, argv)
fprintf(stderr, " %.3f usec per Tcl_GetIntFromObj of \"12345\"\n",
timePer/100000);
Tcl_DecrRefCount(objPtr);
-
+
/* Tcl_GetInt 100000 times */
fprintf(stderr, "Tcl_GetInt of \"12345\" 100000 times\n");
Tcl_GetTime(&start);
@@ -4382,7 +4849,7 @@ GetTimesCmd(unused, interp, argc, argv)
timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
fprintf(stderr, " %.3f usec per Tcl_GetVar of a==\"12345\"\n",
timePer/100000);
-
+
Tcl_ResetResult(interp);
return TCL_OK;
}
@@ -4405,11 +4872,11 @@ GetTimesCmd(unused, interp, argc, argv)
*/
static int
-NoopCmd(unused, interp, argc, argv)
- ClientData unused; /* Unused. */
- Tcl_Interp *interp; /* The current interpreter. */
- int argc; /* The number of arguments. */
- CONST char **argv; /* The argument strings. */
+NoopCmd(
+ ClientData unused, /* Unused. */
+ Tcl_Interp *interp, /* The current interpreter. */
+ int argc, /* The number of arguments. */
+ const char **argv) /* The argument strings. */
{
return TCL_OK;
}
@@ -4432,11 +4899,11 @@ NoopCmd(unused, interp, argc, argv)
*/
static int
-NoopObjCmd(unused, interp, objc, objv)
- ClientData unused; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* The argument objects. */
+NoopObjCmd(
+ ClientData unused, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* The argument objects. */
{
return TCL_OK;
}
@@ -4460,34 +4927,66 @@ NoopObjCmd(unused, interp, objc, objv)
/* ARGSUSED */
static int
-TestsetCmd(data, interp, argc, argv)
- ClientData data; /* Additional flags for Get/SetVar2. */
- register Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- CONST char **argv; /* Argument strings. */
+TestsetCmd(
+ ClientData data, /* Additional flags for Get/SetVar2. */
+ register Tcl_Interp *interp,/* Current interpreter. */
+ int argc, /* Number of arguments. */
+ const char **argv) /* Argument strings. */
{
- int flags = (int) data;
- CONST char *value;
+ int flags = PTR2INT(data);
+ const char *value;
if (argc == 2) {
- Tcl_SetResult(interp, "before get", TCL_STATIC);
- value = Tcl_GetVar2(interp, argv[1], (char *) NULL, flags);
- if (value == NULL) {
- return TCL_ERROR;
- }
+ Tcl_SetResult(interp, "before get", TCL_STATIC);
+ value = Tcl_GetVar2(interp, argv[1], NULL, flags);
+ if (value == NULL) {
+ return TCL_ERROR;
+ }
Tcl_AppendElement(interp, value);
- return TCL_OK;
+ return TCL_OK;
} else if (argc == 3) {
Tcl_SetResult(interp, "before set", TCL_STATIC);
- value = Tcl_SetVar2(interp, argv[1], (char *) NULL, argv[2], flags);
- if (value == NULL) {
- return TCL_ERROR;
- }
+ value = Tcl_SetVar2(interp, argv[1], NULL, argv[2], flags);
+ if (value == NULL) {
+ return TCL_ERROR;
+ }
Tcl_AppendElement(interp, value);
return TCL_OK;
} else {
Tcl_AppendResult(interp, "wrong # args: should be \"",
- argv[0], " varName ?newValue?\"", (char *) NULL);
+ argv[0], " varName ?newValue?\"", NULL);
+ return TCL_ERROR;
+ }
+}
+static int
+Testset2Cmd(
+ ClientData data, /* Additional flags for Get/SetVar2. */
+ register Tcl_Interp *interp,/* Current interpreter. */
+ int argc, /* Number of arguments. */
+ const char **argv) /* Argument strings. */
+{
+ int flags = PTR2INT(data);
+ const char *value;
+
+ if (argc == 3) {
+ Tcl_SetResult(interp, "before get", TCL_STATIC);
+ value = Tcl_GetVar2(interp, argv[1], argv[2], flags);
+ if (value == NULL) {
+ return TCL_ERROR;
+ }
+ Tcl_AppendElement(interp, value);
+ return TCL_OK;
+ } else if (argc == 4) {
+ Tcl_SetResult(interp, "before set", TCL_STATIC);
+ value = Tcl_SetVar2(interp, argv[1], argv[2], argv[3], flags);
+ if (value == NULL) {
+ return TCL_ERROR;
+ }
+ Tcl_AppendElement(interp, value);
+ return TCL_OK;
+ } else {
+ Tcl_AppendResult(interp, "wrong # args: should be \"",
+ argv[0], " varName elemName ?newValue?\"", NULL);
return TCL_ERROR;
}
}
@@ -4497,9 +4996,8 @@ TestsetCmd(data, interp, argc, argv)
*
* TestsaveresultCmd --
*
- * Implements the "testsaveresult" cmd that is used when testing
- * the Tcl_SaveResult, Tcl_RestoreResult, and
- * Tcl_DiscardResult interfaces.
+ * Implements the "testsaveresult" cmd that is used when testing the
+ * Tcl_SaveResult, Tcl_RestoreResult, and Tcl_DiscardResult interfaces.
*
* Results:
* A standard Tcl result.
@@ -4512,16 +5010,16 @@ TestsetCmd(data, interp, argc, argv)
/* ARGSUSED */
static int
-TestsaveresultCmd(dummy, interp, objc, objv)
- ClientData dummy; /* Not used. */
- register Tcl_Interp *interp; /* Current interpreter. */
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* The argument objects. */
+TestsaveresultCmd(
+ ClientData dummy, /* Not used. */
+ register Tcl_Interp *interp,/* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* The argument objects. */
{
int discard, result, index;
Tcl_SavedResult state;
Tcl_Obj *objPtr;
- static CONST char *optionStrings[] = {
+ static const char *optionStrings[] = {
"append", "dynamic", "free", "object", "small", NULL
};
enum options {
@@ -4534,7 +5032,7 @@ TestsaveresultCmd(dummy, interp, objc, objv)
if (objc != 4) {
Tcl_WrongNumArgs(interp, 1, objv, "type script discard");
- return TCL_ERROR;
+ return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0,
&index) != TCL_OK) {
@@ -4546,25 +5044,26 @@ TestsaveresultCmd(dummy, interp, objc, objv)
objPtr = NULL; /* Lint. */
switch ((enum options) index) {
- case RESULT_SMALL:
- Tcl_SetResult(interp, "small result", TCL_VOLATILE);
- break;
- case RESULT_APPEND:
- Tcl_AppendResult(interp, "append result", NULL);
- break;
- case RESULT_FREE: {
- char *buf = ckalloc(200);
- strcpy(buf, "free result");
- Tcl_SetResult(interp, buf, TCL_DYNAMIC);
- break;
- }
- case RESULT_DYNAMIC:
- Tcl_SetResult(interp, "dynamic result", TestsaveresultFree);
- break;
- case RESULT_OBJECT:
- objPtr = Tcl_NewStringObj("object result", -1);
- Tcl_SetObjResult(interp, objPtr);
- break;
+ case RESULT_SMALL:
+ Tcl_SetResult(interp, "small result", TCL_VOLATILE);
+ break;
+ case RESULT_APPEND:
+ Tcl_AppendResult(interp, "append result", NULL);
+ break;
+ case RESULT_FREE: {
+ char *buf = ckalloc(200);
+
+ strcpy(buf, "free result");
+ Tcl_SetResult(interp, buf, TCL_DYNAMIC);
+ break;
+ }
+ case RESULT_DYNAMIC:
+ Tcl_SetResult(interp, "dynamic result", TestsaveresultFree);
+ break;
+ case RESULT_OBJECT:
+ objPtr = Tcl_NewStringObj("object result", -1);
+ Tcl_SetObjResult(interp, objPtr);
+ break;
}
freeCount = 0;
@@ -4584,19 +5083,20 @@ TestsaveresultCmd(dummy, interp, objc, objv)
}
switch ((enum options) index) {
- case RESULT_DYNAMIC: {
- int present = interp->freeProc == TestsaveresultFree;
- int called = freeCount;
- Tcl_AppendElement(interp, called ? "called" : "notCalled");
- Tcl_AppendElement(interp, present ? "present" : "missing");
- break;
- }
- case RESULT_OBJECT:
- Tcl_AppendElement(interp, Tcl_GetObjResult(interp) == objPtr
- ? "same" : "different");
- break;
- default:
- break;
+ case RESULT_DYNAMIC: {
+ int present = interp->freeProc == TestsaveresultFree;
+ int called = freeCount;
+
+ Tcl_AppendElement(interp, called ? "called" : "notCalled");
+ Tcl_AppendElement(interp, present ? "present" : "missing");
+ break;
+ }
+ case RESULT_OBJECT:
+ Tcl_AppendElement(interp, Tcl_GetObjResult(interp) == objPtr
+ ? "same" : "different");
+ break;
+ default:
+ break;
}
return result;
}
@@ -4618,11 +5118,12 @@ TestsaveresultCmd(dummy, interp, objc, objv)
*/
static void
-TestsaveresultFree(blockPtr)
- char *blockPtr;
+TestsaveresultFree(
+ char *blockPtr)
{
freeCount++;
}
+#ifdef USE_OBSOLETE_FS_HOOKS
/*
*----------------------------------------------------------------------
@@ -4642,18 +5143,18 @@ TestsaveresultFree(blockPtr)
*/
static int
-TeststatprocCmd (dummy, interp, argc, argv)
- ClientData dummy; /* Not used. */
- register Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- CONST char **argv; /* Argument strings. */
+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\"", (char *) NULL);
+ argv[0], " option arg\"", NULL);
return TCL_ERROR;
}
@@ -4666,41 +5167,40 @@ TeststatprocCmd (dummy, interp, argc, argv)
} else if (strcmp(argv[2], "TestStatProc3") == 0) {
proc = TestStatProc3;
} else {
- Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": ",
- "must be TclpStat, ",
- "TestStatProc1, TestStatProc2, or TestStatProc3",
- (char *) NULL);
+ 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",
- (char *) NULL);
+ 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", (char *) NULL);
+ 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", (char *) NULL);
+ Tcl_AppendResult(interp, "\"", argv[2], "\": "
+ "could not be ", argv[1], "ed", NULL);
}
return retVal;
}
-static int PretendTclpStat(path, buf)
- CONST char *path;
- Tcl_StatBuf *buf;
+static int
+PretendTclpStat(
+ const char *path,
+ struct stat *buf)
{
int ret;
Tcl_Obj *pathPtr = Tcl_NewStringObj(path, -1);
@@ -4738,8 +5238,8 @@ static int PretendTclpStat(path, buf)
* Note that ino_t/ino64_t is unsigned...
*/
- if (OUT_OF_URANGE(realBuf.st_ino) || OUT_OF_RANGE(realBuf.st_size)
-# ifdef HAVE_ST_BLOCKS
+ 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
) {
@@ -4747,9 +5247,9 @@ static int PretendTclpStat(path, buf)
errno = EOVERFLOW;
# else
# ifdef EFBIG
- errno = EFBIG;
+ errno = EFBIG;
# else
-# error "what error should be returned for a value out of range?"
+# error "what error should be returned for a value out of range?"
# endif
# endif
return -1;
@@ -4759,11 +5259,11 @@ static int PretendTclpStat(path, buf)
# 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...
+ * 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;
@@ -4777,8 +5277,10 @@ static int PretendTclpStat(path, buf)
buf->st_atime = realBuf.st_atime;
buf->st_mtime = realBuf.st_mtime;
buf->st_ctime = realBuf.st_ctime;
-# ifdef HAVE_ST_BLOCKS
+# 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
}
@@ -4786,42 +5288,36 @@ static int PretendTclpStat(path, buf)
#endif /* TCL_WIDE_INT_IS_LONG */
}
-/* Be careful in the compares in these tests, since the Macintosh puts a
- * leading : in the beginning of non-absolute paths before passing them
- * into the file command procedures.
- */
-
static int
-TestStatProc1(path, buf)
- CONST char *path;
- Tcl_StatBuf *buf;
+TestStatProc1(
+ const char *path,
+ struct stat *buf)
{
- memset(buf, 0, sizeof(Tcl_StatBuf));
+ memset(buf, 0, sizeof(struct stat));
buf->st_size = 1234;
return ((strstr(path, "testStat1%.fil") == NULL) ? -1 : 0);
}
-
static int
-TestStatProc2(path, buf)
- CONST char *path;
- Tcl_StatBuf *buf;
+TestStatProc2(
+ const char *path,
+ struct stat *buf)
{
- memset(buf, 0, sizeof(Tcl_StatBuf));
+ memset(buf, 0, sizeof(struct stat));
buf->st_size = 2345;
return ((strstr(path, "testStat2%.fil") == NULL) ? -1 : 0);
}
-
static int
-TestStatProc3(path, buf)
- CONST char *path;
- Tcl_StatBuf *buf;
+TestStatProc3(
+ const char *path,
+ struct stat *buf)
{
- memset(buf, 0, sizeof(Tcl_StatBuf));
+ memset(buf, 0, sizeof(struct stat));
buf->st_size = 3456;
return ((strstr(path, "testStat3%.fil") == NULL) ? -1 : 0);
}
+#endif
/*
*----------------------------------------------------------------------
@@ -4841,14 +5337,14 @@ TestStatProc3(path, buf)
*/
static int
-TestmainthreadCmd (dummy, interp, argc, argv)
- ClientData dummy; /* Not used. */
- register Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- CONST char **argv; /* Argument strings. */
+TestmainthreadCmd(
+ ClientData dummy, /* Not used. */
+ register Tcl_Interp *interp,/* Current interpreter. */
+ int argc, /* Number of arguments. */
+ const char **argv) /* Argument strings. */
{
if (argc == 1) {
- Tcl_Obj *idObj = Tcl_NewLongObj((long)Tcl_GetCurrentThread());
+ Tcl_Obj *idObj = Tcl_NewLongObj((long)(intptr_t)Tcl_GetCurrentThread());
Tcl_SetObjResult(interp, idObj);
return TCL_OK;
} else {
@@ -4901,11 +5397,11 @@ MainLoop(void)
*/
static int
-TestsetmainloopCmd (dummy, interp, argc, argv)
- ClientData dummy; /* Not used. */
- register Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- CONST char **argv; /* Argument strings. */
+TestsetmainloopCmd(
+ ClientData dummy, /* Not used. */
+ register Tcl_Interp *interp,/* Current interpreter. */
+ int argc, /* Number of arguments. */
+ const char **argv) /* Argument strings. */
{
exitMainLoop = 0;
Tcl_SetMainLoop(MainLoop);
@@ -4930,15 +5426,16 @@ TestsetmainloopCmd (dummy, interp, argc, argv)
*/
static int
-TestexitmainloopCmd (dummy, interp, argc, argv)
- ClientData dummy; /* Not used. */
- register Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- CONST char **argv; /* Argument strings. */
+TestexitmainloopCmd(
+ ClientData dummy, /* Not used. */
+ register Tcl_Interp *interp,/* Current interpreter. */
+ int argc, /* Number of arguments. */
+ const char **argv) /* Argument strings. */
{
exitMainLoop = 1;
return TCL_OK;
}
+#ifdef USE_OBSOLETE_FS_HOOKS
/*
*----------------------------------------------------------------------
@@ -4958,18 +5455,18 @@ TestexitmainloopCmd (dummy, interp, argc, argv)
*/
static int
-TestaccessprocCmd (dummy, interp, argc, argv)
- ClientData dummy; /* Not used. */
- register Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- CONST char **argv; /* Argument strings. */
+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\"", (char *) NULL);
+ argv[0], " option arg\"", NULL);
return TCL_ERROR;
}
@@ -4982,41 +5479,40 @@ TestaccessprocCmd (dummy, interp, argc, argv)
} else if (strcmp(argv[2], "TestAccessProc3") == 0) {
proc = TestAccessProc3;
} else {
- Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": ",
- "must be TclpAccess, ",
- "TestAccessProc1, TestAccessProc2, or TestAccessProc3",
- (char *) NULL);
+ 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",
- (char *) NULL);
+ 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", (char *) NULL);
+ 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", (char *) NULL);
+ Tcl_AppendResult(interp, "\"", argv[2], "\": "
+ "could not be ", argv[1], "ed", NULL);
}
return retVal;
}
-static int PretendTclpAccess(path, mode)
- CONST char *path;
- int mode;
+static int
+PretendTclpAccess(
+ const char *path,
+ int mode)
{
int ret;
Tcl_Obj *pathPtr = Tcl_NewStringObj(path, -1);
@@ -5027,27 +5523,25 @@ static int PretendTclpAccess(path, mode)
}
static int
-TestAccessProc1(path, mode)
- CONST char *path;
- int mode;
+TestAccessProc1(
+ const char *path,
+ int mode)
{
return ((strstr(path, "testAccess1%.fil") == NULL) ? -1 : 0);
}
-
static int
-TestAccessProc2(path, mode)
- CONST char *path;
- int mode;
+TestAccessProc2(
+ const char *path,
+ int mode)
{
return ((strstr(path, "testAccess2%.fil") == NULL) ? -1 : 0);
}
-
static int
-TestAccessProc3(path, mode)
- CONST char *path;
- int mode;
+TestAccessProc3(
+ const char *path,
+ int mode)
{
return ((strstr(path, "testAccess3%.fil") == NULL) ? -1 : 0);
}
@@ -5057,8 +5551,9 @@ TestAccessProc3(path, mode)
*
* TestopenfilechannelprocCmd --
*
- * Implements the "testTclOpenFileChannelProc" cmd that is used to test the
- * 'TclOpenFileChannelInsertProc' & 'TclOpenFileChannelDeleteProc' C Apis.
+ * Implements the "testTclOpenFileChannelProc" cmd that is used to test
+ * the 'TclOpenFileChannelInsertProc' & 'TclOpenFileChannelDeleteProc' C
+ * Apis.
*
* Results:
* A standard Tcl result.
@@ -5070,18 +5565,18 @@ TestAccessProc3(path, mode)
*/
static int
-TestopenfilechannelprocCmd (dummy, interp, argc, argv)
- ClientData dummy; /* Not used. */
- register Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- CONST char **argv; /* Argument strings. */
+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\"", (char *) NULL);
+ argv[0], " option arg\"", NULL);
return TCL_ERROR;
}
@@ -5094,50 +5589,47 @@ TestopenfilechannelprocCmd (dummy, interp, argc, argv)
} else if (strcmp(argv[2], "TestOpenFileChannelProc3") == 0) {
proc = TestOpenFileChannelProc3;
} else {
- Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": ",
- "must be TclpOpenFileChannel, ",
- "TestOpenFileChannelProc1, TestOpenFileChannelProc2, or ",
- "TestOpenFileChannelProc3",
- (char *) NULL);
+ 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",
- (char *) NULL);
+ 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", (char *) NULL);
+ 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", (char *) NULL);
+ Tcl_AppendResult(interp, "\"", argv[2], "\": "
+ "could not be ", argv[1], "ed", NULL);
}
return retVal;
}
static Tcl_Channel
-PretendTclpOpenFileChannel(interp, fileName, modeString, permissions)
- Tcl_Interp *interp; /* Interpreter for error reporting;
- * can be NULL. */
- CONST char *fileName; /* Name of file to open. */
- CONST char *modeString; /* A list of POSIX open modes or
- * a string such as "rw". */
- int permissions; /* If the open involves creating a
- * file, with what modes to create
- * it? */
+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;
@@ -5153,11 +5645,10 @@ PretendTclpOpenFileChannel(interp, fileName, modeString, permissions)
if (ret != NULL) {
if (seekFlag) {
if (Tcl_Seek(ret, (Tcl_WideInt)0, SEEK_END) < (Tcl_WideInt)0) {
- if (interp != (Tcl_Interp *) NULL) {
+ if (interp != NULL) {
Tcl_AppendResult(interp,
- "could not seek to end of file while opening \"",
- fileName, "\": ",
- Tcl_PosixError(interp), (char *) NULL);
+ "could not seek to end of file while opening \"",
+ fileName, "\": ", Tcl_PosixError(interp), NULL);
}
Tcl_Close(NULL, ret);
return NULL;
@@ -5168,53 +5659,52 @@ PretendTclpOpenFileChannel(interp, fileName, modeString, permissions)
}
static Tcl_Channel
-TestOpenFileChannelProc1(interp, fileName, modeString, permissions)
- Tcl_Interp *interp; /* Interpreter for error reporting;
- * can be NULL. */
- CONST char *fileName; /* Name of file to open. */
- CONST char *modeString; /* A list of POSIX open modes or
- * a string such as "rw". */
- int permissions; /* If the open involves creating a
- * file, with what modes to create
- * it? */
-{
- CONST char *expectname="testOpenFileChannel1%.fil";
+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",
+ return (PretendTclpOpenFileChannel(interp,
+ "__testOpenFileChannel1%__.fil",
modeString, permissions));
} else {
Tcl_DStringFree(&ds);
- return (NULL);
+ return NULL;
}
}
-
static Tcl_Channel
-TestOpenFileChannelProc2(interp, fileName, modeString, permissions)
- Tcl_Interp *interp; /* Interpreter for error reporting;
- * can be NULL. */
- CONST char *fileName; /* Name of file to open. */
- CONST char *modeString; /* A list of POSIX open modes or
- * a string such as "rw". */
- int permissions; /* If the open involves creating a
- * file, with what modes to create
- * it? */
-{
- CONST char *expectname="testOpenFileChannel2%.fil";
+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",
+ return (PretendTclpOpenFileChannel(interp,
+ "__testOpenFileChannel2%__.fil",
modeString, permissions));
} else {
Tcl_DStringFree(&ds);
@@ -5222,21 +5712,19 @@ TestOpenFileChannelProc2(interp, fileName, modeString, permissions)
}
}
-
static Tcl_Channel
-TestOpenFileChannelProc3(interp, fileName, modeString, permissions)
- Tcl_Interp *interp; /* Interpreter for error reporting;
- * can be NULL. */
- CONST char *fileName; /* Name of file to open. */
- CONST char *modeString; /* A list of POSIX open modes or
- * a string such as "rw". */
- int permissions; /* If the open involves creating a
- * file, with what modes to create
- * it? */
-{
- CONST char *expectname="testOpenFileChannel3%.fil";
+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);
@@ -5249,6 +5737,7 @@ TestOpenFileChannelProc3(interp, fileName, modeString, permissions)
return (NULL);
}
}
+#endif
/*
*----------------------------------------------------------------------
@@ -5269,13 +5758,13 @@ TestOpenFileChannelProc3(interp, fileName, modeString, permissions)
/* ARGSUSED */
static int
-TestChannelCmd(clientData, interp, argc, argv)
- ClientData clientData; /* Not used. */
- Tcl_Interp *interp; /* Interpreter for result. */
- int argc; /* Count of additional args. */
- CONST char **argv; /* Additional arg strings. */
+TestChannelCmd(
+ ClientData clientData, /* Not used. */
+ Tcl_Interp *interp, /* Interpreter for result. */
+ int argc, /* Count of additional args. */
+ const char **argv) /* Additional arg strings. */
{
- CONST char *cmdName; /* Sub command. */
+ const char *cmdName; /* Sub command. */
Tcl_HashTable *hTblPtr; /* Hash table of channels. */
Tcl_HashSearch hSearch; /* Search variable. */
Tcl_HashEntry *hPtr; /* Search variable. */
@@ -5284,28 +5773,49 @@ TestChannelCmd(clientData, interp, argc, argv)
Tcl_Channel chan; /* The opaque type. */
size_t len; /* Length of subcommand string. */
int IOQueued; /* How much IO is queued inside channel? */
- ChannelBuffer *bufPtr; /* For iterating over queued IO. */
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..?\"", (char *) NULL);
- return TCL_ERROR;
+ Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
+ " subcommand ?additional args..?\"", NULL);
+ return TCL_ERROR;
}
cmdName = argv[1];
len = strlen(cmdName);
- chanPtr = (Channel *) NULL;
+ chanPtr = NULL;
if (argc > 2) {
- chan = Tcl_GetChannel(interp, argv[2], &mode);
- if (chan == (Tcl_Channel) NULL) {
- return TCL_ERROR;
- }
- chanPtr = (Channel *) chan;
+ if ((cmdName[0] == 's') && (strncmp(cmdName, "splice", len) == 0)) {
+ /* For splice access the pool of detached channels.
+ * Locate channel, remove from the list.
+ */
+
+ TestChannel **nextPtrPtr, *curPtr;
+
+ chan = (Tcl_Channel) NULL;
+ for (nextPtrPtr = &firstDetached, curPtr = firstDetached;
+ curPtr != NULL;
+ nextPtrPtr = &(curPtr->nextPtr), curPtr = curPtr->nextPtr) {
+
+ if (strcmp(argv[2], Tcl_GetChannelName(curPtr->chan)) == 0) {
+ *nextPtrPtr = curPtr->nextPtr;
+ curPtr->nextPtr = NULL;
+ chan = curPtr->chan;
+ ckfree((char *) curPtr);
+ break;
+ }
+ }
+ } else {
+ chan = Tcl_GetChannel(interp, argv[2], &mode);
+ }
+ if (chan == (Tcl_Channel) NULL) {
+ return TCL_ERROR;
+ }
+ chanPtr = (Channel *) chan;
statePtr = chanPtr->state;
- chanPtr = statePtr->topChanPtr;
+ chanPtr = statePtr->topChanPtr;
chan = (Tcl_Channel) chanPtr;
} else {
/* lint */
@@ -5313,329 +5823,350 @@ TestChannelCmd(clientData, interp, argc, argv)
chan = NULL;
}
+ if ((cmdName[0] == 's') && (strncmp(cmdName, "setchannelerror", len) == 0)) {
+
+ Tcl_Obj *msg = Tcl_NewStringObj(argv[3],-1);
+
+ Tcl_IncrRefCount(msg);
+ Tcl_SetChannelError(chan, msg);
+ Tcl_DecrRefCount(msg);
+
+ Tcl_GetChannelError(chan, &msg);
+ Tcl_SetObjResult(interp, msg);
+ Tcl_DecrRefCount(msg);
+ return TCL_OK;
+ }
+ if ((cmdName[0] == 's') && (strncmp(cmdName, "setchannelerrorinterp", len) == 0)) {
+
+ Tcl_Obj *msg = Tcl_NewStringObj(argv[3],-1);
+
+ Tcl_IncrRefCount(msg);
+ Tcl_SetChannelErrorInterp(interp, msg);
+ Tcl_DecrRefCount(msg);
+
+ Tcl_GetChannelErrorInterp(interp, &msg);
+ Tcl_SetObjResult(interp, msg);
+ Tcl_DecrRefCount(msg);
+ return TCL_OK;
+ }
+
+ /*
+ * "cut" is actually more a simplified detach facility as provided by the
+ * Thread package. Without the safeguards of a regular command (no
+ * checking that the command is truly cut'able, no mutexes for
+ * thread-safety). Its complementary command is "splice", see below.
+ */
+
if ((cmdName[0] == 'c') && (strncmp(cmdName, "cut", len) == 0)) {
- if (argc != 3) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " cut channelName\"", (char *) NULL);
- return TCL_ERROR;
- }
- Tcl_CutChannel(chan);
- return TCL_OK;
+ TestChannel *det;
+
+ if (argc != 3) {
+ Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
+ " cut channelName\"", NULL);
+ return TCL_ERROR;
+ }
+
+ Tcl_RegisterChannel(NULL, chan); /* prevent closing */
+ Tcl_UnregisterChannel(interp, chan);
+
+ Tcl_CutChannel(chan);
+
+ /* Remember the channel in the pool of detached channels */
+
+ det = (TestChannel *) ckalloc(sizeof(TestChannel));
+ det->chan = chan;
+ det->nextPtr = firstDetached;
+ firstDetached = det;
+
+ return TCL_OK;
}
if ((cmdName[0] == 'c') &&
(strncmp(cmdName, "clearchannelhandlers", len) == 0)) {
- if (argc != 3) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " clearchannelhandlers channelName\"", (char *) NULL);
- return TCL_ERROR;
- }
- Tcl_ClearChannelHandlers(chan);
- return TCL_OK;
+ if (argc != 3) {
+ Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
+ " clearchannelhandlers channelName\"", NULL);
+ return TCL_ERROR;
+ }
+ Tcl_ClearChannelHandlers(chan);
+ return TCL_OK;
}
if ((cmdName[0] == 'i') && (strncmp(cmdName, "info", len) == 0)) {
- if (argc != 3) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " info channelName\"", (char *) NULL);
- return TCL_ERROR;
- }
- Tcl_AppendElement(interp, argv[2]);
- Tcl_AppendElement(interp, Tcl_ChannelName(chanPtr->typePtr));
- if (statePtr->flags & TCL_READABLE) {
- Tcl_AppendElement(interp, "read");
- } else {
- Tcl_AppendElement(interp, "");
- }
- if (statePtr->flags & TCL_WRITABLE) {
- Tcl_AppendElement(interp, "write");
- } else {
- Tcl_AppendElement(interp, "");
- }
- if (statePtr->flags & CHANNEL_NONBLOCKING) {
- Tcl_AppendElement(interp, "nonblocking");
- } else {
- Tcl_AppendElement(interp, "blocking");
- }
- if (statePtr->flags & CHANNEL_LINEBUFFERED) {
- Tcl_AppendElement(interp, "line");
- } else if (statePtr->flags & CHANNEL_UNBUFFERED) {
- Tcl_AppendElement(interp, "none");
- } else {
- Tcl_AppendElement(interp, "full");
- }
- if (statePtr->flags & BG_FLUSH_SCHEDULED) {
- Tcl_AppendElement(interp, "async_flush");
- } else {
- Tcl_AppendElement(interp, "");
- }
- if (statePtr->flags & CHANNEL_EOF) {
- Tcl_AppendElement(interp, "eof");
- } else {
- Tcl_AppendElement(interp, "");
- }
- if (statePtr->flags & CHANNEL_BLOCKED) {
- Tcl_AppendElement(interp, "blocked");
- } else {
- Tcl_AppendElement(interp, "unblocked");
- }
- if (statePtr->inputTranslation == TCL_TRANSLATE_AUTO) {
- Tcl_AppendElement(interp, "auto");
- if (statePtr->flags & INPUT_SAW_CR) {
- Tcl_AppendElement(interp, "saw_cr");
- } else {
- Tcl_AppendElement(interp, "");
- }
- } else if (statePtr->inputTranslation == TCL_TRANSLATE_LF) {
- Tcl_AppendElement(interp, "lf");
- Tcl_AppendElement(interp, "");
- } else if (statePtr->inputTranslation == TCL_TRANSLATE_CR) {
- Tcl_AppendElement(interp, "cr");
- Tcl_AppendElement(interp, "");
- } else if (statePtr->inputTranslation == TCL_TRANSLATE_CRLF) {
- Tcl_AppendElement(interp, "crlf");
- if (statePtr->flags & INPUT_SAW_CR) {
- Tcl_AppendElement(interp, "queued_cr");
- } else {
- Tcl_AppendElement(interp, "");
- }
- }
- if (statePtr->outputTranslation == TCL_TRANSLATE_AUTO) {
- Tcl_AppendElement(interp, "auto");
- } else if (statePtr->outputTranslation == TCL_TRANSLATE_LF) {
- Tcl_AppendElement(interp, "lf");
- } else if (statePtr->outputTranslation == TCL_TRANSLATE_CR) {
- Tcl_AppendElement(interp, "cr");
- } else if (statePtr->outputTranslation == TCL_TRANSLATE_CRLF) {
- Tcl_AppendElement(interp, "crlf");
- }
- for (IOQueued = 0, bufPtr = statePtr->inQueueHead;
- bufPtr != (ChannelBuffer *) NULL;
- bufPtr = bufPtr->nextPtr) {
- IOQueued += bufPtr->nextAdded - bufPtr->nextRemoved;
- }
- TclFormatInt(buf, IOQueued);
- Tcl_AppendElement(interp, buf);
-
- IOQueued = 0;
- if (statePtr->curOutPtr != (ChannelBuffer *) NULL) {
- IOQueued = statePtr->curOutPtr->nextAdded -
- statePtr->curOutPtr->nextRemoved;
- }
- for (bufPtr = statePtr->outQueueHead;
- bufPtr != (ChannelBuffer *) NULL;
- bufPtr = bufPtr->nextPtr) {
- IOQueued += (bufPtr->nextAdded - bufPtr->nextRemoved);
- }
- TclFormatInt(buf, IOQueued);
- Tcl_AppendElement(interp, buf);
-
- TclFormatInt(buf, (int)Tcl_Tell((Tcl_Channel) chanPtr));
- Tcl_AppendElement(interp, buf);
+ if (argc != 3) {
+ Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
+ " info channelName\"", NULL);
+ return TCL_ERROR;
+ }
+ Tcl_AppendElement(interp, argv[2]);
+ Tcl_AppendElement(interp, Tcl_ChannelName(chanPtr->typePtr));
+ if (statePtr->flags & TCL_READABLE) {
+ Tcl_AppendElement(interp, "read");
+ } else {
+ Tcl_AppendElement(interp, "");
+ }
+ if (statePtr->flags & TCL_WRITABLE) {
+ Tcl_AppendElement(interp, "write");
+ } else {
+ Tcl_AppendElement(interp, "");
+ }
+ if (statePtr->flags & CHANNEL_NONBLOCKING) {
+ Tcl_AppendElement(interp, "nonblocking");
+ } else {
+ Tcl_AppendElement(interp, "blocking");
+ }
+ if (statePtr->flags & CHANNEL_LINEBUFFERED) {
+ Tcl_AppendElement(interp, "line");
+ } else if (statePtr->flags & CHANNEL_UNBUFFERED) {
+ Tcl_AppendElement(interp, "none");
+ } else {
+ Tcl_AppendElement(interp, "full");
+ }
+ if (statePtr->flags & BG_FLUSH_SCHEDULED) {
+ Tcl_AppendElement(interp, "async_flush");
+ } else {
+ Tcl_AppendElement(interp, "");
+ }
+ if (statePtr->flags & CHANNEL_EOF) {
+ Tcl_AppendElement(interp, "eof");
+ } else {
+ Tcl_AppendElement(interp, "");
+ }
+ if (statePtr->flags & CHANNEL_BLOCKED) {
+ Tcl_AppendElement(interp, "blocked");
+ } else {
+ Tcl_AppendElement(interp, "unblocked");
+ }
+ if (statePtr->inputTranslation == TCL_TRANSLATE_AUTO) {
+ Tcl_AppendElement(interp, "auto");
+ if (statePtr->flags & INPUT_SAW_CR) {
+ Tcl_AppendElement(interp, "saw_cr");
+ } else {
+ Tcl_AppendElement(interp, "");
+ }
+ } else if (statePtr->inputTranslation == TCL_TRANSLATE_LF) {
+ Tcl_AppendElement(interp, "lf");
+ Tcl_AppendElement(interp, "");
+ } else if (statePtr->inputTranslation == TCL_TRANSLATE_CR) {
+ Tcl_AppendElement(interp, "cr");
+ Tcl_AppendElement(interp, "");
+ } else if (statePtr->inputTranslation == TCL_TRANSLATE_CRLF) {
+ Tcl_AppendElement(interp, "crlf");
+ if (statePtr->flags & INPUT_SAW_CR) {
+ Tcl_AppendElement(interp, "queued_cr");
+ } else {
+ Tcl_AppendElement(interp, "");
+ }
+ }
+ if (statePtr->outputTranslation == TCL_TRANSLATE_AUTO) {
+ Tcl_AppendElement(interp, "auto");
+ } else if (statePtr->outputTranslation == TCL_TRANSLATE_LF) {
+ Tcl_AppendElement(interp, "lf");
+ } else if (statePtr->outputTranslation == TCL_TRANSLATE_CR) {
+ Tcl_AppendElement(interp, "cr");
+ } else if (statePtr->outputTranslation == TCL_TRANSLATE_CRLF) {
+ Tcl_AppendElement(interp, "crlf");
+ }
+ IOQueued = Tcl_InputBuffered(chan);
+ TclFormatInt(buf, IOQueued);
+ Tcl_AppendElement(interp, buf);
- TclFormatInt(buf, statePtr->refCount);
- Tcl_AppendElement(interp, buf);
+ IOQueued = Tcl_OutputBuffered(chan);
+ TclFormatInt(buf, IOQueued);
+ Tcl_AppendElement(interp, buf);
- return TCL_OK;
+ TclFormatInt(buf, (int)Tcl_Tell(chan));
+ Tcl_AppendElement(interp, buf);
+
+ TclFormatInt(buf, statePtr->refCount);
+ Tcl_AppendElement(interp, buf);
+
+ return TCL_OK;
}
if ((cmdName[0] == 'i') &&
- (strncmp(cmdName, "inputbuffered", len) == 0)) {
- if (argc != 3) {
- Tcl_AppendResult(interp, "channel name required",
- (char *) NULL);
- return TCL_ERROR;
- }
-
- for (IOQueued = 0, bufPtr = statePtr->inQueueHead;
- bufPtr != (ChannelBuffer *) NULL;
- bufPtr = bufPtr->nextPtr) {
- IOQueued += bufPtr->nextAdded - bufPtr->nextRemoved;
- }
- TclFormatInt(buf, IOQueued);
- Tcl_AppendResult(interp, buf, (char *) NULL);
- return TCL_OK;
+ (strncmp(cmdName, "inputbuffered", len) == 0)) {
+ if (argc != 3) {
+ Tcl_AppendResult(interp, "channel name required", NULL);
+ return TCL_ERROR;
+ }
+ IOQueued = Tcl_InputBuffered(chan);
+ TclFormatInt(buf, IOQueued);
+ Tcl_AppendResult(interp, buf, NULL);
+ return TCL_OK;
}
if ((cmdName[0] == 'i') && (strncmp(cmdName, "isshared", len) == 0)) {
- if (argc != 3) {
- Tcl_AppendResult(interp, "channel name required", (char *) NULL);
- return TCL_ERROR;
- }
-
- TclFormatInt(buf, Tcl_IsChannelShared(chan));
- Tcl_AppendResult(interp, buf, (char *) NULL);
- return TCL_OK;
+ if (argc != 3) {
+ Tcl_AppendResult(interp, "channel name required", NULL);
+ return TCL_ERROR;
+ }
+
+ TclFormatInt(buf, Tcl_IsChannelShared(chan));
+ Tcl_AppendResult(interp, buf, NULL);
+ return TCL_OK;
}
if ((cmdName[0] == 'i') && (strncmp(cmdName, "isstandard", len) == 0)) {
if (argc != 3) {
- Tcl_AppendResult(interp, "channel name required", (char *) NULL);
+ Tcl_AppendResult(interp, "channel name required", NULL);
return TCL_ERROR;
}
-
+
TclFormatInt(buf, Tcl_IsStandardChannel(chan));
- Tcl_AppendResult(interp, buf, (char *) 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",
- (char *) NULL);
- return TCL_ERROR;
- }
-
- if (statePtr->flags & TCL_READABLE) {
- Tcl_AppendElement(interp, "read");
- } else {
- Tcl_AppendElement(interp, "");
- }
- if (statePtr->flags & TCL_WRITABLE) {
- Tcl_AppendElement(interp, "write");
- } else {
- Tcl_AppendElement(interp, "");
- }
- return TCL_OK;
+ if (argc != 3) {
+ Tcl_AppendResult(interp, "channel name required", NULL);
+ return TCL_ERROR;
+ }
+
+ if (statePtr->flags & TCL_READABLE) {
+ Tcl_AppendElement(interp, "read");
+ } else {
+ Tcl_AppendElement(interp, "");
+ }
+ if (statePtr->flags & TCL_WRITABLE) {
+ Tcl_AppendElement(interp, "write");
+ } else {
+ Tcl_AppendElement(interp, "");
+ }
+ return TCL_OK;
}
-
+
if ((cmdName[0] == 'm') && (strncmp(cmdName, "mthread", len) == 0)) {
- if (argc != 3) {
- Tcl_AppendResult(interp, "channel name required",
- (char *) NULL);
- return TCL_ERROR;
- }
+ if (argc != 3) {
+ Tcl_AppendResult(interp, "channel name required", NULL);
+ return TCL_ERROR;
+ }
- TclFormatInt(buf, (long) Tcl_GetChannelThread(chan));
- Tcl_AppendResult(interp, buf, (char *) NULL);
- return TCL_OK;
+ TclFormatInt(buf, (long)(intptr_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",
- (char *) NULL);
- return TCL_ERROR;
- }
- Tcl_AppendResult(interp, statePtr->channelName, (char *) NULL);
- return TCL_OK;
+ if (argc != 3) {
+ Tcl_AppendResult(interp, "channel name required", NULL);
+ return TCL_ERROR;
+ }
+ Tcl_AppendResult(interp, statePtr->channelName, NULL);
+ return TCL_OK;
}
if ((cmdName[0] == 'o') && (strncmp(cmdName, "open", len) == 0)) {
- hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL);
- if (hTblPtr == (Tcl_HashTable *) NULL) {
- return TCL_OK;
- }
- for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch);
- hPtr != (Tcl_HashEntry *) NULL;
+ hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL);
+ if (hTblPtr == NULL) {
+ return TCL_OK;
+ }
+ for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch);
+ hPtr != NULL;
hPtr = Tcl_NextHashEntry(&hSearch)) {
- Tcl_AppendElement(interp, Tcl_GetHashKey(hTblPtr, hPtr));
- }
- return TCL_OK;
+ Tcl_AppendElement(interp, Tcl_GetHashKey(hTblPtr, hPtr));
+ }
+ return TCL_OK;
}
if ((cmdName[0] == 'o') &&
- (strncmp(cmdName, "outputbuffered", len) == 0)) {
- if (argc != 3) {
- Tcl_AppendResult(interp, "channel name required",
- (char *) NULL);
- return TCL_ERROR;
- }
+ (strncmp(cmdName, "outputbuffered", len) == 0)) {
+ if (argc != 3) {
+ Tcl_AppendResult(interp, "channel name required", NULL);
+ return TCL_ERROR;
+ }
- IOQueued = 0;
- if (statePtr->curOutPtr != (ChannelBuffer *) NULL) {
- IOQueued = statePtr->curOutPtr->nextAdded -
- statePtr->curOutPtr->nextRemoved;
- }
- for (bufPtr = statePtr->outQueueHead;
- bufPtr != (ChannelBuffer *) NULL;
- bufPtr = bufPtr->nextPtr) {
- IOQueued += (bufPtr->nextAdded - bufPtr->nextRemoved);
- }
- TclFormatInt(buf, IOQueued);
- Tcl_AppendResult(interp, buf, (char *) NULL);
- return TCL_OK;
+ IOQueued = Tcl_OutputBuffered(chan);
+ TclFormatInt(buf, IOQueued);
+ Tcl_AppendResult(interp, buf, NULL);
+ return TCL_OK;
}
if ((cmdName[0] == 'q') &&
- (strncmp(cmdName, "queuedcr", len) == 0)) {
- if (argc != 3) {
- Tcl_AppendResult(interp, "channel name required",
- (char *) NULL);
- return TCL_ERROR;
- }
+ (strncmp(cmdName, "queuedcr", len) == 0)) {
+ if (argc != 3) {
+ Tcl_AppendResult(interp, "channel name required", NULL);
+ return TCL_ERROR;
+ }
- Tcl_AppendResult(interp,
- (statePtr->flags & INPUT_SAW_CR) ? "1" : "0",
- (char *) NULL);
- return TCL_OK;
+ Tcl_AppendResult(interp,
+ (statePtr->flags & INPUT_SAW_CR) ? "1" : "0", NULL);
+ return TCL_OK;
}
if ((cmdName[0] == 'r') && (strncmp(cmdName, "readable", len) == 0)) {
- hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL);
- if (hTblPtr == (Tcl_HashTable *) NULL) {
- return TCL_OK;
- }
- for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch);
- hPtr != (Tcl_HashEntry *) NULL;
+ hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL);
+ if (hTblPtr == NULL) {
+ return TCL_OK;
+ }
+ for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch);
+ hPtr != NULL;
hPtr = Tcl_NextHashEntry(&hSearch)) {
- chanPtr = (Channel *) Tcl_GetHashValue(hPtr);
+ chanPtr = (Channel *) Tcl_GetHashValue(hPtr);
statePtr = chanPtr->state;
- if (statePtr->flags & TCL_READABLE) {
- Tcl_AppendElement(interp, Tcl_GetHashKey(hTblPtr, hPtr));
- }
- }
- return TCL_OK;
+ if (statePtr->flags & TCL_READABLE) {
+ Tcl_AppendElement(interp, Tcl_GetHashKey(hTblPtr, hPtr));
+ }
+ }
+ return TCL_OK;
}
if ((cmdName[0] == 'r') && (strncmp(cmdName, "refcount", len) == 0)) {
- if (argc != 3) {
- Tcl_AppendResult(interp, "channel name required",
- (char *) NULL);
- return TCL_ERROR;
- }
-
- TclFormatInt(buf, statePtr->refCount);
- Tcl_AppendResult(interp, buf, (char *) NULL);
- return TCL_OK;
+ if (argc != 3) {
+ Tcl_AppendResult(interp, "channel name required", NULL);
+ return TCL_ERROR;
+ }
+
+ TclFormatInt(buf, statePtr->refCount);
+ Tcl_AppendResult(interp, buf, NULL);
+ return TCL_OK;
}
+ /*
+ * "splice" is actually more a simplified attach facility as provided by
+ * the Thread package. Without the safeguards of a regular command (no
+ * checking that the command is truly cut'able, no mutexes for
+ * thread-safety). Its complementary command is "cut", see above.
+ */
+
if ((cmdName[0] == 's') && (strncmp(cmdName, "splice", len) == 0)) {
- if (argc != 3) {
- Tcl_AppendResult(interp, "channel name required", (char *) NULL);
- return TCL_ERROR;
- }
+ if (argc != 3) {
+ Tcl_AppendResult(interp, "channel name required", NULL);
+ return TCL_ERROR;
+ }
- Tcl_SpliceChannel(chan);
- return TCL_OK;
+ Tcl_SpliceChannel(chan);
+
+ Tcl_RegisterChannel(interp, chan);
+ Tcl_UnregisterChannel(NULL, chan);
+
+ return TCL_OK;
}
if ((cmdName[0] == 't') && (strncmp(cmdName, "type", len) == 0)) {
- if (argc != 3) {
- Tcl_AppendResult(interp, "channel name required",
- (char *) NULL);
- return TCL_ERROR;
- }
- Tcl_AppendResult(interp, Tcl_ChannelName(chanPtr->typePtr),
- (char *) NULL);
- return TCL_OK;
+ if (argc != 3) {
+ Tcl_AppendResult(interp, "channel name required", NULL);
+ return TCL_ERROR;
+ }
+ Tcl_AppendResult(interp, Tcl_ChannelName(chanPtr->typePtr), NULL);
+ return TCL_OK;
}
if ((cmdName[0] == 'w') && (strncmp(cmdName, "writable", len) == 0)) {
- hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL);
- if (hTblPtr == (Tcl_HashTable *) NULL) {
- return TCL_OK;
- }
- for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch);
- hPtr != (Tcl_HashEntry *) NULL;
- hPtr = Tcl_NextHashEntry(&hSearch)) {
- chanPtr = (Channel *) Tcl_GetHashValue(hPtr);
+ hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL);
+ if (hTblPtr == NULL) {
+ return TCL_OK;
+ }
+ for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch);
+ hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) {
+ chanPtr = (Channel *) Tcl_GetHashValue(hPtr);
statePtr = chanPtr->state;
- if (statePtr->flags & TCL_WRITABLE) {
- Tcl_AppendElement(interp, Tcl_GetHashKey(hTblPtr, hPtr));
- }
- }
- return TCL_OK;
+ if (statePtr->flags & TCL_WRITABLE) {
+ Tcl_AppendElement(interp, Tcl_GetHashKey(hTblPtr, hPtr));
+ }
+ }
+ return TCL_OK;
}
if ((cmdName[0] == 't') && (strncmp(cmdName, "transform", len) == 0)) {
@@ -5643,14 +6174,14 @@ TestChannelCmd(clientData, interp, argc, argv)
* Syntax: transform channel -command command
*/
- if (argc != 5) {
+ if (argc != 5) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " transform channelId -command cmd\"", (char *) NULL);
- return TCL_ERROR;
- }
+ " transform channelId -command cmd\"", NULL);
+ return TCL_ERROR;
+ }
if (strcmp(argv[3], "-command") != 0) {
Tcl_AppendResult(interp, "bad argument \"", argv[3],
- "\": should be \"-command\"", (char *) NULL);
+ "\": should be \"-command\"", NULL);
return TCL_ERROR;
}
@@ -5663,18 +6194,17 @@ TestChannelCmd(clientData, interp, argc, argv)
* Syntax: unstack channel
*/
- if (argc != 3) {
+ if (argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " unstack channel\"", (char *) NULL);
- return TCL_ERROR;
- }
+ " unstack channel\"", NULL);
+ return TCL_ERROR;
+ }
return Tcl_UnstackChannel(interp, chan);
}
- Tcl_AppendResult(interp, "bad option \"", cmdName, "\": should be ",
- "cut, clearchannelhandlers, info, isshared, mode, open, "
- "readable, splice, writable, transform, unstack",
- (char *) NULL);
+ Tcl_AppendResult(interp, "bad option \"", cmdName, "\": should be "
+ "cut, clearchannelhandlers, info, isshared, mode, open, "
+ "readable, splice, writable, transform, unstack", NULL);
return TCL_ERROR;
}
@@ -5683,8 +6213,8 @@ TestChannelCmd(clientData, interp, argc, argv)
*
* TestChannelEventCmd --
*
- * This procedure implements the "testchannelevent" command. It is
- * used to test the Tcl channel event mechanism.
+ * This procedure implements the "testchannelevent" command. It is used
+ * to test the Tcl channel event mechanism.
*
* Results:
* A standard Tcl result.
@@ -5697,198 +6227,198 @@ TestChannelCmd(clientData, interp, argc, argv)
/* ARGSUSED */
static int
-TestChannelEventCmd(dummy, interp, argc, argv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- CONST char **argv; /* Argument strings. */
+TestChannelEventCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int argc, /* Number of arguments. */
+ const char **argv) /* Argument strings. */
{
Tcl_Obj *resultListPtr;
Channel *chanPtr;
ChannelState *statePtr; /* state info for channel */
EventScriptRecord *esPtr, *prevEsPtr, *nextEsPtr;
- CONST char *cmd;
+ const char *cmd;
int index, i, mask, len;
if ((argc < 3) || (argc > 5)) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " channelName cmd ?arg1? ?arg2?\"", (char *) NULL);
- return TCL_ERROR;
+ Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
+ " channelName cmd ?arg1? ?arg2?\"", NULL);
+ return TCL_ERROR;
}
chanPtr = (Channel *) Tcl_GetChannel(interp, argv[1], NULL);
- if (chanPtr == (Channel *) NULL) {
- return TCL_ERROR;
+ if (chanPtr == NULL) {
+ return TCL_ERROR;
}
statePtr = chanPtr->state;
cmd = argv[2];
len = strlen(cmd);
if ((cmd[0] == 'a') && (strncmp(cmd, "add", (unsigned) len) == 0)) {
- if (argc != 5) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " channelName add eventSpec script\"", (char *) NULL);
- return TCL_ERROR;
- }
- if (strcmp(argv[3], "readable") == 0) {
- mask = TCL_READABLE;
- } else if (strcmp(argv[3], "writable") == 0) {
- mask = TCL_WRITABLE;
- } else if (strcmp(argv[3], "none") == 0) {
- mask = 0;
+ if (argc != 5) {
+ Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
+ " channelName add eventSpec script\"", NULL);
+ return TCL_ERROR;
+ }
+ if (strcmp(argv[3], "readable") == 0) {
+ mask = TCL_READABLE;
+ } else if (strcmp(argv[3], "writable") == 0) {
+ mask = TCL_WRITABLE;
+ } else if (strcmp(argv[3], "none") == 0) {
+ mask = 0;
} else {
- Tcl_AppendResult(interp, "bad event name \"", argv[3],
- "\": must be readable, writable, or none", (char *) NULL);
- return TCL_ERROR;
- }
+ Tcl_AppendResult(interp, "bad event name \"", argv[3],
+ "\": must be readable, writable, or none", NULL);
+ return TCL_ERROR;
+ }
- esPtr = (EventScriptRecord *) ckalloc((unsigned)
- sizeof(EventScriptRecord));
- esPtr->nextPtr = statePtr->scriptRecordPtr;
- statePtr->scriptRecordPtr = esPtr;
-
- esPtr->chanPtr = chanPtr;
- esPtr->interp = interp;
- esPtr->mask = mask;
+ esPtr = (EventScriptRecord *) ckalloc((unsigned)
+ sizeof(EventScriptRecord));
+ esPtr->nextPtr = statePtr->scriptRecordPtr;
+ statePtr->scriptRecordPtr = esPtr;
+
+ esPtr->chanPtr = chanPtr;
+ esPtr->interp = interp;
+ esPtr->mask = mask;
esPtr->scriptPtr = Tcl_NewStringObj(argv[4], -1);
Tcl_IncrRefCount(esPtr->scriptPtr);
- Tcl_CreateChannelHandler((Tcl_Channel) chanPtr, mask,
- TclChannelEventScriptInvoker, (ClientData) esPtr);
-
- return TCL_OK;
+ Tcl_CreateChannelHandler((Tcl_Channel) chanPtr, mask,
+ TclChannelEventScriptInvoker, (ClientData) esPtr);
+
+ return TCL_OK;
}
if ((cmd[0] == 'd') && (strncmp(cmd, "delete", (unsigned) len) == 0)) {
- if (argc != 4) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " channelName delete index\"", (char *) NULL);
- return TCL_ERROR;
- }
- if (Tcl_GetInt(interp, argv[3], &index) == TCL_ERROR) {
- return TCL_ERROR;
- }
- if (index < 0) {
- Tcl_AppendResult(interp, "bad event index: ", argv[3],
- ": must be nonnegative", (char *) NULL);
- return TCL_ERROR;
- }
- for (i = 0, esPtr = statePtr->scriptRecordPtr;
- (i < index) && (esPtr != (EventScriptRecord *) NULL);
+ if (argc != 4) {
+ Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
+ " channelName delete index\"", NULL);
+ return TCL_ERROR;
+ }
+ if (Tcl_GetInt(interp, argv[3], &index) == TCL_ERROR) {
+ return TCL_ERROR;
+ }
+ if (index < 0) {
+ Tcl_AppendResult(interp, "bad event index: ", argv[3],
+ ": must be nonnegative", NULL);
+ return TCL_ERROR;
+ }
+ for (i = 0, esPtr = statePtr->scriptRecordPtr;
+ (i < index) && (esPtr != NULL);
i++, esPtr = esPtr->nextPtr) {
/* Empty loop body. */
- }
- if (esPtr == (EventScriptRecord *) NULL) {
- Tcl_AppendResult(interp, "bad event index ", argv[3],
- ": out of range", (char *) NULL);
- return TCL_ERROR;
- }
- if (esPtr == statePtr->scriptRecordPtr) {
- statePtr->scriptRecordPtr = esPtr->nextPtr;
- } else {
- for (prevEsPtr = statePtr->scriptRecordPtr;
- (prevEsPtr != (EventScriptRecord *) NULL) &&
+ }
+ if (esPtr == NULL) {
+ Tcl_AppendResult(interp, "bad event index ", argv[3],
+ ": out of range", NULL);
+ return TCL_ERROR;
+ }
+ if (esPtr == statePtr->scriptRecordPtr) {
+ statePtr->scriptRecordPtr = esPtr->nextPtr;
+ } else {
+ for (prevEsPtr = statePtr->scriptRecordPtr;
+ (prevEsPtr != NULL) &&
(prevEsPtr->nextPtr != esPtr);
prevEsPtr = prevEsPtr->nextPtr) {
- /* Empty loop body. */
- }
- if (prevEsPtr == (EventScriptRecord *) NULL) {
- panic("TestChannelEventCmd: damaged event script list");
- }
- prevEsPtr->nextPtr = esPtr->nextPtr;
- }
- Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr,
- TclChannelEventScriptInvoker, (ClientData) esPtr);
+ /* Empty loop body. */
+ }
+ if (prevEsPtr == NULL) {
+ Tcl_Panic("TestChannelEventCmd: damaged event script list");
+ }
+ prevEsPtr->nextPtr = esPtr->nextPtr;
+ }
+ Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr,
+ TclChannelEventScriptInvoker, (ClientData) esPtr);
Tcl_DecrRefCount(esPtr->scriptPtr);
- ckfree((char *) esPtr);
+ ckfree((char *) esPtr);
- return TCL_OK;
+ return TCL_OK;
}
if ((cmd[0] == 'l') && (strncmp(cmd, "list", (unsigned) len) == 0)) {
- if (argc != 3) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " channelName list\"", (char *) NULL);
- return TCL_ERROR;
- }
+ if (argc != 3) {
+ Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
+ " channelName list\"", NULL);
+ return TCL_ERROR;
+ }
resultListPtr = Tcl_GetObjResult(interp);
- for (esPtr = statePtr->scriptRecordPtr;
- esPtr != (EventScriptRecord *) NULL;
+ for (esPtr = statePtr->scriptRecordPtr;
+ esPtr != NULL;
esPtr = esPtr->nextPtr) {
if (esPtr->mask) {
- Tcl_ListObjAppendElement(interp, resultListPtr, Tcl_NewStringObj(
+ Tcl_ListObjAppendElement(interp, resultListPtr, Tcl_NewStringObj(
(esPtr->mask == TCL_READABLE) ? "readable" : "writable", -1));
- } else {
- Tcl_ListObjAppendElement(interp, resultListPtr,
+ } else {
+ Tcl_ListObjAppendElement(interp, resultListPtr,
Tcl_NewStringObj("none", -1));
}
- Tcl_ListObjAppendElement(interp, resultListPtr, esPtr->scriptPtr);
- }
+ Tcl_ListObjAppendElement(interp, resultListPtr, esPtr->scriptPtr);
+ }
Tcl_SetObjResult(interp, resultListPtr);
- return TCL_OK;
+ return TCL_OK;
}
if ((cmd[0] == 'r') && (strncmp(cmd, "removeall", (unsigned) len) == 0)) {
- if (argc != 3) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " channelName removeall\"", (char *) NULL);
- return TCL_ERROR;
- }
- for (esPtr = statePtr->scriptRecordPtr;
- esPtr != (EventScriptRecord *) NULL;
+ if (argc != 3) {
+ Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
+ " channelName removeall\"", NULL);
+ return TCL_ERROR;
+ }
+ for (esPtr = statePtr->scriptRecordPtr;
+ esPtr != NULL;
esPtr = nextEsPtr) {
- nextEsPtr = esPtr->nextPtr;
- Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr,
- TclChannelEventScriptInvoker, (ClientData) esPtr);
+ nextEsPtr = esPtr->nextPtr;
+ Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr,
+ TclChannelEventScriptInvoker, (ClientData) esPtr);
Tcl_DecrRefCount(esPtr->scriptPtr);
- ckfree((char *) esPtr);
- }
- statePtr->scriptRecordPtr = (EventScriptRecord *) NULL;
- return TCL_OK;
+ ckfree((char *) esPtr);
+ }
+ statePtr->scriptRecordPtr = NULL;
+ return TCL_OK;
}
- if ((cmd[0] == 's') && (strncmp(cmd, "set", (unsigned) len) == 0)) {
- if (argc != 5) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " channelName delete index event\"", (char *) NULL);
- return TCL_ERROR;
- }
- if (Tcl_GetInt(interp, argv[3], &index) == TCL_ERROR) {
- return TCL_ERROR;
- }
- if (index < 0) {
- Tcl_AppendResult(interp, "bad event index: ", argv[3],
- ": must be nonnegative", (char *) NULL);
- return TCL_ERROR;
- }
- for (i = 0, esPtr = statePtr->scriptRecordPtr;
- (i < index) && (esPtr != (EventScriptRecord *) NULL);
+ if ((cmd[0] == 's') && (strncmp(cmd, "set", (unsigned) len) == 0)) {
+ if (argc != 5) {
+ Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
+ " channelName delete index event\"", NULL);
+ return TCL_ERROR;
+ }
+ if (Tcl_GetInt(interp, argv[3], &index) == TCL_ERROR) {
+ return TCL_ERROR;
+ }
+ if (index < 0) {
+ Tcl_AppendResult(interp, "bad event index: ", argv[3],
+ ": must be nonnegative", NULL);
+ return TCL_ERROR;
+ }
+ for (i = 0, esPtr = statePtr->scriptRecordPtr;
+ (i < index) && (esPtr != NULL);
i++, esPtr = esPtr->nextPtr) {
/* Empty loop body. */
- }
- if (esPtr == (EventScriptRecord *) NULL) {
- Tcl_AppendResult(interp, "bad event index ", argv[3],
- ": out of range", (char *) NULL);
- return TCL_ERROR;
- }
+ }
+ if (esPtr == NULL) {
+ Tcl_AppendResult(interp, "bad event index ", argv[3],
+ ": out of range", NULL);
+ return TCL_ERROR;
+ }
- if (strcmp(argv[4], "readable") == 0) {
- mask = TCL_READABLE;
- } else if (strcmp(argv[4], "writable") == 0) {
- mask = TCL_WRITABLE;
- } else if (strcmp(argv[4], "none") == 0) {
- mask = 0;
+ if (strcmp(argv[4], "readable") == 0) {
+ mask = TCL_READABLE;
+ } else if (strcmp(argv[4], "writable") == 0) {
+ mask = TCL_WRITABLE;
+ } else if (strcmp(argv[4], "none") == 0) {
+ mask = 0;
} else {
- Tcl_AppendResult(interp, "bad event name \"", argv[4],
- "\": must be readable, writable, or none", (char *) NULL);
- return TCL_ERROR;
- }
+ Tcl_AppendResult(interp, "bad event name \"", argv[4],
+ "\": must be readable, writable, or none", NULL);
+ return TCL_ERROR;
+ }
esPtr->mask = mask;
- Tcl_CreateChannelHandler((Tcl_Channel) chanPtr, mask,
- TclChannelEventScriptInvoker, (ClientData) esPtr);
+ Tcl_CreateChannelHandler((Tcl_Channel) chanPtr, mask,
+ TclChannelEventScriptInvoker, (ClientData) esPtr);
return TCL_OK;
- }
- Tcl_AppendResult(interp, "bad command ", cmd, ", must be one of ",
- "add, delete, list, set, or removeall", (char *) NULL);
+ }
+ Tcl_AppendResult(interp, "bad command ", cmd, ", must be one of "
+ "add, delete, list, set, or removeall", NULL);
return TCL_ERROR;
}
@@ -5909,11 +6439,11 @@ TestChannelEventCmd(dummy, interp, argc, argv)
*/
static int
-TestWrongNumArgsObjCmd(dummy, interp, objc, objv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* Argument objects. */
+TestWrongNumArgsObjCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
int i, length;
char *msg;
@@ -5926,7 +6456,7 @@ TestWrongNumArgsObjCmd(dummy, interp, objc, objv)
Tcl_SetResult(interp, "insufficient arguments", TCL_STATIC);
return TCL_ERROR;
}
-
+
if (Tcl_GetIntFromObj(interp, objv[1], &i) != TCL_OK) {
return TCL_ERROR;
}
@@ -5935,7 +6465,7 @@ TestWrongNumArgsObjCmd(dummy, interp, objc, objv)
if (length == 0) {
msg = NULL;
}
-
+
if (i > objc - 3) {
/*
* Asked for more arguments than were given.
@@ -5965,14 +6495,14 @@ TestWrongNumArgsObjCmd(dummy, interp, objc, objv)
*/
static int
-TestGetIndexFromObjStructObjCmd(dummy, interp, objc, objv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* Argument objects. */
+TestGetIndexFromObjStructObjCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
char *ary[] = {
- "a", "b", "c", "d", "e", "f", (char *)NULL,(char *)NULL
+ "a", "b", "c", "d", "e", "f", NULL, NULL
};
int idx,target;
@@ -5981,7 +6511,7 @@ TestGetIndexFromObjStructObjCmd(dummy, interp, objc, objv)
return TCL_ERROR;
}
if (Tcl_GetIndexFromObjStruct(interp, objv[1], ary, 2*sizeof(char *),
- "dummy", 0, &idx) != TCL_OK) {
+ "dummy", 0, &idx) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetIntFromObj(interp, objv[2], &target) != TCL_OK) {
@@ -5991,7 +6521,7 @@ TestGetIndexFromObjStructObjCmd(dummy, interp, objc, objv)
char buffer[64];
sprintf(buffer, "%d", idx);
Tcl_AppendResult(interp, "index value comparison failed: got ",
- buffer, NULL);
+ buffer, NULL);
sprintf(buffer, "%d", target);
Tcl_AppendResult(interp, " when ", buffer, " expected", NULL);
return TCL_ERROR;
@@ -6005,9 +6535,9 @@ TestGetIndexFromObjStructObjCmd(dummy, interp, objc, objv)
*
* TestFilesystemObjCmd --
*
- * This procedure implements the "testfilesystem" command. It is
- * used to test Tcl_FSRegister, Tcl_FSUnregister, and can be used
- * to test that the pluggable filesystem works.
+ * This procedure implements the "testfilesystem" command. It is used to
+ * test Tcl_FSRegister, Tcl_FSUnregister, and can be used to test that
+ * the pluggable filesystem works.
*
* Results:
* A standard Tcl result.
@@ -6019,15 +6549,15 @@ TestGetIndexFromObjStructObjCmd(dummy, interp, objc, objv)
*/
static int
-TestFilesystemObjCmd(dummy, interp, objc, objv)
- ClientData dummy;
- Tcl_Interp *interp;
- int objc;
- Tcl_Obj *CONST objv[];
+TestFilesystemObjCmd(
+ ClientData dummy,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
{
int res, boolVal;
char *msg;
-
+
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "boolean");
return TCL_ERROR;
@@ -6046,78 +6576,90 @@ TestFilesystemObjCmd(dummy, interp, objc, objv)
return res;
}
-static int
-TestReportInFilesystem(Tcl_Obj *pathPtr, ClientData *clientDataPtr)
+static int
+TestReportInFilesystem(
+ Tcl_Obj *pathPtr,
+ ClientData *clientDataPtr)
{
- static Tcl_Obj* lastPathPtr = NULL;
-
+ static Tcl_Obj *lastPathPtr = NULL;
+ Tcl_Obj *newPathPtr;
+
if (pathPtr == lastPathPtr) {
/* Reject all files second time around */
- return -1;
- } else {
- Tcl_Obj * newPathPtr;
- /* Try to claim all files first time around */
-
- newPathPtr = Tcl_DuplicateObj(pathPtr);
- lastPathPtr = newPathPtr;
- Tcl_IncrRefCount(newPathPtr);
- if (Tcl_FSGetFileSystemForPath(newPathPtr) == NULL) {
- /* Nothing claimed it. Therefore we don't either */
- Tcl_DecrRefCount(newPathPtr);
- lastPathPtr = NULL;
- return -1;
- } else {
- lastPathPtr = NULL;
- *clientDataPtr = (ClientData) newPathPtr;
- return TCL_OK;
- }
+ return -1;
}
+
+ /* Try to claim all files first time around */
+
+ newPathPtr = Tcl_DuplicateObj(pathPtr);
+ lastPathPtr = newPathPtr;
+ Tcl_IncrRefCount(newPathPtr);
+ if (Tcl_FSGetFileSystemForPath(newPathPtr) == NULL) {
+ /* Nothing claimed it. Therefore we don't either */
+ Tcl_DecrRefCount(newPathPtr);
+ lastPathPtr = NULL;
+ return -1;
+ }
+ lastPathPtr = NULL;
+ *clientDataPtr = (ClientData) newPathPtr;
+ return TCL_OK;
}
-/*
- * Simple helper function to extract the native vfs representation of a
- * path object, or NULL if no such representation exists.
+/*
+ * Simple helper function to extract the native vfs representation of a path
+ * object, or NULL if no such representation exists.
*/
-static Tcl_Obj*
-TestReportGetNativePath(Tcl_Obj* pathObjPtr) {
- return (Tcl_Obj*) Tcl_FSGetInternalRep(pathObjPtr, &testReportingFilesystem);
+
+static Tcl_Obj *
+TestReportGetNativePath(
+ Tcl_Obj *pathPtr)
+{
+ return (Tcl_Obj*) Tcl_FSGetInternalRep(pathPtr, &testReportingFilesystem);
}
-static void
-TestReportFreeInternalRep(ClientData clientData) {
- Tcl_Obj *nativeRep = (Tcl_Obj*)clientData;
+static void
+TestReportFreeInternalRep(
+ ClientData clientData)
+{
+ Tcl_Obj *nativeRep = (Tcl_Obj *) clientData;
+
if (nativeRep != NULL) {
/* Free the path */
Tcl_DecrRefCount(nativeRep);
}
}
-static ClientData
-TestReportDupInternalRep(ClientData clientData) {
- Tcl_Obj *original = (Tcl_Obj*)clientData;
+static ClientData
+TestReportDupInternalRep(
+ ClientData clientData)
+{
+ Tcl_Obj *original = (Tcl_Obj *) clientData;
+
Tcl_IncrRefCount(original);
return clientData;
}
static void
-TestReport(cmd, path, arg2)
- CONST char* cmd;
- Tcl_Obj* path;
- Tcl_Obj* arg2;
+TestReport(
+ const char *cmd,
+ Tcl_Obj *path,
+ Tcl_Obj *arg2)
{
- Tcl_Interp* interp = (Tcl_Interp*) Tcl_FSData(&testReportingFilesystem);
+ Tcl_Interp *interp = (Tcl_Interp *) Tcl_FSData(&testReportingFilesystem);
+
if (interp == NULL) {
/* This is bad, but not much we can do about it */
} else {
- /*
- * No idea why I decided to program this up using the
- * old string-based API, but there you go. We should
- * convert it to objects.
+ /*
+ * No idea why I decided to program this up using the old string-based
+ * API, but there you go. We should convert it to objects.
*/
+
Tcl_SavedResult savedResult;
Tcl_DString ds;
+
Tcl_DStringInit(&ds);
- Tcl_DStringAppend(&ds, "lappend filesystemReport ",-1);
+ Tcl_DStringAppend(&ds, "lappend filesystemReport ", -1);
Tcl_DStringStartSublist(&ds);
Tcl_DStringAppendElement(&ds, cmd);
if (path != NULL) {
@@ -6135,254 +6677,259 @@ TestReport(cmd, path, arg2)
}
static int
-TestReportStat(path, buf)
- Tcl_Obj *path; /* Path of file to stat (in current CP). */
- Tcl_StatBuf *buf; /* Filled with results of stat call. */
+TestReportStat(
+ Tcl_Obj *path, /* Path of file to stat (in current CP). */
+ Tcl_StatBuf *buf) /* Filled with results of stat call. */
{
- TestReport("stat",path, NULL);
- return Tcl_FSStat(TestReportGetNativePath(path),buf);
+ TestReport("stat", path, NULL);
+ return Tcl_FSStat(TestReportGetNativePath(path), buf);
}
+
static int
-TestReportLstat(path, buf)
- Tcl_Obj *path; /* Path of file to stat (in current CP). */
- Tcl_StatBuf *buf; /* Filled with results of stat call. */
+TestReportLstat(
+ Tcl_Obj *path, /* Path of file to stat (in current CP). */
+ Tcl_StatBuf *buf) /* Filled with results of stat call. */
{
- TestReport("lstat",path, NULL);
- return Tcl_FSLstat(TestReportGetNativePath(path),buf);
+ TestReport("lstat", path, NULL);
+ return Tcl_FSLstat(TestReportGetNativePath(path), buf);
}
+
static int
-TestReportAccess(path, mode)
- Tcl_Obj *path; /* Path of file to access (in current CP). */
- int mode; /* Permission setting. */
+TestReportAccess(
+ Tcl_Obj *path, /* Path of file to access (in current CP). */
+ int mode) /* Permission setting. */
{
- TestReport("access",path,NULL);
- return Tcl_FSAccess(TestReportGetNativePath(path),mode);
+ TestReport("access", path, NULL);
+ return Tcl_FSAccess(TestReportGetNativePath(path), mode);
}
+
static Tcl_Channel
-TestReportOpenFileChannel(interp, fileName, mode, permissions)
- Tcl_Interp *interp; /* Interpreter for error reporting;
- * can be NULL. */
- Tcl_Obj *fileName; /* Name of file to open. */
- int mode; /* POSIX open mode. */
- int permissions; /* If the open involves creating a
- * file, with what modes to create
- * it? */
-{
- TestReport("open",fileName, NULL);
+TestReportOpenFileChannel(
+ Tcl_Interp *interp, /* Interpreter for error reporting; can be
+ * NULL. */
+ Tcl_Obj *fileName, /* Name of file to open. */
+ int mode, /* POSIX open mode. */
+ int permissions) /* If the open involves creating a file, with
+ * what modes to create it? */
+{
+ TestReport("open", fileName, NULL);
return TclpOpenFileChannel(interp, TestReportGetNativePath(fileName),
- mode, permissions);
+ mode, permissions);
}
static int
-TestReportMatchInDirectory(interp, resultPtr, dirPtr, pattern, types)
- Tcl_Interp *interp; /* Interpreter to receive results. */
- Tcl_Obj *resultPtr; /* Object to lappend results. */
- Tcl_Obj *dirPtr; /* Contains path to directory to search. */
- CONST char *pattern; /* Pattern to match against. */
- Tcl_GlobTypeData *types; /* Object containing list of acceptable types.
+TestReportMatchInDirectory(
+ Tcl_Interp *interp, /* Interpreter for error messages. */
+ Tcl_Obj *resultPtr, /* Object to lappend results. */
+ Tcl_Obj *dirPtr, /* Contains path to directory to search. */
+ const char *pattern, /* Pattern to match against. */
+ Tcl_GlobTypeData *types) /* Object containing list of acceptable types.
* May be NULL. */
{
if (types != NULL && types->type & TCL_GLOB_TYPE_MOUNT) {
- TestReport("matchmounts",dirPtr, NULL);
+ TestReport("matchmounts", dirPtr, NULL);
return TCL_OK;
} else {
- TestReport("matchindirectory",dirPtr, NULL);
- return Tcl_FSMatchInDirectory(interp, resultPtr,
- TestReportGetNativePath(dirPtr), pattern,
- types);
+ TestReport("matchindirectory", dirPtr, NULL);
+ return Tcl_FSMatchInDirectory(interp, resultPtr,
+ TestReportGetNativePath(dirPtr), pattern, types);
}
}
+
static int
-TestReportChdir(dirName)
- Tcl_Obj *dirName;
+TestReportChdir(
+ Tcl_Obj *dirName)
{
- TestReport("chdir",dirName,NULL);
+ TestReport("chdir", dirName, NULL);
return Tcl_FSChdir(TestReportGetNativePath(dirName));
}
+
static int
-TestReportLoadFile(interp, fileName,
- handlePtr, unloadProcPtr)
- Tcl_Interp *interp; /* Used for error reporting. */
- Tcl_Obj *fileName; /* Name of the file containing the desired
+TestReportLoadFile(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Obj *fileName, /* Name of the file containing the desired
* code. */
- Tcl_LoadHandle *handlePtr; /* Filled with token for dynamically loaded
- * file which will be passed back to
+ Tcl_LoadHandle *handlePtr, /* Filled with token for dynamically loaded
+ * file which will be passed back to
* (*unloadProcPtr)() to unload the file. */
- Tcl_FSUnloadFileProc **unloadProcPtr;
+ Tcl_FSUnloadFileProc **unloadProcPtr)
/* Filled with address of Tcl_FSUnloadFileProc
* function which should be used for
* this file. */
{
- TestReport("loadfile",fileName,NULL);
- return Tcl_FSLoadFile(interp, TestReportGetNativePath(fileName), NULL, NULL,
- NULL, NULL, handlePtr, unloadProcPtr);
+ TestReport("loadfile", fileName, NULL);
+ return Tcl_FSLoadFile(interp, TestReportGetNativePath(fileName), NULL,
+ NULL, NULL, NULL, handlePtr, unloadProcPtr);
}
+
static Tcl_Obj *
-TestReportLink(path, to, linkType)
- Tcl_Obj *path; /* Path of file to readlink or link */
- Tcl_Obj *to; /* Path of file to link to, or NULL */
- int linkType;
+TestReportLink(
+ Tcl_Obj *path, /* Path of file to readlink or link */
+ Tcl_Obj *to, /* Path of file to link to, or NULL */
+ int linkType)
{
- TestReport("link",path,to);
+ TestReport("link", path, to);
return Tcl_FSLink(TestReportGetNativePath(path), to, linkType);
}
+
static int
-TestReportRenameFile(src, dst)
- Tcl_Obj *src; /* Pathname of file or dir to be renamed
+TestReportRenameFile(
+ Tcl_Obj *src, /* Pathname of file or dir to be renamed
* (UTF-8). */
- Tcl_Obj *dst; /* New pathname of file or directory
+ Tcl_Obj *dst) /* New pathname of file or directory
* (UTF-8). */
{
- TestReport("renamefile",src,dst);
- return Tcl_FSRenameFile(TestReportGetNativePath(src),
- TestReportGetNativePath(dst));
+ TestReport("renamefile", src, dst);
+ return Tcl_FSRenameFile(TestReportGetNativePath(src),
+ TestReportGetNativePath(dst));
}
-static int
-TestReportCopyFile(src, dst)
- Tcl_Obj *src; /* Pathname of file to be copied (UTF-8). */
- Tcl_Obj *dst; /* Pathname of file to copy to (UTF-8). */
+
+static int
+TestReportCopyFile(
+ Tcl_Obj *src, /* Pathname of file to be copied (UTF-8). */
+ Tcl_Obj *dst) /* Pathname of file to copy to (UTF-8). */
{
- TestReport("copyfile",src,dst);
- return Tcl_FSCopyFile(TestReportGetNativePath(src),
- TestReportGetNativePath(dst));
+ TestReport("copyfile", src, dst);
+ return Tcl_FSCopyFile(TestReportGetNativePath(src),
+ TestReportGetNativePath(dst));
}
+
static int
-TestReportDeleteFile(path)
- Tcl_Obj *path; /* Pathname of file to be removed (UTF-8). */
+TestReportDeleteFile(
+ Tcl_Obj *path) /* Pathname of file to be removed (UTF-8). */
{
- TestReport("deletefile",path,NULL);
+ TestReport("deletefile", path, NULL);
return Tcl_FSDeleteFile(TestReportGetNativePath(path));
}
+
static int
-TestReportCreateDirectory(path)
- Tcl_Obj *path; /* Pathname of directory to create (UTF-8). */
+TestReportCreateDirectory(
+ Tcl_Obj *path) /* Pathname of directory to create (UTF-8). */
{
- TestReport("createdirectory",path,NULL);
+ TestReport("createdirectory", path, NULL);
return Tcl_FSCreateDirectory(TestReportGetNativePath(path));
}
+
static int
-TestReportCopyDirectory(src, dst, errorPtr)
- Tcl_Obj *src; /* Pathname of directory to be copied
+TestReportCopyDirectory(
+ Tcl_Obj *src, /* Pathname of directory to be copied
* (UTF-8). */
- Tcl_Obj *dst; /* Pathname of target directory (UTF-8). */
- Tcl_Obj **errorPtr; /* If non-NULL, to be filled with UTF-8 name
- * of file causing error. */
+ Tcl_Obj *dst, /* Pathname of target directory (UTF-8). */
+ Tcl_Obj **errorPtr) /* If non-NULL, to be filled with UTF-8 name
+ * of file causing error. */
{
- TestReport("copydirectory",src,dst);
- return Tcl_FSCopyDirectory(TestReportGetNativePath(src),
- TestReportGetNativePath(dst), errorPtr);
+ TestReport("copydirectory", src, dst);
+ return Tcl_FSCopyDirectory(TestReportGetNativePath(src),
+ TestReportGetNativePath(dst), errorPtr);
}
+
static int
-TestReportRemoveDirectory(path, recursive, errorPtr)
- Tcl_Obj *path; /* Pathname of directory to be removed
+TestReportRemoveDirectory(
+ Tcl_Obj *path, /* Pathname of directory to be removed
* (UTF-8). */
- int recursive; /* If non-zero, removes directories that
+ int recursive, /* If non-zero, removes directories that
* are nonempty. Otherwise, will only remove
* empty directories. */
- Tcl_Obj **errorPtr; /* If non-NULL, to be filled with UTF-8 name
- * of file causing error. */
+ Tcl_Obj **errorPtr) /* If non-NULL, to be filled with UTF-8 name
+ * of file causing error. */
{
- TestReport("removedirectory",path,NULL);
- return Tcl_FSRemoveDirectory(TestReportGetNativePath(path), recursive,
- errorPtr);
+ TestReport("removedirectory", path, NULL);
+ return Tcl_FSRemoveDirectory(TestReportGetNativePath(path), recursive,
+ errorPtr);
}
-static CONST char**
-TestReportFileAttrStrings(fileName, objPtrRef)
- Tcl_Obj* fileName;
- Tcl_Obj** objPtrRef;
+
+static const char **
+TestReportFileAttrStrings(
+ Tcl_Obj *fileName,
+ Tcl_Obj **objPtrRef)
{
- TestReport("fileattributestrings",fileName,NULL);
+ TestReport("fileattributestrings", fileName, NULL);
return Tcl_FSFileAttrStrings(TestReportGetNativePath(fileName), objPtrRef);
}
+
static int
-TestReportFileAttrsGet(interp, index, fileName, objPtrRef)
- Tcl_Interp *interp; /* The interpreter for error reporting. */
- int index; /* index of the attribute command. */
- Tcl_Obj *fileName; /* filename we are operating on. */
- Tcl_Obj **objPtrRef; /* for output. */
+TestReportFileAttrsGet(
+ Tcl_Interp *interp, /* The interpreter for error reporting. */
+ int index, /* index of the attribute command. */
+ Tcl_Obj *fileName, /* filename we are operating on. */
+ Tcl_Obj **objPtrRef) /* for output. */
{
- TestReport("fileattributesget",fileName,NULL);
- return Tcl_FSFileAttrsGet(interp, index,
- TestReportGetNativePath(fileName), objPtrRef);
+ TestReport("fileattributesget", fileName, NULL);
+ return Tcl_FSFileAttrsGet(interp, index,
+ TestReportGetNativePath(fileName), objPtrRef);
}
+
static int
-TestReportFileAttrsSet(interp, index, fileName, objPtr)
- Tcl_Interp *interp; /* The interpreter for error reporting. */
- int index; /* index of the attribute command. */
- Tcl_Obj *fileName; /* filename we are operating on. */
- Tcl_Obj *objPtr; /* for input. */
-{
- TestReport("fileattributesset",fileName,objPtr);
- return Tcl_FSFileAttrsSet(interp, index,
- TestReportGetNativePath(fileName), objPtr);
-}
-static int
-TestReportUtime (fileName, tval)
- Tcl_Obj* fileName;
- struct utimbuf *tval;
-{
- TestReport("utime",fileName,NULL);
+TestReportFileAttrsSet(
+ Tcl_Interp *interp, /* The interpreter for error reporting. */
+ int index, /* index of the attribute command. */
+ Tcl_Obj *fileName, /* filename we are operating on. */
+ Tcl_Obj *objPtr) /* for input. */
+{
+ TestReport("fileattributesset", fileName, objPtr);
+ return Tcl_FSFileAttrsSet(interp, index,
+ TestReportGetNativePath(fileName), objPtr);
+}
+
+static int
+TestReportUtime(
+ Tcl_Obj *fileName,
+ struct utimbuf *tval)
+{
+ TestReport("utime", fileName, NULL);
return Tcl_FSUtime(TestReportGetNativePath(fileName), tval);
}
+
static int
-TestReportNormalizePath(interp, pathPtr, nextCheckpoint)
- Tcl_Interp *interp;
- Tcl_Obj *pathPtr;
- int nextCheckpoint;
+TestReportNormalizePath(
+ Tcl_Interp *interp,
+ Tcl_Obj *pathPtr,
+ int nextCheckpoint)
{
- TestReport("normalizepath",pathPtr,NULL);
+ TestReport("normalizepath", pathPtr, NULL);
return nextCheckpoint;
}
-static int
-SimplePathInFilesystem(Tcl_Obj *pathPtr, ClientData *clientDataPtr) {
- CONST char *str = Tcl_GetString(pathPtr);
- if (strncmp(str,"simplefs:/",10)) {
+static int
+SimplePathInFilesystem(
+ Tcl_Obj *pathPtr,
+ ClientData *clientDataPtr)
+{
+ const char *str = Tcl_GetString(pathPtr);
+
+ if (strncmp(str, "simplefs:/", 10)) {
return -1;
}
return TCL_OK;
}
-/*
- * Since TclCopyChannel insists on an interpreter, we use this
- * to simplify our test scripts. Would be better if it could
- * copy without an interp
- */
-static Tcl_Interp *simpleInterpPtr = NULL;
-/* We use this to ensure we clean up after ourselves */
-static Tcl_Obj *tempFile = NULL;
-
-/*
- * This is a very 'hacky' filesystem which is used just to
- * test two important features of the vfs code: (1) that
- * you can load a shared library from a vfs, (2) that when
- * copying files from one fs to another, the 'mtime' is
- * preserved.
- *
- * It treats any file in 'simplefs:/' as a file, and
- * artificially creates a real file on the fly which it uses
- * to extract information from. The real file it uses is
- * whatever follows the trailing '/' (e.g. 'foo' in 'simplefs:/foo'),
- * and that file is assumed to exist in the native pwd, and is
- * copied over to the native temporary directory where it is
- * accessed.
- *
- * Please do not consider this filesystem a model of how
- * things are to be done. It is quite the opposite! But, it
- * does allow us to test two important features.
- *
- * Finally: this fs can only be used from one interpreter.
+/*
+ * This is a slightly 'hacky' filesystem which is used just to test a few
+ * important features of the vfs code: (1) that you can load a shared library
+ * from a vfs, (2) that when copying files from one fs to another, the 'mtime'
+ * is preserved. (3) that recursive cross-filesystem directory copies have the
+ * correct behaviour with/without -force.
+ *
+ * It treats any file in 'simplefs:/' as a file, which it routes to the
+ * current directory. The real file it uses is whatever follows the trailing
+ * '/' (e.g. 'foo' in 'simplefs:/foo'), and that file exists or not according
+ * to what is in the native pwd.
+ *
+ * Please do not consider this filesystem a model of how things are to be
+ * done. It is quite the opposite! But, it does allow us to test some
+ * important features.
*/
+
static int
-TestSimpleFilesystemObjCmd(dummy, interp, objc, objv)
- ClientData dummy;
- Tcl_Interp *interp;
- int objc;
- Tcl_Obj *CONST objv[];
+TestSimpleFilesystemObjCmd(
+ ClientData dummy,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
{
int res, boolVal;
char *msg;
-
+
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "boolean");
return TCL_ERROR;
@@ -6393,129 +6940,138 @@ TestSimpleFilesystemObjCmd(dummy, interp, objc, objv)
if (boolVal) {
res = Tcl_FSRegister((ClientData)interp, &simpleFilesystem);
msg = (res == TCL_OK) ? "registered" : "failed";
- simpleInterpPtr = interp;
} else {
- if (tempFile != NULL) {
- Tcl_FSDeleteFile(tempFile);
- Tcl_DecrRefCount(tempFile);
- tempFile = NULL;
- }
res = Tcl_FSUnregister(&simpleFilesystem);
msg = (res == TCL_OK) ? "unregistered" : "failed";
- simpleInterpPtr = NULL;
}
Tcl_SetResult(interp, msg, TCL_VOLATILE);
return res;
}
-/*
- * Treats a file name 'simplefs:/foo' by copying the file 'foo'
- * in the current (native) directory to a temporary native file,
- * and then returns that native file.
+/*
+ * Treats a file name 'simplefs:/foo' by using the file 'foo' in the current
+ * (native) directory.
*/
-static Tcl_Obj*
-SimpleCopy(pathPtr)
- Tcl_Obj *pathPtr; /* Name of file to copy. */
+
+static Tcl_Obj *
+SimpleRedirect(
+ Tcl_Obj *pathPtr) /* Name of file to copy. */
{
- int res;
- CONST char *str;
+ int len;
+ const char *str;
Tcl_Obj *origPtr;
- Tcl_Obj *tempPtr;
-
- tempPtr = TclpTempFileName();
- Tcl_IncrRefCount(tempPtr);
- /*
+ /*
* We assume the same name in the current directory is ok.
*/
- str = Tcl_GetString(pathPtr);
+
+ str = Tcl_GetStringFromObj(pathPtr, &len);
+ if (len < 10 || strncmp(str, "simplefs:/", 10)) {
+ /* Probably shouldn't ever reach here */
+ Tcl_IncrRefCount(pathPtr);
+ return pathPtr;
+ }
origPtr = Tcl_NewStringObj(str+10,-1);
Tcl_IncrRefCount(origPtr);
+ return origPtr;
+}
- res = TclCrossFilesystemCopy(simpleInterpPtr, origPtr, tempPtr);
- Tcl_DecrRefCount(origPtr);
+static int
+SimpleMatchInDirectory(
+ Tcl_Interp *interp, /* Interpreter for error
+ * messages. */
+ Tcl_Obj *resultPtr, /* Object to lappend results. */
+ Tcl_Obj *dirPtr, /* Contains path to directory to search. */
+ const char *pattern, /* Pattern to match against. */
+ Tcl_GlobTypeData *types) /* Object containing list of acceptable types.
+ * May be NULL. */
+{
+ int res;
+ Tcl_Obj *origPtr;
+ Tcl_Obj *resPtr;
- if (res != TCL_OK) {
- Tcl_FSDeleteFile(tempPtr);
- Tcl_DecrRefCount(tempPtr);
- return NULL;
+ /* We only provide a new volume, therefore no mounts at all */
+ if (types != NULL && types->type & TCL_GLOB_TYPE_MOUNT) {
+ return TCL_OK;
}
- return tempPtr;
+
+ /*
+ * We assume the same name in the current directory is ok.
+ */
+ resPtr = Tcl_NewObj();
+ Tcl_IncrRefCount(resPtr);
+ origPtr = SimpleRedirect(dirPtr);
+ res = Tcl_FSMatchInDirectory(interp, resPtr, origPtr, pattern, types);
+ if (res == TCL_OK) {
+ int gLength, j;
+ Tcl_ListObjLength(NULL, resPtr, &gLength);
+ for (j = 0; j < gLength; j++) {
+ Tcl_Obj *gElt, *nElt;
+ Tcl_ListObjIndex(NULL, resPtr, j, &gElt);
+ nElt = Tcl_NewStringObj("simplefs:/",10);
+ Tcl_AppendObjToObj(nElt, gElt);
+ Tcl_ListObjAppendElement(NULL, resultPtr, nElt);
+ }
+ }
+ Tcl_DecrRefCount(origPtr);
+ Tcl_DecrRefCount(resPtr);
+ return res;
}
static Tcl_Channel
-SimpleOpenFileChannel(interp, pathPtr, mode, permissions)
- Tcl_Interp *interp; /* Interpreter for error reporting;
- * can be NULL. */
- Tcl_Obj *pathPtr; /* Name of file to open. */
- int mode; /* POSIX open mode. */
- int permissions; /* If the open involves creating a
- * file, with what modes to create
- * it? */
+SimpleOpenFileChannel(
+ Tcl_Interp *interp, /* Interpreter for error reporting; can be
+ * NULL. */
+ Tcl_Obj *pathPtr, /* Name of file to open. */
+ int mode, /* POSIX open mode. */
+ int permissions) /* If the open involves creating a file, with
+ * what modes to create it? */
{
Tcl_Obj *tempPtr;
Tcl_Channel chan;
-
+
if ((mode != 0) && !(mode & O_RDONLY)) {
- Tcl_AppendResult(interp, "read-only",
- (char *) NULL);
- return NULL;
- }
-
- tempPtr = SimpleCopy(pathPtr);
-
- if (tempPtr == NULL) {
+ Tcl_AppendResult(interp, "read-only", NULL);
return NULL;
}
-
- chan = Tcl_FSOpenFileChannel(interp, tempPtr, "r", permissions);
- if (tempFile != NULL) {
- Tcl_FSDeleteFile(tempFile);
- Tcl_DecrRefCount(tempFile);
- tempFile = NULL;
- }
- /*
- * Store file pointer in this global variable so we can delete
- * it later
- */
- tempFile = tempPtr;
+ tempPtr = SimpleRedirect(pathPtr);
+ chan = Tcl_FSOpenFileChannel(interp, tempPtr, "r", permissions);
+ Tcl_DecrRefCount(tempPtr);
return chan;
}
static int
-SimpleAccess(pathPtr, mode)
- Tcl_Obj *pathPtr; /* Path of file to access (in current CP). */
- int mode; /* Permission setting. */
+SimpleAccess(
+ Tcl_Obj *pathPtr, /* Path of file to access (in current CP). */
+ int mode) /* Permission setting. */
{
- /* All files exist */
- return TCL_OK;
+ Tcl_Obj *tempPtr = SimpleRedirect(pathPtr);
+ int res = Tcl_FSAccess(tempPtr, mode);
+
+ Tcl_DecrRefCount(tempPtr);
+ return res;
}
static int
-SimpleStat(pathPtr, bufPtr)
- Tcl_Obj *pathPtr; /* Path of file to stat (in current CP). */
- Tcl_StatBuf *bufPtr; /* Filled with results of stat call. */
+SimpleStat(
+ Tcl_Obj *pathPtr, /* Path of file to stat (in current CP). */
+ Tcl_StatBuf *bufPtr) /* Filled with results of stat call. */
{
- Tcl_Obj *tempPtr = SimpleCopy(pathPtr);
- if (tempPtr == NULL) {
- /* We just pretend the file exists anyway */
- return TCL_OK;
- } else {
- int res = Tcl_FSStat(tempPtr, bufPtr);
- Tcl_FSDeleteFile(tempPtr);
- Tcl_DecrRefCount(tempPtr);
- return res;
- }
+ Tcl_Obj *tempPtr = SimpleRedirect(pathPtr);
+ int res = Tcl_FSStat(tempPtr, bufPtr);
+
+ Tcl_DecrRefCount(tempPtr);
+ return res;
}
-static Tcl_Obj*
+static Tcl_Obj *
SimpleListVolumes(void)
{
/* Add one new volume */
Tcl_Obj *retVal;
- retVal = Tcl_NewStringObj("simplefs:/",-1);
+ retVal = Tcl_NewStringObj("simplefs:/", -1);
Tcl_IncrRefCount(retVal);
return retVal;
}
@@ -6523,15 +7079,17 @@ SimpleListVolumes(void)
/*
* Used to check correct string-length determining in Tcl_NumUtfChars
*/
+
static int
-TestNumUtfCharsCmd(clientData, interp, objc, objv)
- ClientData clientData;
- Tcl_Interp *interp;
- int objc;
- Tcl_Obj *CONST objv[];
+TestNumUtfCharsCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
{
if (objc > 1) {
int len = -1;
+
if (objc > 2) {
(void) Tcl_GetStringFromObj(objv[1], &len);
}
@@ -6540,3 +7098,423 @@ TestNumUtfCharsCmd(clientData, interp, objc, objv)
}
return TCL_OK;
}
+
+/*
+ * Used to do basic checks of the TCL_HASH_KEY_SYSTEM_HASH flag
+ */
+
+static int
+TestHashSystemHashCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ static Tcl_HashKeyType hkType = {
+ TCL_HASH_KEY_TYPE_VERSION, TCL_HASH_KEY_SYSTEM_HASH,
+ NULL, NULL, NULL, NULL
+ };
+ Tcl_HashTable hash;
+ Tcl_HashEntry *hPtr;
+ int i, isNew, limit = 100;
+
+ if (objc>1 && Tcl_GetIntFromObj(interp, objv[1], &limit)!=TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ Tcl_InitCustomHashTable(&hash, TCL_CUSTOM_TYPE_KEYS, &hkType);
+
+ if (hash.numEntries != 0) {
+ Tcl_AppendResult(interp, "non-zero initial size", NULL);
+ Tcl_DeleteHashTable(&hash);
+ return TCL_ERROR;
+ }
+
+ for (i=0 ; i<limit ; i++) {
+ hPtr = Tcl_CreateHashEntry(&hash, (char *) INT2PTR(i), &isNew);
+ if (!isNew) {
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(i));
+ Tcl_AppendToObj(Tcl_GetObjResult(interp)," creation problem",-1);
+ Tcl_DeleteHashTable(&hash);
+ return TCL_ERROR;
+ }
+ Tcl_SetHashValue(hPtr, (ClientData) INT2PTR(i+42));
+ }
+
+ if (hash.numEntries != limit) {
+ Tcl_AppendResult(interp, "unexpected maximal size", NULL);
+ Tcl_DeleteHashTable(&hash);
+ return TCL_ERROR;
+ }
+
+ for (i=0 ; i<limit ; i++) {
+ hPtr = Tcl_FindHashEntry(&hash, (char *) INT2PTR(i));
+ if (hPtr == NULL) {
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(i));
+ Tcl_AppendToObj(Tcl_GetObjResult(interp)," lookup problem",-1);
+ Tcl_DeleteHashTable(&hash);
+ return TCL_ERROR;
+ }
+ if (PTR2INT(Tcl_GetHashValue(hPtr)) != i+42) {
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(i));
+ Tcl_AppendToObj(Tcl_GetObjResult(interp)," value problem",-1);
+ Tcl_DeleteHashTable(&hash);
+ return TCL_ERROR;
+ }
+ Tcl_DeleteHashEntry(hPtr);
+ }
+
+ if (hash.numEntries != 0) {
+ Tcl_AppendResult(interp, "non-zero final size", NULL);
+ Tcl_DeleteHashTable(&hash);
+ return TCL_ERROR;
+ }
+
+ Tcl_DeleteHashTable(&hash);
+ Tcl_AppendResult(interp, "OK", NULL);
+ return TCL_OK;
+}
+
+/*
+ * Used for testing Tcl_GetInt which is no longer used directly by the
+ * core very much.
+ */
+static int
+TestgetintCmd(
+ ClientData dummy,
+ Tcl_Interp *interp,
+ int argc,
+ const char **argv)
+{
+ if (argc < 2) {
+ Tcl_SetResult(interp, "wrong # args", TCL_STATIC);
+ return TCL_ERROR;
+ } else {
+ int val, i, total=0;
+ char buf[TCL_INTEGER_SPACE];
+
+ for (i=1 ; i<argc ; i++) {
+ if (Tcl_GetInt(interp, argv[i], &val) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ total += val;
+ }
+ TclFormatInt(buf, total);
+ Tcl_SetResult(interp, buf, TCL_VOLATILE);
+ return TCL_OK;
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TestconcatobjCmd --
+ *
+ * This procedure implements the "testconcatobj" command. It is used
+ * to test that Tcl_ConcatObj does indeed return a fresh Tcl_Obj in all
+ * cases and thet it never corrupts its arguments. In other words, that
+ * [Bug 1447328] was fixed properly.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TestconcatobjCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int argc, /* Number of arguments. */
+ const char **argv) /* Argument strings. */
+{
+ Tcl_Obj *list1Ptr, *list2Ptr, *emptyPtr, *concatPtr, *tmpPtr;
+ int result = TCL_OK, len;
+ Tcl_Obj *objv[3];
+
+ /*
+ * Set the start of the error message as obj result; it will be cleared at
+ * the end if no errors were found.
+ */
+
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj("Tcl_ConcatObj is unsafe:", -1));
+
+ emptyPtr = Tcl_NewObj();
+
+ list1Ptr = Tcl_NewStringObj("foo bar sum", -1);
+ Tcl_ListObjLength(NULL, list1Ptr, &len);
+ if (list1Ptr->bytes != NULL) {
+ ckfree((char *) list1Ptr->bytes);
+ list1Ptr->bytes = NULL;
+ }
+
+ list2Ptr = Tcl_NewStringObj("eeny meeny", -1);
+ Tcl_ListObjLength(NULL, list2Ptr, &len);
+ 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
+ * return a fresh Tcl_Obj (see also [Bug 2055782]).
+ */
+
+ tmpPtr = Tcl_DuplicateObj(list1Ptr);
+
+ objv[0] = tmpPtr;
+ objv[1] = emptyPtr;
+ concatPtr = Tcl_ConcatObj(2, objv);
+ if (concatPtr->refCount != 0) {
+ result = TCL_ERROR;
+ Tcl_AppendResult(interp,
+ "\n\t* (a) concatObj does not have refCount 0", NULL);
+ }
+ if (concatPtr == tmpPtr) {
+ result = TCL_ERROR;
+ Tcl_AppendResult(interp, "\n\t* (a) concatObj is not a new obj ",
+ NULL);
+ switch (tmpPtr->refCount) {
+ case 0:
+ Tcl_AppendResult(interp, "(no new refCount)", NULL);
+ break;
+ case 1:
+ Tcl_AppendResult(interp, "(refCount added)", NULL);
+ break;
+ default:
+ Tcl_AppendResult(interp, "(more than one refCount added!)", NULL);
+ Tcl_Panic("extremely unsafe behaviour by Tcl_ConcatObj()");
+ }
+ tmpPtr = Tcl_DuplicateObj(list1Ptr);
+ objv[0] = tmpPtr;
+ }
+ Tcl_DecrRefCount(concatPtr);
+
+ Tcl_IncrRefCount(tmpPtr);
+ concatPtr = Tcl_ConcatObj(2, objv);
+ if (concatPtr->refCount != 0) {
+ result = TCL_ERROR;
+ Tcl_AppendResult(interp,
+ "\n\t* (b) concatObj does not have refCount 0", NULL);
+ }
+ if (concatPtr == tmpPtr) {
+ result = TCL_ERROR;
+ Tcl_AppendResult(interp, "\n\t* (b) concatObj is not a new obj ",
+ NULL);
+ switch (tmpPtr->refCount) {
+ case 0:
+ Tcl_AppendResult(interp, "(refCount removed?)", NULL);
+ Tcl_Panic("extremely unsafe behaviour by Tcl_ConcatObj()");
+ break;
+ case 1:
+ Tcl_AppendResult(interp, "(no new refCount)", NULL);
+ break;
+ case 2:
+ Tcl_AppendResult(interp, "(refCount added)", NULL);
+ Tcl_DecrRefCount(tmpPtr);
+ break;
+ default:
+ Tcl_AppendResult(interp, "(more than one refCount added!)", NULL);
+ Tcl_Panic("extremely unsafe behaviour by Tcl_ConcatObj()");
+ }
+ tmpPtr = Tcl_DuplicateObj(list1Ptr);
+ objv[0] = tmpPtr;
+ }
+ Tcl_DecrRefCount(concatPtr);
+
+ objv[0] = emptyPtr;
+ objv[1] = tmpPtr;
+ objv[2] = emptyPtr;
+ concatPtr = Tcl_ConcatObj(3, objv);
+ if (concatPtr->refCount != 0) {
+ result = TCL_ERROR;
+ Tcl_AppendResult(interp,
+ "\n\t* (c) concatObj does not have refCount 0", NULL);
+ }
+ if (concatPtr == tmpPtr) {
+ result = TCL_ERROR;
+ Tcl_AppendResult(interp, "\n\t* (c) concatObj is not a new obj ",
+ NULL);
+ switch (tmpPtr->refCount) {
+ case 0:
+ Tcl_AppendResult(interp, "(no new refCount)", NULL);
+ break;
+ case 1:
+ Tcl_AppendResult(interp, "(refCount added)", NULL);
+ break;
+ default:
+ Tcl_AppendResult(interp, "(more than one refCount added!)", NULL);
+ Tcl_Panic("extremely unsafe behaviour by Tcl_ConcatObj()");
+ }
+ tmpPtr = Tcl_DuplicateObj(list1Ptr);
+ objv[1] = tmpPtr;
+ }
+ Tcl_DecrRefCount(concatPtr);
+
+ Tcl_IncrRefCount(tmpPtr);
+ concatPtr = Tcl_ConcatObj(3, objv);
+ if (concatPtr->refCount != 0) {
+ result = TCL_ERROR;
+ Tcl_AppendResult(interp,
+ "\n\t* (d) concatObj does not have refCount 0", NULL);
+ }
+ if (concatPtr == tmpPtr) {
+ result = TCL_ERROR;
+ Tcl_AppendResult(interp, "\n\t* (d) concatObj is not a new obj ",
+ NULL);
+ switch (tmpPtr->refCount) {
+ case 0:
+ Tcl_AppendResult(interp, "(refCount removed?)", NULL);
+ Tcl_Panic("extremely unsafe behaviour by Tcl_ConcatObj()");
+ break;
+ case 1:
+ Tcl_AppendResult(interp, "(no new refCount)", NULL);
+ break;
+ case 2:
+ Tcl_AppendResult(interp, "(refCount added)", NULL);
+ Tcl_DecrRefCount(tmpPtr);
+ break;
+ default:
+ Tcl_AppendResult(interp, "(more than one refCount added!)", NULL);
+ Tcl_Panic("extremely unsafe behaviour by Tcl_ConcatObj()");
+ }
+ tmpPtr = Tcl_DuplicateObj(list1Ptr);
+ objv[1] = tmpPtr;
+ }
+ Tcl_DecrRefCount(concatPtr);
+
+ /*
+ * Verify that an unshared list is not corrupted when concat'ing things to
+ * it.
+ */
+
+ objv[0] = tmpPtr;
+ objv[1] = list2Ptr;
+ concatPtr = Tcl_ConcatObj(2, objv);
+ if (concatPtr->refCount != 0) {
+ result = TCL_ERROR;
+ Tcl_AppendResult(interp,
+ "\n\t* (e) concatObj does not have refCount 0", NULL);
+ }
+ if (concatPtr == tmpPtr) {
+ int len;
+
+ result = TCL_ERROR;
+ Tcl_AppendResult(interp, "\n\t* (e) concatObj is not a new obj ",
+ NULL);
+
+ (void) Tcl_ListObjLength(NULL, concatPtr, &len);
+ switch (tmpPtr->refCount) {
+ case 3:
+ Tcl_AppendResult(interp, "(failed to concat)", NULL);
+ break;
+ default:
+ Tcl_AppendResult(interp, "(corrupted input!)", NULL);
+ }
+ if (Tcl_IsShared(tmpPtr)) {
+ Tcl_DecrRefCount(tmpPtr);
+ }
+ tmpPtr = Tcl_DuplicateObj(list1Ptr);
+ objv[0] = tmpPtr;
+ }
+ Tcl_DecrRefCount(concatPtr);
+
+ objv[0] = tmpPtr;
+ objv[1] = list2Ptr;
+ Tcl_IncrRefCount(tmpPtr);
+ concatPtr = Tcl_ConcatObj(2, objv);
+ if (concatPtr->refCount != 0) {
+ result = TCL_ERROR;
+ Tcl_AppendResult(interp,
+ "\n\t* (f) concatObj does not have refCount 0", NULL);
+ }
+ if (concatPtr == tmpPtr) {
+ int len;
+
+ result = TCL_ERROR;
+ Tcl_AppendResult(interp, "\n\t* (f) concatObj is not a new obj ",
+ NULL);
+
+ (void) Tcl_ListObjLength(NULL, concatPtr, &len);
+ switch (tmpPtr->refCount) {
+ case 3:
+ Tcl_AppendResult(interp, "(failed to concat)", NULL);
+ break;
+ default:
+ Tcl_AppendResult(interp, "(corrupted input!)", NULL);
+ }
+ if (Tcl_IsShared(tmpPtr)) {
+ Tcl_DecrRefCount(tmpPtr);
+ }
+ tmpPtr = Tcl_DuplicateObj(list1Ptr);
+ objv[0] = tmpPtr;
+ }
+ Tcl_DecrRefCount(concatPtr);
+
+ objv[0] = tmpPtr;
+ objv[1] = list2Ptr;
+ Tcl_IncrRefCount(tmpPtr);
+ Tcl_IncrRefCount(tmpPtr);
+ concatPtr = Tcl_ConcatObj(2, objv);
+ if (concatPtr->refCount != 0) {
+ result = TCL_ERROR;
+ Tcl_AppendResult(interp,
+ "\n\t* (g) concatObj does not have refCount 0", NULL);
+ }
+ if (concatPtr == tmpPtr) {
+ int len;
+
+ result = TCL_ERROR;
+ Tcl_AppendResult(interp, "\n\t* (g) concatObj is not a new obj ",
+ NULL);
+
+ (void) Tcl_ListObjLength(NULL, concatPtr, &len);
+ switch (tmpPtr->refCount) {
+ case 3:
+ Tcl_AppendResult(interp, "(failed to concat)", NULL);
+ break;
+ default:
+ Tcl_AppendResult(interp, "(corrupted input!)", NULL);
+ }
+ Tcl_DecrRefCount(tmpPtr);
+ if (Tcl_IsShared(tmpPtr)) {
+ Tcl_DecrRefCount(tmpPtr);
+ }
+ tmpPtr = Tcl_DuplicateObj(list1Ptr);
+ objv[0] = tmpPtr;
+ }
+ Tcl_DecrRefCount(concatPtr);
+
+ /*
+ * Clean everything up. Note that we don't actually know how many
+ * references there are to tmpPtr here; in the no-error case, it should be
+ * five... [Bug 2895367]
+ */
+
+ Tcl_DecrRefCount(list1Ptr);
+ Tcl_DecrRefCount(list2Ptr);
+ Tcl_DecrRefCount(emptyPtr);
+ while (tmpPtr->refCount > 1) {
+ Tcl_DecrRefCount(tmpPtr);
+ }
+ Tcl_DecrRefCount(tmpPtr);
+
+ if (result == TCL_OK) {
+ Tcl_ResetResult(interp);
+ }
+ return result;
+}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * tab-width: 8
+ * indent-tabs-mode: nil
+ * End:
+ */