source: downloads/tcl8.5.2/win/tclWinFCmd.c @ 68

/*
 * 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.52 2006/08/29 00:36:57 coldstore 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 *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.
     */

#ifndef HAVE_NO_SEH
    __try {
        if ((*tclWinProcs->moveFileProc)(nativeSrc, nativeDst) != FALSE) {
            retval = TCL_OK;
        }
    } __except (EXCEPTION_EXECUTE_HANDLER) {}
#else

    /*
     * 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;
    }
#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;
            WCHAR nativeSrcPath[MAX_PATH];
            WCHAR 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)((TCHAR *) nativeSrcPath);
            (*tclWinProcs->charLowerProc)((TCHAR *) nativeDstPath);

            src = Tcl_WinTCharToUtf((TCHAR *) nativeSrcPath, -1, &srcString);
            dst = Tcl_WinTCharToUtf((TCHAR *) 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;
                WCHAR 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;
                ((char *) nativeRest)[0] = '\0';
                ((char *) nativeRest)[1] = '\0';    /* In case it's Unicode. */

                result = TCL_ERROR;
                nativePrefix = (tclWinProcs->useWide)
                        ? (TCHAR *) L"tclr" : (TCHAR *) "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.
     */

#ifndef HAVE_NO_SEH
    __try {
        if ((*tclWinProcs->copyFileProc)(nativeSrc, nativeDst, 0) != FALSE) {
            retval = TCL_OK;
        }
    } __except (EXCEPTION_EXECUTE_HANDLER) {}
#else

    /*
     * 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;
    }
#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 TCHAR *nativePath)    /* Pathname of file to be removed (native). */
{
    DWORD attr;

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

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

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

    if (Tcl_GetErrno() == EACCES) {
        attr = (*tclWinProcs->getFileAttributesProc)(nativePath);
        if (attr != 0xffffffff) {
            if (attr & FILE_ATTRIBUTE_DIRECTORY) {
                if (attr & FILE_ATTRIBUTE_REPARSE_POINT) {
                    /*
                     * It is a symbolic link - remove it.
                     */
                    if (TclWinSymLinkDelete(nativePath, 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)(nativePath,
                        attr & ~((DWORD)FILE_ATTRIBUTE_READONLY));

                if ((res != 0) && ((*tclWinProcs->deleteFileProc)(nativePath)
                        != FALSE)) {
                    return TCL_OK;
                }
                TclWinConvertError(GetLastError());
                if (res != 0) {
                    (*tclWinProcs->setFileAttributesProc)(nativePath, attr);
                }
            }
        }
    } else if (Tcl_GetErrno() == ENOENT) {
        attr = (*tclWinProcs->getFileAttributesProc)(nativePath);
        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). */
{
    DWORD error;
    if ((*tclWinProcs->createDirectoryProc)(nativePath, NULL) == 0) {
        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;
    }

    Tcl_WinUtfToTChar(Tcl_GetString(normSrcPtr), -1, &srcString);
    Tcl_WinUtfToTChar(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;
        }
        Tcl_WinUtfToTChar(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 and Win32s report 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_NT) {
                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) {
        Tcl_WinTCharToUtf(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(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);
    }

    if (tclWinProcs->useWide) {
        Tcl_DStringAppend(sourcePtr, (char *) L"\\*.*", 4 * sizeof(WCHAR) + 1);
        Tcl_DStringSetLength(sourcePtr, Tcl_DStringLength(sourcePtr) - 1);
    } else {
        Tcl_DStringAppend(sourcePtr, "\\*.*", 4);
    }

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

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

    sourceLen = oldSourceLen;

    if (tclWinProcs->useWide) {
        sourceLen += sizeof(WCHAR);
        Tcl_DStringAppend(sourcePtr, (char *) L"\\", sizeof(WCHAR) + 1);
        Tcl_DStringSetLength(sourcePtr, sourceLen);
    } else {
        sourceLen += 1;
        Tcl_DStringAppend(sourcePtr, "\\", 1);
    }
    if (targetPtr != NULL) {
        oldTargetLen = Tcl_DStringLength(targetPtr);

        targetLen = oldTargetLen;
        if (tclWinProcs->useWide) {
            targetLen += sizeof(WCHAR);
            Tcl_DStringAppend(targetPtr, (char *) L"\\", sizeof(WCHAR) + 1);
            Tcl_DStringSetLength(targetPtr, targetLen);
        } else {
            targetLen += 1;
            Tcl_DStringAppend(targetPtr, "\\", 1);
        }
    }

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

        if (tclWinProcs->useWide) {
            WCHAR *wp;

            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);
        } else {
            if ((strcmp(data.a.cFileName, ".") == 0)
                    || (strcmp(data.a.cFileName, "..") == 0)) {
                continue;
            }
            nativeName = (TCHAR *) data.a.cFileName;
            len = strlen(data.a.cFileName);
        }

        /*
         * 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)(Tcl_DStringValue(sourcePtr),
                (targetPtr == NULL ? NULL : Tcl_DStringValue(targetPtr)),
                DOTREE_POSTD, errorPtr);
    }

  end:
    if (nativeErrfile != NULL) {
        TclWinConvertError(GetLastError());
        if (errorPtr != NULL) {
            Tcl_WinTCharToUtf(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) {
        Tcl_WinTCharToUtf(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) {
        Tcl_WinTCharToUtf(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;
        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;
            TCHAR *nativeName;
            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 = Tcl_WinUtfToTChar(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;
            }
            if (tclWinProcs->useWide) {
                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;
                    }
                }
            } else {
                nativeName = (TCHAR *) data.a.cAlternateFileName;
                if (longShort) {
                    if (data.a.cFileName[0] != '\0') {
                        nativeName = (TCHAR *) data.a.cFileName;
                    }
                } else {
                    if (data.a.cAlternateFileName[0] == '\0') {
                        nativeName = (TCHAR *) data.a.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);
            Tcl_WinTCharToUtf(nativeName, -1, &dsTemp);

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

            if (Tcl_DStringValue(&dsTemp)[0] == '~') {
                tempPath = Tcl_NewStringObj("./",2);
                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;
    int 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",
            (char *) 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:
 */