/* * tclWinFCmd.c * * This file implements the Windows specific portion of file manipulation * subcommands of the "file" command. * * Copyright (c) 1996-1998 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclWinFCmd.c,v 1.21 2002/01/31 21:07:32 uid37547 Exp $ */ #include "tclWinInt.h" /* * The following constants specify the type of callback when * TraverseWinTree() calls the traverseProc() */ #define DOTREE_PRED 1 /* pre-order directory */ #define DOTREE_POSTD 2 /* post-order directory */ #define DOTREE_F 3 /* regular file */ /* * Callbacks for file attributes code. */ static int GetWinFileAttributes _ANSI_ARGS_((Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr)); static int GetWinFileLongName _ANSI_ARGS_((Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr)); static int GetWinFileShortName _ANSI_ARGS_((Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr)); static int SetWinFileAttributes _ANSI_ARGS_((Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj *attributePtr)); static int CannotSetAttribute _ANSI_ARGS_((Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj *attributePtr)); /* * Constants and variables necessary for file attributes subcommand. */ enum { WIN_ARCHIVE_ATTRIBUTE, WIN_HIDDEN_ATTRIBUTE, WIN_LONGNAME_ATTRIBUTE, WIN_READONLY_ATTRIBUTE, WIN_SHORTNAME_ATTRIBUTE, WIN_SYSTEM_ATTRIBUTE }; static int attributeArray[] = {FILE_ATTRIBUTE_ARCHIVE, FILE_ATTRIBUTE_HIDDEN, 0, FILE_ATTRIBUTE_READONLY, 0, FILE_ATTRIBUTE_SYSTEM}; CONST char *tclpFileAttrStrings[] = { "-archive", "-hidden", "-longname", "-readonly", "-shortname", "-system", (char *) NULL }; CONST TclFileAttrProcs tclpFileAttrProcs[] = { {GetWinFileAttributes, SetWinFileAttributes}, {GetWinFileAttributes, SetWinFileAttributes}, {GetWinFileLongName, CannotSetAttribute}, {GetWinFileAttributes, SetWinFileAttributes}, {GetWinFileShortName, CannotSetAttribute}, {GetWinFileAttributes, SetWinFileAttributes}}; /* * Prototype for the TraverseWinTree callback function. */ typedef int (TraversalProc)(CONST TCHAR *srcPtr, CONST TCHAR *dstPtr, int type, Tcl_DString *errorPtr); /* * Declarations for local procedures defined in this file: */ static void StatError(Tcl_Interp *interp, Tcl_Obj *fileName); static int ConvertFileNameFormat(Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, int longShort, Tcl_Obj **attributePtrPtr); static int DoCopyFile(CONST TCHAR *srcPtr, CONST TCHAR *dstPtr); static int DoCreateDirectory(CONST TCHAR *pathPtr); static int DoDeleteFile(CONST TCHAR *pathPtr); static int DoRemoveJustDirectory(CONST TCHAR *nativeSrc, int ignoreError, Tcl_DString *errorPtr); static int DoRemoveDirectory(Tcl_DString *pathPtr, int recursive, Tcl_DString *errorPtr); static int DoRenameFile(CONST TCHAR *nativeSrc, CONST TCHAR *dstPtr); static int TraversalCopy(CONST TCHAR *srcPtr, CONST TCHAR *dstPtr, int type, Tcl_DString *errorPtr); static int TraversalDelete(CONST TCHAR *srcPtr, CONST TCHAR *dstPtr, int type, Tcl_DString *errorPtr); static int TraverseWinTree(TraversalProc *traverseProc, Tcl_DString *sourcePtr, Tcl_DString *dstPtr, Tcl_DString *errorPtr); /* *--------------------------------------------------------------------------- * * TclpObjRenameFile, DoRenameFile -- * * Changes the name of an existing file or directory, from src to dst. * If src and dst refer to the same file or directory, does nothing * and returns success. Otherwise if dst already exists, it will be * deleted and replaced by src subject to the following conditions: * If src is a directory, dst may be an empty directory. * If src is a file, dst may be a file. * In any other situation where dst already exists, the rename will * fail. * * Results: * If the file or directory was successfully renamed, returns TCL_OK. * Otherwise the return value is TCL_ERROR and errno is set to * indicate the error. Some possible values for errno are: * * ENAMETOOLONG: src or dst names are too long. * EACCES: src or dst parent directory can't be read and/or written. * EEXIST: dst is a non-empty directory. * EINVAL: src is a root directory or dst is a subdirectory of src. * EISDIR: dst is a directory, but src is not. * ENOENT: src doesn't exist. src or dst is "". * ENOTDIR: src is a directory, but dst is not. * EXDEV: src and dst are on different filesystems. * * EACCES: exists an open file already referring to src or dst. * EACCES: src or dst specify the current working directory (NT). * EACCES: src specifies a char device (nul:, com1:, etc.) * EEXIST: dst specifies a char device (nul:, com1:, etc.) (NT) * EACCES: dst specifies a char device (nul:, com1:, etc.) (95) * * Side effects: * The implementation supports cross-filesystem renames of files, * but the caller should be prepared to emulate cross-filesystem * renames of directories if errno is EXDEV. * *--------------------------------------------------------------------------- */ int TclpObjRenameFile(srcPathPtr, destPathPtr) Tcl_Obj *srcPathPtr; Tcl_Obj *destPathPtr; { return DoRenameFile(Tcl_FSGetNativePath(srcPathPtr), Tcl_FSGetNativePath(destPathPtr)); } static int DoRenameFile( CONST TCHAR *nativeSrc, /* Pathname of file or dir to be renamed * (native). */ CONST TCHAR *nativeDst) /* New pathname for file or directory * (native). */ { DWORD srcAttr, dstAttr; /* * Would throw an exception under NT if one of the arguments is a * char block device. */ __try { if ((*tclWinProcs->moveFileProc)(nativeSrc, nativeDst) != FALSE) { return TCL_OK; } } __except (-1) {} TclWinConvertError(GetLastError()); srcAttr = (*tclWinProcs->getFileAttributesProc)(nativeSrc); dstAttr = (*tclWinProcs->getFileAttributesProc)(nativeDst); if (srcAttr == 0xffffffff) { if ((*tclWinProcs->getFullPathNameProc)(nativeSrc, 0, NULL, NULL) >= MAX_PATH) { errno = ENAMETOOLONG; return TCL_ERROR; } srcAttr = 0; } if (dstAttr == 0xffffffff) { if ((*tclWinProcs->getFullPathNameProc)(nativeDst, 0, NULL, NULL) >= MAX_PATH) { errno = ENAMETOOLONG; return TCL_ERROR; } dstAttr = 0; } if (errno == EBADF) { errno = EACCES; return TCL_ERROR; } if (errno == EACCES) { decode: if (srcAttr & FILE_ATTRIBUTE_DIRECTORY) { TCHAR *nativeSrcRest, *nativeDstRest; char **srcArgv, **dstArgv; int size, srcArgc, dstArgc; WCHAR nativeSrcPath[MAX_PATH]; WCHAR nativeDstPath[MAX_PATH]; Tcl_DString srcString, dstString; CONST char *src, *dst; size = (*tclWinProcs->getFullPathNameProc)(nativeSrc, MAX_PATH, nativeSrcPath, &nativeSrcRest); if ((size == 0) || (size > MAX_PATH)) { return TCL_ERROR; } size = (*tclWinProcs->getFullPathNameProc)(nativeDst, MAX_PATH, nativeDstPath, &nativeDstRest); if ((size == 0) || (size > MAX_PATH)) { return TCL_ERROR; } (*tclWinProcs->charLowerProc)((TCHAR *) nativeSrcPath); (*tclWinProcs->charLowerProc)((TCHAR *) nativeDstPath); src = Tcl_WinTCharToUtf((TCHAR *) nativeSrcPath, -1, &srcString); dst = Tcl_WinTCharToUtf((TCHAR *) nativeDstPath, -1, &dstString); if (strncmp(src, dst, (size_t) Tcl_DStringLength(&srcString)) == 0) { /* * Trying to move a directory into itself. */ errno = EINVAL; Tcl_DStringFree(&srcString); Tcl_DStringFree(&dstString); return TCL_ERROR; } Tcl_SplitPath(src, &srcArgc, &srcArgv); Tcl_SplitPath(dst, &dstArgc, &dstArgv); Tcl_DStringFree(&srcString); Tcl_DStringFree(&dstString); if (srcArgc == 1) { /* * They are trying to move a root directory. Whether * or not it is across filesystems, this cannot be * done. */ Tcl_SetErrno(EINVAL); } else if ((srcArgc > 0) && (dstArgc > 0) && (strcmp(srcArgv[0], dstArgv[0]) != 0)) { /* * If src is a directory and dst filesystem != src * filesystem, errno should be EXDEV. It is very * important to get this behavior, so that the caller * can respond to a cross filesystem rename by * simulating it with copy and delete. The MoveFile * system call already handles the case of moving a * file between filesystems. */ Tcl_SetErrno(EXDEV); } ckfree((char *) srcArgv); ckfree((char *) dstArgv); } /* * Other types of access failure is that dst is a read-only * filesystem, that an open file referred to src or dest, or that * src or dest specified the current working directory on the * current filesystem. EACCES is returned for those cases. */ } else if (Tcl_GetErrno() == EEXIST) { /* * Reports EEXIST any time the target already exists. If it makes * sense, remove the old file and try renaming again. */ if (srcAttr & FILE_ATTRIBUTE_DIRECTORY) { if (dstAttr & FILE_ATTRIBUTE_DIRECTORY) { /* * Overwrite empty dst directory with src directory. The * following call will remove an empty directory. If it * fails, it's because it wasn't empty. */ if (DoRemoveJustDirectory(nativeDst, 0, NULL) == TCL_OK) { /* * Now that that empty directory is gone, we can try * renaming again. If that fails, we'll put this empty * directory back, for completeness. */ if ((*tclWinProcs->moveFileProc)(nativeSrc, nativeDst) != FALSE) { return TCL_OK; } /* * Some new error has occurred. Don't know what it * could be, but report this one. */ TclWinConvertError(GetLastError()); (*tclWinProcs->createDirectoryProc)(nativeDst, NULL); (*tclWinProcs->setFileAttributesProc)(nativeDst, dstAttr); if (Tcl_GetErrno() == EACCES) { /* * Decode the EACCES to a more meaningful error. */ goto decode; } } } else { /* (dstAttr & FILE_ATTRIBUTE_DIRECTORY) == 0 */ Tcl_SetErrno(ENOTDIR); } } else { /* (srcAttr & FILE_ATTRIBUTE_DIRECTORY) == 0 */ if (dstAttr & FILE_ATTRIBUTE_DIRECTORY) { Tcl_SetErrno(EISDIR); } else { /* * Overwrite existing file by: * * 1. Rename existing file to temp name. * 2. Rename old file to new name. * 3. If success, delete temp file. If failure, * put temp file back to old name. */ TCHAR *nativeRest, *nativeTmp, *nativePrefix; int result, size; WCHAR tempBuf[MAX_PATH]; size = (*tclWinProcs->getFullPathNameProc)(nativeDst, MAX_PATH, tempBuf, &nativeRest); if ((size == 0) || (size > MAX_PATH) || (nativeRest == NULL)) { return TCL_ERROR; } nativeTmp = (TCHAR *) tempBuf; ((char *) nativeRest)[0] = '\0'; ((char *) nativeRest)[1] = '\0'; /* In case it's Unicode. */ result = TCL_ERROR; nativePrefix = (tclWinProcs->useWide) ? (TCHAR *) L"tclr" : (TCHAR *) "tclr"; if ((*tclWinProcs->getTempFileNameProc)(nativeTmp, nativePrefix, 0, tempBuf) != 0) { /* * Strictly speaking, need the following DeleteFile and * MoveFile to be joined as an atomic operation so no * other app comes along in the meantime and creates the * same temp file. */ nativeTmp = (TCHAR *) tempBuf; (*tclWinProcs->deleteFileProc)(nativeTmp); if ((*tclWinProcs->moveFileProc)(nativeDst, nativeTmp) != FALSE) { if ((*tclWinProcs->moveFileProc)(nativeSrc, nativeDst) != FALSE) { (*tclWinProcs->setFileAttributesProc)(nativeTmp, FILE_ATTRIBUTE_NORMAL); (*tclWinProcs->deleteFileProc)(nativeTmp); return TCL_OK; } else { (*tclWinProcs->deleteFileProc)(nativeDst); (*tclWinProcs->moveFileProc)(nativeTmp, nativeDst); } } /* * Can't backup dst file or move src file. Return that * error. Could happen if an open file refers to dst. */ TclWinConvertError(GetLastError()); if (Tcl_GetErrno() == EACCES) { /* * Decode the EACCES to a more meaningful error. */ goto decode; } } return result; } } } return TCL_ERROR; } /* *--------------------------------------------------------------------------- * * TclpObjCopyFile, DoCopyFile -- * * Copy a single file (not a directory). If dst already exists and * is not a directory, it is removed. * * Results: * If the file was successfully copied, returns TCL_OK. Otherwise * the return value is TCL_ERROR and errno is set to indicate the * error. Some possible values for errno are: * * EACCES: src or dst parent directory can't be read and/or written. * EISDIR: src or dst is a directory. * ENOENT: src doesn't exist. src or dst is "". * * EACCES: exists an open file already referring to dst (95). * EACCES: src specifies a char device (nul:, com1:, etc.) (NT) * ENOENT: src specifies a char device (nul:, com1:, etc.) (95) * * Side effects: * It is not an error to copy to a char device. * *--------------------------------------------------------------------------- */ int TclpObjCopyFile(srcPathPtr, destPathPtr) Tcl_Obj *srcPathPtr; Tcl_Obj *destPathPtr; { return DoCopyFile(Tcl_FSGetNativePath(srcPathPtr), Tcl_FSGetNativePath(destPathPtr)); } static int DoCopyFile( CONST TCHAR *nativeSrc, /* Pathname of file to be copied (native). */ CONST TCHAR *nativeDst) /* Pathname of file to copy to (native). */ { /* * Would throw an exception under NT if one of the arguments is a char * block device. */ /* * If 'nativeDst' is NULL, the following code can lock the process * up, at least under Windows2000. Therefore we have to bail at * that point. */ if (nativeDst == NULL) { Tcl_SetErrno(ENOENT); return TCL_ERROR; } /* * Similarly, if 'nativeSrc' is NULL or empty, the following code * locks up the process on WinNT; bail out. */ if (nativeSrc == NULL || nativeSrc[0] == '\0') { Tcl_SetErrno(ENOENT); return TCL_ERROR; } /* * OK, now try the copy. */ __try { if ((*tclWinProcs->copyFileProc)(nativeSrc, nativeDst, 0) != FALSE) { return TCL_OK; } } __except (-1) {} TclWinConvertError(GetLastError()); if (Tcl_GetErrno() == EBADF) { Tcl_SetErrno(EACCES); return TCL_ERROR; } if (Tcl_GetErrno() == EACCES) { DWORD srcAttr, dstAttr; srcAttr = (*tclWinProcs->getFileAttributesProc)(nativeSrc); dstAttr = (*tclWinProcs->getFileAttributesProc)(nativeDst); if (srcAttr != 0xffffffff) { if (dstAttr == 0xffffffff) { dstAttr = 0; } if ((srcAttr & FILE_ATTRIBUTE_DIRECTORY) || (dstAttr & FILE_ATTRIBUTE_DIRECTORY)) { Tcl_SetErrno(EISDIR); } if (dstAttr & FILE_ATTRIBUTE_READONLY) { (*tclWinProcs->setFileAttributesProc)(nativeDst, dstAttr & ~FILE_ATTRIBUTE_READONLY); if ((*tclWinProcs->copyFileProc)(nativeSrc, nativeDst, 0) != FALSE) { return TCL_OK; } /* * Still can't copy onto dst. Return that error, and * restore attributes of dst. */ TclWinConvertError(GetLastError()); (*tclWinProcs->setFileAttributesProc)(nativeDst, dstAttr); } } } return TCL_ERROR; } /* *--------------------------------------------------------------------------- * * TclpObjDeleteFile, DoDeleteFile -- * * Removes a single file (not a directory). * * Results: * If the file was successfully deleted, returns TCL_OK. Otherwise * the return value is TCL_ERROR and errno is set to indicate the * error. Some possible values for errno are: * * EACCES: a parent directory can't be read and/or written. * EISDIR: path is a directory. * ENOENT: path doesn't exist or is "". * * EACCES: exists an open file already referring to path. * EACCES: path is a char device (nul:, com1:, etc.) * * Side effects: * The file is deleted, even if it is read-only. * *--------------------------------------------------------------------------- */ int TclpObjDeleteFile(pathPtr) Tcl_Obj *pathPtr; { return DoDeleteFile(Tcl_FSGetNativePath(pathPtr)); } static int DoDeleteFile( CONST TCHAR *nativePath) /* Pathname of file to be removed (native). */ { DWORD attr; if ((*tclWinProcs->deleteFileProc)(nativePath) != FALSE) { return TCL_OK; } TclWinConvertError(GetLastError()); /* * Win32s thinks that "" is the same as "." and then reports EISDIR * instead of ENOENT. */ if (nativePath == NULL) { Tcl_SetErrno(ENOENT); return TCL_ERROR; } if (tclWinProcs->useWide) { if (((WCHAR *) nativePath)[0] == '\0') { Tcl_SetErrno(ENOENT); return TCL_ERROR; } } else { if (((char *) nativePath)[0] == '\0') { Tcl_SetErrno(ENOENT); return TCL_ERROR; } } if (Tcl_GetErrno() == EACCES) { attr = (*tclWinProcs->getFileAttributesProc)(nativePath); if (attr != 0xffffffff) { if (attr & FILE_ATTRIBUTE_DIRECTORY) { /* * Windows NT reports removing a directory as EACCES instead * of EISDIR. */ Tcl_SetErrno(EISDIR); } else if (attr & FILE_ATTRIBUTE_READONLY) { (*tclWinProcs->setFileAttributesProc)(nativePath, attr & ~FILE_ATTRIBUTE_READONLY); if ((*tclWinProcs->deleteFileProc)(nativePath) != FALSE) { return TCL_OK; } TclWinConvertError(GetLastError()); (*tclWinProcs->setFileAttributesProc)(nativePath, attr); } } } else if (Tcl_GetErrno() == ENOENT) { attr = (*tclWinProcs->getFileAttributesProc)(nativePath); if (attr != 0xffffffff) { if (attr & FILE_ATTRIBUTE_DIRECTORY) { /* * Windows 95 reports removing a directory as ENOENT instead * of EISDIR. */ Tcl_SetErrno(EISDIR); } } } else if (Tcl_GetErrno() == EINVAL) { /* * Windows NT reports removing a char device as EINVAL instead of * EACCES. */ Tcl_SetErrno(EACCES); } return TCL_ERROR; } /* *--------------------------------------------------------------------------- * * TclpObjCreateDirectory -- * * Creates the specified directory. All parent directories of the * specified directory must already exist. The directory is * automatically created with permissions so that user can access * the new directory and create new files or subdirectories in it. * * Results: * If the directory was successfully created, returns TCL_OK. * Otherwise the return value is TCL_ERROR and errno is set to * indicate the error. Some possible values for errno are: * * EACCES: a parent directory can't be read and/or written. * EEXIST: path already exists. * ENOENT: a parent directory doesn't exist. * * Side effects: * A directory is created. * *--------------------------------------------------------------------------- */ int TclpObjCreateDirectory(pathPtr) Tcl_Obj *pathPtr; { return DoCreateDirectory(Tcl_FSGetNativePath(pathPtr)); } static int DoCreateDirectory( CONST TCHAR *nativePath) /* Pathname of directory to create (native). */ { DWORD error; if ((*tclWinProcs->createDirectoryProc)(nativePath, NULL) == 0) { error = GetLastError(); TclWinConvertError(error); return TCL_ERROR; } return TCL_OK; } /* *--------------------------------------------------------------------------- * * TclpObjCopyDirectory -- * * Recursively copies a directory. The target directory dst must * not already exist. Note that this function does not merge two * directory hierarchies, even if the target directory is an an * empty directory. * * Results: * If the directory was successfully copied, returns TCL_OK. * Otherwise the return value is TCL_ERROR, errno is set to indicate * the error, and the pathname of the file that caused the error * is stored in errorPtr. See TclpCreateDirectory and TclpCopyFile * for a description of possible values for errno. * * Side effects: * An exact copy of the directory hierarchy src will be created * with the name dst. If an error occurs, the error will * be returned immediately, and remaining files will not be * processed. * *--------------------------------------------------------------------------- */ int TclpObjCopyDirectory(srcPathPtr, destPathPtr, errorPtr) Tcl_Obj *srcPathPtr; Tcl_Obj *destPathPtr; Tcl_Obj **errorPtr; { Tcl_DString ds; Tcl_DString srcString, dstString; int ret; Tcl_WinUtfToTChar(Tcl_FSGetTranslatedStringPath(NULL,srcPathPtr), -1, &srcString); Tcl_WinUtfToTChar(Tcl_FSGetTranslatedStringPath(NULL,destPathPtr), -1, &dstString); ret = TraverseWinTree(TraversalCopy, &srcString, &dstString, &ds); Tcl_DStringFree(&srcString); Tcl_DStringFree(&dstString); if (ret != TCL_OK) { *errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1); Tcl_DStringFree(&ds); Tcl_IncrRefCount(*errorPtr); } return ret; } /* *---------------------------------------------------------------------- * * TclpObjRemoveDirectory, DoRemoveDirectory -- * * Removes directory (and its contents, if the recursive flag is set). * * Results: * If the directory was successfully removed, returns TCL_OK. * Otherwise the return value is TCL_ERROR, errno is set to indicate * the error, and the pathname of the file that caused the error * is stored in errorPtr. Some possible values for errno are: * * EACCES: path directory can't be read and/or written. * EEXIST: path is a non-empty directory. * EINVAL: path is root directory or current directory. * ENOENT: path doesn't exist or is "". * ENOTDIR: path is not a directory. * * EACCES: path is a char device (nul:, com1:, etc.) (95) * EINVAL: path is a char device (nul:, com1:, etc.) (NT) * * Side effects: * Directory removed. If an error occurs, the error will be returned * immediately, and remaining files will not be deleted. * *---------------------------------------------------------------------- */ int TclpObjRemoveDirectory(pathPtr, recursive, errorPtr) Tcl_Obj *pathPtr; int recursive; Tcl_Obj **errorPtr; { Tcl_DString ds; int ret; if (recursive) { /* * In the recursive case, the string rep is used to construct a * Tcl_DString which may be used extensively, so we can't * optimize this case easily. */ Tcl_DString native; Tcl_WinUtfToTChar(Tcl_FSGetTranslatedStringPath(NULL, pathPtr), -1, &native); ret = DoRemoveDirectory(&native, recursive, &ds); Tcl_DStringFree(&native); } else { ret = DoRemoveJustDirectory(Tcl_FSGetNativePath(pathPtr), 0, &ds); } if (ret != TCL_OK) { int len = Tcl_DStringLength(&ds); if (len > 0) { *errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1); Tcl_IncrRefCount(*errorPtr); } Tcl_DStringFree(&ds); } return ret; } static int DoRemoveJustDirectory( CONST TCHAR *nativePath, /* Pathname of directory to be removed * (native). */ int ignoreError, /* If non-zero, don't initialize the * errorPtr under some circumstances * on return. */ Tcl_DString *errorPtr) /* If non-NULL, uninitialized or free * DString filled with UTF-8 name of file * causing error. */ { DWORD attr; if ((*tclWinProcs->removeDirectoryProc)(nativePath) != FALSE) { return TCL_OK; } TclWinConvertError(GetLastError()); /* * Win32s thinks that "" is the same as "." and then reports EACCES * instead of ENOENT. */ if (nativePath == NULL) { Tcl_SetErrno(ENOENT); goto end; } if (tclWinProcs->useWide) { if (((WCHAR *) nativePath)[0] == '\0') { Tcl_SetErrno(ENOENT); return TCL_ERROR; } } else { if (((char *) nativePath)[0] == '\0') { Tcl_SetErrno(ENOENT); return TCL_ERROR; } } if (Tcl_GetErrno() == EACCES) { attr = (*tclWinProcs->getFileAttributesProc)(nativePath); if (attr != 0xffffffff) { if ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0) { /* * Windows 95 reports calling RemoveDirectory on a file as an * EACCES, not an ENOTDIR. */ Tcl_SetErrno(ENOTDIR); goto end; } if (attr & FILE_ATTRIBUTE_READONLY) { attr &= ~FILE_ATTRIBUTE_READONLY; if ((*tclWinProcs->setFileAttributesProc)(nativePath, attr) == FALSE) { goto end; } if ((*tclWinProcs->removeDirectoryProc)(nativePath) != FALSE) { return TCL_OK; } TclWinConvertError(GetLastError()); (*tclWinProcs->setFileAttributesProc)(nativePath, attr | FILE_ATTRIBUTE_READONLY); } /* * Windows 95 and Win32s report removing a non-empty directory * as EACCES, not EEXIST. If the directory is not empty, * change errno so caller knows what's going on. */ if (TclWinGetPlatformId() != VER_PLATFORM_WIN32_NT) { CONST char *path, *find; HANDLE handle; WIN32_FIND_DATAA data; Tcl_DString buffer; int len; path = (CONST char *) nativePath; Tcl_DStringInit(&buffer); len = strlen(path); find = Tcl_DStringAppend(&buffer, path, len); if ((len > 0) && (find[len - 1] != '\\')) { Tcl_DStringAppend(&buffer, "\\", 1); } find = Tcl_DStringAppend(&buffer, "*.*", 3); handle = FindFirstFileA(find, &data); if (handle != INVALID_HANDLE_VALUE) { while (1) { if ((strcmp(data.cFileName, ".") != 0) && (strcmp(data.cFileName, "..") != 0)) { /* * Found something in this directory. */ Tcl_SetErrno(EEXIST); break; } if (FindNextFileA(handle, &data) == FALSE) { break; } } FindClose(handle); } Tcl_DStringFree(&buffer); } } } if (Tcl_GetErrno() == ENOTEMPTY) { /* * The caller depends on EEXIST to signify that the directory is * not empty, not ENOTEMPTY. */ Tcl_SetErrno(EEXIST); } if ((ignoreError != 0) && (Tcl_GetErrno() == EEXIST)) { /* * If we're being recursive, this error may actually * be ok, so we don't want to initialise the errorPtr * yet. */ return TCL_ERROR; } end: if (errorPtr != NULL) { Tcl_WinTCharToUtf(nativePath, -1, errorPtr); } return TCL_ERROR; } static int DoRemoveDirectory( Tcl_DString *pathPtr, /* Pathname of directory to be removed * (native). */ int recursive, /* If non-zero, removes directories that * are nonempty. Otherwise, will only remove * empty directories. */ Tcl_DString *errorPtr) /* If non-NULL, uninitialized or free * DString filled with UTF-8 name of file * causing error. */ { int res = DoRemoveJustDirectory(Tcl_DStringValue(pathPtr), recursive, errorPtr); if ((res == TCL_ERROR) && (recursive != 0) && (Tcl_GetErrno() == EEXIST)) { /* * The directory is nonempty, but the recursive flag has been * specified, so we recursively remove all the files in the directory. */ return TraverseWinTree(TraversalDelete, pathPtr, NULL, errorPtr); } else { return res; } } /* *--------------------------------------------------------------------------- * * TraverseWinTree -- * * Traverse directory tree specified by sourcePtr, calling the function * traverseProc for each file and directory encountered. If destPtr * is non-null, each of name in the sourcePtr directory is appended to * the directory specified by destPtr and passed as the second argument * to traverseProc() . * * Results: * Standard Tcl result. * * Side effects: * None caused by TraverseWinTree, however the user specified * traverseProc() may change state. If an error occurs, the error will * be returned immediately, and remaining files will not be processed. * *--------------------------------------------------------------------------- */ static int TraverseWinTree( TraversalProc *traverseProc,/* Function to call for every file and * directory in source hierarchy. */ Tcl_DString *sourcePtr, /* Pathname of source directory to be * traversed (native). */ Tcl_DString *targetPtr, /* Pathname of directory to traverse in * parallel with source directory (native), * may be NULL. */ Tcl_DString *errorPtr) /* If non-NULL, uninitialized or free * DString filled with UTF-8 name of file * causing error. */ { DWORD sourceAttr; TCHAR *nativeSource, *nativeTarget, *nativeErrfile; int result, found, sourceLen, targetLen, oldSourceLen, oldTargetLen; HANDLE handle; WIN32_FIND_DATAT data; nativeErrfile = NULL; result = TCL_OK; oldTargetLen = 0; /* lint. */ nativeSource = (TCHAR *) Tcl_DStringValue(sourcePtr); nativeTarget = (TCHAR *) (targetPtr == NULL ? NULL : Tcl_DStringValue(targetPtr)); oldSourceLen = Tcl_DStringLength(sourcePtr); sourceAttr = (*tclWinProcs->getFileAttributesProc)(nativeSource); if (sourceAttr == 0xffffffff) { nativeErrfile = nativeSource; goto end; } if ((sourceAttr & FILE_ATTRIBUTE_DIRECTORY) == 0) { /* * Process the regular file */ return (*traverseProc)(nativeSource, nativeTarget, DOTREE_F, errorPtr); } if (tclWinProcs->useWide) { Tcl_DStringAppend(sourcePtr, (char *) L"\\*.*", 4 * sizeof(WCHAR) + 1); Tcl_DStringSetLength(sourcePtr, Tcl_DStringLength(sourcePtr) - 1); } else { Tcl_DStringAppend(sourcePtr, "\\*.*", 4); } nativeSource = (TCHAR *) Tcl_DStringValue(sourcePtr); handle = (*tclWinProcs->findFirstFileProc)(nativeSource, &data); if (handle == INVALID_HANDLE_VALUE) { /* * Can't read directory */ TclWinConvertError(GetLastError()); nativeErrfile = nativeSource; goto end; } nativeSource[oldSourceLen + 1] = '\0'; Tcl_DStringSetLength(sourcePtr, oldSourceLen); result = (*traverseProc)(nativeSource, nativeTarget, DOTREE_PRED, errorPtr); if (result != TCL_OK) { FindClose(handle); return result; } sourceLen = oldSourceLen; if (tclWinProcs->useWide) { sourceLen += sizeof(WCHAR); Tcl_DStringAppend(sourcePtr, (char *) L"\\", sizeof(WCHAR) + 1); Tcl_DStringSetLength(sourcePtr, sourceLen); } else { sourceLen += 1; Tcl_DStringAppend(sourcePtr, "\\", 1); } if (targetPtr != NULL) { oldTargetLen = Tcl_DStringLength(targetPtr); targetLen = oldTargetLen; if (tclWinProcs->useWide) { targetLen += sizeof(WCHAR); Tcl_DStringAppend(targetPtr, (char *) L"\\", sizeof(WCHAR) + 1); Tcl_DStringSetLength(targetPtr, targetLen); } else { targetLen += 1; Tcl_DStringAppend(targetPtr, "\\", 1); } } found = 1; for ( ; found; found = (*tclWinProcs->findNextFileProc)(handle, &data)) { TCHAR *nativeName; int len; if (tclWinProcs->useWide) { WCHAR *wp; wp = data.w.cFileName; if (*wp == '.') { wp++; if (*wp == '.') { wp++; } if (*wp == '\0') { continue; } } nativeName = (TCHAR *) data.w.cFileName; len = Tcl_UniCharLen(data.w.cFileName) * sizeof(WCHAR); } else { if ((strcmp(data.a.cFileName, ".") == 0) || (strcmp(data.a.cFileName, "..") == 0)) { continue; } nativeName = (TCHAR *) data.a.cFileName; len = strlen(data.a.cFileName); } /* * Append name after slash, and recurse on the file. */ Tcl_DStringAppend(sourcePtr, (char *) nativeName, len + 1); Tcl_DStringSetLength(sourcePtr, Tcl_DStringLength(sourcePtr) - 1); if (targetPtr != NULL) { Tcl_DStringAppend(targetPtr, (char *) nativeName, len + 1); Tcl_DStringSetLength(targetPtr, Tcl_DStringLength(targetPtr) - 1); } result = TraverseWinTree(traverseProc, sourcePtr, targetPtr, errorPtr); if (result != TCL_OK) { break; } /* * Remove name after slash. */ Tcl_DStringSetLength(sourcePtr, sourceLen); if (targetPtr != NULL) { Tcl_DStringSetLength(targetPtr, targetLen); } } FindClose(handle); /* * Strip off the trailing slash we added */ Tcl_DStringSetLength(sourcePtr, oldSourceLen + 1); Tcl_DStringSetLength(sourcePtr, oldSourceLen); if (targetPtr != NULL) { Tcl_DStringSetLength(targetPtr, oldTargetLen + 1); Tcl_DStringSetLength(targetPtr, oldTargetLen); } if (result == TCL_OK) { /* * Call traverseProc() on a directory after visiting all the * files in that directory. */ result = (*traverseProc)(Tcl_DStringValue(sourcePtr), (targetPtr == NULL ? NULL : Tcl_DStringValue(targetPtr)), DOTREE_POSTD, errorPtr); } end: if (nativeErrfile != NULL) { TclWinConvertError(GetLastError()); if (errorPtr != NULL) { Tcl_WinTCharToUtf(nativeErrfile, -1, errorPtr); } result = TCL_ERROR; } return result; } /* *---------------------------------------------------------------------- * * TraversalCopy * * Called from TraverseUnixTree in order to execute a recursive * copy of a directory. * * Results: * Standard Tcl result. * * Side effects: * Depending on the value of type, src may be copied to dst. * *---------------------------------------------------------------------- */ static int TraversalCopy( CONST TCHAR *nativeSrc, /* Source pathname to copy. */ CONST TCHAR *nativeDst, /* Destination pathname of copy. */ int type, /* Reason for call - see TraverseWinTree() */ Tcl_DString *errorPtr) /* If non-NULL, initialized DString filled * with UTF-8 name of file causing error. */ { DWORD attr; switch (type) { case DOTREE_F: { if (DoCopyFile(nativeSrc, nativeDst) == TCL_OK) { return TCL_OK; } break; } case DOTREE_PRED: { if (DoCreateDirectory(nativeDst) == TCL_OK) { attr = (*tclWinProcs->getFileAttributesProc)(nativeSrc); if ((*tclWinProcs->setFileAttributesProc)(nativeDst, attr) != FALSE) { return TCL_OK; } TclWinConvertError(GetLastError()); } break; } case DOTREE_POSTD: { return TCL_OK; } } /* * There shouldn't be a problem with src, because we already * checked it to get here. */ if (errorPtr != NULL) { Tcl_WinTCharToUtf(nativeDst, -1, errorPtr); } return TCL_ERROR; } /* *---------------------------------------------------------------------- * * TraversalDelete -- * * Called by procedure TraverseWinTree for every file and * directory that it encounters in a directory hierarchy. This * procedure unlinks files, and removes directories after all the * containing files have been processed. * * Results: * Standard Tcl result. * * Side effects: * Files or directory specified by src will be deleted. If an * error occurs, the windows error is converted to a Posix error * and errno is set accordingly. * *---------------------------------------------------------------------- */ static int TraversalDelete( CONST TCHAR *nativeSrc, /* Source pathname to delete. */ CONST TCHAR *dstPtr, /* Not used. */ int type, /* Reason for call - see TraverseWinTree() */ Tcl_DString *errorPtr) /* If non-NULL, initialized DString filled * with UTF-8 name of file causing error. */ { switch (type) { case DOTREE_F: { if (DoDeleteFile(nativeSrc) == TCL_OK) { return TCL_OK; } break; } case DOTREE_PRED: { return TCL_OK; } case DOTREE_POSTD: { if (DoRemoveJustDirectory(nativeSrc, 0, NULL) == TCL_OK) { return TCL_OK; } break; } } if (errorPtr != NULL) { Tcl_WinTCharToUtf(nativeSrc, -1, errorPtr); } return TCL_ERROR; } /* *---------------------------------------------------------------------- * * StatError -- * * Sets the object result with the appropriate error. * * Results: * None. * * Side effects: * The interp's object result is set with an error message * based on the objIndex, fileName and errno. * *---------------------------------------------------------------------- */ static void StatError( Tcl_Interp *interp, /* The interp that has the error */ Tcl_Obj *fileName) /* The name of the file which caused the * error. */ { TclWinConvertError(GetLastError()); Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "could not read \"", Tcl_GetString(fileName), "\": ", Tcl_PosixError(interp), (char *) NULL); } /* *---------------------------------------------------------------------- * * GetWinFileAttributes -- * * Returns a Tcl_Obj containing the value of a file attribute. * This routine gets the -hidden, -readonly or -system attribute. * * Results: * Standard Tcl result and a Tcl_Obj in attributePtrPtr. The object * will have ref count 0. If the return value is not TCL_OK, * attributePtrPtr is not touched. * * Side effects: * A new object is allocated if the file is valid. * *---------------------------------------------------------------------- */ static int GetWinFileAttributes( Tcl_Interp *interp, /* The interp we are using for errors. */ int objIndex, /* The index of the attribute. */ Tcl_Obj *fileName, /* The name of the file. */ Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */ { DWORD result; CONST TCHAR *nativeName; nativeName = Tcl_FSGetNativePath(fileName); result = (*tclWinProcs->getFileAttributesProc)(nativeName); if (result == 0xffffffff) { StatError(interp, fileName); return TCL_ERROR; } *attributePtrPtr = Tcl_NewBooleanObj((int) (result & attributeArray[objIndex])); return TCL_OK; } /* *---------------------------------------------------------------------- * * ConvertFileNameFormat -- * * Returns a Tcl_Obj containing either the long or short version of the * file name. * * Results: * Standard Tcl result and a Tcl_Obj in attributePtrPtr. The object * will have ref count 0. If the return value is not TCL_OK, * attributePtrPtr is not touched. * * Warning: if you pass this function a drive name like 'c:' it * will actually return the current working directory on that * drive. To avoid this, make sure the drive name ends in a * slash, like this 'c:/'. * * Side effects: * A new object is allocated if the file is valid. * *---------------------------------------------------------------------- */ static int ConvertFileNameFormat( Tcl_Interp *interp, /* The interp we are using for errors. */ int objIndex, /* The index of the attribute. */ Tcl_Obj *fileName, /* The name of the file. */ int longShort, /* 0 to short name, 1 to long name. */ Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */ { int pathc, i; Tcl_Obj *splitPath; int result = TCL_OK; splitPath = Tcl_FSSplitPath(fileName, &pathc); if (splitPath == NULL || pathc == 0) { if (interp != NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "could not read \"", Tcl_GetString(fileName), "\": no such file or directory", (char *) NULL); } result = TCL_ERROR; goto cleanup; } for (i = 0; i < pathc; i++) { Tcl_Obj *elt; char *pathv; int pathLen; Tcl_ListObjIndex(NULL, splitPath, i, &elt); pathv = Tcl_GetStringFromObj(elt, &pathLen); if ((pathv[0] == '/') || ((pathLen == 3) && (pathv[1] == ':')) || (strcmp(pathv, ".") == 0) || (strcmp(pathv, "..") == 0)) { /* * Handle "/", "//machine/export", "c:/", "." or ".." by just * copying the string literally. Uppercase the drive letter, * just because it looks better under Windows to do so. */ simple: /* Here we are modifying the string representation in place */ /* I believe this is legal, since this won't affect any * file representation this thing may have. */ pathv[0] = (char) Tcl_UniCharToUpper(UCHAR(pathv[0])); } else { Tcl_Obj *tempPath; Tcl_DString ds; Tcl_DString dsTemp; TCHAR *nativeName; char *tempString; int tempLen; WIN32_FIND_DATAT data; HANDLE handle; DWORD attr; tempPath = Tcl_FSJoinPath(splitPath, i+1); Tcl_IncrRefCount(tempPath); /* * We'd like to call Tcl_FSGetNativePath(tempPath) * but that is likely to lead to infinite loops */ Tcl_DStringInit(&ds); tempString = Tcl_GetStringFromObj(tempPath,&tempLen); Tcl_WinUtfToTChar(tempString, tempLen, &ds); Tcl_DecrRefCount(tempPath); nativeName = Tcl_DStringValue(&ds); handle = (*tclWinProcs->findFirstFileProc)(nativeName, &data); if (handle == INVALID_HANDLE_VALUE) { /* * FindFirstFile() doesn't like root directories. We * would only get a root directory here if the caller * specified "c:" or "c:." and the current directory on the * drive was the root directory */ attr = (*tclWinProcs->getFileAttributesProc)(nativeName); if ((attr != 0xFFFFFFFF) && (attr & FILE_ATTRIBUTE_DIRECTORY)) { Tcl_DStringFree(&ds); goto simple; } } if (handle == INVALID_HANDLE_VALUE) { Tcl_DStringFree(&ds); if (interp != NULL) { StatError(interp, fileName); } result = TCL_ERROR; goto cleanup; } if (tclWinProcs->useWide) { nativeName = (TCHAR *) data.w.cAlternateFileName; if (longShort) { if (data.w.cFileName[0] != '\0') { nativeName = (TCHAR *) data.w.cFileName; } } else { if (data.w.cAlternateFileName[0] == '\0') { nativeName = (TCHAR *) data.w.cFileName; } } } else { nativeName = (TCHAR *) data.a.cAlternateFileName; if (longShort) { if (data.a.cFileName[0] != '\0') { nativeName = (TCHAR *) data.a.cFileName; } } else { if (data.a.cAlternateFileName[0] == '\0') { nativeName = (TCHAR *) data.a.cFileName; } } } /* * Purify reports a extraneous UMR in Tcl_WinTCharToUtf() trying * to dereference nativeName as a Unicode string. I have proven * to myself that purify is wrong by running the following * example when nativeName == data.w.cAlternateFileName and * noting that purify doesn't complain about the first line, * but does complain about the second. * * fprintf(stderr, "%d\n", data.w.cAlternateFileName[0]); * fprintf(stderr, "%d\n", ((WCHAR *) nativeName)[0]); */ Tcl_DStringInit(&dsTemp); Tcl_WinTCharToUtf(nativeName, -1, &dsTemp); /* Deal with issues of tildes being absolute */ if (Tcl_DStringValue(&dsTemp)[0] == '~') { tempPath = Tcl_NewStringObj("./",2); Tcl_AppendToObj(tempPath, Tcl_DStringValue(&dsTemp), Tcl_DStringLength(&dsTemp)); } else { tempPath = Tcl_NewStringObj(Tcl_DStringValue(&dsTemp), Tcl_DStringLength(&dsTemp)); } Tcl_ListObjReplace(NULL, splitPath, i, 1, 1, &tempPath); Tcl_DStringFree(&ds); Tcl_DStringFree(&dsTemp); FindClose(handle); } } *attributePtrPtr = Tcl_FSJoinPath(splitPath, -1); cleanup: if (splitPath != NULL) { Tcl_DecrRefCount(splitPath); } return result; } /* *---------------------------------------------------------------------- * * GetWinFileLongName -- * * Returns a Tcl_Obj containing the long version of the file * name. * * Results: * Standard Tcl result and a Tcl_Obj in attributePtrPtr. The object * will have ref count 0. If the return value is not TCL_OK, * attributePtrPtr is not touched. * * Side effects: * A new object is allocated if the file is valid. * *---------------------------------------------------------------------- */ static int GetWinFileLongName( Tcl_Interp *interp, /* The interp we are using for errors. */ int objIndex, /* The index of the attribute. */ Tcl_Obj *fileName, /* The name of the file. */ Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */ { return ConvertFileNameFormat(interp, objIndex, fileName, 1, attributePtrPtr); } /* *---------------------------------------------------------------------- * * GetWinFileShortName -- * * Returns a Tcl_Obj containing the short version of the file * name. * * Results: * Standard Tcl result and a Tcl_Obj in attributePtrPtr. The object * will have ref count 0. If the return value is not TCL_OK, * attributePtrPtr is not touched. * * Side effects: * A new object is allocated if the file is valid. * *---------------------------------------------------------------------- */ static int GetWinFileShortName( Tcl_Interp *interp, /* The interp we are using for errors. */ int objIndex, /* The index of the attribute. */ Tcl_Obj *fileName, /* The name of the file. */ Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */ { return ConvertFileNameFormat(interp, objIndex, fileName, 0, attributePtrPtr); } /* *---------------------------------------------------------------------- * * SetWinFileAttributes -- * * Set the file attributes to the value given by attributePtr. * This routine sets the -hidden, -readonly, or -system attributes. * * Results: * Standard TCL error. * * Side effects: * The file's attribute is set. * *---------------------------------------------------------------------- */ static int SetWinFileAttributes( Tcl_Interp *interp, /* The interp we are using for errors. */ int objIndex, /* The index of the attribute. */ Tcl_Obj *fileName, /* The name of the file. */ Tcl_Obj *attributePtr) /* The new value of the attribute. */ { DWORD fileAttributes; int yesNo; int result; CONST TCHAR *nativeName; nativeName = Tcl_FSGetNativePath(fileName); fileAttributes = (*tclWinProcs->getFileAttributesProc)(nativeName); if (fileAttributes == 0xffffffff) { StatError(interp, fileName); return TCL_ERROR; } result = Tcl_GetBooleanFromObj(interp, attributePtr, &yesNo); if (result != TCL_OK) { return result; } if (yesNo) { fileAttributes |= (attributeArray[objIndex]); } else { fileAttributes &= ~(attributeArray[objIndex]); } if (!(*tclWinProcs->setFileAttributesProc)(nativeName, fileAttributes)) { StatError(interp, fileName); return TCL_ERROR; } return result; } /* *---------------------------------------------------------------------- * * SetWinFileLongName -- * * The attribute in question is a readonly attribute and cannot * be set. * * Results: * TCL_ERROR * * Side effects: * The object result is set to a pertinent error message. * *---------------------------------------------------------------------- */ static int CannotSetAttribute( Tcl_Interp *interp, /* The interp we are using for errors. */ int objIndex, /* The index of the attribute. */ Tcl_Obj *fileName, /* The name of the file. */ Tcl_Obj *attributePtr) /* The new value of the attribute. */ { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "cannot set attribute \"", tclpFileAttrStrings[objIndex], "\" for file \"", Tcl_GetString(fileName), "\": attribute is readonly", (char *) NULL); return TCL_ERROR; } /* *--------------------------------------------------------------------------- * * TclpObjListVolumes -- * * Lists the currently mounted volumes * * Results: * The list of volumes. * * Side effects: * None * *--------------------------------------------------------------------------- */ Tcl_Obj* TclpObjListVolumes(void) { Tcl_Obj *resultPtr, *elemPtr; char buf[40 * 4]; /* There couldn't be more than 30 drives??? */ int i; char *p; resultPtr = Tcl_NewObj(); /* * On Win32s: * GetLogicalDriveStrings() isn't implemented. * GetLogicalDrives() returns incorrect information. */ if (GetLogicalDriveStringsA(sizeof(buf), buf) == 0) { /* * GetVolumeInformation() will detects all drives, but causes * chattering on empty floppy drives. We only do this if * GetLogicalDriveStrings() didn't work. It has also been reported * that on some laptops it takes a while for GetVolumeInformation() * to return when pinging an empty floppy drive, another reason to * try to avoid calling it. */ buf[1] = ':'; buf[2] = '/'; buf[3] = '\0'; for (i = 0; i < 26; i++) { buf[0] = (char) ('a' + i); if (GetVolumeInformationA(buf, NULL, 0, NULL, NULL, NULL, NULL, 0) || (GetLastError() == ERROR_NOT_READY)) { elemPtr = Tcl_NewStringObj(buf, -1); Tcl_ListObjAppendElement(NULL, resultPtr, elemPtr); } } } else { for (p = buf; *p != '\0'; p += 4) { p[2] = '/'; elemPtr = Tcl_NewStringObj(p, -1); Tcl_ListObjAppendElement(NULL, resultPtr, elemPtr); } } Tcl_IncrRefCount(resultPtr); return resultPtr; } /* * This function could be thoroughly tested and then substituted in * below to speed up file normalization on Windows NT/2000/XP */ #if 0 void WinGetLongPathName(CONST TCHAR* origPath, Tcl_DString *dsPtr); #define IsDirSep(a) (a == '/' || a == '\\') void WinGetLongPathName(CONST TCHAR* pszOriginal, Tcl_DString *dsPtr) { TCHAR szResult[_MAX_PATH * 2 + 1]; TCHAR* pchResult = szResult; const TCHAR* pchScan = pszOriginal; WIN32_FIND_DATA wfd; /* Do Drive Letter check... */ if (pchScan[0] && pchScan[1] == ':') { /* Copy drive letter and colon, ensuring drive is upper case. */ char drive = *pchScan++; *pchResult++ = (drive < 97 ? drive : drive - 32); *pchResult++ = *pchScan++; } else if (IsDirSep(pchScan[0]) && IsDirSep(pchScan[1])) { /* Copy \\ and machine name. */ *pchResult++ = *pchScan++; *pchResult++ = *pchScan++; while (*pchScan && !IsDirSep(*pchScan)) { *pchResult++ = *pchScan++; } /* * Note that the code below will fail since FindFirstFile * on a UNC path seems not to work on directory name searches? */ } if (!IsDirSep(*pchScan)) { while ((*pchResult++ = *pchScan++) != '\0'); } else { /* Now loop through directories and files... */ while (IsDirSep(*pchScan)) { char* pchReplace; const TCHAR* pchEnd; HANDLE hFind; *pchResult++ = *pchScan++; pchReplace = pchResult; pchEnd = pchScan; while (*pchEnd && !IsDirSep(*pchEnd)) { *pchResult++ = *pchEnd++; } *pchResult = '\0'; /* Now run this through FindFirstFile... */ hFind = FindFirstFileA(szResult, &wfd); if (hFind != INVALID_HANDLE_VALUE) { FindClose(hFind); strcpy(pchReplace, wfd.cFileName); pchResult = pchReplace + strlen(pchReplace); } else { /* Copy rest of input path & end. */ strcat(pchResult, pchEnd); break; } pchScan = pchEnd; } } /* Copy it over */ Tcl_ExternalToUtfDString(NULL, szResult, -1, dsPtr); } #endif /* *--------------------------------------------------------------------------- * * TclpObjNormalizePath -- * * This function scans through a path specification and replaces * it, in place, with a normalized version. On windows this * means using the 'longname'. * * Results: * The new 'nextCheckpoint' value, giving as far as we could * understand in the path. * * Side effects: * The pathPtr string, which must contain a valid path, is * possibly modified in place. * *--------------------------------------------------------------------------- */ int TclpObjNormalizePath(interp, pathPtr, nextCheckpoint) Tcl_Interp *interp; Tcl_Obj *pathPtr; int nextCheckpoint; { char *lastValidPathEnd = NULL; Tcl_DString ds; int pathLen; char *path = Tcl_GetStringFromObj(pathPtr, &pathLen); if (TclWinGetPlatformId() == VER_PLATFORM_WIN32_WINDOWS) { Tcl_DString eDs; char *nativePath; int nativeLen; Tcl_UtfToExternalDString(NULL, path, -1, &ds); nativePath = Tcl_DStringValue(&ds); nativeLen = Tcl_DStringLength(&ds); /* We're on Windows 95/98 */ lastValidPathEnd = nativePath + Tcl_DStringLength(&ds); while (1) { DWORD res = GetShortPathNameA(nativePath, nativePath, 1+nativeLen); if (res != 0) { /* We found an ok path */ break; } /* Undo the null-termination we put in before */ if (lastValidPathEnd != (nativePath + nativeLen)) { *lastValidPathEnd = '/'; } /* * The path doesn't exist. Back up the path, one component * (directory/file) at a time, until one does exist. */ while (1) { char cur; lastValidPathEnd--; if (lastValidPathEnd == nativePath) { /* We didn't accept any of the path */ Tcl_DStringFree(&ds); return nextCheckpoint; } cur = *(lastValidPathEnd); if (cur == '/' || cur == '\\') { /* Reached directory separator */ break; } } /* Temporarily terminate the string */ *lastValidPathEnd = '\0'; } /* * If we get here, we found a valid path, which we've converted to * short form, and the valid string ends at or before 'lastValidPathEnd' * and the invalid string starts at 'lastValidPathEnd'. */ /* Copy over the valid part of the path and find its length */ Tcl_ExternalToUtfDString(NULL, nativePath, -1, &eDs); path = Tcl_DStringValue(&eDs); if (path[1] == ':') { if (path[0] >= 'a' && path[0] <= 'z') { /* Make uppercase */ path[0] -= 32; } } nextCheckpoint = Tcl_DStringLength(&eDs); Tcl_SetStringObj(pathPtr, path, Tcl_DStringLength(&eDs)); Tcl_DStringFree(&eDs); if (lastValidPathEnd != (nativePath + nativeLen)) { CONST char *tmp; *lastValidPathEnd = '/'; /* Now copy over the invalid (i.e. non-existent) part of the path */ tmp = Tcl_ExternalToUtfDString(NULL, lastValidPathEnd, -1, &eDs); Tcl_AppendToObj(pathPtr, tmp, Tcl_DStringLength(&eDs)); Tcl_DStringFree(&eDs); } Tcl_DStringFree(&ds); } else { /* We're on WinNT or 2000 or XP */ CONST char *nativePath; #if 0 /* * We don't use this simpler version, because the speed * increase does not seem significant at present and the version * below is thoroughly debugged. */ int nativeLen; Tcl_DString eDs; nativePath = Tcl_UtfToExternalDString(NULL, path, -1, &ds); nativeLen = Tcl_DStringLength(&ds); WinGetLongPathName(nativePath, &eDs); /* * We need to add code here to calculate the new value of * 'nextCheckpoint' -- i.e. the longest part of the path * which is an existing file. */ Tcl_SetStringObj(pathPtr, Tcl_DStringValue(&eDs), Tcl_DStringLength(&eDs)); Tcl_DStringFree(&eDs); Tcl_DStringFree(&ds); #else char *currentPathEndPosition; WIN32_FILE_ATTRIBUTE_DATA data; nativePath = Tcl_WinUtfToTChar(path, -1, &ds); if ((*tclWinProcs->getFileAttributesExProc)(nativePath, GetFileExInfoStandard, &data) == TRUE) { currentPathEndPosition = path + pathLen; nextCheckpoint = pathLen; lastValidPathEnd = currentPathEndPosition; Tcl_DStringFree(&ds); } else { Tcl_DStringFree(&ds); currentPathEndPosition = path + nextCheckpoint; while (1) { char cur = *currentPathEndPosition; if ((cur == '/' || cur == 0) && (path != currentPathEndPosition)) { /* Reached directory separator, or end of string */ nativePath = Tcl_WinUtfToTChar(path, currentPathEndPosition - path, &ds); if ((*tclWinProcs->getFileAttributesExProc)(nativePath, GetFileExInfoStandard, &data) != TRUE) { /* File doesn't exist */ Tcl_DStringFree(&ds); break; } Tcl_DStringFree(&ds); lastValidPathEnd = currentPathEndPosition; /* File does exist */ if (cur == 0) { break; } } currentPathEndPosition++; } nextCheckpoint = currentPathEndPosition - path; } if (lastValidPathEnd != NULL) { Tcl_Obj *tmpPathPtr; /* * The leading end of the path description was acceptable to * us. We therefore convert it to its long form, and return * that. */ Tcl_Obj* objPtr = NULL; int endOfString; int useLength = lastValidPathEnd - path; if (*lastValidPathEnd == 0) { tmpPathPtr = Tcl_NewStringObj(path, useLength); endOfString = 1; } else { tmpPathPtr = Tcl_NewStringObj(path, useLength + 1); endOfString = 0; } /* * If this returns an error, we have a strange situation; the * file exists, but we can't get its long name. We will have * to assume the name we have is ok. */ Tcl_IncrRefCount(tmpPathPtr); if (ConvertFileNameFormat(interp, 0, tmpPathPtr, 1, &objPtr) == TCL_OK) { int len; (void) Tcl_GetStringFromObj(objPtr,&len); if (!endOfString) { /* Be nice and fix the string before we clear it */ Tcl_AppendToObj(objPtr, lastValidPathEnd, -1); } nextCheckpoint += (len - useLength); path = Tcl_GetStringFromObj(objPtr,&len); Tcl_SetStringObj(pathPtr,path, len); Tcl_DecrRefCount(objPtr); } Tcl_DecrRefCount(tmpPathPtr); } #endif } return nextCheckpoint; }