/[dtapublic]/projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclwinfcmd.c
ViewVC logotype

Annotation of /projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclwinfcmd.c

Parent Directory Parent Directory | Revision Log Revision Log


Revision 71 - (hide annotations) (download)
Sat Nov 5 11:07:06 2016 UTC (8 years ago) by dashley
File MIME type: text/plain
File size: 47912 byte(s)
Set EOL properties appropriately to facilitate simultaneous Linux and Windows development.
1 dashley 71 /* $Header$ */
2     /*
3     * tclWinFCmd.c
4     *
5     * This file implements the Windows specific portion of file manipulation
6     * subcommands of the "file" command.
7     *
8     * Copyright (c) 1996-1998 Sun Microsystems, Inc.
9     *
10     * See the file "license.terms" for information on usage and redistribution
11     * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
12     *
13     * RCS: @(#) $Id: tclwinfcmd.c,v 1.1.1.1 2001/06/13 04:49:02 dtashley Exp $
14     */
15    
16     #include "tclWinInt.h"
17    
18     /*
19     * The following constants specify the type of callback when
20     * TraverseWinTree() calls the traverseProc()
21     */
22    
23     #define DOTREE_PRED 1 /* pre-order directory */
24     #define DOTREE_POSTD 2 /* post-order directory */
25     #define DOTREE_F 3 /* regular file */
26    
27     /*
28     * Callbacks for file attributes code.
29     */
30    
31     static int GetWinFileAttributes _ANSI_ARGS_((Tcl_Interp *interp,
32     int objIndex, CONST char *fileName,
33     Tcl_Obj **attributePtrPtr));
34     static int GetWinFileLongName _ANSI_ARGS_((Tcl_Interp *interp,
35     int objIndex, CONST char *fileName,
36     Tcl_Obj **attributePtrPtr));
37     static int GetWinFileShortName _ANSI_ARGS_((Tcl_Interp *interp,
38     int objIndex, CONST char *fileName,
39     Tcl_Obj **attributePtrPtr));
40     static int SetWinFileAttributes _ANSI_ARGS_((Tcl_Interp *interp,
41     int objIndex, CONST char *fileName,
42     Tcl_Obj *attributePtr));
43     static int CannotSetAttribute _ANSI_ARGS_((Tcl_Interp *interp,
44     int objIndex, CONST char *fileName,
45     Tcl_Obj *attributePtr));
46    
47     /*
48     * Constants and variables necessary for file attributes subcommand.
49     */
50    
51     enum {
52     WIN_ARCHIVE_ATTRIBUTE,
53     WIN_HIDDEN_ATTRIBUTE,
54     WIN_LONGNAME_ATTRIBUTE,
55     WIN_READONLY_ATTRIBUTE,
56     WIN_SHORTNAME_ATTRIBUTE,
57     WIN_SYSTEM_ATTRIBUTE
58     };
59    
60     static int attributeArray[] = {FILE_ATTRIBUTE_ARCHIVE, FILE_ATTRIBUTE_HIDDEN,
61     0, FILE_ATTRIBUTE_READONLY, 0, FILE_ATTRIBUTE_SYSTEM};
62    
63    
64     char *tclpFileAttrStrings[] = {
65     "-archive", "-hidden", "-longname", "-readonly",
66     "-shortname", "-system", (char *) NULL
67     };
68    
69     const TclFileAttrProcs tclpFileAttrProcs[] = {
70     {GetWinFileAttributes, SetWinFileAttributes},
71     {GetWinFileAttributes, SetWinFileAttributes},
72     {GetWinFileLongName, CannotSetAttribute},
73     {GetWinFileAttributes, SetWinFileAttributes},
74     {GetWinFileShortName, CannotSetAttribute},
75     {GetWinFileAttributes, SetWinFileAttributes}};
76    
77     /*
78     * Prototype for the TraverseWinTree callback function.
79     */
80    
81     typedef int (TraversalProc)(Tcl_DString *srcPtr, Tcl_DString *dstPtr,
82     int type, Tcl_DString *errorPtr);
83    
84     /*
85     * Declarations for local procedures defined in this file:
86     */
87    
88     static void StatError(Tcl_Interp *interp, CONST char *fileName);
89     static int ConvertFileNameFormat(Tcl_Interp *interp,
90     int objIndex, CONST char *fileName, int longShort,
91     Tcl_Obj **attributePtrPtr);
92     static int DoCopyFile(Tcl_DString *srcPtr, Tcl_DString *dstPtr);
93     static int DoCreateDirectory(Tcl_DString *pathPtr);
94     static int DoDeleteFile(Tcl_DString *pathPtr);
95     static int DoRemoveDirectory(Tcl_DString *pathPtr, int recursive,
96     Tcl_DString *errorPtr);
97     static int DoRenameFile(const TCHAR *nativeSrc, Tcl_DString *dstPtr);
98     static int TraversalCopy(Tcl_DString *srcPtr, Tcl_DString *dstPtr,
99     int type, Tcl_DString *errorPtr);
100     static int TraversalDelete(Tcl_DString *srcPtr, Tcl_DString *dstPtr,
101     int type, Tcl_DString *errorPtr);
102     static int TraverseWinTree(TraversalProc *traverseProc,
103     Tcl_DString *sourcePtr, Tcl_DString *dstPtr,
104     Tcl_DString *errorPtr);
105    
106    
107     /*
108     *---------------------------------------------------------------------------
109     *
110     * TclpRenameFile, DoRenameFile --
111     *
112     * Changes the name of an existing file or directory, from src to dst.
113     * If src and dst refer to the same file or directory, does nothing
114     * and returns success. Otherwise if dst already exists, it will be
115     * deleted and replaced by src subject to the following conditions:
116     * If src is a directory, dst may be an empty directory.
117     * If src is a file, dst may be a file.
118     * In any other situation where dst already exists, the rename will
119     * fail.
120     *
121     * Results:
122     * If the file or directory was successfully renamed, returns TCL_OK.
123     * Otherwise the return value is TCL_ERROR and errno is set to
124     * indicate the error. Some possible values for errno are:
125     *
126     * ENAMETOOLONG: src or dst names are too long.
127     * EACCES: src or dst parent directory can't be read and/or written.
128     * EEXIST: dst is a non-empty directory.
129     * EINVAL: src is a root directory or dst is a subdirectory of src.
130     * EISDIR: dst is a directory, but src is not.
131     * ENOENT: src doesn't exist. src or dst is "".
132     * ENOTDIR: src is a directory, but dst is not.
133     * EXDEV: src and dst are on different filesystems.
134     *
135     * EACCES: exists an open file already referring to src or dst.
136     * EACCES: src or dst specify the current working directory (NT).
137     * EACCES: src specifies a char device (nul:, com1:, etc.)
138     * EEXIST: dst specifies a char device (nul:, com1:, etc.) (NT)
139     * EACCES: dst specifies a char device (nul:, com1:, etc.) (95)
140     *
141     * Side effects:
142     * The implementation supports cross-filesystem renames of files,
143     * but the caller should be prepared to emulate cross-filesystem
144     * renames of directories if errno is EXDEV.
145     *
146     *---------------------------------------------------------------------------
147     */
148    
149     int
150     TclpRenameFile(
151     CONST char *src, /* Pathname of file or dir to be renamed
152     * (UTF-8). */
153     CONST char *dst) /* New pathname of file or directory
154     * (UTF-8). */
155     {
156     int result;
157     TCHAR *nativeSrc;
158     Tcl_DString srcString, dstString;
159    
160     nativeSrc = Tcl_WinUtfToTChar(src, -1, &srcString);
161     Tcl_WinUtfToTChar(dst, -1, &dstString);
162    
163     result = DoRenameFile(nativeSrc, &dstString);
164     Tcl_DStringFree(&srcString);
165     Tcl_DStringFree(&dstString);
166     return result;
167     }
168    
169     static int
170     DoRenameFile(
171     CONST TCHAR *nativeSrc, /* Pathname of file or dir to be renamed
172     * (native). */
173     Tcl_DString *dstPtr) /* New pathname for file or directory
174     * (native). */
175     {
176     const TCHAR *nativeDst;
177     DWORD srcAttr, dstAttr;
178    
179     nativeDst = (TCHAR *) Tcl_DStringValue(dstPtr);
180    
181     /*
182     * Would throw an exception under NT if one of the arguments is a
183     * char block device.
184     */
185    
186     __try {
187     if ((*tclWinProcs->moveFileProc)(nativeSrc, nativeDst) != FALSE) {
188     return TCL_OK;
189     }
190     } __except (-1) {}
191    
192     TclWinConvertError(GetLastError());
193    
194     srcAttr = (*tclWinProcs->getFileAttributesProc)(nativeSrc);
195     dstAttr = (*tclWinProcs->getFileAttributesProc)(nativeDst);
196     if (srcAttr == 0xffffffff) {
197     if ((*tclWinProcs->getFullPathNameProc)(nativeSrc, 0, NULL, NULL) >= MAX_PATH) {
198     errno = ENAMETOOLONG;
199     return TCL_ERROR;
200     }
201     srcAttr = 0;
202     }
203     if (dstAttr == 0xffffffff) {
204     if ((*tclWinProcs->getFullPathNameProc)(nativeDst, 0, NULL, NULL) >= MAX_PATH) {
205     errno = ENAMETOOLONG;
206     return TCL_ERROR;
207     }
208     dstAttr = 0;
209     }
210    
211     if (errno == EBADF) {
212     errno = EACCES;
213     return TCL_ERROR;
214     }
215     if (errno == EACCES) {
216     decode:
217     if (srcAttr & FILE_ATTRIBUTE_DIRECTORY) {
218     TCHAR *nativeSrcRest, *nativeDstRest;
219     char **srcArgv, **dstArgv;
220     int size, srcArgc, dstArgc;
221     WCHAR nativeSrcPath[MAX_PATH];
222     WCHAR nativeDstPath[MAX_PATH];
223     Tcl_DString srcString, dstString;
224     CONST char *src, *dst;
225    
226     size = (*tclWinProcs->getFullPathNameProc)(nativeSrc, MAX_PATH,
227     nativeSrcPath, &nativeSrcRest);
228     if ((size == 0) || (size > MAX_PATH)) {
229     return TCL_ERROR;
230     }
231     size = (*tclWinProcs->getFullPathNameProc)(nativeDst, MAX_PATH,
232     nativeDstPath, &nativeDstRest);
233     if ((size == 0) || (size > MAX_PATH)) {
234     return TCL_ERROR;
235     }
236     (*tclWinProcs->charLowerProc)((TCHAR *) nativeSrcPath);
237     (*tclWinProcs->charLowerProc)((TCHAR *) nativeDstPath);
238    
239     src = Tcl_WinTCharToUtf((TCHAR *) nativeSrcPath, -1, &srcString);
240     dst = Tcl_WinTCharToUtf((TCHAR *) nativeDstPath, -1, &dstString);
241     if (strncmp(src, dst, Tcl_DStringLength(&srcString)) == 0) {
242     /*
243     * Trying to move a directory into itself.
244     */
245    
246     errno = EINVAL;
247     Tcl_DStringFree(&srcString);
248     Tcl_DStringFree(&dstString);
249     return TCL_ERROR;
250     }
251     Tcl_SplitPath(src, &srcArgc, &srcArgv);
252     Tcl_SplitPath(dst, &dstArgc, &dstArgv);
253     Tcl_DStringFree(&srcString);
254     Tcl_DStringFree(&dstString);
255    
256     if (srcArgc == 1) {
257     /*
258     * They are trying to move a root directory. Whether
259     * or not it is across filesystems, this cannot be
260     * done.
261     */
262    
263     Tcl_SetErrno(EINVAL);
264     } else if ((srcArgc > 0) && (dstArgc > 0) &&
265     (strcmp(srcArgv[0], dstArgv[0]) != 0)) {
266     /*
267     * If src is a directory and dst filesystem != src
268     * filesystem, errno should be EXDEV. It is very
269     * important to get this behavior, so that the caller
270     * can respond to a cross filesystem rename by
271     * simulating it with copy and delete. The MoveFile
272     * system call already handles the case of moving a
273     * file between filesystems.
274     */
275    
276     Tcl_SetErrno(EXDEV);
277     }
278    
279     ckfree((char *) srcArgv);
280     ckfree((char *) dstArgv);
281     }
282    
283     /*
284     * Other types of access failure is that dst is a read-only
285     * filesystem, that an open file referred to src or dest, or that
286     * src or dest specified the current working directory on the
287     * current filesystem. EACCES is returned for those cases.
288     */
289    
290     } else if (Tcl_GetErrno() == EEXIST) {
291     /*
292     * Reports EEXIST any time the target already exists. If it makes
293     * sense, remove the old file and try renaming again.
294     */
295    
296     if (srcAttr & FILE_ATTRIBUTE_DIRECTORY) {
297     if (dstAttr & FILE_ATTRIBUTE_DIRECTORY) {
298     /*
299     * Overwrite empty dst directory with src directory. The
300     * following call will remove an empty directory. If it
301     * fails, it's because it wasn't empty.
302     */
303    
304     if (DoRemoveDirectory(dstPtr, 0, NULL) == TCL_OK) {
305     /*
306     * Now that that empty directory is gone, we can try
307     * renaming again. If that fails, we'll put this empty
308     * directory back, for completeness.
309     */
310    
311     if ((*tclWinProcs->moveFileProc)(nativeSrc, nativeDst) != FALSE) {
312     return TCL_OK;
313     }
314    
315     /*
316     * Some new error has occurred. Don't know what it
317     * could be, but report this one.
318     */
319    
320     TclWinConvertError(GetLastError());
321     (*tclWinProcs->createDirectoryProc)(nativeDst, NULL);
322     (*tclWinProcs->setFileAttributesProc)(nativeDst, dstAttr);
323     if (Tcl_GetErrno() == EACCES) {
324     /*
325     * Decode the EACCES to a more meaningful error.
326     */
327    
328     goto decode;
329     }
330     }
331     } else { /* (dstAttr & FILE_ATTRIBUTE_DIRECTORY) == 0 */
332     Tcl_SetErrno(ENOTDIR);
333     }
334     } else { /* (srcAttr & FILE_ATTRIBUTE_DIRECTORY) == 0 */
335     if (dstAttr & FILE_ATTRIBUTE_DIRECTORY) {
336     Tcl_SetErrno(EISDIR);
337     } else {
338     /*
339     * Overwrite existing file by:
340     *
341     * 1. Rename existing file to temp name.
342     * 2. Rename old file to new name.
343     * 3. If success, delete temp file. If failure,
344     * put temp file back to old name.
345     */
346    
347     TCHAR *nativeRest, *nativeTmp, *nativePrefix;
348     int result, size;
349     WCHAR tempBuf[MAX_PATH];
350    
351     size = (*tclWinProcs->getFullPathNameProc)(nativeDst, MAX_PATH,
352     tempBuf, &nativeRest);
353     if ((size == 0) || (size > MAX_PATH) || (nativeRest == NULL)) {
354     return TCL_ERROR;
355     }
356     nativeTmp = (TCHAR *) tempBuf;
357     ((char *) nativeRest)[0] = '\0';
358     ((char *) nativeRest)[1] = '\0'; /* In case it's Unicode. */
359    
360     result = TCL_ERROR;
361     nativePrefix = (tclWinProcs->useWide)
362     ? (TCHAR *) L"tclr" : (TCHAR *) "tclr";
363     if ((*tclWinProcs->getTempFileNameProc)(nativeTmp,
364     nativePrefix, 0, tempBuf) != 0) {
365     /*
366     * Strictly speaking, need the following DeleteFile and
367     * MoveFile to be joined as an atomic operation so no
368     * other app comes along in the meantime and creates the
369     * same temp file.
370     */
371    
372     nativeTmp = (TCHAR *) tempBuf;
373     (*tclWinProcs->deleteFileProc)(nativeTmp);
374     if ((*tclWinProcs->moveFileProc)(nativeDst, nativeTmp) != FALSE) {
375     if ((*tclWinProcs->moveFileProc)(nativeSrc, nativeDst) != FALSE) {
376     (*tclWinProcs->setFileAttributesProc)(nativeTmp,
377     FILE_ATTRIBUTE_NORMAL);
378     (*tclWinProcs->deleteFileProc)(nativeTmp);
379     return TCL_OK;
380     } else {
381     (*tclWinProcs->deleteFileProc)(nativeDst);
382     (*tclWinProcs->moveFileProc)(nativeTmp, nativeDst);
383     }
384     }
385    
386     /*
387     * Can't backup dst file or move src file. Return that
388     * error. Could happen if an open file refers to dst.
389     */
390    
391     TclWinConvertError(GetLastError());
392     if (Tcl_GetErrno() == EACCES) {
393     /*
394     * Decode the EACCES to a more meaningful error.
395     */
396    
397     goto decode;
398     }
399     }
400     return result;
401     }
402     }
403     }
404     return TCL_ERROR;
405     }
406    
407     /*
408     *---------------------------------------------------------------------------
409     *
410     * TclpCopyFile, DoCopyFile --
411     *
412     * Copy a single file (not a directory). If dst already exists and
413     * is not a directory, it is removed.
414     *
415     * Results:
416     * If the file was successfully copied, returns TCL_OK. Otherwise
417     * the return value is TCL_ERROR and errno is set to indicate the
418     * error. Some possible values for errno are:
419     *
420     * EACCES: src or dst parent directory can't be read and/or written.
421     * EISDIR: src or dst is a directory.
422     * ENOENT: src doesn't exist. src or dst is "".
423     *
424     * EACCES: exists an open file already referring to dst (95).
425     * EACCES: src specifies a char device (nul:, com1:, etc.) (NT)
426     * ENOENT: src specifies a char device (nul:, com1:, etc.) (95)
427     *
428     * Side effects:
429     * It is not an error to copy to a char device.
430     *
431     *---------------------------------------------------------------------------
432     */
433    
434     int
435     TclpCopyFile(
436     CONST char *src, /* Pathname of file to be copied (UTF-8). */
437     CONST char *dst) /* Pathname of file to copy to (UTF-8). */
438     {
439     int result;
440     Tcl_DString srcString, dstString;
441    
442     Tcl_WinUtfToTChar(src, -1, &srcString);
443     Tcl_WinUtfToTChar(dst, -1, &dstString);
444     result = DoCopyFile(&srcString, &dstString);
445     Tcl_DStringFree(&srcString);
446     Tcl_DStringFree(&dstString);
447     return result;
448     }
449    
450     static int
451     DoCopyFile(
452     Tcl_DString *srcPtr, /* Pathname of file to be copied (native). */
453     Tcl_DString *dstPtr) /* Pathname of file to copy to (native). */
454     {
455     CONST TCHAR *nativeSrc, *nativeDst;
456    
457     nativeSrc = (TCHAR *) Tcl_DStringValue(srcPtr);
458     nativeDst = (TCHAR *) Tcl_DStringValue(dstPtr);
459    
460     /*
461     * Would throw an exception under NT if one of the arguments is a char
462     * block device.
463     */
464    
465     __try {
466     if ((*tclWinProcs->copyFileProc)(nativeSrc, nativeDst, 0) != FALSE) {
467     return TCL_OK;
468     }
469     } __except (-1) {}
470    
471     TclWinConvertError(GetLastError());
472     if (Tcl_GetErrno() == EBADF) {
473     Tcl_SetErrno(EACCES);
474     return TCL_ERROR;
475     }
476     if (Tcl_GetErrno() == EACCES) {
477     DWORD srcAttr, dstAttr;
478    
479     srcAttr = (*tclWinProcs->getFileAttributesProc)(nativeSrc);
480     dstAttr = (*tclWinProcs->getFileAttributesProc)(nativeDst);
481     if (srcAttr != 0xffffffff) {
482     if (dstAttr == 0xffffffff) {
483     dstAttr = 0;
484     }
485     if ((srcAttr & FILE_ATTRIBUTE_DIRECTORY) ||
486     (dstAttr & FILE_ATTRIBUTE_DIRECTORY)) {
487     Tcl_SetErrno(EISDIR);
488     }
489     if (dstAttr & FILE_ATTRIBUTE_READONLY) {
490     (*tclWinProcs->setFileAttributesProc)(nativeDst,
491     dstAttr & ~FILE_ATTRIBUTE_READONLY);
492     if ((*tclWinProcs->copyFileProc)(nativeSrc, nativeDst, 0) != FALSE) {
493     return TCL_OK;
494     }
495     /*
496     * Still can't copy onto dst. Return that error, and
497     * restore attributes of dst.
498     */
499    
500     TclWinConvertError(GetLastError());
501     (*tclWinProcs->setFileAttributesProc)(nativeDst, dstAttr);
502     }
503     }
504     }
505     return TCL_ERROR;
506     }
507    
508     /*
509     *---------------------------------------------------------------------------
510     *
511     * TclpDeleteFile, DoDeleteFile --
512     *
513     * Removes a single file (not a directory).
514     *
515     * Results:
516     * If the file was successfully deleted, returns TCL_OK. Otherwise
517     * the return value is TCL_ERROR and errno is set to indicate the
518     * error. Some possible values for errno are:
519     *
520     * EACCES: a parent directory can't be read and/or written.
521     * EISDIR: path is a directory.
522     * ENOENT: path doesn't exist or is "".
523     *
524     * EACCES: exists an open file already referring to path.
525     * EACCES: path is a char device (nul:, com1:, etc.)
526     *
527     * Side effects:
528     * The file is deleted, even if it is read-only.
529     *
530     *---------------------------------------------------------------------------
531     */
532    
533     int
534     TclpDeleteFile(
535     CONST char *path) /* Pathname of file to be removed (UTF-8). */
536     {
537     int result;
538     Tcl_DString pathString;
539    
540     Tcl_WinUtfToTChar(path, -1, &pathString);
541     result = DoDeleteFile(&pathString);
542     Tcl_DStringFree(&pathString);
543     return result;
544     }
545    
546     static int
547     DoDeleteFile(
548     Tcl_DString *pathPtr) /* Pathname of file to be removed (native). */
549     {
550     DWORD attr;
551     CONST TCHAR *nativePath;
552    
553     nativePath = (TCHAR *) Tcl_DStringValue(pathPtr);
554    
555     if ((*tclWinProcs->deleteFileProc)(nativePath) != FALSE) {
556     return TCL_OK;
557     }
558     TclWinConvertError(GetLastError());
559    
560     /*
561     * Win32s thinks that "" is the same as "." and then reports EISDIR
562     * instead of ENOENT.
563     */
564    
565     if (tclWinProcs->useWide) {
566     if (((WCHAR *) nativePath)[0] == '\0') {
567     Tcl_SetErrno(ENOENT);
568     return TCL_ERROR;
569     }
570     } else {
571     if (((char *) nativePath)[0] == '\0') {
572     Tcl_SetErrno(ENOENT);
573     return TCL_ERROR;
574     }
575     }
576     if (Tcl_GetErrno() == EACCES) {
577     attr = (*tclWinProcs->getFileAttributesProc)(nativePath);
578     if (attr != 0xffffffff) {
579     if (attr & FILE_ATTRIBUTE_DIRECTORY) {
580     /*
581     * Windows NT reports removing a directory as EACCES instead
582     * of EISDIR.
583     */
584    
585     Tcl_SetErrno(EISDIR);
586     } else if (attr & FILE_ATTRIBUTE_READONLY) {
587     (*tclWinProcs->setFileAttributesProc)(nativePath,
588     attr & ~FILE_ATTRIBUTE_READONLY);
589     if ((*tclWinProcs->deleteFileProc)(nativePath) != FALSE) {
590     return TCL_OK;
591     }
592     TclWinConvertError(GetLastError());
593     (*tclWinProcs->setFileAttributesProc)(nativePath, attr);
594     }
595     }
596     } else if (Tcl_GetErrno() == ENOENT) {
597     attr = (*tclWinProcs->getFileAttributesProc)(nativePath);
598     if (attr != 0xffffffff) {
599     if (attr & FILE_ATTRIBUTE_DIRECTORY) {
600     /*
601     * Windows 95 reports removing a directory as ENOENT instead
602     * of EISDIR.
603     */
604    
605     Tcl_SetErrno(EISDIR);
606     }
607     }
608     } else if (Tcl_GetErrno() == EINVAL) {
609     /*
610     * Windows NT reports removing a char device as EINVAL instead of
611     * EACCES.
612     */
613    
614     Tcl_SetErrno(EACCES);
615     }
616    
617     return TCL_ERROR;
618     }
619    
620     /*
621     *---------------------------------------------------------------------------
622     *
623     * TclpCreateDirectory --
624     *
625     * Creates the specified directory. All parent directories of the
626     * specified directory must already exist. The directory is
627     * automatically created with permissions so that user can access
628     * the new directory and create new files or subdirectories in it.
629     *
630     * Results:
631     * If the directory was successfully created, returns TCL_OK.
632     * Otherwise the return value is TCL_ERROR and errno is set to
633     * indicate the error. Some possible values for errno are:
634     *
635     * EACCES: a parent directory can't be read and/or written.
636     * EEXIST: path already exists.
637     * ENOENT: a parent directory doesn't exist.
638     *
639     * Side effects:
640     * A directory is created.
641     *
642     *---------------------------------------------------------------------------
643     */
644    
645     int
646     TclpCreateDirectory(
647     CONST char *path) /* Pathname of directory to create (UTF-8). */
648     {
649     int result;
650     Tcl_DString pathString;
651    
652     Tcl_WinUtfToTChar(path, -1, &pathString);
653     result = DoCreateDirectory(&pathString);
654     Tcl_DStringFree(&pathString);
655     return result;
656     }
657    
658     static int
659     DoCreateDirectory(
660     Tcl_DString *pathPtr) /* Pathname of directory to create (native). */
661     {
662     int error;
663     CONST TCHAR *nativePath;
664    
665     nativePath = (TCHAR *) Tcl_DStringValue(pathPtr);
666     if ((*tclWinProcs->createDirectoryProc)(nativePath, NULL) == 0) {
667     error = GetLastError();
668     TclWinConvertError(error);
669     return TCL_ERROR;
670     }
671     return TCL_OK;
672     }
673    
674     /*
675     *---------------------------------------------------------------------------
676     *
677     * TclpCopyDirectory --
678     *
679     * Recursively copies a directory. The target directory dst must
680     * not already exist. Note that this function does not merge two
681     * directory hierarchies, even if the target directory is an an
682     * empty directory.
683     *
684     * Results:
685     * If the directory was successfully copied, returns TCL_OK.
686     * Otherwise the return value is TCL_ERROR, errno is set to indicate
687     * the error, and the pathname of the file that caused the error
688     * is stored in errorPtr. See TclpCreateDirectory and TclpCopyFile
689     * for a description of possible values for errno.
690     *
691     * Side effects:
692     * An exact copy of the directory hierarchy src will be created
693     * with the name dst. If an error occurs, the error will
694     * be returned immediately, and remaining files will not be
695     * processed.
696     *
697     *---------------------------------------------------------------------------
698     */
699    
700     int
701     TclpCopyDirectory(
702     CONST char *src, /* Pathname of directory to be copied
703     * (UTF-8). */
704     CONST char *dst, /* Pathname of target directory (UTF-8). */
705     Tcl_DString *errorPtr) /* If non-NULL, uninitialized or free
706     * DString filled with UTF-8 name of file
707     * causing error. */
708     {
709     int result;
710     Tcl_DString srcString, dstString;
711    
712     Tcl_WinUtfToTChar(src, -1, &srcString);
713     Tcl_WinUtfToTChar(dst, -1, &dstString);
714    
715     result = TraverseWinTree(TraversalCopy, &srcString, &dstString, errorPtr);
716    
717     Tcl_DStringFree(&srcString);
718     Tcl_DStringFree(&dstString);
719     return result;
720     }
721    
722     /*
723     *----------------------------------------------------------------------
724     *
725     * TclpRemoveDirectory, DoRemoveDirectory --
726     *
727     * Removes directory (and its contents, if the recursive flag is set).
728     *
729     * Results:
730     * If the directory was successfully removed, returns TCL_OK.
731     * Otherwise the return value is TCL_ERROR, errno is set to indicate
732     * the error, and the pathname of the file that caused the error
733     * is stored in errorPtr. Some possible values for errno are:
734     *
735     * EACCES: path directory can't be read and/or written.
736     * EEXIST: path is a non-empty directory.
737     * EINVAL: path is root directory or current directory.
738     * ENOENT: path doesn't exist or is "".
739     * ENOTDIR: path is not a directory.
740     *
741     * EACCES: path is a char device (nul:, com1:, etc.) (95)
742     * EINVAL: path is a char device (nul:, com1:, etc.) (NT)
743     *
744     * Side effects:
745     * Directory removed. If an error occurs, the error will be returned
746     * immediately, and remaining files will not be deleted.
747     *
748     *----------------------------------------------------------------------
749     */
750    
751     int
752     TclpRemoveDirectory(
753     CONST char *path, /* Pathname of directory to be removed
754     * (UTF-8). */
755     int recursive, /* If non-zero, removes directories that
756     * are nonempty. Otherwise, will only remove
757     * empty directories. */
758     Tcl_DString *errorPtr) /* If non-NULL, uninitialized or free
759     * DString filled with UTF-8 name of file
760     * causing error. */
761     {
762     int result;
763     Tcl_DString pathString;
764    
765     Tcl_WinUtfToTChar(path, -1, &pathString);
766     result = DoRemoveDirectory(&pathString, recursive, errorPtr);
767     Tcl_DStringFree(&pathString);
768    
769     return result;
770     }
771    
772     static int
773     DoRemoveDirectory(
774     Tcl_DString *pathPtr, /* Pathname of directory to be removed
775     * (native). */
776     int recursive, /* If non-zero, removes directories that
777     * are nonempty. Otherwise, will only remove
778     * empty directories. */
779     Tcl_DString *errorPtr) /* If non-NULL, uninitialized or free
780     * DString filled with UTF-8 name of file
781     * causing error. */
782     {
783     CONST TCHAR *nativePath;
784     DWORD attr;
785    
786     nativePath = (TCHAR *) Tcl_DStringValue(pathPtr);
787    
788     if ((*tclWinProcs->removeDirectoryProc)(nativePath) != FALSE) {
789     return TCL_OK;
790     }
791     TclWinConvertError(GetLastError());
792    
793     /*
794     * Win32s thinks that "" is the same as "." and then reports EACCES
795     * instead of ENOENT.
796     */
797    
798    
799     if (tclWinProcs->useWide) {
800     if (((WCHAR *) nativePath)[0] == '\0') {
801     Tcl_SetErrno(ENOENT);
802     return TCL_ERROR;
803     }
804     } else {
805     if (((char *) nativePath)[0] == '\0') {
806     Tcl_SetErrno(ENOENT);
807     return TCL_ERROR;
808     }
809     }
810     if (Tcl_GetErrno() == EACCES) {
811     attr = (*tclWinProcs->getFileAttributesProc)(nativePath);
812     if (attr != 0xffffffff) {
813     if ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0) {
814     /*
815     * Windows 95 reports calling RemoveDirectory on a file as an
816     * EACCES, not an ENOTDIR.
817     */
818    
819     Tcl_SetErrno(ENOTDIR);
820     goto end;
821     }
822    
823     if (attr & FILE_ATTRIBUTE_READONLY) {
824     attr &= ~FILE_ATTRIBUTE_READONLY;
825     if ((*tclWinProcs->setFileAttributesProc)(nativePath, attr) == FALSE) {
826     goto end;
827     }
828     if ((*tclWinProcs->removeDirectoryProc)(nativePath) != FALSE) {
829     return TCL_OK;
830     }
831     TclWinConvertError(GetLastError());
832     (*tclWinProcs->setFileAttributesProc)(nativePath,
833     attr | FILE_ATTRIBUTE_READONLY);
834     }
835    
836     /*
837     * Windows 95 and Win32s report removing a non-empty directory
838     * as EACCES, not EEXIST. If the directory is not empty,
839     * change errno so caller knows what's going on.
840     */
841    
842     if (TclWinGetPlatformId() != VER_PLATFORM_WIN32_NT) {
843     char *path, *find;
844     HANDLE handle;
845     WIN32_FIND_DATAA data;
846     Tcl_DString buffer;
847     int len;
848    
849     path = (char *) nativePath;
850    
851     Tcl_DStringInit(&buffer);
852     len = strlen(path);
853     find = Tcl_DStringAppend(&buffer, path, len);
854     if ((len > 0) && (find[len - 1] != '\\')) {
855     Tcl_DStringAppend(&buffer, "\\", 1);
856     }
857     find = Tcl_DStringAppend(&buffer, "*.*", 3);
858     handle = FindFirstFileA(find, &data);
859     if (handle != INVALID_HANDLE_VALUE) {
860     while (1) {
861     if ((strcmp(data.cFileName, ".") != 0)
862     && (strcmp(data.cFileName, "..") != 0)) {
863     /*
864     * Found something in this directory.
865     */
866    
867     Tcl_SetErrno(EEXIST);
868     break;
869     }
870     if (FindNextFileA(handle, &data) == FALSE) {
871     break;
872     }
873     }
874     FindClose(handle);
875     }
876     Tcl_DStringFree(&buffer);
877     }
878     }
879     }
880     if (Tcl_GetErrno() == ENOTEMPTY) {
881     /*
882     * The caller depends on EEXIST to signify that the directory is
883     * not empty, not ENOTEMPTY.
884     */
885    
886     Tcl_SetErrno(EEXIST);
887     }
888     if ((recursive != 0) && (Tcl_GetErrno() == EEXIST)) {
889     /*
890     * The directory is nonempty, but the recursive flag has been
891     * specified, so we recursively remove all the files in the directory.
892     */
893    
894     return TraverseWinTree(TraversalDelete, pathPtr, NULL, errorPtr);
895     }
896    
897     end:
898     if (errorPtr != NULL) {
899     Tcl_WinTCharToUtf(nativePath, -1, errorPtr);
900     }
901     return TCL_ERROR;
902     }
903    
904     /*
905     *---------------------------------------------------------------------------
906     *
907     * TraverseWinTree --
908     *
909     * Traverse directory tree specified by sourcePtr, calling the function
910     * traverseProc for each file and directory encountered. If destPtr
911     * is non-null, each of name in the sourcePtr directory is appended to
912     * the directory specified by destPtr and passed as the second argument
913     * to traverseProc() .
914     *
915     * Results:
916     * Standard Tcl result.
917     *
918     * Side effects:
919     * None caused by TraverseWinTree, however the user specified
920     * traverseProc() may change state. If an error occurs, the error will
921     * be returned immediately, and remaining files will not be processed.
922     *
923     *---------------------------------------------------------------------------
924     */
925    
926     static int
927     TraverseWinTree(
928     TraversalProc *traverseProc,/* Function to call for every file and
929     * directory in source hierarchy. */
930     Tcl_DString *sourcePtr, /* Pathname of source directory to be
931     * traversed (native). */
932     Tcl_DString *targetPtr, /* Pathname of directory to traverse in
933     * parallel with source directory (native). */
934     Tcl_DString *errorPtr) /* If non-NULL, uninitialized or free
935     * DString filled with UTF-8 name of file
936     * causing error. */
937     {
938     DWORD sourceAttr;
939     TCHAR *nativeSource, *nativeErrfile;
940     int result, found, sourceLen, targetLen, oldSourceLen, oldTargetLen;
941     HANDLE handle;
942     WIN32_FIND_DATAT data;
943    
944     nativeErrfile = NULL;
945     result = TCL_OK;
946     oldTargetLen = 0; /* lint. */
947    
948     nativeSource = (TCHAR *) Tcl_DStringValue(sourcePtr);
949     oldSourceLen = Tcl_DStringLength(sourcePtr);
950     sourceAttr = (*tclWinProcs->getFileAttributesProc)(nativeSource);
951     if (sourceAttr == 0xffffffff) {
952     nativeErrfile = nativeSource;
953     goto end;
954     }
955     if ((sourceAttr & FILE_ATTRIBUTE_DIRECTORY) == 0) {
956     /*
957     * Process the regular file
958     */
959    
960     return (*traverseProc)(sourcePtr, targetPtr, DOTREE_F, errorPtr);
961     }
962    
963     if (tclWinProcs->useWide) {
964     Tcl_DStringAppend(sourcePtr, (char *) L"\\*.*", 4 * sizeof(WCHAR) + 1);
965     Tcl_DStringSetLength(sourcePtr, Tcl_DStringLength(sourcePtr) - 1);
966     } else {
967     Tcl_DStringAppend(sourcePtr, "\\*.*", 4);
968     }
969     nativeSource = (TCHAR *) Tcl_DStringValue(sourcePtr);
970     handle = (*tclWinProcs->findFirstFileProc)(nativeSource, &data);
971     if (handle == INVALID_HANDLE_VALUE) {
972     /*
973     * Can't read directory
974     */
975    
976     TclWinConvertError(GetLastError());
977     nativeErrfile = nativeSource;
978     goto end;
979     }
980    
981     nativeSource[oldSourceLen + 1] = '\0';
982     Tcl_DStringSetLength(sourcePtr, oldSourceLen);
983     result = (*traverseProc)(sourcePtr, targetPtr, DOTREE_PRED, errorPtr);
984     if (result != TCL_OK) {
985     FindClose(handle);
986     return result;
987     }
988    
989     sourceLen = oldSourceLen;
990    
991     if (tclWinProcs->useWide) {
992     sourceLen += sizeof(WCHAR);
993     Tcl_DStringAppend(sourcePtr, (char *) L"\\", sizeof(WCHAR) + 1);
994     Tcl_DStringSetLength(sourcePtr, sourceLen);
995     } else {
996     sourceLen += 1;
997     Tcl_DStringAppend(sourcePtr, "\\", 1);
998     }
999     if (targetPtr != NULL) {
1000     oldTargetLen = Tcl_DStringLength(targetPtr);
1001    
1002     targetLen = oldTargetLen;
1003     if (tclWinProcs->useWide) {
1004     targetLen += sizeof(WCHAR);
1005     Tcl_DStringAppend(targetPtr, (char *) L"\\", sizeof(WCHAR) + 1);
1006     Tcl_DStringSetLength(targetPtr, targetLen);
1007     } else {
1008     targetLen += 1;
1009     Tcl_DStringAppend(targetPtr, "\\", 1);
1010     }
1011     }
1012    
1013     found = 1;
1014     for ( ; found; found = (*tclWinProcs->findNextFileProc)(handle, &data)) {
1015     TCHAR *nativeName;
1016     int len;
1017    
1018     if (tclWinProcs->useWide) {
1019     WCHAR *wp;
1020    
1021     wp = data.w.cFileName;
1022     if (*wp == '.') {
1023     wp++;
1024     if (*wp == '.') {
1025     wp++;
1026     }
1027     if (*wp == '\0') {
1028     continue;
1029     }
1030     }
1031     nativeName = (TCHAR *) data.w.cFileName;
1032     len = Tcl_UniCharLen(data.w.cFileName) * sizeof(WCHAR);
1033     } else {
1034     if ((strcmp(data.a.cFileName, ".") == 0)
1035     || (strcmp(data.a.cFileName, "..") == 0)) {
1036     continue;
1037     }
1038     nativeName = (TCHAR *) data.a.cFileName;
1039     len = strlen(data.a.cFileName);
1040     }
1041    
1042     /*
1043     * Append name after slash, and recurse on the file.
1044     */
1045    
1046     Tcl_DStringAppend(sourcePtr, (char *) nativeName, len + 1);
1047     Tcl_DStringSetLength(sourcePtr, Tcl_DStringLength(sourcePtr) - 1);
1048     if (targetPtr != NULL) {
1049     Tcl_DStringAppend(targetPtr, (char *) nativeName, len + 1);
1050     Tcl_DStringSetLength(targetPtr, Tcl_DStringLength(targetPtr) - 1);
1051     }
1052     result = TraverseWinTree(traverseProc, sourcePtr, targetPtr,
1053     errorPtr);
1054     if (result != TCL_OK) {
1055     break;
1056     }
1057    
1058     /*
1059     * Remove name after slash.
1060     */
1061    
1062     Tcl_DStringSetLength(sourcePtr, sourceLen);
1063     if (targetPtr != NULL) {
1064     Tcl_DStringSetLength(targetPtr, targetLen);
1065     }
1066     }
1067     FindClose(handle);
1068    
1069     /*
1070     * Strip off the trailing slash we added
1071     */
1072    
1073     Tcl_DStringSetLength(sourcePtr, oldSourceLen + 1);
1074     Tcl_DStringSetLength(sourcePtr, oldSourceLen);
1075     if (targetPtr != NULL) {
1076     Tcl_DStringSetLength(targetPtr, oldTargetLen + 1);
1077     Tcl_DStringSetLength(targetPtr, oldTargetLen);
1078     }
1079     if (result == TCL_OK) {
1080     /*
1081     * Call traverseProc() on a directory after visiting all the
1082     * files in that directory.
1083     */
1084    
1085     result = (*traverseProc)(sourcePtr, targetPtr, DOTREE_POSTD,
1086     errorPtr);
1087     }
1088     end:
1089     if (nativeErrfile != NULL) {
1090     TclWinConvertError(GetLastError());
1091     if (errorPtr != NULL) {
1092     Tcl_WinTCharToUtf(nativeErrfile, -1, errorPtr);
1093     }
1094     result = TCL_ERROR;
1095     }
1096    
1097     return result;
1098     }
1099    
1100     /*
1101     *----------------------------------------------------------------------
1102     *
1103     * TraversalCopy
1104     *
1105     * Called from TraverseUnixTree in order to execute a recursive
1106     * copy of a directory.
1107     *
1108     * Results:
1109     * Standard Tcl result.
1110     *
1111     * Side effects:
1112     * Depending on the value of type, src may be copied to dst.
1113     *
1114     *----------------------------------------------------------------------
1115     */
1116    
1117     static int
1118     TraversalCopy(
1119     Tcl_DString *srcPtr, /* Source pathname to copy. */
1120     Tcl_DString *dstPtr, /* Destination pathname of copy. */
1121     int type, /* Reason for call - see TraverseWinTree() */
1122     Tcl_DString *errorPtr) /* If non-NULL, initialized DString filled
1123     * with UTF-8 name of file causing error. */
1124     {
1125     TCHAR *nativeDst, *nativeSrc;
1126     DWORD attr;
1127    
1128     switch (type) {
1129     case DOTREE_F: {
1130     if (DoCopyFile(srcPtr, dstPtr) == TCL_OK) {
1131     return TCL_OK;
1132     }
1133     break;
1134     }
1135     case DOTREE_PRED: {
1136     if (DoCreateDirectory(dstPtr) == TCL_OK) {
1137     nativeSrc = (TCHAR *) Tcl_DStringValue(srcPtr);
1138     nativeDst = (TCHAR *) Tcl_DStringValue(dstPtr);
1139     attr = (*tclWinProcs->getFileAttributesProc)(nativeSrc);
1140     if ((*tclWinProcs->setFileAttributesProc)(nativeDst, attr) != FALSE) {
1141     return TCL_OK;
1142     }
1143     TclWinConvertError(GetLastError());
1144     }
1145     break;
1146     }
1147     case DOTREE_POSTD: {
1148     return TCL_OK;
1149     }
1150     }
1151    
1152     /*
1153     * There shouldn't be a problem with src, because we already
1154     * checked it to get here.
1155     */
1156    
1157     if (errorPtr != NULL) {
1158     nativeDst = (TCHAR *) Tcl_DStringValue(dstPtr);
1159     Tcl_WinTCharToUtf(nativeDst, -1, errorPtr);
1160     }
1161     return TCL_ERROR;
1162     }
1163    
1164     /*
1165     *----------------------------------------------------------------------
1166     *
1167     * TraversalDelete --
1168     *
1169     * Called by procedure TraverseWinTree for every file and
1170     * directory that it encounters in a directory hierarchy. This
1171     * procedure unlinks files, and removes directories after all the
1172     * containing files have been processed.
1173     *
1174     * Results:
1175     * Standard Tcl result.
1176     *
1177     * Side effects:
1178     * Files or directory specified by src will be deleted. If an
1179     * error occurs, the windows error is converted to a Posix error
1180     * and errno is set accordingly.
1181     *
1182     *----------------------------------------------------------------------
1183     */
1184    
1185     static int
1186     TraversalDelete(
1187     Tcl_DString *srcPtr, /* Source pathname to delete. */
1188     Tcl_DString *dstPtr, /* Not used. */
1189     int type, /* Reason for call - see TraverseWinTree() */
1190     Tcl_DString *errorPtr) /* If non-NULL, initialized DString filled
1191     * with UTF-8 name of file causing error. */
1192     {
1193     TCHAR *nativeSrc;
1194    
1195     switch (type) {
1196     case DOTREE_F: {
1197     if (DoDeleteFile(srcPtr) == TCL_OK) {
1198     return TCL_OK;
1199     }
1200     break;
1201     }
1202     case DOTREE_PRED: {
1203     return TCL_OK;
1204     }
1205     case DOTREE_POSTD: {
1206     if (DoRemoveDirectory(srcPtr, 0, NULL) == TCL_OK) {
1207     return TCL_OK;
1208     }
1209     break;
1210     }
1211     }
1212    
1213     if (errorPtr != NULL) {
1214     nativeSrc = (TCHAR *) Tcl_DStringValue(srcPtr);
1215     Tcl_WinTCharToUtf(nativeSrc, -1, errorPtr);
1216     }
1217     return TCL_ERROR;
1218     }
1219    
1220     /*
1221     *----------------------------------------------------------------------
1222     *
1223     * StatError --
1224     *
1225     * Sets the object result with the appropriate error.
1226     *
1227     * Results:
1228     * None.
1229     *
1230     * Side effects:
1231     * The interp's object result is set with an error message
1232     * based on the objIndex, fileName and errno.
1233     *
1234     *----------------------------------------------------------------------
1235     */
1236    
1237     static void
1238     StatError(
1239     Tcl_Interp *interp, /* The interp that has the error */
1240     CONST char *fileName) /* The name of the file which caused the
1241     * error. */
1242     {
1243     TclWinConvertError(GetLastError());
1244     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1245     "could not read \"", fileName, "\": ", Tcl_PosixError(interp),
1246     (char *) NULL);
1247     }
1248    
1249     /*
1250     *----------------------------------------------------------------------
1251     *
1252     * GetWinFileAttributes --
1253     *
1254     * Returns a Tcl_Obj containing the value of a file attribute.
1255     * This routine gets the -hidden, -readonly or -system attribute.
1256     *
1257     * Results:
1258     * Standard Tcl result and a Tcl_Obj in attributePtrPtr. The object
1259     * will have ref count 0. If the return value is not TCL_OK,
1260     * attributePtrPtr is not touched.
1261     *
1262     * Side effects:
1263     * A new object is allocated if the file is valid.
1264     *
1265     *----------------------------------------------------------------------
1266     */
1267    
1268     static int
1269     GetWinFileAttributes(
1270     Tcl_Interp *interp, /* The interp we are using for errors. */
1271     int objIndex, /* The index of the attribute. */
1272     CONST char *fileName, /* The name of the file. */
1273     Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */
1274     {
1275     DWORD result;
1276     Tcl_DString ds;
1277     TCHAR *nativeName;
1278    
1279     nativeName = Tcl_WinUtfToTChar(fileName, -1, &ds);
1280     result = (*tclWinProcs->getFileAttributesProc)(nativeName);
1281     Tcl_DStringFree(&ds);
1282    
1283     if (result == 0xffffffff) {
1284     StatError(interp, fileName);
1285     return TCL_ERROR;
1286     }
1287    
1288     *attributePtrPtr = Tcl_NewBooleanObj(result & attributeArray[objIndex]);
1289     return TCL_OK;
1290     }
1291    
1292     /*
1293     *----------------------------------------------------------------------
1294     *
1295     * ConvertFileNameFormat --
1296     *
1297     * Returns a Tcl_Obj containing either the long or short version of the
1298     * file name.
1299     *
1300     * Results:
1301     * Standard Tcl result and a Tcl_Obj in attributePtrPtr. The object
1302     * will have ref count 0. If the return value is not TCL_OK,
1303     * attributePtrPtr is not touched.
1304     *
1305     * Side effects:
1306     * A new object is allocated if the file is valid.
1307     *
1308     *----------------------------------------------------------------------
1309     */
1310    
1311     static int
1312     ConvertFileNameFormat(
1313     Tcl_Interp *interp, /* The interp we are using for errors. */
1314     int objIndex, /* The index of the attribute. */
1315     CONST char *fileName, /* The name of the file. */
1316     int longShort, /* 0 to short name, 1 to long name. */
1317     Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */
1318     {
1319     int pathc, i;
1320     char **pathv, **newv;
1321     char *resultStr;
1322     Tcl_DString resultDString;
1323     int result = TCL_OK;
1324    
1325     Tcl_SplitPath(fileName, &pathc, &pathv);
1326     newv = (char **) ckalloc(pathc * sizeof(char *));
1327    
1328     if (pathc == 0) {
1329     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1330     "could not read \"", fileName,
1331     "\": no such file or directory",
1332     (char *) NULL);
1333     result = TCL_ERROR;
1334     goto cleanup;
1335     }
1336    
1337     for (i = 0; i < pathc; i++) {
1338     if ((pathv[i][0] == '/')
1339     || ((strlen(pathv[i]) == 3) && (pathv[i][1] == ':'))
1340     || (strcmp(pathv[i], ".") == 0)
1341     || (strcmp(pathv[i], "..") == 0)) {
1342     /*
1343     * Handle "/", "//machine/export", "c:/", "." or ".." by just
1344     * copying the string literally. Uppercase the drive letter,
1345     * just because it looks better under Windows to do so.
1346     */
1347    
1348     simple:
1349     pathv[i][0] = (char) Tcl_UniCharToUpper(UCHAR(pathv[i][0]));
1350     newv[i] = (char *) ckalloc(strlen(pathv[i]) + 1);
1351     lstrcpyA(newv[i], pathv[i]);
1352     } else {
1353     char *str;
1354     TCHAR *nativeName;
1355     Tcl_DString ds;
1356     WIN32_FIND_DATAT data;
1357     HANDLE handle;
1358     DWORD attr;
1359    
1360     Tcl_DStringInit(&resultDString);
1361     str = Tcl_JoinPath(i + 1, pathv, &resultDString);
1362     nativeName = Tcl_WinUtfToTChar(str, -1, &ds);
1363     handle = (*tclWinProcs->findFirstFileProc)(nativeName, &data);
1364     if (handle == INVALID_HANDLE_VALUE) {
1365     /*
1366     * FindFirstFile() doesn't like root directories. We
1367     * would only get a root directory here if the caller
1368     * specified "c:" or "c:." and the current directory on the
1369     * drive was the root directory
1370     */
1371    
1372     attr = (*tclWinProcs->getFileAttributesProc)(nativeName);
1373     if ((attr != 0xFFFFFFFF) && (attr & FILE_ATTRIBUTE_DIRECTORY)) {
1374     Tcl_DStringFree(&ds);
1375     Tcl_DStringFree(&resultDString);
1376    
1377     goto simple;
1378     }
1379     }
1380     Tcl_DStringFree(&ds);
1381     Tcl_DStringFree(&resultDString);
1382    
1383     if (handle == INVALID_HANDLE_VALUE) {
1384     pathc = i - 1;
1385     StatError(interp, fileName);
1386     result = TCL_ERROR;
1387     goto cleanup;
1388     }
1389     if (tclWinProcs->useWide) {
1390     nativeName = (TCHAR *) data.w.cAlternateFileName;
1391     if (longShort) {
1392     if (data.w.cFileName[0] != '\0') {
1393     nativeName = (TCHAR *) data.w.cFileName;
1394     }
1395     } else {
1396     if (data.w.cAlternateFileName[0] == '\0') {
1397     nativeName = (TCHAR *) data.w.cFileName;
1398     }
1399     }
1400     } else {
1401     nativeName = (TCHAR *) data.a.cAlternateFileName;
1402     if (longShort) {
1403     if (data.a.cFileName[0] != '\0') {
1404     nativeName = (TCHAR *) data.a.cFileName;
1405     }
1406     } else {
1407     if (data.a.cAlternateFileName[0] == '\0') {
1408     nativeName = (TCHAR *) data.a.cFileName;
1409     }
1410     }
1411     }
1412    
1413     /*
1414     * Purify reports a extraneous UMR in Tcl_WinTCharToUtf() trying
1415     * to dereference nativeName as a Unicode string. I have proven
1416     * to myself that purify is wrong by running the following
1417     * example when nativeName == data.w.cAlternateFileName and
1418     * noting that purify doesn't complain about the first line,
1419     * but does complain about the second.
1420     *
1421     * fprintf(stderr, "%d\n", data.w.cAlternateFileName[0]);
1422     * fprintf(stderr, "%d\n", ((WCHAR *) nativeName)[0]);
1423     */
1424    
1425     Tcl_WinTCharToUtf(nativeName, -1, &ds);
1426     newv[i] = ckalloc(Tcl_DStringLength(&ds) + 1);
1427     lstrcpyA(newv[i], Tcl_DStringValue(&ds));
1428     Tcl_DStringFree(&ds);
1429     FindClose(handle);
1430     }
1431     }
1432    
1433     Tcl_DStringInit(&resultDString);
1434     resultStr = Tcl_JoinPath(pathc, newv, &resultDString);
1435     *attributePtrPtr = Tcl_NewStringObj(resultStr,
1436     Tcl_DStringLength(&resultDString));
1437     Tcl_DStringFree(&resultDString);
1438    
1439     cleanup:
1440     for (i = 0; i < pathc; i++) {
1441     ckfree(newv[i]);
1442     }
1443     ckfree((char *) newv);
1444     ckfree((char *) pathv);
1445     return result;
1446     }
1447    
1448     /*
1449     *----------------------------------------------------------------------
1450     *
1451     * GetWinFileLongName --
1452     *
1453     * Returns a Tcl_Obj containing the short version of the file
1454     * name.
1455     *
1456     * Results:
1457     * Standard Tcl result and a Tcl_Obj in attributePtrPtr. The object
1458     * will have ref count 0. If the return value is not TCL_OK,
1459     * attributePtrPtr is not touched.
1460     *
1461     * Side effects:
1462     * A new object is allocated if the file is valid.
1463     *
1464     *----------------------------------------------------------------------
1465     */
1466    
1467     static int
1468     GetWinFileLongName(
1469     Tcl_Interp *interp, /* The interp we are using for errors. */
1470     int objIndex, /* The index of the attribute. */
1471     CONST char *fileName, /* The name of the file. */
1472     Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */
1473     {
1474     return ConvertFileNameFormat(interp, objIndex, fileName, 1, attributePtrPtr);
1475     }
1476    
1477     /*
1478     *----------------------------------------------------------------------
1479     *
1480     * GetWinFileShortName --
1481     *
1482     * Returns a Tcl_Obj containing the short version of the file
1483     * name.
1484     *
1485     * Results:
1486     * Standard Tcl result and a Tcl_Obj in attributePtrPtr. The object
1487     * will have ref count 0. If the return value is not TCL_OK,
1488     * attributePtrPtr is not touched.
1489     *
1490     * Side effects:
1491     * A new object is allocated if the file is valid.
1492     *
1493     *----------------------------------------------------------------------
1494     */
1495    
1496     static int
1497     GetWinFileShortName(
1498     Tcl_Interp *interp, /* The interp we are using for errors. */
1499     int objIndex, /* The index of the attribute. */
1500     CONST char *fileName, /* The name of the file. */
1501     Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */
1502     {
1503     return ConvertFileNameFormat(interp, objIndex, fileName, 0, attributePtrPtr);
1504     }
1505    
1506     /*
1507     *----------------------------------------------------------------------
1508     *
1509     * SetWinFileAttributes --
1510     *
1511     * Set the file attributes to the value given by attributePtr.
1512     * This routine sets the -hidden, -readonly, or -system attributes.
1513     *
1514     * Results:
1515     * Standard TCL error.
1516     *
1517     * Side effects:
1518     * The file's attribute is set.
1519     *
1520     *----------------------------------------------------------------------
1521     */
1522    
1523     static int
1524     SetWinFileAttributes(
1525     Tcl_Interp *interp, /* The interp we are using for errors. */
1526     int objIndex, /* The index of the attribute. */
1527     CONST char *fileName, /* The name of the file. */
1528     Tcl_Obj *attributePtr) /* The new value of the attribute. */
1529     {
1530     DWORD fileAttributes;
1531     int yesNo;
1532     int result;
1533     Tcl_DString ds;
1534     TCHAR *nativeName;
1535    
1536     nativeName = Tcl_WinUtfToTChar(fileName, -1, &ds);
1537     fileAttributes = (*tclWinProcs->getFileAttributesProc)(nativeName);
1538    
1539     if (fileAttributes == 0xffffffff) {
1540     StatError(interp, fileName);
1541     result = TCL_ERROR;
1542     goto end;
1543     }
1544    
1545     result = Tcl_GetBooleanFromObj(interp, attributePtr, &yesNo);
1546     if (result != TCL_OK) {
1547     goto end;
1548     }
1549    
1550     if (yesNo) {
1551     fileAttributes |= (attributeArray[objIndex]);
1552     } else {
1553     fileAttributes &= ~(attributeArray[objIndex]);
1554     }
1555    
1556     if (!(*tclWinProcs->setFileAttributesProc)(nativeName, fileAttributes)) {
1557     StatError(interp, fileName);
1558     result = TCL_ERROR;
1559     goto end;
1560     }
1561    
1562     end:
1563     Tcl_DStringFree(&ds);
1564    
1565     return result;
1566     }
1567    
1568     /*
1569     *----------------------------------------------------------------------
1570     *
1571     * SetWinFileLongName --
1572     *
1573     * The attribute in question is a readonly attribute and cannot
1574     * be set.
1575     *
1576     * Results:
1577     * TCL_ERROR
1578     *
1579     * Side effects:
1580     * The object result is set to a pertinant error message.
1581     *
1582     *----------------------------------------------------------------------
1583     */
1584    
1585     static int
1586     CannotSetAttribute(
1587     Tcl_Interp *interp, /* The interp we are using for errors. */
1588     int objIndex, /* The index of the attribute. */
1589     CONST char *fileName, /* The name of the file. */
1590     Tcl_Obj *attributePtr) /* The new value of the attribute. */
1591     {
1592     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1593     "cannot set attribute \"", tclpFileAttrStrings[objIndex],
1594     "\" for file \"", fileName, "\": attribute is readonly",
1595     (char *) NULL);
1596     return TCL_ERROR;
1597     }
1598    
1599    
1600     /*
1601     *---------------------------------------------------------------------------
1602     *
1603     * TclpListVolumes --
1604     *
1605     * Lists the currently mounted volumes
1606     *
1607     * Results:
1608     * A standard Tcl result. Will always be TCL_OK, since there is no way
1609     * that this command can fail. Also, the interpreter's result is set to
1610     * the list of volumes.
1611     *
1612     * Side effects:
1613     * None
1614     *
1615     *---------------------------------------------------------------------------
1616     */
1617    
1618     int
1619     TclpListVolumes(
1620     Tcl_Interp *interp) /* Interpreter for returning volume list. */
1621     {
1622     Tcl_Obj *resultPtr, *elemPtr;
1623     char buf[40 * 4]; /* There couldn't be more than 30 drives??? */
1624     int i;
1625     char *p;
1626    
1627     resultPtr = Tcl_GetObjResult(interp);
1628    
1629     /*
1630     * On Win32s:
1631     * GetLogicalDriveStrings() isn't implemented.
1632     * GetLogicalDrives() returns incorrect information.
1633     */
1634    
1635     if (GetLogicalDriveStringsA(sizeof(buf), buf) == 0) {
1636     /*
1637     * GetVolumeInformation() will detects all drives, but causes
1638     * chattering on empty floppy drives. We only do this if
1639     * GetLogicalDriveStrings() didn't work. It has also been reported
1640     * that on some laptops it takes a while for GetVolumeInformation()
1641     * to return when pinging an empty floppy drive, another reason to
1642     * try to avoid calling it.
1643     */
1644    
1645     buf[1] = ':';
1646     buf[2] = '/';
1647     buf[3] = '\0';
1648    
1649     for (i = 0; i < 26; i++) {
1650     buf[0] = (char) ('a' + i);
1651     if (GetVolumeInformationA(buf, NULL, 0, NULL, NULL, NULL, NULL, 0)
1652     || (GetLastError() == ERROR_NOT_READY)) {
1653     elemPtr = Tcl_NewStringObj(buf, -1);
1654     Tcl_ListObjAppendElement(NULL, resultPtr, elemPtr);
1655     }
1656     }
1657     } else {
1658     for (p = buf; *p != '\0'; p += 4) {
1659     p[2] = '/';
1660     elemPtr = Tcl_NewStringObj(p, -1);
1661     Tcl_ListObjAppendElement(NULL, resultPtr, elemPtr);
1662     }
1663     }
1664     return TCL_OK;
1665     }
1666    
1667     /* End of tclwinfcmd.c */

Properties

Name Value
svn:eol-style native
svn:keywords Header

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25