/[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 29 - (hide annotations) (download)
Sat Oct 8 07:08:47 2016 UTC (6 years, 5 months ago) by dashley
Original Path: to_be_filed/sf_code/esrgpcpj/shared/tcl_base/tclwinfile.c
File MIME type: text/plain
File size: 29194 byte(s)
Directories relocated.
1 dashley 25 /* $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