/* 

 * 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.8.2.6 2006/03/27 23:30:54 patthoyts Exp $

 */

#define USE_COMPAT_CONST

#include "tclWinInt.h"

/*

 * For TestplatformChmod on Windows

 */

#ifdef __WIN32__

#include <aclapi.h>

#endif

/*

 * MinGW 3.4.2 does not define this.

 */

#ifndef INHERITED_ACE

#define INHERITED_ACE (0x10)

#endif

/*

 * Forward declarations of procedures defined later in this file:

 */

int		TclplatformtestInit _ANSI_ARGS_((Tcl_Interp *interp));

static int	TesteventloopCmd _ANSI_ARGS_((ClientData dummy,

	Tcl_Interp *interp, int argc, CONST84 char **argv));

static int	TestvolumetypeCmd _ANSI_ARGS_((ClientData dummy,

	Tcl_Interp *interp, int objc,

	Tcl_Obj *CONST objv[]));

static int      TestwinclockCmd _ANSI_ARGS_(( ClientData dummy,

					      Tcl_Interp* interp,

					      int objc,

					      Tcl_Obj *CONST objv[] ));

static int      TestwinsleepCmd _ANSI_ARGS_(( ClientData dummy,

					      Tcl_Interp* interp,

					      int objc,

					      Tcl_Obj *CONST objv[] ));

static Tcl_ObjCmdProc TestExceptionCmd;

static int	TestwincpuidCmd _ANSI_ARGS_(( ClientData dummy,

					      Tcl_Interp* interp,

					      int objc,

					      Tcl_Obj *CONST objv[] ));

static int	TestplatformChmod _ANSI_ARGS_((CONST char *nativePath, 

						 int pmode));

