path: root/win/tclWinFCmd.c

/*
 * tclWinFCmd.c
 *
 *	This file implements the Windows specific portion of file manipulation
 *	subcommands of the "file" command.
 *
 * Copyright (c) 1996-1998 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclWinFCmd.c,v 1.68 2010/09/21 21:50:35 nijtmans Exp $
 */

#include "tclWinInt.h"

/*
 * The following constants specify the type of callback when
 * TraverseWinTree() calls the traverseProc()
 */

#define DOTREE_PRED	1	/* pre-order directory  */
#define DOTREE_POSTD	2	/* post-order directory */
#define DOTREE_F	3	/* regular file */
#define DOTREE_LINK	4	/* symbolic link */

/*
 * Callbacks for file attributes code.
 */

static int		GetWinFileAttributes(Tcl_Interp *interp, int objIndex,
			    Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr);
static int		GetWinFileLongName(Tcl_Interp *interp, int objIndex,
			    Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr);
static int		GetWinFileShortName(Tcl_Interp *interp, int objIndex,
			    Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr);
static int		SetWinFileAttributes(Tcl_Interp *interp, int objIndex,
			    Tcl_Obj *fileName, Tcl_Obj *attributePtr);
static int		CannotSetAttribute(Tcl_Interp *interp, int objIndex,
			    Tcl_Obj *fileName, Tcl_Obj *attributePtr);

/*
 * Constants and variables necessary for file attributes subcommand.
 */

enum {
    WIN_ARCHIVE_ATTRIBUTE,
    WIN_HIDDEN_ATTRIBUTE,
    WIN_LONGNAME_ATTRIBUTE,
    WIN_READONLY_ATTRIBUTE,
    WIN_SHORTNAME_ATTRIBUTE,
    WIN_SYSTEM_ATTRIBUTE
};

static int attributeArray[] = {FILE_ATTRIBUTE_ARCHIVE, FILE_ATTRIBUTE_HIDDEN,
	0, FILE_ATTRIBUTE_READONLY, 0, FILE_ATTRIBUTE_SYSTEM};


const char *const tclpFileAttrStrings[] = {
	"-archive", "-hidden", "-longname", "-readonly",
	"-shortname", "-system", (char *) NULL
};

const TclFileAttrProcs tclpFileAttrProcs[] = {
	{GetWinFileAttributes, SetWinFileAttributes},
	{GetWinFileAttributes, SetWinFileAttributes},
	{GetWinFileLongName, CannotSetAttribute},
	{GetWinFileAttributes, SetWinFileAttributes},
	{GetWinFileShortName, CannotSetAttribute},
	{GetWinFileAttributes, SetWinFileAttributes}};

#ifdef HAVE_NO_SEH

/*
 * Unlike Borland and Microsoft, we don't register exception handlers by
 * pushing registration records onto the runtime stack. Instead, we register
 * them by creating an EXCEPTION_REGISTRATION within the activation record.
 */

typedef struct EXCEPTION_REGISTRATION {
    struct EXCEPTION_REGISTRATION *link;
    EXCEPTION_DISPOSITION (*handler)(
	    struct _EXCEPTION_RECORD *, void *, struct _CONTEXT *, void *);
    void *ebp;
    void *esp;
    int status;
} EXCEPTION_REGISTRATION;

#endif

/*
 * Prototype for the TraverseWinTree callback function.
 */

typedef int (TraversalProc)(const TCHAR *srcPtr, const TCHAR *dstPtr,
	int type, Tcl_DString *errorPtr);

/*
 * Declarations for local functions defined in this file:
 */

static void		StatError(Tcl_Interp *interp, Tcl_Obj *fileName);
static int		ConvertFileNameFormat(Tcl_Interp *interp,
			    int objIndex, Tcl_Obj *fileName, int longShort,
			    Tcl_Obj **attributePtrPtr);
static int		DoCopyFile(const TCHAR *srcPtr, const TCHAR *dstPtr);
static int		DoCreateDirectory(const TCHAR *pathPtr);
static int		DoRemoveJustDirectory(const TCHAR *nativeSrc,
			    int ignoreError, Tcl_DString *errorPtr);
static int		DoRemoveDirectory(Tcl_DString *pathPtr, int recursive,
			    Tcl_DString *errorPtr);
static int		DoRenameFile(const TCHAR *nativeSrc,
			    const TCHAR *dstPtr);
static int		TraversalCopy(const TCHAR *srcPtr, const TCHAR *dstPtr,
			    int type, Tcl_DString *errorPtr);
static int		TraversalDelete(const TCHAR *srcPtr,
			    const TCHAR *dstPtr, int type,
			    Tcl_DString *errorPtr);
static int		TraverseWinTree(TraversalProc *traverseProc,
			    Tcl_DString *sourcePtr, Tcl_DString *dstPtr,
			    Tcl_DString *errorPtr);

/*
 *---------------------------------------------------------------------------
 *
 * TclpObjRenameFile, DoRenameFile --
 *
 *	Changes the name of an existing file or directory, from src to dst.
 *	If src and dst refer to the same file or directory, does nothing and
 *	returns success. Otherwise if dst already exists, it will be deleted
 *	and replaced by src subject to the following conditions:
 *	    If src is a directory, dst may be an empty directory.
 *	    If src is a file, dst may be a file.
 *	In any other situation where dst already exists, the rename will fail.
 *
 * Results:
 *	If the file or directory was successfully renamed, returns TCL_OK.
 *	Otherwise the return value is TCL_ERROR and errno is set to indicate
 *	the error. Some possible values for errno are:
 *
 *	ENAMETOOLONG: src or dst names are too long.
 *	EACCES:	    src or dst parent directory can't be read and/or written.
 *	EEXIST:	    dst is a non-empty directory.
 *	EINVAL:	    src is a root directory or dst is a subdirectory of src.
 *	EISDIR:	    dst is a directory, but src is not.
 *	ENOENT:	    src doesn't exist.	src or dst is "".
 *	ENOTDIR:    src is a directory, but dst is not.
 *	EXDEV:	    src and dst are on different filesystems.
 *
 *	EACCES:	    exists an open file already referring to src or dst.
 *	EACCES:	    src or dst specify the current working directory (NT).
 *	EACCES:	    src specifies a char device (nul:, com1:, etc.)
 *	EEXIST:	    dst specifies a char device (nul:, com1:, etc.) (NT)
 *	EACCES:	    dst specifies a char device (nul:, com1:, etc.) (95)
 *
 * Side effects:
 *	The implementation supports cross-filesystem renames of files, but the
 *	caller should be prepared to emulate cross-filesystem renames of
 *	directories if errno is EXDEV.
 *
 *---------------------------------------------------------------------------
 */

int
TclpObjRenameFile(
    Tcl_Obj *srcPathPtr,
    Tcl_Obj *destPathPtr)
{
    return DoRenameFile(Tcl_FSGetNativePath(srcPathPtr),
	    Tcl_FSGetNativePath(destPathPtr));
}

