开通博客赚积分
发布资源赚积分
分类

源码开发语言/平台
当前位置：首页 > 源码/资料 > Windows编程 > 通讯编程 > 查看源码
tclWinFCmd.c
资源名称：ns-allinone-2.33.tar.gz　[点击查看]
上传用户：rrhhcc
上传日期：2015-12-11
资源大小：54129k
文件大小：55k
源码类别：

通讯编程

开发平台：

Visual C++

tclWinFCmd.c：源码内容
  1. /*
  2.  * tclWinFCmd.c
  3.  *
  4.  *      This file implements the Windows specific portion of file manipulation 
  5.  *      subcommands of the "file" command. 
  6.  *
  7.  * Copyright (c) 1996-1998 Sun Microsystems, Inc.
  8.  *
  9.  * See the file "license.terms" for information on usage and redistribution
  10.  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  11.  *
  12.  * RCS: @(#) $Id: tclWinFCmd.c,v 1.35.2.5 2006/08/30 17:48:48 hobbs Exp $
  13.  */
  15. #include "tclWinInt.h"
  17. /*
  18.  * The following constants specify the type of callback when
  19.  * TraverseWinTree() calls the traverseProc()
  20.  */
  22. #define DOTREE_PRED   1     /* pre-order directory  */
  23. #define DOTREE_POSTD  2     /* post-order directory */
  24. #define DOTREE_F      3     /* regular file */
  26. /*
  27.  * Callbacks for file attributes code.
  28.  */
  30. static int GetWinFileAttributes _ANSI_ARGS_((Tcl_Interp *interp,
  31.     int objIndex, Tcl_Obj *fileName,
  32.     Tcl_Obj **attributePtrPtr));
  33. static int GetWinFileLongName _ANSI_ARGS_((Tcl_Interp *interp,
  34.     int objIndex, Tcl_Obj *fileName,
  35.     Tcl_Obj **attributePtrPtr));
  36. static int GetWinFileShortName _ANSI_ARGS_((Tcl_Interp *interp,
  37.     int objIndex, Tcl_Obj *fileName,
  38.     Tcl_Obj **attributePtrPtr));
  39. static int SetWinFileAttributes _ANSI_ARGS_((Tcl_Interp *interp,
  40.     int objIndex, Tcl_Obj *fileName,
  41.     Tcl_Obj *attributePtr));
  42. static int CannotSetAttribute _ANSI_ARGS_((Tcl_Interp *interp,
  43.     int objIndex, Tcl_Obj *fileName,
  44.     Tcl_Obj *attributePtr));
  46. /*
  47.  * Constants and variables necessary for file attributes subcommand.
  48.  */
  50. enum {
  51.     WIN_ARCHIVE_ATTRIBUTE,
  52.     WIN_HIDDEN_ATTRIBUTE,
  53.     WIN_LONGNAME_ATTRIBUTE,
  54.     WIN_READONLY_ATTRIBUTE,
  55.     WIN_SHORTNAME_ATTRIBUTE,
  56.     WIN_SYSTEM_ATTRIBUTE
  57. };
  59. static int attributeArray[] = {FILE_ATTRIBUTE_ARCHIVE, FILE_ATTRIBUTE_HIDDEN,
  60. 0, FILE_ATTRIBUTE_READONLY, 0, FILE_ATTRIBUTE_SYSTEM};
  63. CONST char *tclpFileAttrStrings[] = {
  64. "-archive", "-hidden", "-longname", "-readonly",
  65. "-shortname", "-system", (char *) NULL
  66. };
  68. CONST TclFileAttrProcs tclpFileAttrProcs[] = {
  69. {GetWinFileAttributes, SetWinFileAttributes},
  70. {GetWinFileAttributes, SetWinFileAttributes},
  71. {GetWinFileLongName, CannotSetAttribute},
  72. {GetWinFileAttributes, SetWinFileAttributes},
  73. {GetWinFileShortName, CannotSetAttribute},
  74. {GetWinFileAttributes, SetWinFileAttributes}};
  76. #ifdef HAVE_NO_SEH
  78. /*
  79.  * Unlike Borland and Microsoft, we don't register exception handlers
  80.  * by pushing registration records onto the runtime stack.  Instead, we
  81.  * register them by creating an EXCEPTION_REGISTRATION within the activation
  82.  * record.
  83.  */
  85. typedef struct EXCEPTION_REGISTRATION {
  86.     struct EXCEPTION_REGISTRATION* link;
  87.     EXCEPTION_DISPOSITION (*handler)( struct _EXCEPTION_RECORD*, void*,
  88.       struct _CONTEXT*, void* );
  89.     void* ebp;
  90.     void* esp;
  91.     int status;
  92. } EXCEPTION_REGISTRATION;
  94. #endif
  96. /*
  97.  * Prototype for the TraverseWinTree callback function.
  98.  */
  100. typedef int (TraversalProc)(CONST TCHAR *srcPtr, CONST TCHAR *dstPtr, 
  101. int type, Tcl_DString *errorPtr);
  103. /*
  104.  * Declarations for local procedures defined in this file:
  105.  */
  107. static void StatError(Tcl_Interp *interp, Tcl_Obj *fileName);
  108. static int ConvertFileNameFormat(Tcl_Interp *interp, 
  109.     int objIndex, Tcl_Obj *fileName, int longShort,
  110.     Tcl_Obj **attributePtrPtr);
  111. static int DoCopyFile(CONST TCHAR *srcPtr, CONST TCHAR *dstPtr);
  112. static int DoCreateDirectory(CONST TCHAR *pathPtr);
  113. static int DoRemoveJustDirectory(CONST TCHAR *nativeSrc, 
  114.     int ignoreError, Tcl_DString *errorPtr);
  115. static int DoRemoveDirectory(Tcl_DString *pathPtr, int recursive, 
  116.     Tcl_DString *errorPtr);
  117. static int DoRenameFile(CONST TCHAR *nativeSrc, CONST TCHAR *dstPtr);
  118. static int TraversalCopy(CONST TCHAR *srcPtr, CONST TCHAR *dstPtr, 
  119.     int type, Tcl_DString *errorPtr);
  120. static int TraversalDelete(CONST TCHAR *srcPtr, CONST TCHAR *dstPtr, 
  121.     int type, Tcl_DString *errorPtr);
  122. static int TraverseWinTree(TraversalProc *traverseProc,
  123.     Tcl_DString *sourcePtr, Tcl_DString *dstPtr, 
  124.     Tcl_DString *errorPtr);
  127. /*
  128.  *---------------------------------------------------------------------------
  129.  *
  130.  * TclpObjRenameFile, DoRenameFile --
  131.  *
  132.  *      Changes the name of an existing file or directory, from src to dst.
  133.  * If src and dst refer to the same file or directory, does nothing
  134.  * and returns success.  Otherwise if dst already exists, it will be
  135.  * deleted and replaced by src subject to the following conditions:
  136.  *     If src is a directory, dst may be an empty directory.
  137.  *     If src is a file, dst may be a file.
  138.  * In any other situation where dst already exists, the rename will
  139.  * fail.  
  140.  *
  141.  * Results:
  142.  * If the file or directory was successfully renamed, returns TCL_OK.
  143.  * Otherwise the return value is TCL_ERROR and errno is set to
  144.  * indicate the error.  Some possible values for errno are:
  145.  *
  146.  * ENAMETOOLONG: src or dst names are too long.
  147.  * EACCES:     src or dst parent directory can't be read and/or written.
  148.  * EEXIST:     dst is a non-empty directory.
  149.  * EINVAL:     src is a root directory or dst is a subdirectory of src.
  150.  * EISDIR:     dst is a directory, but src is not.
  151.  * ENOENT:     src doesn't exist.  src or dst is "".
  152.  * ENOTDIR:    src is a directory, but dst is not.  
  153.  * EXDEV:     src and dst are on different filesystems.
  154.  *
  155.  * EACCES:     exists an open file already referring to src or dst.
  156.  * EACCES:     src or dst specify the current working directory (NT).
  157.  * EACCES:     src specifies a char device (nul:, com1:, etc.) 
  158.  * EEXIST:     dst specifies a char device (nul:, com1:, etc.) (NT)
  159.  * EACCES:     dst specifies a char device (nul:, com1:, etc.) (95)
  160.  *
  161.  * Side effects:
  162.  * The implementation supports cross-filesystem renames of files,
  163.  * but the caller should be prepared to emulate cross-filesystem
  164.  * renames of directories if errno is EXDEV.
  165.  *
  166.  *---------------------------------------------------------------------------
  167.  */
  169. int 
  170. TclpObjRenameFile(srcPathPtr, destPathPtr)
  171.     Tcl_Obj *srcPathPtr;
  172.     Tcl_Obj *destPathPtr;
  173. {
  174.     return DoRenameFile(Tcl_FSGetNativePath(srcPathPtr), 
  175. Tcl_FSGetNativePath(destPathPtr));
  176. }
  178. static int
  179. DoRenameFile(
  180.     CONST TCHAR *nativeSrc, /* Pathname of file or dir to be renamed
  181.  * (native). */ 
  182.     CONST TCHAR *nativeDst) /* New pathname for file or directory
  183.  * (native). */
  184. {    
  185. #ifdef HAVE_NO_SEH
  186.     EXCEPTION_REGISTRATION registration;
  187. #endif
  188.     DWORD srcAttr, dstAttr;
  189.     int retval = -1;
  191.     /*
  192.      * The MoveFile API acts differently under Win95/98 and NT
  193.      * WRT NULL and "". Avoid passing these values.
  194.      */
  196.     if (nativeSrc == NULL || nativeSrc[0] == '' ||
  197.         nativeDst == NULL || nativeDst[0] == '') {
  198. Tcl_SetErrno(ENOENT);
  199. return TCL_ERROR;
  200.     }
  202.     /*
  203.      * The MoveFile API would throw an exception under NT
  204.      * if one of the arguments is a char block device.
  205.      */
  207. #ifndef HAVE_NO_SEH
  208.     __try {
  209. if ((*tclWinProcs->moveFileProc)(nativeSrc, nativeDst) != FALSE) {
  210.     retval = TCL_OK;
  211. }
  212.     } __except (EXCEPTION_EXECUTE_HANDLER) {}
  213. #else
  215.     /*
  216.      * Don't have SEH available, do things the hard way.
  217.      * Note that this needs to be one block of asm, to avoid stack
  218.      * imbalance; also, it is illegal for one asm block to contain 
  219.      * a jump to another.
  220.      */
  222.     __asm__ __volatile__ (
  223. /*
  224.  * Pick up params before messing with the stack */
  226. "movl     %[nativeDst],   %%ebx"     "nt"
  227. "movl       %[nativeSrc],   %%ecx"          "nt"
  229. /*
  230.  * Construct an EXCEPTION_REGISTRATION to protect the
  231.  * call to MoveFile
  232.  */
  233. "leal       %[registration], %%edx"         "nt"
  234. "movl       %%fs:0,         %%eax"          "nt"
  235. "movl       %%eax,          0x0(%%edx)"     "nt" /* link */
  236. "leal       1f,             %%eax"          "nt"
  237. "movl       %%eax,          0x4(%%edx)"     "nt" /* handler */
  238. "movl       %%ebp,          0x8(%%edx)"     "nt" /* ebp */
  239. "movl       %%esp,          0xc(%%edx)"     "nt" /* esp */
  240. "movl       $0,             0x10(%%edx)"    "nt" /* status */
  242. /* Link the EXCEPTION_REGISTRATION on the chain */
  244. "movl       %%edx,          %%fs:0"         "nt"
  246. /* Call MoveFile( nativeSrc, nativeDst ) */
  248. "pushl     %%ebx"     "nt"
  249. "pushl     %%ecx"     "nt"
  250. "movl     %[moveFile],    %%eax"     "nt"
  251. "call     *%%eax"     "nt"
  253. /* 
  254.  * Come here on normal exit.  Recover the EXCEPTION_REGISTRATION
  255.  * and put the status return from MoveFile into it.
  256.  */
  258. "movl     %%fs:0,     %%edx"     "nt"
  259. "movl     %%eax,     0x10(%%edx)"    "nt"
  260. "jmp     2f"     "n"
  262. /*
  263.  * Come here on an exception.  Recover the EXCEPTION_REGISTRATION
  264.  */
  266. "1:"     "t"
  267. "movl       %%fs:0,         %%edx"          "nt"
  268. "movl       0x8(%%edx),     %%edx"          "nt"
  270. /* 
  271.  * Come here however we exited.  Restore context from the
  272.  * EXCEPTION_REGISTRATION in case the stack is unbalanced.
  273.  */
  275. "2:"                                        "t"
  276. "movl       0xc(%%edx),     %%esp"          "nt"
  277. "movl       0x8(%%edx),     %%ebp"          "nt"
  278. "movl       0x0(%%edx),     %%eax"          "nt"
  279. "movl       %%eax,          %%fs:0"         "nt"
  281. :
  282. /* No outputs */
  283.         :
  284. [registration]  "m"     (registration),
  285. [nativeDst] "m"     (nativeDst),
  286. [nativeSrc]     "m"     (nativeSrc),
  287. [moveFile]      "r"     (tclWinProcs->moveFileProc)
  288.         :
  289. "%eax", "%ebx", "%ecx", "%edx", "memory"
  290.         );
  291.     if (registration.status != FALSE) {
  292. retval = TCL_OK;
  293.     }
  294. #endif
  296.     if (retval != -1)
  297.         return retval;
  299.     TclWinConvertError(GetLastError());
  301.     srcAttr = (*tclWinProcs->getFileAttributesProc)(nativeSrc);
  302.     dstAttr = (*tclWinProcs->getFileAttributesProc)(nativeDst);
  303.     if (srcAttr == 0xffffffff) {
  304. if ((*tclWinProcs->getFullPathNameProc)(nativeSrc, 0, NULL, NULL) >= MAX_PATH) {
  305.     errno = ENAMETOOLONG;
  306.     return TCL_ERROR;
  307. }
  308. srcAttr = 0;
  309.     }
  310.     if (dstAttr == 0xffffffff) {
  311. if ((*tclWinProcs->getFullPathNameProc)(nativeDst, 0, NULL, NULL) >= MAX_PATH) {
  312.     errno = ENAMETOOLONG;
  313.     return TCL_ERROR;
  314. }
  315. dstAttr = 0;
  316.     }
  318.     if (errno == EBADF) {
  319. errno = EACCES;
  320. return TCL_ERROR;
  321.     }
  322.     if (errno == EACCES) {
  323. decode:
  324. if (srcAttr & FILE_ATTRIBUTE_DIRECTORY) {
  325.     TCHAR *nativeSrcRest, *nativeDstRest;
  326.     CONST char **srcArgv, **dstArgv;
  327.     int size, srcArgc, dstArgc;
  328.     WCHAR nativeSrcPath[MAX_PATH];
  329.     WCHAR nativeDstPath[MAX_PATH];
  330.     Tcl_DString srcString, dstString;
  331.     CONST char *src, *dst;
  333.     size = (*tclWinProcs->getFullPathNameProc)(nativeSrc, MAX_PATH, 
  334.     nativeSrcPath, &nativeSrcRest);
  335.     if ((size == 0) || (size > MAX_PATH)) {
  336. return TCL_ERROR;
  337.     }
  338.     size = (*tclWinProcs->getFullPathNameProc)(nativeDst, MAX_PATH, 
  339.     nativeDstPath, &nativeDstRest);
  340.     if ((size == 0) || (size > MAX_PATH)) {
  341. return TCL_ERROR;
  342.     }
  343.     (*tclWinProcs->charLowerProc)((TCHAR *) nativeSrcPath);
  344.     (*tclWinProcs->charLowerProc)((TCHAR *) nativeDstPath);
  346.     src = Tcl_WinTCharToUtf((TCHAR *) nativeSrcPath, -1, &srcString);
  347.     dst = Tcl_WinTCharToUtf((TCHAR *) nativeDstPath, -1, &dstString);
  348.     if (strncmp(src, dst, (size_t) Tcl_DStringLength(&srcString)) == 0) {
  349. /*
  350.  * Trying to move a directory into itself.
  351.  */
  353. errno = EINVAL;
  354. Tcl_DStringFree(&srcString);
  355. Tcl_DStringFree(&dstString);
  356. return TCL_ERROR;
  357.     }
  358.     Tcl_SplitPath(src, &srcArgc, &srcArgv);
  359.     Tcl_SplitPath(dst, &dstArgc, &dstArgv);
  360.     Tcl_DStringFree(&srcString);
  361.     Tcl_DStringFree(&dstString);
  363.     if (srcArgc == 1) {
  364. /*
  365.  * They are trying to move a root directory.  Whether
  366.  * or not it is across filesystems, this cannot be
  367.  * done.
  368.  */
  370. Tcl_SetErrno(EINVAL);
  371.     } else if ((srcArgc > 0) && (dstArgc > 0) &&
  372.     (strcmp(srcArgv[0], dstArgv[0]) != 0)) {
  373. /*
  374.  * If src is a directory and dst filesystem != src
  375.  * filesystem, errno should be EXDEV.  It is very
  376.  * important to get this behavior, so that the caller
  377.  * can respond to a cross filesystem rename by
  378.  * simulating it with copy and delete.  The MoveFile
  379.  * system call already handles the case of moving a
  380.  * file between filesystems.
  381.  */
  383. Tcl_SetErrno(EXDEV);
  384.     }
  386.     ckfree((char *) srcArgv);
  387.     ckfree((char *) dstArgv);
  388. }
  390. /*
  391.  * Other types of access failure is that dst is a read-only
  392.  * filesystem, that an open file referred to src or dest, or that
  393.  * src or dest specified the current working directory on the
  394.  * current filesystem.  EACCES is returned for those cases.
  395.  */
  397.     } else if (Tcl_GetErrno() == EEXIST) {
  398. /*
  399.  * Reports EEXIST any time the target already exists.  If it makes
  400.  * sense, remove the old file and try renaming again.
  401.  */
  403. if (srcAttr & FILE_ATTRIBUTE_DIRECTORY) {
  404.     if (dstAttr & FILE_ATTRIBUTE_DIRECTORY) {
  405. /*
  406.  * Overwrite empty dst directory with src directory.  The
  407.  * following call will remove an empty directory.  If it
  408.  * fails, it's because it wasn't empty.
  409.  */
  411. if (DoRemoveJustDirectory(nativeDst, 0, NULL) == TCL_OK) {
  412.     /*
  413.      * Now that that empty directory is gone, we can try
  414.      * renaming again.  If that fails, we'll put this empty
  415.      * directory back, for completeness.
  416.      */
  418.     if ((*tclWinProcs->moveFileProc)(nativeSrc, nativeDst) != FALSE) {
  419. return TCL_OK;
  420.     }
  422.     /*
  423.      * Some new error has occurred.  Don't know what it
  424.      * could be, but report this one.
  425.      */
  427.     TclWinConvertError(GetLastError());
  428.     (*tclWinProcs->createDirectoryProc)(nativeDst, NULL);
  429.     (*tclWinProcs->setFileAttributesProc)(nativeDst, dstAttr);
  430.     if (Tcl_GetErrno() == EACCES) {
  431. /*
  432.  * Decode the EACCES to a more meaningful error.
  433.  */
  435. goto decode;
  436.     }
  437. }
  438.     } else { /* (dstAttr & FILE_ATTRIBUTE_DIRECTORY) == 0 */
  439. Tcl_SetErrno(ENOTDIR);
  440.     }
  441. } else {    /* (srcAttr & FILE_ATTRIBUTE_DIRECTORY) == 0 */
  442.     if (dstAttr & FILE_ATTRIBUTE_DIRECTORY) {
  443. Tcl_SetErrno(EISDIR);
  444.     } else {
  445. /*
  446.  * Overwrite existing file by:
  447.  * 
  448.  * 1. Rename existing file to temp name.
  449.  * 2. Rename old file to new name.
  450.  * 3. If success, delete temp file.  If failure,
  451.  *    put temp file back to old name.
  452.  */
  454. TCHAR *nativeRest, *nativeTmp, *nativePrefix;
  455. int result, size;
  456. WCHAR tempBuf[MAX_PATH];
  458. size = (*tclWinProcs->getFullPathNameProc)(nativeDst, MAX_PATH, 
  459. tempBuf, &nativeRest);
  460. if ((size == 0) || (size > MAX_PATH) || (nativeRest == NULL)) {
  461.     return TCL_ERROR;
  462. }
  463. nativeTmp = (TCHAR *) tempBuf;
  464. ((char *) nativeRest)[0] = '';
  465. ((char *) nativeRest)[1] = '';    /* In case it's Unicode. */
  467. result = TCL_ERROR;
  468. nativePrefix = (tclWinProcs->useWide) 
  469. ? (TCHAR *) L"tclr" : (TCHAR *) "tclr";
  470. if ((*tclWinProcs->getTempFileNameProc)(nativeTmp, 
  471. nativePrefix, 0, tempBuf) != 0) {
  472.     /*
  473.      * Strictly speaking, need the following DeleteFile and
  474.      * MoveFile to be joined as an atomic operation so no
  475.      * other app comes along in the meantime and creates the
  476.      * same temp file.
  477.      */
  478.      
  479.     nativeTmp = (TCHAR *) tempBuf;
  480.     (*tclWinProcs->deleteFileProc)(nativeTmp);
  481.     if ((*tclWinProcs->moveFileProc)(nativeDst, nativeTmp) != FALSE) {
  482. if ((*tclWinProcs->moveFileProc)(nativeSrc, nativeDst) != FALSE) {
  483.     (*tclWinProcs->setFileAttributesProc)(nativeTmp, 
  484.     FILE_ATTRIBUTE_NORMAL);
  485.     (*tclWinProcs->deleteFileProc)(nativeTmp);
  486.     return TCL_OK;
  487. } else {
  488.     (*tclWinProcs->deleteFileProc)(nativeDst);
  489.     (*tclWinProcs->moveFileProc)(nativeTmp, nativeDst);
  490. }
  491.     } 
  493.     /*
  494.      * Can't backup dst file or move src file.  Return that
  495.      * error.  Could happen if an open file refers to dst.
  496.      */
  498.     TclWinConvertError(GetLastError());
  499.     if (Tcl_GetErrno() == EACCES) {
  500. /*
  501.  * Decode the EACCES to a more meaningful error.
  502.  */
  504. goto decode;
  505.     }
  506. }
  507. return result;
  508.     }
  509. }
  510.     }
  511.     return TCL_ERROR;
  512. }
  514. /*
  515.  *---------------------------------------------------------------------------
  516.  *
  517.  * TclpObjCopyFile, DoCopyFile --
  518.  *
  519.  *      Copy a single file (not a directory).  If dst already exists and
  520.  * is not a directory, it is removed.
  521.  *
  522.  * Results:
  523.  * If the file was successfully copied, returns TCL_OK.  Otherwise
  524.  * the return value is TCL_ERROR and errno is set to indicate the
  525.  * error.  Some possible values for errno are:
  526.  *
  527.  * EACCES:     src or dst parent directory can't be read and/or written.
  528.  * EISDIR:     src or dst is a directory.
  529.  * ENOENT:     src doesn't exist.  src or dst is "".
  530.  *
  531.  * EACCES:     exists an open file already referring to dst (95).
  532.  * EACCES:     src specifies a char device (nul:, com1:, etc.) (NT)
  533.  * ENOENT:     src specifies a char device (nul:, com1:, etc.) (95)
  534.  *
  535.  * Side effects:
  536.  * It is not an error to copy to a char device.
  537.  *
  538.  *---------------------------------------------------------------------------
  539.  */
  541. int 
  542. TclpObjCopyFile(srcPathPtr, destPathPtr)
  543.     Tcl_Obj *srcPathPtr;
  544.     Tcl_Obj *destPathPtr;
  545. {
  546.     return DoCopyFile(Tcl_FSGetNativePath(srcPathPtr),
  547.       Tcl_FSGetNativePath(destPathPtr));
  548. }
  550. static int
  551. DoCopyFile(
  552.    CONST TCHAR *nativeSrc, /* Pathname of file to be copied (native). */
  553.    CONST TCHAR *nativeDst) /* Pathname of file to copy to (native). */
  554. {
  555. #ifdef HAVE_NO_SEH
  556.     EXCEPTION_REGISTRATION registration;
  557. #endif
  558.     int retval = -1;
  560.     /*
  561.      * The CopyFile API acts differently under Win95/98 and NT
  562.      * WRT NULL and "". Avoid passing these values.
  563.      */
  565.     if (nativeSrc == NULL || nativeSrc[0] == '' ||
  566.         nativeDst == NULL || nativeDst[0] == '') {
  567. Tcl_SetErrno(ENOENT);
  568. return TCL_ERROR;
  569.     }
  570.     
  571.     /*
  572.      * The CopyFile API would throw an exception under NT if one
  573.      * of the arguments is a char block device.
  574.      */
  576. #ifndef HAVE_NO_SEH
  577.     __try {
  578. if ((*tclWinProcs->copyFileProc)(nativeSrc, nativeDst, 0) != FALSE) {
  579.     retval = TCL_OK;
  580. }
  581.     } __except (EXCEPTION_EXECUTE_HANDLER) {}
  582. #else
  584.     /*
  585.      * Don't have SEH available, do things the hard way.
  586.      * Note that this needs to be one block of asm, to avoid stack
  587.      * imbalance; also, it is illegal for one asm block to contain 
  588.      * a jump to another.
  589.      */
  591.     __asm__ __volatile__ (
  593. /*
  594.  * Pick up parameters before messing with the stack
  595.  */
  597. "movl       %[nativeDst],   %%ebx"          "nt"
  598.         "movl       %[nativeSrc],   %%ecx"          "nt"
  599. /*
  600.  * Construct an EXCEPTION_REGISTRATION to protect the
  601.  * call to CopyFile
  602.  */
  603. "leal       %[registration], %%edx"         "nt"
  604. "movl       %%fs:0,         %%eax"          "nt"
  605. "movl       %%eax,          0x0(%%edx)"     "nt" /* link */
  606. "leal       1f,             %%eax"          "nt"
  607. "movl       %%eax,          0x4(%%edx)"     "nt" /* handler */
  608. "movl       %%ebp,          0x8(%%edx)"     "nt" /* ebp */
  609. "movl       %%esp,          0xc(%%edx)"     "nt" /* esp */
  610. "movl       $0,             0x10(%%edx)"    "nt" /* status */
  612. /* Link the EXCEPTION_REGISTRATION on the chain */
  614. "movl       %%edx,          %%fs:0"         "nt"
  616. /* Call CopyFile( nativeSrc, nativeDst, 0 ) */
  618. "movl     %[copyFile],    %%eax"     "nt"
  619. "pushl     $0"      "nt"
  620. "pushl     %%ebx"     "nt"
  621. "pushl     %%ecx"     "nt"
  622. "call     *%%eax"     "nt"
  624. /* 
  625.  * Come here on normal exit.  Recover the EXCEPTION_REGISTRATION
  626.  * and put the status return from CopyFile into it.
  627.  */
  629. "movl     %%fs:0,     %%edx"     "nt"
  630. "movl     %%eax,     0x10(%%edx)"    "nt"
  631. "jmp     2f"     "n"
  633. /*
  634.  * Come here on an exception.  Recover the EXCEPTION_REGISTRATION
  635.  */
  637. "1:"     "t"
  638. "movl       %%fs:0,         %%edx"          "nt"
  639. "movl       0x8(%%edx),     %%edx"          "nt"
  641. /* 
  642.  * Come here however we exited.  Restore context from the
  643.  * EXCEPTION_REGISTRATION in case the stack is unbalanced.
  644.  */
  646. "2:"                                        "t"
  647. "movl       0xc(%%edx),     %%esp"          "nt"
  648. "movl       0x8(%%edx),     %%ebp"          "nt"
  649. "movl       0x0(%%edx),     %%eax"          "nt"
  650. "movl       %%eax,          %%fs:0"         "nt"
  652. :
  653. /* No outputs */
  654.         :
  655. [registration]  "m"     (registration),
  656. [nativeDst] "m"     (nativeDst),
  657. [nativeSrc]     "m"     (nativeSrc),
  658. [copyFile]      "r"     (tclWinProcs->copyFileProc)
  659.         :
  660. "%eax", "%ebx", "%ecx", "%edx", "memory"
  661.         );
  662.     if (registration.status != FALSE) {
  663. retval = TCL_OK;
  664.     }
  665. #endif
  667.     if (retval != -1)
  668.         return retval;
  670.     TclWinConvertError(GetLastError());
  671.     if (Tcl_GetErrno() == EBADF) {
  672. Tcl_SetErrno(EACCES);
  673. return TCL_ERROR;
  674.     }
  675.     if (Tcl_GetErrno() == EACCES) {
  676. DWORD srcAttr, dstAttr;
  678. srcAttr = (*tclWinProcs->getFileAttributesProc)(nativeSrc);
  679. dstAttr = (*tclWinProcs->getFileAttributesProc)(nativeDst);
  680. if (srcAttr != 0xffffffff) {
  681.     if (dstAttr == 0xffffffff) {
  682. dstAttr = 0;
  683.     }
  684.     if ((srcAttr & FILE_ATTRIBUTE_DIRECTORY) ||
  685.     (dstAttr & FILE_ATTRIBUTE_DIRECTORY)) {
  686. if (srcAttr & FILE_ATTRIBUTE_REPARSE_POINT) {
  687.     /* Source is a symbolic link -- copy it */
  688.     if (TclWinSymLinkCopyDirectory(nativeSrc, nativeDst) == 0) {
  689.         return TCL_OK;
  690.     }
  691. }
  692. Tcl_SetErrno(EISDIR);
  693.     }
  694.     if (dstAttr & FILE_ATTRIBUTE_READONLY) {
  695. (*tclWinProcs->setFileAttributesProc)(nativeDst, 
  696. dstAttr & ~((DWORD)FILE_ATTRIBUTE_READONLY));
  697. if ((*tclWinProcs->copyFileProc)(nativeSrc, nativeDst, 0) != FALSE) {
  698.     return TCL_OK;
  699. }
  700. /*
  701.  * Still can't copy onto dst.  Return that error, and
  702.  * restore attributes of dst.
  703.  */
  705. TclWinConvertError(GetLastError());
  706. (*tclWinProcs->setFileAttributesProc)(nativeDst, dstAttr);
  707.     }
  708. }
  709.     }
  710.     return TCL_ERROR;
  711. }
  713. /*
  714.  *---------------------------------------------------------------------------
  715.  *
  716.  * TclpObjDeleteFile, TclpDeleteFile --
  717.  *
  718.  *      Removes a single file (not a directory).
  719.  *
  720.  * Results:
  721.  * If the file was successfully deleted, returns TCL_OK.  Otherwise
  722.  * the return value is TCL_ERROR and errno is set to indicate the
  723.  * error.  Some possible values for errno are:
  724.  *
  725.  * EACCES:     a parent directory can't be read and/or written.
  726.  * EISDIR:     path is a directory.
  727.  * ENOENT:     path doesn't exist or is "".
  728.  *
  729.  * EACCES:     exists an open file already referring to path.
  730.  * EACCES:     path is a char device (nul:, com1:, etc.)
  731.  *
  732.  * Side effects:
  733.  *      The file is deleted, even if it is read-only.
  734.  *
  735.  *---------------------------------------------------------------------------
  736.  */
  738. int 
  739. TclpObjDeleteFile(pathPtr)
  740.     Tcl_Obj *pathPtr;
  741. {
  742.     return TclpDeleteFile(Tcl_FSGetNativePath(pathPtr));
  743. }
  745. int
  746. TclpDeleteFile(
  747.     CONST TCHAR *nativePath) /* Pathname of file to be removed (native). */
  748. {
  749.     DWORD attr;
  751.     /*
  752.      * The DeleteFile API acts differently under Win95/98 and NT
  753.      * WRT NULL and "". Avoid passing these values.
  754.      */
  756.     if (nativePath == NULL || nativePath[0] == '') {
  757. Tcl_SetErrno(ENOENT);
  758. return TCL_ERROR;
  759.     }
  761.     if ((*tclWinProcs->deleteFileProc)(nativePath) != FALSE) {
  762. return TCL_OK;
  763.     }
  764.     TclWinConvertError(GetLastError());
  766.     if (Tcl_GetErrno() == EACCES) {
  767.         attr = (*tclWinProcs->getFileAttributesProc)(nativePath);
  768. if (attr != 0xffffffff) {
  769.     if (attr & FILE_ATTRIBUTE_DIRECTORY) {
  770. if (attr & FILE_ATTRIBUTE_REPARSE_POINT) {
  771.     /* It is a symbolic link -- remove it */
  772.     if (TclWinSymLinkDelete(nativePath, 0) == 0) {
  773.         return TCL_OK;
  774.     }
  775. }
  777. /* 
  778.  * If we fall through here, it is a directory.
  779.  * 
  780.  * Windows NT reports removing a directory as EACCES instead
  781.  * of EISDIR.
  782.  */
  784. Tcl_SetErrno(EISDIR);
  785.     } else if (attr & FILE_ATTRIBUTE_READONLY) {
  786. int res = (*tclWinProcs->setFileAttributesProc)(nativePath, 
  787. attr & ~((DWORD)FILE_ATTRIBUTE_READONLY));
  788. if ((res != 0) && ((*tclWinProcs->deleteFileProc)(nativePath)
  789. != FALSE)) {
  790.     return TCL_OK;
  791. }
  792. TclWinConvertError(GetLastError());
  793. if (res != 0) {
  794.     (*tclWinProcs->setFileAttributesProc)(nativePath, attr);
  795. }
  796.     }
  797. }
  798.     } else if (Tcl_GetErrno() == ENOENT) {
  799.         attr = (*tclWinProcs->getFileAttributesProc)(nativePath);
  800. if (attr != 0xffffffff) {
  801.     if (attr & FILE_ATTRIBUTE_DIRECTORY) {
  802.      /*
  803.  * Windows 95 reports removing a directory as ENOENT instead 
  804.  * of EISDIR. 
  805.  */
  807. Tcl_SetErrno(EISDIR);
  808.     }
  809. }
  810.     } else if (Tcl_GetErrno() == EINVAL) {
  811. /*
  812.  * Windows NT reports removing a char device as EINVAL instead of
  813.  * EACCES.
  814.  */
  816. Tcl_SetErrno(EACCES);
  817.     }
  819.     return TCL_ERROR;
  820. }
  822. /*
  823.  *---------------------------------------------------------------------------
  824.  *
  825.  * TclpObjCreateDirectory --
  826.  *
  827.  *      Creates the specified directory.  All parent directories of the
  828.  * specified directory must already exist.  The directory is
  829.  * automatically created with permissions so that user can access
  830.  * the new directory and create new files or subdirectories in it.
  831.  *
  832.  * Results:
  833.  * If the directory was successfully created, returns TCL_OK.
  834.  * Otherwise the return value is TCL_ERROR and errno is set to
  835.  * indicate the error.  Some possible values for errno are:
  836.  *
  837.  * EACCES:     a parent directory can't be read and/or written.
  838.  * EEXIST:     path already exists.
  839.  * ENOENT:     a parent directory doesn't exist.
  840.  *
  841.  * Side effects:
  842.  *      A directory is created.
  843.  *
  844.  *---------------------------------------------------------------------------
  845.  */
  847. int 
  848. TclpObjCreateDirectory(pathPtr)
  849.     Tcl_Obj *pathPtr;
  850. {
  851.     return DoCreateDirectory(Tcl_FSGetNativePath(pathPtr));
  852. }
  854. static int
  855. DoCreateDirectory(
  856.     CONST TCHAR *nativePath) /* Pathname of directory to create (native). */
  857. {
  858.     DWORD error;
  859.     if ((*tclWinProcs->createDirectoryProc)(nativePath, NULL) == 0) {
  860. error = GetLastError();
  861. TclWinConvertError(error);
  862. return TCL_ERROR;
  863.     }   
  864.     return TCL_OK;
  865. }
  867. /*
  868.  *---------------------------------------------------------------------------
  869.  *
  870.  * TclpObjCopyDirectory --
  871.  *
  872.  *      Recursively copies a directory.  The target directory dst must
  873.  * not already exist.  Note that this function does not merge two
  874.  * directory hierarchies, even if the target directory is an an
  875.  * empty directory.
  876.  *
  877.  * Results:
  878.  * If the directory was successfully copied, returns TCL_OK.
  879.  * Otherwise the return value is TCL_ERROR, errno is set to indicate
  880.  * the error, and the pathname of the file that caused the error
  881.  * is stored in errorPtr.  See TclpCreateDirectory and TclpCopyFile
  882.  * for a description of possible values for errno.
  883.  *
  884.  * Side effects:
  885.  *      An exact copy of the directory hierarchy src will be created
  886.  * with the name dst.  If an error occurs, the error will
  887.  *      be returned immediately, and remaining files will not be
  888.  * processed.
  889.  *
  890.  *---------------------------------------------------------------------------
  891.  */
  893. int 
  894. TclpObjCopyDirectory(srcPathPtr, destPathPtr, errorPtr)
  895.     Tcl_Obj *srcPathPtr;
  896.     Tcl_Obj *destPathPtr;
  897.     Tcl_Obj **errorPtr;
  898. {
  899.     Tcl_DString ds;
  900.     Tcl_DString srcString, dstString;
  901.     Tcl_Obj *normSrcPtr, *normDestPtr;
  902.     int ret;
  904.     normSrcPtr = Tcl_FSGetNormalizedPath(NULL,srcPathPtr);
  905.     if (normSrcPtr == NULL) {
  906. return TCL_ERROR;
  907.     }
  908.     Tcl_WinUtfToTChar(Tcl_GetString(normSrcPtr), -1, &srcString);
  909.     normDestPtr = Tcl_FSGetNormalizedPath(NULL,destPathPtr);
  910.     if (normDestPtr == NULL) {
  911. return TCL_ERROR;
  912.     }
  913.     Tcl_WinUtfToTChar(Tcl_GetString(normDestPtr), -1, &dstString);
  915.     ret = TraverseWinTree(TraversalCopy, &srcString, &dstString, &ds);
  917.     Tcl_DStringFree(&srcString);
  918.     Tcl_DStringFree(&dstString);
  920.     if (ret != TCL_OK) {
  921. if (!strcmp(Tcl_DStringValue(&ds), Tcl_GetString(normSrcPtr))) {
  922.     *errorPtr = srcPathPtr;
  923. } else if (!strcmp(Tcl_DStringValue(&ds), Tcl_GetString(normDestPtr))) {
  924.     *errorPtr = destPathPtr;
  925. } else {
  926.     *errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1);
  927. }
  928. Tcl_DStringFree(&ds);
  929. Tcl_IncrRefCount(*errorPtr);
  930.     }
  931.     return ret;
  932. }
  934. /*
  935.  *----------------------------------------------------------------------
  936.  *
  937.  * TclpObjRemoveDirectory, DoRemoveDirectory -- 
  938.  *
  939.  * Removes directory (and its contents, if the recursive flag is set).
  940.  *
  941.  * Results:
  942.  * If the directory was successfully removed, returns TCL_OK.
  943.  * Otherwise the return value is TCL_ERROR, errno is set to indicate
  944.  * the error, and the pathname of the file that caused the error
  945.  * is stored in errorPtr.  Some possible values for errno are:
  946.  *
  947.  * EACCES:     path directory can't be read and/or written.
  948.  * EEXIST:     path is a non-empty directory.
  949.  * EINVAL:     path is root directory or current directory.
  950.  * ENOENT:     path doesn't exist or is "".
  951.  *  ENOTDIR:    path is not a directory.
  952.  *
  953.  * EACCES:     path is a char device (nul:, com1:, etc.) (95)
  954.  * EINVAL:     path is a char device (nul:, com1:, etc.) (NT)
  955.  *
  956.  * Side effects:
  957.  * Directory removed.  If an error occurs, the error will be returned
  958.  * immediately, and remaining files will not be deleted.
  959.  *
  960.  *----------------------------------------------------------------------
  961.  */
  963. int 
  964. TclpObjRemoveDirectory(pathPtr, recursive, errorPtr)
  965.     Tcl_Obj *pathPtr;
  966.     int recursive;
  967.     Tcl_Obj **errorPtr;
  968. {
  969.     Tcl_DString ds;
  970.     Tcl_Obj *normPtr = NULL;
  971.     int ret;
  972.     if (recursive) {
  973. /* 
  974.  * In the recursive case, the string rep is used to construct a
  975.  * Tcl_DString which may be used extensively, so we can't
  976.  * optimize this case easily.
  977.  */
  978. Tcl_DString native;
  979. normPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
  980. if (normPtr == NULL) {
  981.     return TCL_ERROR;
  982. }
  983. Tcl_WinUtfToTChar(Tcl_GetString(normPtr), -1, &native);
  984. ret = DoRemoveDirectory(&native, recursive, &ds);
  985. Tcl_DStringFree(&native);
  986.     } else {
  987. ret = DoRemoveJustDirectory(Tcl_FSGetNativePath(pathPtr), 
  988.     0, &ds);
  989.     }
  990.     if (ret != TCL_OK) {
  991. int len = Tcl_DStringLength(&ds);
  992. if (len > 0) {
  993.     if (normPtr != NULL 
  994.       && !strcmp(Tcl_DStringValue(&ds), Tcl_GetString(normPtr))) {
  995. *errorPtr = pathPtr;
  996.     } else {
  997. *errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1);
  998.     }
  999.     Tcl_IncrRefCount(*errorPtr);
  1000. }
  1001. Tcl_DStringFree(&ds);
  1002.     }
  1003.     return ret;
  1004. }
  1006. static int
  1007. DoRemoveJustDirectory(
  1008.     CONST TCHAR *nativePath, /* Pathname of directory to be removed
  1009.  * (native). */
  1010.     int ignoreError, /* If non-zero, don't initialize the
  1011.                     * errorPtr under some circumstances
  1012.                     * on return. */
  1013.     Tcl_DString *errorPtr) /* If non-NULL, uninitialized or free
  1014.  * DString filled with UTF-8 name of file
  1015.  * causing error. */
  1016. {
  1017.     /*
  1018.      * The RemoveDirectory API acts differently under Win95/98 and NT
  1019.      * WRT NULL and "". Avoid passing these values.
  1020.      */
  1022.     if (nativePath == NULL || nativePath[0] == '') {
  1023. Tcl_SetErrno(ENOENT);
  1024. goto end;
  1025.     }
  1027.     if ((*tclWinProcs->removeDirectoryProc)(nativePath) != FALSE) {
  1028. return TCL_OK;
  1029.     }
  1030.     TclWinConvertError(GetLastError());
  1032.     if (Tcl_GetErrno() == EACCES) {
  1033. DWORD attr = (*tclWinProcs->getFileAttributesProc)(nativePath);
  1034. if (attr != 0xffffffff) {
  1035.     if ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0) {
  1036. /* 
  1037.  * Windows 95 reports calling RemoveDirectory on a file as an 
  1038.  * EACCES, not an ENOTDIR.
  1039.  */
  1041. Tcl_SetErrno(ENOTDIR);
  1042. goto end;
  1043.     }
  1045.     if (attr & FILE_ATTRIBUTE_REPARSE_POINT) {
  1046. /* It is a symbolic link -- remove it */
  1047. if (TclWinSymLinkDelete(nativePath, 1) != 0) {
  1048.     goto end;
  1049. }
  1050.     }
  1051.     
  1052.     if (attr & FILE_ATTRIBUTE_READONLY) {
  1053. attr &= ~FILE_ATTRIBUTE_READONLY;
  1054. if ((*tclWinProcs->setFileAttributesProc)(nativePath, attr) == FALSE) {
  1055.     goto end;
  1056. }
  1057. if ((*tclWinProcs->removeDirectoryProc)(nativePath) != FALSE) {
  1058.     return TCL_OK;
  1059. }
  1060. TclWinConvertError(GetLastError());
  1061. (*tclWinProcs->setFileAttributesProc)(nativePath, 
  1062. attr | FILE_ATTRIBUTE_READONLY);
  1063.     }
  1065.     /* 
  1066.      * Windows 95 and Win32s report removing a non-empty directory 
  1067.      * as EACCES, not EEXIST.  If the directory is not empty,
  1068.      * change errno so caller knows what's going on.
  1069.      */
  1071.     if (TclWinGetPlatformId() != VER_PLATFORM_WIN32_NT) {
  1072. CONST char *path, *find;
  1073. HANDLE handle;
  1074. WIN32_FIND_DATAA data;
  1075. Tcl_DString buffer;
  1076. int len;
  1078. path = (CONST char *) nativePath;
  1080. Tcl_DStringInit(&buffer);
  1081. len = strlen(path);
  1082. find = Tcl_DStringAppend(&buffer, path, len);
  1083. if ((len > 0) && (find[len - 1] != '\')) {
  1084.     Tcl_DStringAppend(&buffer, "\", 1);
  1085. }
  1086. find = Tcl_DStringAppend(&buffer, "*.*", 3);
  1087. handle = FindFirstFileA(find, &data);
  1088. if (handle != INVALID_HANDLE_VALUE) {
  1089.     while (1) {
  1090. if ((strcmp(data.cFileName, ".") != 0)
  1091. && (strcmp(data.cFileName, "..") != 0)) {
  1092.     /*
  1093.      * Found something in this directory.
  1094.      */
  1096.     Tcl_SetErrno(EEXIST);
  1097.     break;
  1098. }
  1099. if (FindNextFileA(handle, &data) == FALSE) {
  1100.     break;
  1101. }
  1102.     }
  1103.     FindClose(handle);
  1104. }
  1105. Tcl_DStringFree(&buffer);
  1106.     }
  1107. }
  1108.     }
  1109.     if (Tcl_GetErrno() == ENOTEMPTY) {
  1110. /* 
  1111.  * The caller depends on EEXIST to signify that the directory is
  1112.  * not empty, not ENOTEMPTY. 
  1113.  */
  1115. Tcl_SetErrno(EEXIST);
  1116.     }
  1117.     if ((ignoreError != 0) && (Tcl_GetErrno() == EEXIST)) {
  1118. /* 
  1119.  * If we're being recursive, this error may actually
  1120.  * be ok, so we don't want to initialise the errorPtr
  1121.  * yet.
  1122.  */
  1123. return TCL_ERROR;
  1124.     }
  1126.     end:
  1127.     if (errorPtr != NULL) {
  1128. Tcl_WinTCharToUtf(nativePath, -1, errorPtr);
  1129.     }
  1130.     return TCL_ERROR;
  1132. }
  1134. static int
  1135. DoRemoveDirectory(
  1136.     Tcl_DString *pathPtr, /* Pathname of directory to be removed
  1137.  * (native). */
  1138.     int recursive, /* If non-zero, removes directories that
  1139.  * are nonempty.  Otherwise, will only remove
  1140.  * empty directories. */
  1141.     Tcl_DString *errorPtr) /* If non-NULL, uninitialized or free
  1142.  * DString filled with UTF-8 name of file
  1143.  * causing error. */
  1144. {
  1145.     int res = DoRemoveJustDirectory(Tcl_DStringValue(pathPtr), recursive, 
  1146.     errorPtr);
  1147.     
  1148.     if ((res == TCL_ERROR) && (recursive != 0) && (Tcl_GetErrno() == EEXIST)) {
  1149. /*
  1150.  * The directory is nonempty, but the recursive flag has been
  1151.  * specified, so we recursively remove all the files in the directory.
  1152.  */
  1153. return TraverseWinTree(TraversalDelete, pathPtr, NULL, errorPtr);
  1154.     } else {
  1155. return res;
  1156.     }
  1157. }
  1159. /*
  1160.  *---------------------------------------------------------------------------
  1161.  *
  1162.  * TraverseWinTree --
  1163.  *
  1164.  *      Traverse directory tree specified by sourcePtr, calling the function 
  1165.  * traverseProc for each file and directory encountered.  If destPtr 
  1166.  * is non-null, each of name in the sourcePtr directory is appended to 
  1167.  * the directory specified by destPtr and passed as the second argument 
  1168.  * to traverseProc() .
  1169.  *
  1170.  * Results:
  1171.  *      Standard Tcl result.
  1172.  *
  1173.  * Side effects:
  1174.  *      None caused by TraverseWinTree, however the user specified 
  1175.  * traverseProc() may change state.  If an error occurs, the error will
  1176.  *      be returned immediately, and remaining files will not be processed.
  1177.  *
  1178.  *---------------------------------------------------------------------------
  1179.  */
  1181. static int 
  1182. TraverseWinTree(
  1183.     TraversalProc *traverseProc,/* Function to call for every file and
  1184.  * directory in source hierarchy. */
  1185.     Tcl_DString *sourcePtr, /* Pathname of source directory to be
  1186.  * traversed (native). */
  1187.     Tcl_DString *targetPtr, /* Pathname of directory to traverse in
  1188.  * parallel with source directory (native),
  1189.  * may be NULL. */
  1190.     Tcl_DString *errorPtr) /* If non-NULL, uninitialized or free
  1191.  * DString filled with UTF-8 name of file
  1192.  * causing error. */
  1193. {
  1194.     DWORD sourceAttr;
  1195.     TCHAR *nativeSource, *nativeTarget, *nativeErrfile;
  1196.     int result, found, sourceLen, targetLen, oldSourceLen, oldTargetLen;
  1197.     HANDLE handle;
  1198.     WIN32_FIND_DATAT data;
  1200.     nativeErrfile = NULL;
  1201.     result = TCL_OK;
  1202.     oldTargetLen = 0; /* lint. */
  1204.     nativeSource = (TCHAR *) Tcl_DStringValue(sourcePtr);
  1205.     nativeTarget = (TCHAR *) (targetPtr == NULL 
  1206.       ? NULL : Tcl_DStringValue(targetPtr));
  1207.     
  1208.     oldSourceLen = Tcl_DStringLength(sourcePtr);
  1209.     sourceAttr = (*tclWinProcs->getFileAttributesProc)(nativeSource);
  1210.     if (sourceAttr == 0xffffffff) {
  1211. nativeErrfile = nativeSource;
  1212. goto end;
  1213.     }
  1214.     if ((sourceAttr & FILE_ATTRIBUTE_DIRECTORY) == 0) {
  1215. /*
  1216.  * Process the regular file
  1217.  */
  1219. return (*traverseProc)(nativeSource, nativeTarget, DOTREE_F, errorPtr);
  1220.     }
  1222.     if (tclWinProcs->useWide) {
  1223. Tcl_DStringAppend(sourcePtr, (char *) L"\*.*", 4 * sizeof(WCHAR) + 1);
  1224. Tcl_DStringSetLength(sourcePtr, Tcl_DStringLength(sourcePtr) - 1);
  1225.     } else {
  1226. Tcl_DStringAppend(sourcePtr, "\*.*", 4);
  1227.     }
  1228.     nativeSource = (TCHAR *) Tcl_DStringValue(sourcePtr);
  1229.     handle = (*tclWinProcs->findFirstFileProc)(nativeSource, &data);
  1230.     if (handle == INVALID_HANDLE_VALUE) {      
  1231. /* 
  1232.  * Can't read directory
  1233.  */
  1235. TclWinConvertError(GetLastError());
  1236. nativeErrfile = nativeSource;
  1237. goto end;
  1238.     }
  1240.     nativeSource[oldSourceLen + 1] = '';
  1241.     Tcl_DStringSetLength(sourcePtr, oldSourceLen);
  1242.     result = (*traverseProc)(nativeSource, nativeTarget, DOTREE_PRED, errorPtr);
  1243.     if (result != TCL_OK) {
  1244. FindClose(handle);
  1245. return result;
  1246.     }
  1248.     sourceLen = oldSourceLen;
  1250.     if (tclWinProcs->useWide) {
  1251. sourceLen += sizeof(WCHAR);
  1252. Tcl_DStringAppend(sourcePtr, (char *) L"\", sizeof(WCHAR) + 1);
  1253. Tcl_DStringSetLength(sourcePtr, sourceLen);
  1254.     } else {
  1255. sourceLen += 1;
  1256. Tcl_DStringAppend(sourcePtr, "\", 1);
  1257.     }
  1258.     if (targetPtr != NULL) {
  1259. oldTargetLen = Tcl_DStringLength(targetPtr);
  1261. targetLen = oldTargetLen;
  1262. if (tclWinProcs->useWide) {
  1263.     targetLen += sizeof(WCHAR);
  1264.     Tcl_DStringAppend(targetPtr, (char *) L"\", sizeof(WCHAR) + 1);
  1265.     Tcl_DStringSetLength(targetPtr, targetLen);
  1266. } else {
  1267.     targetLen += 1;
  1268.     Tcl_DStringAppend(targetPtr, "\", 1);
  1269. }
  1270.     }
  1272.     found = 1;
  1273.     for ( ; found; found = (*tclWinProcs->findNextFileProc)(handle, &data)) {
  1274. TCHAR *nativeName;
  1275. int len;
  1277. if (tclWinProcs->useWide) {
  1278.     WCHAR *wp;
  1280.     wp = data.w.cFileName;
  1281.     if (*wp == '.') {
  1282. wp++;
  1283. if (*wp == '.') {
  1284.     wp++;
  1285. }
  1286. if (*wp == '') {
  1287.     continue;
  1288. }
  1289.     }
  1290.     nativeName = (TCHAR *) data.w.cFileName;
  1291.     len = wcslen(data.w.cFileName) * sizeof(WCHAR);
  1292. } else {
  1293.     if ((strcmp(data.a.cFileName, ".") == 0) 
  1294.     || (strcmp(data.a.cFileName, "..") == 0)) {
  1295. continue;
  1296.     }
  1297.     nativeName = (TCHAR *) data.a.cFileName;
  1298.     len = strlen(data.a.cFileName);
  1299. }
  1301. /* 
  1302.  * Append name after slash, and recurse on the file. 
  1303.  */
  1305. Tcl_DStringAppend(sourcePtr, (char *) nativeName, len + 1);
  1306. Tcl_DStringSetLength(sourcePtr, Tcl_DStringLength(sourcePtr) - 1);
  1307. if (targetPtr != NULL) {
  1308.     Tcl_DStringAppend(targetPtr, (char *) nativeName, len + 1);
  1309.     Tcl_DStringSetLength(targetPtr, Tcl_DStringLength(targetPtr) - 1);
  1310. }
  1311. result = TraverseWinTree(traverseProc, sourcePtr, targetPtr, 
  1312. errorPtr);
  1313. if (result != TCL_OK) {
  1314.     break;
  1315. }
  1317. /*
  1318.  * Remove name after slash.
  1319.  */
  1321. Tcl_DStringSetLength(sourcePtr, sourceLen);
  1322. if (targetPtr != NULL) {
  1323.     Tcl_DStringSetLength(targetPtr, targetLen);
  1324. }
  1325.     }
  1326.     FindClose(handle);
  1328.     /*
  1329.      * Strip off the trailing slash we added
  1330.      */
  1332.     Tcl_DStringSetLength(sourcePtr, oldSourceLen + 1);
  1333.     Tcl_DStringSetLength(sourcePtr, oldSourceLen);
  1334.     if (targetPtr != NULL) {
  1335. Tcl_DStringSetLength(targetPtr, oldTargetLen + 1);
  1336. Tcl_DStringSetLength(targetPtr, oldTargetLen);
  1337.     }
  1338.     if (result == TCL_OK) {
  1339. /*
  1340.  * Call traverseProc() on a directory after visiting all the
  1341.  * files in that directory.
  1342.  */
  1344. result = (*traverseProc)(Tcl_DStringValue(sourcePtr), 
  1345. (targetPtr == NULL ? NULL : Tcl_DStringValue(targetPtr)), 
  1346. DOTREE_POSTD, errorPtr);
  1347.     }
  1348.     end:
  1349.     if (nativeErrfile != NULL) {
  1350. TclWinConvertError(GetLastError());
  1351. if (errorPtr != NULL) {
  1352.     Tcl_WinTCharToUtf(nativeErrfile, -1, errorPtr);
  1353. }
  1354. result = TCL_ERROR;
  1355.     }
  1357.     return result;
  1358. }
  1360. /*
  1361.  *----------------------------------------------------------------------
  1362.  *
  1363.  * TraversalCopy
  1364.  *
  1365.  *      Called from TraverseUnixTree in order to execute a recursive
  1366.  *      copy of a directory.
  1367.  *
  1368.  * Results:
  1369.  *      Standard Tcl result.
  1370.  *
  1371.  * Side effects:
  1372.  *      Depending on the value of type, src may be copied to dst.
  1373.  *      
  1374.  *----------------------------------------------------------------------
  1375.  */
  1377. static int 
  1378. TraversalCopy(
  1379.     CONST TCHAR *nativeSrc, /* Source pathname to copy. */
  1380.     CONST TCHAR *nativeDst, /* Destination pathname of copy. */
  1381.     int type, /* Reason for call - see TraverseWinTree() */
  1382.     Tcl_DString *errorPtr) /* If non-NULL, initialized DString filled
  1383.  * with UTF-8 name of file causing error. */
  1384. {
  1385.     switch (type) {
  1386. case DOTREE_F: {
  1387.     if (DoCopyFile(nativeSrc, nativeDst) == TCL_OK) {
  1388. return TCL_OK;
  1389.     }
  1390.     break;
  1391. }
  1392. case DOTREE_PRED: {
  1393.     if (DoCreateDirectory(nativeDst) == TCL_OK) {
  1394. DWORD attr = (*tclWinProcs->getFileAttributesProc)(nativeSrc);
  1395. if ((*tclWinProcs->setFileAttributesProc)(nativeDst, attr) != FALSE) {
  1396.     return TCL_OK;
  1397. }
  1398. TclWinConvertError(GetLastError());
  1399.     }
  1400.     break;
  1401. }
  1402.         case DOTREE_POSTD: {
  1403.     return TCL_OK;
  1404. }
  1405.     }
  1407.     /*
  1408.      * There shouldn't be a problem with src, because we already
  1409.      * checked it to get here.
  1410.      */
  1412.     if (errorPtr != NULL) {
  1413. Tcl_WinTCharToUtf(nativeDst, -1, errorPtr);
  1414.     }
  1415.     return TCL_ERROR;
  1416. }
  1418. /*
  1419.  *----------------------------------------------------------------------
  1420.  *
  1421.  * TraversalDelete --
  1422.  *
  1423.  *      Called by procedure TraverseWinTree for every file and
  1424.  *      directory that it encounters in a directory hierarchy. This
  1425.  *      procedure unlinks files, and removes directories after all the
  1426.  *      containing files have been processed.
  1427.  *
  1428.  * Results:
  1429.  *      Standard Tcl result.
  1430.  *
  1431.  * Side effects:
  1432.  *      Files or directory specified by src will be deleted. If an
  1433.  *      error occurs, the windows error is converted to a Posix error
  1434.  *      and errno is set accordingly.
  1435.  *
  1436.  *----------------------------------------------------------------------
  1437.  */
  1439. static int
  1440. TraversalDelete( 
  1441.     CONST TCHAR *nativeSrc, /* Source pathname to delete. */
  1442.     CONST TCHAR *dstPtr, /* Not used. */
  1443.     int type, /* Reason for call - see TraverseWinTree() */
  1444.     Tcl_DString *errorPtr) /* If non-NULL, initialized DString filled
  1445.  * with UTF-8 name of file causing error. */
  1446. {
  1447.     switch (type) {
  1448. case DOTREE_F: {
  1449.     if (TclpDeleteFile(nativeSrc) == TCL_OK) {
  1450. return TCL_OK;
  1451.     }
  1452.     break;
  1453. }
  1454. case DOTREE_PRED: {
  1455.     return TCL_OK;
  1456. }
  1457. case DOTREE_POSTD: {
  1458.     if (DoRemoveJustDirectory(nativeSrc, 0, NULL) == TCL_OK) {
  1459. return TCL_OK;
  1460.     }
  1461.     break;
  1462. }
  1463.     }
  1465.     if (errorPtr != NULL) {
  1466. Tcl_WinTCharToUtf(nativeSrc, -1, errorPtr);
  1467.     }
  1468.     return TCL_ERROR;
  1469. }
  1471. /*
  1472.  *----------------------------------------------------------------------
  1473.  *
  1474.  * StatError --
  1475.  *
  1476.  * Sets the object result with the appropriate error.
  1477.  *
  1478.  * Results:
  1479.  *      None.
  1480.  *
  1481.  * Side effects:
  1482.  *      The interp's object result is set with an error message
  1483.  * based on the objIndex, fileName and errno.
  1484.  *
  1485.  *----------------------------------------------------------------------
  1486.  */
  1488. static void
  1489. StatError(
  1490.     Tcl_Interp *interp, /* The interp that has the error */
  1491.     Tcl_Obj *fileName)         /* The name of the file which caused the 
  1492.  * error. */
  1493. {
  1494.     TclWinConvertError(GetLastError());
  1495.     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), 
  1496.    "could not read "", Tcl_GetString(fileName), 
  1497.    "": ", Tcl_PosixError(interp), 
  1498.    (char *) NULL);
  1499. }
  1501. /*
  1502.  *----------------------------------------------------------------------
  1503.  *
  1504.  * GetWinFileAttributes --
  1505.  *
  1506.  *      Returns a Tcl_Obj containing the value of a file attribute.
  1507.  * This routine gets the -hidden, -readonly or -system attribute.
  1508.  *
  1509.  * Results:
  1510.  *      Standard Tcl result and a Tcl_Obj in attributePtrPtr. The object
  1511.  * will have ref count 0. If the return value is not TCL_OK,
  1512.  * attributePtrPtr is not touched.
  1513.  *
  1514.  * Side effects:
  1515.  *      A new object is allocated if the file is valid.
  1516.  *
  1517.  *----------------------------------------------------------------------
  1518.  */
  1520. static int
  1521. GetWinFileAttributes(
  1522.     Tcl_Interp *interp, /* The interp we are using for errors. */
  1523.     int objIndex, /* The index of the attribute. */
  1524.     Tcl_Obj *fileName,         /* The name of the file. */
  1525.     Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */
  1526. {
  1527.     DWORD result;
  1528.     CONST TCHAR *nativeName;
  1529.     int attr;
  1530.     
  1531.     nativeName = Tcl_FSGetNativePath(fileName);
  1532.     result = (*tclWinProcs->getFileAttributesProc)(nativeName);
  1534.     if (result == 0xffffffff) {
  1535. StatError(interp, fileName);
  1536. return TCL_ERROR;
  1537.     }
  1539.     attr = (int)(result & attributeArray[objIndex]);
  1540.     if ((objIndex == WIN_HIDDEN_ATTRIBUTE) && (attr != 0)) {
  1541. /* 
  1542.  * It is hidden.  However there is a bug on some Windows
  1543.  * OSes in which root volumes (drives) formatted as NTFS
  1544.  * are declared hidden when they are not (and cannot be).
  1545.  * 
  1546.  * We test for, and fix that case, here.
  1547.  */
  1548. int len;
  1549. char *str = Tcl_GetStringFromObj(fileName,&len);
  1550. if (len < 4) {
  1551.     if (len == 0) {
  1552. /* 
  1553.  * Not sure if this is possible, but we pass it on
  1554.  * anyway 
  1555.  */
  1556.     } else if (len == 1 && (str[0] == '/' || str[0] == '\')) {
  1557. /* Path is pointing to the root volume */
  1558. attr = 0;
  1559.     } else if ((str[1] == ':') 
  1560.        && (len == 2 || (str[2] == '/' || str[2] == '\'))) {
  1561. /* Path is of the form 'x:' or 'x:/' or 'x:' */
  1562. attr = 0;
  1563.     }
  1564. }
  1565.     }
  1566.     *attributePtrPtr = Tcl_NewBooleanObj(attr);
  1567.     return TCL_OK;
  1568. }
  1570. /*
  1571.  *----------------------------------------------------------------------
  1572.  *
  1573.  * ConvertFileNameFormat --
  1574.  *
  1575.  *      Returns a Tcl_Obj containing either the long or short version of the 
  1576.  * file name.
  1577.  *
  1578.  * Results:
  1579.  *      Standard Tcl result and a Tcl_Obj in attributePtrPtr. The object
  1580.  * will have ref count 0. If the return value is not TCL_OK,
  1581.  * attributePtrPtr is not touched.
  1582.  *
  1583.  * Warning: if you pass this function a drive name like 'c:' it
  1584.  * will actually return the current working directory on that
  1585.  * drive.  To avoid this, make sure the drive name ends in a
  1586.  * slash, like this 'c:/'.
  1587.  *
  1588.  * Side effects:
  1589.  *      A new object is allocated if the file is valid.
  1590.  *
  1591.  *----------------------------------------------------------------------
  1592.  */
  1594. static int
  1595. ConvertFileNameFormat(
  1596.     Tcl_Interp *interp, /* The interp we are using for errors. */
  1597.     int objIndex, /* The index of the attribute. */
  1598.     Tcl_Obj *fileName,    /* The name of the file. */
  1599.     int longShort, /* 0 to short name, 1 to long name. */
  1600.     Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */
  1601. {
  1602.     int pathc, i;
  1603.     Tcl_Obj *splitPath;
  1604.     int result = TCL_OK;
  1606.     splitPath = Tcl_FSSplitPath(fileName, &pathc);
  1608.     if (splitPath == NULL || pathc == 0) {
  1609. if (interp != NULL) {
  1610.     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), 
  1611. "could not read "", Tcl_GetString(fileName),
  1612. "": no such file or directory", 
  1613. (char *) NULL);
  1614. }
  1615. result = TCL_ERROR;
  1616. goto cleanup;
  1617.     }
  1618.     
  1619.     for (i = 0; i < pathc; i++) {
  1620. Tcl_Obj *elt;
  1621. char *pathv;
  1622. int pathLen;
  1623. Tcl_ListObjIndex(NULL, splitPath, i, &elt);
  1625. pathv = Tcl_GetStringFromObj(elt, &pathLen);
  1626. if ((pathv[0] == '/')
  1627. || ((pathLen == 3) && (pathv[1] == ':'))
  1628. || (strcmp(pathv, ".") == 0)
  1629. || (strcmp(pathv, "..") == 0)) {
  1630.     /*
  1631.      * Handle "/", "//machine/export", "c:/", "." or ".." by just
  1632.      * copying the string literally.  Uppercase the drive letter,
  1633.      * just because it looks better under Windows to do so.
  1634.      */
  1636.     simple:
  1637.     /* Here we are modifying the string representation in place */
  1638.     /* I believe this is legal, since this won't affect any 
  1639.      * file representation this thing may have. */
  1640.     pathv[0] = (char) Tcl_UniCharToUpper(UCHAR(pathv[0]));
  1641. } else {
  1642.     Tcl_Obj *tempPath;
  1643.     Tcl_DString ds;
  1644.     Tcl_DString dsTemp;
  1645.     TCHAR *nativeName;
  1646.     char *tempString;
  1647.     int tempLen;
  1648.     WIN32_FIND_DATAT data;
  1649.     HANDLE handle;
  1650.     DWORD attr;
  1652.     tempPath = Tcl_FSJoinPath(splitPath, i+1);
  1653.     Tcl_IncrRefCount(tempPath);
  1654.     /* 
  1655.      * We'd like to call Tcl_FSGetNativePath(tempPath)
  1656.      * but that is likely to lead to infinite loops 
  1657.      */
  1658.     Tcl_DStringInit(&ds);
  1659.     tempString = Tcl_GetStringFromObj(tempPath,&tempLen);
  1660.     nativeName = Tcl_WinUtfToTChar(tempString, tempLen, &ds);
  1661.     Tcl_DecrRefCount(tempPath);
  1662.     handle = (*tclWinProcs->findFirstFileProc)(nativeName, &data);
  1663.     if (handle == INVALID_HANDLE_VALUE) {
  1664. /*
  1665.  * FindFirstFile() doesn't like root directories.  We 
  1666.  * would only get a root directory here if the caller
  1667.  * specified "c:" or "c:." and the current directory on the
  1668.  * drive was the root directory
  1669.  */
  1671. attr = (*tclWinProcs->getFileAttributesProc)(nativeName);
  1672. if ((attr != 0xFFFFFFFF) && (attr & FILE_ATTRIBUTE_DIRECTORY)) {
  1673.     Tcl_DStringFree(&ds);
  1674.     goto simple;
  1675. }
  1676.     }
  1678.     if (handle == INVALID_HANDLE_VALUE) {
  1679. Tcl_DStringFree(&ds);
  1680. if (interp != NULL) {
  1681.     StatError(interp, fileName);
  1682. }
  1683. result = TCL_ERROR;
  1684. goto cleanup;
  1685.     }
  1686.     if (tclWinProcs->useWide) {
  1687. nativeName = (TCHAR *) data.w.cAlternateFileName;
  1688. if (longShort) {
  1689.     if (data.w.cFileName[0] != '') {
  1690. nativeName = (TCHAR *) data.w.cFileName;
  1691.     } 
  1692. } else {
  1693.     if (data.w.cAlternateFileName[0] == '') {
  1694. nativeName = (TCHAR *) data.w.cFileName;
  1695.     }
  1696. }
  1697.     } else {
  1698. nativeName = (TCHAR *) data.a.cAlternateFileName;
  1699. if (longShort) {
  1700.     if (data.a.cFileName[0] != '') {
  1701. nativeName = (TCHAR *) data.a.cFileName;
  1702.     } 
  1703. } else {
  1704.     if (data.a.cAlternateFileName[0] == '') {
  1705. nativeName = (TCHAR *) data.a.cFileName;
  1706.     }
  1707. }
  1708.     }
  1710.     /*
  1711.      * Purify reports a extraneous UMR in Tcl_WinTCharToUtf() trying 
  1712.      * to dereference nativeName as a Unicode string.  I have proven 
  1713.      * to myself that purify is wrong by running the following 
  1714.      * example when nativeName == data.w.cAlternateFileName and 
  1715.      * noting that purify doesn't complain about the first line,
  1716.      * but does complain about the second.
  1717.      *
  1718.      * fprintf(stderr, "%dn", data.w.cAlternateFileName[0]);
  1719.      * fprintf(stderr, "%dn", ((WCHAR *) nativeName)[0]);
  1720.      */
  1722.     Tcl_DStringInit(&dsTemp);
  1723.     Tcl_WinTCharToUtf(nativeName, -1, &dsTemp);
  1724.     /* Deal with issues of tildes being absolute */
  1725.     if (Tcl_DStringValue(&dsTemp)[0] == '~') {
  1726. tempPath = Tcl_NewStringObj("./",2);
  1727. Tcl_AppendToObj(tempPath, Tcl_DStringValue(&dsTemp), 
  1728. Tcl_DStringLength(&dsTemp));
  1729.     } else {
  1730. tempPath = Tcl_NewStringObj(Tcl_DStringValue(&dsTemp), 
  1731.     Tcl_DStringLength(&dsTemp));
  1732.     }
  1733.     Tcl_ListObjReplace(NULL, splitPath, i, 1, 1, &tempPath);
  1734.     Tcl_DStringFree(&ds);
  1735.     Tcl_DStringFree(&dsTemp);
  1736.     FindClose(handle);
  1737. }
  1738.     }
  1740.     *attributePtrPtr = Tcl_FSJoinPath(splitPath, -1);
  1742. cleanup:
  1743.     if (splitPath != NULL) {
  1744. Tcl_DecrRefCount(splitPath);
  1745.     }
  1746.   
  1747.     return result;
  1748. }
  1750. /*
  1751.  *----------------------------------------------------------------------
  1752.  *
  1753.  * GetWinFileLongName --
  1754.  *
  1755.  *      Returns a Tcl_Obj containing the long version of the file
  1756.  * name.
  1757.  *
  1758.  * Results:
  1759.  *      Standard Tcl result and a Tcl_Obj in attributePtrPtr. The object
  1760.  * will have ref count 0. If the return value is not TCL_OK,
  1761.  * attributePtrPtr is not touched.
  1762.  *
  1763.  * Side effects:
  1764.  *      A new object is allocated if the file is valid.
  1765.  *
  1766.  *----------------------------------------------------------------------
  1767.  */
  1769. static int
  1770. GetWinFileLongName(
  1771.     Tcl_Interp *interp, /* The interp we are using for errors. */
  1772.     int objIndex, /* The index of the attribute. */
  1773.     Tcl_Obj *fileName,   /* The name of the file. */
  1774.     Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */
  1775. {
  1776.     return ConvertFileNameFormat(interp, objIndex, fileName, 1, attributePtrPtr);
  1777. }
  1779. /*
  1780.  *----------------------------------------------------------------------
  1781.  *
  1782.  * GetWinFileShortName --
  1783.  *
  1784.  *      Returns a Tcl_Obj containing the short version of the file
  1785.  * name.
  1786.  *
  1787.  * Results:
  1788.  *      Standard Tcl result and a Tcl_Obj in attributePtrPtr. The object
  1789.  * will have ref count 0. If the return value is not TCL_OK,
  1790.  * attributePtrPtr is not touched.
  1791.  *
  1792.  * Side effects:
  1793.  *      A new object is allocated if the file is valid.
  1794.  *
  1795.  *----------------------------------------------------------------------
  1796.  */
  1798. static int
  1799. GetWinFileShortName(
  1800.     Tcl_Interp *interp, /* The interp we are using for errors. */
  1801.     int objIndex, /* The index of the attribute. */
  1802.     Tcl_Obj *fileName,   /* The name of the file. */
  1803.     Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */
  1804. {
  1805.     return ConvertFileNameFormat(interp, objIndex, fileName, 0, attributePtrPtr);
  1806. }
  1808. /*
  1809.  *----------------------------------------------------------------------
  1810.  *
  1811.  * SetWinFileAttributes --
  1812.  *
  1813.  * Set the file attributes to the value given by attributePtr.
  1814.  * This routine sets the -hidden, -readonly, or -system attributes.
  1815.  *
  1816.  * Results:
  1817.  *      Standard TCL error.
  1818.  *
  1819.  * Side effects:
  1820.  *      The file's attribute is set.
  1821.  *
  1822.  *----------------------------------------------------------------------
  1823.  */
  1825. static int
  1826. SetWinFileAttributes(
  1827.     Tcl_Interp *interp, /* The interp we are using for errors. */
  1828.     int objIndex, /* The index of the attribute. */
  1829.     Tcl_Obj *fileName,   /* The name of the file. */
  1830.     Tcl_Obj *attributePtr) /* The new value of the attribute. */
  1831. {
  1832.     DWORD fileAttributes;
  1833.     int yesNo;
  1834.     int result;
  1835.     CONST TCHAR *nativeName;
  1837.     nativeName = Tcl_FSGetNativePath(fileName);
  1838.     fileAttributes = (*tclWinProcs->getFileAttributesProc)(nativeName);
  1840.     if (fileAttributes == 0xffffffff) {
  1841. StatError(interp, fileName);
  1842. return TCL_ERROR;
  1843.     }
  1845.     result = Tcl_GetBooleanFromObj(interp, attributePtr, &yesNo);
  1846.     if (result != TCL_OK) {
  1847. return result;
  1848.     }
  1850.     if (yesNo) {
  1851. fileAttributes |= (attributeArray[objIndex]);
  1852.     } else {
  1853. fileAttributes &= ~(attributeArray[objIndex]);
  1854.     }
  1856.     if (!(*tclWinProcs->setFileAttributesProc)(nativeName, fileAttributes)) {
  1857. StatError(interp, fileName);
  1858. return TCL_ERROR;
  1859.     }
  1861.     return result;
  1862. }
  1864. /*
  1865.  *----------------------------------------------------------------------
  1866.  *
  1867.  * SetWinFileLongName --
  1868.  *
  1869.  * The attribute in question is a readonly attribute and cannot
  1870.  * be set.
  1871.  *
  1872.  * Results:
  1873.  *      TCL_ERROR
  1874.  *
  1875.  * Side effects:
  1876.  *      The object result is set to a pertinent error message.
  1877.  *
  1878.  *----------------------------------------------------------------------
  1879.  */
  1881. static int
  1882. CannotSetAttribute(
  1883.     Tcl_Interp *interp, /* The interp we are using for errors. */
  1884.     int objIndex, /* The index of the attribute. */
  1885.     Tcl_Obj *fileName,         /* The name of the file. */
  1886.     Tcl_Obj *attributePtr) /* The new value of the attribute. */
  1887. {
  1888.     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), 
  1889.     "cannot set attribute "", tclpFileAttrStrings[objIndex],
  1890.     "" for file "", Tcl_GetString(fileName), 
  1891.     "": attribute is readonly", 
  1892.     (char *) NULL);
  1893.     return TCL_ERROR;
  1894. }
  1897. /*
  1898.  *---------------------------------------------------------------------------
  1899.  *
  1900.  * TclpObjListVolumes --
  1901.  *
  1902.  * Lists the currently mounted volumes
  1903.  *
  1904.  * Results:
  1905.  * The list of volumes.
  1906.  *
  1907.  * Side effects:
  1908.  * None
  1909.  *
  1910.  *---------------------------------------------------------------------------
  1911.  */
  1913. Tcl_Obj*
  1914. TclpObjListVolumes(void)
  1915. {
  1916.     Tcl_Obj *resultPtr, *elemPtr;
  1917.     char buf[40 * 4]; /* There couldn't be more than 30 drives??? */
  1918.     int i;
  1919.     char *p;
  1921.     resultPtr = Tcl_NewObj();
  1923.     /*
  1924.      * On Win32s:
  1925.      * GetLogicalDriveStrings() isn't implemented.
  1926.      * GetLogicalDrives() returns incorrect information.
  1927.      */
  1929.     if (GetLogicalDriveStringsA(sizeof(buf), buf) == 0) {
  1930. /*
  1931.  * GetVolumeInformation() will detects all drives, but causes
  1932.  * chattering on empty floppy drives.  We only do this if 
  1933.  * GetLogicalDriveStrings() didn't work.  It has also been reported
  1934.  * that on some laptops it takes a while for GetVolumeInformation()
  1935.  * to return when pinging an empty floppy drive, another reason to 
  1936.  * try to avoid calling it.
  1937.  */
  1939. buf[1] = ':';
  1940. buf[2] = '/';
  1941. buf[3] = '';
  1943. for (i = 0; i < 26; i++) {
  1944.     buf[0] = (char) ('a' + i);
  1945.     if (GetVolumeInformationA(buf, NULL, 0, NULL, NULL, NULL, NULL, 0)  
  1946.     || (GetLastError() == ERROR_NOT_READY)) {
  1947. elemPtr = Tcl_NewStringObj(buf, -1);
  1948. Tcl_ListObjAppendElement(NULL, resultPtr, elemPtr);
  1949.     }
  1950. }
  1951.     } else {
  1952. for (p = buf; *p != ''; p += 4) {
  1953.     p[2] = '/';
  1954.     elemPtr = Tcl_NewStringObj(p, -1);
  1955.     Tcl_ListObjAppendElement(NULL, resultPtr, elemPtr);
  1956. }
  1957.     }
  1958.     
  1959.     Tcl_IncrRefCount(resultPtr);
  1960.     return resultPtr;
  1961. }