static int	TestchmodCmd _ANSI_ARGS_((ClientData dummy,

		  Tcl_Interp *interp, int argc, CONST84 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(interp)

    Tcl_Interp *interp;		/* Interpreter to add commands to. */

{

    /*

     * Add commands for platform specific tests for Windows here.

     */

    Tcl_CreateCommand(interp, "testchmod", TestchmodCmd,

		      (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);

    Tcl_CreateCommand(interp, "testeventloop", TesteventloopCmd,

		      (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);

    Tcl_CreateObjCommand(interp, "testvolumetype", TestvolumetypeCmd,

			 (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);

    Tcl_CreateObjCommand(interp, "testwinclock", TestwinclockCmd,

			 (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);

    Tcl_CreateObjCommand(interp, "testwincpuid", TestwincpuidCmd,

			 (ClientData) 0, (Tcl_CmdDeleteProc*) NULL );

    Tcl_CreateObjCommand(interp, "testwinsleep", TestwinsleepCmd,

			 (ClientData) 0, (Tcl_CmdDeleteProc *) NULL );

    Tcl_CreateObjCommand(interp, "testexcept", TestExceptionCmd,

			 (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);

    return TCL_OK;

}

/*

 *----------------------------------------------------------------------

 *

 * TesteventloopCmd --

 *

 *	This procedure 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, interp, argc, argv)

    ClientData clientData;		/* Not used. */

    Tcl_Interp *interp;			/* Current interpreter. */

    int argc;				/* Number of arguments. */

    CONST84 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 ... \"", (char *) 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((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", (char *) NULL);

	return TCL_ERROR;

    }

    return TCL_OK;

}

/*

 *----------------------------------------------------------------------

 *

 * Testvolumetype --

 *

 *	This procedure 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, interp, objc, objv)

    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:""), "\"", (char *) 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;

}

static int 

TestplatformChmod(CONST char *nativePath, int pmode)

{

    SID_IDENTIFIER_AUTHORITY userSidAuthority =

    { SECURITY_WORLD_SID_AUTHORITY };

    typedef DWORD (WINAPI *getSidLengthRequiredDef) ( UCHAR );

    typedef BOOL (WINAPI *initializeSidDef) ( PSID,

    PSID_IDENTIFIER_AUTHORITY, BYTE );

    typedef PDWORD (WINAPI *getSidSubAuthorityDef) ( PSID, DWORD );

    static getSidLengthRequiredDef getSidLengthRequiredProc;

    static initializeSidDef initializeSidProc;

    static getSidSubAuthorityDef getSidSubAuthorityProc;

    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;

    BYTE *secDesc = 0;

    DWORD secDescLen;

    const BOOL set_readOnly = !(pmode & 0222);

    BOOL acl_readOnly_found = FALSE;

    ACL_SIZE_INFORMATION ACLSize;

    BOOL curAclPresent, curAclDefaulted;

    PACL curAcl; 

    PACL newAcl = 0;

    DWORD newAclSize;

    WORD j;

    SID *userSid = 0;

    TCHAR *userDomain = NULL;

    DWORD attr;

    int res = 0;

    /*

     * One time initialization, dynamically load Windows NT features

     */

    typedef DWORD (WINAPI *setNamedSecurityInfoADef)( IN LPSTR,

      IN SE_OBJECT_TYPE, IN SECURITY_INFORMATION, IN PSID, IN PSID,

      IN PACL, IN PACL );

    typedef BOOL (WINAPI *getAceDef) (PACL, DWORD, LPVOID *);

    typedef BOOL (WINAPI *addAceDef) ( PACL, DWORD, DWORD, LPVOID, DWORD );

    typedef BOOL (WINAPI *equalSidDef) ( PSID, PSID );

    typedef BOOL (WINAPI *addAccessDeniedAceDef) ( PACL, DWORD, DWORD, PSID );

    typedef BOOL (WINAPI *initializeAclDef) ( PACL, DWORD, DWORD );

    typedef DWORD (WINAPI *getLengthSidDef) ( PSID );

    typedef BOOL (WINAPI *getAclInformationDef) (PACL, LPVOID, DWORD, 

      ACL_INFORMATION_CLASS );

    typedef BOOL (WINAPI *getSecurityDescriptorDaclDef) (PSECURITY_DESCRIPTOR,

      LPBOOL, PACL *, LPBOOL );

    typedef BOOL (WINAPI *lookupAccountNameADef) ( LPCSTR, LPCSTR, PSID, 

      PDWORD, LPSTR, LPDWORD, PSID_NAME_USE );

    typedef BOOL (WINAPI *getFileSecurityADef) ( LPCSTR, SECURITY_INFORMATION,

      PSECURITY_DESCRIPTOR, DWORD, LPDWORD );

    static setNamedSecurityInfoADef setNamedSecurityInfoProc;

    static getAceDef getAceProc;

    static addAceDef addAceProc;

    static equalSidDef equalSidProc;

    static addAccessDeniedAceDef addAccessDeniedAceProc;

    static initializeAclDef initializeAclProc;

    static getLengthSidDef getLengthSidProc;

    static getAclInformationDef getAclInformationProc;

    static getSecurityDescriptorDaclDef getSecurityDescriptorDaclProc;

    static lookupAccountNameADef lookupAccountNameProc; 

    static getFileSecurityADef getFileSecurityProc;

    static int initialized = 0;

    if (!initialized) {

	TCL_DECLARE_MUTEX(initializeMutex)

	Tcl_MutexLock(&initializeMutex);

	if (!initialized) {

	    HINSTANCE hInstance = LoadLibrary("Advapi32");

	    if (hInstance != NULL) {

		setNamedSecurityInfoProc = (setNamedSecurityInfoADef)

		  GetProcAddress(hInstance, "SetNamedSecurityInfoA");

		getFileSecurityProc = (getFileSecurityADef)

		  GetProcAddress(hInstance, "GetFileSecurityA");

		getAceProc = (getAceDef)

		  GetProcAddress(hInstance, "GetAce");

		addAceProc = (addAceDef)

		  GetProcAddress(hInstance, "AddAce");

		equalSidProc = (equalSidDef)

		  GetProcAddress(hInstance, "EqualSid");

		addAccessDeniedAceProc = (addAccessDeniedAceDef)

		  GetProcAddress(hInstance, "AddAccessDeniedAce");

		initializeAclProc = (initializeAclDef)

		  GetProcAddress(hInstance, "InitializeAcl");

		getLengthSidProc = (getLengthSidDef)

		  GetProcAddress(hInstance, "GetLengthSid");

		getAclInformationProc = (getAclInformationDef)

		  GetProcAddress(hInstance, "GetAclInformation");

		getSecurityDescriptorDaclProc = (getSecurityDescriptorDaclDef)

		  GetProcAddress(hInstance, "GetSecurityDescriptorDacl");

		lookupAccountNameProc = (lookupAccountNameADef)

		  GetProcAddress(hInstance, "LookupAccountNameA");

		getSidLengthRequiredProc = (getSidLengthRequiredDef)

		  GetProcAddress(hInstance, "GetSidLengthRequired");

		initializeSidProc = (initializeSidDef)

		  GetProcAddress(hInstance, "InitializeSid");

		getSidSubAuthorityProc = (getSidSubAuthorityDef)

		  GetProcAddress(hInstance, "GetSidSubAuthority");

		if (setNamedSecurityInfoProc && getAceProc

		  && addAceProc && equalSidProc && addAccessDeniedAceProc

		  && initializeAclProc && getLengthSidProc

		  && getAclInformationProc && getSecurityDescriptorDaclProc

		  && lookupAccountNameProc && getFileSecurityProc

		  && getSidLengthRequiredProc && initializeSidProc

		  && getSidSubAuthorityProc)

		    initialized = 1;

	    }

	    if (!initialized)

		initialized = -1;

	}

	Tcl_MutexUnlock(&initializeMutex);

    }

    /* Process the chmod request */

    attr = GetFileAttributes(nativePath);

    /* nativePath not found */

    if (attr == 0xffffffff) {

	res = -1;

	goto done;

    }

    /* If no ACL API is present or nativePath is not a directory, 

     * there is no special handling 

     */

    if (initialized < 0 || !(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 (!getFileSecurityProc(nativePath, infoBits, NULL, 0, &secDescLen)) {

	if (GetLastError() == ERROR_INSUFFICIENT_BUFFER) {

	    DWORD secDescLen2 = 0;

	    secDesc = (BYTE *) ckalloc(secDescLen);

	    if (!getFileSecurityProc(nativePath, infoBits,

				     (PSECURITY_DESCRIPTOR)secDesc, 

				     secDescLen, &secDescLen2) 

		|| (secDescLen < secDescLen2)) {

		goto done;

	    }

	} else {

	    goto done;

	}

    }

    /* Get the World SID */

    userSid = (SID*) ckalloc(getSidLengthRequiredProc((UCHAR)1));

    initializeSidProc( userSid, &userSidAuthority, (BYTE)1);

    *(getSidSubAuthorityProc( userSid, 0)) = SECURITY_WORLD_RID;

    /* If curAclPresent == false then curAcl and curAclDefaulted not valid */

    if (!getSecurityDescriptorDaclProc(secDesc, &curAclPresent, 

				       &curAcl, &curAclDefaulted))

	goto done;

    if (!curAclPresent || !curAcl) {

	ACLSize.AclBytesInUse = 0;

	ACLSize.AceCount = 0;

    } else if (!getAclInformationProc(curAcl, &ACLSize, sizeof(ACLSize), 

      AclSizeInformation))

	goto done;

    /* Allocate memory for the new ACL */

    newAclSize = ACLSize.AclBytesInUse + sizeof (ACCESS_DENIED_ACE) 

      + getLengthSidProc(userSid) - sizeof (DWORD);

    newAcl = (ACL *) ckalloc (newAclSize);

    /* Initialize the new ACL */

    if(!initializeAclProc(newAcl, newAclSize, ACL_REVISION)) {

	goto done;

    }

    /* Add denied to make readonly, this will be known as a "read-only tag" */

    if (set_readOnly && !addAccessDeniedAceProc(newAcl, ACL_REVISION, 

      readOnlyMask, userSid)) {

	goto done;

    }

    acl_readOnly_found = FALSE;

    for (j = 0; j < ACLSize.AceCount; j++) {

	PACL *pACE2;

	ACE_HEADER *phACE2;

	if (! getAceProc (curAcl, j, (LPVOID*) &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 && equalSidProc(userSid, 

	      (PSID)&(pACEd->SidStart))) {

		acl_readOnly_found = TRUE;

		continue;

	    }

	}

	/* Copy the current ACE from the old to the new ACL */

	if(! addAceProc (newAcl, ACL_REVISION, MAXDWORD, pACE2, 

	  ((PACE_HEADER) pACE2)->AceSize)) {

	    goto done;

	}

    }

    /* Apply the new ACL */

    if (set_readOnly == acl_readOnly_found

	|| setNamedSecurityInfoProc((LPSTR)nativePath, SE_FILE_OBJECT, 

	     DACL_SECURITY_INFORMATION, NULL, NULL, newAcl, NULL)

	   == ERROR_SUCCESS ) {

	res = 0;

    }

 done:

    if (secDesc) ckfree(secDesc);

    if (newAcl) ckfree((char *)newAcl);

    if (userSid) ckfree((char *)userSid);

    if (userDomain) ckfree(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.  Otehrwise, the

 *	file is made read-write.

 *

 * Results:

 *	A standard Tcl result.

 *

 * Side effects:

 *	Changes permissions of specified files.

 *

 *---------------------------------------------------------------------------

 */

static int

TestchmodCmd(dummy, interp, argc, argv)

    ClientData dummy;			/* Not used. */

    Tcl_Interp *interp;			/* Current interpreter. */

    int argc;				/* Number of arguments. */

    CONST84 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;

}