shared_source/c_tcl_base_7_5_w_mods/tclwinfile.c

/* $Header$ */
/* 
 * tclWinFile.c --
 *
 *      This file contains temporary wrappers around UNIX file handling
 *      functions. These wrappers map the UNIX functions to Win32 HANDLE-style
 *      files, which can be manipulated through the Win32 console redirection
 *      interfaces.
 *
 * Copyright (c) 1995-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: tclwinfile.c,v 1.1.1.1 2001/06/13 04:49:10 dtashley Exp $
 */

#include "tclWinInt.h"
#include <sys/stat.h>
#include <shlobj.h>
#include <lmaccess.h>           /* For TclpGetUserHome(). */

static time_t           ToCTime(FILETIME fileTime);

typedef NET_API_STATUS NET_API_FUNCTION NETUSERGETINFOPROC
        (LPWSTR servername, LPWSTR username, DWORD level, LPBYTE *bufptr);

typedef NET_API_STATUS NET_API_FUNCTION NETAPIBUFFERFREEPROC
        (LPVOID Buffer);

typedef NET_API_STATUS NET_API_FUNCTION NETGETDCNAMEPROC
        (LPWSTR servername, LPWSTR domainname, LPBYTE *bufptr);


/*
 *---------------------------------------------------------------------------
 *
 * TclpFindExecutable --
 *
 *      This procedure computes the absolute path name of the current
 *      application, given its argv[0] value.
 *
 * Results:
 *      A dirty UTF string that is the path to the executable.  At this
 *      point we may not know the system encoding.  Convert the native
 *      string value to UTF using the default encoding.  The assumption
 *      is that we will still be able to parse the path given the path
 *      name contains ASCII string and '/' chars do not conflict with
 *      other UTF chars.
 *
 * Side effects:
 *      The variable tclNativeExecutableName gets filled in with the file
 *      name for the application, if we figured it out.  If we couldn't
 *      figure it out, tclNativeExecutableName is set to NULL.
 *
 *---------------------------------------------------------------------------
 */

