/* * 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.28 2010/10/11 12:11:53 nijtmans Exp $ */ #ifndef USE_TCL_STUBS # define USE_TCL_STUBS #endif #include "tclInt.h" /* * For TestplatformChmod on Windows */ #ifdef __WIN32__ #include #endif /* * MinGW 3.4.2 does not define this. */ #ifndef INHERITED_ACE #define INHERITED_ACE (0x10) #endif /* * Forward declarations of functions defined later in this file: */ static int TesteventloopCmd(ClientData dummy, Tcl_Interp *interp, int argc, const 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[]); static int TestplatformChmod(const char *nativePath, int pmode); static int TestchmodCmd(ClientData dummy, Tcl_Interp *interp, int argc, const char **argv); /* *---------------------------------------------------------------------- * * 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, "testchmod", TestchmodCmd, NULL, NULL); Tcl_CreateCommand(interp, "testeventloop", TesteventloopCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testvolumetype", TestvolumetypeCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testwinclock", TestwinclockCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testwincpuid", TestwincpuidCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testwinsleep", TestwinsleepCmd, NULL, 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. */ const 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, done; 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) { MSG msg; if (!GetMessage(&msg, NULL, 0, 0)) { /* * The application is exiting, so repost the quit message and * start unwinding. */ PostQuitMessage((int) 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]; const 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 */ { static const 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 * * 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, 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; } /* *---------------------------------------------------------------------- * * TestwinsleepCmd -- * * Causes this process to wait for the given number of milliseconds by * means of a direct call to Sleep. * * Usage: * testwinsleep * * 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 * * 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 const char *const 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, ""); 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; } static int TestplatformChmod( const char *nativePath, int pmode) { static const SECURITY_INFORMATION infoBits = OWNER_SECURITY_INFORMATION | GROUP_SECURITY_INFORMATION | DACL_SECURITY_INFORMATION; static const DWORD readOnlyMask = FILE_DELETE_CHILD | FILE_ADD_FILE | FILE_ADD_SUBDIRECTORY | FILE_WRITE_EA | FILE_APPEND_DATA | FILE_WRITE_DATA | DELETE; /* * References to security functions (only available on NT and later). */ const BOOL set_readOnly = !(pmode & 0222); BOOL acl_readOnly_found = FALSE, curAclPresent, curAclDefaulted; SID_IDENTIFIER_AUTHORITY userSidAuthority = { SECURITY_WORLD_SID_AUTHORITY }; BYTE *secDesc = 0; DWORD secDescLen, attr, newAclSize; ACL_SIZE_INFORMATION ACLSize; PACL curAcl, newAcl = 0; WORD j; SID *userSid = 0; char *userDomain = 0; int res = 0; /* * One time initialization, dynamically load Windows NT features */ /* * Process the chmod request. */ attr = GetFileAttributesA(nativePath); /* * nativePath not found */ if (attr == 0xffffffff) { res = -1; goto done; } /* * If nativePath is not a directory, there is no special handling. */ if (!(attr & FILE_ATTRIBUTE_DIRECTORY)) { goto done; } /* * Set the result to error, if the ACL change is successful it will be * reset to 0. */ res = -1; /* * Read the security descriptor for the directory. Note the first call * obtains the size of the security descriptor. */ if (!GetFileSecurityA(nativePath, infoBits, NULL, 0, &secDescLen)) { DWORD secDescLen2 = 0; if (GetLastError() != ERROR_INSUFFICIENT_BUFFER) { goto done; } secDesc = (BYTE *) ckalloc(secDescLen); if (!GetFileSecurityA(nativePath, infoBits, (PSECURITY_DESCRIPTOR) secDesc, secDescLen, &secDescLen2) || (secDescLen < secDescLen2)) { goto done; } } /* * Get the World SID. */ userSid = (SID *) ckalloc(GetSidLengthRequired((UCHAR) 1)); InitializeSid(userSid, &userSidAuthority, (BYTE) 1); *(GetSidSubAuthority(userSid, 0)) = SECURITY_WORLD_RID; /* * If curAclPresent == false then curAcl and curAclDefaulted not valid. */ if (!GetSecurityDescriptorDacl((PSECURITY_DESCRIPTOR) secDesc, &curAclPresent, &curAcl, &curAclDefaulted)) { goto done; } if (!curAclPresent || !curAcl) { ACLSize.AclBytesInUse = 0; ACLSize.AceCount = 0; } else if (!GetAclInformation(curAcl, &ACLSize, sizeof(ACLSize), AclSizeInformation)) { goto done; } /* * Allocate memory for the new ACL. */ newAclSize = ACLSize.AclBytesInUse + sizeof(ACCESS_DENIED_ACE) + GetLengthSid(userSid) - sizeof(DWORD); newAcl = (ACL *) ckalloc(newAclSize); /* * Initialize the new ACL. */ if (!InitializeAcl(newAcl, newAclSize, ACL_REVISION)) { goto done; } /* * Add denied to make readonly, this will be known as a "read-only tag". */ if (set_readOnly && !AddAccessDeniedAce(newAcl, ACL_REVISION, readOnlyMask, userSid)) { goto done; } acl_readOnly_found = FALSE; for (j = 0; j < ACLSize.AceCount; j++) { LPVOID pACE2; ACE_HEADER *phACE2; if (!GetAce(curAcl, j, &pACE2)) { goto done; } phACE2 = (ACE_HEADER *) pACE2; /* * Do NOT propagate inherited ACEs. */ if (phACE2->AceFlags & INHERITED_ACE) { continue; } /* * Skip the "read-only tag" restriction (either added above, or it is * being removed). */ if (phACE2->AceType == ACCESS_DENIED_ACE_TYPE) { ACCESS_DENIED_ACE *pACEd = (ACCESS_DENIED_ACE *) phACE2; if (pACEd->Mask == readOnlyMask && EqualSid(userSid, (PSID) &pACEd->SidStart)) { acl_readOnly_found = TRUE; continue; } } /* * Copy the current ACE from the old to the new ACL. */ if (!AddAce(newAcl, ACL_REVISION, MAXDWORD, (PACL *) pACE2, ((PACE_HEADER) pACE2)->AceSize)) { goto done; } } /* * Apply the new ACL. */ if (set_readOnly == acl_readOnly_found || SetNamedSecurityInfoA( (LPSTR) nativePath, SE_FILE_OBJECT, DACL_SECURITY_INFORMATION, NULL, NULL, newAcl, NULL) == ERROR_SUCCESS) { res = 0; } done: if (secDesc) { ckfree((char *) secDesc); } if (newAcl) { ckfree((char *) newAcl); } if (userSid) { ckfree((char *) userSid); } if (userDomain) { ckfree((char *) userDomain); } if (res != 0) { return res; } /* * Run normal chmod command. */ return chmod(nativePath, pmode); } /* *--------------------------------------------------------------------------- * * TestchmodCmd -- * * Implements the "testchmod" cmd. Used when testing "file" command. The * only attribute used by the Windows platform is the user write flag; if * this is not set, the file is made read-only. Otherwise, the file is * made read-write. * * Results: * A standard Tcl result. * * Side effects: * Changes permissions of specified files. * *--------------------------------------------------------------------------- */ static int TestchmodCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { int i, mode; char *rest; if (argc < 2) { usage: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " mode file ?file ...?", NULL); return TCL_ERROR; } mode = (int) strtol(argv[1], &rest, 8); if ((rest == argv[1]) || (*rest != '\0')) { goto usage; } for (i = 2; i < argc; i++) { Tcl_DString buffer; const char *translated; translated = Tcl_TranslateFileName(interp, argv[i], &buffer); if (translated == NULL) { return TCL_ERROR; } if (TestplatformChmod(translated, mode) != 0) { Tcl_AppendResult(interp, translated, ": ", Tcl_PosixError(interp), NULL); return TCL_ERROR; } Tcl_DStringFree(&buffer); } return TCL_OK; } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */