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

Contents of /projs/dtats/trunk/shared_source/c_tcl_base_7_5_w_mods/tclwinfcmd.c

Parent Directory Parent Directory | Revision Log Revision Log


Revision 98 - (show annotations) (download)
Sun Dec 18 00:57:31 2016 UTC (7 years, 9 months ago) by dashley
File MIME type: text/plain
File size: 47912 byte(s)
Reorganization.
1 /* $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