char *
TclpFindExecutable(argv0)
    CONST char *argv0;          /* The value of the application's argv[0]
                                 * (native). */
{
    Tcl_DString ds;
    WCHAR wName[MAX_PATH];

    if (argv0 == NULL) {
        return NULL;
    }
    if (tclNativeExecutableName != NULL) {
        return tclNativeExecutableName;
    }

    /*
     * Under Windows we ignore argv0, and return the path for the file used to
     * create this process.
     */

    (*tclWinProcs->getModuleFileNameProc)(NULL, wName, MAX_PATH);
    Tcl_WinTCharToUtf((TCHAR *) wName, -1, &ds);

    tclNativeExecutableName = ckalloc((unsigned) (Tcl_DStringLength(&ds) + 1));
    strcpy(tclNativeExecutableName, Tcl_DStringValue(&ds));
    Tcl_DStringFree(&ds);

    TclWinNoBackslash(tclNativeExecutableName);
    return tclNativeExecutableName;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpMatchFilesTypes --
 *
 *      This routine is used by the globbing code to search a
 *      directory for all files which match a given pattern.
 *
 * Results: 
 *      If the tail argument is NULL, then the matching files are
 *      added to the the interp's result.  Otherwise, TclDoGlob is called
 *      recursively for each matching subdirectory.  The return value
 *      is a standard Tcl result indicating whether an error occurred
 *      in globbing.
 *
 * Side effects:
 *      None.
 *
 *---------------------------------------------------------------------- */

int
TclpMatchFilesTypes(
    Tcl_Interp *interp,         /* Interpreter to receive results. */
    char *separators,           /* Directory separators to pass to TclDoGlob. */
    Tcl_DString *dirPtr,        /* Contains path to directory to search. */
    char *pattern,              /* Pattern to match against. */
    char *tail,                 /* Pointer to end of pattern.  Tail must
                                 * point to a location in pattern and must
                                 * not be static.*/
    GlobTypeData *types)        /* Object containing list of acceptable types.
                                 * May be NULL. */
{
    char drivePat[] = "?:\\";
    const char *message;
    char *dir, *newPattern, *root;
    int matchDotFiles;
    int dirLength, result = TCL_OK;
    Tcl_DString dirString, patternString;
    DWORD attr, volFlags;
    HANDLE handle;
    WIN32_FIND_DATAT data;
    BOOL found;
    Tcl_DString ds;
    TCHAR *nativeName;
    Tcl_Obj *resultPtr;

    /*
     * Convert the path to normalized form since some interfaces only
     * accept backslashes.  Also, ensure that the directory ends with a
     * separator character.
     */

    dirLength = Tcl_DStringLength(dirPtr);
    Tcl_DStringInit(&dirString);
    if (dirLength == 0) {
        Tcl_DStringAppend(&dirString, ".\\", 2);
    } else {
        char *p;

        Tcl_DStringAppend(&dirString, Tcl_DStringValue(dirPtr),
                Tcl_DStringLength(dirPtr));
        for (p = Tcl_DStringValue(&dirString); *p != '\0'; p++) {
            if (*p == '/') {
                *p = '\\';
            }
        }
        p--;
        if ((*p != '\\') && (*p != ':')) {
            Tcl_DStringAppend(&dirString, "\\", 1);
        }
    }
    dir = Tcl_DStringValue(&dirString);

    /*
     * First verify that the specified path is actually a directory.
     */

    nativeName = Tcl_WinUtfToTChar(dir, Tcl_DStringLength(&dirString), &ds);
    attr = (*tclWinProcs->getFileAttributesProc)(nativeName);
    Tcl_DStringFree(&ds);

    if ((attr == 0xffffffff) || ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0)) {
        Tcl_DStringFree(&dirString);
        return TCL_OK;
    }

    /*
     * Next check the volume information for the directory to see whether
     * comparisons should be case sensitive or not.  If the root is null, then
     * we use the root of the current directory.  If the root is just a drive
     * specifier, we use the root directory of the given drive.
     */

    switch (Tcl_GetPathType(dir)) {
        case TCL_PATH_RELATIVE:
            found = GetVolumeInformationA(NULL, NULL, 0, NULL, NULL, 
                    &volFlags, NULL, 0);
            break;
        case TCL_PATH_VOLUME_RELATIVE:
            if (dir[0] == '\\') {
                root = NULL;
            } else {
                root = drivePat;
                *root = dir[0];
            }
            found = GetVolumeInformationA(root, NULL, 0, NULL, NULL, 
                    &volFlags, NULL, 0);
            break;
        case TCL_PATH_ABSOLUTE:
            if (dir[1] == ':') {
                root = drivePat;
                *root = dir[0];
                found = GetVolumeInformationA(root, NULL, 0, NULL, NULL, 
                        &volFlags, NULL, 0);
            } else if (dir[1] == '\\') {
                char *p;

                p = strchr(dir + 2, '\\');
                p = strchr(p + 1, '\\');
                p++;
                nativeName = Tcl_WinUtfToTChar(dir, p - dir, &ds);
                found = (*tclWinProcs->getVolumeInformationProc)(nativeName, 
                        NULL, 0, NULL, NULL, &volFlags, NULL, 0);
                Tcl_DStringFree(&ds);
            }
            break;
    }

    if (found == 0) {
        message = "couldn't read volume information for \"";
        goto error;
    }

    /*
     * In Windows, although some volumes may support case sensitivity, Windows
     * doesn't honor case.  So in globbing we need to ignore the case
     * of file names.
     */

    Tcl_DStringInit(&patternString);
    newPattern = Tcl_DStringAppend(&patternString, pattern, tail - pattern);
    Tcl_UtfToLower(newPattern);

    /*
     * We need to check all files in the directory, so append a *.*
     * to the path. 
     */

    dir = Tcl_DStringAppend(&dirString, "*.*", 3);
    nativeName = Tcl_WinUtfToTChar(dir, -1, &ds);
    handle = (*tclWinProcs->findFirstFileProc)(nativeName, &data);
    Tcl_DStringFree(&ds);

    if (handle == INVALID_HANDLE_VALUE) {
        message = "couldn't read directory \"";
        goto error;
    }

    /*
     * Clean up the tail pointer.  Leave the tail pointing to the 
     * first character after the path separator or NULL. 
     */

    if (*tail == '\\') {
        tail++;
    }
    if (*tail == '\0') {
        tail = NULL;
    } else {
        tail++;
    }

    /*
     * Check to see if the pattern needs to compare with dot files.
     */

    if ((newPattern[0] == '.')
            || ((pattern[0] == '\\') && (pattern[1] == '.'))) {
        matchDotFiles = 1;
    } else {
        matchDotFiles = 0;
    }

    /*
     * Now iterate over all of the files in the directory.
     */

    resultPtr = Tcl_GetObjResult(interp);
    for (found = 1; found != 0; 
            found = (*tclWinProcs->findNextFileProc)(handle, &data)) {
        TCHAR *nativeMatchResult;
        char *name, *fname;

        if (tclWinProcs->useWide) {
            nativeName = (TCHAR *) data.w.cFileName;
        } else {
            nativeName = (TCHAR *) data.a.cFileName;
        }
        name = Tcl_WinTCharToUtf(nativeName, -1, &ds);

        /*
         * Check to see if the file matches the pattern.  We need to convert
         * the file name to lower case for comparison purposes.  Note that we
         * are ignoring the case sensitivity flag because Windows doesn't honor
         * case even if the volume is case sensitive.  If the volume also
         * doesn't preserve case, then we previously returned the lower case
         * form of the name.  This didn't seem quite right since there are
         * non-case-preserving volumes that actually return mixed case.  So now
         * we are returning exactly what we get from the system.
         */

        Tcl_UtfToLower(name);
        nativeMatchResult = NULL;

        if ((matchDotFiles == 0) && (name[0] == '.')) {
            /*
             * Ignore hidden files.
             */
        } else if (Tcl_StringMatch(name, newPattern) != 0) {
            nativeMatchResult = nativeName;
        }
        Tcl_DStringFree(&ds);

        if (nativeMatchResult == NULL) {
            continue;
        }

        /*
         * If the file matches, then we need to process the remainder of the
         * path.  If there are more characters to process, then ensure matching
         * files are directories and call TclDoGlob. Otherwise, just add the
         * file to the result.
         */

        name = Tcl_WinTCharToUtf(nativeMatchResult, -1, &ds);
        Tcl_DStringAppend(dirPtr, name, -1);
        Tcl_DStringFree(&ds);

        fname = Tcl_DStringValue(dirPtr);
        nativeName = Tcl_WinUtfToTChar(fname, Tcl_DStringLength(dirPtr), &ds);
        attr = (*tclWinProcs->getFileAttributesProc)(nativeName);
        Tcl_DStringFree(&ds);

        if (tail == NULL) {
            int typeOk = 1;
            if (types != NULL) {
                if (types->perm != 0) {
                    if (
                        ((types->perm & TCL_GLOB_PERM_RONLY) &&
                                !(attr & FILE_ATTRIBUTE_READONLY)) ||
                        ((types->perm & TCL_GLOB_PERM_HIDDEN) &&
                                !(attr & FILE_ATTRIBUTE_HIDDEN)) ||
                        ((types->perm & TCL_GLOB_PERM_R) &&
                                (TclpAccess(fname, R_OK) != 0)) ||
                        ((types->perm & TCL_GLOB_PERM_W) &&
                                (TclpAccess(fname, W_OK) != 0)) ||
                        ((types->perm & TCL_GLOB_PERM_X) &&
                                (TclpAccess(fname, X_OK) != 0))
                        ) {
                        typeOk = 0;
                    }
                }
                if (typeOk && types->type != 0) {
                    struct stat buf;
                    /*
                     * We must match at least one flag to be listed
                     */
                    typeOk = 0;
                    if (TclpLstat(fname, &buf) >= 0) {
                        /*
                         * In order bcdpfls as in 'find -t'
                         */
                        if (
                            ((types->type & TCL_GLOB_TYPE_BLOCK) &&
                                    S_ISBLK(buf.st_mode)) ||
                            ((types->type & TCL_GLOB_TYPE_CHAR) &&
                                    S_ISCHR(buf.st_mode)) ||
                            ((types->type & TCL_GLOB_TYPE_DIR) &&
                                    S_ISDIR(buf.st_mode)) ||
                            ((types->type & TCL_GLOB_TYPE_PIPE) &&
                                    S_ISFIFO(buf.st_mode)) ||
                            ((types->type & TCL_GLOB_TYPE_FILE) &&
                                    S_ISREG(buf.st_mode))
#ifdef S_ISLNK
                            || ((types->type & TCL_GLOB_TYPE_LINK) &&
                                    S_ISLNK(buf.st_mode))
#endif
#ifdef S_ISSOCK
                            || ((types->type & TCL_GLOB_TYPE_SOCK) &&
                                    S_ISSOCK(buf.st_mode))
#endif
                            ) {
                            typeOk = 1;
                        }
                    } else {
                        /* Posix error occurred */
                    }
                }               
            } 
            if (typeOk) {
                Tcl_ListObjAppendElement(interp, resultPtr, 
                        Tcl_NewStringObj(fname, Tcl_DStringLength(dirPtr)));
            }
        } else if (attr & FILE_ATTRIBUTE_DIRECTORY) {
            Tcl_DStringAppend(dirPtr, "/", 1);
            result = TclDoGlob(interp, separators, dirPtr, tail, types);
            if (result != TCL_OK) {
                break;
            }
        }
        Tcl_DStringSetLength(dirPtr, dirLength);
    }

    FindClose(handle);
    Tcl_DStringFree(&dirString);
    Tcl_DStringFree(&patternString);

    return result;

    error:
    Tcl_DStringFree(&dirString);
    TclWinConvertError(GetLastError());
    Tcl_ResetResult(interp);
    Tcl_AppendResult(interp, message, Tcl_DStringValue(dirPtr), "\": ", 
            Tcl_PosixError(interp), (char *) NULL);
    return TCL_ERROR;
}

