sl@0: /* 
sl@0:  * tclWinTest.c --
sl@0:  *
sl@0:  *	Contains commands for platform specific tests on Windows.
sl@0:  *
sl@0:  * Copyright (c) 1996 Sun Microsystems, Inc.
sl@0:  *
sl@0:  * See the file "license.terms" for information on usage and redistribution
sl@0:  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
sl@0:  *
sl@0:  * RCS: @(#) $Id: tclWinTest.c,v 1.8.2.6 2006/03/27 23:30:54 patthoyts Exp $
sl@0:  */
sl@0: 
sl@0: #define USE_COMPAT_CONST
sl@0: #include "tclWinInt.h"
sl@0: 
sl@0: /*
sl@0:  * For TestplatformChmod on Windows
sl@0:  */
sl@0: #ifdef __WIN32__
sl@0: #include <aclapi.h>
sl@0: #endif
sl@0: 
sl@0: /*
sl@0:  * MinGW 3.4.2 does not define this.
sl@0:  */
sl@0: #ifndef INHERITED_ACE
sl@0: #define INHERITED_ACE (0x10)
sl@0: #endif
sl@0: 
sl@0: /*
sl@0:  * Forward declarations of procedures defined later in this file:
sl@0:  */
sl@0: int		TclplatformtestInit _ANSI_ARGS_((Tcl_Interp *interp));
sl@0: static int	TesteventloopCmd _ANSI_ARGS_((ClientData dummy,
sl@0: 	Tcl_Interp *interp, int argc, CONST84 char **argv));
sl@0: static int	TestvolumetypeCmd _ANSI_ARGS_((ClientData dummy,
sl@0: 	Tcl_Interp *interp, int objc,
sl@0: 	Tcl_Obj *CONST objv[]));
sl@0: static int      TestwinclockCmd _ANSI_ARGS_(( ClientData dummy,
sl@0: 					      Tcl_Interp* interp,
sl@0: 					      int objc,
sl@0: 					      Tcl_Obj *CONST objv[] ));
sl@0: static int      TestwinsleepCmd _ANSI_ARGS_(( ClientData dummy,
sl@0: 					      Tcl_Interp* interp,
sl@0: 					      int objc,
sl@0: 					      Tcl_Obj *CONST objv[] ));
sl@0: static Tcl_ObjCmdProc TestExceptionCmd;
sl@0: static int	TestwincpuidCmd _ANSI_ARGS_(( ClientData dummy,
sl@0: 					      Tcl_Interp* interp,
sl@0: 					      int objc,
sl@0: 					      Tcl_Obj *CONST objv[] ));
sl@0: static int	TestplatformChmod _ANSI_ARGS_((CONST char *nativePath, 
sl@0: 						 int pmode));
sl@0: static int	TestchmodCmd _ANSI_ARGS_((ClientData dummy,
sl@0: 		  Tcl_Interp *interp, int argc, CONST84 char **argv));
sl@0: 
sl@0: 
sl@0: /*
sl@0:  *----------------------------------------------------------------------
sl@0:  *
sl@0:  * TclplatformtestInit --
sl@0:  *
sl@0:  *	Defines commands that test platform specific functionality for
sl@0:  *	Windows platforms.
sl@0:  *
sl@0:  * Results:
sl@0:  *	A standard Tcl result.
sl@0:  *
sl@0:  * Side effects:
sl@0:  *	Defines new commands.
sl@0:  *
sl@0:  *----------------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: int
sl@0: TclplatformtestInit(interp)
sl@0:     Tcl_Interp *interp;		/* Interpreter to add commands to. */
sl@0: {
sl@0:     /*
sl@0:      * Add commands for platform specific tests for Windows here.
sl@0:      */
sl@0: 
sl@0:     Tcl_CreateCommand(interp, "testchmod", TestchmodCmd,
sl@0: 		      (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
sl@0:     Tcl_CreateCommand(interp, "testeventloop", TesteventloopCmd,
sl@0: 		      (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
sl@0:     Tcl_CreateObjCommand(interp, "testvolumetype", TestvolumetypeCmd,
sl@0: 			 (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
sl@0:     Tcl_CreateObjCommand(interp, "testwinclock", TestwinclockCmd,
sl@0: 			 (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
sl@0:     Tcl_CreateObjCommand(interp, "testwincpuid", TestwincpuidCmd,
sl@0: 			 (ClientData) 0, (Tcl_CmdDeleteProc*) NULL );
sl@0:     Tcl_CreateObjCommand(interp, "testwinsleep", TestwinsleepCmd,
sl@0: 			 (ClientData) 0, (Tcl_CmdDeleteProc *) NULL );
sl@0:     Tcl_CreateObjCommand(interp, "testexcept", TestExceptionCmd,
sl@0: 			 (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
sl@0:     return TCL_OK;
sl@0: }
sl@0: 
sl@0: /*
sl@0:  *----------------------------------------------------------------------
sl@0:  *
sl@0:  * TesteventloopCmd --
sl@0:  *
sl@0:  *	This procedure implements the "testeventloop" command. It is
sl@0:  *	used to test the Tcl notifier from an "external" event loop
sl@0:  *	(i.e. not Tcl_DoOneEvent()).
sl@0:  *
sl@0:  * Results:
sl@0:  *	A standard Tcl result.
sl@0:  *
sl@0:  * Side effects:
sl@0:  *	None.
sl@0:  *
sl@0:  *----------------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: static int
sl@0: TesteventloopCmd(clientData, interp, argc, argv)
sl@0:     ClientData clientData;		/* Not used. */
sl@0:     Tcl_Interp *interp;			/* Current interpreter. */
sl@0:     int argc;				/* Number of arguments. */
sl@0:     CONST84 char **argv;		/* Argument strings. */
sl@0: {
sl@0:     static int *framePtr = NULL; /* Pointer to integer on stack frame of
sl@0: 				  * innermost invocation of the "wait"
sl@0: 				  * subcommand. */
sl@0: 
sl@0:    if (argc < 2) {
sl@0: 	Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
sl@0:                 " option ... \"", (char *) NULL);
sl@0:         return TCL_ERROR;
sl@0:     }
sl@0:     if (strcmp(argv[1], "done") == 0) {
sl@0: 	*framePtr = 1;
sl@0:     } else if (strcmp(argv[1], "wait") == 0) {
sl@0: 	int *oldFramePtr;
sl@0: 	int done;
sl@0: 	MSG msg;
sl@0: 	int oldMode = Tcl_SetServiceMode(TCL_SERVICE_ALL);
sl@0: 
sl@0: 	/*
sl@0: 	 * Save the old stack frame pointer and set up the current frame.
sl@0: 	 */
sl@0: 
sl@0: 	oldFramePtr = framePtr;
sl@0: 	framePtr = &done;
sl@0: 
sl@0: 	/*
sl@0: 	 * Enter a standard Windows event loop until the flag changes.
sl@0: 	 * Note that we do not explicitly call Tcl_ServiceEvent().
sl@0: 	 */
sl@0: 
sl@0: 	done = 0;
sl@0: 	while (!done) {
sl@0: 	    if (!GetMessage(&msg, NULL, 0, 0)) {
sl@0: 		/*
sl@0: 		 * The application is exiting, so repost the quit message
sl@0: 		 * and start unwinding.
sl@0: 		 */
sl@0: 
sl@0: 		PostQuitMessage((int)msg.wParam);
sl@0: 		break;
sl@0: 	    }
sl@0: 	    TranslateMessage(&msg);
sl@0: 	    DispatchMessage(&msg);
sl@0: 	}
sl@0: 	(void) Tcl_SetServiceMode(oldMode);
sl@0: 	framePtr = oldFramePtr;
sl@0:     } else {
sl@0: 	Tcl_AppendResult(interp, "bad option \"", argv[1],
sl@0: 		"\": must be done or wait", (char *) NULL);
sl@0: 	return TCL_ERROR;
sl@0:     }
sl@0:     return TCL_OK;
sl@0: }
sl@0: 
sl@0: /*
sl@0:  *----------------------------------------------------------------------
sl@0:  *
sl@0:  * Testvolumetype --
sl@0:  *
sl@0:  *	This procedure implements the "testvolumetype" command. It is
sl@0:  *	used to check the volume type (FAT, NTFS) of a volume.
sl@0:  *
sl@0:  * Results:
sl@0:  *	A standard Tcl result.
sl@0:  *
sl@0:  * Side effects:
sl@0:  *	None.
sl@0:  *
sl@0:  *----------------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: static int
sl@0: TestvolumetypeCmd(clientData, interp, objc, objv)
sl@0:     ClientData clientData;		/* Not used. */
sl@0:     Tcl_Interp *interp;			/* Current interpreter. */
sl@0:     int objc;				/* Number of arguments. */
sl@0:     Tcl_Obj *CONST objv[];		/* Argument objects. */
sl@0: {
sl@0: #define VOL_BUF_SIZE 32
sl@0:     int found;
sl@0:     char volType[VOL_BUF_SIZE];
sl@0:     char *path;
sl@0: 
sl@0:     if (objc > 2) {
sl@0: 	Tcl_WrongNumArgs(interp, 1, objv, "?name?");
sl@0:         return TCL_ERROR;
sl@0:     }
sl@0:     if (objc == 2) {
sl@0: 	/*
sl@0: 	 * path has to be really a proper volume, but we don't
sl@0: 	 * get query APIs for that until NT5
sl@0: 	 */
sl@0: 	path = Tcl_GetString(objv[1]);
sl@0:     } else {
sl@0: 	path = NULL;
sl@0:     }
sl@0:     found = GetVolumeInformationA(path, NULL, 0, NULL, NULL, 
sl@0: 	    NULL, volType, VOL_BUF_SIZE);
sl@0: 
sl@0:     if (found == 0) {
sl@0: 	Tcl_AppendResult(interp, "could not get volume type for \"",
sl@0: 		(path?path:""), "\"", (char *) NULL);
sl@0: 	TclWinConvertError(GetLastError());
sl@0: 	return TCL_ERROR;
sl@0:     }
sl@0:     Tcl_SetResult(interp, volType, TCL_VOLATILE);
sl@0:     return TCL_OK;
sl@0: #undef VOL_BUF_SIZE
sl@0: }
sl@0: 
sl@0: /*
sl@0:  *----------------------------------------------------------------------
sl@0:  *
sl@0:  * TestwinclockCmd --
sl@0:  *
sl@0:  *	Command that returns the seconds and microseconds portions of
sl@0:  *	the system clock and of the Tcl clock so that they can be
sl@0:  *	compared to validate that the Tcl clock is staying in sync.
sl@0:  *
sl@0:  * Usage:
sl@0:  *	testclock
sl@0:  *
sl@0:  * Parameters:
sl@0:  *	None.
sl@0:  *
sl@0:  * Results:
sl@0:  *	Returns a standard Tcl result comprising a four-element list:
sl@0:  *	the seconds and microseconds portions of the system clock,
sl@0:  *	and the seconds and microseconds portions of the Tcl clock.
sl@0:  *
sl@0:  * Side effects:
sl@0:  *	None.
sl@0:  *
sl@0:  *----------------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: static int
sl@0: TestwinclockCmd( ClientData dummy,
sl@0: 				/* Unused */
sl@0: 		 Tcl_Interp* interp,
sl@0: 				/* Tcl interpreter */
sl@0: 		 int objc,
sl@0: 				/* Argument count */
sl@0: 		 Tcl_Obj *CONST objv[] )
sl@0: 				/* Argument vector */
sl@0: {
sl@0:     CONST static FILETIME posixEpoch = { 0xD53E8000, 0x019DB1DE };
sl@0: 				/* The Posix epoch, expressed as a
sl@0: 				 * Windows FILETIME */
sl@0:     Tcl_Time tclTime;		/* Tcl clock */
sl@0:     FILETIME sysTime;		/* System clock */
sl@0:     Tcl_Obj* result;		/* Result of the command */
sl@0:     LARGE_INTEGER t1, t2;
sl@0:     LARGE_INTEGER p1, p2;
sl@0: 
sl@0:     if ( objc != 1 ) {
sl@0: 	Tcl_WrongNumArgs( interp, 1, objv, "" );
sl@0: 	return TCL_ERROR;
sl@0:     }
sl@0: 
sl@0:     QueryPerformanceCounter( &p1 );
sl@0: 
sl@0:     Tcl_GetTime( &tclTime );
sl@0:     GetSystemTimeAsFileTime( &sysTime );
sl@0:     t1.LowPart = posixEpoch.dwLowDateTime;
sl@0:     t1.HighPart = posixEpoch.dwHighDateTime;
sl@0:     t2.LowPart = sysTime.dwLowDateTime;
sl@0:     t2.HighPart = sysTime.dwHighDateTime;
sl@0:     t2.QuadPart -= t1.QuadPart;
sl@0: 
sl@0:     QueryPerformanceCounter( &p2 );
sl@0: 
sl@0:     result = Tcl_NewObj();
sl@0:     Tcl_ListObjAppendElement
sl@0: 	( interp, result, Tcl_NewIntObj( (int) (t2.QuadPart / 10000000 ) ) );
sl@0:     Tcl_ListObjAppendElement
sl@0: 	( interp, result,
sl@0: 	  Tcl_NewIntObj( (int) ( (t2.QuadPart / 10 ) % 1000000 ) ) );
sl@0:     Tcl_ListObjAppendElement( interp, result, Tcl_NewIntObj( tclTime.sec ) );
sl@0:     Tcl_ListObjAppendElement( interp, result, Tcl_NewIntObj( tclTime.usec ) );
sl@0: 
sl@0:     Tcl_ListObjAppendElement( interp, result, Tcl_NewWideIntObj( p1.QuadPart ) );
sl@0:     Tcl_ListObjAppendElement( interp, result, Tcl_NewWideIntObj( p2.QuadPart ) );
sl@0: 
sl@0:     Tcl_SetObjResult( interp, result );
sl@0: 
sl@0:     return TCL_OK;
sl@0: }
sl@0: 
sl@0: /*
sl@0:  *----------------------------------------------------------------------
sl@0:  *
sl@0:  * TestwincpuidCmd --
sl@0:  *
sl@0:  *	Retrieves CPU ID information.
sl@0:  *
sl@0:  * Usage:
sl@0:  *	testwincpuid <eax>
sl@0:  *
sl@0:  * Parameters:
sl@0:  *	eax - The value to pass in the EAX register to a CPUID instruction.
sl@0:  *
sl@0:  * Results:
sl@0:  *	Returns a four-element list containing the values from the
sl@0:  *	EAX, EBX, ECX and EDX registers returned from the CPUID instruction.
sl@0:  *
sl@0:  * Side effects:
sl@0:  *	None.
sl@0:  *
sl@0:  *----------------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: static int
sl@0: TestwincpuidCmd( ClientData dummy,
sl@0: 		 Tcl_Interp* interp, /* Tcl interpreter */
sl@0: 		 int objc,	/* Parameter count */
sl@0: 		 Tcl_Obj *CONST * objv ) /* Parameter vector */
sl@0: {
sl@0:     int status;
sl@0:     int index;
sl@0:     unsigned int regs[4];
sl@0:     Tcl_Obj * regsObjs[4];
sl@0:     int i;
sl@0: 
sl@0:     if ( objc != 2 ) {
sl@0: 	Tcl_WrongNumArgs( interp, 1, objv, "eax" );
sl@0: 	return TCL_ERROR;
sl@0:     }
sl@0:     if ( Tcl_GetIntFromObj( interp, objv[1], &index ) != TCL_OK ) {
sl@0: 	return TCL_ERROR;
sl@0:     }
sl@0:     status = TclWinCPUID( (unsigned int) index, regs );
sl@0:     if ( status != TCL_OK ) {
sl@0: 	Tcl_SetObjResult( interp, Tcl_NewStringObj( "operation not available", 
sl@0: 						    -1 ) );
sl@0: 	return status;
sl@0:     }
sl@0:     for ( i = 0; i < 4; ++i ) {
sl@0: 	regsObjs[i] = Tcl_NewIntObj( (int) regs[i] );
sl@0:     }
sl@0:     Tcl_SetObjResult( interp, Tcl_NewListObj( 4, regsObjs ) );
sl@0:     return TCL_OK;
sl@0:        
sl@0: }
sl@0: 
sl@0: /*
sl@0:  *----------------------------------------------------------------------
sl@0:  *
sl@0:  * TestwinsleepCmd --
sl@0:  *
sl@0:  *	Causes this process to wait for the given number of milliseconds
sl@0:  *	by means of a direct call to Sleep.
sl@0:  *
sl@0:  * Usage:
sl@0:  *	testwinsleep <n>
sl@0:  *
sl@0:  * Parameters:
sl@0:  *	n - the number of milliseconds to sleep
sl@0:  *
sl@0:  * Results:
sl@0:  *	None.
sl@0:  *
sl@0:  * Side effects:
sl@0:  *	Sleeps for the requisite number of milliseconds.
sl@0:  *
sl@0:  *----------------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: static int
sl@0: TestwinsleepCmd( ClientData clientData,
sl@0: 				/* Unused */
sl@0: 		 Tcl_Interp* interp,
sl@0: 				/* Tcl interpreter */
sl@0: 		 int objc,
sl@0: 				/* Parameter count */
sl@0: 		 Tcl_Obj * CONST * objv )
sl@0: 				/* Parameter vector */
sl@0: {
sl@0:     int ms;
sl@0:     if ( objc != 2 ) {
sl@0: 	Tcl_WrongNumArgs( interp, 1, objv, "ms" );
sl@0: 	return TCL_ERROR;
sl@0:     }
sl@0:     if ( Tcl_GetIntFromObj( interp, objv[1], &ms ) != TCL_OK ) {
sl@0: 	return TCL_ERROR;
sl@0:     }
sl@0:     Sleep( (DWORD) ms );
sl@0:     return TCL_OK;
sl@0: }
sl@0: 
sl@0: /*
sl@0:  *----------------------------------------------------------------------
sl@0:  *
sl@0:  * TestExceptionCmd --
sl@0:  *
sl@0:  *	Causes this process to end with the named exception. Used for
sl@0:  *	testing Tcl_WaitPid().
sl@0:  *
sl@0:  * Usage:
sl@0:  *	testexcept <type>
sl@0:  *
sl@0:  * Parameters:
sl@0:  *	Type of exception.
sl@0:  *
sl@0:  * Results:
sl@0:  *	None, this process closes now and doesn't return.
sl@0:  *
sl@0:  * Side effects:
sl@0:  *	This Tcl process closes, hard... Bang!
sl@0:  *
sl@0:  *----------------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: static int
sl@0: TestExceptionCmd(
sl@0:     ClientData dummy,			/* Unused */
sl@0:     Tcl_Interp* interp,			/* Tcl interpreter */
sl@0:     int objc,				/* Argument count */
sl@0:     Tcl_Obj *CONST objv[])		/* Argument vector */
sl@0: {
sl@0:     static char *cmds[] = {
sl@0: 	    "access_violation",
sl@0: 	    "datatype_misalignment",
sl@0: 	    "array_bounds",
sl@0: 	    "float_denormal",
sl@0: 	    "float_divbyzero",
sl@0: 	    "float_inexact",
sl@0: 	    "float_invalidop",
sl@0: 	    "float_overflow",
sl@0: 	    "float_stack",
sl@0: 	    "float_underflow",
sl@0: 	    "int_divbyzero",
sl@0: 	    "int_overflow",
sl@0: 	    "private_instruction",
sl@0: 	    "inpageerror",
sl@0: 	    "illegal_instruction",
sl@0: 	    "noncontinue",
sl@0: 	    "stack_overflow",
sl@0: 	    "invalid_disp",
sl@0: 	    "guard_page",
sl@0: 	    "invalid_handle",
sl@0: 	    "ctrl+c",
sl@0: 	    NULL
sl@0:     };
sl@0:     static DWORD exceptions[] = {
sl@0: 	    EXCEPTION_ACCESS_VIOLATION,
sl@0: 	    EXCEPTION_DATATYPE_MISALIGNMENT,
sl@0: 	    EXCEPTION_ARRAY_BOUNDS_EXCEEDED,
sl@0: 	    EXCEPTION_FLT_DENORMAL_OPERAND,
sl@0: 	    EXCEPTION_FLT_DIVIDE_BY_ZERO,
sl@0: 	    EXCEPTION_FLT_INEXACT_RESULT,
sl@0: 	    EXCEPTION_FLT_INVALID_OPERATION,
sl@0: 	    EXCEPTION_FLT_OVERFLOW,
sl@0: 	    EXCEPTION_FLT_STACK_CHECK,
sl@0: 	    EXCEPTION_FLT_UNDERFLOW,
sl@0: 	    EXCEPTION_INT_DIVIDE_BY_ZERO,
sl@0: 	    EXCEPTION_INT_OVERFLOW,
sl@0: 	    EXCEPTION_PRIV_INSTRUCTION,
sl@0: 	    EXCEPTION_IN_PAGE_ERROR,
sl@0: 	    EXCEPTION_ILLEGAL_INSTRUCTION,
sl@0: 	    EXCEPTION_NONCONTINUABLE_EXCEPTION,
sl@0: 	    EXCEPTION_STACK_OVERFLOW,
sl@0: 	    EXCEPTION_INVALID_DISPOSITION,
sl@0: 	    EXCEPTION_GUARD_PAGE,
sl@0: 	    EXCEPTION_INVALID_HANDLE,
sl@0: 	    CONTROL_C_EXIT
sl@0:     };
sl@0:     int cmd;
sl@0: 
sl@0:     if ( objc != 2 ) {
sl@0: 	Tcl_WrongNumArgs(interp, 0, objv, "<type-of-exception>");
sl@0: 	return TCL_ERROR;
sl@0:     }
sl@0:     if (Tcl_GetIndexFromObj(interp, objv[1], cmds, "command", 0,
sl@0: 	    &cmd) != TCL_OK) {
sl@0: 	return TCL_ERROR;
sl@0:     }
sl@0: 
sl@0:     /*
sl@0:      * Make sure the GPF dialog doesn't popup.
sl@0:      */
sl@0: 
sl@0:     SetErrorMode(SEM_FAILCRITICALERRORS | SEM_NOGPFAULTERRORBOX);
sl@0: 
sl@0:     /*
sl@0:      * As Tcl does not handle structured exceptions, this falls all the way
sl@0:      * back up the instruction stack to the C run-time portion that called
sl@0:      * main() where the process will now be terminated with this exception
sl@0:      * code by the default handler the C run-time provides.
sl@0:      */
sl@0: 
sl@0:     /* SMASH! */
sl@0:     RaiseException(exceptions[cmd], EXCEPTION_NONCONTINUABLE, 0, NULL);
sl@0: 
sl@0:     /* NOTREACHED */
sl@0:     return TCL_OK;
sl@0: }
sl@0: 
sl@0: static int 
sl@0: TestplatformChmod(CONST char *nativePath, int pmode)
sl@0: {
sl@0:     SID_IDENTIFIER_AUTHORITY userSidAuthority =
sl@0:     { SECURITY_WORLD_SID_AUTHORITY };
sl@0: 
sl@0:     typedef DWORD (WINAPI *getSidLengthRequiredDef) ( UCHAR );
sl@0:     typedef BOOL (WINAPI *initializeSidDef) ( PSID,
sl@0:     PSID_IDENTIFIER_AUTHORITY, BYTE );
sl@0:     typedef PDWORD (WINAPI *getSidSubAuthorityDef) ( PSID, DWORD );
sl@0: 
sl@0:     static getSidLengthRequiredDef getSidLengthRequiredProc;
sl@0:     static initializeSidDef initializeSidProc;
sl@0:     static getSidSubAuthorityDef getSidSubAuthorityProc;
sl@0:     static const SECURITY_INFORMATION infoBits = OWNER_SECURITY_INFORMATION 
sl@0:       | GROUP_SECURITY_INFORMATION | DACL_SECURITY_INFORMATION;
sl@0:     static const DWORD readOnlyMask = FILE_DELETE_CHILD | FILE_ADD_FILE 
sl@0:       | FILE_ADD_SUBDIRECTORY | FILE_WRITE_EA |  FILE_APPEND_DATA 
sl@0:       | FILE_WRITE_DATA | DELETE;
sl@0: 
sl@0:     BYTE *secDesc = 0;
sl@0:     DWORD secDescLen;
sl@0: 
sl@0:     const BOOL set_readOnly = !(pmode & 0222);
sl@0:     BOOL acl_readOnly_found = FALSE;
sl@0: 
sl@0:     ACL_SIZE_INFORMATION ACLSize;
sl@0:     BOOL curAclPresent, curAclDefaulted;
sl@0:     PACL curAcl; 
sl@0:     PACL newAcl = 0;
sl@0:     DWORD newAclSize;
sl@0: 
sl@0:     WORD j;
sl@0:   
sl@0:     SID *userSid = 0;
sl@0:     TCHAR *userDomain = NULL;
sl@0: 
sl@0:     DWORD attr;
sl@0: 
sl@0:     int res = 0;
sl@0: 
sl@0:     /*
sl@0:      * One time initialization, dynamically load Windows NT features
sl@0:      */
sl@0:     typedef DWORD (WINAPI *setNamedSecurityInfoADef)( IN LPSTR,
sl@0:       IN SE_OBJECT_TYPE, IN SECURITY_INFORMATION, IN PSID, IN PSID,
sl@0:       IN PACL, IN PACL );
sl@0:     typedef BOOL (WINAPI *getAceDef) (PACL, DWORD, LPVOID *);
sl@0:     typedef BOOL (WINAPI *addAceDef) ( PACL, DWORD, DWORD, LPVOID, DWORD );
sl@0:     typedef BOOL (WINAPI *equalSidDef) ( PSID, PSID );
sl@0:     typedef BOOL (WINAPI *addAccessDeniedAceDef) ( PACL, DWORD, DWORD, PSID );
sl@0:     typedef BOOL (WINAPI *initializeAclDef) ( PACL, DWORD, DWORD );
sl@0:     typedef DWORD (WINAPI *getLengthSidDef) ( PSID );
sl@0:     typedef BOOL (WINAPI *getAclInformationDef) (PACL, LPVOID, DWORD, 
sl@0:       ACL_INFORMATION_CLASS );
sl@0:     typedef BOOL (WINAPI *getSecurityDescriptorDaclDef) (PSECURITY_DESCRIPTOR,
sl@0:       LPBOOL, PACL *, LPBOOL );
sl@0:     typedef BOOL (WINAPI *lookupAccountNameADef) ( LPCSTR, LPCSTR, PSID, 
sl@0:       PDWORD, LPSTR, LPDWORD, PSID_NAME_USE );
sl@0:     typedef BOOL (WINAPI *getFileSecurityADef) ( LPCSTR, SECURITY_INFORMATION,
sl@0:       PSECURITY_DESCRIPTOR, DWORD, LPDWORD );
sl@0: 
sl@0:     static setNamedSecurityInfoADef setNamedSecurityInfoProc;
sl@0:     static getAceDef getAceProc;
sl@0:     static addAceDef addAceProc;
sl@0:     static equalSidDef equalSidProc;
sl@0:     static addAccessDeniedAceDef addAccessDeniedAceProc;
sl@0:     static initializeAclDef initializeAclProc;
sl@0:     static getLengthSidDef getLengthSidProc;
sl@0:     static getAclInformationDef getAclInformationProc;
sl@0:     static getSecurityDescriptorDaclDef getSecurityDescriptorDaclProc;
sl@0:     static lookupAccountNameADef lookupAccountNameProc; 
sl@0:     static getFileSecurityADef getFileSecurityProc;
sl@0: 
sl@0:     static int initialized = 0;
sl@0:     if (!initialized) {
sl@0: 	TCL_DECLARE_MUTEX(initializeMutex)
sl@0: 	Tcl_MutexLock(&initializeMutex);
sl@0: 	if (!initialized) {
sl@0: 	    HINSTANCE hInstance = LoadLibrary("Advapi32");
sl@0: 	    if (hInstance != NULL) {
sl@0: 		setNamedSecurityInfoProc = (setNamedSecurityInfoADef)
sl@0: 		  GetProcAddress(hInstance, "SetNamedSecurityInfoA");
sl@0: 		getFileSecurityProc = (getFileSecurityADef)
sl@0: 		  GetProcAddress(hInstance, "GetFileSecurityA");
sl@0: 		getAceProc = (getAceDef)
sl@0: 		  GetProcAddress(hInstance, "GetAce");
sl@0: 		addAceProc = (addAceDef)
sl@0: 		  GetProcAddress(hInstance, "AddAce");
sl@0: 		equalSidProc = (equalSidDef)
sl@0: 		  GetProcAddress(hInstance, "EqualSid");
sl@0: 		addAccessDeniedAceProc = (addAccessDeniedAceDef)
sl@0: 		  GetProcAddress(hInstance, "AddAccessDeniedAce");
sl@0: 		initializeAclProc = (initializeAclDef)
sl@0: 		  GetProcAddress(hInstance, "InitializeAcl");
sl@0: 		getLengthSidProc = (getLengthSidDef)
sl@0: 		  GetProcAddress(hInstance, "GetLengthSid");
sl@0: 		getAclInformationProc = (getAclInformationDef)
sl@0: 		  GetProcAddress(hInstance, "GetAclInformation");
sl@0: 		getSecurityDescriptorDaclProc = (getSecurityDescriptorDaclDef)
sl@0: 		  GetProcAddress(hInstance, "GetSecurityDescriptorDacl");
sl@0: 		lookupAccountNameProc = (lookupAccountNameADef)
sl@0: 		  GetProcAddress(hInstance, "LookupAccountNameA");
sl@0: 		getSidLengthRequiredProc = (getSidLengthRequiredDef)
sl@0: 		  GetProcAddress(hInstance, "GetSidLengthRequired");
sl@0: 		initializeSidProc = (initializeSidDef)
sl@0: 		  GetProcAddress(hInstance, "InitializeSid");
sl@0: 		getSidSubAuthorityProc = (getSidSubAuthorityDef)
sl@0: 		  GetProcAddress(hInstance, "GetSidSubAuthority");
sl@0: 		if (setNamedSecurityInfoProc && getAceProc
sl@0: 		  && addAceProc && equalSidProc && addAccessDeniedAceProc
sl@0: 		  && initializeAclProc && getLengthSidProc
sl@0: 		  && getAclInformationProc && getSecurityDescriptorDaclProc
sl@0: 		  && lookupAccountNameProc && getFileSecurityProc
sl@0: 		  && getSidLengthRequiredProc && initializeSidProc
sl@0: 		  && getSidSubAuthorityProc)
sl@0: 		    initialized = 1;
sl@0: 	    }
sl@0: 	    if (!initialized)
sl@0: 		initialized = -1;
sl@0: 	}
sl@0: 	Tcl_MutexUnlock(&initializeMutex);
sl@0:     }
sl@0: 
sl@0:     /* Process the chmod request */
sl@0:     attr = GetFileAttributes(nativePath);
sl@0: 
sl@0:     /* nativePath not found */
sl@0:     if (attr == 0xffffffff) {
sl@0: 	res = -1;
sl@0: 	goto done;
sl@0:     }
sl@0: 
sl@0:     /* If no ACL API is present or nativePath is not a directory, 
sl@0:      * there is no special handling 
sl@0:      */
sl@0:     if (initialized < 0 || !(attr & FILE_ATTRIBUTE_DIRECTORY)) {
sl@0: 	goto done;
sl@0:     }
sl@0:     
sl@0:     /* Set the result to error, if the ACL change is successful it will 
sl@0:      *  be reset to 0 
sl@0:      */
sl@0:     res = -1;
sl@0: 
sl@0:     /*
sl@0:      * Read the security descriptor for the directory. Note the
sl@0:      * first call obtains the size of the security descriptor.
sl@0:      */
sl@0:     if (!getFileSecurityProc(nativePath, infoBits, NULL, 0, &secDescLen)) {
sl@0: 	if (GetLastError() == ERROR_INSUFFICIENT_BUFFER) {
sl@0: 	    DWORD secDescLen2 = 0;
sl@0: 	    secDesc = (BYTE *) ckalloc(secDescLen);
sl@0: 	    if (!getFileSecurityProc(nativePath, infoBits,
sl@0: 				     (PSECURITY_DESCRIPTOR)secDesc, 
sl@0: 				     secDescLen, &secDescLen2) 
sl@0: 		|| (secDescLen < secDescLen2)) {
sl@0: 		goto done;
sl@0: 	    }
sl@0: 	} else {
sl@0: 	    goto done;
sl@0: 	}
sl@0:     }
sl@0: 
sl@0:     /* Get the World SID */
sl@0:     userSid = (SID*) ckalloc(getSidLengthRequiredProc((UCHAR)1));
sl@0:     initializeSidProc( userSid, &userSidAuthority, (BYTE)1);
sl@0:     *(getSidSubAuthorityProc( userSid, 0)) = SECURITY_WORLD_RID;
sl@0: 
sl@0:     /* If curAclPresent == false then curAcl and curAclDefaulted not valid */
sl@0:     if (!getSecurityDescriptorDaclProc(secDesc, &curAclPresent, 
sl@0: 				       &curAcl, &curAclDefaulted))
sl@0: 	goto done;
sl@0: 
sl@0:     if (!curAclPresent || !curAcl) {
sl@0: 	ACLSize.AclBytesInUse = 0;
sl@0: 	ACLSize.AceCount = 0;
sl@0:     } else if (!getAclInformationProc(curAcl, &ACLSize, sizeof(ACLSize), 
sl@0:       AclSizeInformation))
sl@0: 	goto done;
sl@0: 
sl@0:     /* Allocate memory for the new ACL */
sl@0:     newAclSize = ACLSize.AclBytesInUse + sizeof (ACCESS_DENIED_ACE) 
sl@0:       + getLengthSidProc(userSid) - sizeof (DWORD);
sl@0:     newAcl = (ACL *) ckalloc (newAclSize);
sl@0:   
sl@0:     /* Initialize the new ACL */
sl@0:     if(!initializeAclProc(newAcl, newAclSize, ACL_REVISION)) {
sl@0: 	goto done;
sl@0:     }
sl@0:     
sl@0:     /* Add denied to make readonly, this will be known as a "read-only tag" */
sl@0:     if (set_readOnly && !addAccessDeniedAceProc(newAcl, ACL_REVISION, 
sl@0:       readOnlyMask, userSid)) {
sl@0: 	goto done;
sl@0:     }
sl@0:       
sl@0:     acl_readOnly_found = FALSE;
sl@0:     for (j = 0; j < ACLSize.AceCount; j++) {
sl@0: 	PACL *pACE2;
sl@0: 	ACE_HEADER *phACE2;
sl@0: 	if (! getAceProc (curAcl, j, (LPVOID*) &pACE2)) {
sl@0: 	    goto done;
sl@0: 	}
sl@0: 	
sl@0: 	phACE2 = ((ACE_HEADER *) pACE2);
sl@0: 
sl@0: 	/* Do NOT propagate inherited ACEs */
sl@0: 	if (phACE2->AceFlags & INHERITED_ACE) {
sl@0: 	    continue;
sl@0: 	}
sl@0: 	
sl@0: 	/* Skip the "read-only tag" restriction (either added above, or it
sl@0: 	 * is being removed) 
sl@0: 	 */
sl@0: 	if (phACE2->AceType == ACCESS_DENIED_ACE_TYPE) {
sl@0: 	    ACCESS_DENIED_ACE *pACEd = (ACCESS_DENIED_ACE *)phACE2;
sl@0: 	    if (pACEd->Mask == readOnlyMask && equalSidProc(userSid, 
sl@0: 	      (PSID)&(pACEd->SidStart))) {
sl@0: 		acl_readOnly_found = TRUE;
sl@0: 		continue;
sl@0: 	    }
sl@0: 	}
sl@0: 
sl@0: 	/* Copy the current ACE from the old to the new ACL */
sl@0: 	if(! addAceProc (newAcl, ACL_REVISION, MAXDWORD, pACE2, 
sl@0: 	  ((PACE_HEADER) pACE2)->AceSize)) {
sl@0: 	    goto done;
sl@0: 	}
sl@0:     }
sl@0: 
sl@0:     /* Apply the new ACL */
sl@0:     if (set_readOnly == acl_readOnly_found
sl@0: 	|| setNamedSecurityInfoProc((LPSTR)nativePath, SE_FILE_OBJECT, 
sl@0: 	     DACL_SECURITY_INFORMATION, NULL, NULL, newAcl, NULL)
sl@0: 	   == ERROR_SUCCESS ) {
sl@0: 	res = 0;
sl@0:     }
sl@0: 
sl@0:  done:
sl@0:     if (secDesc) ckfree(secDesc);
sl@0:     if (newAcl) ckfree((char *)newAcl);
sl@0:     if (userSid) ckfree((char *)userSid);
sl@0:     if (userDomain) ckfree(userDomain);
sl@0: 
sl@0:     if (res != 0)
sl@0: 	return res;
sl@0:     
sl@0:     /* Run normal chmod command */
sl@0:     return chmod(nativePath, pmode);
sl@0: }
sl@0: 
sl@0: /*
sl@0:  *---------------------------------------------------------------------------
sl@0:  *
sl@0:  * TestchmodCmd --
sl@0:  *
sl@0:  *	Implements the "testchmod" cmd.  Used when testing "file" command.
sl@0:  *	The only attribute used by the Windows platform is the user write
sl@0:  *	flag; if this is not set, the file is made read-only.  Otehrwise, the
sl@0:  *	file is made read-write.
sl@0:  *
sl@0:  * Results:
sl@0:  *	A standard Tcl result.
sl@0:  *
sl@0:  * Side effects:
sl@0:  *	Changes permissions of specified files.
sl@0:  *
sl@0:  *---------------------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: static int
sl@0: TestchmodCmd(dummy, interp, argc, argv)
sl@0:     ClientData dummy;			/* Not used. */
sl@0:     Tcl_Interp *interp;			/* Current interpreter. */
sl@0:     int argc;				/* Number of arguments. */
sl@0:     CONST84 char **argv;		/* Argument strings. */
sl@0: {
sl@0:     int i, mode;
sl@0:     char *rest;
sl@0: 
sl@0:     if (argc < 2) {
sl@0: 	usage:
sl@0: 	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
sl@0: 		" mode file ?file ...?", NULL);
sl@0: 	return TCL_ERROR;
sl@0:     }
sl@0: 
sl@0:     mode = (int) strtol(argv[1], &rest, 8);
sl@0:     if ((rest == argv[1]) || (*rest != '\0')) {
sl@0: 	goto usage;
sl@0:     }
sl@0: 
sl@0:     for (i = 2; i < argc; i++) {
sl@0: 	Tcl_DString buffer;
sl@0: 	CONST char *translated;
sl@0: 
sl@0: 	translated = Tcl_TranslateFileName(interp, argv[i], &buffer);
sl@0: 	if (translated == NULL) {
sl@0: 	    return TCL_ERROR;
sl@0: 	}
sl@0: 	if (TestplatformChmod(translated, mode) != 0) {
sl@0: 	    Tcl_AppendResult(interp, translated, ": ", Tcl_PosixError(interp),
sl@0: 		    NULL);
sl@0: 	    return TCL_ERROR;
sl@0: 	}
sl@0: 	Tcl_DStringFree(&buffer);
sl@0:     }
sl@0:     return TCL_OK;
sl@0: }