/*
* tclWinTest.c --
*
* Contains commands for platform specific tests on Windows.
*
* Copyright (c) 1996 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* RCS: @(#) $Id: tclWinTest.c,v 1.12 2005/11/04 00:06:51 dkf Exp $
*/
#define USE_COMPAT_CONST
#include "tclInt.h"
/*
* Forward declarations of functions defined later in this file:
*/
int TclplatformtestInit(Tcl_Interp *interp);
static int TesteventloopCmd(ClientData dummy, Tcl_Interp *interp,
int argc, char **argv);
static int TestvolumetypeCmd(ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]);
static int TestwinclockCmd(ClientData dummy, Tcl_Interp* interp,
int objc, Tcl_Obj *CONST objv[]);
static int TestwinsleepCmd(ClientData dummy, Tcl_Interp* interp,
int objc, Tcl_Obj *CONST objv[]);
static Tcl_ObjCmdProc TestExceptionCmd;
static int TestwincpuidCmd(ClientData dummy, Tcl_Interp* interp,
int objc, Tcl_Obj *CONST objv[]);
/*
*----------------------------------------------------------------------
*
* TclplatformtestInit --
*
* Defines commands that test platform specific functionality for Windows
* platforms.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Defines new commands.
*
*----------------------------------------------------------------------
*/
int
TclplatformtestInit(
Tcl_Interp *interp) /* Interpreter to add commands to. */
{
/*
* Add commands for platform specific tests for Windows here.
*/
Tcl_CreateCommand(interp, "testeventloop", TesteventloopCmd,
(ClientData) 0, NULL);
Tcl_CreateObjCommand(interp, "testvolumetype", TestvolumetypeCmd,
(ClientData) 0, NULL);
Tcl_CreateObjCommand(interp, "testwinclock", TestwinclockCmd,
(ClientData) 0, NULL);
Tcl_CreateObjCommand(interp, "testwincpuid", TestwincpuidCmd,
(ClientData) 0, NULL);
Tcl_CreateObjCommand(interp, "testwinsleep", TestwinsleepCmd,
(ClientData) 0, NULL);
Tcl_CreateObjCommand(interp, "testexcept", TestExceptionCmd, NULL, NULL);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TesteventloopCmd --
*
* This function implements the "testeventloop" command. It is used to
* test the Tcl notifier from an "external" event loop (i.e. not
* Tcl_DoOneEvent()).
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
TesteventloopCmd(
ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
char **argv) /* Argument strings. */
{
static int *framePtr = NULL;/* Pointer to integer on stack frame of
* innermost invocation of the "wait"
* subcommand. */
if (argc < 2) {
Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
" option ... \"", NULL);
return TCL_ERROR;
}
if (strcmp(argv[1], "done") == 0) {
*framePtr = 1;
} else if (strcmp(argv[1], "wait") == 0) {
int *oldFramePtr;
int done;
MSG msg;
int oldMode = Tcl_SetServiceMode(TCL_SERVICE_ALL);
/*
* Save the old stack frame pointer and set up the current frame.
*/
oldFramePtr = framePtr;
framePtr = &done;
/*
* Enter a standard Windows event loop until the flag changes.
* Note that we do not explicitly call Tcl_ServiceEvent().
*/
done = 0;
while (!done) {
if (!GetMessage(&msg, NULL, 0, 0)) {
/*
* The application is exiting, so repost the quit message
* and start unwinding.
*/
PostQuitMessage(msg.wParam);
break;
}
TranslateMessage(&msg);
DispatchMessage(&msg);
}
(void) Tcl_SetServiceMode(oldMode);
framePtr = oldFramePtr;
} else {
Tcl_AppendResult(interp, "bad option \"", argv[1],
"\": must be done or wait", NULL);
return TCL_ERROR;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Testvolumetype --
*
* This function implements the "testvolumetype" command. It is used to
* check the volume type (FAT, NTFS) of a volume.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
TestvolumetypeCmd(
ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *CONST objv[]) /* Argument objects. */
{
#define VOL_BUF_SIZE 32
int found;
char volType[VOL_BUF_SIZE];
char *path;
if (objc > 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?name?");
return TCL_ERROR;
}
if (objc == 2) {
/*
* path has to be really a proper volume, but we don't
* get query APIs for that until NT5
*/
path = Tcl_GetString(objv[1]);
} else {
path = NULL;
}
found = GetVolumeInformationA(path, NULL, 0, NULL, NULL,
NULL, volType, VOL_BUF_SIZE);
if (found == 0) {
Tcl_AppendResult(interp, "could not get volume type for \"",
(path?path:""), "\"", NULL);
TclWinConvertError(GetLastError());
return TCL_ERROR;
}
Tcl_SetResult(interp, volType, TCL_VOLATILE);
return TCL_OK;
#undef VOL_BUF_SIZE
}
/*
*----------------------------------------------------------------------
*
* TestwinclockCmd --
*
* Command that returns the seconds and microseconds portions of
* the system clock and of the Tcl clock so that they can be
* compared to validate that the Tcl clock is staying in sync.
*
* Usage:
* testclock
*
* Parameters:
* None.
*
* Results:
* Returns a standard Tcl result comprising a four-element list:
* the seconds and microseconds portions of the system clock,
* and the seconds and microseconds portions of the Tcl clock.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
TestwinclockCmd(
ClientData dummy, /* Unused */
Tcl_Interp* interp, /* Tcl interpreter */
int objc, /* Argument count */
Tcl_Obj *CONST objv[]) /* Argument vector */
{
CONST static FILETIME posixEpoch = { 0xD53E8000, 0x019DB1DE };
/* The Posix epoch, expressed as a Windows
* FILETIME */
Tcl_Time tclTime; /* Tcl clock */
FILETIME sysTime; /* System clock */
Tcl_Obj* result; /* Result of the command */
LARGE_INTEGER t1, t2;
LARGE_INTEGER p1, p2;
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1, objv, "");
return TCL_ERROR;
}
QueryPerformanceCounter(&p1);
Tcl_GetTime(&tclTime);
GetSystemTimeAsFileTime(&sysTime);
t1.LowPart = posixEpoch.dwLowDateTime;
t1.HighPart = posixEpoch.dwHighDateTime;
t2.LowPart = sysTime.dwLowDateTime;
t2.HighPart = sysTime.dwHighDateTime;
t2.QuadPart -= t1.QuadPart;
QueryPerformanceCounter(&p2);
result = Tcl_NewObj();
Tcl_ListObjAppendElement(interp, result,
Tcl_NewIntObj((int) (t2.QuadPart / 10000000)));
Tcl_ListObjAppendElement(interp, result,
Tcl_NewIntObj((int) ((t2.QuadPart / 10) % 1000000)));
Tcl_ListObjAppendElement(interp, result, Tcl_NewIntObj(tclTime.sec));
Tcl_ListObjAppendElement(interp, result, Tcl_NewIntObj(tclTime.usec));
Tcl_ListObjAppendElement(interp, result, Tcl_NewWideIntObj(p1.QuadPart));
Tcl_ListObjAppendElement(interp, result, Tcl_NewWideIntObj(p2.QuadPart));
Tcl_SetObjResult(interp, result);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestwincpuidCmd --
*
* 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
TestwincpuidCmd(
ClientData dummy,
Tcl_Interp* interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *CONST * objv) /* Parameter vector */
{
int status;
int index;
unsigned int regs[4];
Tcl_Obj * regsObjs[4];
int i;
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 int) 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;
}
/*
*----------------------------------------------------------------------
*
* TestwinsleepCmd --
*
* Causes this process to wait for the given number of milliseconds by
* means of a direct call to Sleep.
*
* Usage:
* testwinsleep <n>
*
* Parameters:
* n - the number of milliseconds to sleep
*
* Results:
* None.
*
* Side effects:
* Sleeps for the requisite number of milliseconds.
*
*----------------------------------------------------------------------
*/
static int
TestwinsleepCmd(
ClientData clientData, /* Unused */
Tcl_Interp* interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj * CONST * objv) /* Parameter vector */
{
int ms;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "ms");
return TCL_ERROR;
}
if (Tcl_GetIntFromObj(interp, objv[1], &ms) != TCL_OK) {
return TCL_ERROR;
}
Sleep((DWORD) ms);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestExceptionCmd --
*
* Causes this process to end with the named exception. Used for testing
* Tcl_WaitPid().
*
* Usage:
* testexcept <type>
*
* Parameters:
* Type of exception.
*
* Results:
* None, this process closes now and doesn't return.
*
* Side effects:
* This Tcl process closes, hard... Bang!
*
*----------------------------------------------------------------------
*/
static int
TestExceptionCmd(
ClientData dummy, /* Unused */
Tcl_Interp* interp, /* Tcl interpreter */
int objc, /* Argument count */
Tcl_Obj *CONST objv[]) /* Argument vector */
{
static char *cmds[] = {
"access_violation",
"datatype_misalignment",
"array_bounds",
"float_denormal",
"float_divbyzero",
"float_inexact",
"float_invalidop",
"float_overflow",
"float_stack",
"float_underflow",
"int_divbyzero",
"int_overflow",
"private_instruction",
"inpageerror",
"illegal_instruction",
"noncontinue",
"stack_overflow",
"invalid_disp",
"guard_page",
"invalid_handle",
"ctrl+c",
NULL
};
static DWORD exceptions[] = {
EXCEPTION_ACCESS_VIOLATION,
EXCEPTION_DATATYPE_MISALIGNMENT,
EXCEPTION_ARRAY_BOUNDS_EXCEEDED,
EXCEPTION_FLT_DENORMAL_OPERAND,
EXCEPTION_FLT_DIVIDE_BY_ZERO,
EXCEPTION_FLT_INEXACT_RESULT,
EXCEPTION_FLT_INVALID_OPERATION,
EXCEPTION_FLT_OVERFLOW,
EXCEPTION_FLT_STACK_CHECK,
EXCEPTION_FLT_UNDERFLOW,
EXCEPTION_INT_DIVIDE_BY_ZERO,
EXCEPTION_INT_OVERFLOW,
EXCEPTION_PRIV_INSTRUCTION,
EXCEPTION_IN_PAGE_ERROR,
EXCEPTION_ILLEGAL_INSTRUCTION,
EXCEPTION_NONCONTINUABLE_EXCEPTION,
EXCEPTION_STACK_OVERFLOW,
EXCEPTION_INVALID_DISPOSITION,
EXCEPTION_GUARD_PAGE,
EXCEPTION_INVALID_HANDLE,
CONTROL_C_EXIT
};
int cmd;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 0, objv, "<type-of-exception>");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], cmds, "command", 0,
&cmd) != TCL_OK) {
return TCL_ERROR;
}
/*
* Make sure the GPF dialog doesn't popup.
*/
SetErrorMode(SEM_FAILCRITICALERRORS | SEM_NOGPFAULTERRORBOX);
/*
* As Tcl does not handle structured exceptions, this falls all the way
* back up the instruction stack to the C run-time portion that called
* main() where the process will now be terminated with this exception
* code by the default handler the C run-time provides.
*/
/* SMASH! */
RaiseException(exceptions[cmd], EXCEPTION_NONCONTINUABLE, 0, NULL);
/* NOTREACHED */
return TCL_OK;
}