/* 
 * TclpMatchFiles --
 * 
 * This function is now obsolete.  Call the above function 
 * 'TclpMatchFilesTypes' instead.
 */
int
TclpMatchFiles(
    Tcl_Interp *interp,         /* Interpreter to receive results. */
    char *separators,           /* Directory separators to pass to TclDoGlob. */
    Tcl_DString *dirPtr,        /* Contains path to directory to search. */
    char *pattern,              /* Pattern to match against. */
    char *tail)                 /* Pointer to end of pattern.  Tail must
                                 * point to a location in pattern and must
                                 * not be static.*/
{
    return TclpMatchFilesTypes(interp,separators,dirPtr,pattern,tail,NULL);
}

/*
 *----------------------------------------------------------------------
 *
 * TclpGetUserHome --
 *
 *      This function takes the passed in user name and finds the
 *      corresponding home directory specified in the password file.
 *
 * Results:
 *      The result is a pointer to a string specifying the user's home
 *      directory, or NULL if the user's home directory could not be
 *      determined.  Storage for the result string is allocated in
 *      bufferPtr; the caller must call Tcl_DStringFree() when the result
 *      is no longer needed.
 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */

char *
TclpGetUserHome(name, bufferPtr)
    CONST char *name;           /* User name for desired home directory. */
    Tcl_DString *bufferPtr;     /* Uninitialized or free DString filled
                                 * with name of user's home directory. */
{
    char *result;
    HINSTANCE netapiInst;

    result = NULL;

    Tcl_DStringInit(bufferPtr);

    netapiInst = LoadLibraryA("netapi32.dll");
    if (netapiInst != NULL) {
        NETAPIBUFFERFREEPROC *netApiBufferFreeProc;
        NETGETDCNAMEPROC *netGetDCNameProc;
        NETUSERGETINFOPROC *netUserGetInfoProc;

        netApiBufferFreeProc = (NETAPIBUFFERFREEPROC *)
                GetProcAddress(netapiInst, "NetApiBufferFree");
        netGetDCNameProc = (NETGETDCNAMEPROC *) 
                GetProcAddress(netapiInst, "NetGetDCName");
        netUserGetInfoProc = (NETUSERGETINFOPROC *) 
                GetProcAddress(netapiInst, "NetUserGetInfo");
        if ((netUserGetInfoProc != NULL) && (netGetDCNameProc != NULL)
                && (netApiBufferFreeProc != NULL)) {
            USER_INFO_1 *uiPtr;
            Tcl_DString ds;
            int nameLen, badDomain;
            char *domain;
            WCHAR *wName, *wHomeDir, *wDomain;
            WCHAR buf[MAX_PATH];

            badDomain = 0;
            nameLen = -1;
            wDomain = NULL;
            domain = strchr(name, '@');
            if (domain != NULL) {
                Tcl_DStringInit(&ds);
                wName = Tcl_UtfToUniCharDString(domain + 1, -1, &ds);
                badDomain = (*netGetDCNameProc)(NULL, wName,
                        (LPBYTE *) &wDomain);
                Tcl_DStringFree(&ds);
                nameLen = domain - name;
            }
            if (badDomain == 0) {
                Tcl_DStringInit(&ds);
                wName = Tcl_UtfToUniCharDString(name, nameLen, &ds);
                if ((*netUserGetInfoProc)(wDomain, wName, 1, 
                        (LPBYTE *) &uiPtr) == 0) {
                    wHomeDir = uiPtr->usri1_home_dir;
                    if ((wHomeDir != NULL) && (wHomeDir[0] != L'\0')) {
                        Tcl_UniCharToUtfDString(wHomeDir, lstrlenW(wHomeDir),
                                bufferPtr);
                    } else {
                        /* 
                         * User exists but has no home dir.  Return
                         * "{Windows Drive}:/users/default".
                         */

                        GetWindowsDirectoryW(buf, MAX_PATH);
                        Tcl_UniCharToUtfDString(buf, 2, bufferPtr);
                        Tcl_DStringAppend(bufferPtr, "/users/default", -1);
                    }
                    result = Tcl_DStringValue(bufferPtr);
                    (*netApiBufferFreeProc)((void *) uiPtr);
                }
                Tcl_DStringFree(&ds);
            }
            if (wDomain != NULL) {
                (*netApiBufferFreeProc)((void *) wDomain);
            }
        }
        FreeLibrary(netapiInst);
    }
    if (result == NULL) {
        /*
         * Look in the "Password Lists" section of system.ini for the 
         * local user.  There are also entries in that section that begin 
         * with a "*" character that are used by Windows for other 
         * purposes; ignore user names beginning with a "*".
         */

        char buf[MAX_PATH];

        if (name[0] != '*') {
            if (GetPrivateProfileStringA("Password Lists", name, "", buf, 
                    MAX_PATH, "system.ini") > 0) {
                /* 
                 * User exists, but there is no such thing as a home 
                 * directory in system.ini.  Return "{Windows drive}:/".
                 */

                GetWindowsDirectoryA(buf, MAX_PATH);
                Tcl_DStringAppend(bufferPtr, buf, 3);
                result = Tcl_DStringValue(bufferPtr);
            }
        }
    }

    return result;
}

