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

Contents of /projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclwinfile.c

Parent Directory Parent Directory | Revision Log Revision Log


Revision 44 - (show annotations) (download)
Fri Oct 14 02:09:58 2016 UTC (8 years, 2 months ago) by dashley
File MIME type: text/plain
File size: 29194 byte(s)
Rename for reorganization.
1 /* $Header: /cvsroot/esrg/sfesrg/esrgpcpj/shared/tcl_base/tclwinfile.c,v 1.1.1.1 2001/06/13 04:49:10 dtashley Exp $ */
2
3 /*
4 * tclWinFile.c --
5 *
6 * This file contains temporary wrappers around UNIX file handling
7 * functions. These wrappers map the UNIX functions to Win32 HANDLE-style
8 * files, which can be manipulated through the Win32 console redirection
9 * interfaces.
10 *
11 * Copyright (c) 1995-1998 Sun Microsystems, Inc.
12 *
13 * See the file "license.terms" for information on usage and redistribution
14 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
15 *
16 * RCS: @(#) $Id: tclwinfile.c,v 1.1.1.1 2001/06/13 04:49:10 dtashley Exp $
17 */
18
19 #include "tclWinInt.h"
20 #include <sys/stat.h>
21 #include <shlobj.h>
22 #include <lmaccess.h> /* For TclpGetUserHome(). */
23
24 static time_t ToCTime(FILETIME fileTime);
25
26 typedef NET_API_STATUS NET_API_FUNCTION NETUSERGETINFOPROC
27 (LPWSTR servername, LPWSTR username, DWORD level, LPBYTE *bufptr);
28
29 typedef NET_API_STATUS NET_API_FUNCTION NETAPIBUFFERFREEPROC
30 (LPVOID Buffer);
31
32 typedef NET_API_STATUS NET_API_FUNCTION NETGETDCNAMEPROC
33 (LPWSTR servername, LPWSTR domainname, LPBYTE *bufptr);
34
35
36 /*
37 *---------------------------------------------------------------------------
38 *
39 * TclpFindExecutable --
40 *
41 * This procedure computes the absolute path name of the current
42 * application, given its argv[0] value.
43 *
44 * Results:
45 * A dirty UTF string that is the path to the executable. At this
46 * point we may not know the system encoding. Convert the native
47 * string value to UTF using the default encoding. The assumption
48 * is that we will still be able to parse the path given the path
49 * name contains ASCII string and '/' chars do not conflict with
50 * other UTF chars.
51 *
52 * Side effects:
53 * The variable tclNativeExecutableName gets filled in with the file
54 * name for the application, if we figured it out. If we couldn't
55 * figure it out, tclNativeExecutableName is set to NULL.
56 *
57 *---------------------------------------------------------------------------
58 */
59
60 char *
61 TclpFindExecutable(argv0)
62 CONST char *argv0; /* The value of the application's argv[0]
63 * (native). */
64 {
65 Tcl_DString ds;
66 WCHAR wName[MAX_PATH];
67
68 if (argv0 == NULL) {
69 return NULL;
70 }
71 if (tclNativeExecutableName != NULL) {
72 return tclNativeExecutableName;
73 }
74
75 /*
76 * Under Windows we ignore argv0, and return the path for the file used to
77 * create this process.
78 */
79
80 (*tclWinProcs->getModuleFileNameProc)(NULL, wName, MAX_PATH);
81 Tcl_WinTCharToUtf((TCHAR *) wName, -1, &ds);
82
83 tclNativeExecutableName = ckalloc((unsigned) (Tcl_DStringLength(&ds) + 1));
84 strcpy(tclNativeExecutableName, Tcl_DStringValue(&ds));
85 Tcl_DStringFree(&ds);
86
87 TclWinNoBackslash(tclNativeExecutableName);
88 return tclNativeExecutableName;
89 }
90
91 /*
92 *----------------------------------------------------------------------
93 *
94 * TclpMatchFilesTypes --
95 *
96 * This routine is used by the globbing code to search a
97 * directory for all files which match a given pattern.
98 *
99 * Results:
100 * If the tail argument is NULL, then the matching files are
101 * added to the the interp's result. Otherwise, TclDoGlob is called
102 * recursively for each matching subdirectory. The return value
103 * is a standard Tcl result indicating whether an error occurred
104 * in globbing.
105 *
106 * Side effects:
107 * None.
108 *
109 *---------------------------------------------------------------------- */
110
111 int
112 TclpMatchFilesTypes(
113 Tcl_Interp *interp, /* Interpreter to receive results. */
114 char *separators, /* Directory separators to pass to TclDoGlob. */
115 Tcl_DString *dirPtr, /* Contains path to directory to search. */
116 char *pattern, /* Pattern to match against. */
117 char *tail, /* Pointer to end of pattern. Tail must
118 * point to a location in pattern and must
119 * not be static.*/
120 GlobTypeData *types) /* Object containing list of acceptable types.
121 * May be NULL. */
122 {
123 char drivePat[] = "?:\\";
124 const char *message;
125 char *dir, *newPattern, *root;
126 int matchDotFiles;
127 int dirLength, result = TCL_OK;
128 Tcl_DString dirString, patternString;
129 DWORD attr, volFlags;
130 HANDLE handle;
131 WIN32_FIND_DATAT data;
132 BOOL found;
133 Tcl_DString ds;
134 TCHAR *nativeName;
135 Tcl_Obj *resultPtr;
136
137 /*
138 * Convert the path to normalized form since some interfaces only
139 * accept backslashes. Also, ensure that the directory ends with a
140 * separator character.
141 */
142
143 dirLength = Tcl_DStringLength(dirPtr);
144 Tcl_DStringInit(&dirString);
145 if (dirLength == 0) {
146 Tcl_DStringAppend(&dirString, ".\\", 2);
147 } else {
148 char *p;
149
150 Tcl_DStringAppend(&dirString, Tcl_DStringValue(dirPtr),
151 Tcl_DStringLength(dirPtr));
152 for (p = Tcl_DStringValue(&dirString); *p != '\0'; p++) {
153 if (*p == '/') {
154 *p = '\\';
155 }
156 }
157 p--;
158 if ((*p != '\\') && (*p != ':')) {
159 Tcl_DStringAppend(&dirString, "\\", 1);
160 }
161 }
162 dir = Tcl_DStringValue(&dirString);
163
164 /*
165 * First verify that the specified path is actually a directory.
166 */
167
168 nativeName = Tcl_WinUtfToTChar(dir, Tcl_DStringLength(&dirString), &ds);
169 attr = (*tclWinProcs->getFileAttributesProc)(nativeName);
170 Tcl_DStringFree(&ds);
171
172 if ((attr == 0xffffffff) || ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0)) {
173 Tcl_DStringFree(&dirString);
174 return TCL_OK;
175 }
176
177 /*
178 * Next check the volume information for the directory to see whether
179 * comparisons should be case sensitive or not. If the root is null, then
180 * we use the root of the current directory. If the root is just a drive
181 * specifier, we use the root directory of the given drive.
182 */
183
184 switch (Tcl_GetPathType(dir)) {
185 case TCL_PATH_RELATIVE:
186 found = GetVolumeInformationA(NULL, NULL, 0, NULL, NULL,
187 &volFlags, NULL, 0);
188 break;
189 case TCL_PATH_VOLUME_RELATIVE:
190 if (dir[0] == '\\') {
191 root = NULL;
192 } else {
193 root = drivePat;
194 *root = dir[0];
195 }
196 found = GetVolumeInformationA(root, NULL, 0, NULL, NULL,
197 &volFlags, NULL, 0);
198 break;
199 case TCL_PATH_ABSOLUTE:
200 if (dir[1] == ':') {
201 root = drivePat;
202 *root = dir[0];
203 found = GetVolumeInformationA(root, NULL, 0, NULL, NULL,
204 &volFlags, NULL, 0);
205 } else if (dir[1] == '\\') {
206 char *p;
207
208 p = strchr(dir + 2, '\\');
209 p = strchr(p + 1, '\\');
210 p++;
211 nativeName = Tcl_WinUtfToTChar(dir, p - dir, &ds);
212 found = (*tclWinProcs->getVolumeInformationProc)(nativeName,
213 NULL, 0, NULL, NULL, &volFlags, NULL, 0);
214 Tcl_DStringFree(&ds);
215 }
216 break;
217 }
218
219 if (found == 0) {
220 message = "couldn't read volume information for \"";
221 goto error;
222 }
223
224 /*
225 * In Windows, although some volumes may support case sensitivity, Windows
226 * doesn't honor case. So in globbing we need to ignore the case
227 * of file names.
228 */
229
230 Tcl_DStringInit(&patternString);
231 newPattern = Tcl_DStringAppend(&patternString, pattern, tail - pattern);
232 Tcl_UtfToLower(newPattern);
233
234 /*
235 * We need to check all files in the directory, so append a *.*
236 * to the path.
237 */
238
239 dir = Tcl_DStringAppend(&dirString, "*.*", 3);
240 nativeName = Tcl_WinUtfToTChar(dir, -1, &ds);
241 handle = (*tclWinProcs->findFirstFileProc)(nativeName, &data);
242 Tcl_DStringFree(&ds);
243
244 if (handle == INVALID_HANDLE_VALUE) {
245 message = "couldn't read directory \"";
246 goto error;
247 }
248
249 /*
250 * Clean up the tail pointer. Leave the tail pointing to the
251 * first character after the path separator or NULL.
252 */
253
254 if (*tail == '\\') {
255 tail++;
256 }
257 if (*tail == '\0') {
258 tail = NULL;
259 } else {
260 tail++;
261 }
262
263 /*
264 * Check to see if the pattern needs to compare with dot files.
265 */
266
267 if ((newPattern[0] == '.')
268 || ((pattern[0] == '\\') && (pattern[1] == '.'))) {
269 matchDotFiles = 1;
270 } else {
271 matchDotFiles = 0;
272 }
273
274 /*
275 * Now iterate over all of the files in the directory.
276 */
277
278 resultPtr = Tcl_GetObjResult(interp);
279 for (found = 1; found != 0;
280 found = (*tclWinProcs->findNextFileProc)(handle, &data)) {
281 TCHAR *nativeMatchResult;
282 char *name, *fname;
283
284 if (tclWinProcs->useWide) {
285 nativeName = (TCHAR *) data.w.cFileName;
286 } else {
287 nativeName = (TCHAR *) data.a.cFileName;
288 }
289 name = Tcl_WinTCharToUtf(nativeName, -1, &ds);
290
291 /*
292 * Check to see if the file matches the pattern. We need to convert
293 * the file name to lower case for comparison purposes. Note that we
294 * are ignoring the case sensitivity flag because Windows doesn't honor
295 * case even if the volume is case sensitive. If the volume also
296 * doesn't preserve case, then we previously returned the lower case
297 * form of the name. This didn't seem quite right since there are
298 * non-case-preserving volumes that actually return mixed case. So now
299 * we are returning exactly what we get from the system.
300 */
301
302 Tcl_UtfToLower(name);
303 nativeMatchResult = NULL;
304
305 if ((matchDotFiles == 0) && (name[0] == '.')) {
306 /*
307 * Ignore hidden files.
308 */
309 } else if (Tcl_StringMatch(name, newPattern) != 0) {
310 nativeMatchResult = nativeName;
311 }
312 Tcl_DStringFree(&ds);
313
314 if (nativeMatchResult == NULL) {
315 continue;
316 }
317
318 /*
319 * If the file matches, then we need to process the remainder of the
320 * path. If there are more characters to process, then ensure matching
321 * files are directories and call TclDoGlob. Otherwise, just add the
322 * file to the result.
323 */
324
325 name = Tcl_WinTCharToUtf(nativeMatchResult, -1, &ds);
326 Tcl_DStringAppend(dirPtr, name, -1);
327 Tcl_DStringFree(&ds);
328
329 fname = Tcl_DStringValue(dirPtr);
330 nativeName = Tcl_WinUtfToTChar(fname, Tcl_DStringLength(dirPtr), &ds);
331 attr = (*tclWinProcs->getFileAttributesProc)(nativeName);
332 Tcl_DStringFree(&ds);
333
334 if (tail == NULL) {
335 int typeOk = 1;
336 if (types != NULL) {
337 if (types->perm != 0) {
338 if (
339 ((types->perm & TCL_GLOB_PERM_RONLY) &&
340 !(attr & FILE_ATTRIBUTE_READONLY)) ||
341 ((types->perm & TCL_GLOB_PERM_HIDDEN) &&
342 !(attr & FILE_ATTRIBUTE_HIDDEN)) ||
343 ((types->perm & TCL_GLOB_PERM_R) &&
344 (TclpAccess(fname, R_OK) != 0)) ||
345 ((types->perm & TCL_GLOB_PERM_W) &&
346 (TclpAccess(fname, W_OK) != 0)) ||
347 ((types->perm & TCL_GLOB_PERM_X) &&
348 (TclpAccess(fname, X_OK) != 0))
349 ) {
350 typeOk = 0;
351 }
352 }
353 if (typeOk && types->type != 0) {
354 struct stat buf;
355 /*
356 * We must match at least one flag to be listed
357 */
358 typeOk = 0;
359 if (TclpLstat(fname, &buf) >= 0) {
360 /*
361 * In order bcdpfls as in 'find -t'
362 */
363 if (
364 ((types->type & TCL_GLOB_TYPE_BLOCK) &&
365 S_ISBLK(buf.st_mode)) ||
366 ((types->type & TCL_GLOB_TYPE_CHAR) &&
367 S_ISCHR(buf.st_mode)) ||
368 ((types->type & TCL_GLOB_TYPE_DIR) &&
369 S_ISDIR(buf.st_mode)) ||
370 ((types->type & TCL_GLOB_TYPE_PIPE) &&
371 S_ISFIFO(buf.st_mode)) ||
372 ((types->type & TCL_GLOB_TYPE_FILE) &&
373 S_ISREG(buf.st_mode))
374 #ifdef S_ISLNK
375 || ((types->type & TCL_GLOB_TYPE_LINK) &&
376 S_ISLNK(buf.st_mode))
377 #endif
378 #ifdef S_ISSOCK
379 || ((types->type & TCL_GLOB_TYPE_SOCK) &&
380 S_ISSOCK(buf.st_mode))
381 #endif
382 ) {
383 typeOk = 1;
384 }
385 } else {
386 /* Posix error occurred */
387 }
388 }
389 }
390 if (typeOk) {
391 Tcl_ListObjAppendElement(interp, resultPtr,
392 Tcl_NewStringObj(fname, Tcl_DStringLength(dirPtr)));
393 }
394 } else if (attr & FILE_ATTRIBUTE_DIRECTORY) {
395 Tcl_DStringAppend(dirPtr, "/", 1);
396 result = TclDoGlob(interp, separators, dirPtr, tail, types);
397 if (result != TCL_OK) {
398 break;
399 }
400 }
401 Tcl_DStringSetLength(dirPtr, dirLength);
402 }
403
404 FindClose(handle);
405 Tcl_DStringFree(&dirString);
406 Tcl_DStringFree(&patternString);
407
408 return result;
409
410 error:
411 Tcl_DStringFree(&dirString);
412 TclWinConvertError(GetLastError());
413 Tcl_ResetResult(interp);
414 Tcl_AppendResult(interp, message, Tcl_DStringValue(dirPtr), "\": ",
415 Tcl_PosixError(interp), (char *) NULL);
416 return TCL_ERROR;
417 }
418
419 /*
420 * TclpMatchFiles --
421 *
422 * This function is now obsolete. Call the above function
423 * 'TclpMatchFilesTypes' instead.
424 */
425 int
426 TclpMatchFiles(
427 Tcl_Interp *interp, /* Interpreter to receive results. */
428 char *separators, /* Directory separators to pass to TclDoGlob. */
429 Tcl_DString *dirPtr, /* Contains path to directory to search. */
430 char *pattern, /* Pattern to match against. */
431 char *tail) /* Pointer to end of pattern. Tail must
432 * point to a location in pattern and must
433 * not be static.*/
434 {
435 return TclpMatchFilesTypes(interp,separators,dirPtr,pattern,tail,NULL);
436 }
437
438 /*
439 *----------------------------------------------------------------------
440 *
441 * TclpGetUserHome --
442 *
443 * This function takes the passed in user name and finds the
444 * corresponding home directory specified in the password file.
445 *
446 * Results:
447 * The result is a pointer to a string specifying the user's home
448 * directory, or NULL if the user's home directory could not be
449 * determined. Storage for the result string is allocated in
450 * bufferPtr; the caller must call Tcl_DStringFree() when the result
451 * is no longer needed.
452 *
453 * Side effects:
454 * None.
455 *
456 *----------------------------------------------------------------------
457 */
458
459 char *
460 TclpGetUserHome(name, bufferPtr)
461 CONST char *name; /* User name for desired home directory. */
462 Tcl_DString *bufferPtr; /* Uninitialized or free DString filled
463 * with name of user's home directory. */
464 {
465 char *result;
466 HINSTANCE netapiInst;
467
468 result = NULL;
469
470 Tcl_DStringInit(bufferPtr);
471
472 netapiInst = LoadLibraryA("netapi32.dll");
473 if (netapiInst != NULL) {
474 NETAPIBUFFERFREEPROC *netApiBufferFreeProc;
475 NETGETDCNAMEPROC *netGetDCNameProc;
476 NETUSERGETINFOPROC *netUserGetInfoProc;
477
478 netApiBufferFreeProc = (NETAPIBUFFERFREEPROC *)
479 GetProcAddress(netapiInst, "NetApiBufferFree");
480 netGetDCNameProc = (NETGETDCNAMEPROC *)
481 GetProcAddress(netapiInst, "NetGetDCName");
482 netUserGetInfoProc = (NETUSERGETINFOPROC *)
483 GetProcAddress(netapiInst, "NetUserGetInfo");
484 if ((netUserGetInfoProc != NULL) && (netGetDCNameProc != NULL)
485 && (netApiBufferFreeProc != NULL)) {
486 USER_INFO_1 *uiPtr;
487 Tcl_DString ds;
488 int nameLen, badDomain;
489 char *domain;
490 WCHAR *wName, *wHomeDir, *wDomain;
491 WCHAR buf[MAX_PATH];
492
493 badDomain = 0;
494 nameLen = -1;
495 wDomain = NULL;
496 domain = strchr(name, '@');
497 if (domain != NULL) {
498 Tcl_DStringInit(&ds);
499 wName = Tcl_UtfToUniCharDString(domain + 1, -1, &ds);
500 badDomain = (*netGetDCNameProc)(NULL, wName,
501 (LPBYTE *) &wDomain);
502 Tcl_DStringFree(&ds);
503 nameLen = domain - name;
504 }
505 if (badDomain == 0) {
506 Tcl_DStringInit(&ds);
507 wName = Tcl_UtfToUniCharDString(name, nameLen, &ds);
508 if ((*netUserGetInfoProc)(wDomain, wName, 1,
509 (LPBYTE *) &uiPtr) == 0) {
510 wHomeDir = uiPtr->usri1_home_dir;
511 if ((wHomeDir != NULL) && (wHomeDir[0] != L'\0')) {
512 Tcl_UniCharToUtfDString(wHomeDir, lstrlenW(wHomeDir),
513 bufferPtr);
514 } else {
515 /*
516 * User exists but has no home dir. Return
517 * "{Windows Drive}:/users/default".
518 */
519
520 GetWindowsDirectoryW(buf, MAX_PATH);
521 Tcl_UniCharToUtfDString(buf, 2, bufferPtr);
522 Tcl_DStringAppend(bufferPtr, "/users/default", -1);
523 }
524 result = Tcl_DStringValue(bufferPtr);
525 (*netApiBufferFreeProc)((void *) uiPtr);
526 }
527 Tcl_DStringFree(&ds);
528 }
529 if (wDomain != NULL) {
530 (*netApiBufferFreeProc)((void *) wDomain);
531 }
532 }
533 FreeLibrary(netapiInst);
534 }
535 if (result == NULL) {
536 /*
537 * Look in the "Password Lists" section of system.ini for the
538 * local user. There are also entries in that section that begin
539 * with a "*" character that are used by Windows for other
540 * purposes; ignore user names beginning with a "*".
541 */
542
543 char buf[MAX_PATH];
544
545 if (name[0] != '*') {
546 if (GetPrivateProfileStringA("Password Lists", name, "", buf,
547 MAX_PATH, "system.ini") > 0) {
548 /*
549 * User exists, but there is no such thing as a home
550 * directory in system.ini. Return "{Windows drive}:/".
551 */
552
553 GetWindowsDirectoryA(buf, MAX_PATH);
554 Tcl_DStringAppend(bufferPtr, buf, 3);
555 result = Tcl_DStringValue(bufferPtr);
556 }
557 }
558 }
559
560 return result;
561 }
562
563 /*
564 *---------------------------------------------------------------------------
565 *
566 * TclpAccess --
567 *
568 * This function replaces the library version of access(), fixing the
569 * following bugs:
570 *
571 * 1. access() returns that all files have execute permission.
572 *
573 * Results:
574 * See access documentation.
575 *
576 * Side effects:
577 * See access documentation.
578 *
579 *---------------------------------------------------------------------------
580 */
581
582 int
583 TclpAccess(
584 CONST char *path, /* Path of file to access (UTF-8). */
585 int mode) /* Permission setting. */
586 {
587 Tcl_DString ds;
588 TCHAR *nativePath;
589 DWORD attr;
590
591 nativePath = Tcl_WinUtfToTChar(path, -1, &ds);
592 attr = (*tclWinProcs->getFileAttributesProc)(nativePath);
593 Tcl_DStringFree(&ds);
594
595 if (attr == 0xffffffff) {
596 /*
597 * File doesn't exist.
598 */
599
600 TclWinConvertError(GetLastError());
601 return -1;
602 }
603
604 if ((mode & W_OK) && (attr & FILE_ATTRIBUTE_READONLY)) {
605 /*
606 * File is not writable.
607 */
608
609 Tcl_SetErrno(EACCES);
610 return -1;
611 }
612
613 if (mode & X_OK) {
614 CONST char *p;
615
616 if (attr & FILE_ATTRIBUTE_DIRECTORY) {
617 /*
618 * Directories are always executable.
619 */
620
621 return 0;
622 }
623 p = strrchr(path, '.');
624 if (p != NULL) {
625 p++;
626 if ((stricmp(p, "exe") == 0)
627 || (stricmp(p, "com") == 0)
628 || (stricmp(p, "bat") == 0)) {
629 /*
630 * File that ends with .exe, .com, or .bat is executable.
631 */
632
633 return 0;
634 }
635 }
636 Tcl_SetErrno(EACCES);
637 return -1;
638 }
639
640 return 0;
641 }
642
643 /*
644 *----------------------------------------------------------------------
645 *
646 * TclpChdir --
647 *
648 * This function replaces the library version of chdir().
649 *
650 * Results:
651 * See chdir() documentation.
652 *
653 * Side effects:
654 * See chdir() documentation.
655 *
656 *----------------------------------------------------------------------
657 */
658
659 int
660 TclpChdir(path)
661 CONST char *path; /* Path to new working directory (UTF-8). */
662 {
663 int result;
664 Tcl_DString ds;
665 TCHAR *nativePath;
666
667 nativePath = Tcl_WinUtfToTChar(path, -1, &ds);
668 result = (*tclWinProcs->setCurrentDirectoryProc)(nativePath);
669 Tcl_DStringFree(&ds);
670
671 if (result == 0) {
672 TclWinConvertError(GetLastError());
673 return -1;
674 }
675 return 0;
676 }
677
678 /*
679 *----------------------------------------------------------------------
680 *
681 * TclpGetCwd --
682 *
683 * This function replaces the library version of getcwd().
684 *
685 * Results:
686 * The result is a pointer to a string specifying the current
687 * directory, or NULL if the current directory could not be
688 * determined. If NULL is returned, an error message is left in the
689 * interp's result. Storage for the result string is allocated in
690 * bufferPtr; the caller must call Tcl_DStringFree() when the result
691 * is no longer needed.
692 *
693 * Side effects:
694 * None.
695 *
696 *----------------------------------------------------------------------
697 */
698
699 char *
700 TclpGetCwd(interp, bufferPtr)
701 Tcl_Interp *interp; /* If non-NULL, used for error reporting. */
702 Tcl_DString *bufferPtr; /* Uninitialized or free DString filled
703 * with name of current directory. */
704 {
705 WCHAR buffer[MAX_PATH];
706 char *p;
707
708 if ((*tclWinProcs->getCurrentDirectoryProc)(MAX_PATH, buffer) == 0) {
709 TclWinConvertError(GetLastError());
710 if (interp != NULL) {
711 Tcl_AppendResult(interp,
712 "error getting working directory name: ",
713 Tcl_PosixError(interp), (char *) NULL);
714 }
715 return NULL;
716 }
717
718 /*
719 * Watch for the wierd Windows c:\\UNC syntax.
720 */
721
722 if (tclWinProcs->useWide) {
723 WCHAR *native;
724
725 native = (WCHAR *) buffer;
726 if ((native[0] != '\0') && (native[1] == ':')
727 && (native[2] == '\\') && (native[3] == '\\')) {
728 native += 2;
729 }
730 Tcl_WinTCharToUtf((TCHAR *) native, -1, bufferPtr);
731 } else {
732 char *native;
733
734 native = (char *) buffer;
735 if ((native[0] != '\0') && (native[1] == ':')
736 && (native[2] == '\\') && (native[3] == '\\')) {
737 native += 2;
738 }
739 Tcl_WinTCharToUtf((TCHAR *) native, -1, bufferPtr);
740 }
741
742 /*
743 * Convert to forward slashes for easier use in scripts.
744 */
745
746 for (p = Tcl_DStringValue(bufferPtr); *p != '\0'; p++) {
747 if (*p == '\\') {
748 *p = '/';
749 }
750 }
751 return Tcl_DStringValue(bufferPtr);
752 }
753
754 /*
755 *----------------------------------------------------------------------
756 *
757 * TclpStat --
758 *
759 * This function replaces the library version of stat(), fixing
760 * the following bugs:
761 *
762 * 1. stat("c:") returns an error.
763 * 2. Borland stat() return time in GMT instead of localtime.
764 * 3. stat("\\server\mount") would return error.
765 * 4. Accepts slashes or backslashes.
766 * 5. st_dev and st_rdev were wrong for UNC paths.
767 *
768 * Results:
769 * See stat documentation.
770 *
771 * Side effects:
772 * See stat documentation.
773 *
774 *----------------------------------------------------------------------
775 */
776
777 int
778 TclpStat(path, statPtr)
779 CONST char *path; /* Path of file to stat (UTF-8). */
780 struct stat *statPtr; /* Filled with results of stat call. */
781 {
782 Tcl_DString ds;
783 TCHAR *nativePath;
784 WIN32_FIND_DATAT data;
785 HANDLE handle;
786 DWORD attr;
787 WCHAR nativeFullPath[MAX_PATH];
788 TCHAR *nativePart;
789 char *p, *fullPath;
790 int dev, mode;
791
792 /*
793 * Eliminate file names containing wildcard characters, or subsequent
794 * call to FindFirstFile() will expand them, matching some other file.
795 */
796
797 if (strpbrk(path, "?*") != NULL) {
798 Tcl_SetErrno(ENOENT);
799 return -1;
800 }
801
802 nativePath = Tcl_WinUtfToTChar(path, -1, &ds);
803 handle = (*tclWinProcs->findFirstFileProc)(nativePath, &data);
804 if (handle == INVALID_HANDLE_VALUE) {
805 /*
806 * FindFirstFile() doesn't work on root directories, so call
807 * GetFileAttributes() to see if the specified file exists.
808 */
809
810 attr = (*tclWinProcs->getFileAttributesProc)(nativePath);
811 if (attr == 0xffffffff) {
812 Tcl_DStringFree(&ds);
813 Tcl_SetErrno(ENOENT);
814 return -1;
815 }
816
817 /*
818 * Make up some fake information for this file. It has the
819 * correct file attributes and a time of 0.
820 */
821
822 memset(&data, 0, sizeof(data));
823 data.a.dwFileAttributes = attr;
824 } else {
825 FindClose(handle);
826 }
827
828 (*tclWinProcs->getFullPathNameProc)(nativePath, MAX_PATH, nativeFullPath,
829 &nativePart);
830
831 Tcl_DStringFree(&ds);
832 fullPath = Tcl_WinTCharToUtf((TCHAR *) nativeFullPath, -1, &ds);
833
834 dev = -1;
835 if ((fullPath[0] == '\\') && (fullPath[1] == '\\')) {
836 char *p;
837 DWORD dw;
838 TCHAR *nativeVol;
839 Tcl_DString volString;
840
841 p = strchr(fullPath + 2, '\\');
842 p = strchr(p + 1, '\\');
843 if (p == NULL) {
844 /*
845 * Add terminating backslash to fullpath or
846 * GetVolumeInformation() won't work.
847 */
848
849 fullPath = Tcl_DStringAppend(&ds, "\\", 1);
850 p = fullPath + Tcl_DStringLength(&ds);
851 } else {
852 p++;
853 }
854 nativeVol = Tcl_WinUtfToTChar(fullPath, p - fullPath, &volString);
855 dw = (DWORD) -1;
856 (*tclWinProcs->getVolumeInformationProc)(nativeVol, NULL, 0, &dw,
857 NULL, NULL, NULL, 0);
858 /*
859 * GetFullPathName() turns special devices like "NUL" into "\\.\NUL",
860 * but GetVolumeInformation() returns failure for "\\.\NUL". This
861 * will cause "NUL" to get a drive number of -1, which makes about
862 * as much sense as anything since the special devices don't live on
863 * any drive.
864 */
865
866 dev = dw;
867 Tcl_DStringFree(&volString);
868 } else if ((fullPath[0] != '\0') && (fullPath[1] == ':')) {
869 dev = Tcl_UniCharToLower(fullPath[0]) - 'a';
870 }
871 Tcl_DStringFree(&ds);
872
873 attr = data.a.dwFileAttributes;
874 mode = (attr & FILE_ATTRIBUTE_DIRECTORY) ? S_IFDIR | S_IEXEC : S_IFREG;
875 mode |= (attr & FILE_ATTRIBUTE_READONLY) ? S_IREAD : S_IREAD | S_IWRITE;
876 p = strrchr(path, '.');
877 if (p != NULL) {
878 if ((lstrcmpiA(p, ".exe") == 0)
879 || (lstrcmpiA(p, ".com") == 0)
880 || (lstrcmpiA(p, ".bat") == 0)
881 || (lstrcmpiA(p, ".pif") == 0)) {
882 mode |= S_IEXEC;
883 }
884 }
885
886 /*
887 * Propagate the S_IREAD, S_IWRITE, S_IEXEC bits to the group and
888 * other positions.
889 */
890
891 mode |= (mode & 0x0700) >> 3;
892 mode |= (mode & 0x0700) >> 6;
893
894 statPtr->st_dev = (dev_t) dev;
895 statPtr->st_ino = 0;
896 statPtr->st_mode = (unsigned short) mode;
897 statPtr->st_nlink = 1;
898 statPtr->st_uid = 0;
899 statPtr->st_gid = 0;
900 statPtr->st_rdev = (dev_t) dev;
901 statPtr->st_size = data.a.nFileSizeLow;
902 statPtr->st_atime = ToCTime(data.a.ftLastAccessTime);
903 statPtr->st_mtime = ToCTime(data.a.ftLastWriteTime);
904 statPtr->st_ctime = ToCTime(data.a.ftCreationTime);
905 return 0;
906 }
907
908 static time_t
909 ToCTime(
910 FILETIME fileTime) /* UTC Time to convert to local time_t. */
911 {
912 FILETIME localFileTime;
913 SYSTEMTIME systemTime;
914 struct tm tm;
915
916 if (FileTimeToLocalFileTime(&fileTime, &localFileTime) == 0) {
917 return 0;
918 }
919 if (FileTimeToSystemTime(&localFileTime, &systemTime) == 0) {
920 return 0;
921 }
922 tm.tm_sec = systemTime.wSecond;
923 tm.tm_min = systemTime.wMinute;
924 tm.tm_hour = systemTime.wHour;
925 tm.tm_mday = systemTime.wDay;
926 tm.tm_mon = systemTime.wMonth - 1;
927 tm.tm_year = systemTime.wYear - 1900;
928 tm.tm_wday = 0;
929 tm.tm_yday = 0;
930 tm.tm_isdst = -1;
931
932 return mktime(&tm);
933 }
934
935 #if 0
936
937 /*
938 * Borland's stat doesn't take into account localtime.
939 */
940
941 if ((result == 0) && (buf->st_mtime != 0)) {
942 TIME_ZONE_INFORMATION tz;
943 int time, bias;
944
945 time = GetTimeZoneInformation(&tz);
946 bias = tz.Bias;
947 if (time == TIME_ZONE_ID_DAYLIGHT) {
948 bias += tz.DaylightBias;
949 }
950 bias *= 60;
951 buf->st_atime -= bias;
952 buf->st_ctime -= bias;
953 buf->st_mtime -= bias;
954 }
955
956 #endif
957
958
959 #if 0
960 /*
961 *-------------------------------------------------------------------------
962 *
963 * TclWinResolveShortcut --
964 *
965 * Resolve a potential Windows shortcut to get the actual file or
966 * directory in question.
967 *
968 * Results:
969 * Returns 1 if the shortcut could be resolved, or 0 if there was
970 * an error or if the filename was not a shortcut.
971 * If bufferPtr did hold the name of a shortcut, it is modified to
972 * hold the resolved target of the shortcut instead.
973 *
974 * Side effects:
975 * Loads and unloads OLE package to determine if filename refers to
976 * a shortcut.
977 *
978 *-------------------------------------------------------------------------
979 */
980
981 int
982 TclWinResolveShortcut(bufferPtr)
983 Tcl_DString *bufferPtr; /* Holds name of file to resolve. On
984 * return, holds resolved file name. */
985 {
986 HRESULT hres;
987 IShellLink *psl;
988 IPersistFile *ppf;
989 WIN32_FIND_DATA wfd;
990 WCHAR wpath[MAX_PATH];
991 char *path, *ext;
992 char realFileName[MAX_PATH];
993
994 /*
995 * Windows system calls do not automatically resolve
996 * shortcuts like UNIX automatically will with symbolic links.
997 */
998
999 path = Tcl_DStringValue(bufferPtr);
1000 ext = strrchr(path, '.');
1001 if ((ext == NULL) || (stricmp(ext, ".lnk") != 0)) {
1002 return 0;
1003 }
1004
1005 CoInitialize(NULL);
1006 path = Tcl_DStringValue(bufferPtr);
1007 realFileName[0] = '\0';
1008 hres = CoCreateInstance(&CLSID_ShellLink, NULL, CLSCTX_INPROC_SERVER,
1009 &IID_IShellLink, &psl);
1010 if (SUCCEEDED(hres)) {
1011 hres = psl->lpVtbl->QueryInterface(psl, &IID_IPersistFile, &ppf);
1012 if (SUCCEEDED(hres)) {
1013 MultiByteToWideChar(CP_ACP, 0, path, -1, wpath, sizeof(wpath));
1014 hres = ppf->lpVtbl->Load(ppf, wpath, STGM_READ);
1015 if (SUCCEEDED(hres)) {
1016 hres = psl->lpVtbl->Resolve(psl, NULL,
1017 SLR_ANY_MATCH | SLR_NO_UI);
1018 if (SUCCEEDED(hres)) {
1019 hres = psl->lpVtbl->GetPath(psl, realFileName, MAX_PATH,
1020 &wfd, 0);
1021 }
1022 }
1023 ppf->lpVtbl->Release(ppf);
1024 }
1025 psl->lpVtbl->Release(psl);
1026 }
1027 CoUninitialize();
1028
1029 if (realFileName[0] != '\0') {
1030 Tcl_DStringSetLength(bufferPtr, 0);
1031 Tcl_DStringAppend(bufferPtr, realFileName, -1);
1032 return 1;
1033 }
1034 return 0;
1035 }
1036 #endif
1037
1038
1039 /* $History: tclwinfile.c $
1040 *
1041 * ***************** Version 1 *****************
1042 * User: Dtashley Date: 1/02/01 Time: 12:39a
1043 * Created in $/IjuScripter, IjuConsole/Source/Tcl Base
1044 * Initial check-in.
1045 */
1046
1047 /* End of TCLWINFILE.C */

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25