/[dtapublic]/projs/dtats/trunk/shared_source/c_tcl_base_7_5_w_mods/tclwinfile.c

Diff of /projs/dtats/trunk/shared_source/c_tcl_base_7_5_w_mods/tclwinfile.c

Parent Directory | Revision Log | View Patch Patch

-revision 67 by dashley,
Mon Oct 31 00:57:34 2016 UTC
+revision 71 by dashley,
Sat Nov  5 11:07:06 2016 UTC
 Line 1
  /* $Header$ */
  /*
   * tclWinFile.c --
   *
   *      This file contains temporary wrappers around UNIX file handling
   *      functions. These wrappers map the UNIX functions to Win32 HANDLE-style
   *      files, which can be manipulated through the Win32 console redirection
   *      interfaces.
   *
   * Copyright (c) 1995-1998 Sun Microsystems, Inc.
   *
   * See the file "license.terms" for information on usage and redistribution
   * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
   *
   * RCS: @(#) $Id: tclwinfile.c,v 1.1.1.1 2001/06/13 04:49:10 dtashley Exp $
   */
  #include "tclWinInt.h"
  #include <sys/stat.h>
  #include <shlobj.h>
  #include <lmaccess.h>           /* For TclpGetUserHome(). */
  static time_t           ToCTime(FILETIME fileTime);
  typedef NET_API_STATUS NET_API_FUNCTION NETUSERGETINFOPROC
          (LPWSTR servername, LPWSTR username, DWORD level, LPBYTE *bufptr);
  typedef NET_API_STATUS NET_API_FUNCTION NETAPIBUFFERFREEPROC
          (LPVOID Buffer);
  typedef NET_API_STATUS NET_API_FUNCTION NETGETDCNAMEPROC
          (LPWSTR servername, LPWSTR domainname, LPBYTE *bufptr);
  /*
   *---------------------------------------------------------------------------
   *
   * TclpFindExecutable --
   *
   *      This procedure computes the absolute path name of the current
   *      application, given its argv[0] value.
   *
   * Results:
   *      A dirty UTF string that is the path to the executable.  At this
   *      point we may not know the system encoding.  Convert the native
   *      string value to UTF using the default encoding.  The assumption
   *      is that we will still be able to parse the path given the path
   *      name contains ASCII string and '/' chars do not conflict with
   *      other UTF chars.
   *
   * Side effects:
   *      The variable tclNativeExecutableName gets filled in with the file
   *      name for the application, if we figured it out.  If we couldn't
   *      figure it out, tclNativeExecutableName is set to NULL.
   *
   *---------------------------------------------------------------------------
   */
  char *
  TclpFindExecutable(argv0)
      CONST char *argv0;          /* The value of the application's argv[0]
                                   * (native). */
  {
      Tcl_DString ds;
      WCHAR wName[MAX_PATH];
      if (argv0 == NULL) {
          return NULL;
      }
      if (tclNativeExecutableName != NULL) {
          return tclNativeExecutableName;
      }
      /*
       * Under Windows we ignore argv0, and return the path for the file used to
       * create this process.
       */
      (*tclWinProcs->getModuleFileNameProc)(NULL, wName, MAX_PATH);
      Tcl_WinTCharToUtf((TCHAR *) wName, -1, &ds);
      tclNativeExecutableName = ckalloc((unsigned) (Tcl_DStringLength(&ds) + 1));
      strcpy(tclNativeExecutableName, Tcl_DStringValue(&ds));
      Tcl_DStringFree(&ds);
      TclWinNoBackslash(tclNativeExecutableName);
      return tclNativeExecutableName;
  }
  /*
   *----------------------------------------------------------------------
   *
   * TclpMatchFilesTypes --
   *
   *      This routine is used by the globbing code to search a
   *      directory for all files which match a given pattern.
   *
   * Results:
   *      If the tail argument is NULL, then the matching files are
   *      added to the the interp's result.  Otherwise, TclDoGlob is called
   *      recursively for each matching subdirectory.  The return value
   *      is a standard Tcl result indicating whether an error occurred
   *      in globbing.
   *
   * Side effects:
   *      None.
   *
   *---------------------------------------------------------------------- */
  int
  TclpMatchFilesTypes(
      Tcl_Interp *interp,         /* Interpreter to receive results. */
      char *separators,           /* Directory separators to pass to TclDoGlob. */
      Tcl_DString *dirPtr,        /* Contains path to directory to search. */
      char *pattern,              /* Pattern to match against. */
      char *tail,                 /* Pointer to end of pattern.  Tail must
                                   * point to a location in pattern and must
                                   * not be static.*/
      GlobTypeData *types)        /* Object containing list of acceptable types.
                                   * May be NULL. */
  {
      char drivePat[] = "?:\\";
      const char *message;
      char *dir, *newPattern, *root;
      int matchDotFiles;
      int dirLength, result = TCL_OK;
      Tcl_DString dirString, patternString;
      DWORD attr, volFlags;
      HANDLE handle;
      WIN32_FIND_DATAT data;
      BOOL found;
      Tcl_DString ds;
      TCHAR *nativeName;
      Tcl_Obj *resultPtr;
      /*
       * Convert the path to normalized form since some interfaces only
       * accept backslashes.  Also, ensure that the directory ends with a
       * separator character.
       */
      dirLength = Tcl_DStringLength(dirPtr);
      Tcl_DStringInit(&dirString);
      if (dirLength == 0) {
          Tcl_DStringAppend(&dirString, ".\\", 2);
      } else {
          char *p;
          Tcl_DStringAppend(&dirString, Tcl_DStringValue(dirPtr),
                  Tcl_DStringLength(dirPtr));
          for (p = Tcl_DStringValue(&dirString); *p != '\0'; p++) {
              if (*p == '/') {
                  *p = '\\';
              }
          }
          p--;
          if ((*p != '\\') && (*p != ':')) {
              Tcl_DStringAppend(&dirString, "\\", 1);
          }
      }
      dir = Tcl_DStringValue(&dirString);
      /*
       * First verify that the specified path is actually a directory.
       */
      nativeName = Tcl_WinUtfToTChar(dir, Tcl_DStringLength(&dirString), &ds);
      attr = (*tclWinProcs->getFileAttributesProc)(nativeName);
      Tcl_DStringFree(&ds);
      if ((attr == 0xffffffff) || ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0)) {
          Tcl_DStringFree(&dirString);
          return TCL_OK;
      }
      /*
       * Next check the volume information for the directory to see whether
       * comparisons should be case sensitive or not.  If the root is null, then
       * we use the root of the current directory.  If the root is just a drive
       * specifier, we use the root directory of the given drive.
       */
      switch (Tcl_GetPathType(dir)) {
          case TCL_PATH_RELATIVE:
              found = GetVolumeInformationA(NULL, NULL, 0, NULL, NULL,
                      &volFlags, NULL, 0);
              break;
          case TCL_PATH_VOLUME_RELATIVE:
              if (dir[0] == '\\') {
                  root = NULL;
              } else {
                  root = drivePat;
                  *root = dir[0];
              }
              found = GetVolumeInformationA(root, NULL, 0, NULL, NULL,
                      &volFlags, NULL, 0);
              break;
          case TCL_PATH_ABSOLUTE:
              if (dir[1] == ':') {
                  root = drivePat;
                  *root = dir[0];
                  found = GetVolumeInformationA(root, NULL, 0, NULL, NULL,
                          &volFlags, NULL, 0);
              } else if (dir[1] == '\\') {
                  char *p;
                  p = strchr(dir + 2, '\\');
                  p = strchr(p + 1, '\\');
                  p++;
                  nativeName = Tcl_WinUtfToTChar(dir, p - dir, &ds);
                  found = (*tclWinProcs->getVolumeInformationProc)(nativeName,
                          NULL, 0, NULL, NULL, &volFlags, NULL, 0);
                  Tcl_DStringFree(&ds);
              }
              break;
      }
      if (found == 0) {
          message = "couldn't read volume information for \"";
          goto error;
      }
      /*
       * In Windows, although some volumes may support case sensitivity, Windows
       * doesn't honor case.  So in globbing we need to ignore the case
       * of file names.
       */
      Tcl_DStringInit(&patternString);
      newPattern = Tcl_DStringAppend(&patternString, pattern, tail - pattern);
      Tcl_UtfToLower(newPattern);
      /*
       * We need to check all files in the directory, so append a *.*
       * to the path.
       */
      dir = Tcl_DStringAppend(&dirString, "*.*", 3);
      nativeName = Tcl_WinUtfToTChar(dir, -1, &ds);
      handle = (*tclWinProcs->findFirstFileProc)(nativeName, &data);
      Tcl_DStringFree(&ds);
      if (handle == INVALID_HANDLE_VALUE) {
          message = "couldn't read directory \"";
          goto error;
      }
      /*
       * Clean up the tail pointer.  Leave the tail pointing to the
       * first character after the path separator or NULL.
       */
      if (*tail == '\\') {
          tail++;
      }
      if (*tail == '\0') {
          tail = NULL;
      } else {
          tail++;
      }
      /*
       * Check to see if the pattern needs to compare with dot files.
       */
      if ((newPattern[0] == '.')
              || ((pattern[0] == '\\') && (pattern[1] == '.'))) {
          matchDotFiles = 1;
      } else {
          matchDotFiles = 0;
      }
      /*
       * Now iterate over all of the files in the directory.
       */
      resultPtr = Tcl_GetObjResult(interp);
      for (found = 1; found != 0;
              found = (*tclWinProcs->findNextFileProc)(handle, &data)) {
          TCHAR *nativeMatchResult;
          char *name, *fname;
          if (tclWinProcs->useWide) {
              nativeName = (TCHAR *) data.w.cFileName;
          } else {
              nativeName = (TCHAR *) data.a.cFileName;
          }
          name = Tcl_WinTCharToUtf(nativeName, -1, &ds);
          /*
           * Check to see if the file matches the pattern.  We need to convert
           * the file name to lower case for comparison purposes.  Note that we
           * are ignoring the case sensitivity flag because Windows doesn't honor
           * case even if the volume is case sensitive.  If the volume also
           * doesn't preserve case, then we previously returned the lower case
           * form of the name.  This didn't seem quite right since there are
           * non-case-preserving volumes that actually return mixed case.  So now
           * we are returning exactly what we get from the system.
           */
          Tcl_UtfToLower(name);
          nativeMatchResult = NULL;
          if ((matchDotFiles == 0) && (name[0] == '.')) {
              /*
               * Ignore hidden files.
               */
          } else if (Tcl_StringMatch(name, newPattern) != 0) {
              nativeMatchResult = nativeName;
          }
          Tcl_DStringFree(&ds);
          if (nativeMatchResult == NULL) {
              continue;
          }
          /*
           * If the file matches, then we need to process the remainder of the
           * path.  If there are more characters to process, then ensure matching
           * files are directories and call TclDoGlob. Otherwise, just add the
           * file to the result.
           */
          name = Tcl_WinTCharToUtf(nativeMatchResult, -1, &ds);
          Tcl_DStringAppend(dirPtr, name, -1);
          Tcl_DStringFree(&ds);
          fname = Tcl_DStringValue(dirPtr);
          nativeName = Tcl_WinUtfToTChar(fname, Tcl_DStringLength(dirPtr), &ds);
          attr = (*tclWinProcs->getFileAttributesProc)(nativeName);
          Tcl_DStringFree(&ds);
          if (tail == NULL) {
              int typeOk = 1;
              if (types != NULL) {
                  if (types->perm != 0) {
                      if (
                          ((types->perm & TCL_GLOB_PERM_RONLY) &&
                                  !(attr & FILE_ATTRIBUTE_READONLY)) ||
                          ((types->perm & TCL_GLOB_PERM_HIDDEN) &&
                                  !(attr & FILE_ATTRIBUTE_HIDDEN)) ||
                          ((types->perm & TCL_GLOB_PERM_R) &&
                                  (TclpAccess(fname, R_OK) != 0)) ||
                          ((types->perm & TCL_GLOB_PERM_W) &&
                                  (TclpAccess(fname, W_OK) != 0)) ||
                          ((types->perm & TCL_GLOB_PERM_X) &&
                                  (TclpAccess(fname, X_OK) != 0))
                          ) {
                          typeOk = 0;
                      }
                  }
                  if (typeOk && types->type != 0) {
                      struct stat buf;
                      /*
                       * We must match at least one flag to be listed
                       */
                      typeOk = 0;
                      if (TclpLstat(fname, &buf) >= 0) {
                          /*
                           * In order bcdpfls as in 'find -t'
                           */
                          if (
                              ((types->type & TCL_GLOB_TYPE_BLOCK) &&
                                      S_ISBLK(buf.st_mode)) ||
                              ((types->type & TCL_GLOB_TYPE_CHAR) &&
                                      S_ISCHR(buf.st_mode)) ||
                              ((types->type & TCL_GLOB_TYPE_DIR) &&
                                      S_ISDIR(buf.st_mode)) ||
                              ((types->type & TCL_GLOB_TYPE_PIPE) &&
                                      S_ISFIFO(buf.st_mode)) ||
                              ((types->type & TCL_GLOB_TYPE_FILE) &&
                                      S_ISREG(buf.st_mode))
  #ifdef S_ISLNK
                              || ((types->type & TCL_GLOB_TYPE_LINK) &&
                                      S_ISLNK(buf.st_mode))
  #endif
  #ifdef S_ISSOCK
                              || ((types->type & TCL_GLOB_TYPE_SOCK) &&
                                      S_ISSOCK(buf.st_mode))
  #endif
                              ) {
                              typeOk = 1;
                          }
                      } else {
                          /* Posix error occurred */
                      }
                  }
              }
              if (typeOk) {
                  Tcl_ListObjAppendElement(interp, resultPtr,
                          Tcl_NewStringObj(fname, Tcl_DStringLength(dirPtr)));
              }
          } else if (attr & FILE_ATTRIBUTE_DIRECTORY) {
              Tcl_DStringAppend(dirPtr, "/", 1);
              result = TclDoGlob(interp, separators, dirPtr, tail, types);
              if (result != TCL_OK) {
                  break;
              }
          }
          Tcl_DStringSetLength(dirPtr, dirLength);
      }
      FindClose(handle);
      Tcl_DStringFree(&dirString);
      Tcl_DStringFree(&patternString);
      return result;
      error:
      Tcl_DStringFree(&dirString);
      TclWinConvertError(GetLastError());
      Tcl_ResetResult(interp);
      Tcl_AppendResult(interp, message, Tcl_DStringValue(dirPtr), "\": ",
              Tcl_PosixError(interp), (char *) NULL);
      return TCL_ERROR;
  }
  /*
   * TclpMatchFiles --
   *
   * This function is now obsolete.  Call the above function
   * 'TclpMatchFilesTypes' instead.
   */
  int
  TclpMatchFiles(
      Tcl_Interp *interp,         /* Interpreter to receive results. */
      char *separators,           /* Directory separators to pass to TclDoGlob. */
      Tcl_DString *dirPtr,        /* Contains path to directory to search. */
      char *pattern,              /* Pattern to match against. */
      char *tail)                 /* Pointer to end of pattern.  Tail must
                                   * point to a location in pattern and must
                                   * not be static.*/
  {
      return TclpMatchFilesTypes(interp,separators,dirPtr,pattern,tail,NULL);
  }
  /*
   *----------------------------------------------------------------------
   *
   * TclpGetUserHome --
   *
   *      This function takes the passed in user name and finds the
   *      corresponding home directory specified in the password file.
   *
   * Results:
   *      The result is a pointer to a string specifying the user's home
   *      directory, or NULL if the user's home directory could not be
   *      determined.  Storage for the result string is allocated in
   *      bufferPtr; the caller must call Tcl_DStringFree() when the result
   *      is no longer needed.
   *
   * Side effects:
   *      None.
   *
   *----------------------------------------------------------------------
   */
  char *
  TclpGetUserHome(name, bufferPtr)
      CONST char *name;           /* User name for desired home directory. */
      Tcl_DString *bufferPtr;     /* Uninitialized or free DString filled
                                   * with name of user's home directory. */
  {
      char *result;
      HINSTANCE netapiInst;
      result = NULL;
      Tcl_DStringInit(bufferPtr);
      netapiInst = LoadLibraryA("netapi32.dll");
      if (netapiInst != NULL) {
          NETAPIBUFFERFREEPROC *netApiBufferFreeProc;
          NETGETDCNAMEPROC *netGetDCNameProc;
          NETUSERGETINFOPROC *netUserGetInfoProc;
          netApiBufferFreeProc = (NETAPIBUFFERFREEPROC *)
                  GetProcAddress(netapiInst, "NetApiBufferFree");
          netGetDCNameProc = (NETGETDCNAMEPROC *)
                  GetProcAddress(netapiInst, "NetGetDCName");
          netUserGetInfoProc = (NETUSERGETINFOPROC *)
                  GetProcAddress(netapiInst, "NetUserGetInfo");
          if ((netUserGetInfoProc != NULL) && (netGetDCNameProc != NULL)
                  && (netApiBufferFreeProc != NULL)) {
              USER_INFO_1 *uiPtr;
              Tcl_DString ds;
              int nameLen, badDomain;
              char *domain;
              WCHAR *wName, *wHomeDir, *wDomain;
              WCHAR buf[MAX_PATH];
              badDomain = 0;
              nameLen = -1;
              wDomain = NULL;
              domain = strchr(name, '@');
              if (domain != NULL) {
                  Tcl_DStringInit(&ds);
                  wName = Tcl_UtfToUniCharDString(domain + 1, -1, &ds);
                  badDomain = (*netGetDCNameProc)(NULL, wName,
                          (LPBYTE *) &wDomain);
                  Tcl_DStringFree(&ds);
                  nameLen = domain - name;
              }
              if (badDomain == 0) {
                  Tcl_DStringInit(&ds);
                  wName = Tcl_UtfToUniCharDString(name, nameLen, &ds);
                  if ((*netUserGetInfoProc)(wDomain, wName, 1,
                          (LPBYTE *) &uiPtr) == 0) {
                      wHomeDir = uiPtr->usri1_home_dir;
                      if ((wHomeDir != NULL) && (wHomeDir[0] != L'\0')) {
                          Tcl_UniCharToUtfDString(wHomeDir, lstrlenW(wHomeDir),
                                  bufferPtr);
                      } else {
                          /*
                           * User exists but has no home dir.  Return
                           * "{Windows Drive}:/users/default".
                           */
                          GetWindowsDirectoryW(buf, MAX_PATH);
                          Tcl_UniCharToUtfDString(buf, 2, bufferPtr);
                          Tcl_DStringAppend(bufferPtr, "/users/default", -1);
                      }
                      result = Tcl_DStringValue(bufferPtr);
                      (*netApiBufferFreeProc)((void *) uiPtr);
                  }
                  Tcl_DStringFree(&ds);
              }
              if (wDomain != NULL) {
                  (*netApiBufferFreeProc)((void *) wDomain);
              }
          }
          FreeLibrary(netapiInst);
      }
      if (result == NULL) {
          /*
           * Look in the "Password Lists" section of system.ini for the
           * local user.  There are also entries in that section that begin
           * with a "*" character that are used by Windows for other
           * purposes; ignore user names beginning with a "*".
           */
          char buf[MAX_PATH];
          if (name[0] != '*') {
              if (GetPrivateProfileStringA("Password Lists", name, "", buf,
                      MAX_PATH, "system.ini") > 0) {
                  /*
                   * User exists, but there is no such thing as a home
                   * directory in system.ini.  Return "{Windows drive}:/".
                   */
                  GetWindowsDirectoryA(buf, MAX_PATH);
                  Tcl_DStringAppend(bufferPtr, buf, 3);
                  result = Tcl_DStringValue(bufferPtr);
              }
          }
      }
      return result;
  }
  /*
   *---------------------------------------------------------------------------
   *
   * TclpAccess --
   *
   *      This function replaces the library version of access(), fixing the
   *      following bugs:
   *
   *      1. access() returns that all files have execute permission.
   *
   * Results:
   *      See access documentation.
   *
   * Side effects:
   *      See access documentation.
   *
   *---------------------------------------------------------------------------
   */
  int
  TclpAccess(
      CONST char *path,           /* Path of file to access (UTF-8). */
      int mode)                   /* Permission setting. */
  {
      Tcl_DString ds;
      TCHAR *nativePath;
      DWORD attr;
      nativePath = Tcl_WinUtfToTChar(path, -1, &ds);
      attr = (*tclWinProcs->getFileAttributesProc)(nativePath);
      Tcl_DStringFree(&ds);
      if (attr == 0xffffffff) {
          /*
           * File doesn't exist.
           */
          TclWinConvertError(GetLastError());
          return -1;
      }
      if ((mode & W_OK) && (attr & FILE_ATTRIBUTE_READONLY)) {
          /*
           * File is not writable.
           */
          Tcl_SetErrno(EACCES);
          return -1;
      }
      if (mode & X_OK) {
          CONST char *p;
          if (attr & FILE_ATTRIBUTE_DIRECTORY) {
              /*
               * Directories are always executable.
               */
              return 0;
          }
          p = strrchr(path, '.');
          if (p != NULL) {
              p++;
              if ((stricmp(p, "exe") == 0)
                      || (stricmp(p, "com") == 0)
                      || (stricmp(p, "bat") == 0)) {
                  /*
                   * File that ends with .exe, .com, or .bat is executable.
                   */
                  return 0;
              }
          }
          Tcl_SetErrno(EACCES);
          return -1;
      }
      return 0;
  }
  /*
   *----------------------------------------------------------------------
   *
   * TclpChdir --
   *
   *      This function replaces the library version of chdir().
   *
   * Results:
   *      See chdir() documentation.
   *
   * Side effects:
   *      See chdir() documentation.
   *
   *----------------------------------------------------------------------
   */
  int
  TclpChdir(path)
      CONST char *path;           /* Path to new working directory (UTF-8). */
  {
      int result;
      Tcl_DString ds;
      TCHAR *nativePath;
      nativePath = Tcl_WinUtfToTChar(path, -1, &ds);
      result = (*tclWinProcs->setCurrentDirectoryProc)(nativePath);
      Tcl_DStringFree(&ds);
      if (result == 0) {
          TclWinConvertError(GetLastError());
          return -1;
      }
      return 0;
  }
  /*
   *----------------------------------------------------------------------
   *
   * TclpGetCwd --
   *
   *      This function replaces the library version of getcwd().
   *
   * Results:
   *      The result is a pointer to a string specifying the current
   *      directory, or NULL if the current directory could not be
   *      determined.  If NULL is returned, an error message is left in the
   *      interp's result.  Storage for the result string is allocated in
   *      bufferPtr; the caller must call Tcl_DStringFree() when the result
   *      is no longer needed.
   *
   * Side effects:
   *      None.
   *
   *----------------------------------------------------------------------
   */
  char *
  TclpGetCwd(interp, bufferPtr)
      Tcl_Interp *interp;         /* If non-NULL, used for error reporting. */
      Tcl_DString *bufferPtr;     /* Uninitialized or free DString filled
                                   * with name of current directory. */
  {
      WCHAR buffer[MAX_PATH];
      char *p;
      if ((*tclWinProcs->getCurrentDirectoryProc)(MAX_PATH, buffer) == 0) {
          TclWinConvertError(GetLastError());
          if (interp != NULL) {
              Tcl_AppendResult(interp,
                      "error getting working directory name: ",
                      Tcl_PosixError(interp), (char *) NULL);
          }
          return NULL;
      }
      /*
       * Watch for the wierd Windows c:\\UNC syntax.
       */
      if (tclWinProcs->useWide) {
          WCHAR *native;
          native = (WCHAR *) buffer;
          if ((native[0] != '\0') && (native[1] == ':')
                  && (native[2] == '\\') && (native[3] == '\\')) {
              native += 2;
          }
          Tcl_WinTCharToUtf((TCHAR *) native, -1, bufferPtr);
      } else {
          char *native;
          native = (char *) buffer;
          if ((native[0] != '\0') && (native[1] == ':')
                  && (native[2] == '\\') && (native[3] == '\\')) {
              native += 2;
          }
          Tcl_WinTCharToUtf((TCHAR *) native, -1, bufferPtr);
      }
      /*
       * Convert to forward slashes for easier use in scripts.
       */
      for (p = Tcl_DStringValue(bufferPtr); *p != '\0'; p++) {
          if (*p == '\\') {
              *p = '/';
          }
      }
      return Tcl_DStringValue(bufferPtr);
  }
  /*
   *----------------------------------------------------------------------
   *
   * TclpStat --
   *
   *      This function replaces the library version of stat(), fixing
   *      the following bugs:
   *
   *      1. stat("c:") returns an error.
   *      2. Borland stat() return time in GMT instead of localtime.
   *      3. stat("\\server\mount") would return error.
   *      4. Accepts slashes or backslashes.
   *      5. st_dev and st_rdev were wrong for UNC paths.
   *
   * Results:
   *      See stat documentation.
   *
   * Side effects:
   *      See stat documentation.
   *
   *----------------------------------------------------------------------
   */
  int
  TclpStat(path, statPtr)
      CONST char *path;           /* Path of file to stat (UTF-8). */
      struct stat *statPtr;       /* Filled with results of stat call. */
  {
      Tcl_DString ds;
      TCHAR *nativePath;
      WIN32_FIND_DATAT data;
      HANDLE handle;
      DWORD attr;
      WCHAR nativeFullPath[MAX_PATH];
      TCHAR *nativePart;
      char *p, *fullPath;
      int dev, mode;
      /*
       * Eliminate file names containing wildcard characters, or subsequent
       * call to FindFirstFile() will expand them, matching some other file.
       */
      if (strpbrk(path, "?*") != NULL) {
          Tcl_SetErrno(ENOENT);
          return -1;
      }
      nativePath = Tcl_WinUtfToTChar(path, -1, &ds);
      handle = (*tclWinProcs->findFirstFileProc)(nativePath, &data);
      if (handle == INVALID_HANDLE_VALUE) {
          /*
           * FindFirstFile() doesn't work on root directories, so call
           * GetFileAttributes() to see if the specified file exists.
           */
          attr = (*tclWinProcs->getFileAttributesProc)(nativePath);
          if (attr == 0xffffffff) {
              Tcl_DStringFree(&ds);
              Tcl_SetErrno(ENOENT);
              return -1;
          }
          /*
           * Make up some fake information for this file.  It has the
           * correct file attributes and a time of 0.
           */
          memset(&data, 0, sizeof(data));
          data.a.dwFileAttributes = attr;
      } else {
          FindClose(handle);
      }
      (*tclWinProcs->getFullPathNameProc)(nativePath, MAX_PATH, nativeFullPath,
              &nativePart);
      Tcl_DStringFree(&ds);
      fullPath = Tcl_WinTCharToUtf((TCHAR *) nativeFullPath, -1, &ds);
      dev = -1;
      if ((fullPath[0] == '\\') && (fullPath[1] == '\\')) {
          char *p;
          DWORD dw;
          TCHAR *nativeVol;
          Tcl_DString volString;
          p = strchr(fullPath + 2, '\\');
          p = strchr(p + 1, '\\');
          if (p == NULL) {
              /*
               * Add terminating backslash to fullpath or
               * GetVolumeInformation() won't work.
               */
              fullPath = Tcl_DStringAppend(&ds, "\\", 1);
              p = fullPath + Tcl_DStringLength(&ds);
          } else {
              p++;
          }
          nativeVol = Tcl_WinUtfToTChar(fullPath, p - fullPath, &volString);
          dw = (DWORD) -1;
          (*tclWinProcs->getVolumeInformationProc)(nativeVol, NULL, 0, &dw,
                  NULL, NULL, NULL, 0);
          /*
           * GetFullPathName() turns special devices like "NUL" into "\\.\NUL",
           * but GetVolumeInformation() returns failure for "\\.\NUL".  This
           * will cause "NUL" to get a drive number of -1, which makes about
           * as much sense as anything since the special devices don't live on
           * any drive.
           */
          dev = dw;
          Tcl_DStringFree(&volString);
      } else if ((fullPath[0] != '\0') && (fullPath[1] == ':')) {
          dev = Tcl_UniCharToLower(fullPath[0]) - 'a';
      }
      Tcl_DStringFree(&ds);
      attr = data.a.dwFileAttributes;
      mode  = (attr & FILE_ATTRIBUTE_DIRECTORY) ? S_IFDIR | S_IEXEC : S_IFREG;
      mode |= (attr & FILE_ATTRIBUTE_READONLY) ? S_IREAD : S_IREAD | S_IWRITE;
      p = strrchr(path, '.');
      if (p != NULL) {
          if ((lstrcmpiA(p, ".exe") == 0)
                  || (lstrcmpiA(p, ".com") == 0)
                  || (lstrcmpiA(p, ".bat") == 0)
                  || (lstrcmpiA(p, ".pif") == 0)) {
              mode |= S_IEXEC;
          }
      }
      /*
       * Propagate the S_IREAD, S_IWRITE, S_IEXEC bits to the group and
       * other positions.
       */
      mode |= (mode & 0x0700) >> 3;
      mode |= (mode & 0x0700) >> 6;
      statPtr->st_dev     = (dev_t) dev;
      statPtr->st_ino     = 0;
      statPtr->st_mode    = (unsigned short) mode;
      statPtr->st_nlink   = 1;
      statPtr->st_uid     = 0;
      statPtr->st_gid     = 0;
      statPtr->st_rdev    = (dev_t) dev;
      statPtr->st_size    = data.a.nFileSizeLow;
      statPtr->st_atime   = ToCTime(data.a.ftLastAccessTime);
      statPtr->st_mtime   = ToCTime(data.a.ftLastWriteTime);
      statPtr->st_ctime   = ToCTime(data.a.ftCreationTime);
      return 0;
  }
  static time_t
  ToCTime(
      FILETIME fileTime)          /* UTC Time to convert to local time_t. */
  {
      FILETIME localFileTime;
      SYSTEMTIME systemTime;
      struct tm tm;
      if (FileTimeToLocalFileTime(&fileTime, &localFileTime) == 0) {
          return 0;
      }
      if (FileTimeToSystemTime(&localFileTime, &systemTime) == 0) {
          return 0;
      }
      tm.tm_sec = systemTime.wSecond;
      tm.tm_min = systemTime.wMinute;
      tm.tm_hour = systemTime.wHour;
      tm.tm_mday = systemTime.wDay;
      tm.tm_mon = systemTime.wMonth - 1;
      tm.tm_year = systemTime.wYear - 1900;
      tm.tm_wday = 0;
      tm.tm_yday = 0;
      tm.tm_isdst = -1;
      return mktime(&tm);
  }
  #if 0
      /*
       * Borland's stat doesn't take into account localtime.
       */
      if ((result == 0) && (buf->st_mtime != 0)) {
          TIME_ZONE_INFORMATION tz;
          int time, bias;
          time = GetTimeZoneInformation(&tz);
          bias = tz.Bias;
          if (time == TIME_ZONE_ID_DAYLIGHT) {
              bias += tz.DaylightBias;
          }
          bias *= 60;
          buf->st_atime -= bias;
          buf->st_ctime -= bias;
          buf->st_mtime -= bias;
      }
  #endif
  #if 0
  /*
   *-------------------------------------------------------------------------
   *
   * TclWinResolveShortcut --
   *
   *      Resolve a potential Windows shortcut to get the actual file or
   *      directory in question.
   *
   * Results:
   *      Returns 1 if the shortcut could be resolved, or 0 if there was
   *      an error or if the filename was not a shortcut.
   *      If bufferPtr did hold the name of a shortcut, it is modified to
   *      hold the resolved target of the shortcut instead.
   *
   * Side effects:
   *      Loads and unloads OLE package to determine if filename refers to
   *      a shortcut.
   *
   *-------------------------------------------------------------------------
   */
  int
  TclWinResolveShortcut(bufferPtr)
      Tcl_DString *bufferPtr;     /* Holds name of file to resolve.  On
                                   * return, holds resolved file name. */
  {
      HRESULT hres;
      IShellLink *psl;
      IPersistFile *ppf;
      WIN32_FIND_DATA wfd;
      WCHAR wpath[MAX_PATH];
      char *path, *ext;
      char realFileName[MAX_PATH];
      /*
       * Windows system calls do not automatically resolve
       * shortcuts like UNIX automatically will with symbolic links.
       */
      path = Tcl_DStringValue(bufferPtr);
      ext = strrchr(path, '.');
      if ((ext == NULL) || (stricmp(ext, ".lnk") != 0)) {
          return 0;
      }
      CoInitialize(NULL);
      path = Tcl_DStringValue(bufferPtr);
      realFileName[0] = '\0';
      hres = CoCreateInstance(&CLSID_ShellLink, NULL, CLSCTX_INPROC_SERVER,
              &IID_IShellLink, &psl);
      if (SUCCEEDED(hres)) {
          hres = psl->lpVtbl->QueryInterface(psl, &IID_IPersistFile, &ppf);
          if (SUCCEEDED(hres)) {
              MultiByteToWideChar(CP_ACP, 0, path, -1, wpath, sizeof(wpath));
              hres = ppf->lpVtbl->Load(ppf, wpath, STGM_READ);
              if (SUCCEEDED(hres)) {
                  hres = psl->lpVtbl->Resolve(psl, NULL,
                          SLR_ANY_MATCH | SLR_NO_UI);
                  if (SUCCEEDED(hres)) {
                      hres = psl->lpVtbl->GetPath(psl, realFileName, MAX_PATH,
                              &wfd, 0);
                  }
              }
              ppf->lpVtbl->Release(ppf);
          }
          psl->lpVtbl->Release(psl);
      }
      CoUninitialize();
      if (realFileName[0] != '\0') {
          Tcl_DStringSetLength(bufferPtr, 0);
          Tcl_DStringAppend(bufferPtr, realFileName, -1);
          return 1;
      }
      return 0;
  }
  #endif
  /* End of tclwinfile.c */

 Legend:



Removed from v.67
 


changed lines


 
Added in v.71
 Legend:



Removed from v.67
 


changed lines


 
Added in v.71
-Removed from v.67
+Added in v.71

dashley@gmail.com	ViewVC Help
Powered by ViewVC 1.1.25