/*
 *---------------------------------------------------------------------------
 *
 * TclpAccess --
 *
 *      This function replaces the library version of access(), fixing the
 *      following bugs:
 * 
 *      1. access() returns that all files have execute permission.
 *
 * Results:
 *      See access documentation.
 *
 * Side effects:
 *      See access documentation.
 *
 *---------------------------------------------------------------------------
 */

int
TclpAccess(
    CONST char *path,           /* Path of file to access (UTF-8). */
    int mode)                   /* Permission setting. */
{
    Tcl_DString ds;
    TCHAR *nativePath;
    DWORD attr;

    nativePath = Tcl_WinUtfToTChar(path, -1, &ds);
    attr = (*tclWinProcs->getFileAttributesProc)(nativePath);
    Tcl_DStringFree(&ds);

    if (attr == 0xffffffff) {
        /*
         * File doesn't exist. 
         */

        TclWinConvertError(GetLastError());
        return -1;
    }

    if ((mode & W_OK) && (attr & FILE_ATTRIBUTE_READONLY)) {
        /*
         * File is not writable.
         */

        Tcl_SetErrno(EACCES);
        return -1;
    }

    if (mode & X_OK) {
        CONST char *p;

        if (attr & FILE_ATTRIBUTE_DIRECTORY) {
            /*
             * Directories are always executable. 
             */
            
            return 0;
        }
        p = strrchr(path, '.');
        if (p != NULL) {
            p++;
            if ((stricmp(p, "exe") == 0)
                    || (stricmp(p, "com") == 0)
                    || (stricmp(p, "bat") == 0)) {
                /*
                 * File that ends with .exe, .com, or .bat is executable.
                 */

                return 0;
            }
        }
        Tcl_SetErrno(EACCES);
        return -1;
    }

    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpChdir --
 *
 *      This function replaces the library version of chdir().
 *
 * Results:
 *      See chdir() documentation.
 *
 * Side effects:
 *      See chdir() documentation.  
 *
 *----------------------------------------------------------------------
 */

int
TclpChdir(path)
    CONST char *path;           /* Path to new working directory (UTF-8). */
{
    int result;
    Tcl_DString ds;
    TCHAR *nativePath;

    nativePath = Tcl_WinUtfToTChar(path, -1, &ds);
    result = (*tclWinProcs->setCurrentDirectoryProc)(nativePath);
    Tcl_DStringFree(&ds);

    if (result == 0) {
        TclWinConvertError(GetLastError());
        return -1;
    }
    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpGetCwd --
 *
 *      This function replaces the library version of getcwd().
 *
 * Results:
 *      The result is a pointer to a string specifying the current
 *      directory, or NULL if the current directory could not be
 *      determined.  If NULL is returned, an error message is left in the
 *      interp's result.  Storage for the result string is allocated in
 *      bufferPtr; the caller must call Tcl_DStringFree() when the result
 *      is no longer needed.
 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */

char *
TclpGetCwd(interp, bufferPtr)
    Tcl_Interp *interp;         /* If non-NULL, used for error reporting. */
    Tcl_DString *bufferPtr;     /* Uninitialized or free DString filled
                                 * with name of current directory. */
{
    WCHAR buffer[MAX_PATH];
    char *p;

    if ((*tclWinProcs->getCurrentDirectoryProc)(MAX_PATH, buffer) == 0) {
        TclWinConvertError(GetLastError());
        if (interp != NULL) {
            Tcl_AppendResult(interp,
                    "error getting working directory name: ",
                    Tcl_PosixError(interp), (char *) NULL);
        }
        return NULL;
    }

    /*
     * Watch for the wierd Windows c:\\UNC syntax.
     */

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

        native = (WCHAR *) buffer;
        if ((native[0] != '\0') && (native[1] == ':') 
                && (native[2] == '\\') && (native[3] == '\\')) {
            native += 2;
        }
        Tcl_WinTCharToUtf((TCHAR *) native, -1, bufferPtr);
    } else {
        char *native;

        native = (char *) buffer;
        if ((native[0] != '\0') && (native[1] == ':') 
                && (native[2] == '\\') && (native[3] == '\\')) {
            native += 2;
        }
        Tcl_WinTCharToUtf((TCHAR *) native, -1, bufferPtr);
    }

    /*
     * Convert to forward slashes for easier use in scripts.
     */
              
    for (p = Tcl_DStringValue(bufferPtr); *p != '\0'; p++) {
        if (*p == '\\') {
            *p = '/';
        }
    }
    return Tcl_DStringValue(bufferPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * TclpStat --
 *
 *      This function replaces the library version of stat(), fixing 
 *      the following bugs:
 *
 *      1. stat("c:") returns an error.
 *      2. Borland stat() return time in GMT instead of localtime.
 *      3. stat("\\server\mount") would return error.
 *      4. Accepts slashes or backslashes.
 *      5. st_dev and st_rdev were wrong for UNC paths.
 *
 * Results:
 *      See stat documentation.
 *
 * Side effects:
 *      See stat documentation.
 *
 *----------------------------------------------------------------------
 */

int
TclpStat(path, statPtr)
    CONST char *path;           /* Path of file to stat (UTF-8). */
    struct stat *statPtr;       /* Filled with results of stat call. */
{
    Tcl_DString ds;
    TCHAR *nativePath;
    WIN32_FIND_DATAT data;
    HANDLE handle;
    DWORD attr;
    WCHAR nativeFullPath[MAX_PATH];
    TCHAR *nativePart;
    char *p, *fullPath;
    int dev, mode;

    /*
     * Eliminate file names containing wildcard characters, or subsequent 
     * call to FindFirstFile() will expand them, matching some other file.
     */

    if (strpbrk(path, "?*") != NULL) {
        Tcl_SetErrno(ENOENT);
        return -1;
    }

    nativePath = Tcl_WinUtfToTChar(path, -1, &ds);
    handle = (*tclWinProcs->findFirstFileProc)(nativePath, &data);
    if (handle == INVALID_HANDLE_VALUE) {
        /* 
         * FindFirstFile() doesn't work on root directories, so call
         * GetFileAttributes() to see if the specified file exists.
         */

        attr = (*tclWinProcs->getFileAttributesProc)(nativePath);
        if (attr == 0xffffffff) {
            Tcl_DStringFree(&ds);
            Tcl_SetErrno(ENOENT);
            return -1;
        }

        /* 
         * Make up some fake information for this file.  It has the 
         * correct file attributes and a time of 0.
         */

        memset(&data, 0, sizeof(data));
        data.a.dwFileAttributes = attr;
    } else {
        FindClose(handle);
    }

    (*tclWinProcs->getFullPathNameProc)(nativePath, MAX_PATH, nativeFullPath,
            &nativePart);

    Tcl_DStringFree(&ds);
    fullPath = Tcl_WinTCharToUtf((TCHAR *) nativeFullPath, -1, &ds);

    dev = -1;
    if ((fullPath[0] == '\\') && (fullPath[1] == '\\')) {
        char *p;
        DWORD dw;
        TCHAR *nativeVol;
        Tcl_DString volString;

        p = strchr(fullPath + 2, '\\');
        p = strchr(p + 1, '\\');
        if (p == NULL) {
            /*
             * Add terminating backslash to fullpath or 
             * GetVolumeInformation() won't work.
             */

            fullPath = Tcl_DStringAppend(&ds, "\\", 1);
            p = fullPath + Tcl_DStringLength(&ds);
        } else {
            p++;
        }
        nativeVol = Tcl_WinUtfToTChar(fullPath, p - fullPath, &volString);
        dw = (DWORD) -1;
        (*tclWinProcs->getVolumeInformationProc)(nativeVol, NULL, 0, &dw,
                NULL, NULL, NULL, 0);
        /*
         * GetFullPathName() turns special devices like "NUL" into "\\.\NUL", 
         * but GetVolumeInformation() returns failure for "\\.\NUL".  This 
         * will cause "NUL" to get a drive number of -1, which makes about 
         * as much sense as anything since the special devices don't live on 
         * any drive.
         */

        dev = dw;
        Tcl_DStringFree(&volString);
    } else if ((fullPath[0] != '\0') && (fullPath[1] == ':')) {
        dev = Tcl_UniCharToLower(fullPath[0]) - 'a';
    }
    Tcl_DStringFree(&ds);

    attr = data.a.dwFileAttributes;
    mode  = (attr & FILE_ATTRIBUTE_DIRECTORY) ? S_IFDIR | S_IEXEC : S_IFREG;
    mode |= (attr & FILE_ATTRIBUTE_READONLY) ? S_IREAD : S_IREAD | S_IWRITE;
    p = strrchr(path, '.');
    if (p != NULL) {
        if ((lstrcmpiA(p, ".exe") == 0) 
                || (lstrcmpiA(p, ".com") == 0) 
                || (lstrcmpiA(p, ".bat") == 0)
                || (lstrcmpiA(p, ".pif") == 0)) {
            mode |= S_IEXEC;
        }
    }

    /*
     * Propagate the S_IREAD, S_IWRITE, S_IEXEC bits to the group and 
     * other positions.
     */

    mode |= (mode & 0x0700) >> 3;
    mode |= (mode & 0x0700) >> 6;
    
    statPtr->st_dev     = (dev_t) dev;
    statPtr->st_ino     = 0;
    statPtr->st_mode    = (unsigned short) mode;
    statPtr->st_nlink   = 1;
    statPtr->st_uid     = 0;
    statPtr->st_gid     = 0;
    statPtr->st_rdev    = (dev_t) dev;
    statPtr->st_size    = data.a.nFileSizeLow;
    statPtr->st_atime   = ToCTime(data.a.ftLastAccessTime);
    statPtr->st_mtime   = ToCTime(data.a.ftLastWriteTime);
    statPtr->st_ctime   = ToCTime(data.a.ftCreationTime);
    return 0;
}

static time_t
ToCTime(
    FILETIME fileTime)          /* UTC Time to convert to local time_t. */
{
    FILETIME localFileTime;
    SYSTEMTIME systemTime;
    struct tm tm;

    if (FileTimeToLocalFileTime(&fileTime, &localFileTime) == 0) {
        return 0;
    }
    if (FileTimeToSystemTime(&localFileTime, &systemTime) == 0) {
        return 0;
    }
    tm.tm_sec = systemTime.wSecond;
    tm.tm_min = systemTime.wMinute;
    tm.tm_hour = systemTime.wHour;
    tm.tm_mday = systemTime.wDay;
    tm.tm_mon = systemTime.wMonth - 1;
    tm.tm_year = systemTime.wYear - 1900;
    tm.tm_wday = 0;
    tm.tm_yday = 0;
    tm.tm_isdst = -1;

    return mktime(&tm);
}

#if 0

    /*
     * Borland's stat doesn't take into account localtime.
     */

    if ((result == 0) && (buf->st_mtime != 0)) {
        TIME_ZONE_INFORMATION tz;
        int time, bias;

        time = GetTimeZoneInformation(&tz);
        bias = tz.Bias;
        if (time == TIME_ZONE_ID_DAYLIGHT) {
            bias += tz.DaylightBias;
        }
        bias *= 60;
        buf->st_atime -= bias;
        buf->st_ctime -= bias;
        buf->st_mtime -= bias;
    }

#endif


#if 0
/*
 *-------------------------------------------------------------------------
 *
 * TclWinResolveShortcut --
 *
 *      Resolve a potential Windows shortcut to get the actual file or 
 *      directory in question.  
 *
 * Results:
 *      Returns 1 if the shortcut could be resolved, or 0 if there was
 *      an error or if the filename was not a shortcut.
 *      If bufferPtr did hold the name of a shortcut, it is modified to
 *      hold the resolved target of the shortcut instead.
 *
 * Side effects:
 *      Loads and unloads OLE package to determine if filename refers to
 *      a shortcut.
 *
 *-------------------------------------------------------------------------
 */

int
TclWinResolveShortcut(bufferPtr)
    Tcl_DString *bufferPtr;     /* Holds name of file to resolve.  On 
                                 * return, holds resolved file name. */
{
    HRESULT hres; 
    IShellLink *psl; 
    IPersistFile *ppf; 
    WIN32_FIND_DATA wfd; 
    WCHAR wpath[MAX_PATH];
    char *path, *ext;
    char realFileName[MAX_PATH];

    /*
     * Windows system calls do not automatically resolve
     * shortcuts like UNIX automatically will with symbolic links.
     */

    path = Tcl_DStringValue(bufferPtr);
    ext = strrchr(path, '.');
    if ((ext == NULL) || (stricmp(ext, ".lnk") != 0)) {
        return 0;
    }

    CoInitialize(NULL);
    path = Tcl_DStringValue(bufferPtr);
    realFileName[0] = '\0';
    hres = CoCreateInstance(&CLSID_ShellLink, NULL, CLSCTX_INPROC_SERVER, 
            &IID_IShellLink, &psl); 
    if (SUCCEEDED(hres)) { 
        hres = psl->lpVtbl->QueryInterface(psl, &IID_IPersistFile, &ppf);
        if (SUCCEEDED(hres)) { 
            MultiByteToWideChar(CP_ACP, 0, path, -1, wpath, sizeof(wpath));
            hres = ppf->lpVtbl->Load(ppf, wpath, STGM_READ); 
            if (SUCCEEDED(hres)) {
                hres = psl->lpVtbl->Resolve(psl, NULL, 
                        SLR_ANY_MATCH | SLR_NO_UI); 
                if (SUCCEEDED(hres)) { 
                    hres = psl->lpVtbl->GetPath(psl, realFileName, MAX_PATH, 
                            &wfd, 0);
                } 
            } 
            ppf->lpVtbl->Release(ppf); 
        } 
        psl->lpVtbl->Release(psl); 
    } 
    CoUninitialize();

    if (realFileName[0] != '\0') {
        Tcl_DStringSetLength(bufferPtr, 0);
        Tcl_DStringAppend(bufferPtr, realFileName, -1);
        return 1;
    }
    return 0;
}
#endif

/* End of tclwinfile.c */