diff options
author | William Joye <wjoye@cfa.harvard.edu> | 2017-09-22 18:51:12 (GMT) |
---|---|---|
committer | William Joye <wjoye@cfa.harvard.edu> | 2017-09-22 18:51:12 (GMT) |
commit | 3fa8e6dc88e8041b6cb88d1b1e9c05676d3346b7 (patch) | |
tree | 69afbb41089c8358615879f7cd3c4cf7997f4c7e /tcl8.6/win/tclWinFCmd.c | |
parent | a0e17db23c0fd7c771c0afce8cce350c98f90b02 (diff) | |
download | blt-3fa8e6dc88e8041b6cb88d1b1e9c05676d3346b7.zip blt-3fa8e6dc88e8041b6cb88d1b1e9c05676d3346b7.tar.gz blt-3fa8e6dc88e8041b6cb88d1b1e9c05676d3346b7.tar.bz2 |
update to tcl/tk 8.6.7
Diffstat (limited to 'tcl8.6/win/tclWinFCmd.c')
-rw-r--r-- | tcl8.6/win/tclWinFCmd.c | 1968 |
1 files changed, 0 insertions, 1968 deletions
diff --git a/tcl8.6/win/tclWinFCmd.c b/tcl8.6/win/tclWinFCmd.c deleted file mode 100644 index 52ea8c6..0000000 --- a/tcl8.6/win/tclWinFCmd.c +++ /dev/null @@ -1,1968 +0,0 @@ -/* - * 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. - */ - -#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 */ -#define DOTREE_LINK 4 /* symbolic link */ - -/* - * Callbacks for file attributes code. - */ - -static int GetWinFileAttributes(Tcl_Interp *interp, int objIndex, - Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr); -static int GetWinFileLongName(Tcl_Interp *interp, int objIndex, - Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr); -static int GetWinFileShortName(Tcl_Interp *interp, int objIndex, - Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr); -static int SetWinFileAttributes(Tcl_Interp *interp, int objIndex, - Tcl_Obj *fileName, Tcl_Obj *attributePtr); -static int CannotSetAttribute(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 const int attributeArray[] = {FILE_ATTRIBUTE_ARCHIVE, FILE_ATTRIBUTE_HIDDEN, - 0, FILE_ATTRIBUTE_READONLY, 0, FILE_ATTRIBUTE_SYSTEM}; - - -const char *const 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 functions 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 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( - 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). */ -{ -#if defined(HAVE_NO_SEH) && !defined(_WIN64) - TCLEXCEPTION_REGISTRATION registration; -#endif - DWORD srcAttr, dstAttr; - int retval = -1; - - /* - * The MoveFile API acts differently under Win95/98 and NT WRT NULL and - * "". Avoid passing these values. - */ - - if (nativeSrc == NULL || nativeSrc[0] == '\0' || - nativeDst == NULL || nativeDst[0] == '\0') { - Tcl_SetErrno(ENOENT); - return TCL_ERROR; - } - - /* - * The MoveFile API would throw an exception under NT if one of the - * arguments is a char block device. - */ - -#if defined(HAVE_NO_SEH) && !defined(_WIN64) - /* - * Don't have SEH available, do things the hard way. Note that this needs - * to be one block of asm, to avoid stack imbalance; also, it is illegal - * for one asm block to contain a jump to another. - */ - - __asm__ __volatile__ ( - /* - * Pick up params before messing with the stack. - */ - - "movl %[nativeDst], %%ebx" "\n\t" - "movl %[nativeSrc], %%ecx" "\n\t" - - /* - * Construct an TCLEXCEPTION_REGISTRATION to protect the call to - * MoveFile. - */ - - "leal %[registration], %%edx" "\n\t" - "movl %%fs:0, %%eax" "\n\t" - "movl %%eax, 0x0(%%edx)" "\n\t" /* link */ - "leal 1f, %%eax" "\n\t" - "movl %%eax, 0x4(%%edx)" "\n\t" /* handler */ - "movl %%ebp, 0x8(%%edx)" "\n\t" /* ebp */ - "movl %%esp, 0xc(%%edx)" "\n\t" /* esp */ - "movl $0, 0x10(%%edx)" "\n\t" /* status */ - - /* - * Link the TCLEXCEPTION_REGISTRATION on the chain. - */ - - "movl %%edx, %%fs:0" "\n\t" - - /* - * Call MoveFile(nativeSrc, nativeDst) - */ - - "pushl %%ebx" "\n\t" - "pushl %%ecx" "\n\t" - "movl %[moveFile], %%eax" "\n\t" - "call *%%eax" "\n\t" - - /* - * Come here on normal exit. Recover the TCLEXCEPTION_REGISTRATION and - * put the status return from MoveFile into it. - */ - - "movl %%fs:0, %%edx" "\n\t" - "movl %%eax, 0x10(%%edx)" "\n\t" - "jmp 2f" "\n" - - /* - * Come here on an exception. Recover the TCLEXCEPTION_REGISTRATION - */ - - "1:" "\t" - "movl %%fs:0, %%edx" "\n\t" - "movl 0x8(%%edx), %%edx" "\n\t" - - /* - * Come here however we exited. Restore context from the - * TCLEXCEPTION_REGISTRATION in case the stack is unbalanced. - */ - - "2:" "\t" - "movl 0xc(%%edx), %%esp" "\n\t" - "movl 0x8(%%edx), %%ebp" "\n\t" - "movl 0x0(%%edx), %%eax" "\n\t" - "movl %%eax, %%fs:0" "\n\t" - - : - /* No outputs */ - : - [registration] "m" (registration), - [nativeDst] "m" (nativeDst), - [nativeSrc] "m" (nativeSrc), - [moveFile] "r" (MoveFile) - : - "%eax", "%ebx", "%ecx", "%edx", "memory" - ); - if (registration.status != FALSE) { - retval = TCL_OK; - } -#else -#ifndef HAVE_NO_SEH - __try { -#endif - if ((*MoveFile)(nativeSrc, nativeDst) != FALSE) { - retval = TCL_OK; - } -#ifndef HAVE_NO_SEH - } __except (EXCEPTION_EXECUTE_HANDLER) {} -#endif -#endif - - if (retval != -1) { - return retval; - } - - TclWinConvertError(GetLastError()); - - srcAttr = GetFileAttributes(nativeSrc); - dstAttr = GetFileAttributes(nativeDst); - if (srcAttr == 0xffffffff) { - if (GetFullPathName(nativeSrc, 0, NULL, - NULL) >= MAX_PATH) { - errno = ENAMETOOLONG; - return TCL_ERROR; - } - srcAttr = 0; - } - if (dstAttr == 0xffffffff) { - if (GetFullPathName(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; - const char **srcArgv, **dstArgv; - int size, srcArgc, dstArgc; - TCHAR nativeSrcPath[MAX_PATH]; - TCHAR nativeDstPath[MAX_PATH]; - Tcl_DString srcString, dstString; - const char *src, *dst; - - size = GetFullPathName(nativeSrc, MAX_PATH, - nativeSrcPath, &nativeSrcRest); - if ((size == 0) || (size > MAX_PATH)) { - return TCL_ERROR; - } - size = GetFullPathName(nativeDst, MAX_PATH, - nativeDstPath, &nativeDstRest); - if ((size == 0) || (size > MAX_PATH)) { - return TCL_ERROR; - } - CharLower(nativeSrcPath); - CharLower(nativeDstPath); - - src = Tcl_WinTCharToUtf(nativeSrcPath, -1, &srcString); - dst = Tcl_WinTCharToUtf(nativeDstPath, -1, &dstString); - - /* - * Check whether the destination path is actually inside the - * source path. This is true if the prefix matches, and the next - * character is either end-of-string or a directory separator - */ - - if ((strncmp(src, dst, (size_t) Tcl_DStringLength(&srcString))==0) - && (dst[Tcl_DStringLength(&srcString)] == '\\' - || dst[Tcl_DStringLength(&srcString)] == '/' - || dst[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(srcArgv); - ckfree(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 (MoveFile(nativeSrc, - nativeDst) != FALSE) { - return TCL_OK; - } - - /* - * Some new error has occurred. Don't know what it could - * be, but report this one. - */ - - TclWinConvertError(GetLastError()); - CreateDirectory(nativeDst, NULL); - SetFileAttributes(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; - TCHAR tempBuf[MAX_PATH]; - - size = GetFullPathName(nativeDst, MAX_PATH, - tempBuf, &nativeRest); - if ((size == 0) || (size > MAX_PATH) || (nativeRest == NULL)) { - return TCL_ERROR; - } - nativeTmp = (TCHAR *) tempBuf; - nativeRest[0] = L'\0'; - - result = TCL_ERROR; - nativePrefix = (TCHAR *) L"tclr"; - if (GetTempFileName(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 = tempBuf; - DeleteFile(nativeTmp); - if (MoveFile(nativeDst, nativeTmp) != FALSE) { - if (MoveFile(nativeSrc, nativeDst) != FALSE) { - SetFileAttributes(nativeTmp, FILE_ATTRIBUTE_NORMAL); - DeleteFile(nativeTmp); - return TCL_OK; - } else { - DeleteFile(nativeDst); - MoveFile(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( - 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). */ -{ -#if defined(HAVE_NO_SEH) && !defined(_WIN64) - TCLEXCEPTION_REGISTRATION registration; -#endif - int retval = -1; - - /* - * The CopyFile API acts differently under Win95/98 and NT WRT NULL and - * "". Avoid passing these values. - */ - - if (nativeSrc == NULL || nativeSrc[0] == '\0' || - nativeDst == NULL || nativeDst[0] == '\0') { - Tcl_SetErrno(ENOENT); - return TCL_ERROR; - } - - /* - * The CopyFile API would throw an exception under NT if one of the - * arguments is a char block device. - */ - -#if defined(HAVE_NO_SEH) && !defined(_WIN64) - /* - * Don't have SEH available, do things the hard way. Note that this needs - * to be one block of asm, to avoid stack imbalance; also, it is illegal - * for one asm block to contain a jump to another. - */ - - __asm__ __volatile__ ( - - /* - * Pick up parameters before messing with the stack - */ - - "movl %[nativeDst], %%ebx" "\n\t" - "movl %[nativeSrc], %%ecx" "\n\t" - - /* - * Construct an TCLEXCEPTION_REGISTRATION to protect the call to - * CopyFile. - */ - - "leal %[registration], %%edx" "\n\t" - "movl %%fs:0, %%eax" "\n\t" - "movl %%eax, 0x0(%%edx)" "\n\t" /* link */ - "leal 1f, %%eax" "\n\t" - "movl %%eax, 0x4(%%edx)" "\n\t" /* handler */ - "movl %%ebp, 0x8(%%edx)" "\n\t" /* ebp */ - "movl %%esp, 0xc(%%edx)" "\n\t" /* esp */ - "movl $0, 0x10(%%edx)" "\n\t" /* status */ - - /* - * Link the TCLEXCEPTION_REGISTRATION on the chain. - */ - - "movl %%edx, %%fs:0" "\n\t" - - /* - * Call CopyFile(nativeSrc, nativeDst, 0) - */ - - "movl %[copyFile], %%eax" "\n\t" - "pushl $0" "\n\t" - "pushl %%ebx" "\n\t" - "pushl %%ecx" "\n\t" - "call *%%eax" "\n\t" - - /* - * Come here on normal exit. Recover the TCLEXCEPTION_REGISTRATION and - * put the status return from CopyFile into it. - */ - - "movl %%fs:0, %%edx" "\n\t" - "movl %%eax, 0x10(%%edx)" "\n\t" - "jmp 2f" "\n" - - /* - * Come here on an exception. Recover the TCLEXCEPTION_REGISTRATION - */ - - "1:" "\t" - "movl %%fs:0, %%edx" "\n\t" - "movl 0x8(%%edx), %%edx" "\n\t" - - /* - * Come here however we exited. Restore context from the - * TCLEXCEPTION_REGISTRATION in case the stack is unbalanced. - */ - - "2:" "\t" - "movl 0xc(%%edx), %%esp" "\n\t" - "movl 0x8(%%edx), %%ebp" "\n\t" - "movl 0x0(%%edx), %%eax" "\n\t" - "movl %%eax, %%fs:0" "\n\t" - - : - /* No outputs */ - : - [registration] "m" (registration), - [nativeDst] "m" (nativeDst), - [nativeSrc] "m" (nativeSrc), - [copyFile] "r" (CopyFile) - : - "%eax", "%ebx", "%ecx", "%edx", "memory" - ); - if (registration.status != FALSE) { - retval = TCL_OK; - } -#else -#ifndef HAVE_NO_SEH - __try { -#endif - if (CopyFile(nativeSrc, nativeDst, 0) != FALSE) { - retval = TCL_OK; - } -#ifndef HAVE_NO_SEH - } __except (EXCEPTION_EXECUTE_HANDLER) {} -#endif -#endif - - if (retval != -1) { - return retval; - } - - TclWinConvertError(GetLastError()); - if (Tcl_GetErrno() == EBADF) { - Tcl_SetErrno(EACCES); - return TCL_ERROR; - } - if (Tcl_GetErrno() == EACCES) { - DWORD srcAttr, dstAttr; - - srcAttr = GetFileAttributes(nativeSrc); - dstAttr = GetFileAttributes(nativeDst); - if (srcAttr != 0xffffffff) { - if (dstAttr == 0xffffffff) { - dstAttr = 0; - } - if ((srcAttr & FILE_ATTRIBUTE_DIRECTORY) || - (dstAttr & FILE_ATTRIBUTE_DIRECTORY)) { - if (srcAttr & FILE_ATTRIBUTE_REPARSE_POINT) { - /* Source is a symbolic link -- copy it */ - if (TclWinSymLinkCopyDirectory(nativeSrc, nativeDst)==0) { - return TCL_OK; - } - } - Tcl_SetErrno(EISDIR); - } - if (dstAttr & FILE_ATTRIBUTE_READONLY) { - SetFileAttributes(nativeDst, - dstAttr & ~((DWORD)FILE_ATTRIBUTE_READONLY)); - if (CopyFile(nativeSrc, nativeDst, - 0) != FALSE) { - return TCL_OK; - } - - /* - * Still can't copy onto dst. Return that error, and restore - * attributes of dst. - */ - - TclWinConvertError(GetLastError()); - SetFileAttributes(nativeDst, dstAttr); - } - } - } - return TCL_ERROR; -} - -/* - *--------------------------------------------------------------------------- - * - * TclpObjDeleteFile, TclpDeleteFile -- - * - * 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( - Tcl_Obj *pathPtr) -{ - return TclpDeleteFile(Tcl_FSGetNativePath(pathPtr)); -} - -int -TclpDeleteFile( - const void *nativePath) /* Pathname of file to be removed (native). */ -{ - DWORD attr; - const TCHAR *path = nativePath; - - /* - * The DeleteFile API acts differently under Win95/98 and NT WRT NULL and - * "". Avoid passing these values. - */ - - if (path == NULL || path[0] == '\0') { - Tcl_SetErrno(ENOENT); - return TCL_ERROR; - } - - if (DeleteFile(path) != FALSE) { - return TCL_OK; - } - TclWinConvertError(GetLastError()); - - if (Tcl_GetErrno() == EACCES) { - attr = GetFileAttributes(path); - if (attr != 0xffffffff) { - if (attr & FILE_ATTRIBUTE_DIRECTORY) { - if (attr & FILE_ATTRIBUTE_REPARSE_POINT) { - /* - * It is a symbolic link - remove it. - */ - if (TclWinSymLinkDelete(path, 0) == 0) { - return TCL_OK; - } - } - - /* - * If we fall through here, it is a directory. - * - * Windows NT reports removing a directory as EACCES instead - * of EISDIR. - */ - - Tcl_SetErrno(EISDIR); - } else if (attr & FILE_ATTRIBUTE_READONLY) { - int res = SetFileAttributes(path, - attr & ~((DWORD) FILE_ATTRIBUTE_READONLY)); - - if ((res != 0) && - (DeleteFile(path) != FALSE)) { - return TCL_OK; - } - TclWinConvertError(GetLastError()); - if (res != 0) { - SetFileAttributes(path, attr); - } - } - } - } else if (Tcl_GetErrno() == ENOENT) { - attr = GetFileAttributes(path); - 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( - Tcl_Obj *pathPtr) -{ - return DoCreateDirectory(Tcl_FSGetNativePath(pathPtr)); -} - -static int -DoCreateDirectory( - const TCHAR *nativePath) /* Pathname of directory to create (native). */ -{ - if (CreateDirectory(nativePath, NULL) == 0) { - DWORD 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( - Tcl_Obj *srcPathPtr, - Tcl_Obj *destPathPtr, - Tcl_Obj **errorPtr) -{ - Tcl_DString ds; - Tcl_DString srcString, dstString; - Tcl_Obj *normSrcPtr, *normDestPtr; - int ret; - - normSrcPtr = Tcl_FSGetNormalizedPath(NULL,srcPathPtr); - normDestPtr = Tcl_FSGetNormalizedPath(NULL,destPathPtr); - if ((normSrcPtr == NULL) || (normDestPtr == NULL)) { - return TCL_ERROR; - } - - Tcl_WinUtfToTChar(Tcl_GetString(normSrcPtr), -1, &srcString); - Tcl_WinUtfToTChar(Tcl_GetString(normDestPtr), -1, &dstString); - - ret = TraverseWinTree(TraversalCopy, &srcString, &dstString, &ds); - - Tcl_DStringFree(&srcString); - Tcl_DStringFree(&dstString); - - if (ret != TCL_OK) { - if (!strcmp(Tcl_DStringValue(&ds), TclGetString(normSrcPtr))) { - *errorPtr = srcPathPtr; - } else if (!strcmp(Tcl_DStringValue(&ds), TclGetString(normDestPtr))) { - *errorPtr = destPathPtr; - } else { - *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( - Tcl_Obj *pathPtr, - int recursive, - Tcl_Obj **errorPtr) -{ - Tcl_DString ds; - Tcl_Obj *normPtr = NULL; - 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; - normPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr); - if (normPtr == NULL) { - return TCL_ERROR; - } - Tcl_WinUtfToTChar(Tcl_GetString(normPtr), -1, &native); - ret = DoRemoveDirectory(&native, recursive, &ds); - Tcl_DStringFree(&native); - } else { - ret = DoRemoveJustDirectory(Tcl_FSGetNativePath(pathPtr), 0, &ds); - } - - if (ret != TCL_OK) { - if (Tcl_DStringLength(&ds) > 0) { - if (normPtr != NULL && - !strcmp(Tcl_DStringValue(&ds), TclGetString(normPtr))) { - *errorPtr = pathPtr; - } else { - *errorPtr = TclDStringToObj(&ds); - } - 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; - - /* - * The RemoveDirectory API acts differently under Win95/98 and NT WRT NULL - * and "". Avoid passing these values. - */ - - if (nativePath == NULL || nativePath[0] == '\0') { - Tcl_SetErrno(ENOENT); - goto end; - } - - attr = GetFileAttributes(nativePath); - - if (attr & FILE_ATTRIBUTE_REPARSE_POINT) { - /* - * It is a symbolic link - remove it. - */ - if (TclWinSymLinkDelete(nativePath, 0) == 0) { - return TCL_OK; - } - } else { - /* - * Ordinary directory. - */ - - if (RemoveDirectory(nativePath) != FALSE) { - return TCL_OK; - } - } - - TclWinConvertError(GetLastError()); - - if (Tcl_GetErrno() == EACCES) { - attr = GetFileAttributes(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_REPARSE_POINT) { - /* - * It is a symbolic link - remove it. - */ - - if (TclWinSymLinkDelete(nativePath, 1) != 0) { - goto end; - } - } - - if (attr & FILE_ATTRIBUTE_READONLY) { - attr &= ~FILE_ATTRIBUTE_READONLY; - if (SetFileAttributes(nativePath, - attr) == FALSE) { - goto end; - } - if (RemoveDirectory(nativePath) != FALSE) { - return TCL_OK; - } - TclWinConvertError(GetLastError()); - SetFileAttributes(nativePath, - attr | FILE_ATTRIBUTE_READONLY); - } - } - } - - 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) { - char *p; - Tcl_WinTCharToUtf(nativePath, -1, errorPtr); - p = Tcl_DStringValue(errorPtr); - for (; *p; ++p) { - if (*p == '\\') *p = '/'; - } - } - 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((const TCHAR *)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 = 0, oldSourceLen, oldTargetLen; - HANDLE handle; - WIN32_FIND_DATA 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 = GetFileAttributes(nativeSource); - if (sourceAttr == 0xffffffff) { - nativeErrfile = nativeSource; - goto end; - } - - if (sourceAttr & FILE_ATTRIBUTE_REPARSE_POINT) { - /* - * Process the symbolic link - */ - - return traverseProc(nativeSource, nativeTarget, DOTREE_LINK, - errorPtr); - } - - if ((sourceAttr & FILE_ATTRIBUTE_DIRECTORY) == 0) { - /* - * Process the regular file - */ - - return traverseProc(nativeSource, nativeTarget, DOTREE_F, errorPtr); - } - - Tcl_DStringAppend(sourcePtr, (char *) TEXT("\\*.*"), 4 * sizeof(TCHAR) + 1); - Tcl_DStringSetLength(sourcePtr, Tcl_DStringLength(sourcePtr) - 1); - - nativeSource = (TCHAR *) Tcl_DStringValue(sourcePtr); - handle = FindFirstFile(nativeSource, &data); - if (handle == INVALID_HANDLE_VALUE) { - /* - * Can't read directory. - */ - - TclWinConvertError(GetLastError()); - nativeErrfile = nativeSource; - goto end; - } - - Tcl_DStringSetLength(sourcePtr, oldSourceLen + 1); - Tcl_DStringSetLength(sourcePtr, oldSourceLen); - result = traverseProc(nativeSource, nativeTarget, DOTREE_PRED, - errorPtr); - if (result != TCL_OK) { - FindClose(handle); - return result; - } - - sourceLen = oldSourceLen + sizeof(TCHAR); - Tcl_DStringAppend(sourcePtr, (char *) TEXT("\\"), sizeof(TCHAR) + 1); - Tcl_DStringSetLength(sourcePtr, sourceLen); - if (targetPtr != NULL) { - oldTargetLen = Tcl_DStringLength(targetPtr); - - targetLen = oldTargetLen; - targetLen += sizeof(TCHAR); - Tcl_DStringAppend(targetPtr, (char *) TEXT("\\"), sizeof(TCHAR) + 1); - Tcl_DStringSetLength(targetPtr, targetLen); - } - - found = 1; - for (; found; found = FindNextFile(handle, &data)) { - TCHAR *nativeName; - int len; - - TCHAR *wp = data.cFileName; - if (*wp == '.') { - wp++; - if (*wp == '.') { - wp++; - } - if (*wp == '\0') { - continue; - } - } - nativeName = (TCHAR *) data.cFileName; - len = _tcslen(data.cFileName) * sizeof(TCHAR); - - /* - * 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((const TCHAR *)Tcl_DStringValue(sourcePtr), - (const TCHAR *)(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. */ -{ - switch (type) { - case DOTREE_F: - if (DoCopyFile(nativeSrc, nativeDst) == TCL_OK) { - return TCL_OK; - } - break; - case DOTREE_LINK: - if (TclWinSymLinkCopyDirectory(nativeSrc, nativeDst) == TCL_OK) { - return TCL_OK; - } - break; - case DOTREE_PRED: - if (DoCreateDirectory(nativeDst) == TCL_OK) { - DWORD attr = GetFileAttributes(nativeSrc); - - if (SetFileAttributes(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 function TraverseWinTree for every file and directory that - * it encounters in a directory hierarchy. This function 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 (TclpDeleteFile(nativeSrc) == TCL_OK) { - return TCL_OK; - } - break; - case DOTREE_LINK: - if (DoRemoveJustDirectory(nativeSrc, 0, NULL) == 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_SetObjResult(interp, Tcl_ObjPrintf("could not read \"%s\": %s", - TclGetString(fileName), Tcl_PosixError(interp))); -} - -/* - *---------------------------------------------------------------------- - * - * 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; - int attr; - - nativeName = Tcl_FSGetNativePath(fileName); - result = GetFileAttributes(nativeName); - - if (result == 0xffffffff) { - StatError(interp, fileName); - return TCL_ERROR; - } - - attr = (int)(result & attributeArray[objIndex]); - if ((objIndex == WIN_HIDDEN_ATTRIBUTE) && (attr != 0)) { - /* - * It is hidden. However there is a bug on some Windows OSes in which - * root volumes (drives) formatted as NTFS are declared hidden when - * they are not (and cannot be). - * - * We test for, and fix that case, here. - */ - - int len; - const char *str = Tcl_GetStringFromObj(fileName,&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. - */ - - attr = 0; - } else if ((str[1] == ':') - && (len == 2 || (str[2] == '/' || str[2] == '\\'))) { - /* - * Path is of the form 'x:' or 'x:/' or 'x:\' - */ - - attr = 0; - } - } - } - - *attributePtrPtr = Tcl_NewBooleanObj(attr); - 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; - - splitPath = Tcl_FSSplitPath(fileName, &pathc); - - if (splitPath == NULL || pathc == 0) { - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "could not read \"%s\": no such file or directory", - Tcl_GetString(fileName))); - errno = ENOENT; - Tcl_PosixError(interp); - } - goto cleanup; - } - - /* - * We will decrement this again at the end. It is safer to do this in - * case any of the calls below retain a reference to splitPath. - */ - - Tcl_IncrRefCount(splitPath); - - 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; - const TCHAR *nativeName; - const char *tempString; - int tempLen; - WIN32_FIND_DATA 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); - nativeName = Tcl_WinUtfToTChar(tempString, tempLen, &ds); - Tcl_DecrRefCount(tempPath); - handle = FindFirstFile(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 = GetFileAttributes(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); - } - goto cleanup; - } - nativeName = data.cAlternateFileName; - if (longShort) { - if (data.cFileName[0] != '\0') { - nativeName = data.cFileName; - } - } else { - if (data.cAlternateFileName[0] == '\0') { - nativeName = (TCHAR *) data.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); - Tcl_DStringFree(&ds); - - /* - * Deal with issues of tildes being absolute. - */ - - if (Tcl_DStringValue(&dsTemp)[0] == '~') { - TclNewLiteralStringObj(tempPath, "./"); - Tcl_AppendToObj(tempPath, Tcl_DStringValue(&dsTemp), - Tcl_DStringLength(&dsTemp)); - Tcl_DStringFree(&dsTemp); - } else { - tempPath = TclDStringToObj(&dsTemp); - } - Tcl_ListObjReplace(NULL, splitPath, i, 1, 1, &tempPath); - FindClose(handle); - } - } - - *attributePtrPtr = Tcl_FSJoinPath(splitPath, -1); - - if (splitPath != NULL) { - /* - * Unfortunately, the object we will return may have its only refCount - * as part of the list splitPath. This means if we free splitPath, the - * object will disappear. So, we have to be very careful here. - * Unfortunately this means we must manipulate the object's refCount - * directly. - */ - - Tcl_IncrRefCount(*attributePtrPtr); - Tcl_DecrRefCount(splitPath); - --(*attributePtrPtr)->refCount; - } - return TCL_OK; - - cleanup: - if (splitPath != NULL) { - Tcl_DecrRefCount(splitPath); - } - - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * 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, old; - int yesNo, result; - const TCHAR *nativeName; - - nativeName = Tcl_FSGetNativePath(fileName); - fileAttributes = old = GetFileAttributes(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 ((fileAttributes != old) - && !SetFileAttributes(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_SetObjResult(interp, Tcl_ObjPrintf( - "cannot set attribute \"%s\" for file \"%s\": attribute is readonly", - tclpFileAttrStrings[objIndex], Tcl_GetString(fileName))); - errno = EINVAL; - Tcl_PosixError(interp); - 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; -} - -/* - * Local Variables: - * mode: c - * c-basic-offset: 4 - * fill-column: 78 - * End: - */ |