tcl/unix/tclUnixFile.c

   1 /*
   2  * tclUnixFile.c --
   3  *
   4  *      This file contains wrappers around UNIX file handling functions.
   5  *      These wrappers mask differences between Windows and UNIX.
   6  *
   7  * Copyright (c) 1995-1998 Sun Microsystems, Inc.
   8  *
   9  * See the file "license.terms" for information on usage and redistribution
  10  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  11  *
  12  * RCS: @(#) $Id$
  13  */
  14
  15 #include "tclInt.h"
  16 #include "tclPort.h"
  17
  18 static int NativeMatchType(CONST char* nativeName, Tcl_GlobTypeData *types);
  19
  20 \f
  21 /*
  22  *---------------------------------------------------------------------------
  23  *
  24  * TclpFindExecutable --
  25  *
  26  *      This procedure computes the absolute path name of the current
  27  *      application, given its argv[0] value.
  28  *
  29  * Results:
  30  *      A dirty UTF string that is the path to the executable.  At this
  31  *      point we may not know the system encoding.  Convert the native
  32  *      string value to UTF using the default encoding.  The assumption
  33  *      is that we will still be able to parse the path given the path
  34  *      name contains ASCII string and '/' chars do not conflict with
  35  *      other UTF chars.
  36  *
  37  * Side effects:
  38  *      The variable tclNativeExecutableName gets filled in with the file
  39  *      name for the application, if we figured it out.  If we couldn't
  40  *      figure it out, tclNativeExecutableName is set to NULL.
  41  *
  42  *---------------------------------------------------------------------------
  43  */
  44
  45 char *
  46 TclpFindExecutable(argv0)
  47     CONST char *argv0;          /* The value of the application's argv[0]
  48                                  * (native). */
  49 {
  50     CONST char *name, *p;
  51     Tcl_StatBuf statBuf;
  52     int length;
  53     Tcl_DString buffer, nameString;
  54
  55     if (argv0 == NULL) {
  56         return NULL;
  57     }
  58     if (tclNativeExecutableName != NULL) {
  59         return tclNativeExecutableName;
  60     }
  61
  62     Tcl_DStringInit(&buffer);
  63
  64     name = argv0;
  65     for (p = name; *p != '\0'; p++) {
  66         if (*p == '/') {
  67             /*
  68              * The name contains a slash, so use the name directly
  69              * without doing a path search.
  70              */
  71
  72             goto gotName;
  73         }
  74     }
  75
  76     p = getenv("PATH");                                 /* INTL: Native. */
  77     if (p == NULL) {
  78         /*
  79          * There's no PATH environment variable; use the default that
  80          * is used by sh.
  81          */
  82
  83         p = ":/bin:/usr/bin";
  84     } else if (*p == '\0') {
  85         /*
  86          * An empty path is equivalent to ".".
  87          */
  88
  89         p = "./";
  90     }
  91
  92     /*
  93      * Search through all the directories named in the PATH variable
  94      * to see if argv[0] is in one of them.  If so, use that file
  95      * name.
  96      */
  97
  98     while (1) {
  99         while (isspace(UCHAR(*p))) {            /* INTL: BUG */
 100             p++;
 101         }
 102         name = p;
 103         while ((*p != ':') && (*p != 0)) {
 104             p++;
 105         }
 106         Tcl_DStringSetLength(&buffer, 0);
 107         if (p != name) {
 108             Tcl_DStringAppend(&buffer, name, p - name);
 109             if (p[-1] != '/') {
 110                 Tcl_DStringAppend(&buffer, "/", 1);
 111             }
 112         }
 113         name = Tcl_DStringAppend(&buffer, argv0, -1);
 114
 115         /*
 116          * INTL: The following calls to access() and stat() should not be
 117          * converted to Tclp routines because they need to operate on native
 118          * strings directly.
 119          */
 120
 121         if ((access(name, X_OK) == 0)                   /* INTL: Native. */
 122                 && (TclOSstat(name, &statBuf) == 0)     /* INTL: Native. */
 123                 && S_ISREG(statBuf.st_mode)) {
 124             goto gotName;
 125         }
 126         if (*p == '\0') {
 127             break;
 128         } else if (*(p+1) == 0) {
 129             p = "./";
 130         } else {
 131             p++;
 132         }
 133     }
 134     goto done;
 135
 136     /*
 137      * If the name starts with "/" then just copy it to tclExecutableName.
 138      */
 139
 140 gotName:
 141 #ifdef DJGPP
 142     if (name[1] == ':')  {
 143 #else
 144     if (name[0] == '/')  {
 145 #endif
 146         Tcl_ExternalToUtfDString(NULL, name, -1, &nameString);
 147         tclNativeExecutableName = (char *)
 148                 ckalloc((unsigned) (Tcl_DStringLength(&nameString) + 1));
 149         strcpy(tclNativeExecutableName, Tcl_DStringValue(&nameString));
 150         Tcl_DStringFree(&nameString);
 151         goto done;
 152     }
 153
 154     /*
 155      * The name is relative to the current working directory.  First
 156      * strip off a leading "./", if any, then add the full path name of
 157      * the current working directory.
 158      */
 159
 160     if ((name[0] == '.') && (name[1] == '/')) {
 161         name += 2;
 162     }
 163
 164     Tcl_ExternalToUtfDString(NULL, name, -1, &nameString);
 165
 166     Tcl_DStringFree(&buffer);
 167     TclpGetCwd(NULL, &buffer);
 168
 169     length = Tcl_DStringLength(&buffer) + Tcl_DStringLength(&nameString) + 2;
 170     tclNativeExecutableName = (char *) ckalloc((unsigned) length);
 171     strcpy(tclNativeExecutableName, Tcl_DStringValue(&buffer));
 172     tclNativeExecutableName[Tcl_DStringLength(&buffer)] = '/';
 173     strcpy(tclNativeExecutableName + Tcl_DStringLength(&buffer) + 1,
 174             Tcl_DStringValue(&nameString));
 175     Tcl_DStringFree(&nameString);
 176
 177 done:
 178     Tcl_DStringFree(&buffer);
 179     return tclNativeExecutableName;
 180 }
 181 \f
 182 /*
 183  *----------------------------------------------------------------------
 184  *
 185  * TclpMatchInDirectory --
 186  *
 187  *      This routine is used by the globbing code to search a
 188  *      directory for all files which match a given pattern.
 189  *
 190  * Results:
 191  *      The return value is a standard Tcl result indicating whether an
 192  *      error occurred in globbing.  Errors are left in interp, good
 193  *      results are lappended to resultPtr (which must be a valid object)
 194  *
 195  * Side effects:
 196  *      None.
 197  *
 198  *---------------------------------------------------------------------- */
 199
 200 int
 201 TclpMatchInDirectory(interp, resultPtr, pathPtr, pattern, types)
 202     Tcl_Interp *interp;         /* Interpreter to receive errors. */
 203     Tcl_Obj *resultPtr;         /* List object to lappend results. */
 204     Tcl_Obj *pathPtr;           /* Contains path to directory to search. */
 205     CONST char *pattern;        /* Pattern to match against. */
 206     Tcl_GlobTypeData *types;    /* Object containing list of acceptable types.
 207                                  * May be NULL. In particular the directory
 208                                  * flag is very important. */
 209 {
 210     CONST char *native;
 211     Tcl_Obj *fileNamePtr;
 212
 213     fileNamePtr = Tcl_FSGetTranslatedPath(interp, pathPtr);
 214     if (fileNamePtr == NULL) {
 215         return TCL_ERROR;
 216     }
 217
 218     if (pattern == NULL || (*pattern == '\0')) {
 219         /* Match a file directly */
 220         CONST char *native = (CONST char*) Tcl_FSGetNativePath(pathPtr);
 221         if (NativeMatchType(native, types)) {
 222             Tcl_ListObjAppendElement(interp, resultPtr, pathPtr);
 223         }
 224         return TCL_OK;
 225     } else {
 226         CONST char *fname, *dirName;
 227         DIR *d;
 228         Tcl_DString ds;
 229         Tcl_StatBuf statBuf;
 230         int matchHidden;
 231         int nativeDirLen;
 232         int result = TCL_OK;
 233         Tcl_DString dsOrig;
 234         int baseLength;
 235
 236         Tcl_DStringInit(&dsOrig);
 237         Tcl_DStringAppend(&dsOrig, Tcl_GetString(fileNamePtr), -1);
 238         baseLength = Tcl_DStringLength(&dsOrig);
 239
 240         /*
 241          * Make sure that the directory part of the name really is a
 242          * directory.  If the directory name is "", use the name "."
 243          * instead, because some UNIX systems don't treat "" like "."
 244          * automatically.  Keep the "" for use in generating file names,
 245          * otherwise "glob foo.c" would return "./foo.c".
 246          */
 247
 248         if (baseLength == 0) {
 249             dirName = ".";
 250         } else {
 251             dirName = Tcl_DStringValue(&dsOrig);
 252             /* Make sure we have a trailing directory delimiter */
 253             if (dirName[baseLength-1] != '/') {
 254                 dirName = Tcl_DStringAppend(&dsOrig, "/", 1);
 255                 baseLength++;
 256             }
 257         }
 258
 259         /*
 260          * Check to see if the pattern needs to compare with hidden files.
 261          */
 262
 263         if ((pattern[0] == '.')
 264                 || ((pattern[0] == '\\') && (pattern[1] == '.'))) {
 265             matchHidden = 1;
 266         } else {
 267             matchHidden = 0;
 268         }
 269
 270         /*
 271          * Now open the directory for reading and iterate over the contents.
 272          */
 273
 274         native = Tcl_UtfToExternalDString(NULL, dirName, -1, &ds);
 275
 276         if ((TclOSstat(native, &statBuf) != 0)          /* INTL: Native. */
 277                 || !S_ISDIR(statBuf.st_mode)) {
 278             Tcl_DStringFree(&dsOrig);
 279             Tcl_DStringFree(&ds);
 280             return TCL_OK;
 281         }
 282
 283         d = opendir(native);                            /* INTL: Native. */
 284         if (d == NULL) {
 285             char savedChar = '\0';
 286             Tcl_ResetResult(interp);
 287             Tcl_DStringFree(&ds);
 288
 289             /*
 290              * Strip off a trailing '/' if necessary, before reporting the error.
 291              */
 292
 293             if (baseLength > 0) {
 294                 savedChar = (Tcl_DStringValue(&dsOrig))[baseLength-1];
 295                 if (savedChar == '/') {
 296                     (Tcl_DStringValue(&dsOrig))[baseLength-1] = '\0';
 297                 }
 298             }
 299             Tcl_AppendResult(interp, "couldn't read directory \"",
 300                     Tcl_DStringValue(&dsOrig), "\": ",
 301                     Tcl_PosixError(interp), (char *) NULL);
 302             if (baseLength > 0) {
 303                 (Tcl_DStringValue(&dsOrig))[baseLength-1] = savedChar;
 304             }
 305             Tcl_DStringFree(&dsOrig);
 306             return TCL_ERROR;
 307         }
 308
 309         nativeDirLen = Tcl_DStringLength(&ds);
 310
 311         while (1) {
 312             Tcl_DString utfDs;
 313             CONST char *utf;
 314             Tcl_DirEntry *entryPtr;
 315
 316             entryPtr = TclOSreaddir(d);                 /* INTL: Native. */
 317             if (entryPtr == NULL) {
 318                 break;
 319             }
 320             if (types != NULL && (types->perm & TCL_GLOB_PERM_HIDDEN)) {
 321                 /*
 322                  * We explicitly asked for hidden files, so turn around
 323                  * and ignore any file which isn't hidden.
 324                  */
 325                 if (*entryPtr->d_name != '.') {
 326                     continue;
 327                 }
 328             } else if (!matchHidden && (*entryPtr->d_name == '.')) {
 329                 /*
 330                  * Don't match names starting with "." unless the "." is
 331                  * present in the pattern.
 332                  */
 333                 continue;
 334             }
 335
 336             /*
 337              * Now check to see if the file matches, according to both type
 338              * and pattern.  If so, add the file to the result.
 339              */
 340
 341             utf = Tcl_ExternalToUtfDString(NULL, entryPtr->d_name, -1, &utfDs);
 342             if (Tcl_StringMatch(utf, pattern) != 0) {
 343                 int typeOk = 1;
 344
 345                 Tcl_DStringSetLength(&dsOrig, baseLength);
 346                 Tcl_DStringAppend(&dsOrig, utf, -1);
 347                 fname = Tcl_DStringValue(&dsOrig);
 348                 if (types != NULL) {
 349                     char *nativeEntry;
 350                     Tcl_DStringSetLength(&ds, nativeDirLen);
 351                     nativeEntry = Tcl_DStringAppend(&ds, entryPtr->d_name, -1);
 352                     typeOk = NativeMatchType(nativeEntry, types);
 353                 }
 354                 if (typeOk) {
 355                     Tcl_ListObjAppendElement(interp, resultPtr,
 356                             Tcl_NewStringObj(fname, Tcl_DStringLength(&dsOrig)));
 357                 }
 358             }
 359             Tcl_DStringFree(&utfDs);
 360         }
 361
 362         closedir(d);
 363         Tcl_DStringFree(&ds);
 364         Tcl_DStringFree(&dsOrig);
 365         return result;
 366     }
 367 }
 368 static int
 369 NativeMatchType(
 370     CONST char* nativeEntry,  /* Native path to check */
 371     Tcl_GlobTypeData *types)  /* Type description to match against */
 372 {
 373     Tcl_StatBuf buf;
 374     if (types == NULL) {
 375         /*
 376          * Simply check for the file's existence, but do it
 377          * with lstat, in case it is a link to a file which
 378          * doesn't exist (since that case would not show up
 379          * if we used 'access' or 'stat')
 380          */
 381         if (TclOSlstat(nativeEntry, &buf) != 0) {
 382             return 0;
 383         }
 384     } else {
 385         if (types->perm != 0) {
 386             if (TclOSstat(nativeEntry, &buf) != 0) {
 387                 /*
 388                  * Either the file has disappeared between the
 389                  * 'readdir' call and the 'stat' call, or
 390                  * the file is a link to a file which doesn't
 391                  * exist (which we could ascertain with
 392                  * lstat), or there is some other strange
 393                  * problem.  In all these cases, we define this
 394                  * to mean the file does not match any defined
 395                  * permission, and therefore it is not
 396                  * added to the list of files to return.
 397                  */
 398                 return 0;
 399             }
 400
 401             /*
 402              * readonly means that there are NO write permissions
 403              * (even for user), but execute is OK for anybody
 404              */
 405             if (((types->perm & TCL_GLOB_PERM_RONLY) &&
 406                         (buf.st_mode & (S_IWOTH|S_IWGRP|S_IWUSR))) ||
 407                 ((types->perm & TCL_GLOB_PERM_R) &&
 408                         (access(nativeEntry, R_OK) != 0)) ||
 409                 ((types->perm & TCL_GLOB_PERM_W) &&
 410                         (access(nativeEntry, W_OK) != 0)) ||
 411                 ((types->perm & TCL_GLOB_PERM_X) &&
 412                         (access(nativeEntry, X_OK) != 0))
 413                 ) {
 414                 return 0;
 415             }
 416         }
 417         if (types->type != 0) {
 418             if (types->perm == 0) {
 419                 /* We haven't yet done a stat on the file */
 420                 if (TclOSstat(nativeEntry, &buf) != 0) {
 421                     /* Posix error occurred */
 422                     return 0;
 423                 }
 424             }
 425             /*
 426              * In order bcdpfls as in 'find -t'
 427              */
 428             if (
 429                 ((types->type & TCL_GLOB_TYPE_BLOCK) &&
 430                         S_ISBLK(buf.st_mode)) ||
 431                 ((types->type & TCL_GLOB_TYPE_CHAR) &&
 432                         S_ISCHR(buf.st_mode)) ||
 433                 ((types->type & TCL_GLOB_TYPE_DIR) &&
 434                         S_ISDIR(buf.st_mode)) ||
 435                 ((types->type & TCL_GLOB_TYPE_PIPE) &&
 436                         S_ISFIFO(buf.st_mode)) ||
 437                 ((types->type & TCL_GLOB_TYPE_FILE) &&
 438                         S_ISREG(buf.st_mode))
 439 #ifdef S_ISSOCK
 440                 || ((types->type & TCL_GLOB_TYPE_SOCK) &&
 441                         S_ISSOCK(buf.st_mode))
 442 #endif /* S_ISSOCK */
 443                 ) {
 444                 /* Do nothing -- this file is ok */
 445             } else {
 446 #ifdef S_ISLNK
 447                 if (types->type & TCL_GLOB_TYPE_LINK) {
 448                     if (TclOSlstat(nativeEntry, &buf) == 0) {
 449                         if (S_ISLNK(buf.st_mode)) {
 450                             return 1;
 451                         }
 452                     }
 453                 }
 454 #endif /* S_ISLNK */
 455                 return 0;
 456             }
 457         }
 458     }
 459     return 1;
 460 }
 461 \f
 462 /*
 463  *---------------------------------------------------------------------------
 464  *
 465  * TclpGetUserHome --
 466  *
 467  *      This function takes the specified user name and finds their
 468  *      home directory.
 469  *
 470  * Results:
 471  *      The result is a pointer to a string specifying the user's home
 472  *      directory, or NULL if the user's home directory could not be
 473  *      determined.  Storage for the result string is allocated in
 474  *      bufferPtr; the caller must call Tcl_DStringFree() when the result
 475  *      is no longer needed.
 476  *
 477  * Side effects:
 478  *      None.
 479  *
 480  *----------------------------------------------------------------------
 481  */
 482
 483 char *
 484 TclpGetUserHome(name, bufferPtr)
 485     CONST char *name;           /* User name for desired home directory. */
 486     Tcl_DString *bufferPtr;     /* Uninitialized or free DString filled
 487                                  * with name of user's home directory. */
 488 {
 489     struct passwd *pwPtr;
 490     Tcl_DString ds;
 491     CONST char *native;
 492
 493     native = Tcl_UtfToExternalDString(NULL, name, -1, &ds);
 494     pwPtr = getpwnam(native);                           /* INTL: Native. */
 495     Tcl_DStringFree(&ds);
 496
 497     if (pwPtr == NULL) {
 498         endpwent();
 499         return NULL;
 500     }
 501     Tcl_ExternalToUtfDString(NULL, pwPtr->pw_dir, -1, bufferPtr);
 502     endpwent();
 503     return Tcl_DStringValue(bufferPtr);
 504 }
 505 \f
 506 /*
 507  *---------------------------------------------------------------------------
 508  *
 509  * TclpObjAccess --
 510  *
 511  *      This function replaces the library version of access().
 512  *
 513  * Results:
 514  *      See access() documentation.
 515  *
 516  * Side effects:
 517  *      See access() documentation.
 518  *
 519  *---------------------------------------------------------------------------
 520  */
 521
 522 int
 523 TclpObjAccess(pathPtr, mode)
 524     Tcl_Obj *pathPtr;        /* Path of file to access */
 525     int mode;                /* Permission setting. */
 526 {
 527     CONST char *path = Tcl_FSGetNativePath(pathPtr);
 528     if (path == NULL) {
 529         return -1;
 530     } else {
 531         return access(path, mode);
 532     }
 533 }
 534 \f
 535 /*
 536  *---------------------------------------------------------------------------
 537  *
 538  * TclpObjChdir --
 539  *
 540  *      This function replaces the library version of chdir().
 541  *
 542  * Results:
 543  *      See chdir() documentation.
 544  *
 545  * Side effects:
 546  *      See chdir() documentation.
 547  *
 548  *---------------------------------------------------------------------------
 549  */
 550
 551 int
 552 TclpObjChdir(pathPtr)
 553     Tcl_Obj *pathPtr;          /* Path to new working directory */
 554 {
 555     CONST char *path = Tcl_FSGetNativePath(pathPtr);
 556     if (path == NULL) {
 557         return -1;
 558     } else {
 559         return chdir(path);
 560     }
 561 }
 562 \f
 563 /*
 564  *----------------------------------------------------------------------
 565  *
 566  * TclpObjLstat --
 567  *
 568  *      This function replaces the library version of lstat().
 569  *
 570  * Results:
 571  *      See lstat() documentation.
 572  *
 573  * Side effects:
 574  *      See lstat() documentation.
 575  *
 576  *----------------------------------------------------------------------
 577  */
 578
 579 int
 580 TclpObjLstat(pathPtr, bufPtr)
 581     Tcl_Obj *pathPtr;           /* Path of file to stat */
 582     Tcl_StatBuf *bufPtr;        /* Filled with results of stat call. */
 583 {
 584     return TclOSlstat(Tcl_FSGetNativePath(pathPtr), bufPtr);
 585 }
 586 \f
 587 /*
 588  *---------------------------------------------------------------------------
 589  *
 590  * TclpObjGetCwd --
 591  *
 592  *      This function replaces the library version of getcwd().
 593  *
 594  * Results:
 595  *      The result is a pointer to a string specifying the current
 596  *      directory, or NULL if the current directory could not be
 597  *      determined.  If NULL is returned, an error message is left in the
 598  *      interp's result.  Storage for the result string is allocated in
 599  *      bufferPtr; the caller must call Tcl_DStringFree() when the result
 600  *      is no longer needed.
 601  *
 602  * Side effects:
 603  *      None.
 604  *
 605  *----------------------------------------------------------------------
 606  */
 607
 608 Tcl_Obj*
 609 TclpObjGetCwd(interp)
 610     Tcl_Interp *interp;
 611 {
 612     Tcl_DString ds;
 613     if (TclpGetCwd(interp, &ds) != NULL) {
 614         Tcl_Obj *cwdPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1);
 615         Tcl_IncrRefCount(cwdPtr);
 616         Tcl_DStringFree(&ds);
 617         return cwdPtr;
 618     } else {
 619         return NULL;
 620     }
 621 }
 622
 623 /* Older string based version */
 624 CONST char *
 625 TclpGetCwd(interp, bufferPtr)
 626     Tcl_Interp *interp;         /* If non-NULL, used for error reporting. */
 627     Tcl_DString *bufferPtr;     /* Uninitialized or free DString filled
 628                                  * with name of current directory. */
 629 {
 630     char buffer[MAXPATHLEN+1];
 631
 632 #ifdef USEGETWD
 633     if (getwd(buffer) == NULL) {                        /* INTL: Native. */
 634 #else
 635     if (getcwd(buffer, MAXPATHLEN + 1) == NULL) {       /* INTL: Native. */
 636 #endif
 637         if (interp != NULL) {
 638             Tcl_AppendResult(interp,
 639                     "error getting working directory name: ",
 640                     Tcl_PosixError(interp), (char *) NULL);
 641         }
 642         return NULL;
 643     }
 644     return Tcl_ExternalToUtfDString(NULL, buffer, -1, bufferPtr);
 645 }
 646 \f
 647 /*
 648  *---------------------------------------------------------------------------
 649  *
 650  * TclpReadlink --
 651  *
 652  *      This function replaces the library version of readlink().
 653  *
 654  * Results:
 655  *      The result is a pointer to a string specifying the contents
 656  *      of the symbolic link given by 'path', or NULL if the symbolic
 657  *      link could not be read.  Storage for the result string is
 658  *      allocated in bufferPtr; the caller must call Tcl_DStringFree()
 659  *      when the result is no longer needed.
 660  *
 661  * Side effects:
 662  *      See readlink() documentation.
 663  *
 664  *---------------------------------------------------------------------------
 665  */
 666
 667 char *
 668 TclpReadlink(path, linkPtr)
 669     CONST char *path;           /* Path of file to readlink (UTF-8). */
 670     Tcl_DString *linkPtr;       /* Uninitialized or free DString filled
 671                                  * with contents of link (UTF-8). */
 672 {
 673 #ifndef DJGPP
 674     char link[MAXPATHLEN];
 675     int length;
 676     CONST char *native;
 677     Tcl_DString ds;
 678
 679     native = Tcl_UtfToExternalDString(NULL, path, -1, &ds);
 680     length = readlink(native, link, sizeof(link));      /* INTL: Native. */
 681     Tcl_DStringFree(&ds);
 682
 683     if (length < 0) {
 684         return NULL;
 685     }
 686
 687     Tcl_ExternalToUtfDString(NULL, link, length, linkPtr);
 688     return Tcl_DStringValue(linkPtr);
 689 #else
 690     return NULL;
 691 #endif
 692 }
 693 \f
 694 /*
 695  *----------------------------------------------------------------------
 696  *
 697  * TclpObjStat --
 698  *
 699  *      This function replaces the library version of stat().
 700  *
 701  * Results:
 702  *      See stat() documentation.
 703  *
 704  * Side effects:
 705  *      See stat() documentation.
 706  *
 707  *----------------------------------------------------------------------
 708  */
 709
 710 int
 711 TclpObjStat(pathPtr, bufPtr)
 712     Tcl_Obj *pathPtr;           /* Path of file to stat */
 713     Tcl_StatBuf *bufPtr;        /* Filled with results of stat call. */
 714 {
 715     CONST char *path = Tcl_FSGetNativePath(pathPtr);
 716     if (path == NULL) {
 717         return -1;
 718     } else {
 719         return TclOSstat(path, bufPtr);
 720     }
 721 }
 722 \f
 723
 724 #ifdef S_IFLNK
 725
 726 Tcl_Obj*
 727 TclpObjLink(pathPtr, toPtr, linkAction)
 728     Tcl_Obj *pathPtr;
 729     Tcl_Obj *toPtr;
 730     int linkAction;
 731 {
 732     if (toPtr != NULL) {
 733         CONST char *src = Tcl_FSGetNativePath(pathPtr);
 734         CONST char *target = Tcl_FSGetNativePath(toPtr);
 735
 736         if (src == NULL || target == NULL) {
 737             return NULL;
 738         }
 739         if (access(src, F_OK) != -1) {
 740             /* src exists */
 741             errno = EEXIST;
 742             return NULL;
 743         }
 744         if (access(target, F_OK) == -1) {
 745             /* target doesn't exist */
 746             errno = ENOENT;
 747             return NULL;
 748         }
 749         /*
 750          * Check symbolic link flag first, since we prefer to
 751          * create these.
 752          */
 753         if (linkAction & TCL_CREATE_SYMBOLIC_LINK) {
 754             if (symlink(target, src) != 0) return NULL;
 755         } else if (linkAction & TCL_CREATE_HARD_LINK) {
 756             if (link(target, src) != 0) return NULL;
 757         } else {
 758             errno = ENODEV;
 759             return NULL;
 760         }
 761         return toPtr;
 762     } else {
 763         Tcl_Obj* linkPtr = NULL;
 764
 765         char link[MAXPATHLEN];
 766         int length;
 767         Tcl_DString ds;
 768
 769         if (Tcl_FSGetTranslatedPath(NULL, pathPtr) == NULL) {
 770             return NULL;
 771         }
 772         length = readlink(Tcl_FSGetNativePath(pathPtr), link, sizeof(link));
 773         if (length < 0) {
 774             return NULL;
 775         }
 776
 777         Tcl_ExternalToUtfDString(NULL, link, length, &ds);
 778         linkPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds),
 779                                    Tcl_DStringLength(&ds));
 780         Tcl_DStringFree(&ds);
 781         if (linkPtr != NULL) {
 782             Tcl_IncrRefCount(linkPtr);
 783         }
 784         return linkPtr;
 785     }
 786 }
 787
 788 #endif
 789
 790 \f
 791 /*
 792  *---------------------------------------------------------------------------
 793  *
 794  * TclpFilesystemPathType --
 795  *
 796  *      This function is part of the native filesystem support, and
 797  *      returns the path type of the given path.  Right now it simply
 798  *      returns NULL.  In the future it could return specific path
 799  *      types, like 'nfs', 'samba', 'FAT32', etc.
 800  *
 801  * Results:
 802  *      NULL at present.
 803  *
 804  * Side effects:
 805  *      None.
 806  *
 807  *---------------------------------------------------------------------------
 808  */
 809 Tcl_Obj*
 810 TclpFilesystemPathType(pathObjPtr)
 811     Tcl_Obj* pathObjPtr;
 812 {
 813     /* All native paths are of the same type */
 814     return NULL;
 815 }