os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/win/tclWinFCmd.c
1.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2 +++ b/os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/win/tclWinFCmd.c Fri Jun 15 03:10:57 2012 +0200
1.3 @@ -0,0 +1,1961 @@
1.4 +/*
1.5 + * tclWinFCmd.c
1.6 + *
1.7 + * This file implements the Windows specific portion of file manipulation
1.8 + * subcommands of the "file" command.
1.9 + *
1.10 + * Copyright (c) 1996-1998 Sun Microsystems, Inc.
1.11 + *
1.12 + * See the file "license.terms" for information on usage and redistribution
1.13 + * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
1.14 + *
1.15 + * RCS: @(#) $Id: tclWinFCmd.c,v 1.35.2.5 2006/08/30 17:48:48 hobbs Exp $
1.16 + */
1.17 +
1.18 +#include "tclWinInt.h"
1.19 +
1.20 +/*
1.21 + * The following constants specify the type of callback when
1.22 + * TraverseWinTree() calls the traverseProc()
1.23 + */
1.24 +
1.25 +#define DOTREE_PRED 1 /* pre-order directory */
1.26 +#define DOTREE_POSTD 2 /* post-order directory */
1.27 +#define DOTREE_F 3 /* regular file */
1.28 +
1.29 +/*
1.30 + * Callbacks for file attributes code.
1.31 + */
1.32 +
1.33 +static int GetWinFileAttributes _ANSI_ARGS_((Tcl_Interp *interp,
1.34 + int objIndex, Tcl_Obj *fileName,
1.35 + Tcl_Obj **attributePtrPtr));
1.36 +static int GetWinFileLongName _ANSI_ARGS_((Tcl_Interp *interp,
1.37 + int objIndex, Tcl_Obj *fileName,
1.38 + Tcl_Obj **attributePtrPtr));
1.39 +static int GetWinFileShortName _ANSI_ARGS_((Tcl_Interp *interp,
1.40 + int objIndex, Tcl_Obj *fileName,
1.41 + Tcl_Obj **attributePtrPtr));
1.42 +static int SetWinFileAttributes _ANSI_ARGS_((Tcl_Interp *interp,
1.43 + int objIndex, Tcl_Obj *fileName,
1.44 + Tcl_Obj *attributePtr));
1.45 +static int CannotSetAttribute _ANSI_ARGS_((Tcl_Interp *interp,
1.46 + int objIndex, Tcl_Obj *fileName,
1.47 + Tcl_Obj *attributePtr));
1.48 +
1.49 +/*
1.50 + * Constants and variables necessary for file attributes subcommand.
1.51 + */
1.52 +
1.53 +enum {
1.54 + WIN_ARCHIVE_ATTRIBUTE,
1.55 + WIN_HIDDEN_ATTRIBUTE,
1.56 + WIN_LONGNAME_ATTRIBUTE,
1.57 + WIN_READONLY_ATTRIBUTE,
1.58 + WIN_SHORTNAME_ATTRIBUTE,
1.59 + WIN_SYSTEM_ATTRIBUTE
1.60 +};
1.61 +
1.62 +static int attributeArray[] = {FILE_ATTRIBUTE_ARCHIVE, FILE_ATTRIBUTE_HIDDEN,
1.63 + 0, FILE_ATTRIBUTE_READONLY, 0, FILE_ATTRIBUTE_SYSTEM};
1.64 +
1.65 +
1.66 +CONST char *tclpFileAttrStrings[] = {
1.67 + "-archive", "-hidden", "-longname", "-readonly",
1.68 + "-shortname", "-system", (char *) NULL
1.69 +};
1.70 +
1.71 +CONST TclFileAttrProcs tclpFileAttrProcs[] = {
1.72 + {GetWinFileAttributes, SetWinFileAttributes},
1.73 + {GetWinFileAttributes, SetWinFileAttributes},
1.74 + {GetWinFileLongName, CannotSetAttribute},
1.75 + {GetWinFileAttributes, SetWinFileAttributes},
1.76 + {GetWinFileShortName, CannotSetAttribute},
1.77 + {GetWinFileAttributes, SetWinFileAttributes}};
1.78 +
1.79 +#ifdef HAVE_NO_SEH
1.80 +
1.81 +/*
1.82 + * Unlike Borland and Microsoft, we don't register exception handlers
1.83 + * by pushing registration records onto the runtime stack. Instead, we
1.84 + * register them by creating an EXCEPTION_REGISTRATION within the activation
1.85 + * record.
1.86 + */
1.87 +
1.88 +typedef struct EXCEPTION_REGISTRATION {
1.89 + struct EXCEPTION_REGISTRATION* link;
1.90 + EXCEPTION_DISPOSITION (*handler)( struct _EXCEPTION_RECORD*, void*,
1.91 + struct _CONTEXT*, void* );
1.92 + void* ebp;
1.93 + void* esp;
1.94 + int status;
1.95 +} EXCEPTION_REGISTRATION;
1.96 +
1.97 +#endif
1.98 +
1.99 +/*
1.100 + * Prototype for the TraverseWinTree callback function.
1.101 + */
1.102 +
1.103 +typedef int (TraversalProc)(CONST TCHAR *srcPtr, CONST TCHAR *dstPtr,
1.104 + int type, Tcl_DString *errorPtr);
1.105 +
1.106 +/*
1.107 + * Declarations for local procedures defined in this file:
1.108 + */
1.109 +
1.110 +static void StatError(Tcl_Interp *interp, Tcl_Obj *fileName);
1.111 +static int ConvertFileNameFormat(Tcl_Interp *interp,
1.112 + int objIndex, Tcl_Obj *fileName, int longShort,
1.113 + Tcl_Obj **attributePtrPtr);
1.114 +static int DoCopyFile(CONST TCHAR *srcPtr, CONST TCHAR *dstPtr);
1.115 +static int DoCreateDirectory(CONST TCHAR *pathPtr);
1.116 +static int DoRemoveJustDirectory(CONST TCHAR *nativeSrc,
1.117 + int ignoreError, Tcl_DString *errorPtr);
1.118 +static int DoRemoveDirectory(Tcl_DString *pathPtr, int recursive,
1.119 + Tcl_DString *errorPtr);
1.120 +static int DoRenameFile(CONST TCHAR *nativeSrc, CONST TCHAR *dstPtr);
1.121 +static int TraversalCopy(CONST TCHAR *srcPtr, CONST TCHAR *dstPtr,
1.122 + int type, Tcl_DString *errorPtr);
1.123 +static int TraversalDelete(CONST TCHAR *srcPtr, CONST TCHAR *dstPtr,
1.124 + int type, Tcl_DString *errorPtr);
1.125 +static int TraverseWinTree(TraversalProc *traverseProc,
1.126 + Tcl_DString *sourcePtr, Tcl_DString *dstPtr,
1.127 + Tcl_DString *errorPtr);
1.128 +
1.129 +
1.130 +/*
1.131 + *---------------------------------------------------------------------------
1.132 + *
1.133 + * TclpObjRenameFile, DoRenameFile --
1.134 + *
1.135 + * Changes the name of an existing file or directory, from src to dst.
1.136 + * If src and dst refer to the same file or directory, does nothing
1.137 + * and returns success. Otherwise if dst already exists, it will be
1.138 + * deleted and replaced by src subject to the following conditions:
1.139 + * If src is a directory, dst may be an empty directory.
1.140 + * If src is a file, dst may be a file.
1.141 + * In any other situation where dst already exists, the rename will
1.142 + * fail.
1.143 + *
1.144 + * Results:
1.145 + * If the file or directory was successfully renamed, returns TCL_OK.
1.146 + * Otherwise the return value is TCL_ERROR and errno is set to
1.147 + * indicate the error. Some possible values for errno are:
1.148 + *
1.149 + * ENAMETOOLONG: src or dst names are too long.
1.150 + * EACCES: src or dst parent directory can't be read and/or written.
1.151 + * EEXIST: dst is a non-empty directory.
1.152 + * EINVAL: src is a root directory or dst is a subdirectory of src.
1.153 + * EISDIR: dst is a directory, but src is not.
1.154 + * ENOENT: src doesn't exist. src or dst is "".
1.155 + * ENOTDIR: src is a directory, but dst is not.
1.156 + * EXDEV: src and dst are on different filesystems.
1.157 + *
1.158 + * EACCES: exists an open file already referring to src or dst.
1.159 + * EACCES: src or dst specify the current working directory (NT).
1.160 + * EACCES: src specifies a char device (nul:, com1:, etc.)
1.161 + * EEXIST: dst specifies a char device (nul:, com1:, etc.) (NT)
1.162 + * EACCES: dst specifies a char device (nul:, com1:, etc.) (95)
1.163 + *
1.164 + * Side effects:
1.165 + * The implementation supports cross-filesystem renames of files,
1.166 + * but the caller should be prepared to emulate cross-filesystem
1.167 + * renames of directories if errno is EXDEV.
1.168 + *
1.169 + *---------------------------------------------------------------------------
1.170 + */
1.171 +
1.172 +int
1.173 +TclpObjRenameFile(srcPathPtr, destPathPtr)
1.174 + Tcl_Obj *srcPathPtr;
1.175 + Tcl_Obj *destPathPtr;
1.176 +{
1.177 + return DoRenameFile(Tcl_FSGetNativePath(srcPathPtr),
1.178 + Tcl_FSGetNativePath(destPathPtr));
1.179 +}
1.180 +
1.181 +static int
1.182 +DoRenameFile(
1.183 + CONST TCHAR *nativeSrc, /* Pathname of file or dir to be renamed
1.184 + * (native). */
1.185 + CONST TCHAR *nativeDst) /* New pathname for file or directory
1.186 + * (native). */
1.187 +{
1.188 +#ifdef HAVE_NO_SEH
1.189 + EXCEPTION_REGISTRATION registration;
1.190 +#endif
1.191 + DWORD srcAttr, dstAttr;
1.192 + int retval = -1;
1.193 +
1.194 + /*
1.195 + * The MoveFile API acts differently under Win95/98 and NT
1.196 + * WRT NULL and "". Avoid passing these values.
1.197 + */
1.198 +
1.199 + if (nativeSrc == NULL || nativeSrc[0] == '\0' ||
1.200 + nativeDst == NULL || nativeDst[0] == '\0') {
1.201 + Tcl_SetErrno(ENOENT);
1.202 + return TCL_ERROR;
1.203 + }
1.204 +
1.205 + /*
1.206 + * The MoveFile API would throw an exception under NT
1.207 + * if one of the arguments is a char block device.
1.208 + */
1.209 +
1.210 +#ifndef HAVE_NO_SEH
1.211 + __try {
1.212 + if ((*tclWinProcs->moveFileProc)(nativeSrc, nativeDst) != FALSE) {
1.213 + retval = TCL_OK;
1.214 + }
1.215 + } __except (EXCEPTION_EXECUTE_HANDLER) {}
1.216 +#else
1.217 +
1.218 + /*
1.219 + * Don't have SEH available, do things the hard way.
1.220 + * Note that this needs to be one block of asm, to avoid stack
1.221 + * imbalance; also, it is illegal for one asm block to contain
1.222 + * a jump to another.
1.223 + */
1.224 +
1.225 + __asm__ __volatile__ (
1.226 + /*
1.227 + * Pick up params before messing with the stack */
1.228 +
1.229 + "movl %[nativeDst], %%ebx" "\n\t"
1.230 + "movl %[nativeSrc], %%ecx" "\n\t"
1.231 +
1.232 + /*
1.233 + * Construct an EXCEPTION_REGISTRATION to protect the
1.234 + * call to MoveFile
1.235 + */
1.236 + "leal %[registration], %%edx" "\n\t"
1.237 + "movl %%fs:0, %%eax" "\n\t"
1.238 + "movl %%eax, 0x0(%%edx)" "\n\t" /* link */
1.239 + "leal 1f, %%eax" "\n\t"
1.240 + "movl %%eax, 0x4(%%edx)" "\n\t" /* handler */
1.241 + "movl %%ebp, 0x8(%%edx)" "\n\t" /* ebp */
1.242 + "movl %%esp, 0xc(%%edx)" "\n\t" /* esp */
1.243 + "movl $0, 0x10(%%edx)" "\n\t" /* status */
1.244 +
1.245 + /* Link the EXCEPTION_REGISTRATION on the chain */
1.246 +
1.247 + "movl %%edx, %%fs:0" "\n\t"
1.248 +
1.249 + /* Call MoveFile( nativeSrc, nativeDst ) */
1.250 +
1.251 + "pushl %%ebx" "\n\t"
1.252 + "pushl %%ecx" "\n\t"
1.253 + "movl %[moveFile], %%eax" "\n\t"
1.254 + "call *%%eax" "\n\t"
1.255 +
1.256 + /*
1.257 + * Come here on normal exit. Recover the EXCEPTION_REGISTRATION
1.258 + * and put the status return from MoveFile into it.
1.259 + */
1.260 +
1.261 + "movl %%fs:0, %%edx" "\n\t"
1.262 + "movl %%eax, 0x10(%%edx)" "\n\t"
1.263 + "jmp 2f" "\n"
1.264 +
1.265 + /*
1.266 + * Come here on an exception. Recover the EXCEPTION_REGISTRATION
1.267 + */
1.268 +
1.269 + "1:" "\t"
1.270 + "movl %%fs:0, %%edx" "\n\t"
1.271 + "movl 0x8(%%edx), %%edx" "\n\t"
1.272 +
1.273 + /*
1.274 + * Come here however we exited. Restore context from the
1.275 + * EXCEPTION_REGISTRATION in case the stack is unbalanced.
1.276 + */
1.277 +
1.278 + "2:" "\t"
1.279 + "movl 0xc(%%edx), %%esp" "\n\t"
1.280 + "movl 0x8(%%edx), %%ebp" "\n\t"
1.281 + "movl 0x0(%%edx), %%eax" "\n\t"
1.282 + "movl %%eax, %%fs:0" "\n\t"
1.283 +
1.284 + :
1.285 + /* No outputs */
1.286 + :
1.287 + [registration] "m" (registration),
1.288 + [nativeDst] "m" (nativeDst),
1.289 + [nativeSrc] "m" (nativeSrc),
1.290 + [moveFile] "r" (tclWinProcs->moveFileProc)
1.291 + :
1.292 + "%eax", "%ebx", "%ecx", "%edx", "memory"
1.293 + );
1.294 + if (registration.status != FALSE) {
1.295 + retval = TCL_OK;
1.296 + }
1.297 +#endif
1.298 +
1.299 + if (retval != -1)
1.300 + return retval;
1.301 +
1.302 + TclWinConvertError(GetLastError());
1.303 +
1.304 + srcAttr = (*tclWinProcs->getFileAttributesProc)(nativeSrc);
1.305 + dstAttr = (*tclWinProcs->getFileAttributesProc)(nativeDst);
1.306 + if (srcAttr == 0xffffffff) {
1.307 + if ((*tclWinProcs->getFullPathNameProc)(nativeSrc, 0, NULL, NULL) >= MAX_PATH) {
1.308 + errno = ENAMETOOLONG;
1.309 + return TCL_ERROR;
1.310 + }
1.311 + srcAttr = 0;
1.312 + }
1.313 + if (dstAttr == 0xffffffff) {
1.314 + if ((*tclWinProcs->getFullPathNameProc)(nativeDst, 0, NULL, NULL) >= MAX_PATH) {
1.315 + errno = ENAMETOOLONG;
1.316 + return TCL_ERROR;
1.317 + }
1.318 + dstAttr = 0;
1.319 + }
1.320 +
1.321 + if (errno == EBADF) {
1.322 + errno = EACCES;
1.323 + return TCL_ERROR;
1.324 + }
1.325 + if (errno == EACCES) {
1.326 + decode:
1.327 + if (srcAttr & FILE_ATTRIBUTE_DIRECTORY) {
1.328 + TCHAR *nativeSrcRest, *nativeDstRest;
1.329 + CONST char **srcArgv, **dstArgv;
1.330 + int size, srcArgc, dstArgc;
1.331 + WCHAR nativeSrcPath[MAX_PATH];
1.332 + WCHAR nativeDstPath[MAX_PATH];
1.333 + Tcl_DString srcString, dstString;
1.334 + CONST char *src, *dst;
1.335 +
1.336 + size = (*tclWinProcs->getFullPathNameProc)(nativeSrc, MAX_PATH,
1.337 + nativeSrcPath, &nativeSrcRest);
1.338 + if ((size == 0) || (size > MAX_PATH)) {
1.339 + return TCL_ERROR;
1.340 + }
1.341 + size = (*tclWinProcs->getFullPathNameProc)(nativeDst, MAX_PATH,
1.342 + nativeDstPath, &nativeDstRest);
1.343 + if ((size == 0) || (size > MAX_PATH)) {
1.344 + return TCL_ERROR;
1.345 + }
1.346 + (*tclWinProcs->charLowerProc)((TCHAR *) nativeSrcPath);
1.347 + (*tclWinProcs->charLowerProc)((TCHAR *) nativeDstPath);
1.348 +
1.349 + src = Tcl_WinTCharToUtf((TCHAR *) nativeSrcPath, -1, &srcString);
1.350 + dst = Tcl_WinTCharToUtf((TCHAR *) nativeDstPath, -1, &dstString);
1.351 + if (strncmp(src, dst, (size_t) Tcl_DStringLength(&srcString)) == 0) {
1.352 + /*
1.353 + * Trying to move a directory into itself.
1.354 + */
1.355 +
1.356 + errno = EINVAL;
1.357 + Tcl_DStringFree(&srcString);
1.358 + Tcl_DStringFree(&dstString);
1.359 + return TCL_ERROR;
1.360 + }
1.361 + Tcl_SplitPath(src, &srcArgc, &srcArgv);
1.362 + Tcl_SplitPath(dst, &dstArgc, &dstArgv);
1.363 + Tcl_DStringFree(&srcString);
1.364 + Tcl_DStringFree(&dstString);
1.365 +
1.366 + if (srcArgc == 1) {
1.367 + /*
1.368 + * They are trying to move a root directory. Whether
1.369 + * or not it is across filesystems, this cannot be
1.370 + * done.
1.371 + */
1.372 +
1.373 + Tcl_SetErrno(EINVAL);
1.374 + } else if ((srcArgc > 0) && (dstArgc > 0) &&
1.375 + (strcmp(srcArgv[0], dstArgv[0]) != 0)) {
1.376 + /*
1.377 + * If src is a directory and dst filesystem != src
1.378 + * filesystem, errno should be EXDEV. It is very
1.379 + * important to get this behavior, so that the caller
1.380 + * can respond to a cross filesystem rename by
1.381 + * simulating it with copy and delete. The MoveFile
1.382 + * system call already handles the case of moving a
1.383 + * file between filesystems.
1.384 + */
1.385 +
1.386 + Tcl_SetErrno(EXDEV);
1.387 + }
1.388 +
1.389 + ckfree((char *) srcArgv);
1.390 + ckfree((char *) dstArgv);
1.391 + }
1.392 +
1.393 + /*
1.394 + * Other types of access failure is that dst is a read-only
1.395 + * filesystem, that an open file referred to src or dest, or that
1.396 + * src or dest specified the current working directory on the
1.397 + * current filesystem. EACCES is returned for those cases.
1.398 + */
1.399 +
1.400 + } else if (Tcl_GetErrno() == EEXIST) {
1.401 + /*
1.402 + * Reports EEXIST any time the target already exists. If it makes
1.403 + * sense, remove the old file and try renaming again.
1.404 + */
1.405 +
1.406 + if (srcAttr & FILE_ATTRIBUTE_DIRECTORY) {
1.407 + if (dstAttr & FILE_ATTRIBUTE_DIRECTORY) {
1.408 + /*
1.409 + * Overwrite empty dst directory with src directory. The
1.410 + * following call will remove an empty directory. If it
1.411 + * fails, it's because it wasn't empty.
1.412 + */
1.413 +
1.414 + if (DoRemoveJustDirectory(nativeDst, 0, NULL) == TCL_OK) {
1.415 + /*
1.416 + * Now that that empty directory is gone, we can try
1.417 + * renaming again. If that fails, we'll put this empty
1.418 + * directory back, for completeness.
1.419 + */
1.420 +
1.421 + if ((*tclWinProcs->moveFileProc)(nativeSrc, nativeDst) != FALSE) {
1.422 + return TCL_OK;
1.423 + }
1.424 +
1.425 + /*
1.426 + * Some new error has occurred. Don't know what it
1.427 + * could be, but report this one.
1.428 + */
1.429 +
1.430 + TclWinConvertError(GetLastError());
1.431 + (*tclWinProcs->createDirectoryProc)(nativeDst, NULL);
1.432 + (*tclWinProcs->setFileAttributesProc)(nativeDst, dstAttr);
1.433 + if (Tcl_GetErrno() == EACCES) {
1.434 + /*
1.435 + * Decode the EACCES to a more meaningful error.
1.436 + */
1.437 +
1.438 + goto decode;
1.439 + }
1.440 + }
1.441 + } else { /* (dstAttr & FILE_ATTRIBUTE_DIRECTORY) == 0 */
1.442 + Tcl_SetErrno(ENOTDIR);
1.443 + }
1.444 + } else { /* (srcAttr & FILE_ATTRIBUTE_DIRECTORY) == 0 */
1.445 + if (dstAttr & FILE_ATTRIBUTE_DIRECTORY) {
1.446 + Tcl_SetErrno(EISDIR);
1.447 + } else {
1.448 + /*
1.449 + * Overwrite existing file by:
1.450 + *
1.451 + * 1. Rename existing file to temp name.
1.452 + * 2. Rename old file to new name.
1.453 + * 3. If success, delete temp file. If failure,
1.454 + * put temp file back to old name.
1.455 + */
1.456 +
1.457 + TCHAR *nativeRest, *nativeTmp, *nativePrefix;
1.458 + int result, size;
1.459 + WCHAR tempBuf[MAX_PATH];
1.460 +
1.461 + size = (*tclWinProcs->getFullPathNameProc)(nativeDst, MAX_PATH,
1.462 + tempBuf, &nativeRest);
1.463 + if ((size == 0) || (size > MAX_PATH) || (nativeRest == NULL)) {
1.464 + return TCL_ERROR;
1.465 + }
1.466 + nativeTmp = (TCHAR *) tempBuf;
1.467 + ((char *) nativeRest)[0] = '\0';
1.468 + ((char *) nativeRest)[1] = '\0'; /* In case it's Unicode. */
1.469 +
1.470 + result = TCL_ERROR;
1.471 + nativePrefix = (tclWinProcs->useWide)
1.472 + ? (TCHAR *) L"tclr" : (TCHAR *) "tclr";
1.473 + if ((*tclWinProcs->getTempFileNameProc)(nativeTmp,
1.474 + nativePrefix, 0, tempBuf) != 0) {
1.475 + /*
1.476 + * Strictly speaking, need the following DeleteFile and
1.477 + * MoveFile to be joined as an atomic operation so no
1.478 + * other app comes along in the meantime and creates the
1.479 + * same temp file.
1.480 + */
1.481 +
1.482 + nativeTmp = (TCHAR *) tempBuf;
1.483 + (*tclWinProcs->deleteFileProc)(nativeTmp);
1.484 + if ((*tclWinProcs->moveFileProc)(nativeDst, nativeTmp) != FALSE) {
1.485 + if ((*tclWinProcs->moveFileProc)(nativeSrc, nativeDst) != FALSE) {
1.486 + (*tclWinProcs->setFileAttributesProc)(nativeTmp,
1.487 + FILE_ATTRIBUTE_NORMAL);
1.488 + (*tclWinProcs->deleteFileProc)(nativeTmp);
1.489 + return TCL_OK;
1.490 + } else {
1.491 + (*tclWinProcs->deleteFileProc)(nativeDst);
1.492 + (*tclWinProcs->moveFileProc)(nativeTmp, nativeDst);
1.493 + }
1.494 + }
1.495 +
1.496 + /*
1.497 + * Can't backup dst file or move src file. Return that
1.498 + * error. Could happen if an open file refers to dst.
1.499 + */
1.500 +
1.501 + TclWinConvertError(GetLastError());
1.502 + if (Tcl_GetErrno() == EACCES) {
1.503 + /*
1.504 + * Decode the EACCES to a more meaningful error.
1.505 + */
1.506 +
1.507 + goto decode;
1.508 + }
1.509 + }
1.510 + return result;
1.511 + }
1.512 + }
1.513 + }
1.514 + return TCL_ERROR;
1.515 +}
1.516 +
1.517 +/*
1.518 + *---------------------------------------------------------------------------
1.519 + *
1.520 + * TclpObjCopyFile, DoCopyFile --
1.521 + *
1.522 + * Copy a single file (not a directory). If dst already exists and
1.523 + * is not a directory, it is removed.
1.524 + *
1.525 + * Results:
1.526 + * If the file was successfully copied, returns TCL_OK. Otherwise
1.527 + * the return value is TCL_ERROR and errno is set to indicate the
1.528 + * error. Some possible values for errno are:
1.529 + *
1.530 + * EACCES: src or dst parent directory can't be read and/or written.
1.531 + * EISDIR: src or dst is a directory.
1.532 + * ENOENT: src doesn't exist. src or dst is "".
1.533 + *
1.534 + * EACCES: exists an open file already referring to dst (95).
1.535 + * EACCES: src specifies a char device (nul:, com1:, etc.) (NT)
1.536 + * ENOENT: src specifies a char device (nul:, com1:, etc.) (95)
1.537 + *
1.538 + * Side effects:
1.539 + * It is not an error to copy to a char device.
1.540 + *
1.541 + *---------------------------------------------------------------------------
1.542 + */
1.543 +
1.544 +int
1.545 +TclpObjCopyFile(srcPathPtr, destPathPtr)
1.546 + Tcl_Obj *srcPathPtr;
1.547 + Tcl_Obj *destPathPtr;
1.548 +{
1.549 + return DoCopyFile(Tcl_FSGetNativePath(srcPathPtr),
1.550 + Tcl_FSGetNativePath(destPathPtr));
1.551 +}
1.552 +
1.553 +static int
1.554 +DoCopyFile(
1.555 + CONST TCHAR *nativeSrc, /* Pathname of file to be copied (native). */
1.556 + CONST TCHAR *nativeDst) /* Pathname of file to copy to (native). */
1.557 +{
1.558 +#ifdef HAVE_NO_SEH
1.559 + EXCEPTION_REGISTRATION registration;
1.560 +#endif
1.561 + int retval = -1;
1.562 +
1.563 + /*
1.564 + * The CopyFile API acts differently under Win95/98 and NT
1.565 + * WRT NULL and "". Avoid passing these values.
1.566 + */
1.567 +
1.568 + if (nativeSrc == NULL || nativeSrc[0] == '\0' ||
1.569 + nativeDst == NULL || nativeDst[0] == '\0') {
1.570 + Tcl_SetErrno(ENOENT);
1.571 + return TCL_ERROR;
1.572 + }
1.573 +
1.574 + /*
1.575 + * The CopyFile API would throw an exception under NT if one
1.576 + * of the arguments is a char block device.
1.577 + */
1.578 +
1.579 +#ifndef HAVE_NO_SEH
1.580 + __try {
1.581 + if ((*tclWinProcs->copyFileProc)(nativeSrc, nativeDst, 0) != FALSE) {
1.582 + retval = TCL_OK;
1.583 + }
1.584 + } __except (EXCEPTION_EXECUTE_HANDLER) {}
1.585 +#else
1.586 +
1.587 + /*
1.588 + * Don't have SEH available, do things the hard way.
1.589 + * Note that this needs to be one block of asm, to avoid stack
1.590 + * imbalance; also, it is illegal for one asm block to contain
1.591 + * a jump to another.
1.592 + */
1.593 +
1.594 + __asm__ __volatile__ (
1.595 +
1.596 + /*
1.597 + * Pick up parameters before messing with the stack
1.598 + */
1.599 +
1.600 + "movl %[nativeDst], %%ebx" "\n\t"
1.601 + "movl %[nativeSrc], %%ecx" "\n\t"
1.602 + /*
1.603 + * Construct an EXCEPTION_REGISTRATION to protect the
1.604 + * call to CopyFile
1.605 + */
1.606 + "leal %[registration], %%edx" "\n\t"
1.607 + "movl %%fs:0, %%eax" "\n\t"
1.608 + "movl %%eax, 0x0(%%edx)" "\n\t" /* link */
1.609 + "leal 1f, %%eax" "\n\t"
1.610 + "movl %%eax, 0x4(%%edx)" "\n\t" /* handler */
1.611 + "movl %%ebp, 0x8(%%edx)" "\n\t" /* ebp */
1.612 + "movl %%esp, 0xc(%%edx)" "\n\t" /* esp */
1.613 + "movl $0, 0x10(%%edx)" "\n\t" /* status */
1.614 +
1.615 + /* Link the EXCEPTION_REGISTRATION on the chain */
1.616 +
1.617 + "movl %%edx, %%fs:0" "\n\t"
1.618 +
1.619 + /* Call CopyFile( nativeSrc, nativeDst, 0 ) */
1.620 +
1.621 + "movl %[copyFile], %%eax" "\n\t"
1.622 + "pushl $0" "\n\t"
1.623 + "pushl %%ebx" "\n\t"
1.624 + "pushl %%ecx" "\n\t"
1.625 + "call *%%eax" "\n\t"
1.626 +
1.627 + /*
1.628 + * Come here on normal exit. Recover the EXCEPTION_REGISTRATION
1.629 + * and put the status return from CopyFile into it.
1.630 + */
1.631 +
1.632 + "movl %%fs:0, %%edx" "\n\t"
1.633 + "movl %%eax, 0x10(%%edx)" "\n\t"
1.634 + "jmp 2f" "\n"
1.635 +
1.636 + /*
1.637 + * Come here on an exception. Recover the EXCEPTION_REGISTRATION
1.638 + */
1.639 +
1.640 + "1:" "\t"
1.641 + "movl %%fs:0, %%edx" "\n\t"
1.642 + "movl 0x8(%%edx), %%edx" "\n\t"
1.643 +
1.644 + /*
1.645 + * Come here however we exited. Restore context from the
1.646 + * EXCEPTION_REGISTRATION in case the stack is unbalanced.
1.647 + */
1.648 +
1.649 + "2:" "\t"
1.650 + "movl 0xc(%%edx), %%esp" "\n\t"
1.651 + "movl 0x8(%%edx), %%ebp" "\n\t"
1.652 + "movl 0x0(%%edx), %%eax" "\n\t"
1.653 + "movl %%eax, %%fs:0" "\n\t"
1.654 +
1.655 + :
1.656 + /* No outputs */
1.657 + :
1.658 + [registration] "m" (registration),
1.659 + [nativeDst] "m" (nativeDst),
1.660 + [nativeSrc] "m" (nativeSrc),
1.661 + [copyFile] "r" (tclWinProcs->copyFileProc)
1.662 + :
1.663 + "%eax", "%ebx", "%ecx", "%edx", "memory"
1.664 + );
1.665 + if (registration.status != FALSE) {
1.666 + retval = TCL_OK;
1.667 + }
1.668 +#endif
1.669 +
1.670 + if (retval != -1)
1.671 + return retval;
1.672 +
1.673 + TclWinConvertError(GetLastError());
1.674 + if (Tcl_GetErrno() == EBADF) {
1.675 + Tcl_SetErrno(EACCES);
1.676 + return TCL_ERROR;
1.677 + }
1.678 + if (Tcl_GetErrno() == EACCES) {
1.679 + DWORD srcAttr, dstAttr;
1.680 +
1.681 + srcAttr = (*tclWinProcs->getFileAttributesProc)(nativeSrc);
1.682 + dstAttr = (*tclWinProcs->getFileAttributesProc)(nativeDst);
1.683 + if (srcAttr != 0xffffffff) {
1.684 + if (dstAttr == 0xffffffff) {
1.685 + dstAttr = 0;
1.686 + }
1.687 + if ((srcAttr & FILE_ATTRIBUTE_DIRECTORY) ||
1.688 + (dstAttr & FILE_ATTRIBUTE_DIRECTORY)) {
1.689 + if (srcAttr & FILE_ATTRIBUTE_REPARSE_POINT) {
1.690 + /* Source is a symbolic link -- copy it */
1.691 + if (TclWinSymLinkCopyDirectory(nativeSrc, nativeDst) == 0) {
1.692 + return TCL_OK;
1.693 + }
1.694 + }
1.695 + Tcl_SetErrno(EISDIR);
1.696 + }
1.697 + if (dstAttr & FILE_ATTRIBUTE_READONLY) {
1.698 + (*tclWinProcs->setFileAttributesProc)(nativeDst,
1.699 + dstAttr & ~((DWORD)FILE_ATTRIBUTE_READONLY));
1.700 + if ((*tclWinProcs->copyFileProc)(nativeSrc, nativeDst, 0) != FALSE) {
1.701 + return TCL_OK;
1.702 + }
1.703 + /*
1.704 + * Still can't copy onto dst. Return that error, and
1.705 + * restore attributes of dst.
1.706 + */
1.707 +
1.708 + TclWinConvertError(GetLastError());
1.709 + (*tclWinProcs->setFileAttributesProc)(nativeDst, dstAttr);
1.710 + }
1.711 + }
1.712 + }
1.713 + return TCL_ERROR;
1.714 +}
1.715 +
1.716 +/*
1.717 + *---------------------------------------------------------------------------
1.718 + *
1.719 + * TclpObjDeleteFile, TclpDeleteFile --
1.720 + *
1.721 + * Removes a single file (not a directory).
1.722 + *
1.723 + * Results:
1.724 + * If the file was successfully deleted, returns TCL_OK. Otherwise
1.725 + * the return value is TCL_ERROR and errno is set to indicate the
1.726 + * error. Some possible values for errno are:
1.727 + *
1.728 + * EACCES: a parent directory can't be read and/or written.
1.729 + * EISDIR: path is a directory.
1.730 + * ENOENT: path doesn't exist or is "".
1.731 + *
1.732 + * EACCES: exists an open file already referring to path.
1.733 + * EACCES: path is a char device (nul:, com1:, etc.)
1.734 + *
1.735 + * Side effects:
1.736 + * The file is deleted, even if it is read-only.
1.737 + *
1.738 + *---------------------------------------------------------------------------
1.739 + */
1.740 +
1.741 +int
1.742 +TclpObjDeleteFile(pathPtr)
1.743 + Tcl_Obj *pathPtr;
1.744 +{
1.745 + return TclpDeleteFile(Tcl_FSGetNativePath(pathPtr));
1.746 +}
1.747 +
1.748 +int
1.749 +TclpDeleteFile(
1.750 + CONST TCHAR *nativePath) /* Pathname of file to be removed (native). */
1.751 +{
1.752 + DWORD attr;
1.753 +
1.754 + /*
1.755 + * The DeleteFile API acts differently under Win95/98 and NT
1.756 + * WRT NULL and "". Avoid passing these values.
1.757 + */
1.758 +
1.759 + if (nativePath == NULL || nativePath[0] == '\0') {
1.760 + Tcl_SetErrno(ENOENT);
1.761 + return TCL_ERROR;
1.762 + }
1.763 +
1.764 + if ((*tclWinProcs->deleteFileProc)(nativePath) != FALSE) {
1.765 + return TCL_OK;
1.766 + }
1.767 + TclWinConvertError(GetLastError());
1.768 +
1.769 + if (Tcl_GetErrno() == EACCES) {
1.770 + attr = (*tclWinProcs->getFileAttributesProc)(nativePath);
1.771 + if (attr != 0xffffffff) {
1.772 + if (attr & FILE_ATTRIBUTE_DIRECTORY) {
1.773 + if (attr & FILE_ATTRIBUTE_REPARSE_POINT) {
1.774 + /* It is a symbolic link -- remove it */
1.775 + if (TclWinSymLinkDelete(nativePath, 0) == 0) {
1.776 + return TCL_OK;
1.777 + }
1.778 + }
1.779 +
1.780 + /*
1.781 + * If we fall through here, it is a directory.
1.782 + *
1.783 + * Windows NT reports removing a directory as EACCES instead
1.784 + * of EISDIR.
1.785 + */
1.786 +
1.787 + Tcl_SetErrno(EISDIR);
1.788 + } else if (attr & FILE_ATTRIBUTE_READONLY) {
1.789 + int res = (*tclWinProcs->setFileAttributesProc)(nativePath,
1.790 + attr & ~((DWORD)FILE_ATTRIBUTE_READONLY));
1.791 + if ((res != 0) && ((*tclWinProcs->deleteFileProc)(nativePath)
1.792 + != FALSE)) {
1.793 + return TCL_OK;
1.794 + }
1.795 + TclWinConvertError(GetLastError());
1.796 + if (res != 0) {
1.797 + (*tclWinProcs->setFileAttributesProc)(nativePath, attr);
1.798 + }
1.799 + }
1.800 + }
1.801 + } else if (Tcl_GetErrno() == ENOENT) {
1.802 + attr = (*tclWinProcs->getFileAttributesProc)(nativePath);
1.803 + if (attr != 0xffffffff) {
1.804 + if (attr & FILE_ATTRIBUTE_DIRECTORY) {
1.805 + /*
1.806 + * Windows 95 reports removing a directory as ENOENT instead
1.807 + * of EISDIR.
1.808 + */
1.809 +
1.810 + Tcl_SetErrno(EISDIR);
1.811 + }
1.812 + }
1.813 + } else if (Tcl_GetErrno() == EINVAL) {
1.814 + /*
1.815 + * Windows NT reports removing a char device as EINVAL instead of
1.816 + * EACCES.
1.817 + */
1.818 +
1.819 + Tcl_SetErrno(EACCES);
1.820 + }
1.821 +
1.822 + return TCL_ERROR;
1.823 +}
1.824 +
1.825 +/*
1.826 + *---------------------------------------------------------------------------
1.827 + *
1.828 + * TclpObjCreateDirectory --
1.829 + *
1.830 + * Creates the specified directory. All parent directories of the
1.831 + * specified directory must already exist. The directory is
1.832 + * automatically created with permissions so that user can access
1.833 + * the new directory and create new files or subdirectories in it.
1.834 + *
1.835 + * Results:
1.836 + * If the directory was successfully created, returns TCL_OK.
1.837 + * Otherwise the return value is TCL_ERROR and errno is set to
1.838 + * indicate the error. Some possible values for errno are:
1.839 + *
1.840 + * EACCES: a parent directory can't be read and/or written.
1.841 + * EEXIST: path already exists.
1.842 + * ENOENT: a parent directory doesn't exist.
1.843 + *
1.844 + * Side effects:
1.845 + * A directory is created.
1.846 + *
1.847 + *---------------------------------------------------------------------------
1.848 + */
1.849 +
1.850 +int
1.851 +TclpObjCreateDirectory(pathPtr)
1.852 + Tcl_Obj *pathPtr;
1.853 +{
1.854 + return DoCreateDirectory(Tcl_FSGetNativePath(pathPtr));
1.855 +}
1.856 +
1.857 +static int
1.858 +DoCreateDirectory(
1.859 + CONST TCHAR *nativePath) /* Pathname of directory to create (native). */
1.860 +{
1.861 + DWORD error;
1.862 + if ((*tclWinProcs->createDirectoryProc)(nativePath, NULL) == 0) {
1.863 + error = GetLastError();
1.864 + TclWinConvertError(error);
1.865 + return TCL_ERROR;
1.866 + }
1.867 + return TCL_OK;
1.868 +}
1.869 +
1.870 +/*
1.871 + *---------------------------------------------------------------------------
1.872 + *
1.873 + * TclpObjCopyDirectory --
1.874 + *
1.875 + * Recursively copies a directory. The target directory dst must
1.876 + * not already exist. Note that this function does not merge two
1.877 + * directory hierarchies, even if the target directory is an an
1.878 + * empty directory.
1.879 + *
1.880 + * Results:
1.881 + * If the directory was successfully copied, returns TCL_OK.
1.882 + * Otherwise the return value is TCL_ERROR, errno is set to indicate
1.883 + * the error, and the pathname of the file that caused the error
1.884 + * is stored in errorPtr. See TclpCreateDirectory and TclpCopyFile
1.885 + * for a description of possible values for errno.
1.886 + *
1.887 + * Side effects:
1.888 + * An exact copy of the directory hierarchy src will be created
1.889 + * with the name dst. If an error occurs, the error will
1.890 + * be returned immediately, and remaining files will not be
1.891 + * processed.
1.892 + *
1.893 + *---------------------------------------------------------------------------
1.894 + */
1.895 +
1.896 +int
1.897 +TclpObjCopyDirectory(srcPathPtr, destPathPtr, errorPtr)
1.898 + Tcl_Obj *srcPathPtr;
1.899 + Tcl_Obj *destPathPtr;
1.900 + Tcl_Obj **errorPtr;
1.901 +{
1.902 + Tcl_DString ds;
1.903 + Tcl_DString srcString, dstString;
1.904 + Tcl_Obj *normSrcPtr, *normDestPtr;
1.905 + int ret;
1.906 +
1.907 + normSrcPtr = Tcl_FSGetNormalizedPath(NULL,srcPathPtr);
1.908 + if (normSrcPtr == NULL) {
1.909 + return TCL_ERROR;
1.910 + }
1.911 + Tcl_WinUtfToTChar(Tcl_GetString(normSrcPtr), -1, &srcString);
1.912 + normDestPtr = Tcl_FSGetNormalizedPath(NULL,destPathPtr);
1.913 + if (normDestPtr == NULL) {
1.914 + return TCL_ERROR;
1.915 + }
1.916 + Tcl_WinUtfToTChar(Tcl_GetString(normDestPtr), -1, &dstString);
1.917 +
1.918 + ret = TraverseWinTree(TraversalCopy, &srcString, &dstString, &ds);
1.919 +
1.920 + Tcl_DStringFree(&srcString);
1.921 + Tcl_DStringFree(&dstString);
1.922 +
1.923 + if (ret != TCL_OK) {
1.924 + if (!strcmp(Tcl_DStringValue(&ds), Tcl_GetString(normSrcPtr))) {
1.925 + *errorPtr = srcPathPtr;
1.926 + } else if (!strcmp(Tcl_DStringValue(&ds), Tcl_GetString(normDestPtr))) {
1.927 + *errorPtr = destPathPtr;
1.928 + } else {
1.929 + *errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1);
1.930 + }
1.931 + Tcl_DStringFree(&ds);
1.932 + Tcl_IncrRefCount(*errorPtr);
1.933 + }
1.934 + return ret;
1.935 +}
1.936 +
1.937 +/*
1.938 + *----------------------------------------------------------------------
1.939 + *
1.940 + * TclpObjRemoveDirectory, DoRemoveDirectory --
1.941 + *
1.942 + * Removes directory (and its contents, if the recursive flag is set).
1.943 + *
1.944 + * Results:
1.945 + * If the directory was successfully removed, returns TCL_OK.
1.946 + * Otherwise the return value is TCL_ERROR, errno is set to indicate
1.947 + * the error, and the pathname of the file that caused the error
1.948 + * is stored in errorPtr. Some possible values for errno are:
1.949 + *
1.950 + * EACCES: path directory can't be read and/or written.
1.951 + * EEXIST: path is a non-empty directory.
1.952 + * EINVAL: path is root directory or current directory.
1.953 + * ENOENT: path doesn't exist or is "".
1.954 + * ENOTDIR: path is not a directory.
1.955 + *
1.956 + * EACCES: path is a char device (nul:, com1:, etc.) (95)
1.957 + * EINVAL: path is a char device (nul:, com1:, etc.) (NT)
1.958 + *
1.959 + * Side effects:
1.960 + * Directory removed. If an error occurs, the error will be returned
1.961 + * immediately, and remaining files will not be deleted.
1.962 + *
1.963 + *----------------------------------------------------------------------
1.964 + */
1.965 +
1.966 +int
1.967 +TclpObjRemoveDirectory(pathPtr, recursive, errorPtr)
1.968 + Tcl_Obj *pathPtr;
1.969 + int recursive;
1.970 + Tcl_Obj **errorPtr;
1.971 +{
1.972 + Tcl_DString ds;
1.973 + Tcl_Obj *normPtr = NULL;
1.974 + int ret;
1.975 + if (recursive) {
1.976 + /*
1.977 + * In the recursive case, the string rep is used to construct a
1.978 + * Tcl_DString which may be used extensively, so we can't
1.979 + * optimize this case easily.
1.980 + */
1.981 + Tcl_DString native;
1.982 + normPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
1.983 + if (normPtr == NULL) {
1.984 + return TCL_ERROR;
1.985 + }
1.986 + Tcl_WinUtfToTChar(Tcl_GetString(normPtr), -1, &native);
1.987 + ret = DoRemoveDirectory(&native, recursive, &ds);
1.988 + Tcl_DStringFree(&native);
1.989 + } else {
1.990 + ret = DoRemoveJustDirectory(Tcl_FSGetNativePath(pathPtr),
1.991 + 0, &ds);
1.992 + }
1.993 + if (ret != TCL_OK) {
1.994 + int len = Tcl_DStringLength(&ds);
1.995 + if (len > 0) {
1.996 + if (normPtr != NULL
1.997 + && !strcmp(Tcl_DStringValue(&ds), Tcl_GetString(normPtr))) {
1.998 + *errorPtr = pathPtr;
1.999 + } else {
1.1000 + *errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1);
1.1001 + }
1.1002 + Tcl_IncrRefCount(*errorPtr);
1.1003 + }
1.1004 + Tcl_DStringFree(&ds);
1.1005 + }
1.1006 + return ret;
1.1007 +}
1.1008 +
1.1009 +static int
1.1010 +DoRemoveJustDirectory(
1.1011 + CONST TCHAR *nativePath, /* Pathname of directory to be removed
1.1012 + * (native). */
1.1013 + int ignoreError, /* If non-zero, don't initialize the
1.1014 + * errorPtr under some circumstances
1.1015 + * on return. */
1.1016 + Tcl_DString *errorPtr) /* If non-NULL, uninitialized or free
1.1017 + * DString filled with UTF-8 name of file
1.1018 + * causing error. */
1.1019 +{
1.1020 + /*
1.1021 + * The RemoveDirectory API acts differently under Win95/98 and NT
1.1022 + * WRT NULL and "". Avoid passing these values.
1.1023 + */
1.1024 +
1.1025 + if (nativePath == NULL || nativePath[0] == '\0') {
1.1026 + Tcl_SetErrno(ENOENT);
1.1027 + goto end;
1.1028 + }
1.1029 +
1.1030 + if ((*tclWinProcs->removeDirectoryProc)(nativePath) != FALSE) {
1.1031 + return TCL_OK;
1.1032 + }
1.1033 + TclWinConvertError(GetLastError());
1.1034 +
1.1035 + if (Tcl_GetErrno() == EACCES) {
1.1036 + DWORD attr = (*tclWinProcs->getFileAttributesProc)(nativePath);
1.1037 + if (attr != 0xffffffff) {
1.1038 + if ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0) {
1.1039 + /*
1.1040 + * Windows 95 reports calling RemoveDirectory on a file as an
1.1041 + * EACCES, not an ENOTDIR.
1.1042 + */
1.1043 +
1.1044 + Tcl_SetErrno(ENOTDIR);
1.1045 + goto end;
1.1046 + }
1.1047 +
1.1048 + if (attr & FILE_ATTRIBUTE_REPARSE_POINT) {
1.1049 + /* It is a symbolic link -- remove it */
1.1050 + if (TclWinSymLinkDelete(nativePath, 1) != 0) {
1.1051 + goto end;
1.1052 + }
1.1053 + }
1.1054 +
1.1055 + if (attr & FILE_ATTRIBUTE_READONLY) {
1.1056 + attr &= ~FILE_ATTRIBUTE_READONLY;
1.1057 + if ((*tclWinProcs->setFileAttributesProc)(nativePath, attr) == FALSE) {
1.1058 + goto end;
1.1059 + }
1.1060 + if ((*tclWinProcs->removeDirectoryProc)(nativePath) != FALSE) {
1.1061 + return TCL_OK;
1.1062 + }
1.1063 + TclWinConvertError(GetLastError());
1.1064 + (*tclWinProcs->setFileAttributesProc)(nativePath,
1.1065 + attr | FILE_ATTRIBUTE_READONLY);
1.1066 + }
1.1067 +
1.1068 + /*
1.1069 + * Windows 95 and Win32s report removing a non-empty directory
1.1070 + * as EACCES, not EEXIST. If the directory is not empty,
1.1071 + * change errno so caller knows what's going on.
1.1072 + */
1.1073 +
1.1074 + if (TclWinGetPlatformId() != VER_PLATFORM_WIN32_NT) {
1.1075 + CONST char *path, *find;
1.1076 + HANDLE handle;
1.1077 + WIN32_FIND_DATAA data;
1.1078 + Tcl_DString buffer;
1.1079 + int len;
1.1080 +
1.1081 + path = (CONST char *) nativePath;
1.1082 +
1.1083 + Tcl_DStringInit(&buffer);
1.1084 + len = strlen(path);
1.1085 + find = Tcl_DStringAppend(&buffer, path, len);
1.1086 + if ((len > 0) && (find[len - 1] != '\\')) {
1.1087 + Tcl_DStringAppend(&buffer, "\\", 1);
1.1088 + }
1.1089 + find = Tcl_DStringAppend(&buffer, "*.*", 3);
1.1090 + handle = FindFirstFileA(find, &data);
1.1091 + if (handle != INVALID_HANDLE_VALUE) {
1.1092 + while (1) {
1.1093 + if ((strcmp(data.cFileName, ".") != 0)
1.1094 + && (strcmp(data.cFileName, "..") != 0)) {
1.1095 + /*
1.1096 + * Found something in this directory.
1.1097 + */
1.1098 +
1.1099 + Tcl_SetErrno(EEXIST);
1.1100 + break;
1.1101 + }
1.1102 + if (FindNextFileA(handle, &data) == FALSE) {
1.1103 + break;
1.1104 + }
1.1105 + }
1.1106 + FindClose(handle);
1.1107 + }
1.1108 + Tcl_DStringFree(&buffer);
1.1109 + }
1.1110 + }
1.1111 + }
1.1112 + if (Tcl_GetErrno() == ENOTEMPTY) {
1.1113 + /*
1.1114 + * The caller depends on EEXIST to signify that the directory is
1.1115 + * not empty, not ENOTEMPTY.
1.1116 + */
1.1117 +
1.1118 + Tcl_SetErrno(EEXIST);
1.1119 + }
1.1120 + if ((ignoreError != 0) && (Tcl_GetErrno() == EEXIST)) {
1.1121 + /*
1.1122 + * If we're being recursive, this error may actually
1.1123 + * be ok, so we don't want to initialise the errorPtr
1.1124 + * yet.
1.1125 + */
1.1126 + return TCL_ERROR;
1.1127 + }
1.1128 +
1.1129 + end:
1.1130 + if (errorPtr != NULL) {
1.1131 + Tcl_WinTCharToUtf(nativePath, -1, errorPtr);
1.1132 + }
1.1133 + return TCL_ERROR;
1.1134 +
1.1135 +}
1.1136 +
1.1137 +static int
1.1138 +DoRemoveDirectory(
1.1139 + Tcl_DString *pathPtr, /* Pathname of directory to be removed
1.1140 + * (native). */
1.1141 + int recursive, /* If non-zero, removes directories that
1.1142 + * are nonempty. Otherwise, will only remove
1.1143 + * empty directories. */
1.1144 + Tcl_DString *errorPtr) /* If non-NULL, uninitialized or free
1.1145 + * DString filled with UTF-8 name of file
1.1146 + * causing error. */
1.1147 +{
1.1148 + int res = DoRemoveJustDirectory(Tcl_DStringValue(pathPtr), recursive,
1.1149 + errorPtr);
1.1150 +
1.1151 + if ((res == TCL_ERROR) && (recursive != 0) && (Tcl_GetErrno() == EEXIST)) {
1.1152 + /*
1.1153 + * The directory is nonempty, but the recursive flag has been
1.1154 + * specified, so we recursively remove all the files in the directory.
1.1155 + */
1.1156 + return TraverseWinTree(TraversalDelete, pathPtr, NULL, errorPtr);
1.1157 + } else {
1.1158 + return res;
1.1159 + }
1.1160 +}
1.1161 +
1.1162 +/*
1.1163 + *---------------------------------------------------------------------------
1.1164 + *
1.1165 + * TraverseWinTree --
1.1166 + *
1.1167 + * Traverse directory tree specified by sourcePtr, calling the function
1.1168 + * traverseProc for each file and directory encountered. If destPtr
1.1169 + * is non-null, each of name in the sourcePtr directory is appended to
1.1170 + * the directory specified by destPtr and passed as the second argument
1.1171 + * to traverseProc() .
1.1172 + *
1.1173 + * Results:
1.1174 + * Standard Tcl result.
1.1175 + *
1.1176 + * Side effects:
1.1177 + * None caused by TraverseWinTree, however the user specified
1.1178 + * traverseProc() may change state. If an error occurs, the error will
1.1179 + * be returned immediately, and remaining files will not be processed.
1.1180 + *
1.1181 + *---------------------------------------------------------------------------
1.1182 + */
1.1183 +
1.1184 +static int
1.1185 +TraverseWinTree(
1.1186 + TraversalProc *traverseProc,/* Function to call for every file and
1.1187 + * directory in source hierarchy. */
1.1188 + Tcl_DString *sourcePtr, /* Pathname of source directory to be
1.1189 + * traversed (native). */
1.1190 + Tcl_DString *targetPtr, /* Pathname of directory to traverse in
1.1191 + * parallel with source directory (native),
1.1192 + * may be NULL. */
1.1193 + Tcl_DString *errorPtr) /* If non-NULL, uninitialized or free
1.1194 + * DString filled with UTF-8 name of file
1.1195 + * causing error. */
1.1196 +{
1.1197 + DWORD sourceAttr;
1.1198 + TCHAR *nativeSource, *nativeTarget, *nativeErrfile;
1.1199 + int result, found, sourceLen, targetLen, oldSourceLen, oldTargetLen;
1.1200 + HANDLE handle;
1.1201 + WIN32_FIND_DATAT data;
1.1202 +
1.1203 + nativeErrfile = NULL;
1.1204 + result = TCL_OK;
1.1205 + oldTargetLen = 0; /* lint. */
1.1206 +
1.1207 + nativeSource = (TCHAR *) Tcl_DStringValue(sourcePtr);
1.1208 + nativeTarget = (TCHAR *) (targetPtr == NULL
1.1209 + ? NULL : Tcl_DStringValue(targetPtr));
1.1210 +
1.1211 + oldSourceLen = Tcl_DStringLength(sourcePtr);
1.1212 + sourceAttr = (*tclWinProcs->getFileAttributesProc)(nativeSource);
1.1213 + if (sourceAttr == 0xffffffff) {
1.1214 + nativeErrfile = nativeSource;
1.1215 + goto end;
1.1216 + }
1.1217 + if ((sourceAttr & FILE_ATTRIBUTE_DIRECTORY) == 0) {
1.1218 + /*
1.1219 + * Process the regular file
1.1220 + */
1.1221 +
1.1222 + return (*traverseProc)(nativeSource, nativeTarget, DOTREE_F, errorPtr);
1.1223 + }
1.1224 +
1.1225 + if (tclWinProcs->useWide) {
1.1226 + Tcl_DStringAppend(sourcePtr, (char *) L"\\*.*", 4 * sizeof(WCHAR) + 1);
1.1227 + Tcl_DStringSetLength(sourcePtr, Tcl_DStringLength(sourcePtr) - 1);
1.1228 + } else {
1.1229 + Tcl_DStringAppend(sourcePtr, "\\*.*", 4);
1.1230 + }
1.1231 + nativeSource = (TCHAR *) Tcl_DStringValue(sourcePtr);
1.1232 + handle = (*tclWinProcs->findFirstFileProc)(nativeSource, &data);
1.1233 + if (handle == INVALID_HANDLE_VALUE) {
1.1234 + /*
1.1235 + * Can't read directory
1.1236 + */
1.1237 +
1.1238 + TclWinConvertError(GetLastError());
1.1239 + nativeErrfile = nativeSource;
1.1240 + goto end;
1.1241 + }
1.1242 +
1.1243 + nativeSource[oldSourceLen + 1] = '\0';
1.1244 + Tcl_DStringSetLength(sourcePtr, oldSourceLen);
1.1245 + result = (*traverseProc)(nativeSource, nativeTarget, DOTREE_PRED, errorPtr);
1.1246 + if (result != TCL_OK) {
1.1247 + FindClose(handle);
1.1248 + return result;
1.1249 + }
1.1250 +
1.1251 + sourceLen = oldSourceLen;
1.1252 +
1.1253 + if (tclWinProcs->useWide) {
1.1254 + sourceLen += sizeof(WCHAR);
1.1255 + Tcl_DStringAppend(sourcePtr, (char *) L"\\", sizeof(WCHAR) + 1);
1.1256 + Tcl_DStringSetLength(sourcePtr, sourceLen);
1.1257 + } else {
1.1258 + sourceLen += 1;
1.1259 + Tcl_DStringAppend(sourcePtr, "\\", 1);
1.1260 + }
1.1261 + if (targetPtr != NULL) {
1.1262 + oldTargetLen = Tcl_DStringLength(targetPtr);
1.1263 +
1.1264 + targetLen = oldTargetLen;
1.1265 + if (tclWinProcs->useWide) {
1.1266 + targetLen += sizeof(WCHAR);
1.1267 + Tcl_DStringAppend(targetPtr, (char *) L"\\", sizeof(WCHAR) + 1);
1.1268 + Tcl_DStringSetLength(targetPtr, targetLen);
1.1269 + } else {
1.1270 + targetLen += 1;
1.1271 + Tcl_DStringAppend(targetPtr, "\\", 1);
1.1272 + }
1.1273 + }
1.1274 +
1.1275 + found = 1;
1.1276 + for ( ; found; found = (*tclWinProcs->findNextFileProc)(handle, &data)) {
1.1277 + TCHAR *nativeName;
1.1278 + int len;
1.1279 +
1.1280 + if (tclWinProcs->useWide) {
1.1281 + WCHAR *wp;
1.1282 +
1.1283 + wp = data.w.cFileName;
1.1284 + if (*wp == '.') {
1.1285 + wp++;
1.1286 + if (*wp == '.') {
1.1287 + wp++;
1.1288 + }
1.1289 + if (*wp == '\0') {
1.1290 + continue;
1.1291 + }
1.1292 + }
1.1293 + nativeName = (TCHAR *) data.w.cFileName;
1.1294 + len = wcslen(data.w.cFileName) * sizeof(WCHAR);
1.1295 + } else {
1.1296 + if ((strcmp(data.a.cFileName, ".") == 0)
1.1297 + || (strcmp(data.a.cFileName, "..") == 0)) {
1.1298 + continue;
1.1299 + }
1.1300 + nativeName = (TCHAR *) data.a.cFileName;
1.1301 + len = strlen(data.a.cFileName);
1.1302 + }
1.1303 +
1.1304 + /*
1.1305 + * Append name after slash, and recurse on the file.
1.1306 + */
1.1307 +
1.1308 + Tcl_DStringAppend(sourcePtr, (char *) nativeName, len + 1);
1.1309 + Tcl_DStringSetLength(sourcePtr, Tcl_DStringLength(sourcePtr) - 1);
1.1310 + if (targetPtr != NULL) {
1.1311 + Tcl_DStringAppend(targetPtr, (char *) nativeName, len + 1);
1.1312 + Tcl_DStringSetLength(targetPtr, Tcl_DStringLength(targetPtr) - 1);
1.1313 + }
1.1314 + result = TraverseWinTree(traverseProc, sourcePtr, targetPtr,
1.1315 + errorPtr);
1.1316 + if (result != TCL_OK) {
1.1317 + break;
1.1318 + }
1.1319 +
1.1320 + /*
1.1321 + * Remove name after slash.
1.1322 + */
1.1323 +
1.1324 + Tcl_DStringSetLength(sourcePtr, sourceLen);
1.1325 + if (targetPtr != NULL) {
1.1326 + Tcl_DStringSetLength(targetPtr, targetLen);
1.1327 + }
1.1328 + }
1.1329 + FindClose(handle);
1.1330 +
1.1331 + /*
1.1332 + * Strip off the trailing slash we added
1.1333 + */
1.1334 +
1.1335 + Tcl_DStringSetLength(sourcePtr, oldSourceLen + 1);
1.1336 + Tcl_DStringSetLength(sourcePtr, oldSourceLen);
1.1337 + if (targetPtr != NULL) {
1.1338 + Tcl_DStringSetLength(targetPtr, oldTargetLen + 1);
1.1339 + Tcl_DStringSetLength(targetPtr, oldTargetLen);
1.1340 + }
1.1341 + if (result == TCL_OK) {
1.1342 + /*
1.1343 + * Call traverseProc() on a directory after visiting all the
1.1344 + * files in that directory.
1.1345 + */
1.1346 +
1.1347 + result = (*traverseProc)(Tcl_DStringValue(sourcePtr),
1.1348 + (targetPtr == NULL ? NULL : Tcl_DStringValue(targetPtr)),
1.1349 + DOTREE_POSTD, errorPtr);
1.1350 + }
1.1351 + end:
1.1352 + if (nativeErrfile != NULL) {
1.1353 + TclWinConvertError(GetLastError());
1.1354 + if (errorPtr != NULL) {
1.1355 + Tcl_WinTCharToUtf(nativeErrfile, -1, errorPtr);
1.1356 + }
1.1357 + result = TCL_ERROR;
1.1358 + }
1.1359 +
1.1360 + return result;
1.1361 +}
1.1362 +
1.1363 +/*
1.1364 + *----------------------------------------------------------------------
1.1365 + *
1.1366 + * TraversalCopy
1.1367 + *
1.1368 + * Called from TraverseUnixTree in order to execute a recursive
1.1369 + * copy of a directory.
1.1370 + *
1.1371 + * Results:
1.1372 + * Standard Tcl result.
1.1373 + *
1.1374 + * Side effects:
1.1375 + * Depending on the value of type, src may be copied to dst.
1.1376 + *
1.1377 + *----------------------------------------------------------------------
1.1378 + */
1.1379 +
1.1380 +static int
1.1381 +TraversalCopy(
1.1382 + CONST TCHAR *nativeSrc, /* Source pathname to copy. */
1.1383 + CONST TCHAR *nativeDst, /* Destination pathname of copy. */
1.1384 + int type, /* Reason for call - see TraverseWinTree() */
1.1385 + Tcl_DString *errorPtr) /* If non-NULL, initialized DString filled
1.1386 + * with UTF-8 name of file causing error. */
1.1387 +{
1.1388 + switch (type) {
1.1389 + case DOTREE_F: {
1.1390 + if (DoCopyFile(nativeSrc, nativeDst) == TCL_OK) {
1.1391 + return TCL_OK;
1.1392 + }
1.1393 + break;
1.1394 + }
1.1395 + case DOTREE_PRED: {
1.1396 + if (DoCreateDirectory(nativeDst) == TCL_OK) {
1.1397 + DWORD attr = (*tclWinProcs->getFileAttributesProc)(nativeSrc);
1.1398 + if ((*tclWinProcs->setFileAttributesProc)(nativeDst, attr) != FALSE) {
1.1399 + return TCL_OK;
1.1400 + }
1.1401 + TclWinConvertError(GetLastError());
1.1402 + }
1.1403 + break;
1.1404 + }
1.1405 + case DOTREE_POSTD: {
1.1406 + return TCL_OK;
1.1407 + }
1.1408 + }
1.1409 +
1.1410 + /*
1.1411 + * There shouldn't be a problem with src, because we already
1.1412 + * checked it to get here.
1.1413 + */
1.1414 +
1.1415 + if (errorPtr != NULL) {
1.1416 + Tcl_WinTCharToUtf(nativeDst, -1, errorPtr);
1.1417 + }
1.1418 + return TCL_ERROR;
1.1419 +}
1.1420 +
1.1421 +/*
1.1422 + *----------------------------------------------------------------------
1.1423 + *
1.1424 + * TraversalDelete --
1.1425 + *
1.1426 + * Called by procedure TraverseWinTree for every file and
1.1427 + * directory that it encounters in a directory hierarchy. This
1.1428 + * procedure unlinks files, and removes directories after all the
1.1429 + * containing files have been processed.
1.1430 + *
1.1431 + * Results:
1.1432 + * Standard Tcl result.
1.1433 + *
1.1434 + * Side effects:
1.1435 + * Files or directory specified by src will be deleted. If an
1.1436 + * error occurs, the windows error is converted to a Posix error
1.1437 + * and errno is set accordingly.
1.1438 + *
1.1439 + *----------------------------------------------------------------------
1.1440 + */
1.1441 +
1.1442 +static int
1.1443 +TraversalDelete(
1.1444 + CONST TCHAR *nativeSrc, /* Source pathname to delete. */
1.1445 + CONST TCHAR *dstPtr, /* Not used. */
1.1446 + int type, /* Reason for call - see TraverseWinTree() */
1.1447 + Tcl_DString *errorPtr) /* If non-NULL, initialized DString filled
1.1448 + * with UTF-8 name of file causing error. */
1.1449 +{
1.1450 + switch (type) {
1.1451 + case DOTREE_F: {
1.1452 + if (TclpDeleteFile(nativeSrc) == TCL_OK) {
1.1453 + return TCL_OK;
1.1454 + }
1.1455 + break;
1.1456 + }
1.1457 + case DOTREE_PRED: {
1.1458 + return TCL_OK;
1.1459 + }
1.1460 + case DOTREE_POSTD: {
1.1461 + if (DoRemoveJustDirectory(nativeSrc, 0, NULL) == TCL_OK) {
1.1462 + return TCL_OK;
1.1463 + }
1.1464 + break;
1.1465 + }
1.1466 + }
1.1467 +
1.1468 + if (errorPtr != NULL) {
1.1469 + Tcl_WinTCharToUtf(nativeSrc, -1, errorPtr);
1.1470 + }
1.1471 + return TCL_ERROR;
1.1472 +}
1.1473 +
1.1474 +/*
1.1475 + *----------------------------------------------------------------------
1.1476 + *
1.1477 + * StatError --
1.1478 + *
1.1479 + * Sets the object result with the appropriate error.
1.1480 + *
1.1481 + * Results:
1.1482 + * None.
1.1483 + *
1.1484 + * Side effects:
1.1485 + * The interp's object result is set with an error message
1.1486 + * based on the objIndex, fileName and errno.
1.1487 + *
1.1488 + *----------------------------------------------------------------------
1.1489 + */
1.1490 +
1.1491 +static void
1.1492 +StatError(
1.1493 + Tcl_Interp *interp, /* The interp that has the error */
1.1494 + Tcl_Obj *fileName) /* The name of the file which caused the
1.1495 + * error. */
1.1496 +{
1.1497 + TclWinConvertError(GetLastError());
1.1498 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.1499 + "could not read \"", Tcl_GetString(fileName),
1.1500 + "\": ", Tcl_PosixError(interp),
1.1501 + (char *) NULL);
1.1502 +}
1.1503 +
1.1504 +/*
1.1505 + *----------------------------------------------------------------------
1.1506 + *
1.1507 + * GetWinFileAttributes --
1.1508 + *
1.1509 + * Returns a Tcl_Obj containing the value of a file attribute.
1.1510 + * This routine gets the -hidden, -readonly or -system attribute.
1.1511 + *
1.1512 + * Results:
1.1513 + * Standard Tcl result and a Tcl_Obj in attributePtrPtr. The object
1.1514 + * will have ref count 0. If the return value is not TCL_OK,
1.1515 + * attributePtrPtr is not touched.
1.1516 + *
1.1517 + * Side effects:
1.1518 + * A new object is allocated if the file is valid.
1.1519 + *
1.1520 + *----------------------------------------------------------------------
1.1521 + */
1.1522 +
1.1523 +static int
1.1524 +GetWinFileAttributes(
1.1525 + Tcl_Interp *interp, /* The interp we are using for errors. */
1.1526 + int objIndex, /* The index of the attribute. */
1.1527 + Tcl_Obj *fileName, /* The name of the file. */
1.1528 + Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */
1.1529 +{
1.1530 + DWORD result;
1.1531 + CONST TCHAR *nativeName;
1.1532 + int attr;
1.1533 +
1.1534 + nativeName = Tcl_FSGetNativePath(fileName);
1.1535 + result = (*tclWinProcs->getFileAttributesProc)(nativeName);
1.1536 +
1.1537 + if (result == 0xffffffff) {
1.1538 + StatError(interp, fileName);
1.1539 + return TCL_ERROR;
1.1540 + }
1.1541 +
1.1542 + attr = (int)(result & attributeArray[objIndex]);
1.1543 + if ((objIndex == WIN_HIDDEN_ATTRIBUTE) && (attr != 0)) {
1.1544 + /*
1.1545 + * It is hidden. However there is a bug on some Windows
1.1546 + * OSes in which root volumes (drives) formatted as NTFS
1.1547 + * are declared hidden when they are not (and cannot be).
1.1548 + *
1.1549 + * We test for, and fix that case, here.
1.1550 + */
1.1551 + int len;
1.1552 + char *str = Tcl_GetStringFromObj(fileName,&len);
1.1553 + if (len < 4) {
1.1554 + if (len == 0) {
1.1555 + /*
1.1556 + * Not sure if this is possible, but we pass it on
1.1557 + * anyway
1.1558 + */
1.1559 + } else if (len == 1 && (str[0] == '/' || str[0] == '\\')) {
1.1560 + /* Path is pointing to the root volume */
1.1561 + attr = 0;
1.1562 + } else if ((str[1] == ':')
1.1563 + && (len == 2 || (str[2] == '/' || str[2] == '\\'))) {
1.1564 + /* Path is of the form 'x:' or 'x:/' or 'x:\' */
1.1565 + attr = 0;
1.1566 + }
1.1567 + }
1.1568 + }
1.1569 + *attributePtrPtr = Tcl_NewBooleanObj(attr);
1.1570 + return TCL_OK;
1.1571 +}
1.1572 +
1.1573 +/*
1.1574 + *----------------------------------------------------------------------
1.1575 + *
1.1576 + * ConvertFileNameFormat --
1.1577 + *
1.1578 + * Returns a Tcl_Obj containing either the long or short version of the
1.1579 + * file name.
1.1580 + *
1.1581 + * Results:
1.1582 + * Standard Tcl result and a Tcl_Obj in attributePtrPtr. The object
1.1583 + * will have ref count 0. If the return value is not TCL_OK,
1.1584 + * attributePtrPtr is not touched.
1.1585 + *
1.1586 + * Warning: if you pass this function a drive name like 'c:' it
1.1587 + * will actually return the current working directory on that
1.1588 + * drive. To avoid this, make sure the drive name ends in a
1.1589 + * slash, like this 'c:/'.
1.1590 + *
1.1591 + * Side effects:
1.1592 + * A new object is allocated if the file is valid.
1.1593 + *
1.1594 + *----------------------------------------------------------------------
1.1595 + */
1.1596 +
1.1597 +static int
1.1598 +ConvertFileNameFormat(
1.1599 + Tcl_Interp *interp, /* The interp we are using for errors. */
1.1600 + int objIndex, /* The index of the attribute. */
1.1601 + Tcl_Obj *fileName, /* The name of the file. */
1.1602 + int longShort, /* 0 to short name, 1 to long name. */
1.1603 + Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */
1.1604 +{
1.1605 + int pathc, i;
1.1606 + Tcl_Obj *splitPath;
1.1607 + int result = TCL_OK;
1.1608 +
1.1609 + splitPath = Tcl_FSSplitPath(fileName, &pathc);
1.1610 +
1.1611 + if (splitPath == NULL || pathc == 0) {
1.1612 + if (interp != NULL) {
1.1613 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.1614 + "could not read \"", Tcl_GetString(fileName),
1.1615 + "\": no such file or directory",
1.1616 + (char *) NULL);
1.1617 + }
1.1618 + result = TCL_ERROR;
1.1619 + goto cleanup;
1.1620 + }
1.1621 +
1.1622 + for (i = 0; i < pathc; i++) {
1.1623 + Tcl_Obj *elt;
1.1624 + char *pathv;
1.1625 + int pathLen;
1.1626 + Tcl_ListObjIndex(NULL, splitPath, i, &elt);
1.1627 +
1.1628 + pathv = Tcl_GetStringFromObj(elt, &pathLen);
1.1629 + if ((pathv[0] == '/')
1.1630 + || ((pathLen == 3) && (pathv[1] == ':'))
1.1631 + || (strcmp(pathv, ".") == 0)
1.1632 + || (strcmp(pathv, "..") == 0)) {
1.1633 + /*
1.1634 + * Handle "/", "//machine/export", "c:/", "." or ".." by just
1.1635 + * copying the string literally. Uppercase the drive letter,
1.1636 + * just because it looks better under Windows to do so.
1.1637 + */
1.1638 +
1.1639 + simple:
1.1640 + /* Here we are modifying the string representation in place */
1.1641 + /* I believe this is legal, since this won't affect any
1.1642 + * file representation this thing may have. */
1.1643 + pathv[0] = (char) Tcl_UniCharToUpper(UCHAR(pathv[0]));
1.1644 + } else {
1.1645 + Tcl_Obj *tempPath;
1.1646 + Tcl_DString ds;
1.1647 + Tcl_DString dsTemp;
1.1648 + TCHAR *nativeName;
1.1649 + char *tempString;
1.1650 + int tempLen;
1.1651 + WIN32_FIND_DATAT data;
1.1652 + HANDLE handle;
1.1653 + DWORD attr;
1.1654 +
1.1655 + tempPath = Tcl_FSJoinPath(splitPath, i+1);
1.1656 + Tcl_IncrRefCount(tempPath);
1.1657 + /*
1.1658 + * We'd like to call Tcl_FSGetNativePath(tempPath)
1.1659 + * but that is likely to lead to infinite loops
1.1660 + */
1.1661 + Tcl_DStringInit(&ds);
1.1662 + tempString = Tcl_GetStringFromObj(tempPath,&tempLen);
1.1663 + nativeName = Tcl_WinUtfToTChar(tempString, tempLen, &ds);
1.1664 + Tcl_DecrRefCount(tempPath);
1.1665 + handle = (*tclWinProcs->findFirstFileProc)(nativeName, &data);
1.1666 + if (handle == INVALID_HANDLE_VALUE) {
1.1667 + /*
1.1668 + * FindFirstFile() doesn't like root directories. We
1.1669 + * would only get a root directory here if the caller
1.1670 + * specified "c:" or "c:." and the current directory on the
1.1671 + * drive was the root directory
1.1672 + */
1.1673 +
1.1674 + attr = (*tclWinProcs->getFileAttributesProc)(nativeName);
1.1675 + if ((attr != 0xFFFFFFFF) && (attr & FILE_ATTRIBUTE_DIRECTORY)) {
1.1676 + Tcl_DStringFree(&ds);
1.1677 + goto simple;
1.1678 + }
1.1679 + }
1.1680 +
1.1681 + if (handle == INVALID_HANDLE_VALUE) {
1.1682 + Tcl_DStringFree(&ds);
1.1683 + if (interp != NULL) {
1.1684 + StatError(interp, fileName);
1.1685 + }
1.1686 + result = TCL_ERROR;
1.1687 + goto cleanup;
1.1688 + }
1.1689 + if (tclWinProcs->useWide) {
1.1690 + nativeName = (TCHAR *) data.w.cAlternateFileName;
1.1691 + if (longShort) {
1.1692 + if (data.w.cFileName[0] != '\0') {
1.1693 + nativeName = (TCHAR *) data.w.cFileName;
1.1694 + }
1.1695 + } else {
1.1696 + if (data.w.cAlternateFileName[0] == '\0') {
1.1697 + nativeName = (TCHAR *) data.w.cFileName;
1.1698 + }
1.1699 + }
1.1700 + } else {
1.1701 + nativeName = (TCHAR *) data.a.cAlternateFileName;
1.1702 + if (longShort) {
1.1703 + if (data.a.cFileName[0] != '\0') {
1.1704 + nativeName = (TCHAR *) data.a.cFileName;
1.1705 + }
1.1706 + } else {
1.1707 + if (data.a.cAlternateFileName[0] == '\0') {
1.1708 + nativeName = (TCHAR *) data.a.cFileName;
1.1709 + }
1.1710 + }
1.1711 + }
1.1712 +
1.1713 + /*
1.1714 + * Purify reports a extraneous UMR in Tcl_WinTCharToUtf() trying
1.1715 + * to dereference nativeName as a Unicode string. I have proven
1.1716 + * to myself that purify is wrong by running the following
1.1717 + * example when nativeName == data.w.cAlternateFileName and
1.1718 + * noting that purify doesn't complain about the first line,
1.1719 + * but does complain about the second.
1.1720 + *
1.1721 + * fprintf(stderr, "%d\n", data.w.cAlternateFileName[0]);
1.1722 + * fprintf(stderr, "%d\n", ((WCHAR *) nativeName)[0]);
1.1723 + */
1.1724 +
1.1725 + Tcl_DStringInit(&dsTemp);
1.1726 + Tcl_WinTCharToUtf(nativeName, -1, &dsTemp);
1.1727 + /* Deal with issues of tildes being absolute */
1.1728 + if (Tcl_DStringValue(&dsTemp)[0] == '~') {
1.1729 + tempPath = Tcl_NewStringObj("./",2);
1.1730 + Tcl_AppendToObj(tempPath, Tcl_DStringValue(&dsTemp),
1.1731 + Tcl_DStringLength(&dsTemp));
1.1732 + } else {
1.1733 + tempPath = Tcl_NewStringObj(Tcl_DStringValue(&dsTemp),
1.1734 + Tcl_DStringLength(&dsTemp));
1.1735 + }
1.1736 + Tcl_ListObjReplace(NULL, splitPath, i, 1, 1, &tempPath);
1.1737 + Tcl_DStringFree(&ds);
1.1738 + Tcl_DStringFree(&dsTemp);
1.1739 + FindClose(handle);
1.1740 + }
1.1741 + }
1.1742 +
1.1743 + *attributePtrPtr = Tcl_FSJoinPath(splitPath, -1);
1.1744 +
1.1745 +cleanup:
1.1746 + if (splitPath != NULL) {
1.1747 + Tcl_DecrRefCount(splitPath);
1.1748 + }
1.1749 +
1.1750 + return result;
1.1751 +}
1.1752 +
1.1753 +/*
1.1754 + *----------------------------------------------------------------------
1.1755 + *
1.1756 + * GetWinFileLongName --
1.1757 + *
1.1758 + * Returns a Tcl_Obj containing the long version of the file
1.1759 + * name.
1.1760 + *
1.1761 + * Results:
1.1762 + * Standard Tcl result and a Tcl_Obj in attributePtrPtr. The object
1.1763 + * will have ref count 0. If the return value is not TCL_OK,
1.1764 + * attributePtrPtr is not touched.
1.1765 + *
1.1766 + * Side effects:
1.1767 + * A new object is allocated if the file is valid.
1.1768 + *
1.1769 + *----------------------------------------------------------------------
1.1770 + */
1.1771 +
1.1772 +static int
1.1773 +GetWinFileLongName(
1.1774 + Tcl_Interp *interp, /* The interp we are using for errors. */
1.1775 + int objIndex, /* The index of the attribute. */
1.1776 + Tcl_Obj *fileName, /* The name of the file. */
1.1777 + Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */
1.1778 +{
1.1779 + return ConvertFileNameFormat(interp, objIndex, fileName, 1, attributePtrPtr);
1.1780 +}
1.1781 +
1.1782 +/*
1.1783 + *----------------------------------------------------------------------
1.1784 + *
1.1785 + * GetWinFileShortName --
1.1786 + *
1.1787 + * Returns a Tcl_Obj containing the short version of the file
1.1788 + * name.
1.1789 + *
1.1790 + * Results:
1.1791 + * Standard Tcl result and a Tcl_Obj in attributePtrPtr. The object
1.1792 + * will have ref count 0. If the return value is not TCL_OK,
1.1793 + * attributePtrPtr is not touched.
1.1794 + *
1.1795 + * Side effects:
1.1796 + * A new object is allocated if the file is valid.
1.1797 + *
1.1798 + *----------------------------------------------------------------------
1.1799 + */
1.1800 +
1.1801 +static int
1.1802 +GetWinFileShortName(
1.1803 + Tcl_Interp *interp, /* The interp we are using for errors. */
1.1804 + int objIndex, /* The index of the attribute. */
1.1805 + Tcl_Obj *fileName, /* The name of the file. */
1.1806 + Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */
1.1807 +{
1.1808 + return ConvertFileNameFormat(interp, objIndex, fileName, 0, attributePtrPtr);
1.1809 +}
1.1810 +
1.1811 +/*
1.1812 + *----------------------------------------------------------------------
1.1813 + *
1.1814 + * SetWinFileAttributes --
1.1815 + *
1.1816 + * Set the file attributes to the value given by attributePtr.
1.1817 + * This routine sets the -hidden, -readonly, or -system attributes.
1.1818 + *
1.1819 + * Results:
1.1820 + * Standard TCL error.
1.1821 + *
1.1822 + * Side effects:
1.1823 + * The file's attribute is set.
1.1824 + *
1.1825 + *----------------------------------------------------------------------
1.1826 + */
1.1827 +
1.1828 +static int
1.1829 +SetWinFileAttributes(
1.1830 + Tcl_Interp *interp, /* The interp we are using for errors. */
1.1831 + int objIndex, /* The index of the attribute. */
1.1832 + Tcl_Obj *fileName, /* The name of the file. */
1.1833 + Tcl_Obj *attributePtr) /* The new value of the attribute. */
1.1834 +{
1.1835 + DWORD fileAttributes;
1.1836 + int yesNo;
1.1837 + int result;
1.1838 + CONST TCHAR *nativeName;
1.1839 +
1.1840 + nativeName = Tcl_FSGetNativePath(fileName);
1.1841 + fileAttributes = (*tclWinProcs->getFileAttributesProc)(nativeName);
1.1842 +
1.1843 + if (fileAttributes == 0xffffffff) {
1.1844 + StatError(interp, fileName);
1.1845 + return TCL_ERROR;
1.1846 + }
1.1847 +
1.1848 + result = Tcl_GetBooleanFromObj(interp, attributePtr, &yesNo);
1.1849 + if (result != TCL_OK) {
1.1850 + return result;
1.1851 + }
1.1852 +
1.1853 + if (yesNo) {
1.1854 + fileAttributes |= (attributeArray[objIndex]);
1.1855 + } else {
1.1856 + fileAttributes &= ~(attributeArray[objIndex]);
1.1857 + }
1.1858 +
1.1859 + if (!(*tclWinProcs->setFileAttributesProc)(nativeName, fileAttributes)) {
1.1860 + StatError(interp, fileName);
1.1861 + return TCL_ERROR;
1.1862 + }
1.1863 +
1.1864 + return result;
1.1865 +}
1.1866 +
1.1867 +/*
1.1868 + *----------------------------------------------------------------------
1.1869 + *
1.1870 + * SetWinFileLongName --
1.1871 + *
1.1872 + * The attribute in question is a readonly attribute and cannot
1.1873 + * be set.
1.1874 + *
1.1875 + * Results:
1.1876 + * TCL_ERROR
1.1877 + *
1.1878 + * Side effects:
1.1879 + * The object result is set to a pertinent error message.
1.1880 + *
1.1881 + *----------------------------------------------------------------------
1.1882 + */
1.1883 +
1.1884 +static int
1.1885 +CannotSetAttribute(
1.1886 + Tcl_Interp *interp, /* The interp we are using for errors. */
1.1887 + int objIndex, /* The index of the attribute. */
1.1888 + Tcl_Obj *fileName, /* The name of the file. */
1.1889 + Tcl_Obj *attributePtr) /* The new value of the attribute. */
1.1890 +{
1.1891 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.1892 + "cannot set attribute \"", tclpFileAttrStrings[objIndex],
1.1893 + "\" for file \"", Tcl_GetString(fileName),
1.1894 + "\": attribute is readonly",
1.1895 + (char *) NULL);
1.1896 + return TCL_ERROR;
1.1897 +}
1.1898 +
1.1899 +
1.1900 +/*
1.1901 + *---------------------------------------------------------------------------
1.1902 + *
1.1903 + * TclpObjListVolumes --
1.1904 + *
1.1905 + * Lists the currently mounted volumes
1.1906 + *
1.1907 + * Results:
1.1908 + * The list of volumes.
1.1909 + *
1.1910 + * Side effects:
1.1911 + * None
1.1912 + *
1.1913 + *---------------------------------------------------------------------------
1.1914 + */
1.1915 +
1.1916 +Tcl_Obj*
1.1917 +TclpObjListVolumes(void)
1.1918 +{
1.1919 + Tcl_Obj *resultPtr, *elemPtr;
1.1920 + char buf[40 * 4]; /* There couldn't be more than 30 drives??? */
1.1921 + int i;
1.1922 + char *p;
1.1923 +
1.1924 + resultPtr = Tcl_NewObj();
1.1925 +
1.1926 + /*
1.1927 + * On Win32s:
1.1928 + * GetLogicalDriveStrings() isn't implemented.
1.1929 + * GetLogicalDrives() returns incorrect information.
1.1930 + */
1.1931 +
1.1932 + if (GetLogicalDriveStringsA(sizeof(buf), buf) == 0) {
1.1933 + /*
1.1934 + * GetVolumeInformation() will detects all drives, but causes
1.1935 + * chattering on empty floppy drives. We only do this if
1.1936 + * GetLogicalDriveStrings() didn't work. It has also been reported
1.1937 + * that on some laptops it takes a while for GetVolumeInformation()
1.1938 + * to return when pinging an empty floppy drive, another reason to
1.1939 + * try to avoid calling it.
1.1940 + */
1.1941 +
1.1942 + buf[1] = ':';
1.1943 + buf[2] = '/';
1.1944 + buf[3] = '\0';
1.1945 +
1.1946 + for (i = 0; i < 26; i++) {
1.1947 + buf[0] = (char) ('a' + i);
1.1948 + if (GetVolumeInformationA(buf, NULL, 0, NULL, NULL, NULL, NULL, 0)
1.1949 + || (GetLastError() == ERROR_NOT_READY)) {
1.1950 + elemPtr = Tcl_NewStringObj(buf, -1);
1.1951 + Tcl_ListObjAppendElement(NULL, resultPtr, elemPtr);
1.1952 + }
1.1953 + }
1.1954 + } else {
1.1955 + for (p = buf; *p != '\0'; p += 4) {
1.1956 + p[2] = '/';
1.1957 + elemPtr = Tcl_NewStringObj(p, -1);
1.1958 + Tcl_ListObjAppendElement(NULL, resultPtr, elemPtr);
1.1959 + }
1.1960 + }
1.1961 +
1.1962 + Tcl_IncrRefCount(resultPtr);
1.1963 + return resultPtr;
1.1964 +}