static int
DoRenameFile(
    const TCHAR *nativeSrc,	/* Pathname of file or dir to be renamed
				 * (native). */
    const TCHAR *nativeDst)	/* New pathname for file or directory
				 * (native). */
{
#ifdef HAVE_NO_SEH
    EXCEPTION_REGISTRATION registration;
#endif
    DWORD srcAttr, dstAttr;
    int retval = -1;

    /*
     * The MoveFile API acts differently under Win95/98 and NT WRT NULL and
     * "". Avoid passing these values.
     */

    if (nativeSrc == NULL || nativeSrc[0] == '\0' ||
	    nativeDst == NULL || nativeDst[0] == '\0') {
	Tcl_SetErrno(ENOENT);
	return TCL_ERROR;
    }

    /*
     * The MoveFile API would throw an exception under NT if one of the
     * arguments is a char block device.
     */

#if defined(HAVE_NO_SEH) && !defined(_WIN64)
    /*
     * Don't have SEH available, do things the hard way. Note that this needs
     * to be one block of asm, to avoid stack imbalance; also, it is illegal
     * for one asm block to contain a jump to another.
     */

    __asm__ __volatile__ (
	/*
	 * Pick up params before messing with the stack.
	 */

	"movl	    %[nativeDst],   %%ebx"	    "\n\t"
	"movl	    %[nativeSrc],   %%ecx"	    "\n\t"

	/*
	 * Construct an EXCEPTION_REGISTRATION to protect the call to
	 * MoveFile.
	 */

	"leal	    %[registration], %%edx"	    "\n\t"
	"movl	    %%fs:0,	    %%eax"	    "\n\t"
	"movl	    %%eax,	    0x0(%%edx)"	    "\n\t" /* link */
	"leal	    1f,		    %%eax"	    "\n\t"
	"movl	    %%eax,	    0x4(%%edx)"	    "\n\t" /* handler */
	"movl	    %%ebp,	    0x8(%%edx)"	    "\n\t" /* ebp */
	"movl	    %%esp,	    0xc(%%edx)"	    "\n\t" /* esp */
	"movl	    $0,		    0x10(%%edx)"    "\n\t" /* status */

	/*
	 * Link the EXCEPTION_REGISTRATION on the chain.
	 */

	"movl	    %%edx,	    %%fs:0"	    "\n\t"

	/*
	 * Call MoveFile(nativeSrc, nativeDst)
	 */

	"pushl	    %%ebx"			    "\n\t"
	"pushl	    %%ecx"			    "\n\t"
	"movl	    %[moveFile],    %%eax"	    "\n\t"
	"call	    *%%eax"			    "\n\t"

	/*
	 * Come here on normal exit. Recover the EXCEPTION_REGISTRATION and
	 * put the status return from MoveFile into it.
	 */

	"movl	    %%fs:0,	    %%edx"	    "\n\t"
	"movl	    %%eax,	    0x10(%%edx)"    "\n\t"
	"jmp	    2f"				    "\n"

	/*
	 * Come here on an exception. Recover the EXCEPTION_REGISTRATION
	 */

	"1:"					    "\t"
	"movl	    %%fs:0,	    %%edx"	    "\n\t"
	"movl	    0x8(%%edx),	    %%edx"	    "\n\t"

	/*
	 * Come here however we exited. Restore context from the
	 * EXCEPTION_REGISTRATION in case the stack is unbalanced.
	 */

	"2:"					    "\t"
	"movl	    0xc(%%edx),	    %%esp"	    "\n\t"
	"movl	    0x8(%%edx),	    %%ebp"	    "\n\t"
	"movl	    0x0(%%edx),	    %%eax"	    "\n\t"
	"movl	    %%eax,	    %%fs:0"	    "\n\t"

	:
	/* No outputs */
	:
	[registration]	"m"	(registration),
	[nativeDst]	"m"	(nativeDst),
	[nativeSrc]	"m"	(nativeSrc),
	[moveFile]	"r"	(tclWinProcs->moveFileProc)
	:
	"%eax", "%ebx", "%ecx", "%edx", "memory"
	);
    if (registration.status != FALSE) {
	retval = TCL_OK;
    }
#else
#ifndef HAVE_NO_SEH
    __try {
#endif
	if ((*tclWinProcs->moveFileProc)(nativeSrc, nativeDst) != FALSE) {
	    retval = TCL_OK;
	}
#ifndef HAVE_NO_SEH
    } __except (EXCEPTION_EXECUTE_HANDLER) {}
#endif
#endif

    if (retval != -1) {
	return retval;
    }

    TclWinConvertError(GetLastError());

    srcAttr = tclWinProcs->getFileAttributesProc(nativeSrc);
    dstAttr = tclWinProcs->getFileAttributesProc(nativeDst);
    if (srcAttr == 0xffffffff) {
	if (tclWinProcs->getFullPathNameProc(nativeSrc, 0, NULL,
		NULL) >= MAX_PATH) {
	    errno = ENAMETOOLONG;
	    return TCL_ERROR;
	}
	srcAttr = 0;
    }
    if (dstAttr == 0xffffffff) {
	if (tclWinProcs->getFullPathNameProc(nativeDst, 0, NULL,
		NULL) >= MAX_PATH) {
	    errno = ENAMETOOLONG;
	    return TCL_ERROR;
	}
	dstAttr = 0;
    }

    if (errno == EBADF) {
	errno = EACCES;
	return TCL_ERROR;
    }
    if (errno == EACCES) {
    decode:
	if (srcAttr & FILE_ATTRIBUTE_DIRECTORY) {
	    TCHAR *nativeSrcRest, *nativeDstRest;
	    const char **srcArgv, **dstArgv;
	    int size, srcArgc, dstArgc;
	    TCHAR nativeSrcPath[MAX_PATH];
	    TCHAR nativeDstPath[MAX_PATH];
	    Tcl_DString srcString, dstString;
	    const char *src, *dst;

	    size = tclWinProcs->getFullPathNameProc(nativeSrc, MAX_PATH,
		    nativeSrcPath, &nativeSrcRest);
	    if ((size == 0) || (size > MAX_PATH)) {
		return TCL_ERROR;
	    }
	    size = tclWinProcs->getFullPathNameProc(nativeDst, MAX_PATH,
		    nativeDstPath, &nativeDstRest);
	    if ((size == 0) || (size > MAX_PATH)) {
		return TCL_ERROR;
	    }
	    tclWinProcs->charLowerProc(nativeSrcPath);
	    tclWinProcs->charLowerProc(nativeDstPath);

	    src = tclWinProcs->tchar2utf(nativeSrcPath, -1, &srcString);
	    dst = tclWinProcs->tchar2utf(nativeDstPath, -1, &dstString);

	    /*
	     * Check whether the destination path is actually inside the
	     * source path. This is true if the prefix matches, and the next
	     * character is either end-of-string or a directory separator
	     */

	    if ((strncmp(src, dst, (size_t) Tcl_DStringLength(&srcString))==0)
		    && (dst[Tcl_DStringLength(&srcString)] == '\\'
		    || dst[Tcl_DStringLength(&srcString)] == '/'
		    || dst[Tcl_DStringLength(&srcString)] == '\0')) {
		/*
		 * Trying to move a directory into itself.
		 */

		errno = EINVAL;
		Tcl_DStringFree(&srcString);
		Tcl_DStringFree(&dstString);
		return TCL_ERROR;
	    }
	    Tcl_SplitPath(src, &srcArgc, &srcArgv);
	    Tcl_SplitPath(dst, &dstArgc, &dstArgv);
	    Tcl_DStringFree(&srcString);
	    Tcl_DStringFree(&dstString);

	    if (srcArgc == 1) {
		/*
		 * They are trying to move a root directory. Whether or not it
		 * is across filesystems, this cannot be done.
		 */

		Tcl_SetErrno(EINVAL);
	    } else if ((srcArgc > 0) && (dstArgc > 0) &&
		    (strcmp(srcArgv[0], dstArgv[0]) != 0)) {
		/*
		 * If src is a directory and dst filesystem != src filesystem,
		 * errno should be EXDEV. It is very important to get this
		 * behavior, so that the caller can respond to a cross
		 * filesystem rename by simulating it with copy and delete.
		 * The MoveFile system call already handles the case of moving
		 * a file between filesystems.
		 */

		Tcl_SetErrno(EXDEV);
	    }

	    ckfree((char *) srcArgv);
	    ckfree((char *) dstArgv);
	}

	/*
	 * Other types of access failure is that dst is a read-only
	 * filesystem, that an open file referred to src or dest, or that src
	 * or dest specified the current working directory on the current
	 * filesystem. EACCES is returned for those cases.
	 */

    } else if (Tcl_GetErrno() == EEXIST) {
	/*
	 * Reports EEXIST any time the target already exists. If it makes
	 * sense, remove the old file and try renaming again.
	 */

	if (srcAttr & FILE_ATTRIBUTE_DIRECTORY) {
	    if (dstAttr & FILE_ATTRIBUTE_DIRECTORY) {
		/*
		 * Overwrite empty dst directory with src directory. The
		 * following call will remove an empty directory. If it fails,
		 * it's because it wasn't empty.
		 */

		if (DoRemoveJustDirectory(nativeDst, 0, NULL) == TCL_OK) {
		    /*
		     * Now that that empty directory is gone, we can try
		     * renaming again. If that fails, we'll put this empty
		     * directory back, for completeness.
		     */

		    if (tclWinProcs->moveFileProc(nativeSrc,
			    nativeDst) != FALSE) {
			return TCL_OK;
		    }

		    /*
		     * Some new error has occurred. Don't know what it could
		     * be, but report this one.
		     */

		    TclWinConvertError(GetLastError());
		    tclWinProcs->createDirectoryProc(nativeDst, NULL);
		    tclWinProcs->setFileAttributesProc(nativeDst, dstAttr);
		    if (Tcl_GetErrno() == EACCES) {
			/*
			 * Decode the EACCES to a more meaningful error.
			 */

			goto decode;
		    }
		}
	    } else {	/* (dstAttr & FILE_ATTRIBUTE_DIRECTORY) == 0 */
		Tcl_SetErrno(ENOTDIR);
	    }
	} else {    /* (srcAttr & FILE_ATTRIBUTE_DIRECTORY) == 0 */
	    if (dstAttr & FILE_ATTRIBUTE_DIRECTORY) {
		Tcl_SetErrno(EISDIR);
	    } else {
		/*
		 * Overwrite existing file by:
		 *
		 * 1. Rename existing file to temp name.
		 * 2. Rename old file to new name.
		 * 3. If success, delete temp file. If failure, put temp file
		 *    back to old name.
		 */

		TCHAR *nativeRest, *nativeTmp, *nativePrefix;
		int result, size;
		TCHAR tempBuf[MAX_PATH];

		size = tclWinProcs->getFullPathNameProc(nativeDst, MAX_PATH,
			tempBuf, &nativeRest);
		if ((size == 0) || (size > MAX_PATH) || (nativeRest == NULL)) {
		    return TCL_ERROR;
		}
		nativeTmp = (TCHAR *) tempBuf;
		nativeRest[0] = L'\0';

		result = TCL_ERROR;
		nativePrefix = (TCHAR *) L"tclr";
		if (tclWinProcs->getTempFileNameProc(nativeTmp, nativePrefix,
			0, tempBuf) != 0) {
		    /*
		     * Strictly speaking, need the following DeleteFile and
		     * MoveFile to be joined as an atomic operation so no
		     * other app comes along in the meantime and creates the
		     * same temp file.
		     */

		    nativeTmp = (TCHAR *) tempBuf;
		    tclWinProcs->deleteFileProc(nativeTmp);
		    if (tclWinProcs->moveFileProc(nativeDst,
			    nativeTmp) != FALSE) {
			if (tclWinProcs->moveFileProc(nativeSrc,
				nativeDst) != FALSE) {
			    tclWinProcs->setFileAttributesProc(nativeTmp,
				    FILE_ATTRIBUTE_NORMAL);
			    tclWinProcs->deleteFileProc(nativeTmp);
			    return TCL_OK;
			} else {
			    tclWinProcs->deleteFileProc(nativeDst);
			    tclWinProcs->moveFileProc(nativeTmp, nativeDst);
			}
		    }

		    /*
		     * Can't backup dst file or move src file. Return that
		     * error. Could happen if an open file refers to dst.
		     */

		    TclWinConvertError(GetLastError());
		    if (Tcl_GetErrno() == EACCES) {
			/*
			 * Decode the EACCES to a more meaningful error.
			 */

			goto decode;
		    }
		}
		return result;
	    }
	}
    }
    return TCL_ERROR;
}

