1/*
2 * tclWinTest.c --
3 *
4 *	Contains commands for platform specific tests on Windows.
5 *
6 * Copyright (c) 1996 Sun Microsystems, Inc.
7 *
8 * See the file "license.terms" for information on usage and redistribution
9 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
10 *
11 * RCS: @(#) $Id: tclWinTest.c,v 1.8.2.6 2006/03/27 23:30:54 patthoyts Exp $
12 */
13
14#define USE_COMPAT_CONST
15#include "tclWinInt.h"
16
17/*
18 * For TestplatformChmod on Windows
19 */
20#ifdef __WIN32__
21#include <aclapi.h>
22#endif
23
24/*
25 * MinGW 3.4.2 does not define this.
26 */
27#ifndef INHERITED_ACE
28#define INHERITED_ACE (0x10)
29#endif
30
31/*
32 * Forward declarations of procedures defined later in this file:
33 */
34int		TclplatformtestInit _ANSI_ARGS_((Tcl_Interp *interp));
35static int	TesteventloopCmd _ANSI_ARGS_((ClientData dummy,
36	Tcl_Interp *interp, int argc, CONST84 char **argv));
37static int	TestvolumetypeCmd _ANSI_ARGS_((ClientData dummy,
38	Tcl_Interp *interp, int objc,
39	Tcl_Obj *CONST objv[]));
40static int      TestwinclockCmd _ANSI_ARGS_(( ClientData dummy,
41					      Tcl_Interp* interp,
42					      int objc,
43					      Tcl_Obj *CONST objv[] ));
44static int      TestwinsleepCmd _ANSI_ARGS_(( ClientData dummy,
45					      Tcl_Interp* interp,
46					      int objc,
47					      Tcl_Obj *CONST objv[] ));
48static Tcl_ObjCmdProc TestExceptionCmd;
49static int	TestwincpuidCmd _ANSI_ARGS_(( ClientData dummy,
50					      Tcl_Interp* interp,
51					      int objc,
52					      Tcl_Obj *CONST objv[] ));
53static int	TestplatformChmod _ANSI_ARGS_((CONST char *nativePath,
54						 int pmode));
55static int	TestchmodCmd _ANSI_ARGS_((ClientData dummy,
56		  Tcl_Interp *interp, int argc, CONST84 char **argv));
57
58
59/*
60 *----------------------------------------------------------------------
61 *
62 * TclplatformtestInit --
63 *
64 *	Defines commands that test platform specific functionality for
65 *	Windows platforms.
66 *
67 * Results:
68 *	A standard Tcl result.
69 *
70 * Side effects:
71 *	Defines new commands.
72 *
73 *----------------------------------------------------------------------
74 */
75
76int
77TclplatformtestInit(interp)
78    Tcl_Interp *interp;		/* Interpreter to add commands to. */
79{
80    /*
81     * Add commands for platform specific tests for Windows here.
82     */
83
84    Tcl_CreateCommand(interp, "testchmod", TestchmodCmd,
85		      (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
86    Tcl_CreateCommand(interp, "testeventloop", TesteventloopCmd,
87		      (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
88    Tcl_CreateObjCommand(interp, "testvolumetype", TestvolumetypeCmd,
89			 (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
90    Tcl_CreateObjCommand(interp, "testwinclock", TestwinclockCmd,
91			 (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
92    Tcl_CreateObjCommand(interp, "testwincpuid", TestwincpuidCmd,
93			 (ClientData) 0, (Tcl_CmdDeleteProc*) NULL );
94    Tcl_CreateObjCommand(interp, "testwinsleep", TestwinsleepCmd,
95			 (ClientData) 0, (Tcl_CmdDeleteProc *) NULL );
96    Tcl_CreateObjCommand(interp, "testexcept", TestExceptionCmd,
97			 (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
98    return TCL_OK;
99}
100
101/*
102 *----------------------------------------------------------------------
103 *
104 * TesteventloopCmd --
105 *
106 *	This procedure implements the "testeventloop" command. It is
107 *	used to test the Tcl notifier from an "external" event loop
108 *	(i.e. not Tcl_DoOneEvent()).
109 *
110 * Results:
111 *	A standard Tcl result.
112 *
113 * Side effects:
114 *	None.
115 *
116 *----------------------------------------------------------------------
117 */
118
119static int
120TesteventloopCmd(clientData, interp, argc, argv)
121    ClientData clientData;		/* Not used. */
122    Tcl_Interp *interp;			/* Current interpreter. */
123    int argc;				/* Number of arguments. */
124    CONST84 char **argv;		/* Argument strings. */
125{
126    static int *framePtr = NULL; /* Pointer to integer on stack frame of
127				  * innermost invocation of the "wait"
128				  * subcommand. */
129
130   if (argc < 2) {
131	Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
132                " option ... \"", (char *) NULL);
133        return TCL_ERROR;
134    }
135    if (strcmp(argv[1], "done") == 0) {
136	*framePtr = 1;
137    } else if (strcmp(argv[1], "wait") == 0) {
138	int *oldFramePtr;
139	int done;
140	MSG msg;
141	int oldMode = Tcl_SetServiceMode(TCL_SERVICE_ALL);
142
143	/*
144	 * Save the old stack frame pointer and set up the current frame.
145	 */
146
147	oldFramePtr = framePtr;
148	framePtr = &done;
149
150	/*
151	 * Enter a standard Windows event loop until the flag changes.
152	 * Note that we do not explicitly call Tcl_ServiceEvent().
153	 */
154
155	done = 0;
156	while (!done) {
157	    if (!GetMessage(&msg, NULL, 0, 0)) {
158		/*
159		 * The application is exiting, so repost the quit message
160		 * and start unwinding.
161		 */
162
163		PostQuitMessage((int)msg.wParam);
164		break;
165	    }
166	    TranslateMessage(&msg);
167	    DispatchMessage(&msg);
168	}
169	(void) Tcl_SetServiceMode(oldMode);
170	framePtr = oldFramePtr;
171    } else {
172	Tcl_AppendResult(interp, "bad option \"", argv[1],
173		"\": must be done or wait", (char *) NULL);
174	return TCL_ERROR;
175    }
176    return TCL_OK;
177}
178
179/*
180 *----------------------------------------------------------------------
181 *
182 * Testvolumetype --
183 *
184 *	This procedure implements the "testvolumetype" command. It is
185 *	used to check the volume type (FAT, NTFS) of a volume.
186 *
187 * Results:
188 *	A standard Tcl result.
189 *
190 * Side effects:
191 *	None.
192 *
193 *----------------------------------------------------------------------
194 */
195
196static int
197TestvolumetypeCmd(clientData, interp, objc, objv)
198    ClientData clientData;		/* Not used. */
199    Tcl_Interp *interp;			/* Current interpreter. */
200    int objc;				/* Number of arguments. */
201    Tcl_Obj *CONST objv[];		/* Argument objects. */
202{
203#define VOL_BUF_SIZE 32
204    int found;
205    char volType[VOL_BUF_SIZE];
206    char *path;
207
208    if (objc > 2) {
209	Tcl_WrongNumArgs(interp, 1, objv, "?name?");
210        return TCL_ERROR;
211    }
212    if (objc == 2) {
213	/*
214	 * path has to be really a proper volume, but we don't
215	 * get query APIs for that until NT5
216	 */
217	path = Tcl_GetString(objv[1]);
218    } else {
219	path = NULL;
220    }
221    found = GetVolumeInformationA(path, NULL, 0, NULL, NULL,
222	    NULL, volType, VOL_BUF_SIZE);
223
224    if (found == 0) {
225	Tcl_AppendResult(interp, "could not get volume type for \"",
226		(path?path:""), "\"", (char *) NULL);
227	TclWinConvertError(GetLastError());
228	return TCL_ERROR;
229    }
230    Tcl_SetResult(interp, volType, TCL_VOLATILE);
231    return TCL_OK;
232#undef VOL_BUF_SIZE
233}
234
235/*
236 *----------------------------------------------------------------------
237 *
238 * TestwinclockCmd --
239 *
240 *	Command that returns the seconds and microseconds portions of
241 *	the system clock and of the Tcl clock so that they can be
242 *	compared to validate that the Tcl clock is staying in sync.
243 *
244 * Usage:
245 *	testclock
246 *
247 * Parameters:
248 *	None.
249 *
250 * Results:
251 *	Returns a standard Tcl result comprising a four-element list:
252 *	the seconds and microseconds portions of the system clock,
253 *	and the seconds and microseconds portions of the Tcl clock.
254 *
255 * Side effects:
256 *	None.
257 *
258 *----------------------------------------------------------------------
259 */
260
261static int
262TestwinclockCmd( ClientData dummy,
263				/* Unused */
264		 Tcl_Interp* interp,
265				/* Tcl interpreter */
266		 int objc,
267				/* Argument count */
268		 Tcl_Obj *CONST objv[] )
269				/* Argument vector */
270{
271    CONST static FILETIME posixEpoch = { 0xD53E8000, 0x019DB1DE };
272				/* The Posix epoch, expressed as a
273				 * Windows FILETIME */
274    Tcl_Time tclTime;		/* Tcl clock */
275    FILETIME sysTime;		/* System clock */
276    Tcl_Obj* result;		/* Result of the command */
277    LARGE_INTEGER t1, t2;
278    LARGE_INTEGER p1, p2;
279
280    if ( objc != 1 ) {
281	Tcl_WrongNumArgs( interp, 1, objv, "" );
282	return TCL_ERROR;
283    }
284
285    QueryPerformanceCounter( &p1 );
286
287    Tcl_GetTime( &tclTime );
288    GetSystemTimeAsFileTime( &sysTime );
289    t1.LowPart = posixEpoch.dwLowDateTime;
290    t1.HighPart = posixEpoch.dwHighDateTime;
291    t2.LowPart = sysTime.dwLowDateTime;
292    t2.HighPart = sysTime.dwHighDateTime;
293    t2.QuadPart -= t1.QuadPart;
294
295    QueryPerformanceCounter( &p2 );
296
297    result = Tcl_NewObj();
298    Tcl_ListObjAppendElement
299	( interp, result, Tcl_NewIntObj( (int) (t2.QuadPart / 10000000 ) ) );
300    Tcl_ListObjAppendElement
301	( interp, result,
302	  Tcl_NewIntObj( (int) ( (t2.QuadPart / 10 ) % 1000000 ) ) );
303    Tcl_ListObjAppendElement( interp, result, Tcl_NewIntObj( tclTime.sec ) );
304    Tcl_ListObjAppendElement( interp, result, Tcl_NewIntObj( tclTime.usec ) );
305
306    Tcl_ListObjAppendElement( interp, result, Tcl_NewWideIntObj( p1.QuadPart ) );
307    Tcl_ListObjAppendElement( interp, result, Tcl_NewWideIntObj( p2.QuadPart ) );
308
309    Tcl_SetObjResult( interp, result );
310
311    return TCL_OK;
312}
313
314/*
315 *----------------------------------------------------------------------
316 *
317 * TestwincpuidCmd --
318 *
319 *	Retrieves CPU ID information.
320 *
321 * Usage:
322 *	testwincpuid <eax>
323 *
324 * Parameters:
325 *	eax - The value to pass in the EAX register to a CPUID instruction.
326 *
327 * Results:
328 *	Returns a four-element list containing the values from the
329 *	EAX, EBX, ECX and EDX registers returned from the CPUID instruction.
330 *
331 * Side effects:
332 *	None.
333 *
334 *----------------------------------------------------------------------
335 */
336
337static int
338TestwincpuidCmd( ClientData dummy,
339		 Tcl_Interp* interp, /* Tcl interpreter */
340		 int objc,	/* Parameter count */
341		 Tcl_Obj *CONST * objv ) /* Parameter vector */
342{
343    int status;
344    int index;
345    unsigned int regs[4];
346    Tcl_Obj * regsObjs[4];
347    int i;
348
349    if ( objc != 2 ) {
350	Tcl_WrongNumArgs( interp, 1, objv, "eax" );
351	return TCL_ERROR;
352    }
353    if ( Tcl_GetIntFromObj( interp, objv[1], &index ) != TCL_OK ) {
354	return TCL_ERROR;
355    }
356    status = TclWinCPUID( (unsigned int) index, regs );
357    if ( status != TCL_OK ) {
358	Tcl_SetObjResult( interp, Tcl_NewStringObj( "operation not available",
359						    -1 ) );
360	return status;
361    }
362    for ( i = 0; i < 4; ++i ) {
363	regsObjs[i] = Tcl_NewIntObj( (int) regs[i] );
364    }
365    Tcl_SetObjResult( interp, Tcl_NewListObj( 4, regsObjs ) );
366    return TCL_OK;
367
368}
369
370/*
371 *----------------------------------------------------------------------
372 *
373 * TestwinsleepCmd --
374 *
375 *	Causes this process to wait for the given number of milliseconds
376 *	by means of a direct call to Sleep.
377 *
378 * Usage:
379 *	testwinsleep <n>
380 *
381 * Parameters:
382 *	n - the number of milliseconds to sleep
383 *
384 * Results:
385 *	None.
386 *
387 * Side effects:
388 *	Sleeps for the requisite number of milliseconds.
389 *
390 *----------------------------------------------------------------------
391 */
392
393static int
394TestwinsleepCmd( ClientData clientData,
395				/* Unused */
396		 Tcl_Interp* interp,
397				/* Tcl interpreter */
398		 int objc,
399				/* Parameter count */
400		 Tcl_Obj * CONST * objv )
401				/* Parameter vector */
402{
403    int ms;
404    if ( objc != 2 ) {
405	Tcl_WrongNumArgs( interp, 1, objv, "ms" );
406	return TCL_ERROR;
407    }
408    if ( Tcl_GetIntFromObj( interp, objv[1], &ms ) != TCL_OK ) {
409	return TCL_ERROR;
410    }
411    Sleep( (DWORD) ms );
412    return TCL_OK;
413}
414
415/*
416 *----------------------------------------------------------------------
417 *
418 * TestExceptionCmd --
419 *
420 *	Causes this process to end with the named exception. Used for
421 *	testing Tcl_WaitPid().
422 *
423 * Usage:
424 *	testexcept <type>
425 *
426 * Parameters:
427 *	Type of exception.
428 *
429 * Results:
430 *	None, this process closes now and doesn't return.
431 *
432 * Side effects:
433 *	This Tcl process closes, hard... Bang!
434 *
435 *----------------------------------------------------------------------
436 */
437
438static int
439TestExceptionCmd(
440    ClientData dummy,			/* Unused */
441    Tcl_Interp* interp,			/* Tcl interpreter */
442    int objc,				/* Argument count */
443    Tcl_Obj *CONST objv[])		/* Argument vector */
444{
445    static char *cmds[] = {
446	    "access_violation",
447	    "datatype_misalignment",
448	    "array_bounds",
449	    "float_denormal",
450	    "float_divbyzero",
451	    "float_inexact",
452	    "float_invalidop",
453	    "float_overflow",
454	    "float_stack",
455	    "float_underflow",
456	    "int_divbyzero",
457	    "int_overflow",
458	    "private_instruction",
459	    "inpageerror",
460	    "illegal_instruction",
461	    "noncontinue",
462	    "stack_overflow",
463	    "invalid_disp",
464	    "guard_page",
465	    "invalid_handle",
466	    "ctrl+c",
467	    NULL
468    };
469    static DWORD exceptions[] = {
470	    EXCEPTION_ACCESS_VIOLATION,
471	    EXCEPTION_DATATYPE_MISALIGNMENT,
472	    EXCEPTION_ARRAY_BOUNDS_EXCEEDED,
473	    EXCEPTION_FLT_DENORMAL_OPERAND,
474	    EXCEPTION_FLT_DIVIDE_BY_ZERO,
475	    EXCEPTION_FLT_INEXACT_RESULT,
476	    EXCEPTION_FLT_INVALID_OPERATION,
477	    EXCEPTION_FLT_OVERFLOW,
478	    EXCEPTION_FLT_STACK_CHECK,
479	    EXCEPTION_FLT_UNDERFLOW,
480	    EXCEPTION_INT_DIVIDE_BY_ZERO,
481	    EXCEPTION_INT_OVERFLOW,
482	    EXCEPTION_PRIV_INSTRUCTION,
483	    EXCEPTION_IN_PAGE_ERROR,
484	    EXCEPTION_ILLEGAL_INSTRUCTION,
485	    EXCEPTION_NONCONTINUABLE_EXCEPTION,
486	    EXCEPTION_STACK_OVERFLOW,
487	    EXCEPTION_INVALID_DISPOSITION,
488	    EXCEPTION_GUARD_PAGE,
489	    EXCEPTION_INVALID_HANDLE,
490	    CONTROL_C_EXIT
491    };
492    int cmd;
493
494    if ( objc != 2 ) {
495	Tcl_WrongNumArgs(interp, 0, objv, "<type-of-exception>");
496	return TCL_ERROR;
497    }
498    if (Tcl_GetIndexFromObj(interp, objv[1], cmds, "command", 0,
499	    &cmd) != TCL_OK) {
500	return TCL_ERROR;
501    }
502
503    /*
504     * Make sure the GPF dialog doesn't popup.
505     */
506
507    SetErrorMode(SEM_FAILCRITICALERRORS | SEM_NOGPFAULTERRORBOX);
508
509    /*
510     * As Tcl does not handle structured exceptions, this falls all the way
511     * back up the instruction stack to the C run-time portion that called
512     * main() where the process will now be terminated with this exception
513     * code by the default handler the C run-time provides.
514     */
515
516    /* SMASH! */
517    RaiseException(exceptions[cmd], EXCEPTION_NONCONTINUABLE, 0, NULL);
518
519    /* NOTREACHED */
520    return TCL_OK;
521}
522
523static int
524TestplatformChmod(CONST char *nativePath, int pmode)
525{
526    SID_IDENTIFIER_AUTHORITY userSidAuthority =
527    { SECURITY_WORLD_SID_AUTHORITY };
528
529    typedef DWORD (WINAPI *getSidLengthRequiredDef) ( UCHAR );
530    typedef BOOL (WINAPI *initializeSidDef) ( PSID,
531    PSID_IDENTIFIER_AUTHORITY, BYTE );
532    typedef PDWORD (WINAPI *getSidSubAuthorityDef) ( PSID, DWORD );
533
534    static getSidLengthRequiredDef getSidLengthRequiredProc;
535    static initializeSidDef initializeSidProc;
536    static getSidSubAuthorityDef getSidSubAuthorityProc;
537    static const SECURITY_INFORMATION infoBits = OWNER_SECURITY_INFORMATION
538      | GROUP_SECURITY_INFORMATION | DACL_SECURITY_INFORMATION;
539    static const DWORD readOnlyMask = FILE_DELETE_CHILD | FILE_ADD_FILE
540      | FILE_ADD_SUBDIRECTORY | FILE_WRITE_EA |  FILE_APPEND_DATA
541      | FILE_WRITE_DATA | DELETE;
542
543    BYTE *secDesc = 0;
544    DWORD secDescLen;
545
546    const BOOL set_readOnly = !(pmode & 0222);
547    BOOL acl_readOnly_found = FALSE;
548
549    ACL_SIZE_INFORMATION ACLSize;
550    BOOL curAclPresent, curAclDefaulted;
551    PACL curAcl;
552    PACL newAcl = 0;
553    DWORD newAclSize;
554
555    WORD j;
556
557    SID *userSid = 0;
558    TCHAR *userDomain = NULL;
559
560    DWORD attr;
561
562    int res = 0;
563
564    /*
565     * One time initialization, dynamically load Windows NT features
566     */
567    typedef DWORD (WINAPI *setNamedSecurityInfoADef)( IN LPSTR,
568      IN SE_OBJECT_TYPE, IN SECURITY_INFORMATION, IN PSID, IN PSID,
569      IN PACL, IN PACL );
570    typedef BOOL (WINAPI *getAceDef) (PACL, DWORD, LPVOID *);
571    typedef BOOL (WINAPI *addAceDef) ( PACL, DWORD, DWORD, LPVOID, DWORD );
572    typedef BOOL (WINAPI *equalSidDef) ( PSID, PSID );
573    typedef BOOL (WINAPI *addAccessDeniedAceDef) ( PACL, DWORD, DWORD, PSID );
574    typedef BOOL (WINAPI *initializeAclDef) ( PACL, DWORD, DWORD );
575    typedef DWORD (WINAPI *getLengthSidDef) ( PSID );
576    typedef BOOL (WINAPI *getAclInformationDef) (PACL, LPVOID, DWORD,
577      ACL_INFORMATION_CLASS );
578    typedef BOOL (WINAPI *getSecurityDescriptorDaclDef) (PSECURITY_DESCRIPTOR,
579      LPBOOL, PACL *, LPBOOL );
580    typedef BOOL (WINAPI *lookupAccountNameADef) ( LPCSTR, LPCSTR, PSID,
581      PDWORD, LPSTR, LPDWORD, PSID_NAME_USE );
582    typedef BOOL (WINAPI *getFileSecurityADef) ( LPCSTR, SECURITY_INFORMATION,
583      PSECURITY_DESCRIPTOR, DWORD, LPDWORD );
584
585    static setNamedSecurityInfoADef setNamedSecurityInfoProc;
586    static getAceDef getAceProc;
587    static addAceDef addAceProc;
588    static equalSidDef equalSidProc;
589    static addAccessDeniedAceDef addAccessDeniedAceProc;
590    static initializeAclDef initializeAclProc;
591    static getLengthSidDef getLengthSidProc;
592    static getAclInformationDef getAclInformationProc;
593    static getSecurityDescriptorDaclDef getSecurityDescriptorDaclProc;
594    static lookupAccountNameADef lookupAccountNameProc;
595    static getFileSecurityADef getFileSecurityProc;
596
597    static int initialized = 0;
598    if (!initialized) {
599	TCL_DECLARE_MUTEX(initializeMutex)
600	Tcl_MutexLock(&initializeMutex);
601	if (!initialized) {
602	    HINSTANCE hInstance = LoadLibrary("Advapi32");
603	    if (hInstance != NULL) {
604		setNamedSecurityInfoProc = (setNamedSecurityInfoADef)
605		  GetProcAddress(hInstance, "SetNamedSecurityInfoA");
606		getFileSecurityProc = (getFileSecurityADef)
607		  GetProcAddress(hInstance, "GetFileSecurityA");
608		getAceProc = (getAceDef)
609		  GetProcAddress(hInstance, "GetAce");
610		addAceProc = (addAceDef)
611		  GetProcAddress(hInstance, "AddAce");
612		equalSidProc = (equalSidDef)
613		  GetProcAddress(hInstance, "EqualSid");
614		addAccessDeniedAceProc = (addAccessDeniedAceDef)
615		  GetProcAddress(hInstance, "AddAccessDeniedAce");
616		initializeAclProc = (initializeAclDef)
617		  GetProcAddress(hInstance, "InitializeAcl");
618		getLengthSidProc = (getLengthSidDef)
619		  GetProcAddress(hInstance, "GetLengthSid");
620		getAclInformationProc = (getAclInformationDef)
621		  GetProcAddress(hInstance, "GetAclInformation");
622		getSecurityDescriptorDaclProc = (getSecurityDescriptorDaclDef)
623		  GetProcAddress(hInstance, "GetSecurityDescriptorDacl");
624		lookupAccountNameProc = (lookupAccountNameADef)
625		  GetProcAddress(hInstance, "LookupAccountNameA");
626		getSidLengthRequiredProc = (getSidLengthRequiredDef)
627		  GetProcAddress(hInstance, "GetSidLengthRequired");
628		initializeSidProc = (initializeSidDef)
629		  GetProcAddress(hInstance, "InitializeSid");
630		getSidSubAuthorityProc = (getSidSubAuthorityDef)
631		  GetProcAddress(hInstance, "GetSidSubAuthority");
632		if (setNamedSecurityInfoProc && getAceProc
633		  && addAceProc && equalSidProc && addAccessDeniedAceProc
634		  && initializeAclProc && getLengthSidProc
635		  && getAclInformationProc && getSecurityDescriptorDaclProc
636		  && lookupAccountNameProc && getFileSecurityProc
637		  && getSidLengthRequiredProc && initializeSidProc
638		  && getSidSubAuthorityProc)
639		    initialized = 1;
640	    }
641	    if (!initialized)
642		initialized = -1;
643	}
644	Tcl_MutexUnlock(&initializeMutex);
645    }
646
647    /* Process the chmod request */
648    attr = GetFileAttributes(nativePath);
649
650    /* nativePath not found */
651    if (attr == 0xffffffff) {
652	res = -1;
653	goto done;
654    }
655
656    /* If no ACL API is present or nativePath is not a directory,
657     * there is no special handling
658     */
659    if (initialized < 0 || !(attr & FILE_ATTRIBUTE_DIRECTORY)) {
660	goto done;
661    }
662
663    /* Set the result to error, if the ACL change is successful it will
664     *  be reset to 0
665     */
666    res = -1;
667
668    /*
669     * Read the security descriptor for the directory. Note the
670     * first call obtains the size of the security descriptor.
671     */
672    if (!getFileSecurityProc(nativePath, infoBits, NULL, 0, &secDescLen)) {
673	if (GetLastError() == ERROR_INSUFFICIENT_BUFFER) {
674	    DWORD secDescLen2 = 0;
675	    secDesc = (BYTE *) ckalloc(secDescLen);
676	    if (!getFileSecurityProc(nativePath, infoBits,
677				     (PSECURITY_DESCRIPTOR)secDesc,
678				     secDescLen, &secDescLen2)
679		|| (secDescLen < secDescLen2)) {
680		goto done;
681	    }
682	} else {
683	    goto done;
684	}
685    }
686
687    /* Get the World SID */
688    userSid = (SID*) ckalloc(getSidLengthRequiredProc((UCHAR)1));
689    initializeSidProc( userSid, &userSidAuthority, (BYTE)1);
690    *(getSidSubAuthorityProc( userSid, 0)) = SECURITY_WORLD_RID;
691
692    /* If curAclPresent == false then curAcl and curAclDefaulted not valid */
693    if (!getSecurityDescriptorDaclProc(secDesc, &curAclPresent,
694				       &curAcl, &curAclDefaulted))
695	goto done;
696
697    if (!curAclPresent || !curAcl) {
698	ACLSize.AclBytesInUse = 0;
699	ACLSize.AceCount = 0;
700    } else if (!getAclInformationProc(curAcl, &ACLSize, sizeof(ACLSize),
701      AclSizeInformation))
702	goto done;
703
704    /* Allocate memory for the new ACL */
705    newAclSize = ACLSize.AclBytesInUse + sizeof (ACCESS_DENIED_ACE)
706      + getLengthSidProc(userSid) - sizeof (DWORD);
707    newAcl = (ACL *) ckalloc (newAclSize);
708
709    /* Initialize the new ACL */
710    if(!initializeAclProc(newAcl, newAclSize, ACL_REVISION)) {
711	goto done;
712    }
713
714    /* Add denied to make readonly, this will be known as a "read-only tag" */
715    if (set_readOnly && !addAccessDeniedAceProc(newAcl, ACL_REVISION,
716      readOnlyMask, userSid)) {
717	goto done;
718    }
719
720    acl_readOnly_found = FALSE;
721    for (j = 0; j < ACLSize.AceCount; j++) {
722	PACL *pACE2;
723	ACE_HEADER *phACE2;
724	if (! getAceProc (curAcl, j, (LPVOID*) &pACE2)) {
725	    goto done;
726	}
727
728	phACE2 = ((ACE_HEADER *) pACE2);
729
730	/* Do NOT propagate inherited ACEs */
731	if (phACE2->AceFlags & INHERITED_ACE) {
732	    continue;
733	}
734
735	/* Skip the "read-only tag" restriction (either added above, or it
736	 * is being removed)
737	 */
738	if (phACE2->AceType == ACCESS_DENIED_ACE_TYPE) {
739	    ACCESS_DENIED_ACE *pACEd = (ACCESS_DENIED_ACE *)phACE2;
740	    if (pACEd->Mask == readOnlyMask && equalSidProc(userSid,
741	      (PSID)&(pACEd->SidStart))) {
742		acl_readOnly_found = TRUE;
743		continue;
744	    }
745	}
746
747	/* Copy the current ACE from the old to the new ACL */
748	if(! addAceProc (newAcl, ACL_REVISION, MAXDWORD, pACE2,
749	  ((PACE_HEADER) pACE2)->AceSize)) {
750	    goto done;
751	}
752    }
753
754    /* Apply the new ACL */
755    if (set_readOnly == acl_readOnly_found
756	|| setNamedSecurityInfoProc((LPSTR)nativePath, SE_FILE_OBJECT,
757	     DACL_SECURITY_INFORMATION, NULL, NULL, newAcl, NULL)
758	   == ERROR_SUCCESS ) {
759	res = 0;
760    }
761
762 done:
763    if (secDesc) ckfree(secDesc);
764    if (newAcl) ckfree((char *)newAcl);
765    if (userSid) ckfree((char *)userSid);
766    if (userDomain) ckfree(userDomain);
767
768    if (res != 0)
769	return res;
770
771    /* Run normal chmod command */
772    return chmod(nativePath, pmode);
773}
774
775/*
776 *---------------------------------------------------------------------------
777 *
778 * TestchmodCmd --
779 *
780 *	Implements the "testchmod" cmd.  Used when testing "file" command.
781 *	The only attribute used by the Windows platform is the user write
782 *	flag; if this is not set, the file is made read-only.  Otehrwise, the
783 *	file is made read-write.
784 *
785 * Results:
786 *	A standard Tcl result.
787 *
788 * Side effects:
789 *	Changes permissions of specified files.
790 *
791 *---------------------------------------------------------------------------
792 */
793
794static int
795TestchmodCmd(dummy, interp, argc, argv)
796    ClientData dummy;			/* Not used. */
797    Tcl_Interp *interp;			/* Current interpreter. */
798    int argc;				/* Number of arguments. */
799    CONST84 char **argv;		/* Argument strings. */
800{
801    int i, mode;
802    char *rest;
803
804    if (argc < 2) {
805	usage:
806	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
807		" mode file ?file ...?", NULL);
808	return TCL_ERROR;
809    }
810
811    mode = (int) strtol(argv[1], &rest, 8);
812    if ((rest == argv[1]) || (*rest != '\0')) {
813	goto usage;
814    }
815
816    for (i = 2; i < argc; i++) {
817	Tcl_DString buffer;
818	CONST char *translated;
819
820	translated = Tcl_TranslateFileName(interp, argv[i], &buffer);
821	if (translated == NULL) {
822	    return TCL_ERROR;
823	}
824	if (TestplatformChmod(translated, mode) != 0) {
825	    Tcl_AppendResult(interp, translated, ": ", Tcl_PosixError(interp),
826		    NULL);
827	    return TCL_ERROR;
828	}
829	Tcl_DStringFree(&buffer);
830    }
831    return TCL_OK;
832}
833