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