/*
 *---------------------------------------------------------------------------
 *
 * TclpObjCopyFile, DoCopyFile --
 *
 *	Copy a single file (not a directory). If dst already exists and is not
 *	a directory, it is removed.
 *
 * Results:
 *	If the file was successfully copied, returns TCL_OK. Otherwise the
 *	return value is TCL_ERROR and errno is set to indicate the error.
 *	Some possible values for errno are:
 *
 *	EACCES:	    src or dst parent directory can't be read and/or written.
 *	EISDIR:	    src or dst is a directory.
 *	ENOENT:	    src doesn't exist.	src or dst is "".
 *
 *	EACCES:	    exists an open file already referring to dst (95).
 *	EACCES:	    src specifies a char device (nul:, com1:, etc.) (NT)
 *	ENOENT:	    src specifies a char device (nul:, com1:, etc.) (95)
 *
 * Side effects:
 *	It is not an error to copy to a char device.
 *
 *---------------------------------------------------------------------------
 */

int
TclpObjCopyFile(
    Tcl_Obj *srcPathPtr,
    Tcl_Obj *destPathPtr)
{
    return DoCopyFile(Tcl_FSGetNativePath(srcPathPtr),
	    Tcl_FSGetNativePath(destPathPtr));
}

static int
DoCopyFile(
    const TCHAR *nativeSrc,	/* Pathname of file to be copied (native). */
    const TCHAR *nativeDst)	/* Pathname of file to copy to (native). */
{
#ifdef HAVE_NO_SEH
    EXCEPTION_REGISTRATION registration;
#endif
    int retval = -1;

    /*
     * The CopyFile API acts differently under Win95/98 and NT WRT NULL and
     * "". Avoid passing these values.
     */

    if (nativeSrc == NULL || nativeSrc[0] == '\0' ||
	    nativeDst == NULL || nativeDst[0] == '\0') {
	Tcl_SetErrno(ENOENT);
	return TCL_ERROR;
    }

    /*
     * The CopyFile API would throw an exception under NT if one of the
     * arguments is a char block device.
     */

#if defined(HAVE_NO_SEH) && !defined(_WIN64)
    /*
     * Don't have SEH available, do things the hard way. Note that this needs
     * to be one block of asm, to avoid stack imbalance; also, it is illegal
     * for one asm block to contain a jump to another.
     */

    __asm__ __volatile__ (

	/*
	 * Pick up parameters before messing with the stack
	 */

	"movl	    %[nativeDst],   %%ebx"	    "\n\t"
	"movl	    %[nativeSrc],   %%ecx"	    "\n\t"

	/*
	 * Construct an EXCEPTION_REGISTRATION to protect the call to
	 * CopyFile.
	 */

	"leal	    %[registration], %%edx"	    "\n\t"
	"movl	    %%fs:0,	    %%eax"	    "\n\t"
	"movl	    %%eax,	    0x0(%%edx)"	    "\n\t" /* link */
	"leal	    1f,		    %%eax"	    "\n\t"
	"movl	    %%eax,	    0x4(%%edx)"	    "\n\t" /* handler */
	"movl	    %%ebp,	    0x8(%%edx)"	    "\n\t" /* ebp */
	"movl	    %%esp,	    0xc(%%edx)"	    "\n\t" /* esp */
	"movl	    $0,		    0x10(%%edx)"    "\n\t" /* status */

	/*
	 * Link the EXCEPTION_REGISTRATION on the chain.
	 */

	"movl	    %%edx,	    %%fs:0"	    "\n\t"

	/*
	 * Call CopyFile(nativeSrc, nativeDst, 0)
	 */

	"movl	    %[copyFile],    %%eax"	    "\n\t"
	"pushl	    $0"				    "\n\t"
	"pushl	    %%ebx"			    "\n\t"
	"pushl	    %%ecx"			    "\n\t"
	"call	    *%%eax"			    "\n\t"

	/*
	 * Come here on normal exit. Recover the EXCEPTION_REGISTRATION and
	 * put the status return from CopyFile into it.
	 */

	"movl	    %%fs:0,	    %%edx"	    "\n\t"
	"movl	    %%eax,	    0x10(%%edx)"    "\n\t"
	"jmp	    2f"				    "\n"

	/*
	 * Come here on an exception. Recover the EXCEPTION_REGISTRATION
	 */

	"1:"					    "\t"
	"movl	    %%fs:0,	    %%edx"	    "\n\t"
	"movl	    0x8(%%edx),	    %%edx"	    "\n\t"

	/*
	 * Come here however we exited. Restore context from the
	 * EXCEPTION_REGISTRATION in case the stack is unbalanced.
	 */

	"2:"					    "\t"
	"movl	    0xc(%%edx),	    %%esp"	    "\n\t"
	"movl	    0x8(%%edx),	    %%ebp"	    "\n\t"
	"movl	    0x0(%%edx),	    %%eax"	    "\n\t"
	"movl	    %%eax,	    %%fs:0"	    "\n\t"

	:
	/* No outputs */
	:
	[registration]	"m"	(registration),
	[nativeDst]	"m"	(nativeDst),
	[nativeSrc]	"m"	(nativeSrc),
	[copyFile]	"r"	(tclWinProcs->copyFileProc)
	:
	"%eax", "%ebx", "%ecx", "%edx", "memory"
	);
    if (registration.status != FALSE) {
	retval = TCL_OK;
    }
#else
#ifndef HAVE_NO_SEH
    __try {
#endif
	if ((*tclWinProcs->copyFileProc)(nativeSrc, nativeDst, 0) != FALSE) {
	    retval = TCL_OK;
	}
#ifndef HAVE_NO_SEH
    } __except (EXCEPTION_EXECUTE_HANDLER) {}
#endif
#endif

    if (retval != -1) {
	return retval;
    }

    TclWinConvertError(GetLastError());
    if (Tcl_GetErrno() == EBADF) {
	Tcl_SetErrno(EACCES);
	return TCL_ERROR;
    }
    if (Tcl_GetErrno() == EACCES) {
	DWORD srcAttr, dstAttr;

	srcAttr = tclWinProcs->getFileAttributesProc(nativeSrc);
	dstAttr = tclWinProcs->getFileAttributesProc(nativeDst);
	if (srcAttr != 0xffffffff) {
	    if (dstAttr == 0xffffffff) {
		dstAttr = 0;
	    }
	    if ((srcAttr & FILE_ATTRIBUTE_DIRECTORY) ||
		    (dstAttr & FILE_ATTRIBUTE_DIRECTORY)) {
		if (srcAttr & FILE_ATTRIBUTE_REPARSE_POINT) {
		    /* Source is a symbolic link -- copy it */
		    if (TclWinSymLinkCopyDirectory(nativeSrc, nativeDst)==0) {
			return TCL_OK;
		    }
		}
		Tcl_SetErrno(EISDIR);
	    }
	    if (dstAttr & FILE_ATTRIBUTE_READONLY) {
		tclWinProcs->setFileAttributesProc(nativeDst,
			dstAttr & ~((DWORD)FILE_ATTRIBUTE_READONLY));
		if (tclWinProcs->copyFileProc(nativeSrc, nativeDst,
			0) != FALSE) {
		    return TCL_OK;
		}

		/*
		 * Still can't copy onto dst. Return that error, and restore
		 * attributes of dst.
		 */

		TclWinConvertError(GetLastError());
		tclWinProcs->setFileAttributesProc(nativeDst, dstAttr);
	    }
	}
    }
    return TCL_ERROR;
}

