util/src/TclTk/tcl8.6.12/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
  13 #include "tclInt.h"
  14 #include "tclFileSystem.h"
  15
  16 static int NativeMatchType(Tcl_Interp *interp, const char* nativeEntry,
  17         const char* nativeName, Tcl_GlobTypeData *types);
  18 \f
  19 /*
  20  *---------------------------------------------------------------------------
  21  *
  22  * TclpFindExecutable --
  23  *
  24  *      This function computes the absolute path name of the current
  25  *      application, given its argv[0] value. For Cygwin, argv[0] is
  26  *      ignored and the path is determined the same as under win32.
  27  *
  28  * Results:
  29  *      None.
  30  *
  31  * Side effects:
  32  *      The computed path name is stored as a ProcessGlobalValue.
  33  *
  34  *---------------------------------------------------------------------------
  35  */
  36
  37 void
  38 TclpFindExecutable(
  39     const char *argv0)          /* The value of the application's argv[0]
  40                                  * (native). */
  41 {
  42     Tcl_Encoding encoding;
  43 #ifdef __CYGWIN__
  44     int length;
  45     wchar_t buf[PATH_MAX] = L"";
  46     char name[PATH_MAX * 3 + 1];
  47
  48     GetModuleFileNameW(NULL, buf, PATH_MAX);
  49     cygwin_conv_path(3, buf, name, sizeof(name));
  50     length = strlen(name);
  51     if ((length > 4) && !strcasecmp(name + length - 4, ".exe")) {
  52         /* Strip '.exe' part. */
  53         length -= 4;
  54     }
  55     encoding = Tcl_GetEncoding(NULL, NULL);
  56     TclSetObjNameOfExecutable(
  57             Tcl_NewStringObj(name, length), encoding);
  58 #else
  59     const char *name, *p;
  60     Tcl_StatBuf statBuf;
  61     Tcl_DString buffer, nameString, cwd, utfName;
  62
  63     if (argv0 == NULL) {
  64         return;
  65     }
  66     Tcl_DStringInit(&buffer);
  67
  68     name = argv0;
  69     for (p = name; *p != '\0'; p++) {
  70         if (*p == '/') {
  71             /*
  72              * The name contains a slash, so use the name directly without
  73              * doing a path search.
  74              */
  75
  76             goto gotName;
  77         }
  78     }
  79
  80     p = getenv("PATH");                                 /* INTL: Native. */
  81     if (p == NULL) {
  82         /*
  83          * There's no PATH environment variable; use the default that is used
  84          * by sh.
  85          */
  86
  87         p = ":/bin:/usr/bin";
  88     } else if (*p == '\0') {
  89         /*
  90          * An empty path is equivalent to ".".
  91          */
  92
  93         p = "./";
  94     }
  95
  96     /*
  97      * Search through all the directories named in the PATH variable to see if
  98      * argv[0] is in one of them. If so, use that file name.
  99      */
 100
 101     while (1) {
 102         while (TclIsSpaceProcM(*p)) {
 103             p++;
 104         }
 105         name = p;
 106         while ((*p != ':') && (*p != 0)) {
 107             p++;
 108         }
 109         TclDStringClear(&buffer);
 110         if (p != name) {
 111             Tcl_DStringAppend(&buffer, name, p - name);
 112             if (p[-1] != '/') {
 113                 TclDStringAppendLiteral(&buffer, "/");
 114             }
 115         }
 116         name = Tcl_DStringAppend(&buffer, argv0, -1);
 117
 118         /*
 119          * INTL: The following calls to access() and stat() should not be
 120          * converted to Tclp routines because they need to operate on native
 121          * strings directly.
 122          */
 123
 124         if ((access(name, X_OK) == 0)                   /* INTL: Native. */
 125                 && (TclOSstat(name, &statBuf) == 0)     /* INTL: Native. */
 126                 && S_ISREG(statBuf.st_mode)) {
 127             goto gotName;
 128         }
 129         if (*p == '\0') {
 130             break;
 131         } else if (*(p+1) == 0) {
 132             p = "./";
 133         } else {
 134             p++;
 135         }
 136     }
 137     TclSetObjNameOfExecutable(Tcl_NewObj(), NULL);
 138     goto done;
 139
 140     /*
 141      * If the name starts with "/" then just store it
 142      */
 143
 144   gotName:
 145 #ifdef DJGPP
 146     if (name[1] == ':')
 147 #else
 148     if (name[0] == '/')
 149 #endif
 150     {
 151         encoding = Tcl_GetEncoding(NULL, NULL);
 152         Tcl_ExternalToUtfDString(encoding, name, -1, &utfName);
 153         TclSetObjNameOfExecutable(
 154                 Tcl_NewStringObj(Tcl_DStringValue(&utfName), -1), encoding);
 155         Tcl_DStringFree(&utfName);
 156         goto done;
 157     }
 158
 159     if (TclpGetCwd(NULL, &cwd) == NULL) {
 160         TclSetObjNameOfExecutable(Tcl_NewObj(), NULL);
 161         goto done;
 162     }
 163
 164     /*
 165      * The name is relative to the current working directory. First strip off
 166      * a leading "./", if any, then add the full path name of the current
 167      * working directory.
 168      */
 169
 170     if ((name[0] == '.') && (name[1] == '/')) {
 171         name += 2;
 172     }
 173
 174     Tcl_DStringInit(&nameString);
 175     Tcl_DStringAppend(&nameString, name, -1);
 176
 177     Tcl_DStringFree(&buffer);
 178     Tcl_UtfToExternalDString(NULL, Tcl_DStringValue(&cwd),
 179             Tcl_DStringLength(&cwd), &buffer);
 180     if (Tcl_DStringValue(&cwd)[Tcl_DStringLength(&cwd) -1] != '/') {
 181         TclDStringAppendLiteral(&buffer, "/");
 182     }
 183     Tcl_DStringFree(&cwd);
 184     TclDStringAppendDString(&buffer, &nameString);
 185     Tcl_DStringFree(&nameString);
 186
 187     encoding = Tcl_GetEncoding(NULL, NULL);
 188     Tcl_ExternalToUtfDString(encoding, Tcl_DStringValue(&buffer), -1,
 189             &utfName);
 190     TclSetObjNameOfExecutable(
 191             Tcl_NewStringObj(Tcl_DStringValue(&utfName), -1), encoding);
 192     Tcl_DStringFree(&utfName);
 193
 194   done:
 195     Tcl_DStringFree(&buffer);
 196 #endif
 197 }
 198 \f
 199 /*
 200  *----------------------------------------------------------------------
 201  *
 202  * TclpMatchInDirectory --
 203  *
 204  *      This routine is used by the globbing code to search a directory for
 205  *      all files which match a given pattern.
 206  *
 207  * Results:
 208  *      The return value is a standard Tcl result indicating whether an error
 209  *      occurred in globbing. Errors are left in interp, good results are
 210  *      [lappend]ed to resultPtr (which must be a valid object).
 211  *
 212  * Side effects:
 213  *      None.
 214  *
 215  *----------------------------------------------------------------------
 216  */
 217
 218 int
 219 TclpMatchInDirectory(
 220     Tcl_Interp *interp,         /* Interpreter to receive errors. */
 221     Tcl_Obj *resultPtr,         /* List object to lappend results. */
 222     Tcl_Obj *pathPtr,           /* Contains path to directory to search. */
 223     const char *pattern,        /* Pattern to match against. */
 224     Tcl_GlobTypeData *types)    /* Object containing list of acceptable types.
 225                                  * May be NULL. In particular the directory
 226                                  * flag is very important. */
 227 {
 228     const char *native;
 229     Tcl_Obj *fileNamePtr;
 230     int matchResult = 0;
 231
 232     if (types != NULL && types->type == TCL_GLOB_TYPE_MOUNT) {
 233         /*
 234          * The native filesystem never adds mounts.
 235          */
 236
 237         return TCL_OK;
 238     }
 239
 240     fileNamePtr = Tcl_FSGetTranslatedPath(interp, pathPtr);
 241     if (fileNamePtr == NULL) {
 242         return TCL_ERROR;
 243     }
 244
 245     if (pattern == NULL || (*pattern == '\0')) {
 246         /*
 247          * Match a file directly.
 248          */
 249
 250         Tcl_Obj *tailPtr;
 251         const char *nativeTail;
 252
 253         native = (const char *)Tcl_FSGetNativePath(pathPtr);
 254         tailPtr = TclPathPart(interp, pathPtr, TCL_PATH_TAIL);
 255         nativeTail = (const char *)Tcl_FSGetNativePath(tailPtr);
 256         matchResult = NativeMatchType(interp, native, nativeTail, types);
 257         if (matchResult == 1) {
 258             Tcl_ListObjAppendElement(interp, resultPtr, pathPtr);
 259         }
 260         Tcl_DecrRefCount(tailPtr);
 261         Tcl_DecrRefCount(fileNamePtr);
 262     } else {
 263         TclDIR *d;
 264         Tcl_DirEntry *entryPtr;
 265         const char *dirName;
 266         int dirLength, nativeDirLen;
 267         int matchHidden, matchHiddenPat;
 268         Tcl_StatBuf statBuf;
 269         Tcl_DString ds;         /* native encoding of dir */
 270         Tcl_DString dsOrig;     /* utf-8 encoding of dir */
 271
 272         Tcl_DStringInit(&dsOrig);
 273         dirName = Tcl_GetStringFromObj(fileNamePtr, &dirLength);
 274         Tcl_DStringAppend(&dsOrig, dirName, dirLength);
 275
 276         /*
 277          * Make sure that the directory part of the name really is a
 278          * directory. If the directory name is "", use the name "." instead,
 279          * because some UNIX systems don't treat "" like "." automatically.
 280          * Keep the "" for use in generating file names, otherwise "glob
 281          * foo.c" would return "./foo.c".
 282          */
 283
 284         if (dirLength == 0) {
 285             dirName = ".";
 286         } else {
 287             dirName = Tcl_DStringValue(&dsOrig);
 288
 289             /*
 290              * Make sure we have a trailing directory delimiter.
 291              */
 292
 293             if (dirName[dirLength-1] != '/') {
 294                 dirName = TclDStringAppendLiteral(&dsOrig, "/");
 295                 dirLength++;
 296             }
 297         }
 298
 299         /*
 300          * Now open the directory for reading and iterate over the contents.
 301          */
 302
 303         native = Tcl_UtfToExternalDString(NULL, dirName, -1, &ds);
 304
 305         if ((TclOSstat(native, &statBuf) != 0)          /* INTL: Native. */
 306                 || !S_ISDIR(statBuf.st_mode)) {
 307             Tcl_DStringFree(&dsOrig);
 308             Tcl_DStringFree(&ds);
 309             Tcl_DecrRefCount(fileNamePtr);
 310             return TCL_OK;
 311         }
 312
 313         d = TclOSopendir(native);                               /* INTL: Native. */
 314         if (d == NULL) {
 315             Tcl_DStringFree(&ds);
 316             if (interp != NULL) {
 317                 Tcl_SetObjResult(interp, Tcl_ObjPrintf(
 318                         "couldn't read directory \"%s\": %s",
 319                         Tcl_DStringValue(&dsOrig), Tcl_PosixError(interp)));
 320             }
 321             Tcl_DStringFree(&dsOrig);
 322             Tcl_DecrRefCount(fileNamePtr);
 323             return TCL_ERROR;
 324         }
 325
 326         nativeDirLen = Tcl_DStringLength(&ds);
 327
 328         /*
 329          * Check to see if -type or the pattern requests hidden files.
 330          */
 331
 332         matchHiddenPat = (pattern[0] == '.')
 333                 || ((pattern[0] == '\\') && (pattern[1] == '.'));
 334         matchHidden = matchHiddenPat
 335                 || (types && (types->perm & TCL_GLOB_PERM_HIDDEN));
 336         while ((entryPtr = TclOSreaddir(d)) != NULL) {  /* INTL: Native. */
 337             Tcl_DString utfDs;
 338             const char *utfname;
 339
 340             /*
 341              * Skip this file if it doesn't agree with the hidden parameters
 342              * requested by the user (via -type or pattern).
 343              */
 344
 345             if (*entryPtr->d_name == '.') {
 346                 if (!matchHidden) {
 347                     continue;
 348                 }
 349             } else {
 350 #ifdef MAC_OSX_TCL
 351                 if (matchHiddenPat) {
 352                     continue;
 353                 }
 354                 /* Also need to check HFS hidden flag in TclMacOSXMatchType. */
 355 #else
 356                 if (matchHidden) {
 357                     continue;
 358                 }
 359 #endif
 360             }
 361
 362             /*
 363              * Now check to see if the file matches, according to both type
 364              * and pattern. If so, add the file to the result.
 365              */
 366
 367             utfname = Tcl_ExternalToUtfDString(NULL, entryPtr->d_name, -1,
 368                     &utfDs);
 369             if (Tcl_StringCaseMatch(utfname, pattern, 0)) {
 370                 int typeOk = 1;
 371
 372                 if (types != NULL) {
 373                     Tcl_DStringSetLength(&ds, nativeDirLen);
 374                     native = Tcl_DStringAppend(&ds, entryPtr->d_name, -1);
 375                     matchResult = NativeMatchType(interp, native,
 376                             entryPtr->d_name, types);
 377                     typeOk = (matchResult == 1);
 378                 }
 379                 if (typeOk) {
 380                     Tcl_ListObjAppendElement(interp, resultPtr,
 381                             TclNewFSPathObj(pathPtr, utfname,
 382                             Tcl_DStringLength(&utfDs)));
 383                 }
 384             }
 385             Tcl_DStringFree(&utfDs);
 386             if (matchResult < 0) {
 387                 break;
 388             }
 389         }
 390
 391         TclOSclosedir(d);
 392         Tcl_DStringFree(&ds);
 393         Tcl_DStringFree(&dsOrig);
 394         Tcl_DecrRefCount(fileNamePtr);
 395     }
 396     if (matchResult < 0) {
 397         return TCL_ERROR;
 398     }
 399     return TCL_OK;
 400 }
 401 \f
 402 /*
 403  *----------------------------------------------------------------------
 404  *
 405  * NativeMatchType --
 406  *
 407  *      This routine is used by the globbing code to check if a file matches a
 408  *      given type description.
 409  *
 410  * Results:
 411  *      The return value is 1, 0 or -1 indicating whether the file matches the
 412  *      given criteria, does not match them, or an error occurred (in which
 413  *      case an error is left in interp).
 414  *
 415  * Side effects:
 416  *      None.
 417  *
 418  *----------------------------------------------------------------------
 419  */
 420
 421 static int
 422 NativeMatchType(
 423     Tcl_Interp *interp,       /* Interpreter to receive errors. */
 424     const char *nativeEntry,  /* Native path to check. */
 425     const char *nativeName,   /* Native filename to check. */
 426     Tcl_GlobTypeData *types)  /* Type description to match against. */
 427 {
 428     Tcl_StatBuf buf;
 429
 430     if (types == NULL) {
 431         /*
 432          * Simply check for the file's existence, but do it with lstat, in
 433          * case it is a link to a file which doesn't exist (since that case
 434          * would not show up if we used 'access' or 'stat')
 435          */
 436
 437         if (TclOSlstat(nativeEntry, &buf) != 0) {
 438             return 0;
 439         }
 440         return 1;
 441     }
 442
 443     if (types->perm != 0) {
 444         if (TclOSstat(nativeEntry, &buf) != 0) {
 445             /*
 446              * Either the file has disappeared between the 'readdir' call and
 447              * the 'stat' call, or the file is a link to a file which doesn't
 448              * exist (which we could ascertain with lstat), or there is some
 449              * other strange problem. In all these cases, we define this to
 450              * mean the file does not match any defined permission, and
 451              * therefore it is not added to the list of files to return.
 452              */
 453
 454             return 0;
 455         }
 456
 457         /*
 458          * readonly means that there are NO write permissions (even for user),
 459          * but execute is OK for anybody OR that the user immutable flag is
 460          * set (where supported).
 461          */
 462
 463         if (((types->perm & TCL_GLOB_PERM_RONLY) &&
 464 #if defined(HAVE_CHFLAGS) && defined(UF_IMMUTABLE)
 465                 !(buf.st_flags & UF_IMMUTABLE) &&
 466 #endif
 467                 (buf.st_mode & (S_IWOTH|S_IWGRP|S_IWUSR))) ||
 468             ((types->perm & TCL_GLOB_PERM_R) &&
 469                 (access(nativeEntry, R_OK) != 0)) ||
 470             ((types->perm & TCL_GLOB_PERM_W) &&
 471                 (access(nativeEntry, W_OK) != 0)) ||
 472             ((types->perm & TCL_GLOB_PERM_X) &&
 473                 (access(nativeEntry, X_OK) != 0))
 474 #ifndef MAC_OSX_TCL
 475             || ((types->perm & TCL_GLOB_PERM_HIDDEN) &&
 476                 (*nativeName != '.'))
 477 #endif /* MAC_OSX_TCL */
 478                 ) {
 479             return 0;
 480         }
 481     }
 482     if (types->type != 0) {
 483         if (types->perm == 0) {
 484             /*
 485              * We haven't yet done a stat on the file.
 486              */
 487
 488             if (TclOSstat(nativeEntry, &buf) != 0) {
 489                 /*
 490                  * Posix error occurred. The only ok case is if this is a link
 491                  * to a nonexistent file, and the user did 'glob -l'. So we
 492                  * check that here:
 493                  */
 494
 495                 if ((types->type & TCL_GLOB_TYPE_LINK)
 496                         && (TclOSlstat(nativeEntry, &buf) == 0)
 497                         && S_ISLNK(buf.st_mode)) {
 498                     return 1;
 499                 }
 500                 return 0;
 501             }
 502         }
 503
 504         /*
 505          * In order bcdpsfl as in 'find -t'
 506          */
 507
 508         if (    ((types->type & TCL_GLOB_TYPE_BLOCK)&& S_ISBLK(buf.st_mode)) ||
 509                 ((types->type & TCL_GLOB_TYPE_CHAR) && S_ISCHR(buf.st_mode)) ||
 510                 ((types->type & TCL_GLOB_TYPE_DIR)  && S_ISDIR(buf.st_mode)) ||
 511                 ((types->type & TCL_GLOB_TYPE_PIPE) && S_ISFIFO(buf.st_mode))||
 512 #ifdef S_ISSOCK
 513                 ((types->type & TCL_GLOB_TYPE_SOCK) && S_ISSOCK(buf.st_mode))||
 514 #endif /* S_ISSOCK */
 515                 ((types->type & TCL_GLOB_TYPE_FILE) && S_ISREG(buf.st_mode))) {
 516             /*
 517              * Do nothing - this file is ok.
 518              */
 519         } else {
 520 #ifdef S_ISLNK
 521             if ((types->type & TCL_GLOB_TYPE_LINK)
 522                     && (TclOSlstat(nativeEntry, &buf) == 0)
 523                     && S_ISLNK(buf.st_mode)) {
 524                 goto filetypeOK;
 525             }
 526 #endif /* S_ISLNK */
 527             return 0;
 528         }
 529     }
 530   filetypeOK:
 531
 532     /*
 533      * If we're on OSX, we also have to worry about matching the file creator
 534      * code (if specified). Do that now.
 535      */
 536
 537 #ifdef MAC_OSX_TCL
 538     if (types->macType != NULL || types->macCreator != NULL ||
 539             (types->perm & TCL_GLOB_PERM_HIDDEN)) {
 540         int matchResult;
 541
 542         if (types->perm == 0 && types->type == 0) {
 543             /*
 544              * We haven't yet done a stat on the file.
 545              */
 546
 547             if (TclOSstat(nativeEntry, &buf) != 0) {
 548                 return 0;
 549             }
 550         }
 551
 552         matchResult = TclMacOSXMatchType(interp, nativeEntry, nativeName,
 553                 &buf, types);
 554         if (matchResult != 1) {
 555             return matchResult;
 556         }
 557     }
 558 #endif /* MAC_OSX_TCL */
 559
 560     return 1;
 561 }
 562 \f
 563 /*
 564  *---------------------------------------------------------------------------
 565  *
 566  * TclpGetUserHome --
 567  *
 568  *      This function takes the specified user name and finds their home
 569  *      directory.
 570  *
 571  * Results:
 572  *      The result is a pointer to a string specifying the user's home
 573  *      directory, or NULL if the user's home directory could not be
 574  *      determined. Storage for the result string is allocated in bufferPtr;
 575  *      the caller must call Tcl_DStringFree() when the result is no longer
 576  *      needed.
 577  *
 578  * Side effects:
 579  *      None.
 580  *
 581  *----------------------------------------------------------------------
 582  */
 583
 584 const char *
 585 TclpGetUserHome(
 586     const char *name,           /* User name for desired home directory. */
 587     Tcl_DString *bufferPtr)     /* Uninitialized or free DString filled with
 588                                  * name of user's home directory. */
 589 {
 590     struct passwd *pwPtr;
 591     Tcl_DString ds;
 592     const char *native = Tcl_UtfToExternalDString(NULL, name, -1, &ds);
 593
 594     pwPtr = TclpGetPwNam(native);                       /* INTL: Native. */
 595     Tcl_DStringFree(&ds);
 596
 597     if (pwPtr == NULL) {
 598         return NULL;
 599     }
 600     Tcl_ExternalToUtfDString(NULL, pwPtr->pw_dir, -1, bufferPtr);
 601     return Tcl_DStringValue(bufferPtr);
 602 }
 603 \f
 604 /*
 605  *---------------------------------------------------------------------------
 606  *
 607  * TclpObjAccess --
 608  *
 609  *      This function replaces the library version of access().
 610  *
 611  * Results:
 612  *      See access() documentation.
 613  *
 614  * Side effects:
 615  *      See access() documentation.
 616  *
 617  *---------------------------------------------------------------------------
 618  */
 619
 620 int
 621 TclpObjAccess(
 622     Tcl_Obj *pathPtr,           /* Path of file to access */
 623     int mode)                   /* Permission setting. */
 624 {
 625     const char *path = Tcl_FSGetNativePath(pathPtr);
 626
 627     if (path == NULL) {
 628         return -1;
 629     }
 630     return access(path, mode);
 631 }
 632 \f
 633 /*
 634  *---------------------------------------------------------------------------
 635  *
 636  * TclpObjChdir --
 637  *
 638  *      This function replaces the library version of chdir().
 639  *
 640  * Results:
 641  *      See chdir() documentation.
 642  *
 643  * Side effects:
 644  *      See chdir() documentation.
 645  *
 646  *---------------------------------------------------------------------------
 647  */
 648
 649 int
 650 TclpObjChdir(
 651     Tcl_Obj *pathPtr)           /* Path to new working directory */
 652 {
 653     const char *path = (const char *)Tcl_FSGetNativePath(pathPtr);
 654
 655     if (path == NULL) {
 656         return -1;
 657     }
 658     return chdir(path);
 659 }
 660 \f
 661 /*
 662  *----------------------------------------------------------------------
 663  *
 664  * TclpObjLstat --
 665  *
 666  *      This function replaces the library version of lstat().
 667  *
 668  * Results:
 669  *      See lstat() documentation.
 670  *
 671  * Side effects:
 672  *      See lstat() documentation.
 673  *
 674  *----------------------------------------------------------------------
 675  */
 676
 677 int
 678 TclpObjLstat(
 679     Tcl_Obj *pathPtr,           /* Path of file to stat */
 680     Tcl_StatBuf *bufPtr)        /* Filled with results of stat call. */
 681 {
 682     return TclOSlstat((const char *)Tcl_FSGetNativePath(pathPtr), bufPtr);
 683 }
 684 \f
 685 /*
 686  *---------------------------------------------------------------------------
 687  *
 688  * TclpGetNativeCwd --
 689  *
 690  *      This function replaces the library version of getcwd().
 691  *
 692  * Results:
 693  *      The input and output are filesystem paths in native form. The result
 694  *      is either the given clientData, if the working directory hasn't
 695  *      changed, or a new clientData (owned by our caller), giving the new
 696  *      native path, or NULL if the current directory could not be determined.
 697  *      If NULL is returned, the caller can examine the standard posix error
 698  *      codes to determine the cause of the problem.
 699  *
 700  * Side effects:
 701  *      None.
 702  *
 703  *----------------------------------------------------------------------
 704  */
 705
 706 ClientData
 707 TclpGetNativeCwd(
 708     ClientData clientData)
 709 {
 710     char buffer[MAXPATHLEN+1];
 711
 712 #ifdef USEGETWD
 713     if (getwd(buffer) == NULL) {                        /* INTL: Native. */
 714         return NULL;
 715     }
 716 #else
 717     if (getcwd(buffer, MAXPATHLEN+1) == NULL) {         /* INTL: Native. */
 718         return NULL;
 719     }
 720 #endif /* USEGETWD */
 721
 722     if ((clientData == NULL) || strcmp(buffer, (const char *) clientData)) {
 723         char *newCd = (char*)ckalloc(strlen(buffer) + 1);
 724
 725         strcpy(newCd, buffer);
 726         return newCd;
 727     }
 728
 729     /*
 730      * No change to pwd.
 731      */
 732
 733     return clientData;
 734 }
 735 \f
 736 /*
 737  *---------------------------------------------------------------------------
 738  *
 739  * TclpGetCwd --
 740  *
 741  *      This function replaces the library version of getcwd(). (Obsolete
 742  *      function, only retained for old extensions which may call it
 743  *      directly).
 744  *
 745  * Results:
 746  *      The result is a pointer to a string specifying the current directory,
 747  *      or NULL if the current directory could not be determined. If NULL is
 748  *      returned, an error message is left in the interp's result. Storage for
 749  *      the result string is allocated in bufferPtr; the caller must call
 750  *      Tcl_DStringFree() when the result is no longer needed.
 751  *
 752  * Side effects:
 753  *      None.
 754  *
 755  *----------------------------------------------------------------------
 756  */
 757
 758 const char *
 759 TclpGetCwd(
 760     Tcl_Interp *interp,         /* If non-NULL, used for error reporting. */
 761     Tcl_DString *bufferPtr)     /* Uninitialized or free DString filled with
 762                                  * name of current directory. */
 763 {
 764     char buffer[MAXPATHLEN+1];
 765
 766 #ifdef USEGETWD
 767     if (getwd(buffer) == NULL)                          /* INTL: Native. */
 768 #else
 769     if (getcwd(buffer, MAXPATHLEN+1) == NULL)           /* INTL: Native. */
 770 #endif /* USEGETWD */
 771     {
 772         if (interp != NULL) {
 773             Tcl_SetObjResult(interp, Tcl_ObjPrintf(
 774                     "error getting working directory name: %s",
 775                     Tcl_PosixError(interp)));
 776         }
 777         return NULL;
 778     }
 779     return Tcl_ExternalToUtfDString(NULL, buffer, -1, bufferPtr);
 780 }
 781 \f
 782 /*
 783  *---------------------------------------------------------------------------
 784  *
 785  * TclpReadlink --
 786  *
 787  *      This function replaces the library version of readlink().
 788  *
 789  * Results:
 790  *      The result is a pointer to a string specifying the contents of the
 791  *      symbolic link given by 'path', or NULL if the symbolic link could not
 792  *      be read. Storage for the result string is allocated in bufferPtr; the
 793  *      caller must call Tcl_DStringFree() when the result is no longer
 794  *      needed.
 795  *
 796  * Side effects:
 797  *      See readlink() documentation.
 798  *
 799  *---------------------------------------------------------------------------
 800  */
 801
 802 char *
 803 TclpReadlink(
 804     const char *path,           /* Path of file to readlink (UTF-8). */
 805     Tcl_DString *linkPtr)       /* Uninitialized or free DString filled with
 806                                  * contents of link (UTF-8). */
 807 {
 808 #ifndef DJGPP
 809     char link[MAXPATHLEN];
 810     int length;
 811     const char *native;
 812     Tcl_DString ds;
 813
 814     native = Tcl_UtfToExternalDString(NULL, path, -1, &ds);
 815     length = readlink(native, link, sizeof(link));      /* INTL: Native. */
 816     Tcl_DStringFree(&ds);
 817
 818     if (length < 0) {
 819         return NULL;
 820     }
 821
 822     Tcl_ExternalToUtfDString(NULL, link, length, linkPtr);
 823     return Tcl_DStringValue(linkPtr);
 824 #else
 825     return NULL;
 826 #endif /* !DJGPP */
 827 }
 828 \f
 829 /*
 830  *----------------------------------------------------------------------
 831  *
 832  * TclpObjStat --
 833  *
 834  *      This function replaces the library version of stat().
 835  *
 836  * Results:
 837  *      See stat() documentation.
 838  *
 839  * Side effects:
 840  *      See stat() documentation.
 841  *
 842  *----------------------------------------------------------------------
 843  */
 844
 845 int
 846 TclpObjStat(
 847     Tcl_Obj *pathPtr,           /* Path of file to stat */
 848     Tcl_StatBuf *bufPtr)        /* Filled with results of stat call. */
 849 {
 850     const char *path = (const char *)Tcl_FSGetNativePath(pathPtr);
 851
 852     if (path == NULL) {
 853         return -1;
 854     }
 855     return TclOSstat(path, bufPtr);
 856 }
 857 \f
 858 #ifdef S_IFLNK
 859
 860 Tcl_Obj *
 861 TclpObjLink(
 862     Tcl_Obj *pathPtr,
 863     Tcl_Obj *toPtr,
 864     int linkAction)
 865 {
 866     if (toPtr != NULL) {
 867         const char *src = (const char *)Tcl_FSGetNativePath(pathPtr);
 868         const char *target = NULL;
 869
 870         if (src == NULL) {
 871             return NULL;
 872         }
 873
 874         /*
 875          * If we're making a symbolic link and the path is relative, then we
 876          * must check whether it exists _relative_ to the directory in which
 877          * the src is found (not relative to the current cwd which is just not
 878          * relevant in this case).
 879          *
 880          * If we're making a hard link, then a relative path is just converted
 881          * to absolute relative to the cwd.
 882          */
 883
 884         if ((linkAction & TCL_CREATE_SYMBOLIC_LINK)
 885                 && (Tcl_FSGetPathType(toPtr) == TCL_PATH_RELATIVE)) {
 886             Tcl_Obj *dirPtr, *absPtr;
 887
 888             dirPtr = TclPathPart(NULL, pathPtr, TCL_PATH_DIRNAME);
 889             if (dirPtr == NULL) {
 890                 return NULL;
 891             }
 892             absPtr = Tcl_FSJoinToPath(dirPtr, 1, &toPtr);
 893             Tcl_IncrRefCount(absPtr);
 894             if (Tcl_FSAccess(absPtr, F_OK) == -1) {
 895                 Tcl_DecrRefCount(absPtr);
 896                 Tcl_DecrRefCount(dirPtr);
 897
 898                 /*
 899                  * Target doesn't exist.
 900                  */
 901
 902                 errno = ENOENT;
 903                 return NULL;
 904             }
 905
 906             /*
 907              * Target exists; we'll construct the relative path we want below.
 908              */
 909
 910             Tcl_DecrRefCount(absPtr);
 911             Tcl_DecrRefCount(dirPtr);
 912         } else {
 913             target = (const char*)Tcl_FSGetNativePath(toPtr);
 914             if (target == NULL) {
 915                 return NULL;
 916             }
 917             if (access(target, F_OK) == -1) {
 918                 /*
 919                  * Target doesn't exist.
 920                  */
 921
 922                 errno = ENOENT;
 923                 return NULL;
 924             }
 925         }
 926
 927         if (access(src, F_OK) != -1) {
 928             /*
 929              * Src exists.
 930              */
 931
 932             errno = EEXIST;
 933             return NULL;
 934         }
 935
 936         /*
 937          * Check symbolic link flag first, since we prefer to create these.
 938          */
 939
 940         if (linkAction & TCL_CREATE_SYMBOLIC_LINK) {
 941             int targetLen;
 942             Tcl_DString ds;
 943             Tcl_Obj *transPtr;
 944
 945             /*
 946              * Now we don't want to link to the absolute, normalized path.
 947              * Relative links are quite acceptable (but links to ~user are not
 948              * -- these must be expanded first).
 949              */
 950
 951             transPtr = Tcl_FSGetTranslatedPath(NULL, toPtr);
 952             if (transPtr == NULL) {
 953                 return NULL;
 954             }
 955             target = Tcl_GetStringFromObj(transPtr, &targetLen);
 956             target = Tcl_UtfToExternalDString(NULL, target, targetLen, &ds);
 957             Tcl_DecrRefCount(transPtr);
 958
 959             if (symlink(target, src) != 0) {
 960                 toPtr = NULL;
 961             }
 962             Tcl_DStringFree(&ds);
 963         } else if (linkAction & TCL_CREATE_HARD_LINK) {
 964             if (link(target, src) != 0) {
 965                 return NULL;
 966             }
 967         } else {
 968             errno = ENODEV;
 969             return NULL;
 970         }
 971         return toPtr;
 972     } else {
 973         Tcl_Obj *linkPtr = NULL;
 974
 975         char link[MAXPATHLEN];
 976         int length;
 977         Tcl_DString ds;
 978         Tcl_Obj *transPtr;
 979
 980         transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr);
 981         if (transPtr == NULL) {
 982             return NULL;
 983         }
 984         Tcl_DecrRefCount(transPtr);
 985
 986         length = readlink((const char *)Tcl_FSGetNativePath(pathPtr), link, sizeof(link));
 987         if (length < 0) {
 988             return NULL;
 989         }
 990
 991         Tcl_ExternalToUtfDString(NULL, link, length, &ds);
 992         linkPtr = TclDStringToObj(&ds);
 993         Tcl_IncrRefCount(linkPtr);
 994         return linkPtr;
 995     }
 996 }
 997 #endif /* S_IFLNK */
 998 \f
 999 /*
1000  *---------------------------------------------------------------------------
1001  *
1002  * TclpFilesystemPathType --
1003  *
1004  *      This function is part of the native filesystem support, and returns
1005  *      the path type of the given path. Right now it simply returns NULL. In
1006  *      the future it could return specific path types, like 'nfs', 'samba',
1007  *      'FAT32', etc.
1008  *
1009  * Results:
1010  *      NULL at present.
1011  *
1012  * Side effects:
1013  *      None.
1014  *
1015  *---------------------------------------------------------------------------
1016  */
1017
1018 Tcl_Obj *
1019 TclpFilesystemPathType(
1020     Tcl_Obj *pathPtr)
1021 {
1022     /*
1023      * All native paths are of the same type.
1024      */
1025
1026     return NULL;
1027 }
1028 \f
1029 /*
1030  *---------------------------------------------------------------------------
1031  *
1032  * TclpNativeToNormalized --
1033  *
1034  *      Convert native format to a normalized path object, with refCount of
1035  *      zero.
1036  *
1037  *      Currently assumes all native paths are actually normalized already, so
1038  *      if the path given is not normalized this will actually just convert to
1039  *      a valid string path, but not necessarily a normalized one.
1040  *
1041  * Results:
1042  *      A valid normalized path.
1043  *
1044  * Side effects:
1045  *      None.
1046  *
1047  *---------------------------------------------------------------------------
1048  */
1049
1050 Tcl_Obj *
1051 TclpNativeToNormalized(
1052     ClientData clientData)
1053 {
1054     Tcl_DString ds;
1055
1056     Tcl_ExternalToUtfDString(NULL, (const char *) clientData, -1, &ds);
1057     return TclDStringToObj(&ds);
1058 }
1059 \f
1060 /*
1061  *---------------------------------------------------------------------------
1062  *
1063  * TclNativeCreateNativeRep --
1064  *
1065  *      Create a native representation for the given path.
1066  *
1067  * Results:
1068  *      The nativePath representation.
1069  *
1070  * Side effects:
1071  *      Memory will be allocated. The path may need to be normalized.
1072  *
1073  *---------------------------------------------------------------------------
1074  */
1075
1076 ClientData
1077 TclNativeCreateNativeRep(
1078     Tcl_Obj *pathPtr)
1079 {
1080     char *nativePathPtr;
1081     const char *str;
1082     Tcl_DString ds;
1083     Tcl_Obj *validPathPtr;
1084     int len;
1085
1086     if (TclFSCwdIsNative()) {
1087         /*
1088          * The cwd is native, which means we can use the translated path
1089          * without worrying about normalization (this will also usually be
1090          * shorter so the utf-to-external conversion will be somewhat faster).
1091          */
1092
1093         validPathPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr);
1094         if (validPathPtr == NULL) {
1095             return NULL;
1096         }
1097     } else {
1098         /*
1099          * Make sure the normalized path is set.
1100          */
1101
1102         validPathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
1103         if (validPathPtr == NULL) {
1104             return NULL;
1105         }
1106         Tcl_IncrRefCount(validPathPtr);
1107     }
1108
1109     str = Tcl_GetStringFromObj(validPathPtr, &len);
1110     Tcl_UtfToExternalDString(NULL, str, len, &ds);
1111     len = Tcl_DStringLength(&ds) + sizeof(char);
1112     if (strlen(Tcl_DStringValue(&ds)) < len - sizeof(char)) {
1113         /* See bug [3118489]: NUL in filenames */
1114         Tcl_DecrRefCount(validPathPtr);
1115         Tcl_DStringFree(&ds);
1116         return NULL;
1117     }
1118     Tcl_DecrRefCount(validPathPtr);
1119     nativePathPtr = (char *)ckalloc(len);
1120     memcpy(nativePathPtr, Tcl_DStringValue(&ds), len);
1121
1122     Tcl_DStringFree(&ds);
1123     return nativePathPtr;
1124 }
1125 \f
1126 /*
1127  *---------------------------------------------------------------------------
1128  *
1129  * TclNativeDupInternalRep --
1130  *
1131  *      Duplicate the native representation.
1132  *
1133  * Results:
1134  *      The copied native representation, or NULL if it is not possible to
1135  *      copy the representation.
1136  *
1137  * Side effects:
1138  *      Memory will be allocated for the copy.
1139  *
1140  *---------------------------------------------------------------------------
1141  */
1142
1143 ClientData
1144 TclNativeDupInternalRep(
1145     ClientData clientData)
1146 {
1147     char *copy;
1148     size_t len;
1149
1150     if (clientData == NULL) {
1151         return NULL;
1152     }
1153
1154     /*
1155      * ASCII representation when running on Unix.
1156      */
1157
1158     len = (strlen((const char*) clientData) + 1) * sizeof(char);
1159
1160     copy = (char *)ckalloc(len);
1161     memcpy(copy, clientData, len);
1162     return copy;
1163 }
1164 \f
1165 /*
1166  *---------------------------------------------------------------------------
1167  *
1168  * TclpUtime --
1169  *
1170  *      Set the modification date for a file.
1171  *
1172  * Results:
1173  *      0 on success, -1 on error.
1174  *
1175  * Side effects:
1176  *      None.
1177  *
1178  *---------------------------------------------------------------------------
1179  */
1180
1181 int
1182 TclpUtime(
1183     Tcl_Obj *pathPtr,           /* File to modify */
1184     struct utimbuf *tval)       /* New modification date structure */
1185 {
1186     return utime((const char *)Tcl_FSGetNativePath(pathPtr), tval);
1187 }
1188 \f
1189 #ifdef __CYGWIN__
1190
1191 int
1192 TclOSstat(
1193     const char *name,
1194     void *cygstat)
1195 {
1196     struct stat buf;
1197     Tcl_StatBuf *statBuf = (Tcl_StatBuf *)cygstat;
1198     int result = stat(name, &buf);
1199
1200     statBuf->st_mode = buf.st_mode;
1201     statBuf->st_ino = buf.st_ino;
1202     statBuf->st_dev = buf.st_dev;
1203     statBuf->st_rdev = buf.st_rdev;
1204     statBuf->st_nlink = buf.st_nlink;
1205     statBuf->st_uid = buf.st_uid;
1206     statBuf->st_gid = buf.st_gid;
1207     statBuf->st_size = buf.st_size;
1208     statBuf->st_atime = buf.st_atime;
1209     statBuf->st_mtime = buf.st_mtime;
1210     statBuf->st_ctime = buf.st_ctime;
1211     return result;
1212 }
1213
1214 int
1215 TclOSlstat(
1216     const char *name,
1217     void *cygstat)
1218 {
1219     struct stat buf;
1220     Tcl_StatBuf *statBuf = (Tcl_StatBuf *)cygstat;
1221     int result = lstat(name, &buf);
1222
1223     statBuf->st_mode = buf.st_mode;
1224     statBuf->st_ino = buf.st_ino;
1225     statBuf->st_dev = buf.st_dev;
1226     statBuf->st_rdev = buf.st_rdev;
1227     statBuf->st_nlink = buf.st_nlink;
1228     statBuf->st_uid = buf.st_uid;
1229     statBuf->st_gid = buf.st_gid;
1230     statBuf->st_size = buf.st_size;
1231     statBuf->st_atime = buf.st_atime;
1232     statBuf->st_mtime = buf.st_mtime;
1233     statBuf->st_ctime = buf.st_ctime;
1234     return result;
1235 }
1236 #endif /* CYGWIN */
1237 \f
1238 /*
1239  * Local Variables:
1240  * mode: c
1241  * c-basic-offset: 4
1242  * fill-column: 78
1243  * End:
1244  */