--- to_be_filed/sf_code/esrgpcpj/shared/tcl_base/tclwinfile.c 2016/10/08 07:08:47 29 +++ projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclwinfile.c 2016/11/05 11:07:06 71 @@ -1,1047 +1,1037 @@ -/* $Header: /cvsroot/esrg/sfesrg/esrgpcpj/shared/tcl_base/tclwinfile.c,v 1.1.1.1 2001/06/13 04:49:10 dtashley Exp $ */ - -/* - * 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 -#include -#include /* 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 */ \ No newline at end of file +/* $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 +#include +#include /* 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 */