diff options
Diffstat (limited to 'win/tclWinFCmd.c')
| -rw-r--r-- | win/tclWinFCmd.c | 1401 |
1 files changed, 0 insertions, 1401 deletions
diff --git a/win/tclWinFCmd.c b/win/tclWinFCmd.c deleted file mode 100644 index 8eb836f..0000000 --- a/win/tclWinFCmd.c +++ /dev/null @@ -1,1401 +0,0 @@ -/* - * tclWinFCmd.c - * - * This file implements the Windows specific portion of file manipulation - * subcommands of the "file" command. - * - * Copyright (c) 1996-1997 Sun Microsystems, Inc. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclWinFCmd.c,v 1.2 1998/09/14 18:40:19 stanton Exp $ - */ - -#include "tclWinInt.h" - -/* - * The following constants specify the type of callback when - * TraverseWinTree() calls the traverseProc() - */ - -#define DOTREE_PRED 1 /* pre-order directory */ -#define DOTREE_POSTD 2 /* post-order directory */ -#define DOTREE_F 3 /* regular file */ - -/* - * Callbacks for file attributes code. - */ - -static int GetWinFileAttributes _ANSI_ARGS_((Tcl_Interp *interp, - int objIndex, char *fileName, - Tcl_Obj **attributePtrPtr)); -static int GetWinFileLongName _ANSI_ARGS_((Tcl_Interp *interp, - int objIndex, char *fileName, - Tcl_Obj **attributePtrPtr)); -static int GetWinFileShortName _ANSI_ARGS_((Tcl_Interp *interp, - int objIndex, char *fileName, - Tcl_Obj **attributePtrPtr)); -static int SetWinFileAttributes _ANSI_ARGS_((Tcl_Interp *interp, - int objIndex, char *fileName, - Tcl_Obj *attributePtr)); -static int CannotSetAttribute _ANSI_ARGS_((Tcl_Interp *interp, - int objIndex, char *fileName, - Tcl_Obj *attributePtr)); - -/* - * Constants and variables necessary for file attributes subcommand. - */ - -enum { - WIN_ARCHIVE_ATTRIBUTE, - WIN_HIDDEN_ATTRIBUTE, - WIN_LONGNAME_ATTRIBUTE, - WIN_READONLY_ATTRIBUTE, - WIN_SHORTNAME_ATTRIBUTE, - WIN_SYSTEM_ATTRIBUTE -}; - -static int attributeArray[] = {FILE_ATTRIBUTE_ARCHIVE, FILE_ATTRIBUTE_HIDDEN, - 0, FILE_ATTRIBUTE_READONLY, 0, FILE_ATTRIBUTE_SYSTEM}; - - -char *tclpFileAttrStrings[] = {"-archive", "-hidden", "-longname", "-readonly", - "-shortname", "-system", (char *) NULL}; -CONST TclFileAttrProcs tclpFileAttrProcs[] = { - {GetWinFileAttributes, SetWinFileAttributes}, - {GetWinFileAttributes, SetWinFileAttributes}, - {GetWinFileLongName, CannotSetAttribute}, - {GetWinFileAttributes, SetWinFileAttributes}, - {GetWinFileShortName, CannotSetAttribute}, - {GetWinFileAttributes, SetWinFileAttributes}}; - -/* - * Prototype for the TraverseWinTree callback function. - */ - -typedef int (TraversalProc)(char *src, char *dst, DWORD attr, int type, - Tcl_DString *errorPtr); - -/* - * Declarations for local procedures defined in this file: - */ - -static void AttributesPosixError _ANSI_ARGS_((Tcl_Interp *interp, - int objIndex, char *fileName, int getOrSet)); -static int ConvertFileNameFormat _ANSI_ARGS_((Tcl_Interp *interp, - int objIndex, char *fileName, int longShort, - Tcl_Obj **attributePtrPtr)); -static int TraversalCopy(char *src, char *dst, DWORD attr, - int type, Tcl_DString *errorPtr); -static int TraversalDelete(char *src, char *dst, DWORD attr, - int type, Tcl_DString *errorPtr); -static int TraverseWinTree(TraversalProc *traverseProc, - Tcl_DString *sourcePtr, Tcl_DString *destPtr, - Tcl_DString *errorPtr); - - -/* - *--------------------------------------------------------------------------- - * - * TclpRenameFile -- - * - * 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 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: 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 -TclpRenameFile( - char *src, /* Pathname of file or dir to be renamed. */ - char *dst) /* New pathname for file or directory. */ -{ - DWORD srcAttr, dstAttr; - - /* - * Would throw an exception under NT if one of the arguments is a - * char block device. - */ - - try { - if (MoveFile(src, dst) != FALSE) { - return TCL_OK; - } - } except (-1) {} - - TclWinConvertError(GetLastError()); - - srcAttr = GetFileAttributes(src); - dstAttr = GetFileAttributes(dst); - if (srcAttr == (DWORD) -1) { - srcAttr = 0; - } - if (dstAttr == (DWORD) -1) { - dstAttr = 0; - } - - if (errno == EBADF) { - errno = EACCES; - return TCL_ERROR; - } - if ((errno == EACCES) && (TclWinGetPlatformId() == VER_PLATFORM_WIN32s)) { - if ((srcAttr != 0) && (dstAttr != 0)) { - /* - * Win32s reports trying to overwrite an existing file or directory - * as EACCES. - */ - - errno = EEXIST; - } - } - if (errno == EACCES) { - decode: - if (srcAttr & FILE_ATTRIBUTE_DIRECTORY) { - char srcPath[MAX_PATH], dstPath[MAX_PATH]; - int srcArgc, dstArgc; - char **srcArgv, **dstArgv; - char *srcRest, *dstRest; - int size; - - size = GetFullPathName(src, sizeof(srcPath), srcPath, &srcRest); - if ((size == 0) || (size > sizeof(srcPath))) { - return TCL_ERROR; - } - size = GetFullPathName(dst, sizeof(dstPath), dstPath, &dstRest); - if ((size == 0) || (size > sizeof(dstPath))) { - return TCL_ERROR; - } - if (srcRest == NULL) { - srcRest = srcPath + strlen(srcPath); - } - if (strnicmp(srcPath, dstPath, srcRest - srcPath) == 0) { - /* - * Trying to move a directory into itself. - */ - - errno = EINVAL; - return TCL_ERROR; - } - Tcl_SplitPath(srcPath, &srcArgc, &srcArgv); - Tcl_SplitPath(dstPath, &dstArgc, &dstArgv); - if (srcArgc == 1) { - /* - * They are trying to move a root directory. Whether - * or not it is across filesystems, this cannot be - * done. - */ - - errno = EINVAL; - } else if ((srcArgc > 0) && (dstArgc > 0) && - (stricmp(srcArgv[0], dstArgv[0]) != 0)) { - /* - * If src is a directory and dst filesystem != src - * filesystem, errno should be EXDEV. It is very - * important to get this behavior, so that the caller - * can respond to a cross filesystem rename by - * simulating it with copy and delete. The MoveFile - * system call already handles the case of moving a - * file between filesystems. - */ - - errno = EXDEV; - } - - ckfree((char *) srcArgv); - ckfree((char *) dstArgv); - } - - /* - * Other types of access failure is that dst is a read-only - * filesystem, that an open file referred to src or dest, or that - * src or dest specified the current working directory on the - * current filesystem. EACCES is returned for those cases. - */ - - } else if (errno == 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 (TclpRemoveDirectory(dst, 0, NULL) == TCL_OK) { - /* - * Now that that empty directory is gone, we can try - * renaming again. If that fails, we'll put this empty - * directory back, for completeness. - */ - - if (MoveFile(src, dst) != FALSE) { - return TCL_OK; - } - - /* - * Some new error has occurred. Don't know what it - * could be, but report this one. - */ - - TclWinConvertError(GetLastError()); - CreateDirectory(dst, NULL); - SetFileAttributes(dst, dstAttr); - if (errno == EACCES) { - /* - * Decode the EACCES to a more meaningful error. - */ - - goto decode; - } - } - } else { /* (dstAttr & FILE_ATTRIBUTE_DIRECTORY) == 0 */ - errno = ENOTDIR; - } - } else { /* (srcAttr & FILE_ATTRIBUTE_DIRECTORY) == 0 */ - if (dstAttr & FILE_ATTRIBUTE_DIRECTORY) { - errno = 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. - */ - - char tempName[MAX_PATH]; - int result, size; - char *rest; - - size = GetFullPathName(dst, sizeof(tempName), tempName, &rest); - if ((size == 0) || (size > sizeof(tempName)) || (rest == NULL)) { - return TCL_ERROR; - } - *rest = '\0'; - result = TCL_ERROR; - if (GetTempFileName(tempName, "tclr", 0, tempName) != 0) { - /* - * Strictly speaking, need the following DeleteFile and - * MoveFile to be joined as an atomic operation so no - * other app comes along in the meantime and creates the - * same temp file. - */ - - DeleteFile(tempName); - if (MoveFile(dst, tempName) != FALSE) { - if (MoveFile(src, dst) != FALSE) { - SetFileAttributes(tempName, FILE_ATTRIBUTE_NORMAL); - DeleteFile(tempName); - return TCL_OK; - } else { - DeleteFile(dst); - MoveFile(tempName, dst); - } - } - - /* - * Can't backup dst file or move src file. Return that - * error. Could happen if an open file refers to dst. - */ - - TclWinConvertError(GetLastError()); - if (errno == EACCES) { - /* - * Decode the EACCES to a more meaningful error. - */ - - goto decode; - } - } - return result; - } - } - } - return TCL_ERROR; -} - -/* - *--------------------------------------------------------------------------- - * - * TclpCopyFile -- - * - * 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 -TclpCopyFile( - char *src, /* Pathname of file to be copied. */ - char *dst) /* Pathname of file to copy to. */ -{ - /* - * Would throw an exception under NT if one of the arguments is a char - * block device. - */ - - try { - if (CopyFile(src, dst, 0) != FALSE) { - return TCL_OK; - } - } except (-1) {} - - TclWinConvertError(GetLastError()); - if (errno == EBADF) { - errno = EACCES; - return TCL_ERROR; - } - if (errno == EACCES) { - DWORD srcAttr, dstAttr; - - srcAttr = GetFileAttributes(src); - dstAttr = GetFileAttributes(dst); - if (srcAttr != (DWORD) -1) { - if (dstAttr == (DWORD) -1) { - dstAttr = 0; - } - if ((srcAttr & FILE_ATTRIBUTE_DIRECTORY) || - (dstAttr & FILE_ATTRIBUTE_DIRECTORY)) { - errno = EISDIR; - } - if (dstAttr & FILE_ATTRIBUTE_READONLY) { - SetFileAttributes(dst, dstAttr & ~FILE_ATTRIBUTE_READONLY); - if (CopyFile(src, dst, 0) != FALSE) { - return TCL_OK; - } - /* - * Still can't copy onto dst. Return that error, and - * restore attributes of dst. - */ - - TclWinConvertError(GetLastError()); - SetFileAttributes(dst, dstAttr); - } - } - } - return TCL_ERROR; -} - -/* - *--------------------------------------------------------------------------- - * - * 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 -TclpDeleteFile( - char *path) /* Pathname of file to be removed. */ -{ - DWORD attr; - - if (DeleteFile(path) != FALSE) { - return TCL_OK; - } - TclWinConvertError(GetLastError()); - if (path[0] == '\0') { - /* - * Win32s thinks that "" is the same as "." and then reports EISDIR - * instead of ENOENT. - */ - - errno = ENOENT; - } else if (errno == EACCES) { - attr = GetFileAttributes(path); - if (attr != (DWORD) -1) { - if (attr & FILE_ATTRIBUTE_DIRECTORY) { - /* - * Windows NT reports removing a directory as EACCES instead - * of EISDIR. - */ - - errno = EISDIR; - } else if (attr & FILE_ATTRIBUTE_READONLY) { - SetFileAttributes(path, attr & ~FILE_ATTRIBUTE_READONLY); - if (DeleteFile(path) != FALSE) { - return TCL_OK; - } - TclWinConvertError(GetLastError()); - SetFileAttributes(path, attr); - } - } - } else if (errno == ENOENT) { - attr = GetFileAttributes(path); - if (attr != (DWORD) -1) { - if (attr & FILE_ATTRIBUTE_DIRECTORY) { - /* - * Windows 95 reports removing a directory as ENOENT instead - * of EISDIR. - */ - - errno = EISDIR; - } - } - } else if (errno == EINVAL) { - /* - * Windows NT reports removing a char device as EINVAL instead of - * EACCES. - */ - - errno = EACCES; - } - - return TCL_ERROR; -} - -/* - *--------------------------------------------------------------------------- - * - * TclpCreateDirectory -- - * - * 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 -TclpCreateDirectory( - char *path) /* Pathname of directory to create */ -{ - int error; - - if (CreateDirectory(path, NULL) == 0) { - error = GetLastError(); - if (TclWinGetPlatformId() == VER_PLATFORM_WIN32s) { - if ((error == ERROR_ACCESS_DENIED) - && (GetFileAttributes(path) != (DWORD) -1)) { - error = ERROR_FILE_EXISTS; - } - } - TclWinConvertError(error); - return TCL_ERROR; - } - return TCL_OK; -} - -/* - *--------------------------------------------------------------------------- - * - * TclpCopyDirectory -- - * - * 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 -TclpCopyDirectory( - char *src, /* Pathname of directory to be copied. */ - char *dst, /* Pathname of target directory. */ - Tcl_DString *errorPtr) /* If non-NULL, initialized DString for - * error reporting. */ -{ - int result; - Tcl_DString srcBuffer; - Tcl_DString dstBuffer; - - Tcl_DStringInit(&srcBuffer); - Tcl_DStringInit(&dstBuffer); - Tcl_DStringAppend(&srcBuffer, src, -1); - Tcl_DStringAppend(&dstBuffer, dst, -1); - result = TraverseWinTree(TraversalCopy, &srcBuffer, &dstBuffer, - errorPtr); - Tcl_DStringFree(&srcBuffer); - Tcl_DStringFree(&dstBuffer); - return result; -} - -/* - *---------------------------------------------------------------------- - * - * TclpRemoveDirectory -- - * - * 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 -TclpRemoveDirectory( - char *path, /* Pathname of directory to be removed. */ - int recursive, /* If non-zero, removes directories that - * are nonempty. Otherwise, will only remove - * empty directories. */ - Tcl_DString *errorPtr) /* If non-NULL, initialized DString for - * error reporting. */ -{ - int result; - Tcl_DString buffer; - DWORD attr; - - if (RemoveDirectory(path) != FALSE) { - return TCL_OK; - } - TclWinConvertError(GetLastError()); - if (path[0] == '\0') { - /* - * Win32s thinks that "" is the same as "." and then reports EACCES - * instead of ENOENT. - */ - - errno = ENOENT; - } - if (errno == EACCES) { - attr = GetFileAttributes(path); - if (attr != (DWORD) -1) { - if ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0) { - /* - * Windows 95 reports calling RemoveDirectory on a file as an - * EACCES, not an ENOTDIR. - */ - - errno = ENOTDIR; - goto end; - } - - if (attr & FILE_ATTRIBUTE_READONLY) { - attr &= ~FILE_ATTRIBUTE_READONLY; - if (SetFileAttributes(path, attr) == FALSE) { - goto end; - } - if (RemoveDirectory(path) != FALSE) { - return TCL_OK; - } - TclWinConvertError(GetLastError()); - SetFileAttributes(path, attr | FILE_ATTRIBUTE_READONLY); - } - - /* - * Windows 95 and Win32s report removing a non-empty directory - * as EACCES, not EEXIST. If the directory is not empty, - * change errno so caller knows what's going on. - */ - - if (TclWinGetPlatformId() != VER_PLATFORM_WIN32_NT) { - HANDLE handle; - WIN32_FIND_DATA data; - Tcl_DString buffer; - char *find; - int len; - - Tcl_DStringInit(&buffer); - find = Tcl_DStringAppend(&buffer, path, -1); - len = Tcl_DStringLength(&buffer); - if ((len > 0) && (find[len - 1] != '\\')) { - Tcl_DStringAppend(&buffer, "\\", 1); - } - find = Tcl_DStringAppend(&buffer, "*.*", 3); - handle = FindFirstFile(find, &data); - if (handle != INVALID_HANDLE_VALUE) { - while (1) { - if ((strcmp(data.cFileName, ".") != 0) - && (strcmp(data.cFileName, "..") != 0)) { - /* - * Found something in this directory. - */ - - errno = EEXIST; - break; - } - if (FindNextFile(handle, &data) == FALSE) { - break; - } - } - FindClose(handle); - } - Tcl_DStringFree(&buffer); - } - } - } - if (errno == ENOTEMPTY) { - /* - * The caller depends on EEXIST to signify that the directory is - * not empty, not ENOTEMPTY. - */ - - errno = EEXIST; - } - if ((recursive != 0) && (errno == EEXIST)) { - /* - * The directory is nonempty, but the recursive flag has been - * specified, so we recursively remove all the files in the directory. - */ - - Tcl_DStringInit(&buffer); - Tcl_DStringAppend(&buffer, path, -1); - result = TraverseWinTree(TraversalDelete, &buffer, NULL, errorPtr); - Tcl_DStringFree(&buffer); - return result; - } - - end: - if (errorPtr != NULL) { - Tcl_DStringAppend(errorPtr, path, -1); - } - return TCL_ERROR; -} - -/* - *--------------------------------------------------------------------------- - * - * 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. */ - Tcl_DString *targetPtr, /* Pathname of directory to traverse in - * parallel with source directory. */ - Tcl_DString *errorPtr) /* If non-NULL, an initialized DString for - * error reporting. */ -{ - DWORD sourceAttr; - char *source, *target, *errfile; - int result, sourceLen, targetLen, sourceLenOriginal, targetLenOriginal; - HANDLE handle; - WIN32_FIND_DATA data; - - result = TCL_OK; - source = Tcl_DStringValue(sourcePtr); - sourceLenOriginal = Tcl_DStringLength(sourcePtr); - if (targetPtr != NULL) { - target = Tcl_DStringValue(targetPtr); - targetLenOriginal = Tcl_DStringLength(targetPtr); - } else { - target = NULL; - targetLenOriginal = 0; - } - - errfile = NULL; - - sourceAttr = GetFileAttributes(source); - if (sourceAttr == (DWORD) -1) { - errfile = source; - goto end; - } - if ((sourceAttr & FILE_ATTRIBUTE_DIRECTORY) == 0) { - /* - * Process the regular file - */ - - return (*traverseProc)(source, target, sourceAttr, DOTREE_F, errorPtr); - } - - /* - * When given the pathname of the form "c:\" (one that already ends - * with a backslash), must make sure not to add another "\" to the end - * otherwise it will try to access a network drive. - */ - - sourceLen = sourceLenOriginal; - if ((sourceLen > 0) && (source[sourceLen - 1] != '\\')) { - Tcl_DStringAppend(sourcePtr, "\\", 1); - sourceLen++; - } - source = Tcl_DStringAppend(sourcePtr, "*.*", 3); - handle = FindFirstFile(source, &data); - Tcl_DStringSetLength(sourcePtr, sourceLen); - if (handle == INVALID_HANDLE_VALUE) { - /* - * Can't read directory - */ - - TclWinConvertError(GetLastError()); - errfile = source; - goto end; - } - - result = (*traverseProc)(source, target, sourceAttr, DOTREE_PRED, errorPtr); - if (result != TCL_OK) { - FindClose(handle); - return result; - } - - if (targetPtr != NULL) { - targetLen = targetLenOriginal; - if ((targetLen > 0) && (target[targetLen - 1] != '\\')) { - target = Tcl_DStringAppend(targetPtr, "\\", 1); - targetLen++; - } - } - - while (1) { - if ((strcmp(data.cFileName, ".") != 0) - && (strcmp(data.cFileName, "..") != 0)) { - /* - * Append name after slash, and recurse on the file. - */ - - Tcl_DStringAppend(sourcePtr, data.cFileName, -1); - if (targetPtr != NULL) { - Tcl_DStringAppend(targetPtr, data.cFileName, -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); - } - } - if (FindNextFile(handle, &data) == FALSE) { - break; - } - } - FindClose(handle); - - /* - * Strip off the trailing slash we added - */ - - Tcl_DStringSetLength(sourcePtr, sourceLenOriginal); - source = Tcl_DStringValue(sourcePtr); - if (targetPtr != NULL) { - Tcl_DStringSetLength(targetPtr, targetLenOriginal); - target = Tcl_DStringValue(targetPtr); - } - - if (result == TCL_OK) { - /* - * Call traverseProc() on a directory after visiting all the - * files in that directory. - */ - - result = (*traverseProc)(source, target, sourceAttr, - DOTREE_POSTD, errorPtr); - } - end: - if (errfile != NULL) { - TclWinConvertError(GetLastError()); - if (errorPtr != NULL) { - Tcl_DStringAppend(errorPtr, errfile, -1); - } - 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( - char *src, /* Source pathname to copy. */ - char *dst, /* Destination pathname of copy. */ - DWORD srcAttr, /* File attributes for src. */ - int type, /* Reason for call - see TraverseWinTree() */ - Tcl_DString *errorPtr) /* If non-NULL, initialized DString for - * error return. */ -{ - switch (type) { - case DOTREE_F: - if (TclpCopyFile(src, dst) == TCL_OK) { - return TCL_OK; - } - break; - - case DOTREE_PRED: - if (TclpCreateDirectory(dst) == TCL_OK) { - if (SetFileAttributes(dst, srcAttr) != 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_DStringAppend(errorPtr, dst, -1); - } - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * TraversalDelete -- - * - * Called by procedure TraverseWinTree for every file and - * directory that it encounters in a directory hierarchy. This - * procedure unlinks files, and removes directories after all the - * containing files have been processed. - * - * Results: - * Standard Tcl result. - * - * Side effects: - * Files or directory specified by src will be deleted. If an - * error occurs, the windows error is converted to a Posix error - * and errno is set accordingly. - * - *---------------------------------------------------------------------- - */ - -static int -TraversalDelete( - char *src, /* Source pathname. */ - char *ignore, /* Destination pathname (not used). */ - DWORD srcAttr, /* File attributes for src (not used). */ - int type, /* Reason for call - see TraverseWinTree(). */ - Tcl_DString *errorPtr) /* If non-NULL, initialized DString for - * error return. */ -{ - switch (type) { - case DOTREE_F: - if (TclpDeleteFile(src) == TCL_OK) { - return TCL_OK; - } - break; - - case DOTREE_PRED: - return TCL_OK; - - case DOTREE_POSTD: - if (TclpRemoveDirectory(src, 0, NULL) == TCL_OK) { - return TCL_OK; - } - break; - - } - - if (errorPtr != NULL) { - Tcl_DStringAppend(errorPtr, src, -1); - } - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * AttributesPosixError -- - * - * 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 -AttributesPosixError( - Tcl_Interp *interp, /* The interp that has the error */ - int objIndex, /* The attribute which caused the problem. */ - char *fileName, /* The name of the file which caused the - * error. */ - int getOrSet) /* 0 for get; 1 for set */ -{ - TclWinConvertError(GetLastError()); - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "cannot ", getOrSet ? "set" : "get", " attribute \"", - tclpFileAttrStrings[objIndex], "\" for file \"", fileName, - "\": ", Tcl_PosixError(interp), (char *) NULL); -} - -/* - *---------------------------------------------------------------------- - * - * GetWinFileAttributes -- - * - * Returns a Tcl_Obj containing the value of a file attribute. - * This routine gets the -hidden, -readonly or -system attribute. - * - * Results: - * Standard Tcl result and a Tcl_Obj in attributePtrPtr. The object - * will have ref count 0. If the return value is not TCL_OK, - * attributePtrPtr is not touched. - * - * Side effects: - * A new object is allocated if the file is valid. - * - *---------------------------------------------------------------------- - */ - -static int -GetWinFileAttributes( - Tcl_Interp *interp, /* The interp we are using for errors. */ - int objIndex, /* The index of the attribute. */ - char *fileName, /* The name of the file. */ - Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */ -{ - DWORD result = GetFileAttributes(fileName); - - if (result == 0xFFFFFFFF) { - AttributesPosixError(interp, objIndex, fileName, 0); - return TCL_ERROR; - } - - *attributePtrPtr = Tcl_NewBooleanObj(result & attributeArray[objIndex]); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * ConvertFileNameFormat -- - * - * Returns a Tcl_Obj containing either the long or short version of the - * file name. - * - * Results: - * Standard Tcl result and a Tcl_Obj in attributePtrPtr. The object - * will have ref count 0. If the return value is not TCL_OK, - * attributePtrPtr is not touched. - * - * 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. */ - char *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. */ -{ - HANDLE findHandle; - WIN32_FIND_DATA findData; - int pathArgc, i; - char **pathArgv, **newPathArgv; - char *currentElement, *resultStr; - Tcl_DString resultDString; - int result = TCL_OK; - - Tcl_SplitPath(fileName, &pathArgc, &pathArgv); - newPathArgv = (char **) ckalloc(pathArgc * sizeof(char *)); - - i = 0; - if ((pathArgv[0][0] == '/') - || ((strlen(pathArgv[0]) == 3) && (pathArgv[0][1] == ':'))) { - newPathArgv[0] = (char *) ckalloc(strlen(pathArgv[0]) + 1); - strcpy(newPathArgv[0], pathArgv[0]); - i = 1; - } - for ( ; i < pathArgc; i++) { - if (strcmp(pathArgv[i], ".") == 0) { - currentElement = ckalloc(2); - strcpy(currentElement, "."); - } else if (strcmp(pathArgv[i], "..") == 0) { - currentElement = ckalloc(3); - strcpy(currentElement, ".."); - } else { - int useLong; - - Tcl_DStringInit(&resultDString); - resultStr = Tcl_JoinPath(i + 1, pathArgv, &resultDString); - findHandle = FindFirstFile(resultStr, &findData); - if (findHandle == INVALID_HANDLE_VALUE) { - pathArgc = i - 1; - AttributesPosixError(interp, objIndex, fileName, 0); - result = TCL_ERROR; - Tcl_DStringFree(&resultDString); - goto cleanup; - } - if (longShort) { - if (findData.cFileName[0] != '\0') { - useLong = 1; - } else { - useLong = 0; - } - } else { - if (findData.cAlternateFileName[0] == '\0') { - useLong = 1; - } else { - useLong = 0; - } - } - if (useLong) { - currentElement = ckalloc(strlen(findData.cFileName) + 1); - strcpy(currentElement, findData.cFileName); - } else { - currentElement = ckalloc(strlen(findData.cAlternateFileName) - + 1); - strcpy(currentElement, findData.cAlternateFileName); - } - Tcl_DStringFree(&resultDString); - FindClose(findHandle); - } - newPathArgv[i] = currentElement; - } - - Tcl_DStringInit(&resultDString); - resultStr = Tcl_JoinPath(pathArgc, newPathArgv, &resultDString); - *attributePtrPtr = Tcl_NewStringObj(resultStr, Tcl_DStringLength(&resultDString)); - Tcl_DStringFree(&resultDString); - -cleanup: - for (i = 0; i < pathArgc; i++) { - ckfree(newPathArgv[i]); - } - ckfree((char *) newPathArgv); - return result; -} - -/* - *---------------------------------------------------------------------- - * - * GetWinFileLongName -- - * - * 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 -GetWinFileLongName( - Tcl_Interp *interp, /* The interp we are using for errors. */ - int objIndex, /* The index of the attribute. */ - char *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. */ - char *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. */ - char *fileName, /* The name of the file. */ - Tcl_Obj *attributePtr) /* The new value of the attribute. */ -{ - DWORD fileAttributes = GetFileAttributes(fileName); - int yesNo; - int result; - - if (fileAttributes == 0xFFFFFFFF) { - AttributesPosixError(interp, objIndex, fileName, 1); - 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 (!SetFileAttributes(fileName, fileAttributes)) { - AttributesPosixError(interp, objIndex, fileName, 1); - return TCL_ERROR; - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * 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 pertinant error message. - * - *---------------------------------------------------------------------- - */ - -static int -CannotSetAttribute( - Tcl_Interp *interp, /* The interp we are using for errors. */ - int objIndex, /* The index of the attribute. */ - char *fileName, /* The name of the file. */ - Tcl_Obj *attributePtr) /* The new value of the attribute. */ -{ - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "cannot set attribute \"", tclpFileAttrStrings[objIndex], - "\" for file \"", fileName, "\" : attribute is readonly", - (char *) NULL); - return TCL_ERROR; -} - - -/* - *--------------------------------------------------------------------------- - * - * TclpListVolumes -- - * - * Lists the currently mounted volumes - * - * Results: - * A standard Tcl result. Will always be TCL_OK, since there is no way - * that this command can fail. Also, the interpreter's result is set to - * the list of volumes. - * - * Side effects: - * None - * - *--------------------------------------------------------------------------- - */ - -int -TclpListVolumes( - Tcl_Interp *interp) /* Interpreter to which to pass the volume list */ -{ - Tcl_Obj *resultPtr, *elemPtr; - char buf[4]; - int i; - - resultPtr = Tcl_GetObjResult(interp); - - buf[1] = ':'; - buf[2] = '/'; - buf[3] = '\0'; - - /* - * On Win32s: - * GetLogicalDriveStrings() isn't implemented. - * GetLogicalDrives() returns incorrect information. - */ - - for (i = 0; i < 26; i++) { - buf[0] = (char) ('a' + i); - if (GetVolumeInformation(buf, NULL, 0, NULL, NULL, NULL, NULL, 0) - || (GetLastError() == ERROR_NOT_READY)) { - elemPtr = Tcl_NewStringObj(buf, -1); - Tcl_ListObjAppendElement(NULL, resultPtr, elemPtr); - } - } - return TCL_OK; -} |