summaryrefslogtreecommitdiffstats
path: root/win/tclWinFile.c
diff options
context:
space:
mode:
Diffstat (limited to 'win/tclWinFile.c')
-rw-r--r--win/tclWinFile.c611
1 files changed, 328 insertions, 283 deletions
diff --git a/win/tclWinFile.c b/win/tclWinFile.c
index 90feb0c..b0c1854 100644
--- a/win/tclWinFile.c
+++ b/win/tclWinFile.c
@@ -11,7 +11,7 @@
* 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.26 2002/02/15 14:28:51 dkf Exp $
+ * RCS: @(#) $Id: tclWinFile.c,v 1.27 2002/03/24 11:41:51 vincentdarley Exp $
*/
#include "tclWinInt.h"
@@ -33,6 +33,8 @@ typedef NET_API_STATUS NET_API_FUNCTION NETGETDCNAMEPROC
static int NativeAccess(CONST TCHAR *path, int mode);
static int NativeStat(CONST TCHAR *path, Tcl_StatBuf *statPtr);
static int NativeIsExec(CONST TCHAR *path);
+static int NativeMatchType(int isDrive, CONST TCHAR* nativeName,
+ Tcl_GlobTypeData *types);
/*
@@ -119,332 +121,375 @@ TclpMatchInDirectory(interp, resultPtr, pathPtr, pattern, types)
* May be NULL. In particular the directory
* flag is very important. */
{
- char drivePat[] = "?:\\";
- const char *message;
- CONST char *dir;
- char *root;
- int dirLength;
- Tcl_DString dirString;
- DWORD attr, volFlags;
- HANDLE handle;
- WIN32_FIND_DATAT data;
- BOOL found;
- Tcl_DString ds;
- Tcl_DString dsOrig;
- Tcl_Obj *fileNamePtr;
CONST TCHAR *nativeName;
- int matchSpecialDots;
-
- /*
- * Convert the path to normalized form since some interfaces only
- * accept backslashes. Also, ensure that the directory ends with a
- * separator character.
- */
- fileNamePtr = Tcl_FSGetTranslatedPath(interp, pathPtr);
- if (fileNamePtr == NULL) {
- return TCL_ERROR;
- }
- Tcl_DStringInit(&dsOrig);
- Tcl_DStringAppend(&dsOrig, Tcl_GetString(fileNamePtr), -1);
-
- dirLength = Tcl_DStringLength(&dsOrig);
- Tcl_DStringInit(&dirString);
- if (dirLength == 0) {
- Tcl_DStringAppend(&dirString, ".\\", 2);
- } else {
- char *p;
-
- Tcl_DStringAppend(&dirString, Tcl_DStringValue(&dsOrig),
- Tcl_DStringLength(&dsOrig));
- for (p = Tcl_DStringValue(&dirString); *p != '\0'; p++) {
- if (*p == '/') {
- *p = '\\';
+ if (pattern == NULL || (*pattern == '\0')) {
+ int isDrive = 0;
+ int len;
+ char *str = Tcl_GetStringFromObj(pathPtr,&len);
+ if (len < 4) {
+ if (len == 0) {
+ /*
+ * Not sure if this is possible, but we pass it on
+ * anyway
+ */
+ } else if (len == 1 && (str[0] == '/' || str[0] == '\\')) {
+ /* Path is pointing to the root volume */
+ isDrive = 1;
+ } else if ((str[1] == ':') && (len == 2 || (str[2] == '/' || str[2] == '\\'))) {
+ /* Path is of the form 'x:' or 'x:/' or 'x:\' */
+ isDrive = 1;
}
}
- p--;
- /* Make sure we have a trailing directory delimiter */
- if ((*p != '\\') && (*p != ':')) {
- Tcl_DStringAppend(&dirString, "\\", 1);
- Tcl_DStringAppend(&dsOrig, "/", 1);
- dirLength++;
+ /* Match a file directly */
+ nativeName = (CONST TCHAR*) Tcl_FSGetNativePath(pathPtr);
+ if (NativeMatchType(isDrive, nativeName, types)) {
+ Tcl_ListObjAppendElement(interp, resultPtr, pathPtr);
}
- }
- 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;
- }
+ } else {
+ char drivePat[] = "?:\\";
+ const char *message;
+ CONST char *dir;
+ char *root;
+ int dirLength;
+ Tcl_DString dirString;
+ DWORD attr, volFlags;
+ HANDLE handle;
+ WIN32_FIND_DATAT data;
+ BOOL found;
+ Tcl_DString ds;
+ Tcl_DString dsOrig;
+ Tcl_Obj *fileNamePtr;
+ int matchSpecialDots;
+
+ /*
+ * Convert the path to normalized form since some interfaces only
+ * accept backslashes. Also, ensure that the directory ends with a
+ * separator character.
+ */
- /*
- * 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.
- */
+ fileNamePtr = Tcl_FSGetTranslatedPath(interp, pathPtr);
+ if (fileNamePtr == NULL) {
+ return TCL_ERROR;
+ }
+ Tcl_DStringInit(&dsOrig);
+ Tcl_DStringAppend(&dsOrig, Tcl_GetString(fileNamePtr), -1);
- 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;
+ dirLength = Tcl_DStringLength(&dsOrig);
+ Tcl_DStringInit(&dirString);
+ if (dirLength == 0) {
+ Tcl_DStringAppend(&dirString, ".\\", 2);
+ } else {
+ 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);
+ Tcl_DStringAppend(&dirString, Tcl_DStringValue(&dsOrig),
+ Tcl_DStringLength(&dsOrig));
+ for (p = Tcl_DStringValue(&dirString); *p != '\0'; p++) {
+ if (*p == '/') {
+ *p = '\\';
+ }
}
- break;
- }
+ p--;
+ /* Make sure we have a trailing directory delimiter */
+ if ((*p != '\\') && (*p != ':')) {
+ Tcl_DStringAppend(&dirString, "\\", 1);
+ Tcl_DStringAppend(&dsOrig, "/", 1);
+ dirLength++;
+ }
+ }
+ dir = Tcl_DStringValue(&dirString);
- if (found == 0) {
- message = "couldn't read volume information for \"";
- goto error;
- }
+ /*
+ * First verify that the specified path is actually a directory.
+ */
- /*
- * Check to see if the pattern should match the special
- * . and .. names, referring to the current directory,
- * or the directory above. We need a special check for
- * this because paths beginning with a dot are not considered
- * hidden on Windows, and so otherwise a relative glob like
- * 'glob -join * *' will actually return './. ../..' etc.
- */
+ nativeName = Tcl_WinUtfToTChar(dir, Tcl_DStringLength(&dirString), &ds);
+ attr = (*tclWinProcs->getFileAttributesProc)(nativeName);
+ Tcl_DStringFree(&ds);
- if ((pattern[0] == '.')
- || ((pattern[0] == '\\') && (pattern[1] == '.'))) {
- matchSpecialDots = 1;
- } else {
- matchSpecialDots = 0;
- }
+ if ((attr == 0xffffffff) || ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0)) {
+ Tcl_DStringFree(&dirString);
+ return TCL_OK;
+ }
- /*
- * We need to check all files in the directory, so append a *.*
- * to the path.
- */
+ /*
+ * 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.
+ */
- dir = Tcl_DStringAppend(&dirString, "*.*", 3);
- nativeName = Tcl_WinUtfToTChar(dir, -1, &ds);
- handle = (*tclWinProcs->findFirstFileProc)(nativeName, &data);
- Tcl_DStringFree(&ds);
+ 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 (handle == INVALID_HANDLE_VALUE) {
- message = "couldn't read directory \"";
- goto error;
- }
+ if (found == 0) {
+ message = "couldn't read volume information for \"";
+ goto error;
+ }
- /*
- * Now iterate over all of the files in the directory.
- */
+ /*
+ * Check to see if the pattern should match the special
+ * . and .. names, referring to the current directory,
+ * or the directory above. We need a special check for
+ * this because paths beginning with a dot are not considered
+ * hidden on Windows, and so otherwise a relative glob like
+ * 'glob -join * *' will actually return './. ../..' etc.
+ */
- for (found = 1; found != 0;
- found = (*tclWinProcs->findNextFileProc)(handle, &data)) {
- CONST TCHAR *nativeMatchResult;
- CONST char *name, *fname;
-
- int typeOk = 1;
-
- if (tclWinProcs->useWide) {
- nativeName = (CONST TCHAR *) data.w.cFileName;
+ if ((pattern[0] == '.')
+ || ((pattern[0] == '\\') && (pattern[1] == '.'))) {
+ matchSpecialDots = 1;
} else {
- nativeName = (CONST TCHAR *) data.a.cFileName;
+ matchSpecialDots = 0;
}
- name = Tcl_WinTCharToUtf(nativeName, -1, &ds);
- if (!matchSpecialDots) {
- /* If it is exactly '.' or '..' then we ignore it */
- if (name[0] == '.') {
- if (name[1] == '\0' || (name[1] == '.' && name[2] == '\0')) {
- continue;
- }
- }
- }
-
/*
- * Check to see if the file matches the pattern. 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.
+ * We need to check all files in the directory, so append a *.*
+ * to the path.
*/
- nativeMatchResult = NULL;
-
- if (Tcl_StringCaseMatch(name, pattern, 1) != 0) {
- nativeMatchResult = nativeName;
- }
- Tcl_DStringFree(&ds);
+ dir = Tcl_DStringAppend(&dirString, "*.*", 3);
+ nativeName = Tcl_WinUtfToTChar(dir, -1, &ds);
+ handle = (*tclWinProcs->findFirstFileProc)(nativeName, &data);
+ Tcl_DStringFree(&ds);
- if (nativeMatchResult == NULL) {
- continue;
+ if (handle == INVALID_HANDLE_VALUE) {
+ message = "couldn't read directory \"";
+ goto error;
}
/*
- * If the file matches, then we need to process the remainder of the
- * path.
+ * Now iterate over all of the files in the directory.
*/
- name = Tcl_WinTCharToUtf(nativeMatchResult, -1, &ds);
- Tcl_DStringAppend(&dsOrig, name, -1);
- Tcl_DStringFree(&ds);
+ for (found = 1; found != 0;
+ found = (*tclWinProcs->findNextFileProc)(handle, &data)) {
+ CONST TCHAR *nativeMatchResult;
+ CONST char *name, *fname;
+
+ if (tclWinProcs->useWide) {
+ nativeName = (CONST TCHAR *) data.w.cFileName;
+ } else {
+ nativeName = (CONST TCHAR *) data.a.cFileName;
+ }
+ name = Tcl_WinTCharToUtf(nativeName, -1, &ds);
+
+ if (!matchSpecialDots) {
+ /* If it is exactly '.' or '..' then we ignore it */
+ if (name[0] == '.') {
+ if (name[1] == '\0' || (name[1] == '.' && name[2] == '\0')) {
+ continue;
+ }
+ }
+ }
+
+ /*
+ * Check to see if the file matches the pattern. 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.
+ */
+
+ nativeMatchResult = NULL;
+
+ if (Tcl_StringCaseMatch(name, pattern, 1) != 0) {
+ nativeMatchResult = nativeName;
+ }
+ Tcl_DStringFree(&ds);
+
+ if (nativeMatchResult == NULL) {
+ continue;
+ }
+
+ /*
+ * If the file matches, then we need to process the remainder of the
+ * path.
+ */
+
+ name = Tcl_WinTCharToUtf(nativeMatchResult, -1, &ds);
+ Tcl_DStringAppend(&dsOrig, name, -1);
+ Tcl_DStringFree(&ds);
+
+ fname = Tcl_DStringValue(&dsOrig);
+ nativeName = Tcl_WinUtfToTChar(fname, Tcl_DStringLength(&dsOrig), &ds);
+
+ if (NativeMatchType(0, nativeName, types)) {
+ Tcl_ListObjAppendElement(interp, resultPtr,
+ Tcl_NewStringObj(fname, Tcl_DStringLength(&dsOrig)));
+ }
+ /*
+ * Free ds here to ensure that nativeName is valid above.
+ */
+
+ Tcl_DStringFree(&ds);
- fname = Tcl_DStringValue(&dsOrig);
- nativeName = Tcl_WinUtfToTChar(fname, Tcl_DStringLength(&dsOrig), &ds);
+ Tcl_DStringSetLength(&dsOrig, dirLength);
+ }
+
+ FindClose(handle);
+ Tcl_DStringFree(&dirString);
+ Tcl_DStringFree(&dsOrig);
+
+ return TCL_OK;
- /*
- * 'attr' represents the attributes of the file, but we only
- * want to retrieve this info if it is absolutely necessary
- * because it is an expensive call. Unfortunately, to deal
- * with hidden files properly, we must always retrieve it.
- * There are more modern Win32 APIs available which we should
- * look into.
- */
+ error:
+ Tcl_DStringFree(&dirString);
+ TclWinConvertError(GetLastError());
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, message, Tcl_DStringValue(&dsOrig), "\": ",
+ Tcl_PosixError(interp), (char *) NULL);
+ Tcl_DStringFree(&dsOrig);
+ return TCL_ERROR;
+ }
- attr = (*tclWinProcs->getFileAttributesProc)(nativeName);
- if (types == NULL) {
- /* If invisible, don't return the file */
- if (attr & FILE_ATTRIBUTE_HIDDEN) {
- typeOk = 0;
+}
+
+/*
+ * This function needs a special case for a path which is a root
+ * volume, because for NTFS root volumes, the getFileAttributesProc
+ * returns a 'hidden' attribute when it should not.
+ */
+static int
+NativeMatchType(
+ int isDrive, /* Is this path a drive (root volume) */
+ CONST TCHAR* nativeName, /* Native path to check */
+ Tcl_GlobTypeData *types) /* Type description to match against */
+{
+ /*
+ * 'attr' represents the attributes of the file, but we only
+ * want to retrieve this info if it is absolutely necessary
+ * because it is an expensive call. Unfortunately, to deal
+ * with hidden files properly, we must always retrieve it.
+ * There are more modern Win32 APIs available which we should
+ * look into.
+ */
+
+ DWORD attr = (*tclWinProcs->getFileAttributesProc)(nativeName);
+ if (attr == 0xffffffff) {
+ /* File doesn't exist */
+ return 0;
+ }
+
+ if (types == NULL) {
+ /* If invisible, don't return the file */
+ if (attr & FILE_ATTRIBUTE_HIDDEN && !isDrive) {
+ return 0;
+ }
+ } else {
+ if (attr & FILE_ATTRIBUTE_HIDDEN && !isDrive) {
+ /* If invisible */
+ if ((types->perm == 0) ||
+ !(types->perm & TCL_GLOB_PERM_HIDDEN)) {
+ return 0;
}
} else {
- if (attr & FILE_ATTRIBUTE_HIDDEN) {
- /* If invisible */
- if ((types->perm == 0) ||
- !(types->perm & TCL_GLOB_PERM_HIDDEN)) {
- typeOk = 0;
- }
- } else {
- /* Visible */
- if (types->perm & TCL_GLOB_PERM_HIDDEN) {
- typeOk = 0;
- }
+ /* Visible */
+ if (types->perm & TCL_GLOB_PERM_HIDDEN) {
+ return 0;
}
+ }
+
+ if (types->perm != 0) {
+ if (
+ ((types->perm & TCL_GLOB_PERM_RONLY) &&
+ !(attr & FILE_ATTRIBUTE_READONLY)) ||
+ ((types->perm & TCL_GLOB_PERM_R) &&
+ (NativeAccess(nativeName, R_OK) != 0)) ||
+ ((types->perm & TCL_GLOB_PERM_W) &&
+ (NativeAccess(nativeName, W_OK) != 0)) ||
+ ((types->perm & TCL_GLOB_PERM_X) &&
+ (NativeAccess(nativeName, X_OK) != 0))
+ ) {
+ return 0;
+ }
+ }
+ if (types->type != 0) {
+ Tcl_StatBuf buf;
- if (typeOk == 1 && types->perm != 0) {
- if (
- ((types->perm & TCL_GLOB_PERM_RONLY) &&
- !(attr & FILE_ATTRIBUTE_READONLY)) ||
- ((types->perm & TCL_GLOB_PERM_R) &&
- (NativeAccess(nativeName, R_OK) != 0)) ||
- ((types->perm & TCL_GLOB_PERM_W) &&
- (NativeAccess(nativeName, W_OK) != 0)) ||
- ((types->perm & TCL_GLOB_PERM_X) &&
- (NativeAccess(nativeName, X_OK) != 0))
- ) {
- typeOk = 0;
- }
+ if (NativeStat(nativeName, &buf) != 0) {
+ /*
+ * Posix error occurred, either the file
+ * has disappeared, or there is some other
+ * strange error. In any case we don't
+ * return this file.
+ */
+ return 0;
}
- if (typeOk && types->type != 0) {
- Tcl_StatBuf buf;
-
- if (NativeStat(nativeName, &buf) != 0) {
- /*
- * Posix error occurred, either the file
- * has disappeared, or there is some other
- * strange error. In any case we don't
- * return this file.
- */
- typeOk = 0;
- }
- if (typeOk) {
- /*
- * 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))
+ /*
+ * 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_ISSOCK
- || ((types->type & TCL_GLOB_TYPE_SOCK) &&
- S_ISSOCK(buf.st_mode))
+ || ((types->type & TCL_GLOB_TYPE_SOCK) &&
+ S_ISSOCK(buf.st_mode))
#endif
- ) {
- /* Do nothing -- this file is ok */
- } else {
- typeOk = 0;
+ ) {
+ /* Do nothing -- this file is ok */
+ } else {
#ifdef S_ISLNK
- if (types->type & TCL_GLOB_TYPE_LINK) {
- /*
- * We should use 'lstat' but it is the
- * same as 'stat' on windows.
- */
- if (NativeStat(nativeName, &buf) == 0) {
- if (S_ISLNK(buf.st_mode)) {
- typeOk = 1;
- }
- }
+ if (types->type & TCL_GLOB_TYPE_LINK) {
+ /*
+ * We should use 'lstat' but it is the
+ * same as 'stat' on windows.
+ */
+ if (NativeStat(nativeName, &buf) == 0) {
+ if (S_ISLNK(buf.st_mode)) {
+ return 1;
}
-#endif
}
}
- }
- }
- if (typeOk) {
- Tcl_ListObjAppendElement(interp, resultPtr,
- Tcl_NewStringObj(fname, Tcl_DStringLength(&dsOrig)));
- }
- /*
- * Free ds here to ensure that nativeName is valid above.
- */
-
- Tcl_DStringFree(&ds);
-
- Tcl_DStringSetLength(&dsOrig, dirLength);
- }
-
- FindClose(handle);
- Tcl_DStringFree(&dirString);
- Tcl_DStringFree(&dsOrig);
-
- return TCL_OK;
-
- error:
- Tcl_DStringFree(&dirString);
- TclWinConvertError(GetLastError());
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, message, Tcl_DStringValue(&dsOrig), "\": ",
- Tcl_PosixError(interp), (char *) NULL);
- Tcl_DStringFree(&dsOrig);
- return TCL_ERROR;
+#endif
+ return 0;
+ }
+ }
+ }
+ return 1;
}
/*