/*
 *---------------------------------------------------------------------------
 *
 * TclpObjDeleteFile, TclpDeleteFile --
 *
 *	Removes a single file (not a directory).
 *
 * Results:
 *	If the file was successfully deleted, returns TCL_OK. Otherwise the
 *	return value is TCL_ERROR and errno is set to indicate the error.
 *	Some possible values for errno are:
 *
 *	EACCES:	    a parent directory can't be read and/or written.
 *	EISDIR:	    path is a directory.
 *	ENOENT:	    path doesn't exist or is "".
 *
 *	EACCES:	    exists an open file already referring to path.
 *	EACCES:	    path is a char device (nul:, com1:, etc.)
 *
 * Side effects:
 *	The file is deleted, even if it is read-only.
 *
 *---------------------------------------------------------------------------
 */

int
TclpObjDeleteFile(
    Tcl_Obj *pathPtr)
{
    return TclpDeleteFile(Tcl_FSGetNativePath(pathPtr));
}

int
TclpDeleteFile(
    const void *nativePath)	/* Pathname of file to be removed (native). */
{
    DWORD attr;
    const TCHAR *path = nativePath;

    /*
     * The DeleteFile API acts differently under Win95/98 and NT WRT NULL and
     * "". Avoid passing these values.
     */

    if (path == NULL || path[0] == '\0') {
	Tcl_SetErrno(ENOENT);
	return TCL_ERROR;
    }

    if (tclWinProcs->deleteFileProc(path) != FALSE) {
	return TCL_OK;
    }
    TclWinConvertError(GetLastError());

    if (Tcl_GetErrno() == EACCES) {
	attr = tclWinProcs->getFileAttributesProc(path);
	if (attr != 0xffffffff) {
	    if (attr & FILE_ATTRIBUTE_DIRECTORY) {
		if (attr & FILE_ATTRIBUTE_REPARSE_POINT) {
		    /*
		     * It is a symbolic link - remove it.
		     */
		    if (TclWinSymLinkDelete(path, 0) == 0) {
			return TCL_OK;
		    }
		}

		/*
		 * If we fall through here, it is a directory.
		 *
		 * Windows NT reports removing a directory as EACCES instead
		 * of EISDIR.
		 */

		Tcl_SetErrno(EISDIR);
	    } else if (attr & FILE_ATTRIBUTE_READONLY) {
		int res = tclWinProcs->setFileAttributesProc(path,
			attr & ~((DWORD) FILE_ATTRIBUTE_READONLY));

		if ((res != 0) &&
			(tclWinProcs->deleteFileProc(path) != FALSE)) {
		    return TCL_OK;
		}
		TclWinConvertError(GetLastError());
		if (res != 0) {
		    tclWinProcs->setFileAttributesProc(path, attr);
		}
	    }
	}
    } else if (Tcl_GetErrno() == ENOENT) {
	attr = tclWinProcs->getFileAttributesProc(path);
	if (attr != 0xffffffff) {
	    if (attr & FILE_ATTRIBUTE_DIRECTORY) {
		/*
		 * Windows 95 reports removing a directory as ENOENT instead
		 * of EISDIR.
		 */

		Tcl_SetErrno(EISDIR);
	    }
	}
    } else if (Tcl_GetErrno() == EINVAL) {
	/*
	 * Windows NT reports removing a char device as EINVAL instead of
	 * EACCES.
	 */

	Tcl_SetErrno(EACCES);
    }

    return TCL_ERROR;
}

/*
 *---------------------------------------------------------------------------
 *
 * TclpObjCreateDirectory --
 *
 *	Creates the specified directory. All parent directories of the
 *	specified directory must already exist. The directory is automatically
 *	created with permissions so that user can access the new directory and
 *	create new files or subdirectories in it.
 *
 * Results:
 *	If the directory was successfully created, returns TCL_OK. Otherwise
 *	the return value is TCL_ERROR and errno is set to indicate the error.
 *	Some possible values for errno are:
 *
 *	EACCES:	    a parent directory can't be read and/or written.
 *	EEXIST:	    path already exists.
 *	ENOENT:	    a parent directory doesn't exist.
 *
 * Side effects:
 *	A directory is created.
 *
 *---------------------------------------------------------------------------
 */

int
TclpObjCreateDirectory(
    Tcl_Obj *pathPtr)
{
    return DoCreateDirectory(Tcl_FSGetNativePath(pathPtr));
}

