/[dtapublic]/sf_code/esrgpcpj/shared/tcl_base/tclwinfcmd.c
ViewVC logotype

Contents of /sf_code/esrgpcpj/shared/tcl_base/tclwinfcmd.c

Parent Directory Parent Directory | Revision Log Revision Log


Revision 25 - (show annotations) (download)
Sat Oct 8 06:43:03 2016 UTC (8 years, 2 months ago) by dashley
File MIME type: text/plain
File size: 49911 byte(s)
Initial commit.
1 /* $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