riscv
/
OpenFPGA
mirror of https://github.com/lnis-uofu/OpenFPGA.git
1
0
Fork 0
Code Issues Projects Releases Wiki Activity
OpenFPGA/libs/EXTERNAL/tcl8.6.12/win/tclWinFCmd.c

1968 lines
52 KiB
C
Raw Normal View History

adding Tcl interface to vpr
2022-06-07 11:15:20 -05:00
/*
* 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 WCHAR *srcPtr, const WCHAR *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 WCHAR *srcPtr, const WCHAR *dstPtr);
static int DoCreateDirectory(const WCHAR *pathPtr);
static int DoRemoveJustDirectory(const WCHAR *nativeSrc,
int ignoreError, Tcl_DString *errorPtr);
static int DoRemoveDirectory(Tcl_DString *pathPtr, int recursive,
Tcl_DString *errorPtr);
static int DoRenameFile(const WCHAR *nativeSrc,
const WCHAR *dstPtr);
static int TraversalCopy(const WCHAR *srcPtr, const WCHAR *dstPtr,
int type, Tcl_DString *errorPtr);
static int TraversalDelete(const WCHAR *srcPtr,
const WCHAR *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 WCHAR *nativeSrc, /* Pathname of file or dir to be renamed
* (native). */
const WCHAR *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 MoveFileW 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 MoveFileW 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
* MoveFileW.
*/
"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 MoveFileW(nativeSrc, nativeDst)
*/
"pushl %%ebx" "\n\t"
"pushl %%ecx" "\n\t"
"movl %[moveFileW], %%eax" "\n\t"
"call *%%eax" "\n\t"
/*
* Come here on normal exit. Recover the TCLEXCEPTION_REGISTRATION and
* put the status return from MoveFileW 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),
[moveFileW] "r" (MoveFileW)
:
"%eax", "%ebx", "%ecx", "%edx", "memory"
);
if (registration.status != FALSE) {
retval = TCL_OK;
}
#else
#ifndef HAVE_NO_SEH
__try {
#endif
if ((*MoveFileW)(nativeSrc, nativeDst) != FALSE) {
retval = TCL_OK;
}
#ifndef HAVE_NO_SEH
} __except (EXCEPTION_EXECUTE_HANDLER) {}
#endif
#endif
if (retval != -1) {
return retval;
}
TclWinConvertError(GetLastError());
srcAttr = GetFileAttributesW(nativeSrc);
dstAttr = GetFileAttributesW(nativeDst);
if (srcAttr == 0xFFFFFFFF) {
if (GetFullPathNameW(nativeSrc, 0, NULL,
NULL) >= MAX_PATH) {
errno = ENAMETOOLONG;
return TCL_ERROR;
}
srcAttr = 0;
}
if (dstAttr == 0xFFFFFFFF) {
if (GetFullPathNameW(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) {
WCHAR *nativeSrcRest, *nativeDstRest;
const char **srcArgv, **dstArgv;
int size, srcArgc, dstArgc;
WCHAR nativeSrcPath[MAX_PATH];
WCHAR nativeDstPath[MAX_PATH];
Tcl_DString srcString, dstString;
const char *src, *dst;
size = GetFullPathNameW(nativeSrc, MAX_PATH,
nativeSrcPath, &nativeSrcRest);
if ((size == 0) || (size > MAX_PATH)) {
return TCL_ERROR;
}
size = GetFullPathNameW(nativeDst, MAX_PATH,
nativeDstPath, &nativeDstRest);
if ((size == 0) || (size > MAX_PATH)) {
return TCL_ERROR;
}
CharLowerW(nativeSrcPath);
CharLowerW(nativeDstPath);
src = Tcl_WinTCharToUtf((TCHAR *)nativeSrcPath, -1, &srcString);
dst = Tcl_WinTCharToUtf((TCHAR *)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, 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 MoveFileW 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 (MoveFileW(nativeSrc,
nativeDst) != FALSE) {
return TCL_OK;
}
/*
* Some new error has occurred. Don't know what it could
* be, but report this one.
*/
TclWinConvertError(GetLastError());
CreateDirectoryW(nativeDst, NULL);
SetFileAttributesW(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.
*/
WCHAR *nativeRest, *nativeTmp, *nativePrefix;
int result, size;
WCHAR tempBuf[MAX_PATH];
size = GetFullPathNameW(nativeDst, MAX_PATH,
tempBuf, &nativeRest);
if ((size == 0) || (size > MAX_PATH) || (nativeRest == NULL)) {
return TCL_ERROR;
}
nativeTmp = (WCHAR *) tempBuf;
nativeRest[0] = L'\0';
result = TCL_ERROR;
nativePrefix = (WCHAR *) L"tclr";
if (GetTempFileNameW(nativeTmp, nativePrefix,
0, tempBuf) != 0) {
/*
* Strictly speaking, need the following DeleteFile and
* MoveFileW to be joined as an atomic operation so no
* other app comes along in the meantime and creates the
* same temp file.
*/
nativeTmp = tempBuf;
DeleteFileW(nativeTmp);
if (MoveFileW(nativeDst, nativeTmp) != FALSE) {
if (MoveFileW(nativeSrc, nativeDst) != FALSE) {
SetFileAttributesW(nativeTmp, FILE_ATTRIBUTE_NORMAL);
DeleteFileW(nativeTmp);
return TCL_OK;
} else {
DeleteFileW(nativeDst);
MoveFileW(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 WCHAR *nativeSrc, /* Pathname of file to be copied (native). */
const WCHAR *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 CopyFileW(nativeSrc, nativeDst, 0)
*/
"movl %[copyFileW], %%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),
[copyFileW] "r" (CopyFileW)
:
"%eax", "%ebx", "%ecx", "%edx", "memory"
);
if (registration.status != FALSE) {
retval = TCL_OK;
}
#else
#ifndef HAVE_NO_SEH
__try {
#endif
if (CopyFileW(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 = GetFileAttributesW(nativeSrc);
dstAttr = GetFileAttributesW(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) {
SetFileAttributesW(nativeDst,
dstAttr & ~((DWORD)FILE_ATTRIBUTE_READONLY));
if (CopyFileW(nativeSrc, nativeDst,
0) != FALSE) {
return TCL_OK;
}
/*
* Still can't copy onto dst. Return that error, and restore
* attributes of dst.
*/
TclWinConvertError(GetLastError());
SetFileAttributesW(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 WCHAR *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 (DeleteFileW(path) != FALSE) {
return TCL_OK;
}
TclWinConvertError(GetLastError());
if (Tcl_GetErrno() == EACCES) {
attr = GetFileAttributesW(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 = SetFileAttributesW(path,
attr & ~((DWORD) FILE_ATTRIBUTE_READONLY));
if ((res != 0) &&
(DeleteFileW(path) != FALSE)) {
return TCL_OK;
}
TclWinConvertError(GetLastError());
if (res != 0) {
SetFileAttributesW(path, attr);
}
}
}
} else if (Tcl_GetErrno() == ENOENT) {
attr = GetFileAttributesW(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 WCHAR *nativePath) /* Pathname of directory to create (native). */
{
if (CreateDirectoryW(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 WCHAR *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);
Tcl_DStringInit(errorPtr);
return TCL_ERROR;
}
attr = GetFileAttributesW(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 (RemoveDirectoryW(nativePath) != FALSE) {
return TCL_OK;
}
}
TclWinConvertError(GetLastError());
if (Tcl_GetErrno() == EACCES) {
attr = GetFileAttributesW(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 (SetFileAttributesW(nativePath,
attr) == FALSE) {
goto end;
}
if (RemoveDirectoryW(nativePath) != FALSE) {
return TCL_OK;
}
TclWinConvertError(GetLastError());
SetFileAttributesW(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((TCHAR *)nativePath, -1, 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 WCHAR *)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;
WCHAR *nativeSource, *nativeTarget, *nativeErrfile;
int result, found, sourceLen, targetLen = 0, oldSourceLen, oldTargetLen;
HANDLE handle;
WIN32_FIND_DATAW data;
nativeErrfile = NULL;
result = TCL_OK;
oldTargetLen = 0; /* lint. */
nativeSource = (WCHAR *) Tcl_DStringValue(sourcePtr);
nativeTarget = (WCHAR *)
(targetPtr == NULL ? NULL : Tcl_DStringValue(targetPtr));
oldSourceLen = Tcl_DStringLength(sourcePtr);
sourceAttr = GetFileAttributesW(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 *) L"\\*.*", 4 * sizeof(WCHAR) + 1);
Tcl_DStringSetLength(sourcePtr, Tcl_DStringLength(sourcePtr) - 1);
nativeSource = (WCHAR *) Tcl_DStringValue(sourcePtr);
handle = FindFirstFileW(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(WCHAR);
Tcl_DStringAppend(sourcePtr, (char *) L"\\", sizeof(WCHAR) + 1);
Tcl_DStringSetLength(sourcePtr, sourceLen);
if (targetPtr != NULL) {
oldTargetLen = Tcl_DStringLength(targetPtr);
targetLen = oldTargetLen;
targetLen += sizeof(WCHAR);
Tcl_DStringAppend(targetPtr, (char *) L"\\", sizeof(WCHAR) + 1);
Tcl_DStringSetLength(targetPtr, targetLen);
}
found = 1;
for (; found; found = FindNextFileW(handle, &data)) {
WCHAR *nativeName;
size_t len;
WCHAR *wp = data.cFileName;
if (*wp == '.') {
wp++;
if (*wp == '.') {
wp++;
}
if (*wp == '\0') {
continue;
}
}
nativeName = (WCHAR *) data.cFileName;
len = wcslen(data.cFileName) * sizeof(WCHAR);
/*
* 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 WCHAR *)Tcl_DStringValue(sourcePtr),
(const WCHAR *)(targetPtr == NULL ? NULL : Tcl_DStringValue(targetPtr)),
DOTREE_POSTD, errorPtr);
}
end:
if (nativeErrfile != NULL) {
TclWinConvertError(GetLastError());
if (errorPtr != NULL) {
Tcl_WinTCharToUtf((TCHAR *)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 WCHAR *nativeSrc, /* Source pathname to copy. */
const WCHAR *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 = GetFileAttributesW(nativeSrc);
if (SetFileAttributesW(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((TCHAR *)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 WCHAR *nativeSrc, /* Source pathname to delete. */
const WCHAR *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((TCHAR *)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 WCHAR *nativeName;
int attr;
nativeName = Tcl_FSGetNativePath(fileName);
result = GetFileAttributesW(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 WCHAR *nativeName;
const char *tempString;
int tempLen;
WIN32_FIND_DATAW 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 = (WCHAR *)Tcl_WinUtfToTChar(tempString, tempLen, &ds);
Tcl_DecrRefCount(tempPath);
handle = FindFirstFileW(nativeName, &data);
if (handle == INVALID_HANDLE_VALUE) {
/*
* FindFirstFileW() 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 = GetFileAttributesW(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 = (WCHAR *) 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((TCHAR *)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 WCHAR *nativeName;
nativeName = Tcl_FSGetNativePath(fileName);
fileAttributes = old = GetFileAttributesW(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)
&& !SetFileAttributesW(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;
TclNewObj(resultPtr);
/*
* On Win32s:
* GetLogicalDriveStrings() isn't implemented.
* GetLogicalDrives() returns incorrect information.
*/
if (GetLogicalDriveStringsA(sizeof(buf), buf) == 0) {
/*
* GetVolumeInformationW() will detect 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 GetVolumeInformationW() 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:
*/