/[dtapublic]/projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclwinfile.c
ViewVC logotype

Diff of /projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclwinfile.c

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 64 by dashley, Sun Oct 30 04:21:11 2016 UTC revision 71 by dashley, Sat Nov 5 11:07:06 2016 UTC
# Line 1  Line 1 
 /* $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  
   
   
 /* $History: tclwinfile.c $  
  *  
  * *****************  Version 1  *****************  
  * User: Dtashley     Date: 1/02/01    Time: 12:39a  
  * Created in $/IjuScripter, IjuConsole/Source/Tcl Base  
  * Initial check-in.  
  */  
   
 /* End of TCLWINFILE.C */  
1    /* $Header$ */
2    /*
3     * tclWinFile.c --
4     *
5     *      This file contains temporary wrappers around UNIX file handling
6     *      functions. These wrappers map the UNIX functions to Win32 HANDLE-style
7     *      files, which can be manipulated through the Win32 console redirection
8     *      interfaces.
9     *
10     * Copyright (c) 1995-1998 Sun Microsystems, Inc.
11     *
12     * See the file "license.terms" for information on usage and redistribution
13     * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
14     *
15     * RCS: @(#) $Id: tclwinfile.c,v 1.1.1.1 2001/06/13 04:49:10 dtashley Exp $
16     */
17    
18    #include "tclWinInt.h"
19    #include <sys/stat.h>
20    #include <shlobj.h>
21    #include <lmaccess.h>           /* For TclpGetUserHome(). */
22    
23    static time_t           ToCTime(FILETIME fileTime);
24    
25    typedef NET_API_STATUS NET_API_FUNCTION NETUSERGETINFOPROC
26            (LPWSTR servername, LPWSTR username, DWORD level, LPBYTE *bufptr);
27    
28    typedef NET_API_STATUS NET_API_FUNCTION NETAPIBUFFERFREEPROC
29            (LPVOID Buffer);
30    
31    typedef NET_API_STATUS NET_API_FUNCTION NETGETDCNAMEPROC
32            (LPWSTR servername, LPWSTR domainname, LPBYTE *bufptr);
33    
34    
35    /*
36     *---------------------------------------------------------------------------
37     *
38     * TclpFindExecutable --
39     *
40     *      This procedure computes the absolute path name of the current
41     *      application, given its argv[0] value.
42     *
43     * Results:
44     *      A dirty UTF string that is the path to the executable.  At this
45     *      point we may not know the system encoding.  Convert the native
46     *      string value to UTF using the default encoding.  The assumption
47     *      is that we will still be able to parse the path given the path
48     *      name contains ASCII string and '/' chars do not conflict with
49     *      other UTF chars.
50     *
51     * Side effects:
52     *      The variable tclNativeExecutableName gets filled in with the file
53     *      name for the application, if we figured it out.  If we couldn't
54     *      figure it out, tclNativeExecutableName is set to NULL.
55     *
56     *---------------------------------------------------------------------------
57     */
58    
59    char *
60    TclpFindExecutable(argv0)
61        CONST char *argv0;          /* The value of the application's argv[0]
62                                     * (native). */
63    {
64        Tcl_DString ds;
65        WCHAR wName[MAX_PATH];
66    
67        if (argv0 == NULL) {
68            return NULL;
69        }
70        if (tclNativeExecutableName != NULL) {
71            return tclNativeExecutableName;
72        }
73    
74        /*
75         * Under Windows we ignore argv0, and return the path for the file used to
76         * create this process.
77         */
78    
79        (*tclWinProcs->getModuleFileNameProc)(NULL, wName, MAX_PATH);
80        Tcl_WinTCharToUtf((TCHAR *) wName, -1, &ds);
81    
82        tclNativeExecutableName = ckalloc((unsigned) (Tcl_DStringLength(&ds) + 1));
83        strcpy(tclNativeExecutableName, Tcl_DStringValue(&ds));
84        Tcl_DStringFree(&ds);
85    
86        TclWinNoBackslash(tclNativeExecutableName);
87        return tclNativeExecutableName;
88    }
89    
90    /*
91     *----------------------------------------------------------------------
92     *
93     * TclpMatchFilesTypes --
94     *
95     *      This routine is used by the globbing code to search a
96     *      directory for all files which match a given pattern.
97     *
98     * Results:
99     *      If the tail argument is NULL, then the matching files are
100     *      added to the the interp's result.  Otherwise, TclDoGlob is called
101     *      recursively for each matching subdirectory.  The return value
102     *      is a standard Tcl result indicating whether an error occurred
103     *      in globbing.
104     *
105     * Side effects:
106     *      None.
107     *
108     *---------------------------------------------------------------------- */
109    
110    int
111    TclpMatchFilesTypes(
112        Tcl_Interp *interp,         /* Interpreter to receive results. */
113        char *separators,           /* Directory separators to pass to TclDoGlob. */
114        Tcl_DString *dirPtr,        /* Contains path to directory to search. */
115        char *pattern,              /* Pattern to match against. */
116        char *tail,                 /* Pointer to end of pattern.  Tail must
117                                     * point to a location in pattern and must
118                                     * not be static.*/
119        GlobTypeData *types)        /* Object containing list of acceptable types.
120                                     * May be NULL. */
121    {
122        char drivePat[] = "?:\\";
123        const char *message;
124        char *dir, *newPattern, *root;
125        int matchDotFiles;
126        int dirLength, result = TCL_OK;
127        Tcl_DString dirString, patternString;
128        DWORD attr, volFlags;
129        HANDLE handle;
130        WIN32_FIND_DATAT data;
131        BOOL found;
132        Tcl_DString ds;
133        TCHAR *nativeName;
134        Tcl_Obj *resultPtr;
135    
136        /*
137         * Convert the path to normalized form since some interfaces only
138         * accept backslashes.  Also, ensure that the directory ends with a
139         * separator character.
140         */
141    
142        dirLength = Tcl_DStringLength(dirPtr);
143        Tcl_DStringInit(&dirString);
144        if (dirLength == 0) {
145            Tcl_DStringAppend(&dirString, ".\\", 2);
146        } else {
147            char *p;
148    
149            Tcl_DStringAppend(&dirString, Tcl_DStringValue(dirPtr),
150                    Tcl_DStringLength(dirPtr));
151            for (p = Tcl_DStringValue(&dirString); *p != '\0'; p++) {
152                if (*p == '/') {
153                    *p = '\\';
154                }
155            }
156            p--;
157            if ((*p != '\\') && (*p != ':')) {
158                Tcl_DStringAppend(&dirString, "\\", 1);
159            }
160        }
161        dir = Tcl_DStringValue(&dirString);
162    
163        /*
164         * First verify that the specified path is actually a directory.
165         */
166    
167        nativeName = Tcl_WinUtfToTChar(dir, Tcl_DStringLength(&dirString), &ds);
168        attr = (*tclWinProcs->getFileAttributesProc)(nativeName);
169        Tcl_DStringFree(&ds);
170    
171        if ((attr == 0xffffffff) || ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0)) {
172            Tcl_DStringFree(&dirString);
173            return TCL_OK;
174        }
175    
176        /*
177         * Next check the volume information for the directory to see whether
178         * comparisons should be case sensitive or not.  If the root is null, then
179         * we use the root of the current directory.  If the root is just a drive
180         * specifier, we use the root directory of the given drive.
181         */
182    
183        switch (Tcl_GetPathType(dir)) {
184            case TCL_PATH_RELATIVE:
185                found = GetVolumeInformationA(NULL, NULL, 0, NULL, NULL,
186                        &volFlags, NULL, 0);
187                break;
188            case TCL_PATH_VOLUME_RELATIVE:
189                if (dir[0] == '\\') {
190                    root = NULL;
191                } else {
192                    root = drivePat;
193                    *root = dir[0];
194                }
195                found = GetVolumeInformationA(root, NULL, 0, NULL, NULL,
196                        &volFlags, NULL, 0);
197                break;
198            case TCL_PATH_ABSOLUTE:
199                if (dir[1] == ':') {
200                    root = drivePat;
201                    *root = dir[0];
202                    found = GetVolumeInformationA(root, NULL, 0, NULL, NULL,
203                            &volFlags, NULL, 0);
204                } else if (dir[1] == '\\') {
205                    char *p;
206    
207                    p = strchr(dir + 2, '\\');
208                    p = strchr(p + 1, '\\');
209                    p++;
210                    nativeName = Tcl_WinUtfToTChar(dir, p - dir, &ds);
211                    found = (*tclWinProcs->getVolumeInformationProc)(nativeName,
212                            NULL, 0, NULL, NULL, &volFlags, NULL, 0);
213                    Tcl_DStringFree(&ds);
214                }
215                break;
216        }
217    
218        if (found == 0) {
219            message = "couldn't read volume information for \"";
220            goto error;
221        }
222    
223        /*
224         * In Windows, although some volumes may support case sensitivity, Windows
225         * doesn't honor case.  So in globbing we need to ignore the case
226         * of file names.
227         */
228    
229        Tcl_DStringInit(&patternString);
230        newPattern = Tcl_DStringAppend(&patternString, pattern, tail - pattern);
231        Tcl_UtfToLower(newPattern);
232    
233        /*
234         * We need to check all files in the directory, so append a *.*
235         * to the path.
236         */
237    
238        dir = Tcl_DStringAppend(&dirString, "*.*", 3);
239        nativeName = Tcl_WinUtfToTChar(dir, -1, &ds);
240        handle = (*tclWinProcs->findFirstFileProc)(nativeName, &data);
241        Tcl_DStringFree(&ds);
242    
243        if (handle == INVALID_HANDLE_VALUE) {
244            message = "couldn't read directory \"";
245            goto error;
246        }
247    
248        /*
249         * Clean up the tail pointer.  Leave the tail pointing to the
250         * first character after the path separator or NULL.
251         */
252    
253        if (*tail == '\\') {
254            tail++;
255        }
256        if (*tail == '\0') {
257            tail = NULL;
258        } else {
259            tail++;
260        }
261    
262        /*
263         * Check to see if the pattern needs to compare with dot files.
264         */
265    
266        if ((newPattern[0] == '.')
267                || ((pattern[0] == '\\') && (pattern[1] == '.'))) {
268            matchDotFiles = 1;
269        } else {
270            matchDotFiles = 0;
271        }
272    
273        /*
274         * Now iterate over all of the files in the directory.
275         */
276    
277        resultPtr = Tcl_GetObjResult(interp);
278        for (found = 1; found != 0;
279                found = (*tclWinProcs->findNextFileProc)(handle, &data)) {
280            TCHAR *nativeMatchResult;
281            char *name, *fname;
282    
283            if (tclWinProcs->useWide) {
284                nativeName = (TCHAR *) data.w.cFileName;
285            } else {
286                nativeName = (TCHAR *) data.a.cFileName;
287            }
288            name = Tcl_WinTCharToUtf(nativeName, -1, &ds);
289    
290            /*
291             * Check to see if the file matches the pattern.  We need to convert
292             * the file name to lower case for comparison purposes.  Note that we
293             * are ignoring the case sensitivity flag because Windows doesn't honor
294             * case even if the volume is case sensitive.  If the volume also
295             * doesn't preserve case, then we previously returned the lower case
296             * form of the name.  This didn't seem quite right since there are
297             * non-case-preserving volumes that actually return mixed case.  So now
298             * we are returning exactly what we get from the system.
299             */
300    
301            Tcl_UtfToLower(name);
302            nativeMatchResult = NULL;
303    
304            if ((matchDotFiles == 0) && (name[0] == '.')) {
305                /*
306                 * Ignore hidden files.
307                 */
308            } else if (Tcl_StringMatch(name, newPattern) != 0) {
309                nativeMatchResult = nativeName;
310            }
311            Tcl_DStringFree(&ds);
312    
313            if (nativeMatchResult == NULL) {
314                continue;
315            }
316    
317            /*
318             * If the file matches, then we need to process the remainder of the
319             * path.  If there are more characters to process, then ensure matching
320             * files are directories and call TclDoGlob. Otherwise, just add the
321             * file to the result.
322             */
323    
324            name = Tcl_WinTCharToUtf(nativeMatchResult, -1, &ds);
325            Tcl_DStringAppend(dirPtr, name, -1);
326            Tcl_DStringFree(&ds);
327    
328            fname = Tcl_DStringValue(dirPtr);
329            nativeName = Tcl_WinUtfToTChar(fname, Tcl_DStringLength(dirPtr), &ds);
330            attr = (*tclWinProcs->getFileAttributesProc)(nativeName);
331            Tcl_DStringFree(&ds);
332    
333            if (tail == NULL) {
334                int typeOk = 1;
335                if (types != NULL) {
336                    if (types->perm != 0) {
337                        if (
338                            ((types->perm & TCL_GLOB_PERM_RONLY) &&
339                                    !(attr & FILE_ATTRIBUTE_READONLY)) ||
340                            ((types->perm & TCL_GLOB_PERM_HIDDEN) &&
341                                    !(attr & FILE_ATTRIBUTE_HIDDEN)) ||
342                            ((types->perm & TCL_GLOB_PERM_R) &&
343                                    (TclpAccess(fname, R_OK) != 0)) ||
344                            ((types->perm & TCL_GLOB_PERM_W) &&
345                                    (TclpAccess(fname, W_OK) != 0)) ||
346                            ((types->perm & TCL_GLOB_PERM_X) &&
347                                    (TclpAccess(fname, X_OK) != 0))
348                            ) {
349                            typeOk = 0;
350                        }
351                    }
352                    if (typeOk && types->type != 0) {
353                        struct stat buf;
354                        /*
355                         * We must match at least one flag to be listed
356                         */
357                        typeOk = 0;
358                        if (TclpLstat(fname, &buf) >= 0) {
359                            /*
360                             * In order bcdpfls as in 'find -t'
361                             */
362                            if (
363                                ((types->type & TCL_GLOB_TYPE_BLOCK) &&
364                                        S_ISBLK(buf.st_mode)) ||
365                                ((types->type & TCL_GLOB_TYPE_CHAR) &&
366                                        S_ISCHR(buf.st_mode)) ||
367                                ((types->type & TCL_GLOB_TYPE_DIR) &&
368                                        S_ISDIR(buf.st_mode)) ||
369                                ((types->type & TCL_GLOB_TYPE_PIPE) &&
370                                        S_ISFIFO(buf.st_mode)) ||
371                                ((types->type & TCL_GLOB_TYPE_FILE) &&
372                                        S_ISREG(buf.st_mode))
373    #ifdef S_ISLNK
374                                || ((types->type & TCL_GLOB_TYPE_LINK) &&
375                                        S_ISLNK(buf.st_mode))
376    #endif
377    #ifdef S_ISSOCK
378                                || ((types->type & TCL_GLOB_TYPE_SOCK) &&
379                                        S_ISSOCK(buf.st_mode))
380    #endif
381                                ) {
382                                typeOk = 1;
383                            }
384                        } else {
385                            /* Posix error occurred */
386                        }
387                    }              
388                }
389                if (typeOk) {
390                    Tcl_ListObjAppendElement(interp, resultPtr,
391                            Tcl_NewStringObj(fname, Tcl_DStringLength(dirPtr)));
392                }
393            } else if (attr & FILE_ATTRIBUTE_DIRECTORY) {
394                Tcl_DStringAppend(dirPtr, "/", 1);
395                result = TclDoGlob(interp, separators, dirPtr, tail, types);
396                if (result != TCL_OK) {
397                    break;
398                }
399            }
400            Tcl_DStringSetLength(dirPtr, dirLength);
401        }
402    
403        FindClose(handle);
404        Tcl_DStringFree(&dirString);
405        Tcl_DStringFree(&patternString);
406    
407        return result;
408    
409        error:
410        Tcl_DStringFree(&dirString);
411        TclWinConvertError(GetLastError());
412        Tcl_ResetResult(interp);
413        Tcl_AppendResult(interp, message, Tcl_DStringValue(dirPtr), "\": ",
414                Tcl_PosixError(interp), (char *) NULL);
415        return TCL_ERROR;
416    }
417    
418    /*
419     * TclpMatchFiles --
420     *
421     * This function is now obsolete.  Call the above function
422     * 'TclpMatchFilesTypes' instead.
423     */
424    int
425    TclpMatchFiles(
426        Tcl_Interp *interp,         /* Interpreter to receive results. */
427        char *separators,           /* Directory separators to pass to TclDoGlob. */
428        Tcl_DString *dirPtr,        /* Contains path to directory to search. */
429        char *pattern,              /* Pattern to match against. */
430        char *tail)                 /* Pointer to end of pattern.  Tail must
431                                     * point to a location in pattern and must
432                                     * not be static.*/
433    {
434        return TclpMatchFilesTypes(interp,separators,dirPtr,pattern,tail,NULL);
435    }
436    
437    /*
438     *----------------------------------------------------------------------
439     *
440     * TclpGetUserHome --
441     *
442     *      This function takes the passed in user name and finds the
443     *      corresponding home directory specified in the password file.
444     *
445     * Results:
446     *      The result is a pointer to a string specifying the user's home
447     *      directory, or NULL if the user's home directory could not be
448     *      determined.  Storage for the result string is allocated in
449     *      bufferPtr; the caller must call Tcl_DStringFree() when the result
450     *      is no longer needed.
451     *
452     * Side effects:
453     *      None.
454     *
455     *----------------------------------------------------------------------
456     */
457    
458    char *
459    TclpGetUserHome(name, bufferPtr)
460        CONST char *name;           /* User name for desired home directory. */
461        Tcl_DString *bufferPtr;     /* Uninitialized or free DString filled
462                                     * with name of user's home directory. */
463    {
464        char *result;
465        HINSTANCE netapiInst;
466    
467        result = NULL;
468    
469        Tcl_DStringInit(bufferPtr);
470    
471        netapiInst = LoadLibraryA("netapi32.dll");
472        if (netapiInst != NULL) {
473            NETAPIBUFFERFREEPROC *netApiBufferFreeProc;
474            NETGETDCNAMEPROC *netGetDCNameProc;
475            NETUSERGETINFOPROC *netUserGetInfoProc;
476    
477            netApiBufferFreeProc = (NETAPIBUFFERFREEPROC *)
478                    GetProcAddress(netapiInst, "NetApiBufferFree");
479            netGetDCNameProc = (NETGETDCNAMEPROC *)
480                    GetProcAddress(netapiInst, "NetGetDCName");
481            netUserGetInfoProc = (NETUSERGETINFOPROC *)
482                    GetProcAddress(netapiInst, "NetUserGetInfo");
483            if ((netUserGetInfoProc != NULL) && (netGetDCNameProc != NULL)
484                    && (netApiBufferFreeProc != NULL)) {
485                USER_INFO_1 *uiPtr;
486                Tcl_DString ds;
487                int nameLen, badDomain;
488                char *domain;
489                WCHAR *wName, *wHomeDir, *wDomain;
490                WCHAR buf[MAX_PATH];
491    
492                badDomain = 0;
493                nameLen = -1;
494                wDomain = NULL;
495                domain = strchr(name, '@');
496                if (domain != NULL) {
497                    Tcl_DStringInit(&ds);
498                    wName = Tcl_UtfToUniCharDString(domain + 1, -1, &ds);
499                    badDomain = (*netGetDCNameProc)(NULL, wName,
500                            (LPBYTE *) &wDomain);
501                    Tcl_DStringFree(&ds);
502                    nameLen = domain - name;
503                }
504                if (badDomain == 0) {
505                    Tcl_DStringInit(&ds);
506                    wName = Tcl_UtfToUniCharDString(name, nameLen, &ds);
507                    if ((*netUserGetInfoProc)(wDomain, wName, 1,
508                            (LPBYTE *) &uiPtr) == 0) {
509                        wHomeDir = uiPtr->usri1_home_dir;
510                        if ((wHomeDir != NULL) && (wHomeDir[0] != L'\0')) {
511                            Tcl_UniCharToUtfDString(wHomeDir, lstrlenW(wHomeDir),
512                                    bufferPtr);
513                        } else {
514                            /*
515                             * User exists but has no home dir.  Return
516                             * "{Windows Drive}:/users/default".
517                             */
518    
519                            GetWindowsDirectoryW(buf, MAX_PATH);
520                            Tcl_UniCharToUtfDString(buf, 2, bufferPtr);
521                            Tcl_DStringAppend(bufferPtr, "/users/default", -1);
522                        }
523                        result = Tcl_DStringValue(bufferPtr);
524                        (*netApiBufferFreeProc)((void *) uiPtr);
525                    }
526                    Tcl_DStringFree(&ds);
527                }
528                if (wDomain != NULL) {
529                    (*netApiBufferFreeProc)((void *) wDomain);
530                }
531            }
532            FreeLibrary(netapiInst);
533        }
534        if (result == NULL) {
535            /*
536             * Look in the "Password Lists" section of system.ini for the
537             * local user.  There are also entries in that section that begin
538             * with a "*" character that are used by Windows for other
539             * purposes; ignore user names beginning with a "*".
540             */
541    
542            char buf[MAX_PATH];
543    
544            if (name[0] != '*') {
545                if (GetPrivateProfileStringA("Password Lists", name, "", buf,
546                        MAX_PATH, "system.ini") > 0) {
547                    /*
548                     * User exists, but there is no such thing as a home
549                     * directory in system.ini.  Return "{Windows drive}:/".
550                     */
551    
552                    GetWindowsDirectoryA(buf, MAX_PATH);
553                    Tcl_DStringAppend(bufferPtr, buf, 3);
554                    result = Tcl_DStringValue(bufferPtr);
555                }
556            }
557        }
558    
559        return result;
560    }
561    
562    /*
563     *---------------------------------------------------------------------------
564     *
565     * TclpAccess --
566     *
567     *      This function replaces the library version of access(), fixing the
568     *      following bugs:
569     *
570     *      1. access() returns that all files have execute permission.
571     *
572     * Results:
573     *      See access documentation.
574     *
575     * Side effects:
576     *      See access documentation.
577     *
578     *---------------------------------------------------------------------------
579     */
580    
581    int
582    TclpAccess(
583        CONST char *path,           /* Path of file to access (UTF-8). */
584        int mode)                   /* Permission setting. */
585    {
586        Tcl_DString ds;
587        TCHAR *nativePath;
588        DWORD attr;
589    
590        nativePath = Tcl_WinUtfToTChar(path, -1, &ds);
591        attr = (*tclWinProcs->getFileAttributesProc)(nativePath);
592        Tcl_DStringFree(&ds);
593    
594        if (attr == 0xffffffff) {
595            /*
596             * File doesn't exist.
597             */
598    
599            TclWinConvertError(GetLastError());
600            return -1;
601        }
602    
603        if ((mode & W_OK) && (attr & FILE_ATTRIBUTE_READONLY)) {
604            /*
605             * File is not writable.
606             */
607    
608            Tcl_SetErrno(EACCES);
609            return -1;
610        }
611    
612        if (mode & X_OK) {
613            CONST char *p;
614    
615            if (attr & FILE_ATTRIBUTE_DIRECTORY) {
616                /*
617                 * Directories are always executable.
618                 */
619                
620                return 0;
621            }
622            p = strrchr(path, '.');
623            if (p != NULL) {
624                p++;
625                if ((stricmp(p, "exe") == 0)
626                        || (stricmp(p, "com") == 0)
627                        || (stricmp(p, "bat") == 0)) {
628                    /*
629                     * File that ends with .exe, .com, or .bat is executable.
630                     */
631    
632                    return 0;
633                }
634            }
635            Tcl_SetErrno(EACCES);
636            return -1;
637        }
638    
639        return 0;
640    }
641    
642    /*
643     *----------------------------------------------------------------------
644     *
645     * TclpChdir --
646     *
647     *      This function replaces the library version of chdir().
648     *
649     * Results:
650     *      See chdir() documentation.
651     *
652     * Side effects:
653     *      See chdir() documentation.  
654     *
655     *----------------------------------------------------------------------
656     */
657    
658    int
659    TclpChdir(path)
660        CONST char *path;           /* Path to new working directory (UTF-8). */
661    {
662        int result;
663        Tcl_DString ds;
664        TCHAR *nativePath;
665    
666        nativePath = Tcl_WinUtfToTChar(path, -1, &ds);
667        result = (*tclWinProcs->setCurrentDirectoryProc)(nativePath);
668        Tcl_DStringFree(&ds);
669    
670        if (result == 0) {
671            TclWinConvertError(GetLastError());
672            return -1;
673        }
674        return 0;
675    }
676    
677    /*
678     *----------------------------------------------------------------------
679     *
680     * TclpGetCwd --
681     *
682     *      This function replaces the library version of getcwd().
683     *
684     * Results:
685     *      The result is a pointer to a string specifying the current
686     *      directory, or NULL if the current directory could not be
687     *      determined.  If NULL is returned, an error message is left in the
688     *      interp's result.  Storage for the result string is allocated in
689     *      bufferPtr; the caller must call Tcl_DStringFree() when the result
690     *      is no longer needed.
691     *
692     * Side effects:
693     *      None.
694     *
695     *----------------------------------------------------------------------
696     */
697    
698    char *
699    TclpGetCwd(interp, bufferPtr)
700        Tcl_Interp *interp;         /* If non-NULL, used for error reporting. */
701        Tcl_DString *bufferPtr;     /* Uninitialized or free DString filled
702                                     * with name of current directory. */
703    {
704        WCHAR buffer[MAX_PATH];
705        char *p;
706    
707        if ((*tclWinProcs->getCurrentDirectoryProc)(MAX_PATH, buffer) == 0) {
708            TclWinConvertError(GetLastError());
709            if (interp != NULL) {
710                Tcl_AppendResult(interp,
711                        "error getting working directory name: ",
712                        Tcl_PosixError(interp), (char *) NULL);
713            }
714            return NULL;
715        }
716    
717        /*
718         * Watch for the wierd Windows c:\\UNC syntax.
719         */
720    
721        if (tclWinProcs->useWide) {
722            WCHAR *native;
723    
724            native = (WCHAR *) buffer;
725            if ((native[0] != '\0') && (native[1] == ':')
726                    && (native[2] == '\\') && (native[3] == '\\')) {
727                native += 2;
728            }
729            Tcl_WinTCharToUtf((TCHAR *) native, -1, bufferPtr);
730        } else {
731            char *native;
732    
733            native = (char *) buffer;
734            if ((native[0] != '\0') && (native[1] == ':')
735                    && (native[2] == '\\') && (native[3] == '\\')) {
736                native += 2;
737            }
738            Tcl_WinTCharToUtf((TCHAR *) native, -1, bufferPtr);
739        }
740    
741        /*
742         * Convert to forward slashes for easier use in scripts.
743         */
744                  
745        for (p = Tcl_DStringValue(bufferPtr); *p != '\0'; p++) {
746            if (*p == '\\') {
747                *p = '/';
748            }
749        }
750        return Tcl_DStringValue(bufferPtr);
751    }
752    
753    /*
754     *----------------------------------------------------------------------
755     *
756     * TclpStat --
757     *
758     *      This function replaces the library version of stat(), fixing
759     *      the following bugs:
760     *
761     *      1. stat("c:") returns an error.
762     *      2. Borland stat() return time in GMT instead of localtime.
763     *      3. stat("\\server\mount") would return error.
764     *      4. Accepts slashes or backslashes.
765     *      5. st_dev and st_rdev were wrong for UNC paths.
766     *
767     * Results:
768     *      See stat documentation.
769     *
770     * Side effects:
771     *      See stat documentation.
772     *
773     *----------------------------------------------------------------------
774     */
775    
776    int
777    TclpStat(path, statPtr)
778        CONST char *path;           /* Path of file to stat (UTF-8). */
779        struct stat *statPtr;       /* Filled with results of stat call. */
780    {
781        Tcl_DString ds;
782        TCHAR *nativePath;
783        WIN32_FIND_DATAT data;
784        HANDLE handle;
785        DWORD attr;
786        WCHAR nativeFullPath[MAX_PATH];
787        TCHAR *nativePart;
788        char *p, *fullPath;
789        int dev, mode;
790    
791        /*
792         * Eliminate file names containing wildcard characters, or subsequent
793         * call to FindFirstFile() will expand them, matching some other file.
794         */
795    
796        if (strpbrk(path, "?*") != NULL) {
797            Tcl_SetErrno(ENOENT);
798            return -1;
799        }
800    
801        nativePath = Tcl_WinUtfToTChar(path, -1, &ds);
802        handle = (*tclWinProcs->findFirstFileProc)(nativePath, &data);
803        if (handle == INVALID_HANDLE_VALUE) {
804            /*
805             * FindFirstFile() doesn't work on root directories, so call
806             * GetFileAttributes() to see if the specified file exists.
807             */
808    
809            attr = (*tclWinProcs->getFileAttributesProc)(nativePath);
810            if (attr == 0xffffffff) {
811                Tcl_DStringFree(&ds);
812                Tcl_SetErrno(ENOENT);
813                return -1;
814            }
815    
816            /*
817             * Make up some fake information for this file.  It has the
818             * correct file attributes and a time of 0.
819             */
820    
821            memset(&data, 0, sizeof(data));
822            data.a.dwFileAttributes = attr;
823        } else {
824            FindClose(handle);
825        }
826    
827        (*tclWinProcs->getFullPathNameProc)(nativePath, MAX_PATH, nativeFullPath,
828                &nativePart);
829    
830        Tcl_DStringFree(&ds);
831        fullPath = Tcl_WinTCharToUtf((TCHAR *) nativeFullPath, -1, &ds);
832    
833        dev = -1;
834        if ((fullPath[0] == '\\') && (fullPath[1] == '\\')) {
835            char *p;
836            DWORD dw;
837            TCHAR *nativeVol;
838            Tcl_DString volString;
839    
840            p = strchr(fullPath + 2, '\\');
841            p = strchr(p + 1, '\\');
842            if (p == NULL) {
843                /*
844                 * Add terminating backslash to fullpath or
845                 * GetVolumeInformation() won't work.
846                 */
847    
848                fullPath = Tcl_DStringAppend(&ds, "\\", 1);
849                p = fullPath + Tcl_DStringLength(&ds);
850            } else {
851                p++;
852            }
853            nativeVol = Tcl_WinUtfToTChar(fullPath, p - fullPath, &volString);
854            dw = (DWORD) -1;
855            (*tclWinProcs->getVolumeInformationProc)(nativeVol, NULL, 0, &dw,
856                    NULL, NULL, NULL, 0);
857            /*
858             * GetFullPathName() turns special devices like "NUL" into "\\.\NUL",
859             * but GetVolumeInformation() returns failure for "\\.\NUL".  This
860             * will cause "NUL" to get a drive number of -1, which makes about
861             * as much sense as anything since the special devices don't live on
862             * any drive.
863             */
864    
865            dev = dw;
866            Tcl_DStringFree(&volString);
867        } else if ((fullPath[0] != '\0') && (fullPath[1] == ':')) {
868            dev = Tcl_UniCharToLower(fullPath[0]) - 'a';
869        }
870        Tcl_DStringFree(&ds);
871    
872        attr = data.a.dwFileAttributes;
873        mode  = (attr & FILE_ATTRIBUTE_DIRECTORY) ? S_IFDIR | S_IEXEC : S_IFREG;
874        mode |= (attr & FILE_ATTRIBUTE_READONLY) ? S_IREAD : S_IREAD | S_IWRITE;
875        p = strrchr(path, '.');
876        if (p != NULL) {
877            if ((lstrcmpiA(p, ".exe") == 0)
878                    || (lstrcmpiA(p, ".com") == 0)
879                    || (lstrcmpiA(p, ".bat") == 0)
880                    || (lstrcmpiA(p, ".pif") == 0)) {
881                mode |= S_IEXEC;
882            }
883        }
884    
885        /*
886         * Propagate the S_IREAD, S_IWRITE, S_IEXEC bits to the group and
887         * other positions.
888         */
889    
890        mode |= (mode & 0x0700) >> 3;
891        mode |= (mode & 0x0700) >> 6;
892        
893        statPtr->st_dev     = (dev_t) dev;
894        statPtr->st_ino     = 0;
895        statPtr->st_mode    = (unsigned short) mode;
896        statPtr->st_nlink   = 1;
897        statPtr->st_uid     = 0;
898        statPtr->st_gid     = 0;
899        statPtr->st_rdev    = (dev_t) dev;
900        statPtr->st_size    = data.a.nFileSizeLow;
901        statPtr->st_atime   = ToCTime(data.a.ftLastAccessTime);
902        statPtr->st_mtime   = ToCTime(data.a.ftLastWriteTime);
903        statPtr->st_ctime   = ToCTime(data.a.ftCreationTime);
904        return 0;
905    }
906    
907    static time_t
908    ToCTime(
909        FILETIME fileTime)          /* UTC Time to convert to local time_t. */
910    {
911        FILETIME localFileTime;
912        SYSTEMTIME systemTime;
913        struct tm tm;
914    
915        if (FileTimeToLocalFileTime(&fileTime, &localFileTime) == 0) {
916            return 0;
917        }
918        if (FileTimeToSystemTime(&localFileTime, &systemTime) == 0) {
919            return 0;
920        }
921        tm.tm_sec = systemTime.wSecond;
922        tm.tm_min = systemTime.wMinute;
923        tm.tm_hour = systemTime.wHour;
924        tm.tm_mday = systemTime.wDay;
925        tm.tm_mon = systemTime.wMonth - 1;
926        tm.tm_year = systemTime.wYear - 1900;
927        tm.tm_wday = 0;
928        tm.tm_yday = 0;
929        tm.tm_isdst = -1;
930    
931        return mktime(&tm);
932    }
933    
934    #if 0
935    
936        /*
937         * Borland's stat doesn't take into account localtime.
938         */
939    
940        if ((result == 0) && (buf->st_mtime != 0)) {
941            TIME_ZONE_INFORMATION tz;
942            int time, bias;
943    
944            time = GetTimeZoneInformation(&tz);
945            bias = tz.Bias;
946            if (time == TIME_ZONE_ID_DAYLIGHT) {
947                bias += tz.DaylightBias;
948            }
949            bias *= 60;
950            buf->st_atime -= bias;
951            buf->st_ctime -= bias;
952            buf->st_mtime -= bias;
953        }
954    
955    #endif
956    
957    
958    #if 0
959    /*
960     *-------------------------------------------------------------------------
961     *
962     * TclWinResolveShortcut --
963     *
964     *      Resolve a potential Windows shortcut to get the actual file or
965     *      directory in question.  
966     *
967     * Results:
968     *      Returns 1 if the shortcut could be resolved, or 0 if there was
969     *      an error or if the filename was not a shortcut.
970     *      If bufferPtr did hold the name of a shortcut, it is modified to
971     *      hold the resolved target of the shortcut instead.
972     *
973     * Side effects:
974     *      Loads and unloads OLE package to determine if filename refers to
975     *      a shortcut.
976     *
977     *-------------------------------------------------------------------------
978     */
979    
980    int
981    TclWinResolveShortcut(bufferPtr)
982        Tcl_DString *bufferPtr;     /* Holds name of file to resolve.  On
983                                     * return, holds resolved file name. */
984    {
985        HRESULT hres;
986        IShellLink *psl;
987        IPersistFile *ppf;
988        WIN32_FIND_DATA wfd;
989        WCHAR wpath[MAX_PATH];
990        char *path, *ext;
991        char realFileName[MAX_PATH];
992    
993        /*
994         * Windows system calls do not automatically resolve
995         * shortcuts like UNIX automatically will with symbolic links.
996         */
997    
998        path = Tcl_DStringValue(bufferPtr);
999        ext = strrchr(path, '.');
1000        if ((ext == NULL) || (stricmp(ext, ".lnk") != 0)) {
1001            return 0;
1002        }
1003    
1004        CoInitialize(NULL);
1005        path = Tcl_DStringValue(bufferPtr);
1006        realFileName[0] = '\0';
1007        hres = CoCreateInstance(&CLSID_ShellLink, NULL, CLSCTX_INPROC_SERVER,
1008                &IID_IShellLink, &psl);
1009        if (SUCCEEDED(hres)) {
1010            hres = psl->lpVtbl->QueryInterface(psl, &IID_IPersistFile, &ppf);
1011            if (SUCCEEDED(hres)) {
1012                MultiByteToWideChar(CP_ACP, 0, path, -1, wpath, sizeof(wpath));
1013                hres = ppf->lpVtbl->Load(ppf, wpath, STGM_READ);
1014                if (SUCCEEDED(hres)) {
1015                    hres = psl->lpVtbl->Resolve(psl, NULL,
1016                            SLR_ANY_MATCH | SLR_NO_UI);
1017                    if (SUCCEEDED(hres)) {
1018                        hres = psl->lpVtbl->GetPath(psl, realFileName, MAX_PATH,
1019                                &wfd, 0);
1020                    }
1021                }
1022                ppf->lpVtbl->Release(ppf);
1023            }
1024            psl->lpVtbl->Release(psl);
1025        }
1026        CoUninitialize();
1027    
1028        if (realFileName[0] != '\0') {
1029            Tcl_DStringSetLength(bufferPtr, 0);
1030            Tcl_DStringAppend(bufferPtr, realFileName, -1);
1031            return 1;
1032        }
1033        return 0;
1034    }
1035    #endif
1036    
1037    /* End of tclwinfile.c */

Legend:
Removed from v.64  
changed lines
  Added in v.71

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25