summaryrefslogtreecommitdiffstats
path: root/generic/tclTest.c
diff options
context:
space:
mode:
authorstanton <stanton>1999-04-16 00:46:29 (GMT)
committerstanton <stanton>1999-04-16 00:46:29 (GMT)
commit97464e6cba8eb0008cf2727c15718671992b913f (patch)
treece9959f2747257d98d52ec8d18bf3b0de99b9535 /generic/tclTest.c
parenta8c96ddb94d1483a9de5e340b740cb74ef6cafa7 (diff)
downloadtcl-97464e6cba8eb0008cf2727c15718671992b913f.zip
tcl-97464e6cba8eb0008cf2727c15718671992b913f.tar.gz
tcl-97464e6cba8eb0008cf2727c15718671992b913f.tar.bz2
merged tcl 8.1 branch back into the main trunk
Diffstat (limited to 'generic/tclTest.c')
-rw-r--r--generic/tclTest.c1315
1 files changed, 1222 insertions, 93 deletions
diff --git a/generic/tclTest.c b/generic/tclTest.c
index b31ed64..80b296a 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -8,24 +8,28 @@
*
* Copyright (c) 1993-1994 The Regents of the University of California.
* Copyright (c) 1994-1997 Sun Microsystems, Inc.
+ * Copyright (c) 1998-1999 by Scriptics Corporation.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclTest.c,v 1.9 1999/03/10 05:52:50 stanton Exp $
+ * RCS: @(#) $Id: tclTest.c,v 1.10 1999/04/16 00:46:54 stanton Exp $
*/
#define TCL_TEST
#include "tclInt.h"
#include "tclPort.h"
+#include "tclRegexp.h"
+#include <locale.h>
/*
* Declare external functions used in Windows tests.
*/
#if defined(__WIN32__)
-extern TclPlatformType * TclWinGetPlatform _ANSI_ARGS_((void));
+extern TclPlatformType *TclWinGetPlatform(void);
+EXTERN void TclWinSetInterfaces(int);
#endif
/*
@@ -77,6 +81,24 @@ typedef struct DelCmd {
} DelCmd;
/*
+ * The following is used to keep track of an encoding that invokes a Tcl
+ * command.
+ */
+
+typedef struct TclEncoding {
+ Tcl_Interp *interp;
+ char *toUtfCmd;
+ char *fromUtfCmd;
+} TclEncoding;
+
+/*
+ * The counter below is used to determine if the TestsaveresultFree
+ * routine was called for a result.
+ */
+
+static int freeCount;
+
+/*
* Forward declarations for procedures defined later in this file:
*/
@@ -111,6 +133,17 @@ static void DelCallbackProc _ANSI_ARGS_((ClientData clientData,
static int DelCmdProc _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int argc, 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,
+ 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,
+ 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,
@@ -118,7 +151,10 @@ static int GetTimesCmd _ANSI_ARGS_((ClientData clientData,
static int NoopCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int argc, char **argv));
static int NoopObjCmd _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+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,
@@ -149,10 +185,22 @@ static int TestdelassocdataCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, char **argv));
static int TestdstringCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, 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 TestexithandlerCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, char **argv));
static int TestexprlongCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, char **argv));
+static int TestexprparserObjCmd _ANSI_ARGS_((ClientData dummy,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
static int TestexprstringCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, char **argv));
static int TestfileCmd _ANSI_ARGS_((ClientData dummy,
@@ -170,6 +218,9 @@ static int TestinterpdeleteCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, char **argv));
static int TestlinkCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, char **argv));
+static int TestlocaleCmd _ANSI_ARGS_((ClientData dummy,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
static int TestMathFunc _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, Tcl_Value *args,
Tcl_Value *resultPtr));
@@ -182,8 +233,26 @@ static Tcl_Channel TestOpenFileChannelProc2 _ANSI_ARGS_((Tcl_Interp *interp,
char *filename, char *modeString, int permissions));
static Tcl_Channel TestOpenFileChannelProc3 _ANSI_ARGS_((Tcl_Interp *interp,
char *filename, char *modeString, int permissions));
-static int TestPanicCmd _ANSI_ARGS_((ClientData dummy,
+static int TestpanicCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, char **argv));
+static int TestparserObjCmd _ANSI_ARGS_((ClientData dummy,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+static int TestparsevarObjCmd _ANSI_ARGS_((ClientData dummy,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+static int TestparsevarnameObjCmd _ANSI_ARGS_((ClientData dummy,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+static int TestregexpObjCmd _ANSI_ARGS_((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_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, char **argv));
static int TestsetCmd _ANSI_ARGS_((ClientData dummy,
@@ -212,18 +281,15 @@ static int TesttranslatefilenameCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, char **argv));
static int TestupvarCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, char **argv));
-static int TestwordendObjCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *CONST objv[]));
/*
- * External (platform specific) initialization routine, this declaration
- * explicitly does not use EXTERN since this code does not get compiled
+ * External (platform specific) initialization routine, these declarations
+ * explicitly don't use EXTERN since this code does not get compiled
* into the library:
*/
-extern int TclplatformtestInit _ANSI_ARGS_((
- Tcl_Interp *interp));
+extern int TclplatformtestInit _ANSI_ARGS_((Tcl_Interp *interp));
+extern int TclThread_Init _ANSI_ARGS_((Tcl_Interp *interp));
/*
*----------------------------------------------------------------------
@@ -236,7 +302,7 @@ extern int TclplatformtestInit _ANSI_ARGS_((
*
* Results:
* Returns a standard Tcl completion code, and leaves an error
- * message in interp->result if an error occurs.
+ * message in the interp's result if an error occurs.
*
* Side effects:
* Depends on the startup script.
@@ -258,6 +324,8 @@ Tcltest_Init(interp)
* 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,
@@ -289,12 +357,22 @@ Tcltest_Init(interp)
Tcl_DStringInit(&dstring);
Tcl_CreateCommand(interp, "testdstring", TestdstringCmd, (ClientData) 0,
(Tcl_CmdDeleteProc *) NULL);
+ Tcl_CreateObjCommand(interp, "testencoding", TestencodingObjCmd, (ClientData) 0,
+ (Tcl_CmdDeleteProc *) NULL);
+ Tcl_CreateObjCommand(interp, "testevalex", TestevalexObjCmd,
+ (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+ Tcl_CreateObjCommand(interp, "testevalobjv", TestevalobjvObjCmd,
+ (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testexithandler", TestexithandlerCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testexprlong", TestexprlongCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+ Tcl_CreateObjCommand(interp, "testexprparser", TestexprparserObjCmd,
+ (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testexprstring", TestexprstringCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+ Tcl_CreateCommand(interp, "testfevent", TestfeventCmd, (ClientData) 0,
+ (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testfile", TestfileCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testgetassocdata", TestgetassocdataCmd,
@@ -308,9 +386,23 @@ Tcltest_Init(interp)
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testlink", TestlinkCmd, (ClientData) 0,
(Tcl_CmdDeleteProc *) 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);
+ Tcl_CreateObjCommand(interp, "testparser", TestparserObjCmd,
+ (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+ Tcl_CreateObjCommand(interp, "testparsevar", TestparsevarObjCmd,
+ (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+ Tcl_CreateObjCommand(interp, "testparsevarname", TestparsevarnameObjCmd,
+ (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+ Tcl_CreateObjCommand(interp, "testregexp", TestregexpObjCmd,
+ (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+ Tcl_CreateObjCommand(interp, "testsaveresult", TestsaveresultCmd,
+ (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testsetassocdata", TestsetassocdataCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testsetnoerr", TestsetCmd,
@@ -332,14 +424,6 @@ Tcltest_Init(interp)
(Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testupvar", TestupvarCmd, (ClientData) 0,
(Tcl_CmdDeleteProc *) NULL);
- Tcl_CreateObjCommand(interp, "testwordend", TestwordendObjCmd,
- (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
- Tcl_CreateCommand(interp, "testfevent", TestfeventCmd, (ClientData) 0,
- (Tcl_CmdDeleteProc *) NULL);
- Tcl_CreateCommand(interp, "testpanic", TestPanicCmd, (ClientData) 0,
- (Tcl_CmdDeleteProc *) NULL);
- Tcl_CreateCommand(interp, "gettimes", GetTimesCmd, (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,
@@ -351,6 +435,12 @@ Tcltest_Init(interp)
Tcl_CreateMathFunc(interp, "T3", 2, t3ArgTypes, TestMathFunc2,
(ClientData) 0);
+#ifdef TCL_THREADS
+ if (TclThread_Init(interp) != TCL_OK) {
+ return TCL_ERROR;
+ }
+#endif
+
/*
* And finally add any platform specific test commands.
*/
@@ -386,7 +476,7 @@ TestasyncCmd(dummy, interp, argc, argv)
TestAsyncHandler *asyncPtr, *prevPtr;
int id, code;
static int nextId = 1;
- char buf[30];
+ char buf[TCL_INTEGER_SPACE];
if (argc < 2) {
wrongNumArgs:
@@ -406,7 +496,7 @@ TestasyncCmd(dummy, interp, argc, argv)
strcpy(asyncPtr->command, argv[2]);
asyncPtr->nextPtr = firstHandler;
firstHandler = asyncPtr;
- sprintf(buf, "%d", asyncPtr->id);
+ TclFormatInt(buf, asyncPtr->id);
Tcl_SetResult(interp, buf, TCL_VOLATILE);
} else if (strcmp(argv[1], "delete") == 0) {
if (argc == 2) {
@@ -475,11 +565,11 @@ AsyncHandlerProc(clientData, interp, code)
{
TestAsyncHandler *asyncPtr = (TestAsyncHandler *) clientData;
char *listArgv[4];
- char string[20], *cmd;
+ char string[TCL_INTEGER_SPACE], *cmd;
- sprintf(string, "%d", code);
+ TclFormatInt(string, code);
listArgv[0] = asyncPtr->command;
- listArgv[1] = interp->result;
+ listArgv[1] = Tcl_GetStringResult(interp);
listArgv[2] = string;
listArgv[3] = NULL;
cmd = Tcl_Merge(3, listArgv);
@@ -677,8 +767,7 @@ TestcmdtokenCmd(dummy, interp, argc, argv)
Tcl_AppendElement(interp,
Tcl_GetCommandName(interp, (Tcl_Command) l));
- Tcl_AppendElement(interp,
- Tcl_GetStringFromObj(objPtr, (int *) NULL));
+ Tcl_AppendElement(interp, Tcl_GetString(objPtr));
Tcl_DecrRefCount(objPtr);
} else {
Tcl_AppendResult(interp, "bad option \"", argv[1],
@@ -744,7 +833,7 @@ TestcmdtraceCmd(dummy, interp, argc, argv)
cmdTrace = Tcl_CreateTrace(interp, 50000,
(Tcl_CmdTraceProc *) CmdTraceDeleteProc, (ClientData) NULL);
- result = Tcl_Eval(interp, argv[2]);
+ Tcl_Eval(interp, argv[2]);
} else {
Tcl_AppendResult(interp, "bad option \"", argv[1],
"\": must be tracetest or deletetest", (char *) NULL);
@@ -958,9 +1047,9 @@ DelCallbackProc(clientData, interp)
Tcl_Interp *interp; /* Interpreter being deleted. */
{
int id = (int) clientData;
- char buffer[10];
+ char buffer[TCL_INTEGER_SPACE];
- sprintf(buffer, "%d", id);
+ TclFormatInt(buffer, id);
Tcl_DStringAppendElement(&delString, buffer);
if (interp != delInterp) {
Tcl_DStringAppendElement(&delString, "bogus interpreter argument!");
@@ -1160,12 +1249,12 @@ TestdstringCmd(dummy, interp, argc, argv)
}
Tcl_DStringGetResult(interp, &dstring);
} else if (strcmp(argv[1], "length") == 0) {
- char buf[30];
+ char buf[TCL_INTEGER_SPACE];
if (argc != 2) {
goto wrongNumArgs;
}
- sprintf(buf, "%d", Tcl_DStringLength(&dstring));
+ TclFormatInt(buf, Tcl_DStringLength(&dstring));
Tcl_SetResult(interp, buf, TCL_VOLATILE);
} else if (strcmp(argv[1], "result") == 0) {
if (argc != 2) {
@@ -1208,6 +1297,285 @@ static void SpecialFree(blockPtr)
/*
*----------------------------------------------------------------------
*
+ * TestencodingCmd --
+ *
+ * This procedure implements the "testencoding" command. It is used
+ * to test the encoding package.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * Load encodings.
+ *
+ *----------------------------------------------------------------------
+ */
+
+ /* 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. */
+{
+ Tcl_Encoding encoding;
+ int index, length;
+ char *string;
+ TclEncoding *encodingPtr;
+ static char *optionStrings[] = {
+ "create", "delete", "path",
+ NULL
+ };
+ enum options {
+ ENC_CREATE, ENC_DELETE, ENC_PATH
+ };
+
+ 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;
+
+ 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[4], &length);
+ encodingPtr->fromUtfCmd = (char *) ckalloc((unsigned) (length + 1));
+ memcpy(encodingPtr->fromUtfCmd, string, (unsigned) (length + 1));
+
+ 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;
+
+ 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;
+ }
+ }
+ 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. */
+{
+ int len;
+ TclEncoding *encodingPtr;
+
+ encodingPtr = (TclEncoding *) clientData;
+ Tcl_GlobalEval(encodingPtr->interp, encodingPtr->toUtfCmd);
+
+ len = strlen(Tcl_GetStringResult(encodingPtr->interp));
+ if (len > dstLen) {
+ len = dstLen;
+ }
+ memcpy(dst, Tcl_GetStringResult(encodingPtr->interp), (unsigned) len);
+ Tcl_ResetResult(encodingPtr->interp);
+
+ *srcReadPtr = srcLen;
+ *dstWrotePtr = len;
+ *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. */
+{
+ int len;
+ TclEncoding *encodingPtr;
+
+ encodingPtr = (TclEncoding *) clientData;
+ Tcl_GlobalEval(encodingPtr->interp, encodingPtr->fromUtfCmd);
+
+ len = strlen(Tcl_GetStringResult(encodingPtr->interp));
+ if (len > dstLen) {
+ len = dstLen;
+ }
+ memcpy(dst, Tcl_GetStringResult(encodingPtr->interp), (unsigned) len);
+ Tcl_ResetResult(encodingPtr->interp);
+
+ *srcReadPtr = srcLen;
+ *dstWrotePtr = len;
+ *dstCharsPtr = len;
+ return TCL_OK;
+}
+static void
+EncodingFreeProc(clientData)
+ ClientData clientData; /* ClientData associated with type. */
+{
+ TclEncoding *encodingPtr;
+
+ encodingPtr = (TclEncoding *) clientData;
+ ckfree((char *) encodingPtr->toUtfCmd);
+ ckfree((char *) encodingPtr->fromUtfCmd);
+ ckfree((char *) encodingPtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TestevalexObjCmd --
+ *
+ * This procedure implements the "testevalex" command. It is
+ * used to test Tcl_EvalEx.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+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. */
+{
+ 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;
+ }
+
+ 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);
+ return TCL_ERROR;
+ }
+ flags = TCL_EVAL_GLOBAL;
+ } else if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "script ?global?");
+ 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;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TestevalobjvObjCmd --
+ *
+ * This procedure implements the "testevalobjv" command. It is
+ * used to test Tcl_EvalObjv.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+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. */
+{
+ int evalGlobal;
+
+ if (objc < 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "global word ?word ...?");
+ return TCL_ERROR;
+ }
+ if (Tcl_GetIntFromObj(interp, objv[1], &evalGlobal) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ return Tcl_EvalObjv(interp, objc-2, objv+2,
+ (evalGlobal) ? TCL_EVAL_GLOBAL : 0);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TestexithandlerCmd --
*
* This procedure implements the "testexithandler" command. It is
@@ -1257,7 +1625,7 @@ static void
ExitProcOdd(clientData)
ClientData clientData; /* Integer value to print. */
{
- char buf[100];
+ char buf[16 + TCL_INTEGER_SPACE];
sprintf(buf, "odd %d\n", (int) clientData);
write(1, buf, strlen(buf));
@@ -1267,7 +1635,7 @@ static void
ExitProcEven(clientData)
ClientData clientData; /* Integer value to print. */
{
- char buf[100];
+ char buf[16 + TCL_INTEGER_SPACE];
sprintf(buf, "even %d\n", (int) clientData);
write(1, buf, strlen(buf));
@@ -1298,7 +1666,7 @@ TestexprlongCmd(clientData, interp, argc, argv)
char **argv; /* Argument strings. */
{
long exprResult;
- char buf[30];
+ char buf[4 + TCL_INTEGER_SPACE];
int result;
Tcl_SetResult(interp, "This is a result", TCL_STATIC);
@@ -1463,8 +1831,6 @@ TestinterpdeleteCmd(dummy, interp, argc, argv)
}
slaveToDelete = Tcl_GetSlave(interp, argv[1]);
if (slaveToDelete == (Tcl_Interp *) NULL) {
- Tcl_AppendResult(interp, "could not find interpreter \"",
- argv[1], "\"", (char *) NULL);
return TCL_ERROR;
}
Tcl_DeleteInterp(slaveToDelete);
@@ -1557,11 +1923,11 @@ TestlinkCmd(dummy, interp, argc, argv)
Tcl_UnlinkVar(interp, "string");
created = 0;
} else if (strcmp(argv[1], "get") == 0) {
- sprintf(buffer, "%d", intVar);
+ TclFormatInt(buffer, intVar);
Tcl_AppendElement(interp, buffer);
Tcl_PrintDouble((Tcl_Interp *) NULL, realVar, buffer);
Tcl_AppendElement(interp, buffer);
- sprintf(buffer, "%d", boolVar);
+ TclFormatInt(buffer, boolVar);
Tcl_AppendElement(interp, buffer);
Tcl_AppendElement(interp, (stringVar == NULL) ? "-" : stringVar);
} else if (strcmp(argv[1], "set") == 0) {
@@ -1646,6 +2012,68 @@ TestlinkCmd(dummy, interp, argc, argv)
/*
*----------------------------------------------------------------------
*
+ * TestlocaleCmd --
+ *
+ * This procedure implements the "testlocale" command. It is used
+ * to test the effects of setting different locales in Tcl.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * Modifies the current C locale.
+ *
+ *----------------------------------------------------------------------
+ */
+
+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. */
+{
+ int index;
+ char *locale;
+
+ static char *optionStrings[] = {
+ "ctype", "numeric", "time", "collate", "monetary",
+ "all", NULL
+ };
+ static int lcTypes[] = {
+ LC_CTYPE, LC_NUMERIC, LC_TIME, LC_COLLATE, LC_MONETARY,
+ LC_ALL
+ };
+
+ /*
+ * LC_CTYPE, etc. correspond to the indices for the strings.
+ */
+
+ if (objc < 2 || objc > 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "category ?locale?");
+ return TCL_ERROR;
+ }
+
+ if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0,
+ &index) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ if (objc == 3) {
+ locale = Tcl_GetString(objv[2]);
+ } else {
+ locale = NULL;
+ }
+ locale = setlocale(lcTypes[index], locale);
+ if (locale) {
+ Tcl_SetStringObj(Tcl_GetObjResult(interp), locale, -1);
+ }
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TestMathFunc --
*
* This is a user-defined math procedure to test out math procedures
@@ -1696,8 +2124,8 @@ 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_Values for the two
- * arguments. */
+ * Tcl_Value structs for the
+ * two arguments. */
Tcl_Value *resultPtr; /* Where to store the result. */
{
int result = TCL_OK;
@@ -1776,6 +2204,617 @@ CleanupTestSetassocdataTests(clientData, interp)
/*
*----------------------------------------------------------------------
*
+ * TestparserObjCmd --
+ *
+ * This procedure implements the "testparser" command. It is
+ * used for testing the new Tcl script parser in Tcl 8.1.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+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. */
+{
+ char *script;
+ int length, dummy;
+ Tcl_Parse parse;
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "script length");
+ return TCL_ERROR;
+ }
+ script = Tcl_GetStringFromObj(objv[1], &dummy);
+ if (Tcl_GetIntFromObj(interp, objv[2], &length)) {
+ return TCL_ERROR;
+ }
+ if (length == 0) {
+ length = dummy;
+ }
+ if (Tcl_ParseCommand(interp, script, length, 0, &parse) != TCL_OK) {
+ Tcl_AddErrorInfo(interp, "\n (remainder of script: \"");
+ Tcl_AddErrorInfo(interp, parse.term);
+ Tcl_AddErrorInfo(interp, "\")");
+ return TCL_ERROR;
+ }
+
+ /*
+ * The parse completed successfully. Just print out the contents
+ * of the parse structure into the interpreter's result.
+ */
+
+ PrintParse(interp, &parse);
+ Tcl_FreeParse(&parse);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TestexprparserObjCmd --
+ *
+ * This procedure implements the "testexprparser" command. It is
+ * used for testing the new Tcl expression parser in Tcl 8.1.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+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. */
+{
+ char *script;
+ int length, dummy;
+ Tcl_Parse parse;
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "expr length");
+ return TCL_ERROR;
+ }
+ script = Tcl_GetStringFromObj(objv[1], &dummy);
+ if (Tcl_GetIntFromObj(interp, objv[2], &length)) {
+ return TCL_ERROR;
+ }
+ if (length == 0) {
+ length = dummy;
+ }
+ if (Tcl_ParseExpr(interp, script, length, &parse) != TCL_OK) {
+ Tcl_AddErrorInfo(interp, "\n (remainder of expr: \"");
+ Tcl_AddErrorInfo(interp, parse.term);
+ Tcl_AddErrorInfo(interp, "\")");
+ return TCL_ERROR;
+ }
+
+ /*
+ * The parse completed successfully. Just print out the contents
+ * of the parse structure into the interpreter's result.
+ */
+
+ PrintParse(interp, &parse);
+ Tcl_FreeParse(&parse);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * PrintParse --
+ *
+ * This procedure prints out the contents of a Tcl_Parse structure
+ * in the result of an interpreter.
+ *
+ * Results:
+ * Interp's result is set to a prettily formatted version of the
+ * contents of parsePtr.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+PrintParse(interp, parsePtr)
+ 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_Obj *objPtr;
+ char *typeString;
+ Tcl_Token *tokenPtr;
+ int i;
+
+ objPtr = Tcl_GetObjResult(interp);
+ if (parsePtr->commentSize > 0) {
+ Tcl_ListObjAppendElement((Tcl_Interp *) NULL, objPtr,
+ Tcl_NewStringObj(parsePtr->commentStart,
+ parsePtr->commentSize));
+ } else {
+ Tcl_ListObjAppendElement((Tcl_Interp *) NULL, objPtr,
+ Tcl_NewStringObj("-", 1));
+ }
+ Tcl_ListObjAppendElement((Tcl_Interp *) NULL, objPtr,
+ Tcl_NewStringObj(parsePtr->commandStart, parsePtr->commandSize));
+ Tcl_ListObjAppendElement((Tcl_Interp *) 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;
+ }
+ Tcl_ListObjAppendElement((Tcl_Interp *) NULL, objPtr,
+ Tcl_NewStringObj(typeString, -1));
+ Tcl_ListObjAppendElement((Tcl_Interp *) NULL, objPtr,
+ Tcl_NewStringObj(tokenPtr->start, tokenPtr->size));
+ Tcl_ListObjAppendElement((Tcl_Interp *) NULL, objPtr,
+ Tcl_NewIntObj(tokenPtr->numComponents));
+ }
+ Tcl_ListObjAppendElement((Tcl_Interp *) NULL, objPtr,
+ Tcl_NewStringObj(parsePtr->commandStart + parsePtr->commandSize,
+ -1));
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TestparsevarObjCmd --
+ *
+ * This procedure implements the "testparsevar" command. It is
+ * used for testing Tcl_ParseVar.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+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. */
+{
+ char *name, *value, *termPtr;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "varName");
+ return TCL_ERROR;
+ }
+ name = Tcl_GetString(objv[1]);
+ value = Tcl_ParseVar(interp, name, &termPtr);
+ if (value == NULL) {
+ return TCL_ERROR;
+ }
+
+ Tcl_AppendElement(interp, value);
+ Tcl_AppendElement(interp, termPtr);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TestparsevarnameObjCmd --
+ *
+ * This procedure implements the "testparsevarname" command. It is
+ * used for testing the new Tcl script parser in Tcl 8.1.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+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. */
+{
+ char *script;
+ int append, length, dummy;
+ Tcl_Parse parse;
+
+ if (objc != 4) {
+ Tcl_WrongNumArgs(interp, 1, objv, "script length append");
+ return TCL_ERROR;
+ }
+ script = Tcl_GetStringFromObj(objv[1], &dummy);
+ if (Tcl_GetIntFromObj(interp, objv[2], &length)) {
+ return TCL_ERROR;
+ }
+ if (length == 0) {
+ length = dummy;
+ }
+ if (Tcl_GetIntFromObj(interp, objv[3], &append)) {
+ return TCL_ERROR;
+ }
+ if (Tcl_ParseVarName(interp, script, length, &parse, append) != TCL_OK) {
+ Tcl_AddErrorInfo(interp, "\n (remainder of script: \"");
+ Tcl_AddErrorInfo(interp, parse.term);
+ Tcl_AddErrorInfo(interp, "\")");
+ return TCL_ERROR;
+ }
+
+ /*
+ * The parse completed successfully. Just print out the contents
+ * of the parse structure into the interpreter's result.
+ */
+
+ parse.commentSize = 0;
+ parse.commandStart = script + parse.tokenPtr->size;
+ parse.commandSize = 0;
+ PrintParse(interp, &parse);
+ Tcl_FreeParse(&parse);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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 REGEXP_TEST define, which
+ * enables the -xflags option.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+ /* ARGSUSED */
+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. */
+{
+ int i, result, indices, stringLength, wLen, match, about;
+ int hasxflags, cflags, eflags;
+ Tcl_RegExp regExpr;
+ char *string;
+ Tcl_DString stringBuffer, valueBuffer;
+ Tcl_UniChar *wStart;
+# define REGEXP_TEST /* yes */
+ static char *options[] = {
+ "-indices", "-nocase", "-about", "-expanded",
+ "-line", "-linestop", "-lineanchor",
+#ifdef REGEXP_TEST
+ "-xflags",
+#endif
+ "--", (char *) NULL
+ };
+ enum options {
+ REGEXP_INDICES, REGEXP_NOCASE, REGEXP_ABOUT, REGEXP_EXPANDED,
+ REGEXP_MULTI, REGEXP_NOCROSS, REGEXP_NEWL,
+#ifdef REGEXP_TEST
+ REGEXP_XFLAGS,
+#endif
+ REGEXP_LAST
+ };
+#ifndef REGEXP_TEST
+# define REGEXP_XFLAGS -1 /* impossible value */
+# define TestregexpXflags(a,b,c,d) /* do nothing */
+#endif
+
+ indices = 0;
+ about = 0;
+ cflags = REG_ADVANCED;
+ eflags = 0;
+ hasxflags = 0;
+
+ for (i = 1; i < objc; i++) {
+ char *name;
+ int index;
+
+ name = Tcl_GetString(objv[i]);
+ if (name[0] != '-') {
+ break;
+ }
+ if (Tcl_GetIndexFromObj(interp, objv[i], options, "switch", TCL_EXACT,
+ &index) != TCL_OK) {
+ 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;
+ }
+ }
+ }
+
+ endOfForLoop:
+ if (objc - i < hasxflags + 2 - about) {
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?");
+ return TCL_ERROR;
+ }
+ objc -= i;
+ objv += i;
+
+ if (hasxflags) {
+ string = Tcl_GetStringFromObj(objv[0], &stringLength);
+ TestregexpXflags(string, stringLength, &cflags, &eflags);
+ objc--;
+ objv++;
+ }
+
+ regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags);
+ if (regExpr == NULL) {
+ return TCL_ERROR;
+ }
+
+ if (about) {
+ if (TclRegAbout(interp, regExpr) < 0) {
+ return TCL_ERROR;
+ }
+ return TCL_OK;
+ }
+
+ result = TCL_OK;
+ string = Tcl_GetStringFromObj(objv[1], &stringLength);
+
+ Tcl_DStringInit(&valueBuffer);
+
+ Tcl_DStringInit(&stringBuffer);
+ wStart = Tcl_UtfToUniCharDString(string, stringLength, &stringBuffer);
+ wLen = Tcl_DStringLength(&stringBuffer) / sizeof(Tcl_UniChar);
+
+ match = TclRegExpExecUniChar(interp, regExpr, wStart, wLen, objc-2, eflags);
+ if (match < 0) {
+ result = TCL_ERROR;
+ goto done;
+ }
+ if (match == 0) {
+ /*
+ * Set the interpreter's object result to an integer object w/ value 0.
+ */
+
+ Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
+ goto done;
+ }
+
+ /*
+ * If additional variable names have been specified, return
+ * index information in those variables.
+ */
+
+ objc -= 2;
+ objv += 2;
+
+ for (i = 0; i < objc; i++) {
+ char *varName, *value;
+ int start, end;
+
+ varName = Tcl_GetString(objv[i]);
+
+ TclRegExpRangeUniChar(regExpr, i, &start, &end);
+ if (start < 0) {
+ if (indices) {
+ value = Tcl_SetVar(interp, varName, "-1 -1", 0);
+ } else {
+ value = Tcl_SetVar(interp, varName, "", 0);
+ }
+ } else {
+ if (indices) {
+ char info[TCL_INTEGER_SPACE * 2];
+
+ sprintf(info, "%d %d", start, end - 1);
+ value = Tcl_SetVar(interp, varName, info, 0);
+ } else {
+ value = Tcl_UniCharToUtfDString(wStart + start, end - start,
+ &valueBuffer);
+ value = Tcl_SetVar(interp, varName, value, 0);
+ Tcl_DStringSetLength(&valueBuffer, 0);
+ }
+ }
+ if (value == NULL) {
+ Tcl_AppendResult(interp, "couldn't set variable \"",
+ varName, "\"", (char *) NULL);
+ result = TCL_ERROR;
+ goto done;
+ }
+ }
+
+ /*
+ * Set the interpreter's object result to an integer object w/ value 1.
+ */
+
+ Tcl_SetIntObj(Tcl_GetObjResult(interp), 1);
+
+ done:
+ Tcl_DStringFree(&stringBuffer);
+ Tcl_DStringFree(&valueBuffer);
+ return result;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * TestregexpXflags --
+ *
+ * Parse a string of extended regexp flag letters, for testing.
+ *
+ * Results:
+ * No return value (you're on your own for errors here).
+ *
+ * Side effects:
+ * Modifies *cflagsPtr, a regcomp flags word, and *eflagsPtr, a
+ * regexec flags word, as appropriate.
+ *
+ *----------------------------------------------------------------------
+ */
+
+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 */
+{
+ int i;
+ int cflags;
+ int 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 '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 '+': {
+ cflags |= REG_FAKEEC;
+ 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 '%': {
+ eflags |= REG_SMALL;
+ break;
+ }
+ }
+ }
+
+ *cflagsPtr = cflags;
+ *eflagsPtr = eflags;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TestsetassocdataCmd --
*
* This procedure implements the "testsetassocdata" command. It is used
@@ -2070,46 +3109,6 @@ TestupvarCmd(dummy, interp, argc, argv)
/*
*----------------------------------------------------------------------
*
- * TestwordendCmd --
- *
- * This procedure implements the "testwordend" command. It is used
- * to test TclWordEnd.
- *
- * Results:
- * A standard Tcl result.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
- /* ARGSUSED */
-static int
-TestwordendObjCmd(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. */
-{
- Tcl_Obj *objPtr;
- char *string, *end;
- int length;
-
- if (objc != 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "string");
- return TCL_ERROR;
- }
- objPtr = Tcl_GetObjResult(interp);
- string = Tcl_GetStringFromObj(objv[1], &length);
- end = TclWordEnd(string, string+length, 0, NULL);
- Tcl_AppendToObj(objPtr, end, length - (end - string));
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
* TestsetobjerrorcodeCmd --
*
* This procedure implements the "testsetobjerrorcodeCmd".
@@ -2189,7 +3188,7 @@ TestfeventCmd(clientData, interp, argc, argv)
}
if (interp2 != (Tcl_Interp *) NULL) {
code = Tcl_GlobalEval(interp2, argv[2]);
- interp->result = interp2->result;
+ Tcl_SetObjResult(interp, Tcl_GetObjResult(interp2));
return code;
} else {
Tcl_AppendResult(interp,
@@ -2224,7 +3223,7 @@ TestfeventCmd(clientData, interp, argc, argv)
/*
*----------------------------------------------------------------------
*
- * TestPanicCmd --
+ * TestpanicCmd --
*
* Calls the panic routine.
*
@@ -2238,7 +3237,7 @@ TestfeventCmd(clientData, interp, argc, argv)
*/
static int
-TestPanicCmd(dummy, interp, argc, argv)
+TestpanicCmd(dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
@@ -2420,9 +3419,9 @@ TestgetvarfullnameCmd(dummy, interp, objc, objv)
return TCL_ERROR;
}
- name = Tcl_GetStringFromObj(objv[1], (int *) NULL);
+ name = Tcl_GetString(objv[1]);
- arg = Tcl_GetStringFromObj(objv[2], (int *) NULL);
+ arg = Tcl_GetString(objv[2]);
if (strcmp(arg, "global") == 0) {
flags = TCL_GLOBAL_ONLY;
} else if (strcmp(arg, "namespace") == 0) {
@@ -2495,7 +3494,7 @@ GetTimesCmd(unused, interp, argc, argv)
Tcl_Obj *objPtr;
Tcl_Obj **objv;
char *s;
- char newString[30];
+ char newString[TCL_INTEGER_SPACE];
/* alloc & free 100000 times */
fprintf(stderr, "alloc & free 100000 6 word items\n");
@@ -2551,12 +3550,12 @@ GetTimesCmd(unused, interp, argc, argv)
fprintf(stderr, " %.3f usec per Tcl_DecrRefCount\n", timePer/5000);
ckfree((char *) objv);
- /* TclGetStringFromObj 100000 times */
+ /* TclGetString 100000 times */
fprintf(stderr, "TclGetStringFromObj of \"12345\" 100000 times\n");
objPtr = Tcl_NewStringObj("12345", -1);
TclpGetTime(&start);
for (i = 0; i < 100000; i++) {
- (void) TclGetStringFromObj(objPtr, &n);
+ (void) TclGetString(objPtr);
}
TclpGetTime(&stop);
timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
@@ -2728,8 +3727,7 @@ TestsetCmd(data, interp, argc, argv)
if (argc == 2) {
Tcl_SetResult(interp, "before get", TCL_STATIC);
- value = Tcl_GetVar2(interp, argv[1], (char *) NULL,
- TCL_PARSE_PART1|flags);
+ value = Tcl_GetVar2(interp, argv[1], (char *) NULL, flags);
if (value == NULL) {
return TCL_ERROR;
}
@@ -2737,8 +3735,7 @@ TestsetCmd(data, interp, argc, argv)
return TCL_OK;
} else if (argc == 3) {
Tcl_SetResult(interp, "before set", TCL_STATIC);
- value = Tcl_SetVar2(interp, argv[1], (char *) NULL, argv[2],
- TCL_PARSE_PART1|flags);
+ value = Tcl_SetVar2(interp, argv[1], (char *) NULL, argv[2], flags);
if (value == NULL) {
return TCL_ERROR;
}
@@ -2754,6 +3751,138 @@ TestsetCmd(data, interp, argc, argv)
/*
*----------------------------------------------------------------------
*
+ * TestsaveresultCmd --
+ *
+ * Implements the "testsaveresult" cmd that is used when testing
+ * the Tcl_SaveResult, Tcl_RestoreResult, and
+ * Tcl_DiscardResult interfaces.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+ /* 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. */
+{
+ int discard, result, index;
+ Tcl_SavedResult state;
+ Tcl_Obj *objPtr;
+ static char *optionStrings[] = {
+ "append", "dynamic", "free", "object", "small", NULL
+ };
+ enum options {
+ RESULT_APPEND, RESULT_DYNAMIC, RESULT_FREE, RESULT_OBJECT, RESULT_SMALL
+ };
+
+ /*
+ * Parse arguments
+ */
+
+ if (objc != 4) {
+ Tcl_WrongNumArgs(interp, 1, objv, "type script discard");
+ return TCL_ERROR;
+ }
+ if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0,
+ &index) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (Tcl_GetBooleanFromObj(interp, objv[3], &discard) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ 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;
+ }
+
+ freeCount = 0;
+ Tcl_SaveResult(interp, &state);
+
+ if (((enum options) index) == RESULT_OBJECT) {
+ result = Tcl_EvalObjEx(interp, objv[2], 0);
+ } else {
+ result = Tcl_Eval(interp, Tcl_GetString(objv[2]));
+ }
+
+ if (discard) {
+ Tcl_DiscardResult(&state);
+ } else {
+ Tcl_RestoreResult(interp, &state);
+ result = TCL_OK;
+ }
+
+ 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;
+ }
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TestsaveresultFree --
+ *
+ * Special purpose freeProc used by TestsaveresultCmd.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Increments the freeCount.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+TestsaveresultFree(blockPtr)
+ char *blockPtr;
+{
+ freeCount++;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TeststatprocCmd --
*
* Implements the "testTclStatProc" cmd that is used to test the