static int
DoCreateDirectory(
    const TCHAR *nativePath)	/* Pathname of directory to create (native). */
{
    if (tclWinProcs->createDirectoryProc(nativePath, NULL) == 0) {
	DWORD error = GetLastError();

	TclWinConvertError(error);
	return TCL_ERROR;
    }
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * TclpObjCopyDirectory --
 *
 *	Recursively copies a directory. The target directory dst must not
 *	already exist. Note that this function does not merge two directory
 *	hierarchies, even if the target directory is an an empty directory.
 *
 * Results:
 *	If the directory was successfully copied, returns TCL_OK. Otherwise
 *	the return value is TCL_ERROR, errno is set to indicate the error, and
 *	the pathname of the file that caused the error is stored in errorPtr.
 *	See TclpCreateDirectory and TclpCopyFile for a description of possible
 *	values for errno.
 *
 * Side effects:
 *	An exact copy of the directory hierarchy src will be created with the
 *	name dst. If an error occurs, the error will be returned immediately,
 *	and remaining files will not be processed.
 *
 *---------------------------------------------------------------------------
 */

int
TclpObjCopyDirectory(
    Tcl_Obj *srcPathPtr,
    Tcl_Obj *destPathPtr,
    Tcl_Obj **errorPtr)
{
    Tcl_DString ds;
    Tcl_DString srcString, dstString;
    Tcl_Obj *normSrcPtr, *normDestPtr;
    int ret;

    normSrcPtr = Tcl_FSGetNormalizedPath(NULL,srcPathPtr);
    normDestPtr = Tcl_FSGetNormalizedPath(NULL,destPathPtr);
    if ((normSrcPtr == NULL) || (normDestPtr == NULL)) {
	return TCL_ERROR;
    }

    tclWinProcs->utf2tchar(Tcl_GetString(normSrcPtr), -1, &srcString);
    tclWinProcs->utf2tchar(Tcl_GetString(normDestPtr), -1, &dstString);

    ret = TraverseWinTree(TraversalCopy, &srcString, &dstString, &ds);

    Tcl_DStringFree(&srcString);
    Tcl_DStringFree(&dstString);

    if (ret != TCL_OK) {
	if (!strcmp(Tcl_DStringValue(&ds), TclGetString(normSrcPtr))) {
	    *errorPtr = srcPathPtr;
	} else if (!strcmp(Tcl_DStringValue(&ds), TclGetString(normDestPtr))) {
	    *errorPtr = destPathPtr;
	} else {
	    *errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1);
	}
	Tcl_DStringFree(&ds);
	Tcl_IncrRefCount(*errorPtr);
    }
    return ret;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpObjRemoveDirectory, DoRemoveDirectory --
 *
 *	Removes directory (and its contents, if the recursive flag is set).
 *
 * Results:
 *	If the directory was successfully removed, returns TCL_OK. Otherwise
 *	the return value is TCL_ERROR, errno is set to indicate the error, and
 *	the pathname of the file that caused the error is stored in errorPtr.
 *	Some possible values for errno are:
 *
 *	EACCES:	    path directory can't be read and/or written.
 *	EEXIST:	    path is a non-empty directory.
 *	EINVAL:	    path is root directory or current directory.
 *	ENOENT:	    path doesn't exist or is "".
 *	ENOTDIR:    path is not a directory.
 *
 *	EACCES:	    path is a char device (nul:, com1:, etc.) (95)
 *	EINVAL:	    path is a char device (nul:, com1:, etc.) (NT)
 *
 * Side effects:
 *	Directory removed. If an error occurs, the error will be returned
 *	immediately, and remaining files will not be deleted.
 *
 *----------------------------------------------------------------------
 */

int
TclpObjRemoveDirectory(
    Tcl_Obj *pathPtr,
    int recursive,
    Tcl_Obj **errorPtr)
{
    Tcl_DString ds;
    Tcl_Obj *normPtr = NULL;
    int ret;

    if (recursive) {
	/*
	 * In the recursive case, the string rep is used to construct a
	 * Tcl_DString which may be used extensively, so we can't optimize
	 * this case easily.
	 */

	Tcl_DString native;
	normPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
	if (normPtr == NULL) {
	    return TCL_ERROR;
	}
	tclWinProcs->utf2tchar(Tcl_GetString(normPtr), -1, &native);
	ret = DoRemoveDirectory(&native, recursive, &ds);
	Tcl_DStringFree(&native);
    } else {
	ret = DoRemoveJustDirectory(Tcl_FSGetNativePath(pathPtr), 0, &ds);
    }

    if (ret != TCL_OK) {
	int len = Tcl_DStringLength(&ds);
	if (len > 0) {
	    if (normPtr != NULL &&
		    !strcmp(Tcl_DStringValue(&ds), TclGetString(normPtr))) {
		*errorPtr = pathPtr;
	    } else {
		*errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1);
	    }
	    Tcl_IncrRefCount(*errorPtr);
	}
	Tcl_DStringFree(&ds);
    }

    return ret;
}

static int
DoRemoveJustDirectory(
    const TCHAR *nativePath,	/* Pathname of directory to be removed
				 * (native). */
    int ignoreError,		/* If non-zero, don't initialize the errorPtr
				 * under some circumstances on return. */
    Tcl_DString *errorPtr)	/* If non-NULL, uninitialized or free DString
				 * filled with UTF-8 name of file causing
				 * error. */
{
    DWORD attr;

    /*
     * The RemoveDirectory API acts differently under Win95/98 and NT WRT NULL
     * and "". Avoid passing these values.
     */

    if (nativePath == NULL || nativePath[0] == '\0') {
	Tcl_SetErrno(ENOENT);
	goto end;
    }

    attr = tclWinProcs->getFileAttributesProc(nativePath);

    if (attr & FILE_ATTRIBUTE_REPARSE_POINT) {
	/*
	 * It is a symbolic link - remove it.
	 */
	if (TclWinSymLinkDelete(nativePath, 0) == 0) {
	    return TCL_OK;
	}
    } else {
	/*
	 * Ordinary directory.
	 */

	if (tclWinProcs->removeDirectoryProc(nativePath) != FALSE) {
	    return TCL_OK;
	}
    }

    TclWinConvertError(GetLastError());

    if (Tcl_GetErrno() == EACCES) {
	attr = tclWinProcs->getFileAttributesProc(nativePath);
	if (attr != 0xffffffff) {
	    if ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0) {
		/*
		 * Windows 95 reports calling RemoveDirectory on a file as an
		 * EACCES, not an ENOTDIR.
		 */

		Tcl_SetErrno(ENOTDIR);
		goto end;
	    }

	    if (attr & FILE_ATTRIBUTE_REPARSE_POINT) {
		/*
		 * It is a symbolic link - remove it.
		 */

		if (TclWinSymLinkDelete(nativePath, 1) != 0) {
		    goto end;
		}
	    }

	    if (attr & FILE_ATTRIBUTE_READONLY) {
		attr &= ~FILE_ATTRIBUTE_READONLY;
		if (tclWinProcs->setFileAttributesProc(nativePath,
			attr) == FALSE) {
		    goto end;
		}
		if (tclWinProcs->removeDirectoryProc(nativePath) != FALSE) {
		    return TCL_OK;
		}
		TclWinConvertError(GetLastError());
		tclWinProcs->setFileAttributesProc(nativePath,
			attr | FILE_ATTRIBUTE_READONLY);
	    }

	    /*
	     * Windows 95 reports removing a non-empty directory as
	     * EACCES, not EEXIST. If the directory is not empty, change errno
	     * so caller knows what's going on.
	     */

	    if (TclWinGetPlatformId() == VER_PLATFORM_WIN32_WINDOWS) {
		const char *path, *find;
		HANDLE handle;
		WIN32_FIND_DATAA data;
		Tcl_DString buffer;
		int len;

		path = (const char *) nativePath;

		Tcl_DStringInit(&buffer);
		len = strlen(path);
		find = Tcl_DStringAppend(&buffer, path, len);
		if ((len > 0) && (find[len - 1] != '\\')) {
		    Tcl_DStringAppend(&buffer, "\\", 1);
		}
		find = Tcl_DStringAppend(&buffer, "*.*", 3);
		handle = FindFirstFileA(find, &data);
		if (handle != INVALID_HANDLE_VALUE) {
		    while (1) {
			if ((strcmp(data.cFileName, ".") != 0)
				&& (strcmp(data.cFileName, "..") != 0)) {
			    /*
			     * Found something in this directory.
			     */

			    Tcl_SetErrno(EEXIST);
			    break;
			}
			if (FindNextFileA(handle, &data) == FALSE) {
			    break;
			}
		    }
		    FindClose(handle);
		}
		Tcl_DStringFree(&buffer);
	    }
	}
    }

    if (Tcl_GetErrno() == ENOTEMPTY) {
	/*
	 * The caller depends on EEXIST to signify that the directory is not
	 * empty, not ENOTEMPTY.
	 */

	Tcl_SetErrno(EEXIST);
    }

    if ((ignoreError != 0) && (Tcl_GetErrno() == EEXIST)) {
	/*
	 * If we're being recursive, this error may actually be ok, so we
	 * don't want to initialise the errorPtr yet.
	 */
	return TCL_ERROR;
    }

  end:
    if (errorPtr != NULL) {
	tclWinProcs->tchar2utf(nativePath, -1, errorPtr);
    }
    return TCL_ERROR;

}

static int
DoRemoveDirectory(
    Tcl_DString *pathPtr,	/* Pathname of directory to be removed
				 * (native). */
    int recursive,		/* If non-zero, removes directories that are
				 * nonempty. Otherwise, will only remove empty
				 * directories. */
    Tcl_DString *errorPtr)	/* If non-NULL, uninitialized or free DString
				 * filled with UTF-8 name of file causing
				 * error. */
{
    int res = DoRemoveJustDirectory((const TCHAR *)Tcl_DStringValue(pathPtr), recursive,
	    errorPtr);

    if ((res == TCL_ERROR) && (recursive != 0) && (Tcl_GetErrno() == EEXIST)) {
	/*
	 * The directory is nonempty, but the recursive flag has been
	 * specified, so we recursively remove all the files in the directory.
	 */

	return TraverseWinTree(TraversalDelete, pathPtr, NULL, errorPtr);
    } else {
	return res;
    }
}

