tcl/win/tclWinFile.c

   1 /*
   2  * tclWinFile.c --
   3  *
   4  *      This file contains temporary wrappers around UNIX file handling
   5  *      functions. These wrappers map the UNIX functions to Win32 HANDLE-style
   6  *      files, which can be manipulated through the Win32 console redirection
   7  *      interfaces.
   8  *
   9  * Copyright (c) 1995-1998 Sun Microsystems, Inc.
  10  *
  11  * See the file "license.terms" for information on usage and redistribution
  12  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  13  *
  14  * RCS: @(#) $Id$
  15  */
  16
  17 //#define _WIN32_WINNT  0x0500
  18
  19 #include "tclWinInt.h"
  20 #include <winioctl.h>
  21 #include <sys/stat.h>
  22 #include <shlobj.h>
  23 #include <lmaccess.h>           /* For TclpGetUserHome(). */
  24
  25 /*
  26  * Declarations for 'link' related information.  This information
  27  * should come with VC++ 6.0, but is not in some older SDKs.
  28  * In any case it is not well documented.
  29  */
  30 #ifndef IO_REPARSE_TAG_RESERVED_ONE
  31 #  define IO_REPARSE_TAG_RESERVED_ONE 0x000000001
  32 #endif
  33 #ifndef IO_REPARSE_TAG_RESERVED_RANGE
  34 #  define IO_REPARSE_TAG_RESERVED_RANGE 0x000000001
  35 #endif
  36 #ifndef IO_REPARSE_TAG_VALID_VALUES
  37 #  define IO_REPARSE_TAG_VALID_VALUES 0x0E000FFFF
  38 #endif
  39 #ifndef IO_REPARSE_TAG_HSM
  40 #  define IO_REPARSE_TAG_HSM 0x0C0000004
  41 #endif
  42 #ifndef IO_REPARSE_TAG_NSS
  43 #  define IO_REPARSE_TAG_NSS 0x080000005
  44 #endif
  45 #ifndef IO_REPARSE_TAG_NSSRECOVER
  46 #  define IO_REPARSE_TAG_NSSRECOVER 0x080000006
  47 #endif
  48 #ifndef IO_REPARSE_TAG_SIS
  49 #  define IO_REPARSE_TAG_SIS 0x080000007
  50 #endif
  51 #ifndef IO_REPARSE_TAG_DFS
  52 #  define IO_REPARSE_TAG_DFS 0x080000008
  53 #endif
  54
  55 #ifndef IO_REPARSE_TAG_RESERVED_ZERO
  56 #  define IO_REPARSE_TAG_RESERVED_ZERO 0x00000000
  57 #endif
  58 #ifndef FILE_FLAG_OPEN_REPARSE_POINT
  59 #  define FILE_FLAG_OPEN_REPARSE_POINT 0x00200000
  60 #endif
  61 #ifndef IO_REPARSE_TAG_MOUNT_POINT
  62 #  define IO_REPARSE_TAG_MOUNT_POINT 0xA0000003
  63 #endif
  64 #ifndef IsReparseTagValid
  65 #  define IsReparseTagValid(x) (!((x)&~IO_REPARSE_TAG_VALID_VALUES)&&((x)>IO_REPARSE_TAG_RESERVED_RANGE))
  66 #endif
  67 #ifndef IO_REPARSE_TAG_SYMBOLIC_LINK
  68 #  define IO_REPARSE_TAG_SYMBOLIC_LINK IO_REPARSE_TAG_RESERVED_ZERO
  69 #endif
  70 #ifndef FILE_SPECIAL_ACCESS
  71 #  define FILE_SPECIAL_ACCESS         (FILE_ANY_ACCESS)
  72 #endif
  73 #ifndef FSCTL_SET_REPARSE_POINT
  74 #  define FSCTL_SET_REPARSE_POINT    CTL_CODE(FILE_DEVICE_FILE_SYSTEM, 41, METHOD_BUFFERED, FILE_SPECIAL_ACCESS)
  75 #  define FSCTL_GET_REPARSE_POINT    CTL_CODE(FILE_DEVICE_FILE_SYSTEM, 42, METHOD_BUFFERED, FILE_ANY_ACCESS)
  76 #  define FSCTL_DELETE_REPARSE_POINT CTL_CODE(FILE_DEVICE_FILE_SYSTEM, 43, METHOD_BUFFERED, FILE_SPECIAL_ACCESS)
  77 #endif
  78
  79 /*
  80  * Maximum reparse buffer info size. The max user defined reparse
  81  * data is 16KB, plus there's a header.
  82  */
  83
  84 #define MAX_REPARSE_SIZE        17000
  85
  86 /*
  87  * Undocumented REPARSE_MOUNTPOINT_HEADER_SIZE structure definition.
  88  * This is found in winnt.h.
  89  *
  90  * IMPORTANT: caution when using this structure, since the actual
  91  * structures used will want to store a full path in the 'PathBuffer'
  92  * field, but there isn't room (there's only a single WCHAR!).  Therefore
  93  * one must artificially create a larger space of memory and then cast it
  94  * to this type.  We use the 'DUMMY_REPARSE_BUFFER' struct just below to
  95  * deal with this problem.
  96  */
  97
  98 #define REPARSE_MOUNTPOINT_HEADER_SIZE   8
  99 #ifndef REPARSE_DATA_BUFFER_HEADER_SIZE
 100 typedef struct _REPARSE_DATA_BUFFER {
 101     DWORD  ReparseTag;
 102     WORD   ReparseDataLength;
 103     WORD   Reserved;
 104     union {
 105         struct {
 106             WORD   SubstituteNameOffset;
 107             WORD   SubstituteNameLength;
 108             WORD   PrintNameOffset;
 109             WORD   PrintNameLength;
 110             WCHAR PathBuffer[1];
 111         } SymbolicLinkReparseBuffer;
 112         struct {
 113             WORD   SubstituteNameOffset;
 114             WORD   SubstituteNameLength;
 115             WORD   PrintNameOffset;
 116             WORD   PrintNameLength;
 117             WCHAR PathBuffer[1];
 118         } MountPointReparseBuffer;
 119         struct {
 120             BYTE   DataBuffer[1];
 121         } GenericReparseBuffer;
 122     };
 123 } REPARSE_DATA_BUFFER;
 124 #endif
 125
 126 typedef struct {
 127     REPARSE_DATA_BUFFER dummy;
 128     WCHAR  dummyBuf[MAX_PATH*3];
 129 } DUMMY_REPARSE_BUFFER;
 130
 131 /* Other typedefs required by this code */
 132
 133 static time_t           ToCTime(FILETIME fileTime);
 134
 135 typedef NET_API_STATUS NET_API_FUNCTION NETUSERGETINFOPROC
 136         (LPWSTR servername, LPWSTR username, DWORD level, LPBYTE *bufptr);
 137
 138 typedef NET_API_STATUS NET_API_FUNCTION NETAPIBUFFERFREEPROC
 139         (LPVOID Buffer);
 140
 141 typedef NET_API_STATUS NET_API_FUNCTION NETGETDCNAMEPROC
 142         (LPWSTR servername, LPWSTR domainname, LPBYTE *bufptr);
 143
 144 /*
 145  * Declarations for local procedures defined in this file:
 146  */
 147
 148 static int NativeAccess(CONST TCHAR *path, int mode);
 149 static int NativeStat(CONST TCHAR *path, Tcl_StatBuf *statPtr, int checkLinks);
 150 static int NativeIsExec(CONST TCHAR *path);
 151 static int NativeReadReparse(CONST TCHAR* LinkDirectory,
 152                              REPARSE_DATA_BUFFER* buffer);
 153 static int NativeWriteReparse(CONST TCHAR* LinkDirectory,
 154                               REPARSE_DATA_BUFFER* buffer);
 155 static int NativeMatchType(CONST char *name, int nameLen,
 156                            CONST TCHAR* nativeName, Tcl_GlobTypeData *types);
 157 static int WinIsDrive(CONST char *name, int nameLen);
 158 static Tcl_Obj* WinReadLink(CONST TCHAR* LinkSource);
 159 static Tcl_Obj* WinReadLinkDirectory(CONST TCHAR* LinkDirectory);
 160 static int WinLink(CONST TCHAR* LinkSource, CONST TCHAR* LinkTarget,
 161                    int linkAction);
 162 static int WinSymLinkDirectory(CONST TCHAR* LinkDirectory,
 163                                CONST TCHAR* LinkTarget);
 164
 165 \f
 166 /*
 167  *--------------------------------------------------------------------
 168  *
 169  * WinLink
 170  *
 171  * Make a link from source to target.
 172  *--------------------------------------------------------------------
 173  */
 174 static int
 175 WinLink(LinkSource, LinkTarget, linkAction)
 176     CONST TCHAR* LinkSource;
 177     CONST TCHAR* LinkTarget;
 178     int linkAction;
 179 {
 180     WCHAR       tempFileName[MAX_PATH];
 181     TCHAR*      tempFilePart;
 182     int         attr;
 183
 184     /* Get the full path referenced by the target */
 185     if (!(*tclWinProcs->getFullPathNameProc)(LinkTarget,
 186                           MAX_PATH, tempFileName, &tempFilePart)) {
 187         /* Invalid file */
 188         TclWinConvertError(GetLastError());
 189         return -1;
 190     }
 191
 192     /* Make sure source file doesn't exist */
 193     attr = (*tclWinProcs->getFileAttributesProc)(LinkSource);
 194     if (attr != 0xffffffff) {
 195         Tcl_SetErrno(EEXIST);
 196         return -1;
 197     }
 198
 199     /* Get the full path referenced by the directory */
 200     if (!(*tclWinProcs->getFullPathNameProc)(LinkSource,
 201                           MAX_PATH, tempFileName, &tempFilePart)) {
 202         /* Invalid file */
 203         TclWinConvertError(GetLastError());
 204         return -1;
 205     }
 206     /* Check the target */
 207     attr = (*tclWinProcs->getFileAttributesProc)(LinkTarget);
 208     if (attr == 0xffffffff) {
 209         /* The target doesn't exist */
 210         TclWinConvertError(GetLastError());
 211         return -1;
 212     } else if ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0) {
 213         /* It is a file */
 214         if (tclWinProcs->createHardLinkProc == NULL) {
 215             Tcl_SetErrno(ENOTDIR);
 216             return -1;
 217         }
 218         if (linkAction & TCL_CREATE_HARD_LINK) {
 219             if (!(*tclWinProcs->createHardLinkProc)(LinkSource, LinkTarget, NULL)) {
 220                 TclWinConvertError(GetLastError());
 221                 return -1;
 222             }
 223             return 0;
 224         } else if (linkAction & TCL_CREATE_SYMBOLIC_LINK) {
 225             /* Can't symlink files */
 226             Tcl_SetErrno(ENOTDIR);
 227             return -1;
 228         } else {
 229             Tcl_SetErrno(ENODEV);
 230             return -1;
 231         }
 232     } else {
 233         if (linkAction & TCL_CREATE_SYMBOLIC_LINK) {
 234             return WinSymLinkDirectory(LinkSource, LinkTarget);
 235         } else if (linkAction & TCL_CREATE_HARD_LINK) {
 236             /* Can't hard link directories */
 237             Tcl_SetErrno(EISDIR);
 238             return -1;
 239         } else {
 240             Tcl_SetErrno(ENODEV);
 241             return -1;
 242         }
 243     }
 244 }
 245 \f
 246 /*
 247  *--------------------------------------------------------------------
 248  *
 249  * WinReadLink
 250  *
 251  * What does 'LinkSource' point to?  We need the original 'pathPtr'
 252  * just so we can construct a path object in the correct filesystem.
 253  *--------------------------------------------------------------------
 254  */
 255 static Tcl_Obj*
 256 WinReadLink(LinkSource)
 257     CONST TCHAR* LinkSource;
 258 {
 259     WCHAR       tempFileName[MAX_PATH];
 260     TCHAR*      tempFilePart;
 261     int         attr;
 262
 263     /* Get the full path referenced by the target */
 264     if (!(*tclWinProcs->getFullPathNameProc)(LinkSource,
 265                           MAX_PATH, tempFileName, &tempFilePart)) {
 266         /* Invalid file */
 267         TclWinConvertError(GetLastError());
 268         return NULL;
 269     }
 270
 271     /* Make sure source file does exist */
 272     attr = (*tclWinProcs->getFileAttributesProc)(LinkSource);
 273     if (attr == 0xffffffff) {
 274         /* The source doesn't exist */
 275         TclWinConvertError(GetLastError());
 276         return NULL;
 277     } else if ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0) {
 278         /* It is a file - this is not yet supported */
 279         Tcl_SetErrno(ENOTDIR);
 280         return NULL;
 281     } else {
 282         return WinReadLinkDirectory(LinkSource);
 283     }
 284 }
 285 \f
 286 /*
 287  *--------------------------------------------------------------------
 288  *
 289  * WinSymLinkDirectory
 290  *
 291  * This routine creates a NTFS junction, using the undocumented
 292  * FSCTL_SET_REPARSE_POINT structure Win2K uses for mount points
 293  * and junctions.
 294  *
 295  * Assumption that LinkTarget is a valid, existing directory.
 296  *
 297  * Returns zero on success.
 298  *--------------------------------------------------------------------
 299  */
 300 static int
 301 WinSymLinkDirectory(LinkDirectory, LinkTarget)
 302     CONST TCHAR* LinkDirectory;
 303     CONST TCHAR* LinkTarget;
 304 {
 305     DUMMY_REPARSE_BUFFER dummy;
 306     REPARSE_DATA_BUFFER *reparseBuffer = (REPARSE_DATA_BUFFER*)&dummy;
 307     int         len;
 308     WCHAR       nativeTarget[MAX_PATH];
 309     WCHAR       *loop;
 310
 311     /* Make the native target name */
 312     memcpy((VOID*)nativeTarget, (VOID*)L"\\??\\", 4*sizeof(WCHAR));
 313     memcpy((VOID*)(nativeTarget + 4), (VOID*)LinkTarget,
 314            sizeof(WCHAR)*(1+wcslen((WCHAR*)LinkTarget)));
 315     len = wcslen(nativeTarget);
 316     /*
 317      * We must have backslashes only.  This is VERY IMPORTANT.
 318      * If we have any forward slashes everything appears to work,
 319      * but the resulting symlink is useless!
 320      */
 321     for (loop = nativeTarget; *loop != 0; loop++) {
 322         if (*loop == L'/') *loop = L'\\';
 323     }
 324     if ((nativeTarget[len-1] == L'\\') && (nativeTarget[len-2] != L':')) {
 325         nativeTarget[len-1] = 0;
 326     }
 327
 328     /* Build the reparse info */
 329     memset(reparseBuffer, 0, sizeof(DUMMY_REPARSE_BUFFER));
 330     reparseBuffer->ReparseTag = IO_REPARSE_TAG_MOUNT_POINT;
 331     reparseBuffer->SymbolicLinkReparseBuffer.SubstituteNameLength =
 332       wcslen(nativeTarget) * sizeof(WCHAR);
 333     reparseBuffer->Reserved = 0;
 334     reparseBuffer->SymbolicLinkReparseBuffer.PrintNameLength = 0;
 335     reparseBuffer->SymbolicLinkReparseBuffer.PrintNameOffset =
 336       reparseBuffer->SymbolicLinkReparseBuffer.SubstituteNameLength
 337       + sizeof(WCHAR);
 338     memcpy(reparseBuffer->SymbolicLinkReparseBuffer.PathBuffer, nativeTarget,
 339       sizeof(WCHAR)
 340       + reparseBuffer->SymbolicLinkReparseBuffer.SubstituteNameLength);
 341     reparseBuffer->ReparseDataLength =
 342       reparseBuffer->SymbolicLinkReparseBuffer.SubstituteNameLength + 12;
 343
 344     return NativeWriteReparse(LinkDirectory, reparseBuffer);
 345 }
 346 \f
 347 /*
 348  *--------------------------------------------------------------------
 349  *
 350  * TclWinSymLinkCopyDirectory
 351  *
 352  * Copy a Windows NTFS junction.  This function assumes that
 353  * LinkOriginal exists and is a valid junction point, and that
 354  * LinkCopy does not exist.
 355  *
 356  * Returns zero on success.
 357  *--------------------------------------------------------------------
 358  */
 359 int
 360 TclWinSymLinkCopyDirectory(LinkOriginal, LinkCopy)
 361     CONST TCHAR* LinkOriginal;  /* Existing junction - reparse point */
 362     CONST TCHAR* LinkCopy;      /* Will become a duplicate junction */
 363 {
 364     DUMMY_REPARSE_BUFFER dummy;
 365     REPARSE_DATA_BUFFER *reparseBuffer = (REPARSE_DATA_BUFFER*)&dummy;
 366
 367     if (NativeReadReparse(LinkOriginal, reparseBuffer)) {
 368         return -1;
 369     }
 370     return NativeWriteReparse(LinkCopy, reparseBuffer);
 371 }
 372 \f
 373 /*
 374  *--------------------------------------------------------------------
 375  *
 376  * TclWinSymLinkDelete
 377  *
 378  * Delete a Windows NTFS junction.  Once the junction information
 379  * is deleted, the filesystem object becomes an ordinary directory.
 380  * Unless 'linkOnly' is given, that directory is also removed.
 381  *
 382  * Assumption that LinkOriginal is a valid, existing junction.
 383  *
 384  * Returns zero on success.
 385  *--------------------------------------------------------------------
 386  */
 387 int
 388 TclWinSymLinkDelete(LinkOriginal, linkOnly)
 389     CONST TCHAR* LinkOriginal;
 390     int linkOnly;
 391 {
 392     /* It is a symbolic link -- remove it */
 393     DUMMY_REPARSE_BUFFER dummy;
 394     REPARSE_DATA_BUFFER *reparseBuffer = (REPARSE_DATA_BUFFER*)&dummy;
 395     HANDLE hFile;
 396     int returnedLength;
 397     memset(reparseBuffer, 0, sizeof(DUMMY_REPARSE_BUFFER));
 398     reparseBuffer->ReparseTag = IO_REPARSE_TAG_MOUNT_POINT;
 399     hFile = (*tclWinProcs->createFileProc)(LinkOriginal, GENERIC_WRITE, 0,
 400         NULL, OPEN_EXISTING,
 401         FILE_FLAG_OPEN_REPARSE_POINT|FILE_FLAG_BACKUP_SEMANTICS, NULL);
 402     if (hFile != INVALID_HANDLE_VALUE) {
 403         if (!DeviceIoControl(hFile, FSCTL_DELETE_REPARSE_POINT, reparseBuffer,
 404                              REPARSE_MOUNTPOINT_HEADER_SIZE,
 405                              NULL, 0, &returnedLength, NULL)) {
 406             /* Error setting junction */
 407             TclWinConvertError(GetLastError());
 408             CloseHandle(hFile);
 409         } else {
 410             CloseHandle(hFile);
 411             if (!linkOnly) {
 412                 (*tclWinProcs->removeDirectoryProc)(LinkOriginal);
 413             }
 414             return 0;
 415         }
 416     }
 417     return -1;
 418 }
 419 \f
 420 /*
 421  *--------------------------------------------------------------------
 422  *
 423  * WinReadLinkDirectory
 424  *
 425  * This routine reads a NTFS junction, using the undocumented
 426  * FSCTL_GET_REPARSE_POINT structure Win2K uses for mount points
 427  * and junctions.
 428  *
 429  * Assumption that LinkDirectory is a valid, existing directory.
 430  *
 431  * Returns a Tcl_Obj with refCount of 1 (i.e. owned by the caller).
 432  *--------------------------------------------------------------------
 433  */
 434 static Tcl_Obj*
 435 WinReadLinkDirectory(LinkDirectory)
 436     CONST TCHAR* LinkDirectory;
 437 {
 438     int attr;
 439     DUMMY_REPARSE_BUFFER dummy;
 440     REPARSE_DATA_BUFFER *reparseBuffer = (REPARSE_DATA_BUFFER*)&dummy;
 441
 442     attr = (*tclWinProcs->getFileAttributesProc)(LinkDirectory);
 443     if (!(attr & FILE_ATTRIBUTE_REPARSE_POINT)) {
 444         Tcl_SetErrno(EINVAL);
 445         return NULL;
 446     }
 447     if (NativeReadReparse(LinkDirectory, reparseBuffer)) {
 448         return NULL;
 449     }
 450
 451     switch (reparseBuffer->ReparseTag) {
 452         case 0x80000000|IO_REPARSE_TAG_SYMBOLIC_LINK:
 453         case IO_REPARSE_TAG_SYMBOLIC_LINK:
 454         case IO_REPARSE_TAG_MOUNT_POINT: {
 455             Tcl_Obj *retVal;
 456             Tcl_DString ds;
 457             CONST char *copy;
 458             int len;
 459
 460             Tcl_WinTCharToUtf(
 461                 (CONST char*)reparseBuffer->SymbolicLinkReparseBuffer.PathBuffer,
 462                 (int)reparseBuffer->SymbolicLinkReparseBuffer.SubstituteNameLength,
 463                 &ds);
 464
 465             copy = Tcl_DStringValue(&ds);
 466             len = Tcl_DStringLength(&ds);
 467             /*
 468              * Certain native path representations on Windows have this special
 469              * prefix to indicate that they are to be treated specially.  For
 470              * example extremely long paths, or symlinks
 471              */
 472             if (*copy == '\\') {
 473                 if (0 == strncmp(copy,"\\??\\",4)) {
 474                     copy += 4;
 475                     len -= 4;
 476                 } else if (0 == strncmp(copy,"\\\\?\\",4)) {
 477                     copy += 4;
 478                     len -= 4;
 479                 }
 480             }
 481             retVal = Tcl_NewStringObj(copy,len);
 482             Tcl_IncrRefCount(retVal);
 483             Tcl_DStringFree(&ds);
 484             return retVal;
 485         }
 486     }
 487     Tcl_SetErrno(EINVAL);
 488     return NULL;
 489 }
 490 \f
 491 /*
 492  *--------------------------------------------------------------------
 493  *
 494  * NativeReadReparse
 495  *
 496  * Read the junction/reparse information from a given NTFS directory.
 497  *
 498  * Assumption that LinkDirectory is a valid, existing directory.
 499  *
 500  * Returns zero on success.
 501  *--------------------------------------------------------------------
 502  */
 503 static int
 504 NativeReadReparse(LinkDirectory, buffer)
 505     CONST TCHAR* LinkDirectory;   /* The junction to read */
 506     REPARSE_DATA_BUFFER* buffer;  /* Pointer to buffer. Cannot be NULL */
 507 {
 508     HANDLE hFile;
 509     int returnedLength;
 510
 511     hFile = (*tclWinProcs->createFileProc)(LinkDirectory, GENERIC_READ, 0,
 512         NULL, OPEN_EXISTING,
 513         FILE_FLAG_OPEN_REPARSE_POINT|FILE_FLAG_BACKUP_SEMANTICS, NULL);
 514     if (hFile == INVALID_HANDLE_VALUE) {
 515         /* Error creating directory */
 516         TclWinConvertError(GetLastError());
 517         return -1;
 518     }
 519     /* Get the link */
 520     if (!DeviceIoControl(hFile, FSCTL_GET_REPARSE_POINT, NULL,
 521                          0, buffer, sizeof(DUMMY_REPARSE_BUFFER),
 522                          &returnedLength, NULL)) {
 523         /* Error setting junction */
 524         TclWinConvertError(GetLastError());
 525         CloseHandle(hFile);
 526         return -1;
 527     }
 528     CloseHandle(hFile);
 529
 530     if (!IsReparseTagValid(buffer->ReparseTag)) {
 531         Tcl_SetErrno(EINVAL);
 532         return -1;
 533     }
 534     return 0;
 535 }
 536 \f
 537 /*
 538  *--------------------------------------------------------------------
 539  *
 540  * NativeWriteReparse
 541  *
 542  * Write the reparse information for a given directory.
 543  *
 544  * Assumption that LinkDirectory does not exist.
 545  *--------------------------------------------------------------------
 546  */
 547 static int
 548 NativeWriteReparse(LinkDirectory, buffer)
 549     CONST TCHAR* LinkDirectory;
 550     REPARSE_DATA_BUFFER* buffer;
 551 {
 552     HANDLE hFile;
 553     int returnedLength;
 554
 555     /* Create the directory - it must not already exist */
 556     if ((*tclWinProcs->createDirectoryProc)(LinkDirectory, NULL) == 0) {
 557         /* Error creating directory */
 558         TclWinConvertError(GetLastError());
 559         return -1;
 560     }
 561     hFile = (*tclWinProcs->createFileProc)(LinkDirectory, GENERIC_WRITE, 0,
 562         NULL, OPEN_EXISTING,
 563         FILE_FLAG_OPEN_REPARSE_POINT|FILE_FLAG_BACKUP_SEMANTICS, NULL);
 564     if (hFile == INVALID_HANDLE_VALUE) {
 565         /* Error creating directory */
 566         TclWinConvertError(GetLastError());
 567         return -1;
 568     }
 569     /* Set the link */
 570     if (!DeviceIoControl(hFile, FSCTL_SET_REPARSE_POINT, buffer,
 571                          buffer->ReparseDataLength
 572                          + REPARSE_MOUNTPOINT_HEADER_SIZE,
 573                          NULL, 0, &returnedLength, NULL)) {
 574         /* Error setting junction */
 575         TclWinConvertError(GetLastError());
 576         CloseHandle(hFile);
 577         (*tclWinProcs->removeDirectoryProc)(LinkDirectory);
 578         return -1;
 579     }
 580     CloseHandle(hFile);
 581     /* We succeeded */
 582     return 0;
 583 }
 584 \f
 585 /*
 586  *---------------------------------------------------------------------------
 587  *
 588  * TclpFindExecutable --
 589  *
 590  *      This procedure computes the absolute path name of the current
 591  *      application, given its argv[0] value.
 592  *
 593  * Results:
 594  *      A dirty UTF string that is the path to the executable.  At this
 595  *      point we may not know the system encoding.  Convert the native
 596  *      string value to UTF using the default encoding.  The assumption
 597  *      is that we will still be able to parse the path given the path
 598  *      name contains ASCII string and '/' chars do not conflict with
 599  *      other UTF chars.
 600  *
 601  * Side effects:
 602  *      The variable tclNativeExecutableName gets filled in with the file
 603  *      name for the application, if we figured it out.  If we couldn't
 604  *      figure it out, tclNativeExecutableName is set to NULL.
 605  *
 606  *---------------------------------------------------------------------------
 607  */
 608
 609 char *
 610 TclpFindExecutable(argv0)
 611     CONST char *argv0;          /* The value of the application's argv[0]
 612                                  * (native). */
 613 {
 614     Tcl_DString ds;
 615     WCHAR wName[MAX_PATH];
 616
 617     if (argv0 == NULL) {
 618         return NULL;
 619     }
 620     if (tclNativeExecutableName != NULL) {
 621         return tclNativeExecutableName;
 622     }
 623
 624     /*
 625      * Under Windows we ignore argv0, and return the path for the file used to
 626      * create this process.
 627      */
 628
 629     (*tclWinProcs->getModuleFileNameProc)(NULL, wName, MAX_PATH);
 630     Tcl_WinTCharToUtf((CONST TCHAR *) wName, -1, &ds);
 631
 632     tclNativeExecutableName = ckalloc((unsigned) (Tcl_DStringLength(&ds) + 1));
 633     strcpy(tclNativeExecutableName, Tcl_DStringValue(&ds));
 634     Tcl_DStringFree(&ds);
 635
 636     TclWinNoBackslash(tclNativeExecutableName);
 637     return tclNativeExecutableName;
 638 }
 639 \f
 640 /*
 641  *----------------------------------------------------------------------
 642  *
 643  * TclpMatchInDirectory --
 644  *
 645  *      This routine is used by the globbing code to search a
 646  *      directory for all files which match a given pattern.
 647  *
 648  * Results:
 649  *
 650  *      The return value is a standard Tcl result indicating whether an
 651  *      error occurred in globbing.  Errors are left in interp, good
 652  *      results are lappended to resultPtr (which must be a valid object)
 653  *
 654  * Side effects:
 655  *      None.
 656  *
 657  *---------------------------------------------------------------------- */
 658
 659 int
 660 TclpMatchInDirectory(interp, resultPtr, pathPtr, pattern, types)
 661     Tcl_Interp *interp;         /* Interpreter to receive errors. */
 662     Tcl_Obj *resultPtr;         /* List object to lappend results. */
 663     Tcl_Obj *pathPtr;           /* Contains path to directory to search. */
 664     CONST char *pattern;        /* Pattern to match against. */
 665     Tcl_GlobTypeData *types;    /* Object containing list of acceptable types.
 666                                  * May be NULL. In particular the directory
 667                                  * flag is very important. */
 668 {
 669     CONST TCHAR *nativeName;
 670
 671     if (pattern == NULL || (*pattern == '\0')) {
 672         Tcl_Obj *norm = Tcl_FSGetNormalizedPath(NULL, pathPtr);
 673         if (norm != NULL) {
 674             int len;
 675             char *str = Tcl_GetStringFromObj(norm,&len);
 676             /* Match a file directly */
 677             nativeName = (CONST TCHAR*) Tcl_FSGetNativePath(pathPtr);
 678             if (NativeMatchType(str, len, nativeName, types)) {
 679                 Tcl_ListObjAppendElement(interp, resultPtr, pathPtr);
 680             }
 681         }
 682         return TCL_OK;
 683     } else {
 684         char drivePat[] = "?:\\";
 685         const char *message;
 686         CONST char *dir;
 687         char *root;
 688         int dirLength;
 689         Tcl_DString dirString;
 690         DWORD attr, volFlags;
 691         HANDLE handle;
 692         WIN32_FIND_DATAT data;
 693         BOOL found;
 694         Tcl_DString ds;
 695         Tcl_DString dsOrig;
 696         Tcl_Obj *fileNamePtr;
 697         int matchSpecialDots;
 698
 699         /*
 700          * Convert the path to normalized form since some interfaces only
 701          * accept backslashes.  Also, ensure that the directory ends with a
 702          * separator character.
 703          */
 704
 705         fileNamePtr = Tcl_FSGetTranslatedPath(interp, pathPtr);
 706         if (fileNamePtr == NULL) {
 707             return TCL_ERROR;
 708         }
 709         Tcl_DStringInit(&dsOrig);
 710         Tcl_DStringAppend(&dsOrig, Tcl_GetString(fileNamePtr), -1);
 711
 712         dirLength = Tcl_DStringLength(&dsOrig);
 713         Tcl_DStringInit(&dirString);
 714         if (dirLength == 0) {
 715             Tcl_DStringAppend(&dirString, ".\\", 2);
 716         } else {
 717             char *p;
 718
 719             Tcl_DStringAppend(&dirString, Tcl_DStringValue(&dsOrig),
 720                     Tcl_DStringLength(&dsOrig));
 721             for (p = Tcl_DStringValue(&dirString); *p != '\0'; p++) {
 722                 if (*p == '/') {
 723                     *p = '\\';
 724                 }
 725             }
 726             p--;
 727             /* Make sure we have a trailing directory delimiter */
 728             if ((*p != '\\') && (*p != ':')) {
 729                 Tcl_DStringAppend(&dirString, "\\", 1);
 730                 Tcl_DStringAppend(&dsOrig, "/", 1);
 731                 dirLength++;
 732             }
 733         }
 734         dir = Tcl_DStringValue(&dirString);
 735
 736         /*
 737          * First verify that the specified path is actually a directory.
 738          */
 739
 740         nativeName = Tcl_WinUtfToTChar(dir, Tcl_DStringLength(&dirString), &ds);
 741         attr = (*tclWinProcs->getFileAttributesProc)(nativeName);
 742         Tcl_DStringFree(&ds);
 743
 744         if ((attr == 0xffffffff) || ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0)) {
 745             Tcl_DStringFree(&dirString);
 746             return TCL_OK;
 747         }
 748
 749         /*
 750          * Next check the volume information for the directory to see
 751          * whether comparisons should be case sensitive or not.  If the
 752          * root is null, then we use the root of the current directory.
 753          * If the root is just a drive specifier, we use the root
 754          * directory of the given drive.
 755          */
 756
 757         switch (Tcl_GetPathType(dir)) {
 758             case TCL_PATH_RELATIVE:
 759                 found = GetVolumeInformationA(NULL, NULL, 0, NULL, NULL,
 760                         &volFlags, NULL, 0);
 761                 break;
 762             case TCL_PATH_VOLUME_RELATIVE:
 763                 if (dir[0] == '\\') {
 764                     root = NULL;
 765                 } else {
 766                     root = drivePat;
 767                     *root = dir[0];
 768                 }
 769                 found = GetVolumeInformationA(root, NULL, 0, NULL, NULL,
 770                         &volFlags, NULL, 0);
 771                 break;
 772             case TCL_PATH_ABSOLUTE:
 773                 if (dir[1] == ':') {
 774                     root = drivePat;
 775                     *root = dir[0];
 776                     found = GetVolumeInformationA(root, NULL, 0, NULL, NULL,
 777                             &volFlags, NULL, 0);
 778                 } else if (dir[1] == '\\') {
 779                     char *p;
 780
 781                     p = strchr(dir + 2, '\\');
 782                     p = strchr(p + 1, '\\');
 783                     p++;
 784                     nativeName = Tcl_WinUtfToTChar(dir, p - dir, &ds);
 785                     found = (*tclWinProcs->getVolumeInformationProc)(nativeName,
 786                             NULL, 0, NULL, NULL, &volFlags, NULL, 0);
 787                     Tcl_DStringFree(&ds);
 788                 }
 789                 break;
 790         }
 791
 792         if (found == 0) {
 793             message = "couldn't read volume information for \"";
 794             goto error;
 795         }
 796
 797         /*
 798          * Check to see if the pattern should match the special
 799          * . and .. names, referring to the current directory,
 800          * or the directory above.  We need a special check for
 801          * this because paths beginning with a dot are not considered
 802          * hidden on Windows, and so otherwise a relative glob like
 803          * 'glob -join * *' will actually return './. ../..' etc.
 804          */
 805
 806         if ((pattern[0] == '.')
 807                 || ((pattern[0] == '\\') && (pattern[1] == '.'))) {
 808             matchSpecialDots = 1;
 809         } else {
 810             matchSpecialDots = 0;
 811         }
 812
 813         /*
 814          * We need to check all files in the directory, so append a *.*
 815          * to the path.
 816          */
 817
 818         dir = Tcl_DStringAppend(&dirString, "*.*", 3);
 819         nativeName = Tcl_WinUtfToTChar(dir, -1, &ds);
 820         handle = (*tclWinProcs->findFirstFileProc)(nativeName, &data);
 821         Tcl_DStringFree(&ds);
 822
 823         if (handle == INVALID_HANDLE_VALUE) {
 824             message = "couldn't read directory \"";
 825             goto error;
 826         }
 827
 828         /*
 829          * Now iterate over all of the files in the directory.
 830          */
 831
 832         for (found = 1; found != 0;
 833                 found = (*tclWinProcs->findNextFileProc)(handle, &data)) {
 834             CONST TCHAR *nativeMatchResult;
 835             CONST char *name, *fname;
 836
 837             if (tclWinProcs->useWide) {
 838                 nativeName = (CONST TCHAR *) data.w.cFileName;
 839             } else {
 840                 nativeName = (CONST TCHAR *) data.a.cFileName;
 841             }
 842             name = Tcl_WinTCharToUtf(nativeName, -1, &ds);
 843
 844             if (!matchSpecialDots) {
 845                 /* If it is exactly '.' or '..' then we ignore it */
 846                 if (name[0] == '.') {
 847                     if (name[1] == '\0'
 848                       || (name[1] == '.' && name[2] == '\0')) {
 849                         continue;
 850                     }
 851                 }
 852             }
 853
 854             /*
 855              * Check to see if the file matches the pattern.  Note that
 856              * we are ignoring the case sensitivity flag because Windows
 857              * doesn't honor case even if the volume is case sensitive.
 858              * If the volume also doesn't preserve case, then we
 859              * previously returned the lower case form of the name.  This
 860              * didn't seem quite right since there are
 861              * non-case-preserving volumes that actually return mixed
 862              * case.  So now we are returning exactly what we get from
 863              * the system.
 864              */
 865
 866             nativeMatchResult = NULL;
 867
 868             if (Tcl_StringCaseMatch(name, pattern, 1) != 0) {
 869                 nativeMatchResult = nativeName;
 870             }
 871             Tcl_DStringFree(&ds);
 872
 873             if (nativeMatchResult == NULL) {
 874                 continue;
 875             }
 876
 877             /*
 878              * If the file matches, then we need to process the remainder
 879              * of the path.
 880              */
 881
 882             name = Tcl_WinTCharToUtf(nativeMatchResult, -1, &ds);
 883             Tcl_DStringAppend(&dsOrig, name, -1);
 884             Tcl_DStringFree(&ds);
 885
 886             fname = Tcl_DStringValue(&dsOrig);
 887             nativeName = Tcl_WinUtfToTChar(fname, Tcl_DStringLength(&dsOrig),
 888                                            &ds);
 889
 890             if (NativeMatchType(fname, Tcl_DStringLength(&dsOrig),
 891                                 nativeName, types)) {
 892                 Tcl_ListObjAppendElement(interp, resultPtr,
 893                         Tcl_NewStringObj(fname, Tcl_DStringLength(&dsOrig)));
 894             }
 895             /*
 896              * Free ds here to ensure that nativeName is valid above.
 897              */
 898
 899             Tcl_DStringFree(&ds);
 900
 901             Tcl_DStringSetLength(&dsOrig, dirLength);
 902         }
 903
 904         FindClose(handle);
 905         Tcl_DStringFree(&dirString);
 906         Tcl_DStringFree(&dsOrig);
 907
 908         return TCL_OK;
 909
 910         error:
 911         Tcl_DStringFree(&dirString);
 912         TclWinConvertError(GetLastError());
 913         Tcl_ResetResult(interp);
 914         Tcl_AppendResult(interp, message, Tcl_DStringValue(&dsOrig), "\": ",
 915                          Tcl_PosixError(interp), (char *) NULL);
 916                          Tcl_DStringFree(&dsOrig);
 917         return TCL_ERROR;
 918     }
 919
 920 }
 921 \f
 922 /*
 923  * Does the given path represent a root volume?  We need this special
 924  * case because for NTFS root volumes, the getFileAttributesProc returns
 925  * a 'hidden' attribute when it should not.
 926  */
 927 static int
 928 WinIsDrive(
 929     CONST char *name,     /* Name (UTF-8) */
 930     int len)              /* Length of name */
 931 {
 932     int remove = 0;
 933     while (len > 4) {
 934         if ((name[len-1] != '.' || name[len-2] != '.')
 935             || (name[len-3] != '/' && name[len-3] != '\\')) {
 936             /* We don't have '/..' at the end */
 937             if (remove == 0) {
 938                 break;
 939             }
 940             remove--;
 941             while (len > 0) {
 942                 len--;
 943                 if (name[len] == '/' || name[len] == '\\') {
 944                     break;
 945                 }
 946             }
 947             if (len < 4) {
 948                 len++;
 949                 break;
 950             }
 951         } else {
 952             /* We do have '/..' */
 953             len -= 3;
 954             remove++;
 955         }
 956     }
 957     if (len < 4) {
 958         if (len == 0) {
 959             /*
 960              * Not sure if this is possible, but we pass it on
 961              * anyway
 962              */
 963         } else if (len == 1 && (name[0] == '/' || name[0] == '\\')) {
 964             /* Path is pointing to the root volume */
 965             return 1;
 966         } else if ((name[1] == ':')
 967                    && (len == 2 || (name[2] == '/' || name[2] == '\\'))) {
 968             /* Path is of the form 'x:' or 'x:/' or 'x:\' */
 969             return 1;
 970         }
 971     }
 972     return 0;
 973 }
 974
 975 \f
 976 /*
 977  * This function needs a special case for a path which is a root
 978  * volume, because for NTFS root volumes, the getFileAttributesProc
 979  * returns a 'hidden' attribute when it should not.
 980  */
 981 static int
 982 NativeMatchType(
 983     CONST char *name,         /* Name */
 984     int nameLen,              /* Length of name */
 985     CONST TCHAR* nativeName,  /* Native path to check */
 986     Tcl_GlobTypeData *types)  /* Type description to match against */
 987 {
 988     /*
 989      * 'attr' represents the attributes of the file, but we only
 990      * want to retrieve this info if it is absolutely necessary
 991      * because it is an expensive call.  Unfortunately, to deal
 992      * with hidden files properly, we must always retrieve it.
 993      * There are more modern Win32 APIs available which we should
 994      * look into.
 995      */
 996
 997     DWORD attr = (*tclWinProcs->getFileAttributesProc)(nativeName);
 998     if (attr == 0xffffffff) {
 999         /* File doesn't exist */
1000         return 0;
1001     }
1002
1003     if (types == NULL) {
1004         /* If invisible, don't return the file */
1005         if (attr & FILE_ATTRIBUTE_HIDDEN && !WinIsDrive(name, nameLen)) {
1006             return 0;
1007         }
1008     } else {
1009         if (attr & FILE_ATTRIBUTE_HIDDEN && !WinIsDrive(name, nameLen)) {
1010             /* If invisible */
1011             if ((types->perm == 0) ||
1012               !(types->perm & TCL_GLOB_PERM_HIDDEN)) {
1013                 return 0;
1014             }
1015         } else {
1016             /* Visible */
1017             if (types->perm & TCL_GLOB_PERM_HIDDEN) {
1018                 return 0;
1019             }
1020         }
1021
1022         if (types->perm != 0) {
1023             if (
1024                 ((types->perm & TCL_GLOB_PERM_RONLY) &&
1025                         !(attr & FILE_ATTRIBUTE_READONLY)) ||
1026                 ((types->perm & TCL_GLOB_PERM_R) &&
1027                         (NativeAccess(nativeName, R_OK) != 0)) ||
1028                 ((types->perm & TCL_GLOB_PERM_W) &&
1029                         (NativeAccess(nativeName, W_OK) != 0)) ||
1030                 ((types->perm & TCL_GLOB_PERM_X) &&
1031                         (NativeAccess(nativeName, X_OK) != 0))
1032                 ) {
1033                 return 0;
1034             }
1035         }
1036         if (types->type != 0) {
1037             Tcl_StatBuf buf;
1038
1039             if (NativeStat(nativeName, &buf, 0) != 0) {
1040                 /*
1041                  * Posix error occurred, either the file
1042                  * has disappeared, or there is some other
1043                  * strange error.  In any case we don't
1044                  * return this file.
1045                  */
1046                 return 0;
1047             }
1048             /*
1049              * In order bcdpfls as in 'find -t'
1050              */
1051             if (
1052                 ((types->type & TCL_GLOB_TYPE_BLOCK) &&
1053                         S_ISBLK(buf.st_mode)) ||
1054                 ((types->type & TCL_GLOB_TYPE_CHAR) &&
1055                         S_ISCHR(buf.st_mode)) ||
1056                 ((types->type & TCL_GLOB_TYPE_DIR) &&
1057                         S_ISDIR(buf.st_mode)) ||
1058                 ((types->type & TCL_GLOB_TYPE_PIPE) &&
1059                         S_ISFIFO(buf.st_mode)) ||
1060                 ((types->type & TCL_GLOB_TYPE_FILE) &&
1061                         S_ISREG(buf.st_mode))
1062 #ifdef S_ISSOCK
1063                 || ((types->type & TCL_GLOB_TYPE_SOCK) &&
1064                         S_ISSOCK(buf.st_mode))
1065 #endif
1066                 ) {
1067                 /* Do nothing -- this file is ok */
1068             } else {
1069 #ifdef S_ISLNK
1070                 if (types->type & TCL_GLOB_TYPE_LINK) {
1071                     if (NativeStat(nativeName, &buf, 1) == 0) {
1072                         if (S_ISLNK(buf.st_mode)) {
1073                             return 1;
1074                         }
1075                     }
1076                 }
1077 #endif
1078                 return 0;
1079             }
1080         }
1081     }
1082     return 1;
1083 }
1084 \f
1085 /*
1086  *----------------------------------------------------------------------
1087  *
1088  * TclpGetUserHome --
1089  *
1090  *      This function takes the passed in user name and finds the
1091  *      corresponding home directory specified in the password file.
1092  *
1093  * Results:
1094  *      The result is a pointer to a string specifying the user's home
1095  *      directory, or NULL if the user's home directory could not be
1096  *      determined.  Storage for the result string is allocated in
1097  *      bufferPtr; the caller must call Tcl_DStringFree() when the result
1098  *      is no longer needed.
1099  *
1100  * Side effects:
1101  *      None.
1102  *
1103  *----------------------------------------------------------------------
1104  */
1105
1106 char *
1107 TclpGetUserHome(name, bufferPtr)
1108     CONST char *name;           /* User name for desired home directory. */
1109     Tcl_DString *bufferPtr;     /* Uninitialized or free DString filled
1110                                  * with name of user's home directory. */
1111 {
1112     char *result;
1113     HINSTANCE netapiInst;
1114
1115     result = NULL;
1116
1117     Tcl_DStringInit(bufferPtr);
1118
1119     netapiInst = LoadLibraryA("netapi32.dll");
1120     if (netapiInst != NULL) {
1121         NETAPIBUFFERFREEPROC *netApiBufferFreeProc;
1122         NETGETDCNAMEPROC *netGetDCNameProc;
1123         NETUSERGETINFOPROC *netUserGetInfoProc;
1124
1125         netApiBufferFreeProc = (NETAPIBUFFERFREEPROC *)
1126                 GetProcAddress(netapiInst, "NetApiBufferFree");
1127         netGetDCNameProc = (NETGETDCNAMEPROC *)
1128                 GetProcAddress(netapiInst, "NetGetDCName");
1129         netUserGetInfoProc = (NETUSERGETINFOPROC *)
1130                 GetProcAddress(netapiInst, "NetUserGetInfo");
1131         if ((netUserGetInfoProc != NULL) && (netGetDCNameProc != NULL)
1132                 && (netApiBufferFreeProc != NULL)) {
1133             USER_INFO_1 *uiPtr;
1134             Tcl_DString ds;
1135             int nameLen, badDomain;
1136             char *domain;
1137             WCHAR *wName, *wHomeDir, *wDomain;
1138             WCHAR buf[MAX_PATH];
1139
1140             badDomain = 0;
1141             nameLen = -1;
1142             wDomain = NULL;
1143             domain = strchr(name, '@');
1144             if (domain != NULL) {
1145                 Tcl_DStringInit(&ds);
1146                 wName = Tcl_UtfToUniCharDString(domain + 1, -1, &ds);
1147                 badDomain = (*netGetDCNameProc)(NULL, wName,
1148                         (LPBYTE *) &wDomain);
1149                 Tcl_DStringFree(&ds);
1150                 nameLen = domain - name;
1151             }
1152             if (badDomain == 0) {
1153                 Tcl_DStringInit(&ds);
1154                 wName = Tcl_UtfToUniCharDString(name, nameLen, &ds);
1155                 if ((*netUserGetInfoProc)(wDomain, wName, 1,
1156                         (LPBYTE *) &uiPtr) == 0) {
1157                     wHomeDir = uiPtr->usri1_home_dir;
1158                     if ((wHomeDir != NULL) && (wHomeDir[0] != L'\0')) {
1159                         Tcl_UniCharToUtfDString(wHomeDir, lstrlenW(wHomeDir),
1160                                 bufferPtr);
1161                     } else {
1162                         /*
1163                          * User exists but has no home dir.  Return
1164                          * "{Windows Drive}:/users/default".
1165                          */
1166
1167                         GetWindowsDirectoryW(buf, MAX_PATH);
1168                         Tcl_UniCharToUtfDString(buf, 2, bufferPtr);
1169                         Tcl_DStringAppend(bufferPtr, "/users/default", -1);
1170                     }
1171                     result = Tcl_DStringValue(bufferPtr);
1172                     (*netApiBufferFreeProc)((void *) uiPtr);
1173                 }
1174                 Tcl_DStringFree(&ds);
1175             }
1176             if (wDomain != NULL) {
1177                 (*netApiBufferFreeProc)((void *) wDomain);
1178             }
1179         }
1180         FreeLibrary(netapiInst);
1181     }
1182     if (result == NULL) {
1183         /*
1184          * Look in the "Password Lists" section of system.ini for the
1185          * local user.  There are also entries in that section that begin
1186          * with a "*" character that are used by Windows for other
1187          * purposes; ignore user names beginning with a "*".
1188          */
1189
1190         char buf[MAX_PATH];
1191
1192         if (name[0] != '*') {
1193             if (GetPrivateProfileStringA("Password Lists", name, "", buf,
1194                     MAX_PATH, "system.ini") > 0) {
1195                 /*
1196                  * User exists, but there is no such thing as a home
1197                  * directory in system.ini.  Return "{Windows drive}:/".
1198                  */
1199
1200                 GetWindowsDirectoryA(buf, MAX_PATH);
1201                 Tcl_DStringAppend(bufferPtr, buf, 3);
1202                 result = Tcl_DStringValue(bufferPtr);
1203             }
1204         }
1205     }
1206
1207     return result;
1208 }
1209
1210 \f
1211 /*
1212  *---------------------------------------------------------------------------
1213  *
1214  * NativeAccess --
1215  *
1216  *      This function replaces the library version of access(), fixing the
1217  *      following bugs:
1218  *
1219  *      1. access() returns that all files have execute permission.
1220  *
1221  * Results:
1222  *      See access documentation.
1223  *
1224  * Side effects:
1225  *      See access documentation.
1226  *
1227  *---------------------------------------------------------------------------
1228  */
1229
1230 static int
1231 NativeAccess(
1232     CONST TCHAR *nativePath,    /* Path of file to access (UTF-8). */
1233     int mode)                   /* Permission setting. */
1234 {
1235     DWORD attr;
1236
1237     attr = (*tclWinProcs->getFileAttributesProc)(nativePath);
1238
1239     if (attr == 0xffffffff) {
1240         /*
1241          * File doesn't exist.
1242          */
1243
1244         TclWinConvertError(GetLastError());
1245         return -1;
1246     }
1247
1248     if ((mode & W_OK) && (attr & FILE_ATTRIBUTE_READONLY)) {
1249         /*
1250          * File is not writable.
1251          */
1252
1253         Tcl_SetErrno(EACCES);
1254         return -1;
1255     }
1256
1257     if (mode & X_OK) {
1258         if (attr & FILE_ATTRIBUTE_DIRECTORY) {
1259             /*
1260              * Directories are always executable.
1261              */
1262
1263             return 0;
1264         }
1265         if (NativeIsExec(nativePath)) {
1266             return 0;
1267         }
1268         Tcl_SetErrno(EACCES);
1269         return -1;
1270     }
1271
1272     return 0;
1273 }
1274 \f
1275 static int
1276 NativeIsExec(nativePath)
1277     CONST TCHAR *nativePath;
1278 {
1279     CONST char *p, *path;
1280     Tcl_DString ds;
1281
1282     /*
1283      * This is really not efficient.  We should be able to examine
1284      * the native path directly without converting to UTF.
1285      */
1286     Tcl_DStringInit(&ds);
1287     path = Tcl_WinTCharToUtf(nativePath, -1, &ds);
1288
1289     p = strrchr(path, '.');
1290     if (p != NULL) {
1291         p++;
1292         /*
1293          * Note: in the old code, stat considered '.pif' files as
1294          * executable, whereas access did not.
1295          */
1296         if ((stricmp(p, "exe") == 0)
1297                 || (stricmp(p, "com") == 0)
1298                 || (stricmp(p, "bat") == 0)) {
1299             /*
1300              * File that ends with .exe, .com, or .bat is executable.
1301              */
1302
1303             Tcl_DStringFree(&ds);
1304             return 1;
1305         }
1306     }
1307     Tcl_DStringFree(&ds);
1308     return 0;
1309 }
1310 \f
1311 /*
1312  *----------------------------------------------------------------------
1313  *
1314  * TclpObjChdir --
1315  *
1316  *      This function replaces the library version of chdir().
1317  *
1318  * Results:
1319  *      See chdir() documentation.
1320  *
1321  * Side effects:
1322  *      See chdir() documentation.
1323  *
1324  *----------------------------------------------------------------------
1325  */
1326
1327 int
1328 TclpObjChdir(pathPtr)
1329     Tcl_Obj *pathPtr;   /* Path to new working directory. */
1330 {
1331     int result;
1332     CONST TCHAR *nativePath;
1333
1334     nativePath = (CONST TCHAR *) Tcl_FSGetNativePath(pathPtr);
1335     result = (*tclWinProcs->setCurrentDirectoryProc)(nativePath);
1336
1337     if (result == 0) {
1338         TclWinConvertError(GetLastError());
1339         return -1;
1340     }
1341     return 0;
1342 }
1343 \f
1344 #ifdef __CYGWIN__
1345 /*
1346  *---------------------------------------------------------------------------
1347  *
1348  * TclpReadlink --
1349  *
1350  *     This function replaces the library version of readlink().
1351  *
1352  * Results:
1353  *     The result is a pointer to a string specifying the contents
1354  *     of the symbolic link given by 'path', or NULL if the symbolic
1355  *     link could not be read.  Storage for the result string is
1356  *     allocated in bufferPtr; the caller must call Tcl_DStringFree()
1357  *     when the result is no longer needed.
1358  *
1359  * Side effects:
1360  *     See readlink() documentation.
1361  *
1362  *---------------------------------------------------------------------------
1363  */
1364
1365 char *
1366 TclpReadlink(path, linkPtr)
1367     CONST char *path;          /* Path of file to readlink (UTF-8). */
1368     Tcl_DString *linkPtr;      /* Uninitialized or free DString filled
1369                                 * with contents of link (UTF-8). */
1370 {
1371     char link[MAXPATHLEN];
1372     int length;
1373     char *native;
1374     Tcl_DString ds;
1375
1376     native = Tcl_UtfToExternalDString(NULL, path, -1, &ds);
1377     length = readlink(native, link, sizeof(link));     /* INTL: Native. */
1378     Tcl_DStringFree(&ds);
1379
1380     if (length < 0) {
1381         return NULL;
1382     }
1383
1384     Tcl_ExternalToUtfDString(NULL, link, length, linkPtr);
1385     return Tcl_DStringValue(linkPtr);
1386 }
1387 #endif /* __CYGWIN__ */
1388 \f
1389 /*
1390  *----------------------------------------------------------------------
1391  *
1392  * TclpGetCwd --
1393  *
1394  *      This function replaces the library version of getcwd().
1395  *
1396  * Results:
1397  *      The result is a pointer to a string specifying the current
1398  *      directory, or NULL if the current directory could not be
1399  *      determined.  If NULL is returned, an error message is left in the
1400  *      interp's result.  Storage for the result string is allocated in
1401  *      bufferPtr; the caller must call Tcl_DStringFree() when the result
1402  *      is no longer needed.
1403  *
1404  * Side effects:
1405  *      None.
1406  *
1407  *----------------------------------------------------------------------
1408  */
1409
1410 CONST char *
1411 TclpGetCwd(interp, bufferPtr)
1412     Tcl_Interp *interp;         /* If non-NULL, used for error reporting. */
1413     Tcl_DString *bufferPtr;     /* Uninitialized or free DString filled
1414                                  * with name of current directory. */
1415 {
1416     WCHAR buffer[MAX_PATH];
1417     char *p;
1418
1419     if ((*tclWinProcs->getCurrentDirectoryProc)(MAX_PATH, buffer) == 0) {
1420         TclWinConvertError(GetLastError());
1421         if (interp != NULL) {
1422             Tcl_AppendResult(interp,
1423                     "error getting working directory name: ",
1424                     Tcl_PosixError(interp), (char *) NULL);
1425         }
1426         return NULL;
1427     }
1428
1429     /*
1430      * Watch for the weird Windows c:\\UNC syntax.
1431      */
1432
1433     if (tclWinProcs->useWide) {
1434         WCHAR *native;
1435
1436         native = (WCHAR *) buffer;
1437         if ((native[0] != '\0') && (native[1] == ':')
1438                 && (native[2] == '\\') && (native[3] == '\\')) {
1439             native += 2;
1440         }
1441         Tcl_WinTCharToUtf((TCHAR *) native, -1, bufferPtr);
1442     } else {
1443         char *native;
1444
1445         native = (char *) buffer;
1446         if ((native[0] != '\0') && (native[1] == ':')
1447                 && (native[2] == '\\') && (native[3] == '\\')) {
1448             native += 2;
1449         }
1450         Tcl_WinTCharToUtf((TCHAR *) native, -1, bufferPtr);
1451     }
1452
1453     /*
1454      * Convert to forward slashes for easier use in scripts.
1455      */
1456
1457     for (p = Tcl_DStringValue(bufferPtr); *p != '\0'; p++) {
1458         if (*p == '\\') {
1459             *p = '/';
1460         }
1461     }
1462     return Tcl_DStringValue(bufferPtr);
1463 }
1464 \f
1465 int
1466 TclpObjStat(pathPtr, statPtr)
1467     Tcl_Obj *pathPtr;          /* Path of file to stat */
1468     Tcl_StatBuf *statPtr;      /* Filled with results of stat call. */
1469 {
1470 #ifdef OLD_API
1471     Tcl_Obj *transPtr;
1472     /*
1473      * Eliminate file names containing wildcard characters, or subsequent
1474      * call to FindFirstFile() will expand them, matching some other file.
1475      */
1476
1477     transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr);
1478     if (transPtr == NULL || (strpbrk(Tcl_GetString(transPtr), "?*") != NULL)) {
1479         Tcl_SetErrno(ENOENT);
1480         return -1;
1481     }
1482 #endif
1483
1484     /*
1485      * Ensure correct file sizes by forcing the OS to write any
1486      * pending data to disk. This is done only for channels which are
1487      * dirty, i.e. have been written to since the last flush here.
1488      */
1489
1490     TclWinFlushDirtyChannels ();
1491
1492     return NativeStat((CONST TCHAR*) Tcl_FSGetNativePath(pathPtr), statPtr, 0);
1493 }
1494 \f
1495 /*
1496  *----------------------------------------------------------------------
1497  *
1498  * NativeStat --
1499  *
1500  *      This function replaces the library version of stat(), fixing
1501  *      the following bugs:
1502  *
1503  *      1. stat("c:") returns an error.
1504  *      2. Borland stat() return time in GMT instead of localtime.
1505  *      3. stat("\\server\mount") would return error.
1506  *      4. Accepts slashes or backslashes.
1507  *      5. st_dev and st_rdev were wrong for UNC paths.
1508  *
1509  * Results:
1510  *      See stat documentation.
1511  *
1512  * Side effects:
1513  *      See stat documentation.
1514  *
1515  *----------------------------------------------------------------------
1516  */
1517
1518 static int
1519 NativeStat(nativePath, statPtr, checkLinks)
1520     CONST TCHAR *nativePath;   /* Path of file to stat */
1521     Tcl_StatBuf *statPtr;      /* Filled with results of stat call. */
1522     int checkLinks;            /* If non-zero, behave like 'lstat' */
1523 {
1524     Tcl_DString ds;
1525     DWORD attr;
1526     WCHAR nativeFullPath[MAX_PATH];
1527     TCHAR *nativePart;
1528     CONST char *fullPath;
1529     int dev, mode;
1530
1531     if (tclWinProcs->getFileAttributesExProc == NULL) {
1532         /*
1533          * We don't have the faster attributes proc, so we're
1534          * probably running on Win95
1535          */
1536         WIN32_FIND_DATAT data;
1537         HANDLE handle;
1538
1539         handle = (*tclWinProcs->findFirstFileProc)(nativePath, &data);
1540         if (handle == INVALID_HANDLE_VALUE) {
1541             /*
1542              * FindFirstFile() doesn't work on root directories, so call
1543              * GetFileAttributes() to see if the specified file exists.
1544              */
1545
1546             attr = (*tclWinProcs->getFileAttributesProc)(nativePath);
1547             if (attr == 0xffffffff) {
1548                 Tcl_SetErrno(ENOENT);
1549                 return -1;
1550             }
1551
1552             /*
1553              * Make up some fake information for this file.  It has the
1554              * correct file attributes and a time of 0.
1555              */
1556
1557             memset(&data, 0, sizeof(data));
1558             data.a.dwFileAttributes = attr;
1559         } else {
1560             FindClose(handle);
1561         }
1562
1563
1564         (*tclWinProcs->getFullPathNameProc)(nativePath, MAX_PATH, nativeFullPath,
1565                 &nativePart);
1566
1567         fullPath = Tcl_WinTCharToUtf((TCHAR *) nativeFullPath, -1, &ds);
1568
1569         dev = -1;
1570         if ((fullPath[0] == '\\') && (fullPath[1] == '\\')) {
1571             CONST char *p;
1572             DWORD dw;
1573             CONST TCHAR *nativeVol;
1574             Tcl_DString volString;
1575
1576             p = strchr(fullPath + 2, '\\');
1577             p = strchr(p + 1, '\\');
1578             if (p == NULL) {
1579                 /*
1580                  * Add terminating backslash to fullpath or
1581                  * GetVolumeInformation() won't work.
1582                  */
1583
1584                 fullPath = Tcl_DStringAppend(&ds, "\\", 1);
1585                 p = fullPath + Tcl_DStringLength(&ds);
1586             } else {
1587                 p++;
1588             }
1589             nativeVol = Tcl_WinUtfToTChar(fullPath, p - fullPath, &volString);
1590             dw = (DWORD) -1;
1591             (*tclWinProcs->getVolumeInformationProc)(nativeVol, NULL, 0, &dw,
1592                     NULL, NULL, NULL, 0);
1593             /*
1594              * GetFullPathName() turns special devices like "NUL" into
1595              * "\\.\NUL", but GetVolumeInformation() returns failure for
1596              * "\\.\NUL".  This will cause "NUL" to get a drive number of
1597              * -1, which makes about as much sense as anything since the
1598              * special devices don't live on any drive.
1599              */
1600
1601             dev = dw;
1602             Tcl_DStringFree(&volString);
1603         } else if ((fullPath[0] != '\0') && (fullPath[1] == ':')) {
1604             dev = Tcl_UniCharToLower(fullPath[0]) - 'a';
1605         }
1606         Tcl_DStringFree(&ds);
1607
1608         attr = data.a.dwFileAttributes;
1609
1610         statPtr->st_size  = ((Tcl_WideInt)data.a.nFileSizeLow) |
1611                 (((Tcl_WideInt)data.a.nFileSizeHigh) << 32);
1612         statPtr->st_atime = ToCTime(data.a.ftLastAccessTime);
1613         statPtr->st_mtime = ToCTime(data.a.ftLastWriteTime);
1614         statPtr->st_ctime = ToCTime(data.a.ftCreationTime);
1615     } else {
1616         WIN32_FILE_ATTRIBUTE_DATA data;
1617         if((*tclWinProcs->getFileAttributesExProc)(nativePath,
1618                                                    GetFileExInfoStandard,
1619                                                    &data) != TRUE) {
1620             Tcl_SetErrno(ENOENT);
1621             return -1;
1622         }
1623
1624
1625         (*tclWinProcs->getFullPathNameProc)(nativePath, MAX_PATH,
1626                                             nativeFullPath, &nativePart);
1627
1628         fullPath = Tcl_WinTCharToUtf((TCHAR *) nativeFullPath, -1, &ds);
1629
1630         dev = -1;
1631         if ((fullPath[0] == '\\') && (fullPath[1] == '\\')) {
1632             CONST char *p;
1633             DWORD dw;
1634             CONST TCHAR *nativeVol;
1635             Tcl_DString volString;
1636
1637             p = strchr(fullPath + 2, '\\');
1638             p = strchr(p + 1, '\\');
1639             if (p == NULL) {
1640                 /*
1641                  * Add terminating backslash to fullpath or
1642                  * GetVolumeInformation() won't work.
1643                  */
1644
1645                 fullPath = Tcl_DStringAppend(&ds, "\\", 1);
1646                 p = fullPath + Tcl_DStringLength(&ds);
1647             } else {
1648                 p++;
1649             }
1650             nativeVol = Tcl_WinUtfToTChar(fullPath, p - fullPath, &volString);
1651             dw = (DWORD) -1;
1652             (*tclWinProcs->getVolumeInformationProc)(nativeVol, NULL, 0, &dw,
1653                     NULL, NULL, NULL, 0);
1654             /*
1655              * GetFullPathName() turns special devices like "NUL" into
1656              * "\\.\NUL", but GetVolumeInformation() returns failure for
1657              * "\\.\NUL".  This will cause "NUL" to get a drive number of
1658              * -1, which makes about as much sense as anything since the
1659              * special devices don't live on any drive.
1660              */
1661
1662             dev = dw;
1663             Tcl_DStringFree(&volString);
1664         } else if ((fullPath[0] != '\0') && (fullPath[1] == ':')) {
1665             dev = Tcl_UniCharToLower(fullPath[0]) - 'a';
1666         }
1667         Tcl_DStringFree(&ds);
1668
1669         attr = data.dwFileAttributes;
1670
1671         statPtr->st_size  = ((Tcl_WideInt)data.nFileSizeLow) |
1672                 (((Tcl_WideInt)data.nFileSizeHigh) << 32);
1673         statPtr->st_atime = ToCTime(data.ftLastAccessTime);
1674         statPtr->st_mtime = ToCTime(data.ftLastWriteTime);
1675         statPtr->st_ctime = ToCTime(data.ftCreationTime);
1676     }
1677
1678     if (checkLinks && (attr & FILE_ATTRIBUTE_REPARSE_POINT)) {
1679         /* It is a link */
1680         mode = S_IFLNK;
1681     } else {
1682         mode  = (attr & FILE_ATTRIBUTE_DIRECTORY) ? S_IFDIR | S_IEXEC : S_IFREG;
1683     }
1684     mode |= (attr & FILE_ATTRIBUTE_READONLY) ? S_IREAD : S_IREAD | S_IWRITE;
1685     if (NativeIsExec(nativePath)) {
1686         mode |= S_IEXEC;
1687     }
1688
1689     /*
1690      * Propagate the S_IREAD, S_IWRITE, S_IEXEC bits to the group and
1691      * other positions.
1692      */
1693
1694     mode |= (mode & 0x0700) >> 3;
1695     mode |= (mode & 0x0700) >> 6;
1696
1697     statPtr->st_dev     = (dev_t) dev;
1698     statPtr->st_ino     = 0;
1699     statPtr->st_mode    = (unsigned short) mode;
1700     statPtr->st_nlink   = 1;
1701     statPtr->st_uid     = 0;
1702     statPtr->st_gid     = 0;
1703     statPtr->st_rdev    = (dev_t) dev;
1704     return 0;
1705 }
1706
1707 static time_t
1708 ToCTime(
1709     FILETIME fileTime)          /* UTC Time to convert to local time_t. */
1710 {
1711     FILETIME localFileTime;
1712     SYSTEMTIME systemTime;
1713     struct tm tm;
1714
1715     if (FileTimeToLocalFileTime(&fileTime, &localFileTime) == 0) {
1716         return 0;
1717     }
1718     if (FileTimeToSystemTime(&localFileTime, &systemTime) == 0) {
1719         return 0;
1720     }
1721     tm.tm_sec = systemTime.wSecond;
1722     tm.tm_min = systemTime.wMinute;
1723     tm.tm_hour = systemTime.wHour;
1724     tm.tm_mday = systemTime.wDay;
1725     tm.tm_mon = systemTime.wMonth - 1;
1726     tm.tm_year = systemTime.wYear - 1900;
1727     tm.tm_wday = 0;
1728     tm.tm_yday = 0;
1729     tm.tm_isdst = -1;
1730
1731     return mktime(&tm);
1732 }
1733
1734 #if 0
1735
1736     /*
1737      * Borland's stat doesn't take into account localtime.
1738      */
1739
1740     if ((result == 0) && (buf->st_mtime != 0)) {
1741         TIME_ZONE_INFORMATION tz;
1742         int time, bias;
1743
1744         time = GetTimeZoneInformation(&tz);
1745         bias = tz.Bias;
1746         if (time == TIME_ZONE_ID_DAYLIGHT) {
1747             bias += tz.DaylightBias;
1748         }
1749         bias *= 60;
1750         buf->st_atime -= bias;
1751         buf->st_ctime -= bias;
1752         buf->st_mtime -= bias;
1753     }
1754
1755 #endif
1756
1757
1758 #if 0
1759 /*
1760  *-------------------------------------------------------------------------
1761  *
1762  * TclWinResolveShortcut --
1763  *
1764  *      Resolve a potential Windows shortcut to get the actual file or
1765  *      directory in question.
1766  *
1767  * Results:
1768  *      Returns 1 if the shortcut could be resolved, or 0 if there was
1769  *      an error or if the filename was not a shortcut.
1770  *      If bufferPtr did hold the name of a shortcut, it is modified to
1771  *      hold the resolved target of the shortcut instead.
1772  *
1773  * Side effects:
1774  *      Loads and unloads OLE package to determine if filename refers to
1775  *      a shortcut.
1776  *
1777  *-------------------------------------------------------------------------
1778  */
1779
1780 int
1781 TclWinResolveShortcut(bufferPtr)
1782     Tcl_DString *bufferPtr;     /* Holds name of file to resolve.  On
1783                                  * return, holds resolved file name. */
1784 {
1785     HRESULT hres;
1786     IShellLink *psl;
1787     IPersistFile *ppf;
1788     WIN32_FIND_DATA wfd;
1789     WCHAR wpath[MAX_PATH];
1790     char *path, *ext;
1791     char realFileName[MAX_PATH];
1792
1793     /*
1794      * Windows system calls do not automatically resolve
1795      * shortcuts like UNIX automatically will with symbolic links.
1796      */
1797
1798     path = Tcl_DStringValue(bufferPtr);
1799     ext = strrchr(path, '.');
1800     if ((ext == NULL) || (stricmp(ext, ".lnk") != 0)) {
1801         return 0;
1802     }
1803
1804     CoInitialize(NULL);
1805     path = Tcl_DStringValue(bufferPtr);
1806     realFileName[0] = '\0';
1807     hres = CoCreateInstance(&CLSID_ShellLink, NULL, CLSCTX_INPROC_SERVER,
1808             &IID_IShellLink, &psl);
1809     if (SUCCEEDED(hres)) {
1810         hres = psl->lpVtbl->QueryInterface(psl, &IID_IPersistFile, &ppf);
1811         if (SUCCEEDED(hres)) {
1812             MultiByteToWideChar(CP_ACP, 0, path, -1, wpath, sizeof(wpath));
1813             hres = ppf->lpVtbl->Load(ppf, wpath, STGM_READ);
1814             if (SUCCEEDED(hres)) {
1815                 hres = psl->lpVtbl->Resolve(psl, NULL,
1816                         SLR_ANY_MATCH | SLR_NO_UI);
1817                 if (SUCCEEDED(hres)) {
1818                     hres = psl->lpVtbl->GetPath(psl, realFileName, MAX_PATH,
1819                             &wfd, 0);
1820                 }
1821             }
1822             ppf->lpVtbl->Release(ppf);
1823         }
1824         psl->lpVtbl->Release(psl);
1825     }
1826     CoUninitialize();
1827
1828     if (realFileName[0] != '\0') {
1829         Tcl_DStringSetLength(bufferPtr, 0);
1830         Tcl_DStringAppend(bufferPtr, realFileName, -1);
1831         return 1;
1832     }
1833     return 0;
1834 }
1835 #endif
1836 \f
1837 Tcl_Obj*
1838 TclpObjGetCwd(interp)
1839     Tcl_Interp *interp;
1840 {
1841     Tcl_DString ds;
1842     if (TclpGetCwd(interp, &ds) != NULL) {
1843         Tcl_Obj *cwdPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1);
1844         Tcl_IncrRefCount(cwdPtr);
1845         Tcl_DStringFree(&ds);
1846         return cwdPtr;
1847     } else {
1848         return NULL;
1849     }
1850 }
1851
1852 int
1853 TclpObjAccess(pathPtr, mode)
1854     Tcl_Obj *pathPtr;
1855     int mode;
1856 {
1857     return NativeAccess((CONST TCHAR*) Tcl_FSGetNativePath(pathPtr), mode);
1858 }
1859
1860 int
1861 TclpObjLstat(pathPtr, statPtr)
1862     Tcl_Obj *pathPtr;
1863     Tcl_StatBuf *statPtr;
1864 {
1865     /*
1866      * Ensure correct file sizes by forcing the OS to write any
1867      * pending data to disk. This is done only for channels which are
1868      * dirty, i.e. have been written to since the last flush here.
1869      */
1870
1871     TclWinFlushDirtyChannels ();
1872
1873     return NativeStat((CONST TCHAR*) Tcl_FSGetNativePath(pathPtr), statPtr, 1);
1874 }
1875
1876 #ifdef S_IFLNK
1877
1878 Tcl_Obj*
1879 TclpObjLink(pathPtr, toPtr, linkAction)
1880     Tcl_Obj *pathPtr;
1881     Tcl_Obj *toPtr;
1882     int linkAction;
1883 {
1884     if (toPtr != NULL) {
1885         int res;
1886         TCHAR* LinkTarget = (TCHAR*)Tcl_FSGetNativePath(toPtr);
1887         TCHAR* LinkSource = (TCHAR*)Tcl_FSGetNativePath(pathPtr);
1888         if (LinkSource == NULL || LinkTarget == NULL) {
1889             return NULL;
1890         }
1891         res = WinLink(LinkSource, LinkTarget, linkAction);
1892         if (res == 0) {
1893             return toPtr;
1894         } else {
1895             return NULL;
1896         }
1897     } else {
1898         TCHAR* LinkSource = (TCHAR*)Tcl_FSGetNativePath(pathPtr);
1899         if (LinkSource == NULL) {
1900             return NULL;
1901         }
1902         return WinReadLink(LinkSource);
1903     }
1904 }
1905
1906 #endif
1907
1908 \f
1909 /*
1910  *---------------------------------------------------------------------------
1911  *
1912  * TclpFilesystemPathType --
1913  *
1914  *      This function is part of the native filesystem support, and
1915  *      returns the path type of the given path.  Returns NTFS or FAT
1916  *      or whatever is returned by the 'volume information' proc.
1917  *
1918  * Results:
1919  *      NULL at present.
1920  *
1921  * Side effects:
1922  *      None.
1923  *
1924  *---------------------------------------------------------------------------
1925  */
1926 Tcl_Obj*
1927 TclpFilesystemPathType(pathObjPtr)
1928     Tcl_Obj* pathObjPtr;
1929 {
1930 #define VOL_BUF_SIZE 32
1931     int found;
1932     char volType[VOL_BUF_SIZE];
1933     char* firstSeparator;
1934     CONST char *path;
1935
1936     Tcl_Obj *normPath = Tcl_FSGetNormalizedPath(NULL, pathObjPtr);
1937     if (normPath == NULL) return NULL;
1938     path = Tcl_GetString(normPath);
1939     if (path == NULL) return NULL;
1940
1941     firstSeparator = strchr(path, '/');
1942     if (firstSeparator == NULL) {
1943         found = tclWinProcs->getVolumeInformationProc(
1944                 Tcl_FSGetNativePath(pathObjPtr), NULL, 0, NULL, NULL,
1945                 NULL, (WCHAR *)volType, VOL_BUF_SIZE);
1946     } else {
1947         Tcl_Obj *driveName = Tcl_NewStringObj(path, firstSeparator - path+1);
1948         Tcl_IncrRefCount(driveName);
1949         found = tclWinProcs->getVolumeInformationProc(
1950                 Tcl_FSGetNativePath(driveName), NULL, 0, NULL, NULL,
1951                 NULL, (WCHAR *)volType, VOL_BUF_SIZE);
1952         Tcl_DecrRefCount(driveName);
1953     }
1954
1955     if (found == 0) {
1956         return NULL;
1957     } else {
1958         Tcl_DString ds;
1959         Tcl_Obj *objPtr;
1960
1961         Tcl_WinTCharToUtf(volType, -1, &ds);
1962         objPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds),Tcl_DStringLength(&ds));
1963         Tcl_DStringFree(&ds);
1964         return objPtr;
1965     }
1966 #undef VOL_BUF_SIZE
1967 }
1968
1969 \f
1970 /*
1971  *---------------------------------------------------------------------------
1972  *
1973  * TclpObjNormalizePath --
1974  *
1975  *      This function scans through a path specification and replaces it,
1976  *      in place, with a normalized version.  This means using the
1977  *      'longname', and expanding any symbolic links contained within the
1978  *      path.
1979  *
1980  * Results:
1981  *      The new 'nextCheckpoint' value, giving as far as we could
1982  *      understand in the path.
1983  *
1984  * Side effects:
1985  *      The pathPtr string, which must contain a valid path, is
1986  *      possibly modified in place.
1987  *
1988  *---------------------------------------------------------------------------
1989  */
1990
1991 int
1992 TclpObjNormalizePath(interp, pathPtr, nextCheckpoint)
1993     Tcl_Interp *interp;
1994     Tcl_Obj *pathPtr;
1995     int nextCheckpoint;
1996 {
1997     char *lastValidPathEnd = NULL;
1998     /* This will hold the normalized string */
1999     Tcl_DString dsNorm;
2000     char *path;
2001     char *currentPathEndPosition;
2002
2003     Tcl_DStringInit(&dsNorm);
2004     path = Tcl_GetString(pathPtr);
2005
2006     if (TclWinGetPlatformId() == VER_PLATFORM_WIN32_WINDOWS) {
2007         /*
2008          * We're on Win95, 98 or ME.  There are two assumptions
2009          * in this block of code.  First that the native (NULL)
2010          * encoding is basically ascii, and second that symbolic
2011          * links are not possible.  Both of these assumptions
2012          * appear to be true of these operating systems.
2013          */
2014         Tcl_Obj *temp = NULL;
2015         int isDrive = 1;
2016         Tcl_DString ds;
2017
2018         currentPathEndPosition = path + nextCheckpoint;
2019         while (1) {
2020             char cur = *currentPathEndPosition;
2021             if ((cur == '/' || cur == 0) && (path != currentPathEndPosition)) {
2022                 /* Reached directory separator, or end of string */
2023                 CONST char *nativePath = Tcl_UtfToExternalDString(NULL, path,
2024                             currentPathEndPosition - path, &ds);
2025
2026                 /*
2027                  * Now we convert the tail of the current path to its
2028                  * 'long form', and append it to 'dsNorm' which holds
2029                  * the current normalized path, if the file exists.
2030                  */
2031                 if (isDrive) {
2032                     if (GetFileAttributesA(nativePath)
2033                         == 0xffffffff) {
2034                         /* File doesn't exist */
2035                         Tcl_DStringFree(&ds);
2036                         break;
2037                     }
2038                     if (nativePath[0] >= 'a') {
2039                         ((char*)nativePath)[0] -= ('a' - 'A');
2040                     }
2041                     Tcl_DStringAppend(&dsNorm,nativePath,Tcl_DStringLength(&ds));
2042                 } else {
2043                     WIN32_FIND_DATA fData;
2044                     HANDLE handle;
2045
2046                     handle = FindFirstFileA(nativePath, &fData);
2047                     if (handle == INVALID_HANDLE_VALUE) {
2048                         if (GetFileAttributesA(nativePath)
2049                             == 0xffffffff) {
2050                             /* File doesn't exist */
2051                             Tcl_DStringFree(&ds);
2052                             break;
2053                         }
2054                         /* This is usually the '/' in 'c:/' at end of string */
2055                         Tcl_DStringAppend(&dsNorm,"/", 1);
2056                     } else {
2057                         char *nativeName;
2058                         if (fData.cFileName[0] != '\0') {
2059                             nativeName = fData.cFileName;
2060                         } else {
2061                             nativeName = fData.cAlternateFileName;
2062                         }
2063                         FindClose(handle);
2064                         Tcl_DStringAppend(&dsNorm,"/", 1);
2065                         Tcl_DStringAppend(&dsNorm,nativeName,-1);
2066                     }
2067                 }
2068                 Tcl_DStringFree(&ds);
2069                 lastValidPathEnd = currentPathEndPosition;
2070                 if (cur == 0) {
2071                     break;
2072                 }
2073                 /*
2074                  * If we get here, we've got past one directory
2075                  * delimiter, so we know it is no longer a drive
2076                  */
2077                 isDrive = 0;
2078             }
2079             currentPathEndPosition++;
2080         }
2081     } else {
2082         /* We're on WinNT or 2000 or XP */
2083         Tcl_Obj *temp = NULL;
2084         int isDrive = 1;
2085         Tcl_DString ds;
2086
2087         currentPathEndPosition = path + nextCheckpoint;
2088         while (1) {
2089             char cur = *currentPathEndPosition;
2090             if ((cur == '/' || cur == 0) && (path != currentPathEndPosition)) {
2091                 /* Reached directory separator, or end of string */
2092                 WIN32_FILE_ATTRIBUTE_DATA data;
2093                 CONST char *nativePath = Tcl_WinUtfToTChar(path,
2094                             currentPathEndPosition - path, &ds);
2095                 if ((*tclWinProcs->getFileAttributesExProc)(nativePath,
2096                     GetFileExInfoStandard, &data) != TRUE) {
2097                     /* File doesn't exist */
2098                     Tcl_DStringFree(&ds);
2099                     break;
2100                 }
2101
2102                 /*
2103                  * File 'nativePath' does exist if we get here.  We
2104                  * now want to check if it is a symlink and otherwise
2105                  * continue with the rest of the path.
2106                  */
2107
2108                 /*
2109                  * Check for symlinks, except at last component
2110                  * of path (we don't follow final symlinks). Also
2111                  * a drive (C:/) for example, may sometimes have
2112                  * the reparse flag set for some reason I don't
2113                  * understand.  We therefore don't perform this
2114                  * check for drives.
2115                  */
2116                 if (cur != 0 && !isDrive && (data.dwFileAttributes
2117                                  & FILE_ATTRIBUTE_REPARSE_POINT)) {
2118                     Tcl_Obj *to = WinReadLinkDirectory(nativePath);
2119                     if (to != NULL) {
2120                         /* Read the reparse point ok */
2121                         /* Tcl_GetStringFromObj(to, &pathLen); */
2122                         nextCheckpoint = 0; /* pathLen */
2123                         Tcl_AppendToObj(to, currentPathEndPosition, -1);
2124                         /* Convert link to forward slashes */
2125                         for (path = Tcl_GetString(to); *path != 0; path++) {
2126                             if (*path == '\\') *path = '/';
2127                         }
2128                         path = Tcl_GetString(to);
2129                         currentPathEndPosition = path + nextCheckpoint;
2130                         if (temp != NULL) {
2131                             Tcl_DecrRefCount(temp);
2132                         }
2133                         temp = to;
2134                         /* Reset variables so we can restart normalization */
2135                         isDrive = 1;
2136                         Tcl_DStringFree(&dsNorm);
2137                         Tcl_DStringInit(&dsNorm);
2138                         Tcl_DStringFree(&ds);
2139                         continue;
2140                     }
2141                 }
2142                 /*
2143                  * Now we convert the tail of the current path to its
2144                  * 'long form', and append it to 'dsNorm' which holds
2145                  * the current normalized path
2146                  */
2147                 if (isDrive) {
2148                     WCHAR drive = ((WCHAR*)nativePath)[0];
2149                     if (drive >= L'a') {
2150                         drive -= (L'a' - L'A');
2151                         ((WCHAR*)nativePath)[0] = drive;
2152                     }
2153                     Tcl_DStringAppend(&dsNorm,nativePath,Tcl_DStringLength(&ds));
2154                 } else {
2155                     WIN32_FIND_DATAW fData;
2156                     HANDLE handle;
2157
2158                     handle = FindFirstFileW((WCHAR*)nativePath, &fData);
2159                     if (handle == INVALID_HANDLE_VALUE) {
2160                         /* This is usually the '/' in 'c:/' at end of string */
2161                         Tcl_DStringAppend(&dsNorm,(CONST char*)L"/",
2162                                           sizeof(WCHAR));
2163                     } else {
2164                         WCHAR *nativeName;
2165                         if (fData.cFileName[0] != '\0') {
2166                             nativeName = fData.cFileName;
2167                         } else {
2168                             nativeName = fData.cAlternateFileName;
2169                         }
2170                         FindClose(handle);
2171                         Tcl_DStringAppend(&dsNorm,(CONST char*)L"/",
2172                                           sizeof(WCHAR));
2173                         Tcl_DStringAppend(&dsNorm,(TCHAR*)nativeName,
2174                                           wcslen(nativeName)*sizeof(WCHAR));
2175                     }
2176                 }
2177                 Tcl_DStringFree(&ds);
2178                 lastValidPathEnd = currentPathEndPosition;
2179                 if (cur == 0) {
2180                     break;
2181                 }
2182                 /*
2183                  * If we get here, we've got past one directory
2184                  * delimiter, so we know it is no longer a drive
2185                  */
2186                 isDrive = 0;
2187             }
2188             currentPathEndPosition++;
2189         }
2190     }
2191     /* Common code path for all Windows platforms */
2192     nextCheckpoint = currentPathEndPosition - path;
2193     if (lastValidPathEnd != NULL) {
2194         /*
2195          * Concatenate the normalized string in dsNorm with the
2196          * tail of the path which we didn't recognise.  The
2197          * string in dsNorm is in the native encoding, so we
2198          * have to convert it to Utf.
2199          */
2200         Tcl_DString dsTemp;
2201         Tcl_WinTCharToUtf(Tcl_DStringValue(&dsNorm),
2202                           Tcl_DStringLength(&dsNorm), &dsTemp);
2203         nextCheckpoint = Tcl_DStringLength(&dsTemp);
2204         if (*lastValidPathEnd != 0) {
2205             /* Not the end of the string */
2206             int len;
2207             char *path;
2208             Tcl_Obj *tmpPathPtr;
2209             tmpPathPtr = Tcl_NewStringObj(Tcl_DStringValue(&dsTemp),
2210                                           nextCheckpoint);
2211             Tcl_AppendToObj(tmpPathPtr, lastValidPathEnd, -1);
2212             path = Tcl_GetStringFromObj(tmpPathPtr, &len);
2213             Tcl_SetStringObj(pathPtr, path, len);
2214             Tcl_DecrRefCount(tmpPathPtr);
2215         } else {
2216             /* End of string was reached above */
2217             Tcl_SetStringObj(pathPtr, Tcl_DStringValue(&dsTemp),
2218                              nextCheckpoint);
2219         }
2220         Tcl_DStringFree(&dsTemp);
2221     }
2222     Tcl_DStringFree(&dsNorm);
2223     return nextCheckpoint;
2224 }