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

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

Parent Directory Parent Directory | Revision Log Revision Log


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

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25