/*
 *---------------------------------------------------------------------------
 *
 * TraverseWinTree --
 *
 *	Traverse directory tree specified by sourcePtr, calling the function
 *	traverseProc for each file and directory encountered. If destPtr is
 *	non-null, each of name in the sourcePtr directory is appended to the
 *	directory specified by destPtr and passed as the second argument to
 *	traverseProc().
 *
 * Results:
 *	Standard Tcl result.
 *
 * Side effects:
 *	None caused by TraverseWinTree, however the user specified
 *	traverseProc() may change state. If an error occurs, the error will be
 *	returned immediately, and remaining files will not be processed.
 *
 *---------------------------------------------------------------------------
 */

static int
TraverseWinTree(
    TraversalProc *traverseProc,/* Function to call for every file and
				 * directory in source hierarchy. */
    Tcl_DString *sourcePtr,	/* Pathname of source directory to be
				 * traversed (native). */
    Tcl_DString *targetPtr,	/* Pathname of directory to traverse in
				 * parallel with source directory (native),
				 * may be NULL. */
    Tcl_DString *errorPtr)	/* If non-NULL, uninitialized or free DString
				 * filled with UTF-8 name of file causing
				 * error. */
{
    DWORD sourceAttr;
    TCHAR *nativeSource, *nativeTarget, *nativeErrfile;
    int result, found, sourceLen, targetLen = 0, oldSourceLen, oldTargetLen;
    HANDLE handle;
    WIN32_FIND_DATAT data;

    nativeErrfile = NULL;
    result = TCL_OK;
    oldTargetLen = 0;		/* lint. */

    nativeSource = (TCHAR *) Tcl_DStringValue(sourcePtr);
    nativeTarget = (TCHAR *)
	    (targetPtr == NULL ? NULL : Tcl_DStringValue(targetPtr));

    oldSourceLen = Tcl_DStringLength(sourcePtr);
    sourceAttr = tclWinProcs->getFileAttributesProc(nativeSource);
    if (sourceAttr == 0xffffffff) {
	nativeErrfile = nativeSource;
	goto end;
    }

    if (sourceAttr & FILE_ATTRIBUTE_REPARSE_POINT) {
	/*
	 * Process the symbolic link
	 */

	return traverseProc(nativeSource, nativeTarget, DOTREE_LINK,
		errorPtr);
    }

    if ((sourceAttr & FILE_ATTRIBUTE_DIRECTORY) == 0) {
	/*
	 * Process the regular file
	 */

	return traverseProc(nativeSource, nativeTarget, DOTREE_F, errorPtr);
    }

    Tcl_DStringAppend(sourcePtr, (char *) L"\\*.*", 4 * sizeof(WCHAR) + 1);
    Tcl_DStringSetLength(sourcePtr, Tcl_DStringLength(sourcePtr) - 1);

    nativeSource = (TCHAR *) Tcl_DStringValue(sourcePtr);
    handle = tclWinProcs->findFirstFileProc(nativeSource, &data);
    if (handle == INVALID_HANDLE_VALUE) {
	/*
	 * Can't read directory.
	 */

	TclWinConvertError(GetLastError());
	nativeErrfile = nativeSource;
	goto end;
    }

    Tcl_DStringSetLength(sourcePtr, oldSourceLen + 1);
    Tcl_DStringSetLength(sourcePtr, oldSourceLen);
    result = traverseProc(nativeSource, nativeTarget, DOTREE_PRED,
	    errorPtr);
    if (result != TCL_OK) {
	FindClose(handle);
	return result;
    }

    sourceLen = oldSourceLen + sizeof(WCHAR);
    Tcl_DStringAppend(sourcePtr, (char *) L"\\", sizeof(WCHAR) + 1);
    Tcl_DStringSetLength(sourcePtr, sourceLen);
    if (targetPtr != NULL) {
	oldTargetLen = Tcl_DStringLength(targetPtr);

	targetLen = oldTargetLen;
	targetLen += sizeof(WCHAR);
	Tcl_DStringAppend(targetPtr, (char *) L"\\", sizeof(WCHAR) + 1);
	Tcl_DStringSetLength(targetPtr, targetLen);
    }

    found = 1;
    for (; found; found = tclWinProcs->findNextFileProc(handle, &data)) {
	TCHAR *nativeName;
	int len;

	WCHAR *wp = data.w.cFileName;
	if (*wp == '.') {
	    wp++;
	    if (*wp == '.') {
		wp++;
	    }
	    if (*wp == '\0') {
		continue;
	    }
	}
	nativeName = (TCHAR *) data.w.cFileName;
	len = wcslen(data.w.cFileName) * sizeof(WCHAR);

	/*
	 * Append name after slash, and recurse on the file.
	 */

	Tcl_DStringAppend(sourcePtr, (char *) nativeName, len + 1);
	Tcl_DStringSetLength(sourcePtr, Tcl_DStringLength(sourcePtr) - 1);
	if (targetPtr != NULL) {
	    Tcl_DStringAppend(targetPtr, (char *) nativeName, len + 1);
	    Tcl_DStringSetLength(targetPtr, Tcl_DStringLength(targetPtr) - 1);
	}
	result = TraverseWinTree(traverseProc, sourcePtr, targetPtr,
		errorPtr);
	if (result != TCL_OK) {
	    break;
	}

	/*
	 * Remove name after slash.
	 */

	Tcl_DStringSetLength(sourcePtr, sourceLen);
	if (targetPtr != NULL) {
	    Tcl_DStringSetLength(targetPtr, targetLen);
	}
    }
    FindClose(handle);

    /*
     * Strip off the trailing slash we added.
     */

    Tcl_DStringSetLength(sourcePtr, oldSourceLen + 1);
    Tcl_DStringSetLength(sourcePtr, oldSourceLen);
    if (targetPtr != NULL) {
	Tcl_DStringSetLength(targetPtr, oldTargetLen + 1);
	Tcl_DStringSetLength(targetPtr, oldTargetLen);
    }
    if (result == TCL_OK) {
	/*
	 * Call traverseProc() on a directory after visiting all the
	 * files in that directory.
	 */

	result = traverseProc((const TCHAR *)Tcl_DStringValue(sourcePtr),
		(const TCHAR *)(targetPtr == NULL ? NULL : Tcl_DStringValue(targetPtr)),
		DOTREE_POSTD, errorPtr);
    }

  end:
    if (nativeErrfile != NULL) {
	TclWinConvertError(GetLastError());
	if (errorPtr != NULL) {
	    tclWinProcs->tchar2utf(nativeErrfile, -1, errorPtr);
	}
	result = TCL_ERROR;
    }

    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * TraversalCopy
 *
 *	Called from TraverseUnixTree in order to execute a recursive copy of a
 *	directory.
 *
 * Results:
 *	Standard Tcl result.
 *
 * Side effects:
 *	Depending on the value of type, src may be copied to dst.
 *
 *----------------------------------------------------------------------
 */

static int
TraversalCopy(
    const TCHAR *nativeSrc,	/* Source pathname to copy. */
    const TCHAR *nativeDst,	/* Destination pathname of copy. */
    int type,			/* Reason for call - see TraverseWinTree() */
    Tcl_DString *errorPtr)	/* If non-NULL, initialized DString filled
				 * with UTF-8 name of file causing error. */
{
    switch (type) {
    case DOTREE_F:
	if (DoCopyFile(nativeSrc, nativeDst) == TCL_OK) {
	    return TCL_OK;
	}
	break;
    case DOTREE_LINK:
	if (TclWinSymLinkCopyDirectory(nativeSrc, nativeDst) == TCL_OK) {
	    return TCL_OK;
	}
	break;
    case DOTREE_PRED:
	if (DoCreateDirectory(nativeDst) == TCL_OK) {
	    DWORD attr = tclWinProcs->getFileAttributesProc(nativeSrc);

	    if (tclWinProcs->setFileAttributesProc(nativeDst,
		    attr) != FALSE) {
		return TCL_OK;
	    }
	    TclWinConvertError(GetLastError());
	}
	break;
    case DOTREE_POSTD:
	return TCL_OK;
    }

    /*
     * There shouldn't be a problem with src, because we already checked it to
     * get here.
     */

    if (errorPtr != NULL) {
	tclWinProcs->tchar2utf(nativeDst, -1, errorPtr);
    }
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * TraversalDelete --
 *
 *	Called by function TraverseWinTree for every file and directory that
 *	it encounters in a directory hierarchy. This function unlinks files,
 *	and removes directories after all the containing files have been
 *	processed.
 *
 * Results:
 *	Standard Tcl result.
 *
 * Side effects:
 *	Files or directory specified by src will be deleted. If an error
 *	occurs, the windows error is converted to a Posix error and errno is
 *	set accordingly.
 *
 *----------------------------------------------------------------------
 */

static int
TraversalDelete(
    const TCHAR *nativeSrc,	/* Source pathname to delete. */
    const TCHAR *dstPtr,	/* Not used. */
    int type,			/* Reason for call - see TraverseWinTree() */
    Tcl_DString *errorPtr)	/* If non-NULL, initialized DString filled
				 * with UTF-8 name of file causing error. */
{
    switch (type) {
    case DOTREE_F:
	if (TclpDeleteFile(nativeSrc) == TCL_OK) {
	    return TCL_OK;
	}
	break;
    case DOTREE_LINK:
	if (DoRemoveJustDirectory(nativeSrc, 0, NULL) == TCL_OK) {
	    return TCL_OK;
	}
	break;
    case DOTREE_PRED:
	return TCL_OK;
    case DOTREE_POSTD:
	if (DoRemoveJustDirectory(nativeSrc, 0, NULL) == TCL_OK) {
	    return TCL_OK;
	}
	break;
    }

    if (errorPtr != NULL) {
	tclWinProcs->tchar2utf(nativeSrc, -1, errorPtr);
    }
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * StatError --
 *
 *	Sets the object result with the appropriate error.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The interp's object result is set with an error message based on the
 *	objIndex, fileName and errno.
 *
 *----------------------------------------------------------------------
 */

static void
StatError(
    Tcl_Interp *interp,		/* The interp that has the error */
    Tcl_Obj *fileName)		/* The name of the file which caused the
				 * error. */
{
    TclWinConvertError(GetLastError());
    Tcl_AppendResult(interp, "could not read \"", TclGetString(fileName),
	    "\": ", Tcl_PosixError(interp), (char *) NULL);
}

/*
 *----------------------------------------------------------------------
 *
 * GetWinFileAttributes --
 *
 *	Returns a Tcl_Obj containing the value of a file attribute. This
 *	routine gets the -hidden, -readonly or -system attribute.
 *
 * Results:
 *	Standard Tcl result and a Tcl_Obj in attributePtrPtr. The object will
 *	have ref count 0. If the return value is not TCL_OK, attributePtrPtr
 *	is not touched.
 *
 * Side effects:
 *	A new object is allocated if the file is valid.
 *
 *----------------------------------------------------------------------
 */

static int
GetWinFileAttributes(
    Tcl_Interp *interp,		/* The interp we are using for errors. */
    int objIndex,		/* The index of the attribute. */
    Tcl_Obj *fileName,		/* The name of the file. */
    Tcl_Obj **attributePtrPtr)	/* A pointer to return the object with. */
{
    DWORD result;
    const TCHAR *nativeName;
    int attr;

    nativeName = Tcl_FSGetNativePath(fileName);
    result = tclWinProcs->getFileAttributesProc(nativeName);

    if (result == 0xffffffff) {
	StatError(interp, fileName);
	return TCL_ERROR;
    }

    attr = (int)(result & attributeArray[objIndex]);
    if ((objIndex == WIN_HIDDEN_ATTRIBUTE) && (attr != 0)) {
	/*
	 * It is hidden. However there is a bug on some Windows OSes in which
	 * root volumes (drives) formatted as NTFS are declared hidden when
	 * they are not (and cannot be).
	 *
	 * We test for, and fix that case, here.
	 */

	int len;
	const char *str = Tcl_GetStringFromObj(fileName,&len);

	if (len < 4) {
	    if (len == 0) {
		/*
		 * Not sure if this is possible, but we pass it on anyway.
		 */
	    } else if (len == 1 && (str[0] == '/' || str[0] == '\\')) {
		/*
		 * Path is pointing to the root volume.
		 */

		attr = 0;
	    } else if ((str[1] == ':')
		    && (len == 2 || (str[2] == '/' || str[2] == '\\'))) {
		/*
		 * Path is of the form 'x:' or 'x:/' or 'x:\'
		 */

		attr = 0;
	    }
	}
    }

    *attributePtrPtr = Tcl_NewBooleanObj(attr);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * ConvertFileNameFormat --
 *
 *	Returns a Tcl_Obj containing either the long or short version of the
 *	file name.
 *
 * Results:
 *	Standard Tcl result and a Tcl_Obj in attributePtrPtr. The object will
 *	have ref count 0. If the return value is not TCL_OK, attributePtrPtr
 *	is not touched.
 *
 *	Warning: if you pass this function a drive name like 'c:' it will
 *	actually return the current working directory on that drive. To avoid
 *	this, make sure the drive name ends in a slash, like this 'c:/'.
 *
 * Side effects:
 *	A new object is allocated if the file is valid.
 *
 *----------------------------------------------------------------------
 */

static int
ConvertFileNameFormat(
    Tcl_Interp *interp,		/* The interp we are using for errors. */
    int objIndex,		/* The index of the attribute. */
    Tcl_Obj *fileName,		/* The name of the file. */
    int longShort,		/* 0 to short name, 1 to long name. */
    Tcl_Obj **attributePtrPtr)	/* A pointer to return the object with. */
{
    int pathc, i;
    Tcl_Obj *splitPath;

    splitPath = Tcl_FSSplitPath(fileName, &pathc);

    if (splitPath == NULL || pathc == 0) {
	if (interp != NULL) {
	    Tcl_AppendResult(interp, "could not read \"",
		    Tcl_GetString(fileName), "\": no such file or directory",
		    (char *) NULL);
	}
	goto cleanup;
    }

    /*
     * We will decrement this again at the end.	 It is safer to do this in
     * case any of the calls below retain a reference to splitPath.
     */

    Tcl_IncrRefCount(splitPath);

    for (i = 0; i < pathc; i++) {
	Tcl_Obj *elt;
	char *pathv;
	int pathLen;

	Tcl_ListObjIndex(NULL, splitPath, i, &elt);

	pathv = Tcl_GetStringFromObj(elt, &pathLen);
	if ((pathv[0] == '/') || ((pathLen == 3) && (pathv[1] == ':'))
		|| (strcmp(pathv, ".") == 0) || (strcmp(pathv, "..") == 0)) {
	    /*
	     * Handle "/", "//machine/export", "c:/", "." or ".." by just
	     * copying the string literally.  Uppercase the drive letter, just
	     * because it looks better under Windows to do so.
	     */

	simple:
	    /*
	     * Here we are modifying the string representation in place.
	     *
	     * I believe this is legal, since this won't affect any file
	     * representation this thing may have.
	     */

	    pathv[0] = (char) Tcl_UniCharToUpper(UCHAR(pathv[0]));
	} else {
	    Tcl_Obj *tempPath;
	    Tcl_DString ds;
	    Tcl_DString dsTemp;
	    const TCHAR *nativeName;
	    const char *tempString;
	    int tempLen;
	    WIN32_FIND_DATAT data;
	    HANDLE handle;
	    DWORD attr;

	    tempPath = Tcl_FSJoinPath(splitPath, i+1);
	    Tcl_IncrRefCount(tempPath);

	    /*
	     * We'd like to call Tcl_FSGetNativePath(tempPath) but that is
	     * likely to lead to infinite loops.
	     */

	    Tcl_DStringInit(&ds);
	    tempString = Tcl_GetStringFromObj(tempPath,&tempLen);
	    nativeName = tclWinProcs->utf2tchar(tempString, tempLen, &ds);
	    Tcl_DecrRefCount(tempPath);
	    handle = tclWinProcs->findFirstFileProc(nativeName, &data);
	    if (handle == INVALID_HANDLE_VALUE) {
		/*
		 * FindFirstFile() doesn't like root directories. We would
		 * only get a root directory here if the caller specified "c:"
		 * or "c:." and the current directory on the drive was the
		 * root directory
		 */

		attr = tclWinProcs->getFileAttributesProc(nativeName);
		if ((attr!=0xFFFFFFFF) && (attr & FILE_ATTRIBUTE_DIRECTORY)) {
		    Tcl_DStringFree(&ds);
		    goto simple;
		}
	    }

	    if (handle == INVALID_HANDLE_VALUE) {
		Tcl_DStringFree(&ds);
		if (interp != NULL) {
		    StatError(interp, fileName);
		}
		goto cleanup;
	    }
	    nativeName = (TCHAR *) data.w.cAlternateFileName;
	    if (longShort) {
		if (data.w.cFileName[0] != '\0') {
		    nativeName = (TCHAR *) data.w.cFileName;
		}
	    } else {
		if (data.w.cAlternateFileName[0] == '\0') {
		    nativeName = (TCHAR *) data.w.cFileName;
		}
	    }

	    /*
	     * Purify reports a extraneous UMR in Tcl_WinTCharToUtf() trying
	     * to dereference nativeName as a Unicode string. I have proven to
	     * myself that purify is wrong by running the following example
	     * when nativeName == data.w.cAlternateFileName and noting that
	     * purify doesn't complain about the first line, but does complain
	     * about the second.
	     *
	     *	fprintf(stderr, "%d\n", data.w.cAlternateFileName[0]);
	     *	fprintf(stderr, "%d\n", ((WCHAR *) nativeName)[0]);
	     */

	    Tcl_DStringInit(&dsTemp);
	    tclWinProcs->tchar2utf(nativeName, -1, &dsTemp);

	    /*
	     * Deal with issues of tildes being absolute.
	     */

	    if (Tcl_DStringValue(&dsTemp)[0] == '~') {
		TclNewLiteralStringObj(tempPath, "./");
		Tcl_AppendToObj(tempPath, Tcl_DStringValue(&dsTemp),
			Tcl_DStringLength(&dsTemp));
	    } else {
		tempPath = Tcl_NewStringObj(Tcl_DStringValue(&dsTemp),
			Tcl_DStringLength(&dsTemp));
	    }
	    Tcl_ListObjReplace(NULL, splitPath, i, 1, 1, &tempPath);
	    Tcl_DStringFree(&ds);
	    Tcl_DStringFree(&dsTemp);
	    FindClose(handle);
	}
    }

    *attributePtrPtr = Tcl_FSJoinPath(splitPath, -1);

    if (splitPath != NULL) {
	/*
	 * Unfortunately, the object we will return may have its only refCount
	 * as part of the list splitPath. This means if we free splitPath, the
	 * object will disappear. So, we have to be very careful here.
	 * Unfortunately this means we must manipulate the object's refCount
	 * directly.
	 */

	Tcl_IncrRefCount(*attributePtrPtr);
	Tcl_DecrRefCount(splitPath);
	--(*attributePtrPtr)->refCount;
    }
    return TCL_OK;

  cleanup:
    if (splitPath != NULL) {
	Tcl_DecrRefCount(splitPath);
    }

    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * GetWinFileLongName --
 *
 *	Returns a Tcl_Obj containing the long version of the file name.
 *
 * Results:
 *	Standard Tcl result and a Tcl_Obj in attributePtrPtr. The object will
 *	have ref count 0. If the return value is not TCL_OK, attributePtrPtr
 *	is not touched.
 *
 * Side effects:
 *	A new object is allocated if the file is valid.
 *
 *----------------------------------------------------------------------
 */

static int
GetWinFileLongName(
    Tcl_Interp *interp,		/* The interp we are using for errors. */
    int objIndex,		/* The index of the attribute. */
    Tcl_Obj *fileName,		/* The name of the file. */
    Tcl_Obj **attributePtrPtr)	/* A pointer to return the object with. */
{
    return ConvertFileNameFormat(interp, objIndex, fileName, 1,
	    attributePtrPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * GetWinFileShortName --
 *
 *	Returns a Tcl_Obj containing the short version of the file name.
 *
 * Results:
 *	Standard Tcl result and a Tcl_Obj in attributePtrPtr. The object will
 *	have ref count 0. If the return value is not TCL_OK, attributePtrPtr
 *	is not touched.
 *
 * Side effects:
 *	A new object is allocated if the file is valid.
 *
 *----------------------------------------------------------------------
 */

static int
GetWinFileShortName(
    Tcl_Interp *interp,		/* The interp we are using for errors. */
    int objIndex,		/* The index of the attribute. */
    Tcl_Obj *fileName,		/* The name of the file. */
    Tcl_Obj **attributePtrPtr)	/* A pointer to return the object with. */
{
    return ConvertFileNameFormat(interp, objIndex, fileName, 0,
	    attributePtrPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * SetWinFileAttributes --
 *
 *	Set the file attributes to the value given by attributePtr. This
 *	routine sets the -hidden, -readonly, or -system attributes.
 *
 * Results:
 *	Standard TCL error.
 *
 * Side effects:
 *	The file's attribute is set.
 *
 *----------------------------------------------------------------------
 */

static int
SetWinFileAttributes(
    Tcl_Interp *interp,		/* The interp we are using for errors. */
    int objIndex,		/* The index of the attribute. */
    Tcl_Obj *fileName,		/* The name of the file. */
    Tcl_Obj *attributePtr)	/* The new value of the attribute. */
{
    DWORD fileAttributes;
    int yesNo, result;
    const TCHAR *nativeName;

    nativeName = Tcl_FSGetNativePath(fileName);
    fileAttributes = tclWinProcs->getFileAttributesProc(nativeName);

    if (fileAttributes == 0xffffffff) {
	StatError(interp, fileName);
	return TCL_ERROR;
    }

    result = Tcl_GetBooleanFromObj(interp, attributePtr, &yesNo);
    if (result != TCL_OK) {
	return result;
    }

    if (yesNo) {
	fileAttributes |= (attributeArray[objIndex]);
    } else {
	fileAttributes &= ~(attributeArray[objIndex]);
    }

    if (!tclWinProcs->setFileAttributesProc(nativeName, fileAttributes)) {
	StatError(interp, fileName);
	return TCL_ERROR;
    }

    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * SetWinFileLongName --
 *
 *	The attribute in question is a readonly attribute and cannot be set.
 *
 * Results:
 *	TCL_ERROR
 *
 * Side effects:
 *	The object result is set to a pertinent error message.
 *
 *----------------------------------------------------------------------
 */

static int
CannotSetAttribute(
    Tcl_Interp *interp,		/* The interp we are using for errors. */
    int objIndex,		/* The index of the attribute. */
    Tcl_Obj *fileName,		/* The name of the file. */
    Tcl_Obj *attributePtr)	/* The new value of the attribute. */
{
    Tcl_AppendResult(interp, "cannot set attribute \"",
	    tclpFileAttrStrings[objIndex], "\" for file \"",
	    Tcl_GetString(fileName), "\": attribute is readonly", NULL);
    return TCL_ERROR;
}


/*
 *---------------------------------------------------------------------------
 *
 * TclpObjListVolumes --
 *
 *	Lists the currently mounted volumes
 *
 * Results:
 *	The list of volumes.
 *
 * Side effects:
 *	None
 *
 *---------------------------------------------------------------------------
 */

Tcl_Obj *
TclpObjListVolumes(void)
{
    Tcl_Obj *resultPtr, *elemPtr;
    char buf[40 * 4];		/* There couldn't be more than 30 drives??? */
    int i;
    char *p;

    resultPtr = Tcl_NewObj();

    /*
     * On Win32s:
     * GetLogicalDriveStrings() isn't implemented.
     * GetLogicalDrives() returns incorrect information.
     */

    if (GetLogicalDriveStringsA(sizeof(buf), buf) == 0) {
	/*
	 * GetVolumeInformation() will detects all drives, but causes
	 * chattering on empty floppy drives. We only do this if
	 * GetLogicalDriveStrings() didn't work. It has also been reported
	 * that on some laptops it takes a while for GetVolumeInformation() to
	 * return when pinging an empty floppy drive, another reason to try to
	 * avoid calling it.
	 */

	buf[1] = ':';
	buf[2] = '/';
	buf[3] = '\0';

	for (i = 0; i < 26; i++) {
	    buf[0] = (char) ('a' + i);
	    if (GetVolumeInformationA(buf, NULL, 0, NULL, NULL, NULL, NULL, 0)
		    || (GetLastError() == ERROR_NOT_READY)) {
		elemPtr = Tcl_NewStringObj(buf, -1);
		Tcl_ListObjAppendElement(NULL, resultPtr, elemPtr);
	    }
	}
    } else {
	for (p = buf; *p != '\0'; p += 4) {
	    p[2] = '/';
	    elemPtr = Tcl_NewStringObj(p, -1);
	    Tcl_ListObjAppendElement(NULL, resultPtr, elemPtr);
	}
    }

    Tcl_IncrRefCount(resultPtr);
    return resultPtr;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */