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

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

Parent Directory Parent Directory | Revision Log Revision Log


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

Properties

Name Value
svn:keywords Header

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25