sl@0: /*
sl@0:  * tclWinFCmd.c
sl@0:  *
sl@0:  *      This file implements the Windows specific portion of file manipulation 
sl@0:  *      subcommands of the "file" command. 
sl@0:  *
sl@0:  * Copyright (c) 1996-1998 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: tclWinFCmd.c,v 1.35.2.5 2006/08/30 17:48:48 hobbs Exp $
sl@0:  */
sl@0: 
sl@0: #include "tclWinInt.h"
sl@0: 
sl@0: /*
sl@0:  * The following constants specify the type of callback when
sl@0:  * TraverseWinTree() calls the traverseProc()
sl@0:  */
sl@0: 
sl@0: #define DOTREE_PRED   1     /* pre-order directory  */
sl@0: #define DOTREE_POSTD  2     /* post-order directory */
sl@0: #define DOTREE_F      3     /* regular file */
sl@0: 
sl@0: /*
sl@0:  * Callbacks for file attributes code.
sl@0:  */
sl@0: 
sl@0: static int		GetWinFileAttributes _ANSI_ARGS_((Tcl_Interp *interp,
sl@0: 			    int objIndex, Tcl_Obj *fileName,
sl@0: 			    Tcl_Obj **attributePtrPtr));
sl@0: static int		GetWinFileLongName _ANSI_ARGS_((Tcl_Interp *interp,
sl@0: 			    int objIndex, Tcl_Obj *fileName,
sl@0: 			    Tcl_Obj **attributePtrPtr));
sl@0: static int		GetWinFileShortName _ANSI_ARGS_((Tcl_Interp *interp,
sl@0: 			    int objIndex, Tcl_Obj *fileName,
sl@0: 			    Tcl_Obj **attributePtrPtr));
sl@0: static int		SetWinFileAttributes _ANSI_ARGS_((Tcl_Interp *interp,
sl@0: 			    int objIndex, Tcl_Obj *fileName,
sl@0: 			    Tcl_Obj *attributePtr));
sl@0: static int		CannotSetAttribute _ANSI_ARGS_((Tcl_Interp *interp,
sl@0: 			    int objIndex, Tcl_Obj *fileName,
sl@0: 			    Tcl_Obj *attributePtr));
sl@0: 
sl@0: /*
sl@0:  * Constants and variables necessary for file attributes subcommand.
sl@0:  */
sl@0: 
sl@0: enum {
sl@0:     WIN_ARCHIVE_ATTRIBUTE,
sl@0:     WIN_HIDDEN_ATTRIBUTE,
sl@0:     WIN_LONGNAME_ATTRIBUTE,
sl@0:     WIN_READONLY_ATTRIBUTE,
sl@0:     WIN_SHORTNAME_ATTRIBUTE,
sl@0:     WIN_SYSTEM_ATTRIBUTE
sl@0: };
sl@0: 
sl@0: static int attributeArray[] = {FILE_ATTRIBUTE_ARCHIVE, FILE_ATTRIBUTE_HIDDEN,
sl@0: 	0, FILE_ATTRIBUTE_READONLY, 0, FILE_ATTRIBUTE_SYSTEM};
sl@0: 
sl@0: 
sl@0: CONST char *tclpFileAttrStrings[] = {
sl@0: 	"-archive", "-hidden", "-longname", "-readonly",
sl@0: 	"-shortname", "-system", (char *) NULL
sl@0: };
sl@0: 
sl@0: CONST TclFileAttrProcs tclpFileAttrProcs[] = {
sl@0: 	{GetWinFileAttributes, SetWinFileAttributes},
sl@0: 	{GetWinFileAttributes, SetWinFileAttributes},
sl@0: 	{GetWinFileLongName, CannotSetAttribute},
sl@0: 	{GetWinFileAttributes, SetWinFileAttributes},
sl@0: 	{GetWinFileShortName, CannotSetAttribute},
sl@0: 	{GetWinFileAttributes, SetWinFileAttributes}};
sl@0: 
sl@0: #ifdef HAVE_NO_SEH
sl@0: 
sl@0: /*
sl@0:  * Unlike Borland and Microsoft, we don't register exception handlers
sl@0:  * by pushing registration records onto the runtime stack.  Instead, we
sl@0:  * register them by creating an EXCEPTION_REGISTRATION within the activation
sl@0:  * record.
sl@0:  */
sl@0: 
sl@0: typedef struct EXCEPTION_REGISTRATION {
sl@0:     struct EXCEPTION_REGISTRATION* link;
sl@0:     EXCEPTION_DISPOSITION (*handler)( struct _EXCEPTION_RECORD*, void*,
sl@0: 				      struct _CONTEXT*, void* );
sl@0:     void* ebp;
sl@0:     void* esp;
sl@0:     int status;
sl@0: } EXCEPTION_REGISTRATION;
sl@0: 
sl@0: #endif
sl@0: 
sl@0: /*
sl@0:  * Prototype for the TraverseWinTree callback function.
sl@0:  */
sl@0: 
sl@0: typedef int (TraversalProc)(CONST TCHAR *srcPtr, CONST TCHAR *dstPtr, 
sl@0: 	int type, Tcl_DString *errorPtr);
sl@0: 
sl@0: /*
sl@0:  * Declarations for local procedures defined in this file:
sl@0:  */
sl@0: 
sl@0: static void		StatError(Tcl_Interp *interp, Tcl_Obj *fileName);
sl@0: static int		ConvertFileNameFormat(Tcl_Interp *interp, 
sl@0: 			    int objIndex, Tcl_Obj *fileName, int longShort,
sl@0: 			    Tcl_Obj **attributePtrPtr);
sl@0: static int		DoCopyFile(CONST TCHAR *srcPtr, CONST TCHAR *dstPtr);
sl@0: static int		DoCreateDirectory(CONST TCHAR *pathPtr);
sl@0: static int		DoRemoveJustDirectory(CONST TCHAR *nativeSrc, 
sl@0: 			    int ignoreError, Tcl_DString *errorPtr);
sl@0: static int		DoRemoveDirectory(Tcl_DString *pathPtr, int recursive, 
sl@0: 			    Tcl_DString *errorPtr);
sl@0: static int		DoRenameFile(CONST TCHAR *nativeSrc, CONST TCHAR *dstPtr);
sl@0: static int		TraversalCopy(CONST TCHAR *srcPtr, CONST TCHAR *dstPtr, 
sl@0: 			    int type, Tcl_DString *errorPtr);
sl@0: static int		TraversalDelete(CONST TCHAR *srcPtr, CONST TCHAR *dstPtr, 
sl@0: 			    int type, Tcl_DString *errorPtr);
sl@0: static int		TraverseWinTree(TraversalProc *traverseProc,
sl@0: 			    Tcl_DString *sourcePtr, Tcl_DString *dstPtr, 
sl@0: 			    Tcl_DString *errorPtr);
sl@0: 
sl@0: 
sl@0: /*
sl@0:  *---------------------------------------------------------------------------
sl@0:  *
sl@0:  * TclpObjRenameFile, DoRenameFile --
sl@0:  *
sl@0:  *      Changes the name of an existing file or directory, from src to dst.
sl@0:  *	If src and dst refer to the same file or directory, does nothing
sl@0:  *	and returns success.  Otherwise if dst already exists, it will be
sl@0:  *	deleted and replaced by src subject to the following conditions:
sl@0:  *	    If src is a directory, dst may be an empty directory.
sl@0:  *	    If src is a file, dst may be a file.
sl@0:  *	In any other situation where dst already exists, the rename will
sl@0:  *	fail.  
sl@0:  *
sl@0:  * Results:
sl@0:  *	If the file or directory was successfully renamed, returns TCL_OK.
sl@0:  *	Otherwise the return value is TCL_ERROR and errno is set to
sl@0:  *	indicate the error.  Some possible values for errno are:
sl@0:  *
sl@0:  *	ENAMETOOLONG: src or dst names are too long.
sl@0:  *	EACCES:     src or dst parent directory can't be read and/or written.
sl@0:  *	EEXIST:	    dst is a non-empty directory.
sl@0:  *	EINVAL:	    src is a root directory or dst is a subdirectory of src.
sl@0:  *	EISDIR:	    dst is a directory, but src is not.
sl@0:  *	ENOENT:	    src doesn't exist.  src or dst is "".
sl@0:  *	ENOTDIR:    src is a directory, but dst is not.  
sl@0:  *	EXDEV:	    src and dst are on different filesystems.
sl@0:  *
sl@0:  *	EACCES:     exists an open file already referring to src or dst.
sl@0:  *	EACCES:     src or dst specify the current working directory (NT).
sl@0:  *	EACCES:	    src specifies a char device (nul:, com1:, etc.) 
sl@0:  *	EEXIST:	    dst specifies a char device (nul:, com1:, etc.) (NT)
sl@0:  *	EACCES:	    dst specifies a char device (nul:, com1:, etc.) (95)
sl@0:  *	
sl@0:  * Side effects:
sl@0:  *	The implementation supports cross-filesystem renames of files,
sl@0:  *	but the caller should be prepared to emulate cross-filesystem
sl@0:  *	renames of directories if errno is EXDEV.
sl@0:  *
sl@0:  *---------------------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: int 
sl@0: TclpObjRenameFile(srcPathPtr, destPathPtr)
sl@0:     Tcl_Obj *srcPathPtr;
sl@0:     Tcl_Obj *destPathPtr;
sl@0: {
sl@0:     return DoRenameFile(Tcl_FSGetNativePath(srcPathPtr), 
sl@0: 			Tcl_FSGetNativePath(destPathPtr));
sl@0: }
sl@0: 
sl@0: static int
sl@0: DoRenameFile(
sl@0:     CONST TCHAR *nativeSrc,	/* Pathname of file or dir to be renamed
sl@0: 				 * (native). */ 
sl@0:     CONST TCHAR *nativeDst)	/* New pathname for file or directory
sl@0: 				 * (native). */
sl@0: {    
sl@0: #ifdef HAVE_NO_SEH
sl@0:     EXCEPTION_REGISTRATION registration;
sl@0: #endif
sl@0:     DWORD srcAttr, dstAttr;
sl@0:     int retval = -1;
sl@0: 
sl@0:     /*
sl@0:      * The MoveFile API acts differently under Win95/98 and NT
sl@0:      * WRT NULL and "". Avoid passing these values.
sl@0:      */
sl@0: 
sl@0:     if (nativeSrc == NULL || nativeSrc[0] == '\0' ||
sl@0:         nativeDst == NULL || nativeDst[0] == '\0') {
sl@0: 	Tcl_SetErrno(ENOENT);
sl@0: 	return TCL_ERROR;
sl@0:     }
sl@0: 
sl@0:     /*
sl@0:      * The MoveFile API would throw an exception under NT
sl@0:      * if one of the arguments is a char block device.
sl@0:      */
sl@0: 
sl@0: #ifndef HAVE_NO_SEH
sl@0:     __try {
sl@0: 	if ((*tclWinProcs->moveFileProc)(nativeSrc, nativeDst) != FALSE) {
sl@0: 	    retval = TCL_OK;
sl@0: 	}
sl@0:     } __except (EXCEPTION_EXECUTE_HANDLER) {}
sl@0: #else
sl@0: 
sl@0:     /*
sl@0:      * Don't have SEH available, do things the hard way.
sl@0:      * Note that this needs to be one block of asm, to avoid stack
sl@0:      * imbalance; also, it is illegal for one asm block to contain 
sl@0:      * a jump to another.
sl@0:      */
sl@0: 
sl@0:     __asm__ __volatile__ (
sl@0: 	/*
sl@0: 	 * Pick up params before messing with the stack */
sl@0: 
sl@0: 	"movl	    %[nativeDst],   %%ebx"	    "\n\t"
sl@0: 	"movl       %[nativeSrc],   %%ecx"          "\n\t"
sl@0: 
sl@0: 	/*
sl@0: 	 * Construct an EXCEPTION_REGISTRATION to protect the
sl@0: 	 * call to MoveFile
sl@0: 	 */
sl@0: 	"leal       %[registration], %%edx"         "\n\t"
sl@0: 	"movl       %%fs:0,         %%eax"          "\n\t"
sl@0: 	"movl       %%eax,          0x0(%%edx)"     "\n\t" /* link */
sl@0: 	"leal       1f,             %%eax"          "\n\t"
sl@0: 	"movl       %%eax,          0x4(%%edx)"     "\n\t" /* handler */
sl@0: 	"movl       %%ebp,          0x8(%%edx)"     "\n\t" /* ebp */
sl@0: 	"movl       %%esp,          0xc(%%edx)"     "\n\t" /* esp */
sl@0: 	"movl       $0,             0x10(%%edx)"    "\n\t" /* status */
sl@0: 	
sl@0: 	/* Link the EXCEPTION_REGISTRATION on the chain */
sl@0: 	
sl@0: 	"movl       %%edx,          %%fs:0"         "\n\t"
sl@0: 	
sl@0: 	/* Call MoveFile( nativeSrc, nativeDst ) */
sl@0: 	
sl@0: 	"pushl	    %%ebx"			    "\n\t"
sl@0: 	"pushl	    %%ecx"			    "\n\t"
sl@0: 	"movl	    %[moveFile],    %%eax"	    "\n\t"
sl@0: 	"call	    *%%eax"			    "\n\t"
sl@0: 	
sl@0: 	/* 
sl@0: 	 * Come here on normal exit.  Recover the EXCEPTION_REGISTRATION
sl@0: 	 * and put the status return from MoveFile into it.
sl@0: 	 */
sl@0: 	
sl@0: 	"movl	    %%fs:0,	    %%edx"	    "\n\t"
sl@0: 	"movl	    %%eax,	    0x10(%%edx)"    "\n\t"
sl@0: 	"jmp	    2f"				    "\n"
sl@0: 	
sl@0: 	/*
sl@0: 	 * Come here on an exception.  Recover the EXCEPTION_REGISTRATION
sl@0: 	 */
sl@0: 	
sl@0: 	"1:"					    "\t"
sl@0: 	"movl       %%fs:0,         %%edx"          "\n\t"
sl@0: 	"movl       0x8(%%edx),     %%edx"          "\n\t"
sl@0: 	
sl@0: 	/* 
sl@0: 	 * Come here however we exited.  Restore context from the
sl@0: 	 * EXCEPTION_REGISTRATION in case the stack is unbalanced.
sl@0: 	 */
sl@0: 	
sl@0: 	"2:"                                        "\t"
sl@0: 	"movl       0xc(%%edx),     %%esp"          "\n\t"
sl@0: 	"movl       0x8(%%edx),     %%ebp"          "\n\t"
sl@0: 	"movl       0x0(%%edx),     %%eax"          "\n\t"
sl@0: 	"movl       %%eax,          %%fs:0"         "\n\t"
sl@0: 	
sl@0: 	:
sl@0: 	/* No outputs */
sl@0:         :
sl@0: 	[registration]  "m"     (registration),
sl@0: 	[nativeDst]	"m"     (nativeDst),
sl@0: 	[nativeSrc]     "m"     (nativeSrc),
sl@0: 	[moveFile]      "r"     (tclWinProcs->moveFileProc)
sl@0:         :
sl@0: 	"%eax", "%ebx", "%ecx", "%edx", "memory"
sl@0:         );
sl@0:     if (registration.status != FALSE) {
sl@0: 	retval = TCL_OK;
sl@0:     }
sl@0: #endif
sl@0: 
sl@0:     if (retval != -1)
sl@0:         return retval;
sl@0: 
sl@0:     TclWinConvertError(GetLastError());
sl@0: 
sl@0:     srcAttr = (*tclWinProcs->getFileAttributesProc)(nativeSrc);
sl@0:     dstAttr = (*tclWinProcs->getFileAttributesProc)(nativeDst);
sl@0:     if (srcAttr == 0xffffffff) {
sl@0: 	if ((*tclWinProcs->getFullPathNameProc)(nativeSrc, 0, NULL, NULL) >= MAX_PATH) {
sl@0: 	    errno = ENAMETOOLONG;
sl@0: 	    return TCL_ERROR;
sl@0: 	}
sl@0: 	srcAttr = 0;
sl@0:     }
sl@0:     if (dstAttr == 0xffffffff) {
sl@0: 	if ((*tclWinProcs->getFullPathNameProc)(nativeDst, 0, NULL, NULL) >= MAX_PATH) {
sl@0: 	    errno = ENAMETOOLONG;
sl@0: 	    return TCL_ERROR;
sl@0: 	}
sl@0: 	dstAttr = 0;
sl@0:     }
sl@0: 
sl@0:     if (errno == EBADF) {
sl@0: 	errno = EACCES;
sl@0: 	return TCL_ERROR;
sl@0:     }
sl@0:     if (errno == EACCES) {
sl@0: 	decode:
sl@0: 	if (srcAttr & FILE_ATTRIBUTE_DIRECTORY) {
sl@0: 	    TCHAR *nativeSrcRest, *nativeDstRest;
sl@0: 	    CONST char **srcArgv, **dstArgv;
sl@0: 	    int size, srcArgc, dstArgc;
sl@0: 	    WCHAR nativeSrcPath[MAX_PATH];
sl@0: 	    WCHAR nativeDstPath[MAX_PATH];
sl@0: 	    Tcl_DString srcString, dstString;
sl@0: 	    CONST char *src, *dst;
sl@0: 
sl@0: 	    size = (*tclWinProcs->getFullPathNameProc)(nativeSrc, MAX_PATH, 
sl@0: 		    nativeSrcPath, &nativeSrcRest);
sl@0: 	    if ((size == 0) || (size > MAX_PATH)) {
sl@0: 		return TCL_ERROR;
sl@0: 	    }
sl@0: 	    size = (*tclWinProcs->getFullPathNameProc)(nativeDst, MAX_PATH, 
sl@0: 		    nativeDstPath, &nativeDstRest);
sl@0: 	    if ((size == 0) || (size > MAX_PATH)) {
sl@0: 		return TCL_ERROR;
sl@0: 	    }
sl@0: 	    (*tclWinProcs->charLowerProc)((TCHAR *) nativeSrcPath);
sl@0: 	    (*tclWinProcs->charLowerProc)((TCHAR *) nativeDstPath);
sl@0: 
sl@0: 	    src = Tcl_WinTCharToUtf((TCHAR *) nativeSrcPath, -1, &srcString);
sl@0: 	    dst = Tcl_WinTCharToUtf((TCHAR *) nativeDstPath, -1, &dstString);
sl@0: 	    if (strncmp(src, dst, (size_t) Tcl_DStringLength(&srcString)) == 0) {
sl@0: 		/*
sl@0: 		 * Trying to move a directory into itself.
sl@0: 		 */
sl@0: 
sl@0: 		errno = EINVAL;
sl@0: 		Tcl_DStringFree(&srcString);
sl@0: 		Tcl_DStringFree(&dstString);
sl@0: 		return TCL_ERROR;
sl@0: 	    }
sl@0: 	    Tcl_SplitPath(src, &srcArgc, &srcArgv);
sl@0: 	    Tcl_SplitPath(dst, &dstArgc, &dstArgv);
sl@0: 	    Tcl_DStringFree(&srcString);
sl@0: 	    Tcl_DStringFree(&dstString);
sl@0: 
sl@0: 	    if (srcArgc == 1) {
sl@0: 		/*
sl@0: 		 * They are trying to move a root directory.  Whether
sl@0: 		 * or not it is across filesystems, this cannot be
sl@0: 		 * done.
sl@0: 		 */
sl@0: 
sl@0: 		Tcl_SetErrno(EINVAL);
sl@0: 	    } else if ((srcArgc > 0) && (dstArgc > 0) &&
sl@0: 		    (strcmp(srcArgv[0], dstArgv[0]) != 0)) {
sl@0: 		/*
sl@0: 		 * If src is a directory and dst filesystem != src
sl@0: 		 * filesystem, errno should be EXDEV.  It is very
sl@0: 		 * important to get this behavior, so that the caller
sl@0: 		 * can respond to a cross filesystem rename by
sl@0: 		 * simulating it with copy and delete.  The MoveFile
sl@0: 		 * system call already handles the case of moving a
sl@0: 		 * file between filesystems.
sl@0: 		 */
sl@0: 
sl@0: 		Tcl_SetErrno(EXDEV);
sl@0: 	    }
sl@0: 
sl@0: 	    ckfree((char *) srcArgv);
sl@0: 	    ckfree((char *) dstArgv);
sl@0: 	}
sl@0: 
sl@0: 	/*
sl@0: 	 * Other types of access failure is that dst is a read-only
sl@0: 	 * filesystem, that an open file referred to src or dest, or that
sl@0: 	 * src or dest specified the current working directory on the
sl@0: 	 * current filesystem.  EACCES is returned for those cases.
sl@0: 	 */
sl@0: 
sl@0:     } else if (Tcl_GetErrno() == EEXIST) {
sl@0: 	/*
sl@0: 	 * Reports EEXIST any time the target already exists.  If it makes
sl@0: 	 * sense, remove the old file and try renaming again.
sl@0: 	 */
sl@0: 
sl@0: 	if (srcAttr & FILE_ATTRIBUTE_DIRECTORY) {
sl@0: 	    if (dstAttr & FILE_ATTRIBUTE_DIRECTORY) {
sl@0: 		/*
sl@0: 		 * Overwrite empty dst directory with src directory.  The
sl@0: 		 * following call will remove an empty directory.  If it
sl@0: 		 * fails, it's because it wasn't empty.
sl@0: 		 */
sl@0: 
sl@0: 		if (DoRemoveJustDirectory(nativeDst, 0, NULL) == TCL_OK) {
sl@0: 		    /*
sl@0: 		     * Now that that empty directory is gone, we can try
sl@0: 		     * renaming again.  If that fails, we'll put this empty
sl@0: 		     * directory back, for completeness.
sl@0: 		     */
sl@0: 
sl@0: 		    if ((*tclWinProcs->moveFileProc)(nativeSrc, nativeDst) != FALSE) {
sl@0: 			return TCL_OK;
sl@0: 		    }
sl@0: 
sl@0: 		    /*
sl@0: 		     * Some new error has occurred.  Don't know what it
sl@0: 		     * could be, but report this one.
sl@0: 		     */
sl@0: 
sl@0: 		    TclWinConvertError(GetLastError());
sl@0: 		    (*tclWinProcs->createDirectoryProc)(nativeDst, NULL);
sl@0: 		    (*tclWinProcs->setFileAttributesProc)(nativeDst, dstAttr);
sl@0: 		    if (Tcl_GetErrno() == EACCES) {
sl@0: 			/*
sl@0: 			 * Decode the EACCES to a more meaningful error.
sl@0: 			 */
sl@0: 
sl@0: 			goto decode;
sl@0: 		    }
sl@0: 		}
sl@0: 	    } else {	/* (dstAttr & FILE_ATTRIBUTE_DIRECTORY) == 0 */
sl@0: 		Tcl_SetErrno(ENOTDIR);
sl@0: 	    }
sl@0: 	} else {    /* (srcAttr & FILE_ATTRIBUTE_DIRECTORY) == 0 */
sl@0: 	    if (dstAttr & FILE_ATTRIBUTE_DIRECTORY) {
sl@0: 		Tcl_SetErrno(EISDIR);
sl@0: 	    } else {
sl@0: 		/*
sl@0: 		 * Overwrite existing file by:
sl@0: 		 * 
sl@0: 		 * 1. Rename existing file to temp name.
sl@0: 		 * 2. Rename old file to new name.
sl@0: 		 * 3. If success, delete temp file.  If failure,
sl@0: 		 *    put temp file back to old name.
sl@0: 		 */
sl@0: 
sl@0: 		TCHAR *nativeRest, *nativeTmp, *nativePrefix;
sl@0: 		int result, size;
sl@0: 		WCHAR tempBuf[MAX_PATH];
sl@0: 		
sl@0: 		size = (*tclWinProcs->getFullPathNameProc)(nativeDst, MAX_PATH, 
sl@0: 			tempBuf, &nativeRest);
sl@0: 		if ((size == 0) || (size > MAX_PATH) || (nativeRest == NULL)) {
sl@0: 		    return TCL_ERROR;
sl@0: 		}
sl@0: 		nativeTmp = (TCHAR *) tempBuf;
sl@0: 		((char *) nativeRest)[0] = '\0';
sl@0: 		((char *) nativeRest)[1] = '\0';    /* In case it's Unicode. */
sl@0: 
sl@0: 		result = TCL_ERROR;
sl@0: 		nativePrefix = (tclWinProcs->useWide) 
sl@0: 			? (TCHAR *) L"tclr" : (TCHAR *) "tclr";
sl@0: 		if ((*tclWinProcs->getTempFileNameProc)(nativeTmp, 
sl@0: 			nativePrefix, 0, tempBuf) != 0) {
sl@0: 		    /*
sl@0: 		     * Strictly speaking, need the following DeleteFile and
sl@0: 		     * MoveFile to be joined as an atomic operation so no
sl@0: 		     * other app comes along in the meantime and creates the
sl@0: 		     * same temp file.
sl@0: 		     */
sl@0: 		     
sl@0: 		    nativeTmp = (TCHAR *) tempBuf;
sl@0: 		    (*tclWinProcs->deleteFileProc)(nativeTmp);
sl@0: 		    if ((*tclWinProcs->moveFileProc)(nativeDst, nativeTmp) != FALSE) {
sl@0: 			if ((*tclWinProcs->moveFileProc)(nativeSrc, nativeDst) != FALSE) {
sl@0: 			    (*tclWinProcs->setFileAttributesProc)(nativeTmp, 
sl@0: 				    FILE_ATTRIBUTE_NORMAL);
sl@0: 			    (*tclWinProcs->deleteFileProc)(nativeTmp);
sl@0: 			    return TCL_OK;
sl@0: 			} else {
sl@0: 			    (*tclWinProcs->deleteFileProc)(nativeDst);
sl@0: 			    (*tclWinProcs->moveFileProc)(nativeTmp, nativeDst);
sl@0: 			}
sl@0: 		    } 
sl@0: 
sl@0: 		    /*
sl@0: 		     * Can't backup dst file or move src file.  Return that
sl@0: 		     * error.  Could happen if an open file refers to dst.
sl@0: 		     */
sl@0: 
sl@0: 		    TclWinConvertError(GetLastError());
sl@0: 		    if (Tcl_GetErrno() == EACCES) {
sl@0: 			/*
sl@0: 			 * Decode the EACCES to a more meaningful error.
sl@0: 			 */
sl@0: 
sl@0: 			goto decode;
sl@0: 		    }
sl@0: 		}
sl@0: 		return result;
sl@0: 	    }
sl@0: 	}
sl@0:     }
sl@0:     return TCL_ERROR;
sl@0: }
sl@0: 
sl@0: /*
sl@0:  *---------------------------------------------------------------------------
sl@0:  *
sl@0:  * TclpObjCopyFile, DoCopyFile --
sl@0:  *
sl@0:  *      Copy a single file (not a directory).  If dst already exists and
sl@0:  *	is not a directory, it is removed.
sl@0:  *
sl@0:  * Results:
sl@0:  *	If the file was successfully copied, returns TCL_OK.  Otherwise
sl@0:  *	the return value is TCL_ERROR and errno is set to indicate the
sl@0:  *	error.  Some possible values for errno are:
sl@0:  *
sl@0:  *	EACCES:     src or dst parent directory can't be read and/or written.
sl@0:  *	EISDIR:	    src or dst is a directory.
sl@0:  *	ENOENT:	    src doesn't exist.  src or dst is "".
sl@0:  *
sl@0:  *	EACCES:     exists an open file already referring to dst (95).
sl@0:  *	EACCES:	    src specifies a char device (nul:, com1:, etc.) (NT)
sl@0:  *	ENOENT:	    src specifies a char device (nul:, com1:, etc.) (95)
sl@0:  *
sl@0:  * Side effects:
sl@0:  *	It is not an error to copy to a char device.
sl@0:  *
sl@0:  *---------------------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: int 
sl@0: TclpObjCopyFile(srcPathPtr, destPathPtr)
sl@0:     Tcl_Obj *srcPathPtr;
sl@0:     Tcl_Obj *destPathPtr;
sl@0: {
sl@0:     return DoCopyFile(Tcl_FSGetNativePath(srcPathPtr),
sl@0: 		      Tcl_FSGetNativePath(destPathPtr));
sl@0: }
sl@0: 
sl@0: static int
sl@0: DoCopyFile(
sl@0:    CONST TCHAR *nativeSrc,	/* Pathname of file to be copied (native). */
sl@0:    CONST TCHAR *nativeDst)	/* Pathname of file to copy to (native). */
sl@0: {
sl@0: #ifdef HAVE_NO_SEH
sl@0:     EXCEPTION_REGISTRATION registration;
sl@0: #endif
sl@0:     int retval = -1;
sl@0: 
sl@0:     /*
sl@0:      * The CopyFile API acts differently under Win95/98 and NT
sl@0:      * WRT NULL and "". Avoid passing these values.
sl@0:      */
sl@0: 
sl@0:     if (nativeSrc == NULL || nativeSrc[0] == '\0' ||
sl@0:         nativeDst == NULL || nativeDst[0] == '\0') {
sl@0: 	Tcl_SetErrno(ENOENT);
sl@0: 	return TCL_ERROR;
sl@0:     }
sl@0:     
sl@0:     /*
sl@0:      * The CopyFile API would throw an exception under NT if one
sl@0:      * of the arguments is a char block device.
sl@0:      */
sl@0: 
sl@0: #ifndef HAVE_NO_SEH
sl@0:     __try {
sl@0: 	if ((*tclWinProcs->copyFileProc)(nativeSrc, nativeDst, 0) != FALSE) {
sl@0: 	    retval = TCL_OK;
sl@0: 	}
sl@0:     } __except (EXCEPTION_EXECUTE_HANDLER) {}
sl@0: #else
sl@0: 
sl@0:     /*
sl@0:      * Don't have SEH available, do things the hard way.
sl@0:      * Note that this needs to be one block of asm, to avoid stack
sl@0:      * imbalance; also, it is illegal for one asm block to contain 
sl@0:      * a jump to another.
sl@0:      */
sl@0: 
sl@0:     __asm__ __volatile__ (
sl@0: 
sl@0: 	/*
sl@0: 	 * Pick up parameters before messing with the stack
sl@0: 	 */
sl@0: 
sl@0: 	"movl       %[nativeDst],   %%ebx"          "\n\t"
sl@0:         "movl       %[nativeSrc],   %%ecx"          "\n\t"
sl@0: 	/*
sl@0: 	 * Construct an EXCEPTION_REGISTRATION to protect the
sl@0: 	 * call to CopyFile
sl@0: 	 */
sl@0: 	"leal       %[registration], %%edx"         "\n\t"
sl@0: 	"movl       %%fs:0,         %%eax"          "\n\t"
sl@0: 	"movl       %%eax,          0x0(%%edx)"     "\n\t" /* link */
sl@0: 	"leal       1f,             %%eax"          "\n\t"
sl@0: 	"movl       %%eax,          0x4(%%edx)"     "\n\t" /* handler */
sl@0: 	"movl       %%ebp,          0x8(%%edx)"     "\n\t" /* ebp */
sl@0: 	"movl       %%esp,          0xc(%%edx)"     "\n\t" /* esp */
sl@0: 	"movl       $0,             0x10(%%edx)"    "\n\t" /* status */
sl@0: 	
sl@0: 	/* Link the EXCEPTION_REGISTRATION on the chain */
sl@0: 	
sl@0: 	"movl       %%edx,          %%fs:0"         "\n\t"
sl@0: 	
sl@0: 	/* Call CopyFile( nativeSrc, nativeDst, 0 ) */
sl@0: 	
sl@0: 	"movl	    %[copyFile],    %%eax"	    "\n\t"
sl@0: 	"pushl	    $0" 			    "\n\t"
sl@0: 	"pushl	    %%ebx"			    "\n\t"
sl@0: 	"pushl	    %%ecx"			    "\n\t"
sl@0: 	"call	    *%%eax"			    "\n\t"
sl@0: 	
sl@0: 	/* 
sl@0: 	 * Come here on normal exit.  Recover the EXCEPTION_REGISTRATION
sl@0: 	 * and put the status return from CopyFile into it.
sl@0: 	 */
sl@0: 	
sl@0: 	"movl	    %%fs:0,	    %%edx"	    "\n\t"
sl@0: 	"movl	    %%eax,	    0x10(%%edx)"    "\n\t"
sl@0: 	"jmp	    2f"				    "\n"
sl@0: 	
sl@0: 	/*
sl@0: 	 * Come here on an exception.  Recover the EXCEPTION_REGISTRATION
sl@0: 	 */
sl@0: 	
sl@0: 	"1:"					    "\t"
sl@0: 	"movl       %%fs:0,         %%edx"          "\n\t"
sl@0: 	"movl       0x8(%%edx),     %%edx"          "\n\t"
sl@0: 	
sl@0: 	/* 
sl@0: 	 * Come here however we exited.  Restore context from the
sl@0: 	 * EXCEPTION_REGISTRATION in case the stack is unbalanced.
sl@0: 	 */
sl@0: 	
sl@0: 	"2:"                                        "\t"
sl@0: 	"movl       0xc(%%edx),     %%esp"          "\n\t"
sl@0: 	"movl       0x8(%%edx),     %%ebp"          "\n\t"
sl@0: 	"movl       0x0(%%edx),     %%eax"          "\n\t"
sl@0: 	"movl       %%eax,          %%fs:0"         "\n\t"
sl@0: 	
sl@0: 	:
sl@0: 	/* No outputs */
sl@0:         :
sl@0: 	[registration]  "m"     (registration),
sl@0: 	[nativeDst]	"m"     (nativeDst),
sl@0: 	[nativeSrc]     "m"     (nativeSrc),
sl@0: 	[copyFile]      "r"     (tclWinProcs->copyFileProc)
sl@0:         :
sl@0: 	"%eax", "%ebx", "%ecx", "%edx", "memory"
sl@0:         );
sl@0:     if (registration.status != FALSE) {
sl@0: 	retval = TCL_OK;
sl@0:     }
sl@0: #endif
sl@0: 
sl@0:     if (retval != -1)
sl@0:         return retval;
sl@0: 
sl@0:     TclWinConvertError(GetLastError());
sl@0:     if (Tcl_GetErrno() == EBADF) {
sl@0: 	Tcl_SetErrno(EACCES);
sl@0: 	return TCL_ERROR;
sl@0:     }
sl@0:     if (Tcl_GetErrno() == EACCES) {
sl@0: 	DWORD srcAttr, dstAttr;
sl@0: 
sl@0: 	srcAttr = (*tclWinProcs->getFileAttributesProc)(nativeSrc);
sl@0: 	dstAttr = (*tclWinProcs->getFileAttributesProc)(nativeDst);
sl@0: 	if (srcAttr != 0xffffffff) {
sl@0: 	    if (dstAttr == 0xffffffff) {
sl@0: 		dstAttr = 0;
sl@0: 	    }
sl@0: 	    if ((srcAttr & FILE_ATTRIBUTE_DIRECTORY) ||
sl@0: 		    (dstAttr & FILE_ATTRIBUTE_DIRECTORY)) {
sl@0: 		if (srcAttr & FILE_ATTRIBUTE_REPARSE_POINT) {
sl@0: 		    /* Source is a symbolic link -- copy it */
sl@0: 		    if (TclWinSymLinkCopyDirectory(nativeSrc, nativeDst) == 0) {
sl@0: 		        return TCL_OK;
sl@0: 		    }
sl@0: 		}
sl@0: 		Tcl_SetErrno(EISDIR);
sl@0: 	    }
sl@0: 	    if (dstAttr & FILE_ATTRIBUTE_READONLY) {
sl@0: 		(*tclWinProcs->setFileAttributesProc)(nativeDst, 
sl@0: 			dstAttr & ~((DWORD)FILE_ATTRIBUTE_READONLY));
sl@0: 		if ((*tclWinProcs->copyFileProc)(nativeSrc, nativeDst, 0) != FALSE) {
sl@0: 		    return TCL_OK;
sl@0: 		}
sl@0: 		/*
sl@0: 		 * Still can't copy onto dst.  Return that error, and
sl@0: 		 * restore attributes of dst.
sl@0: 		 */
sl@0: 
sl@0: 		TclWinConvertError(GetLastError());
sl@0: 		(*tclWinProcs->setFileAttributesProc)(nativeDst, dstAttr);
sl@0: 	    }
sl@0: 	}
sl@0:     }
sl@0:     return TCL_ERROR;
sl@0: }
sl@0: 
sl@0: /*
sl@0:  *---------------------------------------------------------------------------
sl@0:  *
sl@0:  * TclpObjDeleteFile, TclpDeleteFile --
sl@0:  *
sl@0:  *      Removes a single file (not a directory).
sl@0:  *
sl@0:  * Results:
sl@0:  *	If the file was successfully deleted, returns TCL_OK.  Otherwise
sl@0:  *	the return value is TCL_ERROR and errno is set to indicate the
sl@0:  *	error.  Some possible values for errno are:
sl@0:  *
sl@0:  *	EACCES:     a parent directory can't be read and/or written.
sl@0:  *	EISDIR:	    path is a directory.
sl@0:  *	ENOENT:	    path doesn't exist or is "".
sl@0:  *
sl@0:  *	EACCES:     exists an open file already referring to path.
sl@0:  *	EACCES:	    path is a char device (nul:, com1:, etc.)
sl@0:  *
sl@0:  * Side effects:
sl@0:  *      The file is deleted, even if it is read-only.
sl@0:  *
sl@0:  *---------------------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: int 
sl@0: TclpObjDeleteFile(pathPtr)
sl@0:     Tcl_Obj *pathPtr;
sl@0: {
sl@0:     return TclpDeleteFile(Tcl_FSGetNativePath(pathPtr));
sl@0: }
sl@0: 
sl@0: int
sl@0: TclpDeleteFile(
sl@0:     CONST TCHAR *nativePath)	/* Pathname of file to be removed (native). */
sl@0: {
sl@0:     DWORD attr;
sl@0: 
sl@0:     /*
sl@0:      * The DeleteFile API acts differently under Win95/98 and NT
sl@0:      * WRT NULL and "". Avoid passing these values.
sl@0:      */
sl@0: 
sl@0:     if (nativePath == NULL || nativePath[0] == '\0') {
sl@0: 	Tcl_SetErrno(ENOENT);
sl@0: 	return TCL_ERROR;
sl@0:     }
sl@0: 
sl@0:     if ((*tclWinProcs->deleteFileProc)(nativePath) != FALSE) {
sl@0: 	return TCL_OK;
sl@0:     }
sl@0:     TclWinConvertError(GetLastError());
sl@0: 
sl@0:     if (Tcl_GetErrno() == EACCES) {
sl@0:         attr = (*tclWinProcs->getFileAttributesProc)(nativePath);
sl@0: 	if (attr != 0xffffffff) {
sl@0: 	    if (attr & FILE_ATTRIBUTE_DIRECTORY) {
sl@0: 		if (attr & FILE_ATTRIBUTE_REPARSE_POINT) {
sl@0: 		    /* It is a symbolic link -- remove it */
sl@0: 		    if (TclWinSymLinkDelete(nativePath, 0) == 0) {
sl@0: 		        return TCL_OK;
sl@0: 		    }
sl@0: 		}
sl@0: 		
sl@0: 		/* 
sl@0: 		 * If we fall through here, it is a directory.
sl@0: 		 * 
sl@0: 		 * Windows NT reports removing a directory as EACCES instead
sl@0: 		 * of EISDIR.
sl@0: 		 */
sl@0: 
sl@0: 		Tcl_SetErrno(EISDIR);
sl@0: 	    } else if (attr & FILE_ATTRIBUTE_READONLY) {
sl@0: 		int res = (*tclWinProcs->setFileAttributesProc)(nativePath, 
sl@0: 			attr & ~((DWORD)FILE_ATTRIBUTE_READONLY));
sl@0: 		if ((res != 0) && ((*tclWinProcs->deleteFileProc)(nativePath)
sl@0: 			!= FALSE)) {
sl@0: 		    return TCL_OK;
sl@0: 		}
sl@0: 		TclWinConvertError(GetLastError());
sl@0: 		if (res != 0) {
sl@0: 		    (*tclWinProcs->setFileAttributesProc)(nativePath, attr);
sl@0: 		}
sl@0: 	    }
sl@0: 	}
sl@0:     } else if (Tcl_GetErrno() == ENOENT) {
sl@0:         attr = (*tclWinProcs->getFileAttributesProc)(nativePath);
sl@0: 	if (attr != 0xffffffff) {
sl@0: 	    if (attr & FILE_ATTRIBUTE_DIRECTORY) {
sl@0: 	    	/*
sl@0: 		 * Windows 95 reports removing a directory as ENOENT instead 
sl@0: 		 * of EISDIR. 
sl@0: 		 */
sl@0: 
sl@0: 		Tcl_SetErrno(EISDIR);
sl@0: 	    }
sl@0: 	}
sl@0:     } else if (Tcl_GetErrno() == EINVAL) {
sl@0: 	/*
sl@0: 	 * Windows NT reports removing a char device as EINVAL instead of
sl@0: 	 * EACCES.
sl@0: 	 */
sl@0: 
sl@0: 	Tcl_SetErrno(EACCES);
sl@0:     }
sl@0: 
sl@0:     return TCL_ERROR;
sl@0: }
sl@0: 
sl@0: /*
sl@0:  *---------------------------------------------------------------------------
sl@0:  *
sl@0:  * TclpObjCreateDirectory --
sl@0:  *
sl@0:  *      Creates the specified directory.  All parent directories of the
sl@0:  *	specified directory must already exist.  The directory is
sl@0:  *	automatically created with permissions so that user can access
sl@0:  *	the new directory and create new files or subdirectories in it.
sl@0:  *
sl@0:  * Results:
sl@0:  *	If the directory was successfully created, returns TCL_OK.
sl@0:  *	Otherwise the return value is TCL_ERROR and errno is set to
sl@0:  *	indicate the error.  Some possible values for errno are:
sl@0:  *
sl@0:  *	EACCES:     a parent directory can't be read and/or written.
sl@0:  *	EEXIST:	    path already exists.
sl@0:  *	ENOENT:	    a parent directory doesn't exist.
sl@0:  *
sl@0:  * Side effects:
sl@0:  *      A directory is created.
sl@0:  *
sl@0:  *---------------------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: int 
sl@0: TclpObjCreateDirectory(pathPtr)
sl@0:     Tcl_Obj *pathPtr;
sl@0: {
sl@0:     return DoCreateDirectory(Tcl_FSGetNativePath(pathPtr));
sl@0: }
sl@0: 
sl@0: static int
sl@0: DoCreateDirectory(
sl@0:     CONST TCHAR *nativePath)	/* Pathname of directory to create (native). */
sl@0: {
sl@0:     DWORD error;
sl@0:     if ((*tclWinProcs->createDirectoryProc)(nativePath, NULL) == 0) {
sl@0: 	error = GetLastError();
sl@0: 	TclWinConvertError(error);
sl@0: 	return TCL_ERROR;
sl@0:     }   
sl@0:     return TCL_OK;
sl@0: }
sl@0: 
sl@0: /*
sl@0:  *---------------------------------------------------------------------------
sl@0:  *
sl@0:  * TclpObjCopyDirectory --
sl@0:  *
sl@0:  *      Recursively copies a directory.  The target directory dst must
sl@0:  *	not already exist.  Note that this function does not merge two
sl@0:  *	directory hierarchies, even if the target directory is an an
sl@0:  *	empty directory.
sl@0:  *
sl@0:  * Results:
sl@0:  *	If the directory was successfully copied, returns TCL_OK.
sl@0:  *	Otherwise the return value is TCL_ERROR, errno is set to indicate
sl@0:  *	the error, and the pathname of the file that caused the error
sl@0:  *	is stored in errorPtr.  See TclpCreateDirectory and TclpCopyFile
sl@0:  *	for a description of possible values for errno.
sl@0:  *
sl@0:  * Side effects:
sl@0:  *      An exact copy of the directory hierarchy src will be created
sl@0:  *	with the name dst.  If an error occurs, the error will
sl@0:  *      be returned immediately, and remaining files will not be
sl@0:  *	processed.
sl@0:  *
sl@0:  *---------------------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: int 
sl@0: TclpObjCopyDirectory(srcPathPtr, destPathPtr, errorPtr)
sl@0:     Tcl_Obj *srcPathPtr;
sl@0:     Tcl_Obj *destPathPtr;
sl@0:     Tcl_Obj **errorPtr;
sl@0: {
sl@0:     Tcl_DString ds;
sl@0:     Tcl_DString srcString, dstString;
sl@0:     Tcl_Obj *normSrcPtr, *normDestPtr;
sl@0:     int ret;
sl@0: 
sl@0:     normSrcPtr = Tcl_FSGetNormalizedPath(NULL,srcPathPtr);
sl@0:     if (normSrcPtr == NULL) {
sl@0: 	return TCL_ERROR;
sl@0:     }
sl@0:     Tcl_WinUtfToTChar(Tcl_GetString(normSrcPtr), -1, &srcString);
sl@0:     normDestPtr = Tcl_FSGetNormalizedPath(NULL,destPathPtr);
sl@0:     if (normDestPtr == NULL) {
sl@0: 	return TCL_ERROR;
sl@0:     }
sl@0:     Tcl_WinUtfToTChar(Tcl_GetString(normDestPtr), -1, &dstString);
sl@0: 
sl@0:     ret = TraverseWinTree(TraversalCopy, &srcString, &dstString, &ds);
sl@0: 
sl@0:     Tcl_DStringFree(&srcString);
sl@0:     Tcl_DStringFree(&dstString);
sl@0: 
sl@0:     if (ret != TCL_OK) {
sl@0: 	if (!strcmp(Tcl_DStringValue(&ds), Tcl_GetString(normSrcPtr))) {
sl@0: 	    *errorPtr = srcPathPtr;
sl@0: 	} else if (!strcmp(Tcl_DStringValue(&ds), Tcl_GetString(normDestPtr))) {
sl@0: 	    *errorPtr = destPathPtr;
sl@0: 	} else {
sl@0: 	    *errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1);
sl@0: 	}
sl@0: 	Tcl_DStringFree(&ds);
sl@0: 	Tcl_IncrRefCount(*errorPtr);
sl@0:     }
sl@0:     return ret;
sl@0: }
sl@0: 
sl@0: /*
sl@0:  *----------------------------------------------------------------------
sl@0:  *
sl@0:  * TclpObjRemoveDirectory, DoRemoveDirectory -- 
sl@0:  *
sl@0:  *	Removes directory (and its contents, if the recursive flag is set).
sl@0:  *
sl@0:  * Results:
sl@0:  *	If the directory was successfully removed, returns TCL_OK.
sl@0:  *	Otherwise the return value is TCL_ERROR, errno is set to indicate
sl@0:  *	the error, and the pathname of the file that caused the error
sl@0:  *	is stored in errorPtr.  Some possible values for errno are:
sl@0:  *
sl@0:  *	EACCES:     path directory can't be read and/or written.
sl@0:  *	EEXIST:	    path is a non-empty directory.
sl@0:  *	EINVAL:	    path is root directory or current directory.
sl@0:  *	ENOENT:	    path doesn't exist or is "".
sl@0:  * 	ENOTDIR:    path is not a directory.
sl@0:  *
sl@0:  *	EACCES:	    path is a char device (nul:, com1:, etc.) (95)
sl@0:  *	EINVAL:	    path is a char device (nul:, com1:, etc.) (NT)
sl@0:  *
sl@0:  * Side effects:
sl@0:  *	Directory removed.  If an error occurs, the error will be returned
sl@0:  *	immediately, and remaining files will not be deleted.
sl@0:  *
sl@0:  *----------------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: int 
sl@0: TclpObjRemoveDirectory(pathPtr, recursive, errorPtr)
sl@0:     Tcl_Obj *pathPtr;
sl@0:     int recursive;
sl@0:     Tcl_Obj **errorPtr;
sl@0: {
sl@0:     Tcl_DString ds;
sl@0:     Tcl_Obj *normPtr = NULL;
sl@0:     int ret;
sl@0:     if (recursive) {
sl@0: 	/* 
sl@0: 	 * In the recursive case, the string rep is used to construct a
sl@0: 	 * Tcl_DString which may be used extensively, so we can't
sl@0: 	 * optimize this case easily.
sl@0: 	 */
sl@0: 	Tcl_DString native;
sl@0: 	normPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
sl@0: 	if (normPtr == NULL) {
sl@0: 	    return TCL_ERROR;
sl@0: 	}
sl@0: 	Tcl_WinUtfToTChar(Tcl_GetString(normPtr), -1, &native);
sl@0: 	ret = DoRemoveDirectory(&native, recursive, &ds);
sl@0: 	Tcl_DStringFree(&native);
sl@0:     } else {
sl@0: 	ret = DoRemoveJustDirectory(Tcl_FSGetNativePath(pathPtr), 
sl@0: 				    0, &ds);
sl@0:     }
sl@0:     if (ret != TCL_OK) {
sl@0: 	int len = Tcl_DStringLength(&ds);
sl@0: 	if (len > 0) {
sl@0: 	    if (normPtr != NULL 
sl@0: 	      && !strcmp(Tcl_DStringValue(&ds), Tcl_GetString(normPtr))) {
sl@0: 		*errorPtr = pathPtr;
sl@0: 	    } else {
sl@0: 		*errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1);
sl@0: 	    }
sl@0: 	    Tcl_IncrRefCount(*errorPtr);
sl@0: 	}
sl@0: 	Tcl_DStringFree(&ds);
sl@0:     }
sl@0:     return ret;
sl@0: }
sl@0: 
sl@0: static int
sl@0: DoRemoveJustDirectory(
sl@0:     CONST TCHAR *nativePath,	/* Pathname of directory to be removed
sl@0: 				 * (native). */
sl@0:     int ignoreError,		/* If non-zero, don't initialize the
sl@0:                   		 * errorPtr under some circumstances
sl@0:                   		 * on return. */
sl@0:     Tcl_DString *errorPtr)	/* If non-NULL, uninitialized or free
sl@0: 				 * DString filled with UTF-8 name of file
sl@0: 				 * causing error. */
sl@0: {
sl@0:     /*
sl@0:      * The RemoveDirectory API acts differently under Win95/98 and NT
sl@0:      * WRT NULL and "". Avoid passing these values.
sl@0:      */
sl@0: 
sl@0:     if (nativePath == NULL || nativePath[0] == '\0') {
sl@0: 	Tcl_SetErrno(ENOENT);
sl@0: 	goto end;
sl@0:     }
sl@0: 
sl@0:     if ((*tclWinProcs->removeDirectoryProc)(nativePath) != FALSE) {
sl@0: 	return TCL_OK;
sl@0:     }
sl@0:     TclWinConvertError(GetLastError());
sl@0: 
sl@0:     if (Tcl_GetErrno() == EACCES) {
sl@0: 	DWORD attr = (*tclWinProcs->getFileAttributesProc)(nativePath);
sl@0: 	if (attr != 0xffffffff) {
sl@0: 	    if ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0) {
sl@0: 		/* 
sl@0: 		 * Windows 95 reports calling RemoveDirectory on a file as an 
sl@0: 		 * EACCES, not an ENOTDIR.
sl@0: 		 */
sl@0: 		
sl@0: 		Tcl_SetErrno(ENOTDIR);
sl@0: 		goto end;
sl@0: 	    }
sl@0: 
sl@0: 	    if (attr & FILE_ATTRIBUTE_REPARSE_POINT) {
sl@0: 		/* It is a symbolic link -- remove it */
sl@0: 		if (TclWinSymLinkDelete(nativePath, 1) != 0) {
sl@0: 		    goto end;
sl@0: 		}
sl@0: 	    }
sl@0: 	    
sl@0: 	    if (attr & FILE_ATTRIBUTE_READONLY) {
sl@0: 		attr &= ~FILE_ATTRIBUTE_READONLY;
sl@0: 		if ((*tclWinProcs->setFileAttributesProc)(nativePath, attr) == FALSE) {
sl@0: 		    goto end;
sl@0: 		}
sl@0: 		if ((*tclWinProcs->removeDirectoryProc)(nativePath) != FALSE) {
sl@0: 		    return TCL_OK;
sl@0: 		}
sl@0: 		TclWinConvertError(GetLastError());
sl@0: 		(*tclWinProcs->setFileAttributesProc)(nativePath, 
sl@0: 			attr | FILE_ATTRIBUTE_READONLY);
sl@0: 	    }
sl@0: 
sl@0: 	    /* 
sl@0: 	     * Windows 95 and Win32s report removing a non-empty directory 
sl@0: 	     * as EACCES, not EEXIST.  If the directory is not empty,
sl@0: 	     * change errno so caller knows what's going on.
sl@0: 	     */
sl@0: 
sl@0: 	    if (TclWinGetPlatformId() != VER_PLATFORM_WIN32_NT) {
sl@0: 		CONST char *path, *find;
sl@0: 		HANDLE handle;
sl@0: 		WIN32_FIND_DATAA data;
sl@0: 		Tcl_DString buffer;
sl@0: 		int len;
sl@0: 
sl@0: 		path = (CONST char *) nativePath;
sl@0: 
sl@0: 		Tcl_DStringInit(&buffer);
sl@0: 		len = strlen(path);
sl@0: 		find = Tcl_DStringAppend(&buffer, path, len);
sl@0: 		if ((len > 0) && (find[len - 1] != '\\')) {
sl@0: 		    Tcl_DStringAppend(&buffer, "\\", 1);
sl@0: 		}
sl@0: 		find = Tcl_DStringAppend(&buffer, "*.*", 3);
sl@0: 		handle = FindFirstFileA(find, &data);
sl@0: 		if (handle != INVALID_HANDLE_VALUE) {
sl@0: 		    while (1) {
sl@0: 			if ((strcmp(data.cFileName, ".") != 0)
sl@0: 				&& (strcmp(data.cFileName, "..") != 0)) {
sl@0: 			    /*
sl@0: 			     * Found something in this directory.
sl@0: 			     */
sl@0: 
sl@0: 			    Tcl_SetErrno(EEXIST);
sl@0: 			    break;
sl@0: 			}
sl@0: 			if (FindNextFileA(handle, &data) == FALSE) {
sl@0: 			    break;
sl@0: 			}
sl@0: 		    }
sl@0: 		    FindClose(handle);
sl@0: 		}
sl@0: 		Tcl_DStringFree(&buffer);
sl@0: 	    }
sl@0: 	}
sl@0:     }
sl@0:     if (Tcl_GetErrno() == ENOTEMPTY) {
sl@0: 	/* 
sl@0: 	 * The caller depends on EEXIST to signify that the directory is
sl@0: 	 * not empty, not ENOTEMPTY. 
sl@0: 	 */
sl@0: 
sl@0: 	Tcl_SetErrno(EEXIST);
sl@0:     }
sl@0:     if ((ignoreError != 0) && (Tcl_GetErrno() == EEXIST)) {
sl@0: 	/* 
sl@0: 	 * If we're being recursive, this error may actually
sl@0: 	 * be ok, so we don't want to initialise the errorPtr
sl@0: 	 * yet.
sl@0: 	 */
sl@0: 	return TCL_ERROR;
sl@0:     }
sl@0: 
sl@0:     end:
sl@0:     if (errorPtr != NULL) {
sl@0: 	Tcl_WinTCharToUtf(nativePath, -1, errorPtr);
sl@0:     }
sl@0:     return TCL_ERROR;
sl@0: 
sl@0: }
sl@0: 
sl@0: static int
sl@0: DoRemoveDirectory(
sl@0:     Tcl_DString *pathPtr,	/* Pathname of directory to be removed
sl@0: 				 * (native). */
sl@0:     int recursive,		/* If non-zero, removes directories that
sl@0: 				 * are nonempty.  Otherwise, will only remove
sl@0: 				 * empty directories. */
sl@0:     Tcl_DString *errorPtr)	/* If non-NULL, uninitialized or free
sl@0: 				 * DString filled with UTF-8 name of file
sl@0: 				 * causing error. */
sl@0: {
sl@0:     int res = DoRemoveJustDirectory(Tcl_DStringValue(pathPtr), recursive, 
sl@0: 				    errorPtr);
sl@0:     
sl@0:     if ((res == TCL_ERROR) && (recursive != 0) && (Tcl_GetErrno() == EEXIST)) {
sl@0: 	/*
sl@0: 	 * The directory is nonempty, but the recursive flag has been
sl@0: 	 * specified, so we recursively remove all the files in the directory.
sl@0: 	 */
sl@0: 	return TraverseWinTree(TraversalDelete, pathPtr, NULL, errorPtr);
sl@0:     } else {
sl@0: 	return res;
sl@0:     }
sl@0: }
sl@0: 
sl@0: /*
sl@0:  *---------------------------------------------------------------------------
sl@0:  *
sl@0:  * TraverseWinTree --
sl@0:  *
sl@0:  *      Traverse directory tree specified by sourcePtr, calling the function 
sl@0:  *	traverseProc for each file and directory encountered.  If destPtr 
sl@0:  *	is non-null, each of name in the sourcePtr directory is appended to 
sl@0:  *	the directory specified by destPtr and passed as the second argument 
sl@0:  *	to traverseProc() .
sl@0:  *
sl@0:  * Results:
sl@0:  *      Standard Tcl result.
sl@0:  *
sl@0:  * Side effects:
sl@0:  *      None caused by TraverseWinTree, however the user specified 
sl@0:  *	traverseProc() may change state.  If an error occurs, the error will
sl@0:  *      be returned immediately, and remaining files will not be processed.
sl@0:  *
sl@0:  *---------------------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: static int 
sl@0: TraverseWinTree(
sl@0:     TraversalProc *traverseProc,/* Function to call for every file and
sl@0: 				 * directory in source hierarchy. */
sl@0:     Tcl_DString *sourcePtr,	/* Pathname of source directory to be
sl@0: 				 * traversed (native). */
sl@0:     Tcl_DString *targetPtr,	/* Pathname of directory to traverse in
sl@0: 				 * parallel with source directory (native),
sl@0: 				 * may be NULL. */
sl@0:     Tcl_DString *errorPtr)	/* If non-NULL, uninitialized or free
sl@0: 				 * DString filled with UTF-8 name of file
sl@0: 				 * causing error. */
sl@0: {
sl@0:     DWORD sourceAttr;
sl@0:     TCHAR *nativeSource, *nativeTarget, *nativeErrfile;
sl@0:     int result, found, sourceLen, targetLen, oldSourceLen, oldTargetLen;
sl@0:     HANDLE handle;
sl@0:     WIN32_FIND_DATAT data;
sl@0: 
sl@0:     nativeErrfile = NULL;
sl@0:     result = TCL_OK;
sl@0:     oldTargetLen = 0;		/* lint. */
sl@0: 
sl@0:     nativeSource = (TCHAR *) Tcl_DStringValue(sourcePtr);
sl@0:     nativeTarget = (TCHAR *) (targetPtr == NULL 
sl@0: 			      ? NULL : Tcl_DStringValue(targetPtr));
sl@0:     
sl@0:     oldSourceLen = Tcl_DStringLength(sourcePtr);
sl@0:     sourceAttr = (*tclWinProcs->getFileAttributesProc)(nativeSource);
sl@0:     if (sourceAttr == 0xffffffff) {
sl@0: 	nativeErrfile = nativeSource;
sl@0: 	goto end;
sl@0:     }
sl@0:     if ((sourceAttr & FILE_ATTRIBUTE_DIRECTORY) == 0) {
sl@0: 	/*
sl@0: 	 * Process the regular file
sl@0: 	 */
sl@0: 
sl@0: 	return (*traverseProc)(nativeSource, nativeTarget, DOTREE_F, errorPtr);
sl@0:     }
sl@0: 
sl@0:     if (tclWinProcs->useWide) {
sl@0: 	Tcl_DStringAppend(sourcePtr, (char *) L"\\*.*", 4 * sizeof(WCHAR) + 1);
sl@0: 	Tcl_DStringSetLength(sourcePtr, Tcl_DStringLength(sourcePtr) - 1);
sl@0:     } else {
sl@0: 	Tcl_DStringAppend(sourcePtr, "\\*.*", 4);
sl@0:     }
sl@0:     nativeSource = (TCHAR *) Tcl_DStringValue(sourcePtr);
sl@0:     handle = (*tclWinProcs->findFirstFileProc)(nativeSource, &data);
sl@0:     if (handle == INVALID_HANDLE_VALUE) {      
sl@0: 	/* 
sl@0: 	 * Can't read directory
sl@0: 	 */
sl@0: 
sl@0: 	TclWinConvertError(GetLastError());
sl@0: 	nativeErrfile = nativeSource;
sl@0: 	goto end;
sl@0:     }
sl@0: 
sl@0:     nativeSource[oldSourceLen + 1] = '\0';
sl@0:     Tcl_DStringSetLength(sourcePtr, oldSourceLen);
sl@0:     result = (*traverseProc)(nativeSource, nativeTarget, DOTREE_PRED, errorPtr);
sl@0:     if (result != TCL_OK) {
sl@0: 	FindClose(handle);
sl@0: 	return result;
sl@0:     }
sl@0: 
sl@0:     sourceLen = oldSourceLen;
sl@0: 
sl@0:     if (tclWinProcs->useWide) {
sl@0: 	sourceLen += sizeof(WCHAR);
sl@0: 	Tcl_DStringAppend(sourcePtr, (char *) L"\\", sizeof(WCHAR) + 1);
sl@0: 	Tcl_DStringSetLength(sourcePtr, sourceLen);
sl@0:     } else {
sl@0: 	sourceLen += 1;
sl@0: 	Tcl_DStringAppend(sourcePtr, "\\", 1);
sl@0:     }
sl@0:     if (targetPtr != NULL) {
sl@0: 	oldTargetLen = Tcl_DStringLength(targetPtr);
sl@0: 
sl@0: 	targetLen = oldTargetLen;
sl@0: 	if (tclWinProcs->useWide) {
sl@0: 	    targetLen += sizeof(WCHAR);
sl@0: 	    Tcl_DStringAppend(targetPtr, (char *) L"\\", sizeof(WCHAR) + 1);
sl@0: 	    Tcl_DStringSetLength(targetPtr, targetLen);
sl@0: 	} else {
sl@0: 	    targetLen += 1;
sl@0: 	    Tcl_DStringAppend(targetPtr, "\\", 1);
sl@0: 	}
sl@0:     }
sl@0: 
sl@0:     found = 1;
sl@0:     for ( ; found; found = (*tclWinProcs->findNextFileProc)(handle, &data)) {
sl@0: 	TCHAR *nativeName;
sl@0: 	int len;
sl@0: 
sl@0: 	if (tclWinProcs->useWide) {
sl@0: 	    WCHAR *wp;
sl@0: 
sl@0: 	    wp = data.w.cFileName;
sl@0: 	    if (*wp == '.') {
sl@0: 		wp++;
sl@0: 		if (*wp == '.') {
sl@0: 		    wp++;
sl@0: 		}
sl@0: 		if (*wp == '\0') {
sl@0: 		    continue;
sl@0: 		}
sl@0: 	    }
sl@0: 	    nativeName = (TCHAR *) data.w.cFileName;
sl@0: 	    len = wcslen(data.w.cFileName) * sizeof(WCHAR);
sl@0: 	} else {
sl@0: 	    if ((strcmp(data.a.cFileName, ".") == 0) 
sl@0: 		    || (strcmp(data.a.cFileName, "..") == 0)) {
sl@0: 		continue;
sl@0: 	    }
sl@0: 	    nativeName = (TCHAR *) data.a.cFileName;
sl@0: 	    len = strlen(data.a.cFileName);
sl@0: 	}
sl@0: 
sl@0: 	/* 
sl@0: 	 * Append name after slash, and recurse on the file. 
sl@0: 	 */
sl@0: 
sl@0: 	Tcl_DStringAppend(sourcePtr, (char *) nativeName, len + 1);
sl@0: 	Tcl_DStringSetLength(sourcePtr, Tcl_DStringLength(sourcePtr) - 1);
sl@0: 	if (targetPtr != NULL) {
sl@0: 	    Tcl_DStringAppend(targetPtr, (char *) nativeName, len + 1);
sl@0: 	    Tcl_DStringSetLength(targetPtr, Tcl_DStringLength(targetPtr) - 1);
sl@0: 	}
sl@0: 	result = TraverseWinTree(traverseProc, sourcePtr, targetPtr, 
sl@0: 		errorPtr);
sl@0: 	if (result != TCL_OK) {
sl@0: 	    break;
sl@0: 	}
sl@0: 
sl@0: 	/*
sl@0: 	 * Remove name after slash.
sl@0: 	 */
sl@0: 
sl@0: 	Tcl_DStringSetLength(sourcePtr, sourceLen);
sl@0: 	if (targetPtr != NULL) {
sl@0: 	    Tcl_DStringSetLength(targetPtr, targetLen);
sl@0: 	}
sl@0:     }
sl@0:     FindClose(handle);
sl@0: 
sl@0:     /*
sl@0:      * Strip off the trailing slash we added
sl@0:      */
sl@0: 
sl@0:     Tcl_DStringSetLength(sourcePtr, oldSourceLen + 1);
sl@0:     Tcl_DStringSetLength(sourcePtr, oldSourceLen);
sl@0:     if (targetPtr != NULL) {
sl@0: 	Tcl_DStringSetLength(targetPtr, oldTargetLen + 1);
sl@0: 	Tcl_DStringSetLength(targetPtr, oldTargetLen);
sl@0:     }
sl@0:     if (result == TCL_OK) {
sl@0: 	/*
sl@0: 	 * Call traverseProc() on a directory after visiting all the
sl@0: 	 * files in that directory.
sl@0: 	 */
sl@0: 
sl@0: 	result = (*traverseProc)(Tcl_DStringValue(sourcePtr), 
sl@0: 			(targetPtr == NULL ? NULL : Tcl_DStringValue(targetPtr)), 
sl@0: 			DOTREE_POSTD, errorPtr);
sl@0:     }
sl@0:     end:
sl@0:     if (nativeErrfile != NULL) {
sl@0: 	TclWinConvertError(GetLastError());
sl@0: 	if (errorPtr != NULL) {
sl@0: 	    Tcl_WinTCharToUtf(nativeErrfile, -1, errorPtr);
sl@0: 	}
sl@0: 	result = TCL_ERROR;
sl@0:     }
sl@0: 
sl@0:     return result;
sl@0: }
sl@0: 
sl@0: /*
sl@0:  *----------------------------------------------------------------------
sl@0:  *
sl@0:  * TraversalCopy
sl@0:  *
sl@0:  *      Called from TraverseUnixTree in order to execute a recursive
sl@0:  *      copy of a directory.
sl@0:  *
sl@0:  * Results:
sl@0:  *      Standard Tcl result.
sl@0:  *
sl@0:  * Side effects:
sl@0:  *      Depending on the value of type, src may be copied to dst.
sl@0:  *      
sl@0:  *----------------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: static int 
sl@0: TraversalCopy(
sl@0:     CONST TCHAR *nativeSrc,	/* Source pathname to copy. */
sl@0:     CONST TCHAR *nativeDst,	/* Destination pathname of copy. */
sl@0:     int type,			/* Reason for call - see TraverseWinTree() */
sl@0:     Tcl_DString *errorPtr)	/* If non-NULL, initialized DString filled
sl@0: 				 * with UTF-8 name of file causing error. */
sl@0: {
sl@0:     switch (type) {
sl@0: 	case DOTREE_F: {
sl@0: 	    if (DoCopyFile(nativeSrc, nativeDst) == TCL_OK) {
sl@0: 		return TCL_OK;
sl@0: 	    }
sl@0: 	    break;
sl@0: 	}
sl@0: 	case DOTREE_PRED: {
sl@0: 	    if (DoCreateDirectory(nativeDst) == TCL_OK) {
sl@0: 		DWORD attr = (*tclWinProcs->getFileAttributesProc)(nativeSrc);
sl@0: 		if ((*tclWinProcs->setFileAttributesProc)(nativeDst, attr) != FALSE) {
sl@0: 		    return TCL_OK;
sl@0: 		}
sl@0: 		TclWinConvertError(GetLastError());
sl@0: 	    }
sl@0: 	    break;
sl@0: 	}
sl@0:         case DOTREE_POSTD: {
sl@0: 	    return TCL_OK;
sl@0: 	}
sl@0:     }
sl@0: 
sl@0:     /*
sl@0:      * There shouldn't be a problem with src, because we already
sl@0:      * checked it to get here.
sl@0:      */
sl@0: 
sl@0:     if (errorPtr != NULL) {
sl@0: 	Tcl_WinTCharToUtf(nativeDst, -1, errorPtr);
sl@0:     }
sl@0:     return TCL_ERROR;
sl@0: }
sl@0: 
sl@0: /*
sl@0:  *----------------------------------------------------------------------
sl@0:  *
sl@0:  * TraversalDelete --
sl@0:  *
sl@0:  *      Called by procedure TraverseWinTree for every file and
sl@0:  *      directory that it encounters in a directory hierarchy. This
sl@0:  *      procedure unlinks files, and removes directories after all the
sl@0:  *      containing files have been processed.
sl@0:  *
sl@0:  * Results:
sl@0:  *      Standard Tcl result.
sl@0:  *
sl@0:  * Side effects:
sl@0:  *      Files or directory specified by src will be deleted. If an
sl@0:  *      error occurs, the windows error is converted to a Posix error
sl@0:  *      and errno is set accordingly.
sl@0:  *
sl@0:  *----------------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: static int
sl@0: TraversalDelete( 
sl@0:     CONST TCHAR *nativeSrc,	/* Source pathname to delete. */
sl@0:     CONST TCHAR *dstPtr,	/* Not used. */
sl@0:     int type,			/* Reason for call - see TraverseWinTree() */
sl@0:     Tcl_DString *errorPtr)	/* If non-NULL, initialized DString filled
sl@0: 				 * with UTF-8 name of file causing error. */
sl@0: {
sl@0:     switch (type) {
sl@0: 	case DOTREE_F: {
sl@0: 	    if (TclpDeleteFile(nativeSrc) == TCL_OK) {
sl@0: 		return TCL_OK;
sl@0: 	    }
sl@0: 	    break;
sl@0: 	}
sl@0: 	case DOTREE_PRED: {
sl@0: 	    return TCL_OK;
sl@0: 	}
sl@0: 	case DOTREE_POSTD: {
sl@0: 	    if (DoRemoveJustDirectory(nativeSrc, 0, NULL) == TCL_OK) {
sl@0: 		return TCL_OK;
sl@0: 	    }
sl@0: 	    break;
sl@0: 	}
sl@0:     }
sl@0: 
sl@0:     if (errorPtr != NULL) {
sl@0: 	Tcl_WinTCharToUtf(nativeSrc, -1, errorPtr);
sl@0:     }
sl@0:     return TCL_ERROR;
sl@0: }
sl@0: 
sl@0: /*
sl@0:  *----------------------------------------------------------------------
sl@0:  *
sl@0:  * StatError --
sl@0:  *
sl@0:  *	Sets the object result with the appropriate error.
sl@0:  *
sl@0:  * Results:
sl@0:  *      None.
sl@0:  *
sl@0:  * Side effects:
sl@0:  *      The interp's object result is set with an error message
sl@0:  *	based on the objIndex, fileName and errno.
sl@0:  *
sl@0:  *----------------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: static void
sl@0: StatError(
sl@0:     Tcl_Interp *interp,		/* The interp that has the error */
sl@0:     Tcl_Obj *fileName)	        /* The name of the file which caused the 
sl@0: 				 * error. */
sl@0: {
sl@0:     TclWinConvertError(GetLastError());
sl@0:     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), 
sl@0: 			   "could not read \"", Tcl_GetString(fileName), 
sl@0: 			   "\": ", Tcl_PosixError(interp), 
sl@0: 			   (char *) NULL);
sl@0: }
sl@0: 
sl@0: /*
sl@0:  *----------------------------------------------------------------------
sl@0:  *
sl@0:  * GetWinFileAttributes --
sl@0:  *
sl@0:  *      Returns a Tcl_Obj containing the value of a file attribute.
sl@0:  *	This routine gets the -hidden, -readonly or -system attribute.
sl@0:  *
sl@0:  * Results:
sl@0:  *      Standard Tcl result and a Tcl_Obj in attributePtrPtr. The object
sl@0:  *	will have ref count 0. If the return value is not TCL_OK,
sl@0:  *	attributePtrPtr is not touched.
sl@0:  *
sl@0:  * Side effects:
sl@0:  *      A new object is allocated if the file is valid.
sl@0:  *
sl@0:  *----------------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: static int
sl@0: GetWinFileAttributes(
sl@0:     Tcl_Interp *interp,		/* The interp we are using for errors. */
sl@0:     int objIndex,		/* The index of the attribute. */
sl@0:     Tcl_Obj *fileName,	        /* The name of the file. */
sl@0:     Tcl_Obj **attributePtrPtr)	/* A pointer to return the object with. */
sl@0: {
sl@0:     DWORD result;
sl@0:     CONST TCHAR *nativeName;
sl@0:     int attr;
sl@0:     
sl@0:     nativeName = Tcl_FSGetNativePath(fileName);
sl@0:     result = (*tclWinProcs->getFileAttributesProc)(nativeName);
sl@0: 
sl@0:     if (result == 0xffffffff) {
sl@0: 	StatError(interp, fileName);
sl@0: 	return TCL_ERROR;
sl@0:     }
sl@0: 
sl@0:     attr = (int)(result & attributeArray[objIndex]);
sl@0:     if ((objIndex == WIN_HIDDEN_ATTRIBUTE) && (attr != 0)) {
sl@0: 	/* 
sl@0: 	 * It is hidden.  However there is a bug on some Windows
sl@0: 	 * OSes in which root volumes (drives) formatted as NTFS
sl@0: 	 * are declared hidden when they are not (and cannot be).
sl@0: 	 * 
sl@0: 	 * We test for, and fix that case, here.
sl@0: 	 */
sl@0: 	int len;
sl@0: 	char *str = Tcl_GetStringFromObj(fileName,&len);
sl@0: 	if (len < 4) {
sl@0: 	    if (len == 0) {
sl@0: 		/* 
sl@0: 		 * Not sure if this is possible, but we pass it on
sl@0: 		 * anyway 
sl@0: 		 */
sl@0: 	    } else if (len == 1 && (str[0] == '/' || str[0] == '\\')) {
sl@0: 		/* Path is pointing to the root volume */
sl@0: 		attr = 0;
sl@0: 	    } else if ((str[1] == ':') 
sl@0: 		       && (len == 2 || (str[2] == '/' || str[2] == '\\'))) {
sl@0: 		/* Path is of the form 'x:' or 'x:/' or 'x:\' */
sl@0: 		attr = 0;
sl@0: 	    }
sl@0: 	}
sl@0:     }
sl@0:     *attributePtrPtr = Tcl_NewBooleanObj(attr);
sl@0:     return TCL_OK;
sl@0: }
sl@0: 
sl@0: /*
sl@0:  *----------------------------------------------------------------------
sl@0:  *
sl@0:  * ConvertFileNameFormat --
sl@0:  *
sl@0:  *      Returns a Tcl_Obj containing either the long or short version of the 
sl@0:  *	file name.
sl@0:  *
sl@0:  * Results:
sl@0:  *      Standard Tcl result and a Tcl_Obj in attributePtrPtr. The object
sl@0:  *	will have ref count 0. If the return value is not TCL_OK,
sl@0:  *	attributePtrPtr is not touched.
sl@0:  *	
sl@0:  *	Warning: if you pass this function a drive name like 'c:' it
sl@0:  *	will actually return the current working directory on that
sl@0:  *	drive.  To avoid this, make sure the drive name ends in a
sl@0:  *	slash, like this 'c:/'.
sl@0:  *
sl@0:  * Side effects:
sl@0:  *      A new object is allocated if the file is valid.
sl@0:  *
sl@0:  *----------------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: static int
sl@0: ConvertFileNameFormat(
sl@0:     Tcl_Interp *interp,		/* The interp we are using for errors. */
sl@0:     int objIndex,		/* The index of the attribute. */
sl@0:     Tcl_Obj *fileName,   	/* The name of the file. */
sl@0:     int longShort,		/* 0 to short name, 1 to long name. */
sl@0:     Tcl_Obj **attributePtrPtr)	/* A pointer to return the object with. */
sl@0: {
sl@0:     int pathc, i;
sl@0:     Tcl_Obj *splitPath;
sl@0:     int result = TCL_OK;
sl@0: 
sl@0:     splitPath = Tcl_FSSplitPath(fileName, &pathc);
sl@0: 
sl@0:     if (splitPath == NULL || pathc == 0) {
sl@0: 	if (interp != NULL) {
sl@0: 	    Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), 
sl@0: 		"could not read \"", Tcl_GetString(fileName),
sl@0: 		"\": no such file or directory", 
sl@0: 		(char *) NULL);
sl@0: 	}
sl@0: 	result = TCL_ERROR;
sl@0: 	goto cleanup;
sl@0:     }
sl@0:     
sl@0:     for (i = 0; i < pathc; i++) {
sl@0: 	Tcl_Obj *elt;
sl@0: 	char *pathv;
sl@0: 	int pathLen;
sl@0: 	Tcl_ListObjIndex(NULL, splitPath, i, &elt);
sl@0: 	
sl@0: 	pathv = Tcl_GetStringFromObj(elt, &pathLen);
sl@0: 	if ((pathv[0] == '/')
sl@0: 		|| ((pathLen == 3) && (pathv[1] == ':'))
sl@0: 		|| (strcmp(pathv, ".") == 0)
sl@0: 		|| (strcmp(pathv, "..") == 0)) {
sl@0: 	    /*
sl@0: 	     * Handle "/", "//machine/export", "c:/", "." or ".." by just
sl@0: 	     * copying the string literally.  Uppercase the drive letter,
sl@0: 	     * just because it looks better under Windows to do so.
sl@0: 	     */
sl@0: 
sl@0: 	    simple:
sl@0: 	    /* Here we are modifying the string representation in place */
sl@0: 	    /* I believe this is legal, since this won't affect any 
sl@0: 	     * file representation this thing may have. */
sl@0: 	    pathv[0] = (char) Tcl_UniCharToUpper(UCHAR(pathv[0]));
sl@0: 	} else {
sl@0: 	    Tcl_Obj *tempPath;
sl@0: 	    Tcl_DString ds;
sl@0: 	    Tcl_DString dsTemp;
sl@0: 	    TCHAR *nativeName;
sl@0: 	    char *tempString;
sl@0: 	    int tempLen;
sl@0: 	    WIN32_FIND_DATAT data;
sl@0: 	    HANDLE handle;
sl@0: 	    DWORD attr;
sl@0: 
sl@0: 	    tempPath = Tcl_FSJoinPath(splitPath, i+1);
sl@0: 	    Tcl_IncrRefCount(tempPath);
sl@0: 	    /* 
sl@0: 	     * We'd like to call Tcl_FSGetNativePath(tempPath)
sl@0: 	     * but that is likely to lead to infinite loops 
sl@0: 	     */
sl@0: 	    Tcl_DStringInit(&ds);
sl@0: 	    tempString = Tcl_GetStringFromObj(tempPath,&tempLen);
sl@0: 	    nativeName = Tcl_WinUtfToTChar(tempString, tempLen, &ds);
sl@0: 	    Tcl_DecrRefCount(tempPath);
sl@0: 	    handle = (*tclWinProcs->findFirstFileProc)(nativeName, &data);
sl@0: 	    if (handle == INVALID_HANDLE_VALUE) {
sl@0: 		/*
sl@0: 		 * FindFirstFile() doesn't like root directories.  We 
sl@0: 		 * would only get a root directory here if the caller
sl@0: 		 * specified "c:" or "c:." and the current directory on the
sl@0: 		 * drive was the root directory
sl@0: 		 */
sl@0: 
sl@0: 		attr = (*tclWinProcs->getFileAttributesProc)(nativeName);
sl@0: 		if ((attr != 0xFFFFFFFF) && (attr & FILE_ATTRIBUTE_DIRECTORY)) {
sl@0: 		    Tcl_DStringFree(&ds);
sl@0: 		    goto simple;
sl@0: 		}
sl@0: 	    }
sl@0: 
sl@0: 	    if (handle == INVALID_HANDLE_VALUE) {
sl@0: 		Tcl_DStringFree(&ds);
sl@0: 		if (interp != NULL) {
sl@0: 		    StatError(interp, fileName);
sl@0: 		}
sl@0: 		result = TCL_ERROR;
sl@0: 		goto cleanup;
sl@0: 	    }
sl@0: 	    if (tclWinProcs->useWide) {
sl@0: 		nativeName = (TCHAR *) data.w.cAlternateFileName;
sl@0: 		if (longShort) {
sl@0: 		    if (data.w.cFileName[0] != '\0') {
sl@0: 			nativeName = (TCHAR *) data.w.cFileName;
sl@0: 		    } 
sl@0: 		} else {
sl@0: 		    if (data.w.cAlternateFileName[0] == '\0') {
sl@0: 			nativeName = (TCHAR *) data.w.cFileName;
sl@0: 		    }
sl@0: 		}
sl@0: 	    } else {
sl@0: 		nativeName = (TCHAR *) data.a.cAlternateFileName;
sl@0: 		if (longShort) {
sl@0: 		    if (data.a.cFileName[0] != '\0') {
sl@0: 			nativeName = (TCHAR *) data.a.cFileName;
sl@0: 		    } 
sl@0: 		} else {
sl@0: 		    if (data.a.cAlternateFileName[0] == '\0') {
sl@0: 			nativeName = (TCHAR *) data.a.cFileName;
sl@0: 		    }
sl@0: 		}
sl@0: 	    }
sl@0: 
sl@0: 	    /*
sl@0: 	     * Purify reports a extraneous UMR in Tcl_WinTCharToUtf() trying 
sl@0: 	     * to dereference nativeName as a Unicode string.  I have proven 
sl@0: 	     * to myself that purify is wrong by running the following 
sl@0: 	     * example when nativeName == data.w.cAlternateFileName and 
sl@0: 	     * noting that purify doesn't complain about the first line,
sl@0: 	     * but does complain about the second.
sl@0: 	     *
sl@0: 	     *	fprintf(stderr, "%d\n", data.w.cAlternateFileName[0]);
sl@0: 	     *	fprintf(stderr, "%d\n", ((WCHAR *) nativeName)[0]);
sl@0: 	     */
sl@0: 
sl@0: 	    Tcl_DStringInit(&dsTemp);
sl@0: 	    Tcl_WinTCharToUtf(nativeName, -1, &dsTemp);
sl@0: 	    /* Deal with issues of tildes being absolute */
sl@0: 	    if (Tcl_DStringValue(&dsTemp)[0] == '~') {
sl@0: 		tempPath = Tcl_NewStringObj("./",2);
sl@0: 		Tcl_AppendToObj(tempPath, Tcl_DStringValue(&dsTemp), 
sl@0: 				Tcl_DStringLength(&dsTemp));
sl@0: 	    } else {
sl@0: 		tempPath = Tcl_NewStringObj(Tcl_DStringValue(&dsTemp), 
sl@0: 					    Tcl_DStringLength(&dsTemp));
sl@0: 	    }
sl@0: 	    Tcl_ListObjReplace(NULL, splitPath, i, 1, 1, &tempPath);
sl@0: 	    Tcl_DStringFree(&ds);
sl@0: 	    Tcl_DStringFree(&dsTemp);
sl@0: 	    FindClose(handle);
sl@0: 	}
sl@0:     }
sl@0: 
sl@0:     *attributePtrPtr = Tcl_FSJoinPath(splitPath, -1);
sl@0: 
sl@0: cleanup:
sl@0:     if (splitPath != NULL) {
sl@0: 	Tcl_DecrRefCount(splitPath);
sl@0:     }
sl@0:   
sl@0:     return result;
sl@0: }
sl@0: 
sl@0: /*
sl@0:  *----------------------------------------------------------------------
sl@0:  *
sl@0:  * GetWinFileLongName --
sl@0:  *
sl@0:  *      Returns a Tcl_Obj containing the long version of the file
sl@0:  *	name.
sl@0:  *
sl@0:  * Results:
sl@0:  *      Standard Tcl result and a Tcl_Obj in attributePtrPtr. The object
sl@0:  *	will have ref count 0. If the return value is not TCL_OK,
sl@0:  *	attributePtrPtr is not touched.
sl@0:  *
sl@0:  * Side effects:
sl@0:  *      A new object is allocated if the file is valid.
sl@0:  *
sl@0:  *----------------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: static int
sl@0: GetWinFileLongName(
sl@0:     Tcl_Interp *interp,		/* The interp we are using for errors. */
sl@0:     int objIndex,		/* The index of the attribute. */
sl@0:     Tcl_Obj *fileName,  	/* The name of the file. */
sl@0:     Tcl_Obj **attributePtrPtr)	/* A pointer to return the object with. */
sl@0: {
sl@0:     return ConvertFileNameFormat(interp, objIndex, fileName, 1, attributePtrPtr);
sl@0: }
sl@0: 
sl@0: /*
sl@0:  *----------------------------------------------------------------------
sl@0:  *
sl@0:  * GetWinFileShortName --
sl@0:  *
sl@0:  *      Returns a Tcl_Obj containing the short version of the file
sl@0:  *	name.
sl@0:  *
sl@0:  * Results:
sl@0:  *      Standard Tcl result and a Tcl_Obj in attributePtrPtr. The object
sl@0:  *	will have ref count 0. If the return value is not TCL_OK,
sl@0:  *	attributePtrPtr is not touched.
sl@0:  *
sl@0:  * Side effects:
sl@0:  *      A new object is allocated if the file is valid.
sl@0:  *
sl@0:  *----------------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: static int
sl@0: GetWinFileShortName(
sl@0:     Tcl_Interp *interp,		/* The interp we are using for errors. */
sl@0:     int objIndex,		/* The index of the attribute. */
sl@0:     Tcl_Obj *fileName,  	/* The name of the file. */
sl@0:     Tcl_Obj **attributePtrPtr)	/* A pointer to return the object with. */
sl@0: {
sl@0:     return ConvertFileNameFormat(interp, objIndex, fileName, 0, attributePtrPtr);
sl@0: }
sl@0: 
sl@0: /*
sl@0:  *----------------------------------------------------------------------
sl@0:  *
sl@0:  * SetWinFileAttributes --
sl@0:  *
sl@0:  *	Set the file attributes to the value given by attributePtr.
sl@0:  *	This routine sets the -hidden, -readonly, or -system attributes.
sl@0:  *
sl@0:  * Results:
sl@0:  *      Standard TCL error.
sl@0:  *
sl@0:  * Side effects:
sl@0:  *      The file's attribute is set.
sl@0:  *
sl@0:  *----------------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: static int
sl@0: SetWinFileAttributes(
sl@0:     Tcl_Interp *interp,		/* The interp we are using for errors. */
sl@0:     int objIndex,		/* The index of the attribute. */
sl@0:     Tcl_Obj *fileName,  	/* The name of the file. */
sl@0:     Tcl_Obj *attributePtr)	/* The new value of the attribute. */
sl@0: {
sl@0:     DWORD fileAttributes;
sl@0:     int yesNo;
sl@0:     int result;
sl@0:     CONST TCHAR *nativeName;
sl@0: 
sl@0:     nativeName = Tcl_FSGetNativePath(fileName);
sl@0:     fileAttributes = (*tclWinProcs->getFileAttributesProc)(nativeName);
sl@0: 
sl@0:     if (fileAttributes == 0xffffffff) {
sl@0: 	StatError(interp, fileName);
sl@0: 	return TCL_ERROR;
sl@0:     }
sl@0: 
sl@0:     result = Tcl_GetBooleanFromObj(interp, attributePtr, &yesNo);
sl@0:     if (result != TCL_OK) {
sl@0: 	return result;
sl@0:     }
sl@0: 
sl@0:     if (yesNo) {
sl@0: 	fileAttributes |= (attributeArray[objIndex]);
sl@0:     } else {
sl@0: 	fileAttributes &= ~(attributeArray[objIndex]);
sl@0:     }
sl@0: 
sl@0:     if (!(*tclWinProcs->setFileAttributesProc)(nativeName, fileAttributes)) {
sl@0: 	StatError(interp, fileName);
sl@0: 	return TCL_ERROR;
sl@0:     }
sl@0: 
sl@0:     return result;
sl@0: }
sl@0: 
sl@0: /*
sl@0:  *----------------------------------------------------------------------
sl@0:  *
sl@0:  * SetWinFileLongName --
sl@0:  *
sl@0:  *	The attribute in question is a readonly attribute and cannot
sl@0:  *	be set.
sl@0:  *
sl@0:  * Results:
sl@0:  *      TCL_ERROR
sl@0:  *
sl@0:  * Side effects:
sl@0:  *      The object result is set to a pertinent error message.
sl@0:  *
sl@0:  *----------------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: static int
sl@0: CannotSetAttribute(
sl@0:     Tcl_Interp *interp,		/* The interp we are using for errors. */
sl@0:     int objIndex,		/* The index of the attribute. */
sl@0:     Tcl_Obj *fileName,	        /* The name of the file. */
sl@0:     Tcl_Obj *attributePtr)	/* The new value of the attribute. */
sl@0: {
sl@0:     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), 
sl@0: 	    "cannot set attribute \"", tclpFileAttrStrings[objIndex],
sl@0: 	    "\" for file \"", Tcl_GetString(fileName), 
sl@0: 	    "\": attribute is readonly", 
sl@0: 	    (char *) NULL);
sl@0:     return TCL_ERROR;
sl@0: }
sl@0: 
sl@0: 
sl@0: /*
sl@0:  *---------------------------------------------------------------------------
sl@0:  *
sl@0:  * TclpObjListVolumes --
sl@0:  *
sl@0:  *	Lists the currently mounted volumes
sl@0:  *
sl@0:  * Results:
sl@0:  *	The list of volumes.
sl@0:  *
sl@0:  * Side effects:
sl@0:  *	None
sl@0:  *
sl@0:  *---------------------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: Tcl_Obj*
sl@0: TclpObjListVolumes(void)
sl@0: {
sl@0:     Tcl_Obj *resultPtr, *elemPtr;
sl@0:     char buf[40 * 4];		/* There couldn't be more than 30 drives??? */
sl@0:     int i;
sl@0:     char *p;
sl@0: 
sl@0:     resultPtr = Tcl_NewObj();
sl@0: 
sl@0:     /*
sl@0:      * On Win32s:
sl@0:      * GetLogicalDriveStrings() isn't implemented.
sl@0:      * GetLogicalDrives() returns incorrect information.
sl@0:      */
sl@0: 
sl@0:     if (GetLogicalDriveStringsA(sizeof(buf), buf) == 0) {
sl@0: 	/*
sl@0: 	 * GetVolumeInformation() will detects all drives, but causes
sl@0: 	 * chattering on empty floppy drives.  We only do this if 
sl@0: 	 * GetLogicalDriveStrings() didn't work.  It has also been reported
sl@0: 	 * that on some laptops it takes a while for GetVolumeInformation()
sl@0: 	 * to return when pinging an empty floppy drive, another reason to 
sl@0: 	 * try to avoid calling it.
sl@0: 	 */
sl@0: 
sl@0: 	buf[1] = ':';
sl@0: 	buf[2] = '/';
sl@0: 	buf[3] = '\0';
sl@0: 
sl@0: 	for (i = 0; i < 26; i++) {
sl@0: 	    buf[0] = (char) ('a' + i);
sl@0: 	    if (GetVolumeInformationA(buf, NULL, 0, NULL, NULL, NULL, NULL, 0)  
sl@0: 		    || (GetLastError() == ERROR_NOT_READY)) {
sl@0: 		elemPtr = Tcl_NewStringObj(buf, -1);
sl@0: 		Tcl_ListObjAppendElement(NULL, resultPtr, elemPtr);
sl@0: 	    }
sl@0: 	}
sl@0:     } else {
sl@0: 	for (p = buf; *p != '\0'; p += 4) {
sl@0: 	    p[2] = '/';
sl@0: 	    elemPtr = Tcl_NewStringObj(p, -1);
sl@0: 	    Tcl_ListObjAppendElement(NULL, resultPtr, elemPtr);
sl@0: 	}
sl@0:     }
sl@0:     
sl@0:     Tcl_IncrRefCount(resultPtr);
sl@0:     return resultPtr;
sl@0: }