diff options
Diffstat (limited to 'generic/tclTest.c')
| -rw-r--r-- | generic/tclTest.c | 185 |
1 files changed, 120 insertions, 65 deletions
diff --git a/generic/tclTest.c b/generic/tclTest.c index 37ec751..a27c95a 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -15,11 +15,6 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ -#ifndef _WIN64 -/* See [Bug 2935503]: file mtime sets wrong time */ -# define _USE_32BIT_TIME_T -#endif - #undef STATIC_BUILD #ifndef USE_TCL_STUBS # define USE_TCL_STUBS @@ -313,11 +308,8 @@ 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 TestfinexitObjCmd(ClientData dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -static int TestparseargsCmd(ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); +static int TestparseargsCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); static int TestparserObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -335,10 +327,12 @@ static int TestreturnObjCmd(ClientData dummy, Tcl_Obj *const objv[]); static void TestregexpXflags(const char *string, int length, int *cflagsPtr, int *eflagsPtr); +#ifndef TCL_NO_DEPRECATED static int TestsaveresultCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static void TestsaveresultFree(char *blockPtr); +#endif /* TCL_NO_DEPRECATED */ static int TestsetassocdataCmd(ClientData dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestsetCmd(ClientData dummy, @@ -389,7 +383,8 @@ static Tcl_FSRenameFileProc TestReportRenameFile; static Tcl_FSCreateDirectoryProc TestReportCreateDirectory; static Tcl_FSCopyDirectoryProc TestReportCopyDirectory; static Tcl_FSRemoveDirectoryProc TestReportRemoveDirectory; -static Tcl_FSLoadFileProc TestReportLoadFile; +static int TestReportLoadFile(Tcl_Interp *interp, Tcl_Obj *pathPtr, + Tcl_LoadHandle *handlePtr, Tcl_FSUnloadFileProc **unloadProcPtr); static Tcl_FSLinkProc TestReportLink; static Tcl_FSFileAttrStringsProc TestReportFileAttrStrings; static Tcl_FSFileAttrsGetProc TestReportFileAttrsGet; @@ -419,6 +414,11 @@ static int TestNRELevels(ClientData clientData, static int TestInterpResolverCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); +#if defined(HAVE_CPUID) || defined(_WIN32) +static int TestcpuidCmd(ClientData dummy, + Tcl_Interp* interp, int objc, + Tcl_Obj *const objv[]); +#endif static const Tcl_Filesystem testReportingFilesystem = { "reporting", @@ -449,7 +449,7 @@ static const Tcl_Filesystem testReportingFilesystem = { TestReportRenameFile, TestReportCopyDirectory, TestReportLstat, - TestReportLoadFile, + (Tcl_FSLoadFileProc *) TestReportLoadFile, NULL /* cwd */, TestReportChdir }; @@ -525,7 +525,9 @@ int Tcltest_Init( Tcl_Interp *interp) /* Interpreter for application. */ { +#ifndef TCL_NO_DEPRECATED Tcl_ValueType t3ArgTypes[2]; +#endif /* TCL_NO_DEPRECATED */ Tcl_Obj *listPtr; Tcl_Obj **objv; @@ -633,7 +635,6 @@ Tcltest_Init( Tcl_CreateObjCommand(interp, "testlocale", TestlocaleCmd, NULL, NULL); Tcl_CreateCommand(interp, "testpanic", TestpanicCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testfinexit", TestfinexitObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testparseargs", TestparseargsCmd,NULL,NULL); Tcl_CreateObjCommand(interp, "testparser", TestparserObjCmd, NULL, NULL); @@ -645,8 +646,10 @@ Tcltest_Init( NULL, NULL); Tcl_CreateObjCommand(interp, "testreturn", TestreturnObjCmd, NULL, NULL); +#ifndef TCL_NO_DEPRECATED Tcl_CreateObjCommand(interp, "testsaveresult", TestsaveresultCmd, NULL, NULL); +#endif /* TCL_NO_DEPRECATED */ Tcl_CreateCommand(interp, "testsetassocdata", TestsetassocdataCmd, NULL, NULL); Tcl_CreateCommand(interp, "testsetnoerr", TestsetCmd, @@ -668,18 +671,26 @@ Tcltest_Init( Tcl_CreateCommand(interp, "testtranslatefilename", TesttranslatefilenameCmd, NULL, NULL); Tcl_CreateCommand(interp, "testupvar", TestupvarCmd, NULL, NULL); +#ifndef TCL_NO_DEPRECATED Tcl_CreateMathFunc(interp, "T1", 0, NULL, TestMathFunc, (ClientData) 123); Tcl_CreateMathFunc(interp, "T2", 0, NULL, TestMathFunc, (ClientData) 345); +#endif /* TCL_NO_DEPRECATED */ Tcl_CreateCommand(interp, "testmainthread", TestmainthreadCmd, NULL, NULL); Tcl_CreateCommand(interp, "testsetmainloop", TestsetmainloopCmd, NULL, NULL); Tcl_CreateCommand(interp, "testexitmainloop", TestexitmainloopCmd, NULL, NULL); +#if defined(HAVE_CPUID) || defined(_WIN32) + Tcl_CreateObjCommand(interp, "testcpuid", TestcpuidCmd, + (ClientData) 0, NULL); +#endif +#ifndef TCL_NO_DEPRECATED t3ArgTypes[0] = TCL_EITHER; t3ArgTypes[1] = TCL_EITHER; Tcl_CreateMathFunc(interp, "T3", 2, t3ArgTypes, TestMathFunc2, NULL); +#endif /* TCL_NO_DEPRECATED */ Tcl_CreateObjCommand(interp, "testnrelevels", TestNRELevels, NULL, NULL); @@ -861,6 +872,7 @@ TestasyncCmd( || (Tcl_GetInt(interp, argv[4], &code) != TCL_OK)) { return TCL_ERROR; } + Tcl_MutexLock(&asyncTestMutex); for (asyncPtr = firstHandler; asyncPtr != NULL; asyncPtr = asyncPtr->nextPtr) { if (asyncPtr->id == id) { @@ -869,6 +881,7 @@ TestasyncCmd( } } Tcl_SetObjResult(interp, Tcl_NewStringObj(argv[3], -1)); + Tcl_MutexUnlock(&asyncTestMutex); return code; #ifdef TCL_THREADS } else if (strcmp(argv[1], "marklater") == 0) { @@ -878,6 +891,7 @@ TestasyncCmd( if (Tcl_GetInt(interp, argv[2], &id) != TCL_OK) { return TCL_ERROR; } + Tcl_MutexLock(&asyncTestMutex); for (asyncPtr = firstHandler; asyncPtr != NULL; asyncPtr = asyncPtr->nextPtr) { if (asyncPtr->id == id) { @@ -886,11 +900,13 @@ TestasyncCmd( INT2PTR(id), TCL_THREAD_STACK_DEFAULT, TCL_THREAD_NOFLAGS) != TCL_OK) { Tcl_SetResult(interp, "can't create thread", TCL_STATIC); + Tcl_MutexUnlock(&asyncTestMutex); return TCL_ERROR; } break; } } + Tcl_MutexUnlock(&asyncTestMutex); } else { Tcl_AppendResult(interp, "bad option \"", argv[1], "\": must be create, delete, int, mark, or marklater", NULL); @@ -1539,14 +1555,14 @@ DelCallbackProc( * * TestdelCmd -- * - * This procedure implements the "testdcall" command. It is used - * to test Tcl_CallWhenDeleted. + * This procedure implements the "testdel" command. It is used + * to test calling of command deletion callbacks. * * Results: * A standard Tcl result. * * Side effects: - * Creates and deletes interpreters. + * Creates a command. * *---------------------------------------------------------------------- */ @@ -1840,7 +1856,7 @@ TestdstringCmd( if (Tcl_GetInt(interp, argv[2], &count) != TCL_OK) { return TCL_ERROR; } - Tcl_DStringTrunc(&dstring, count); + Tcl_DStringSetLength(&dstring, count); } else if (strcmp(argv[1], "start") == 0) { if (argc != 2) { goto wrongNumArgs; @@ -3262,7 +3278,7 @@ TestlocaleCmd( "ctype", "numeric", "time", "collate", "monetary", "all", NULL }; - static int lcTypes[] = { + static const int lcTypes[] = { LC_CTYPE, LC_NUMERIC, LC_TIME, LC_COLLATE, LC_MONETARY, LC_ALL }; @@ -4392,8 +4408,26 @@ TestseterrorcodeCmd( Tcl_SetResult(interp, "too many args", TCL_STATIC); return TCL_ERROR; } - Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], argv[4], - argv[5], NULL); + switch (argc) { + case 1: + Tcl_SetErrorCode(interp, "NONE", NULL); + break; + case 2: + Tcl_SetErrorCode(interp, argv[1], NULL); + break; + case 3: + Tcl_SetErrorCode(interp, argv[1], argv[2], NULL); + break; + case 4: + Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], NULL); + break; + case 5: + Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], argv[4], NULL); + break; + case 6: + Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], argv[4], + argv[5], NULL); + } return TCL_ERROR; } @@ -4538,47 +4572,6 @@ TestpanicCmd( return TCL_OK; } -/* - *---------------------------------------------------------------------- - * - * TestfinexitObjCmd -- - * - * Calls a variant of [exit] including the full finalization path. - * - * Results: - * Error, or doesn't return. - * - * Side effects: - * Exits application. - * - *---------------------------------------------------------------------- - */ - -static int -TestfinexitObjCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - int value; - - if ((objc != 1) && (objc != 2)) { - Tcl_WrongNumArgs(interp, 1, objv, "?returnCode?"); - return TCL_ERROR; - } - - if (objc == 1) { - value = 0; - } else if (Tcl_GetIntFromObj(interp, objv[1], &value) != TCL_OK) { - return TCL_ERROR; - } - Tcl_Finalize(); - TclpExit(value); - /*NOTREACHED*/ - return TCL_ERROR; /* Better not ever reach this! */ -} - static int TestfileCmd( ClientData dummy, /* Not used. */ @@ -5038,6 +5031,7 @@ Testset2Cmd( } } +#ifndef TCL_NO_DEPRECATED /* *---------------------------------------------------------------------- * @@ -5171,6 +5165,7 @@ TestsaveresultFree( { freeCount++; } +#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -6205,7 +6200,7 @@ TestReport( * API, but there you go. We should convert it to objects. */ - Tcl_SavedResult savedResult; + Tcl_Obj *savedResult; Tcl_DString ds; Tcl_DStringInit(&ds); @@ -6219,11 +6214,15 @@ TestReport( Tcl_DStringAppendElement(&ds, Tcl_GetString(arg2)); } Tcl_DStringEndSublist(&ds); - Tcl_SaveResult(interp, &savedResult); + savedResult = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(savedResult); + Tcl_SetObjResult(interp, Tcl_NewObj()); Tcl_Eval(interp, Tcl_DStringValue(&ds)); Tcl_DStringFree(&ds); - Tcl_RestoreResult(interp, &savedResult); - } + Tcl_ResetResult(interp); + Tcl_SetObjResult(interp, savedResult); + Tcl_DecrRefCount(savedResult); + } } static int @@ -6648,6 +6647,62 @@ TestNumUtfCharsCmd( } return TCL_OK; } + +#if defined(HAVE_CPUID) || defined(_WIN32) +/* + *---------------------------------------------------------------------- + * + * TestcpuidCmd -- + * + * Retrieves CPU ID information. + * + * Usage: + * testwincpuid <eax> + * + * Parameters: + * eax - The value to pass in the EAX register to a CPUID instruction. + * + * Results: + * Returns a four-element list containing the values from the EAX, EBX, + * ECX and EDX registers returned from the CPUID instruction. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestcpuidCmd( + ClientData dummy, + Tcl_Interp* interp, /* Tcl interpreter */ + int objc, /* Parameter count */ + Tcl_Obj *const * objv) /* Parameter vector */ +{ + int status, index, i; + unsigned int regs[4]; + Tcl_Obj *regsObjs[4]; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "eax"); + return TCL_ERROR; + } + if (Tcl_GetIntFromObj(interp, objv[1], &index) != TCL_OK) { + return TCL_ERROR; + } + status = TclWinCPUID((unsigned) index, regs); + if (status != TCL_OK) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("operation not available", -1)); + return status; + } + for (i=0 ; i<4 ; ++i) { + regsObjs[i] = Tcl_NewIntObj((int) regs[i]); + } + Tcl_SetObjResult(interp, Tcl_NewListObj(4, regsObjs)); + return TCL_OK; +} +#endif /* * Used to do basic checks of the TCL_HASH_KEY_SYSTEM_HASH flag |