diff options
Diffstat (limited to 'unix/tclUnixFile.c')
| -rw-r--r-- | unix/tclUnixFile.c | 1421 |
1 files changed, 1038 insertions, 383 deletions
diff --git a/unix/tclUnixFile.c b/unix/tclUnixFile.c index ace9c3e..2cb0027 100644 --- a/unix/tclUnixFile.c +++ b/unix/tclUnixFile.c @@ -1,585 +1,1240 @@ -/* +/* * tclUnixFile.c -- * - * This file contains wrappers around UNIX file handling functions. - * These wrappers mask differences between Windows and UNIX. + * This file contains wrappers around UNIX file handling functions. + * These wrappers mask differences between Windows and UNIX. * - * Copyright (c) 1995 Sun Microsystems, Inc. + * Copyright (c) 1995-1998 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclUnixFile.c,v 1.5 1999/03/10 05:52:52 stanton Exp $ */ #include "tclInt.h" -#include "tclPort.h" +#include "tclFileSystem.h" +static int NativeMatchType(Tcl_Interp *interp, const char* nativeEntry, + const char* nativeName, Tcl_GlobTypeData *types); + /* - * The variable below caches the name of the current working directory - * in order to avoid repeated calls to getcwd. The string is malloc-ed. - * NULL means the cache needs to be refreshed. + *--------------------------------------------------------------------------- + * + * TclpFindExecutable -- + * + * This function computes the absolute path name of the current + * application, given its argv[0] value. For Cygwin, argv[0] is + * ignored and the path is determined the same as under win32. + * + * Results: + * None. + * + * Side effects: + * The computed path name is stored as a ProcessGlobalValue. + * + *--------------------------------------------------------------------------- */ -static char *currentDir = NULL; -static int currentDirExitHandlerSet = 0; +void +TclpFindExecutable( + const char *argv0) /* The value of the application's argv[0] + * (native). */ +{ + Tcl_Encoding encoding; +#ifdef __CYGWIN__ + int length; + char buf[PATH_MAX * 2]; + char name[PATH_MAX * TCL_UTF_MAX + 1]; + GetModuleFileNameW(NULL, buf, PATH_MAX); + cygwin_conv_path(3, buf, name, PATH_MAX); + length = strlen(name); + if ((length > 4) && !strcasecmp(name + length - 4, ".exe")) { + /* Strip '.exe' part. */ + length -= 4; + } + encoding = Tcl_GetEncoding(NULL, NULL); + TclSetObjNameOfExecutable( + Tcl_NewStringObj(name, length), encoding); +#else + const char *name, *p; + Tcl_StatBuf statBuf; + Tcl_DString buffer, nameString, cwd, utfName; -/* - * The variable below is set if the exit routine for deleting the string - * containing the executable name has been registered. - */ + if (argv0 == NULL) { + return; + } + Tcl_DStringInit(&buffer); -static int executableNameExitHandlerSet = 0; + name = argv0; + for (p = name; *p != '\0'; p++) { + if (*p == '/') { + /* + * The name contains a slash, so use the name directly without + * doing a path search. + */ -extern pid_t waitpid _ANSI_ARGS_((pid_t pid, int *stat_loc, int options)); + goto gotName; + } + } -/* - * Static routines for this file: - */ + p = getenv("PATH"); /* INTL: Native. */ + if (p == NULL) { + /* + * There's no PATH environment variable; use the default that is used + * by sh. + */ -static void FreeExecutableName _ANSI_ARGS_((ClientData clientData)); + p = ":/bin:/usr/bin"; + } else if (*p == '\0') { + /* + * An empty path is equivalent to ".". + */ + + p = "./"; + } + + /* + * Search through all the directories named in the PATH variable to see if + * argv[0] is in one of them. If so, use that file name. + */ + + while (1) { + while (TclIsSpaceProc(*p)) { + p++; + } + name = p; + while ((*p != ':') && (*p != 0)) { + p++; + } + TclDStringClear(&buffer); + if (p != name) { + Tcl_DStringAppend(&buffer, name, p - name); + if (p[-1] != '/') { + TclDStringAppendLiteral(&buffer, "/"); + } + } + name = Tcl_DStringAppend(&buffer, argv0, -1); + + /* + * INTL: The following calls to access() and stat() should not be + * converted to Tclp routines because they need to operate on native + * strings directly. + */ + + if ((access(name, X_OK) == 0) /* INTL: Native. */ + && (TclOSstat(name, &statBuf) == 0) /* INTL: Native. */ + && S_ISREG(statBuf.st_mode)) { + goto gotName; + } + if (*p == '\0') { + break; + } else if (*(p+1) == 0) { + p = "./"; + } else { + p++; + } + } + TclSetObjNameOfExecutable(Tcl_NewObj(), NULL); + goto done; + + /* + * If the name starts with "/" then just store it + */ + + gotName: +#ifdef DJGPP + if (name[1] == ':') +#else + if (name[0] == '/') +#endif + { + encoding = Tcl_GetEncoding(NULL, NULL); + Tcl_ExternalToUtfDString(encoding, name, -1, &utfName); + TclSetObjNameOfExecutable( + Tcl_NewStringObj(Tcl_DStringValue(&utfName), -1), encoding); + Tcl_DStringFree(&utfName); + goto done; + } + + /* + * The name is relative to the current working directory. First strip off + * a leading "./", if any, then add the full path name of the current + * working directory. + */ + + if ((name[0] == '.') && (name[1] == '/')) { + name += 2; + } + + Tcl_DStringInit(&nameString); + Tcl_DStringAppend(&nameString, name, -1); + + TclpGetCwd(NULL, &cwd); + + Tcl_DStringFree(&buffer); + Tcl_UtfToExternalDString(NULL, Tcl_DStringValue(&cwd), + Tcl_DStringLength(&cwd), &buffer); + if (Tcl_DStringValue(&cwd)[Tcl_DStringLength(&cwd) -1] != '/') { + TclDStringAppendLiteral(&buffer, "/"); + } + Tcl_DStringFree(&cwd); + TclDStringAppendDString(&buffer, &nameString); + Tcl_DStringFree(&nameString); + + encoding = Tcl_GetEncoding(NULL, NULL); + Tcl_ExternalToUtfDString(encoding, Tcl_DStringValue(&buffer), -1, + &utfName); + TclSetObjNameOfExecutable( + Tcl_NewStringObj(Tcl_DStringValue(&utfName), -1), encoding); + Tcl_DStringFree(&utfName); + + done: + Tcl_DStringFree(&buffer); +#endif +} /* *---------------------------------------------------------------------- * - * FreeCurrentDir -- + * TclpMatchInDirectory -- * - * Frees the string stored in the currentDir variable. This routine - * is registered as an exit handler and will be called during shutdown. + * This routine is used by the globbing code to search a directory for + * all files which match a given pattern. * * Results: - * None. + * The return value is a standard Tcl result indicating whether an error + * occurred in globbing. Errors are left in interp, good results are + * [lappend]ed to resultPtr (which must be a valid object). * * Side effects: - * Frees the memory occuppied by the currentDir value. + * None. * *---------------------------------------------------------------------- */ - /* ARGSUSED */ -static void -FreeCurrentDir(clientData) - ClientData clientData; /* Not used. */ +int +TclpMatchInDirectory( + Tcl_Interp *interp, /* Interpreter to receive errors. */ + Tcl_Obj *resultPtr, /* List object to lappend results. */ + Tcl_Obj *pathPtr, /* Contains path to directory to search. */ + const char *pattern, /* Pattern to match against. */ + Tcl_GlobTypeData *types) /* Object containing list of acceptable types. + * May be NULL. In particular the directory + * flag is very important. */ { - if (currentDir != (char *) NULL) { - ckfree(currentDir); - currentDir = (char *) NULL; - currentDirExitHandlerSet = 0; + const char *native; + Tcl_Obj *fileNamePtr; + int matchResult = 0; + + if (types != NULL && types->type == TCL_GLOB_TYPE_MOUNT) { + /* + * The native filesystem never adds mounts. + */ + + return TCL_OK; + } + + fileNamePtr = Tcl_FSGetTranslatedPath(interp, pathPtr); + if (fileNamePtr == NULL) { + return TCL_ERROR; + } + + if (pattern == NULL || (*pattern == '\0')) { + /* + * Match a file directly. + */ + + Tcl_Obj *tailPtr; + const char *nativeTail; + + native = Tcl_FSGetNativePath(pathPtr); + tailPtr = TclPathPart(interp, pathPtr, TCL_PATH_TAIL); + nativeTail = Tcl_FSGetNativePath(tailPtr); + matchResult = NativeMatchType(interp, native, nativeTail, types); + if (matchResult == 1) { + Tcl_ListObjAppendElement(interp, resultPtr, pathPtr); + } + Tcl_DecrRefCount(tailPtr); + Tcl_DecrRefCount(fileNamePtr); + } else { + DIR *d; + Tcl_DirEntry *entryPtr; + const char *dirName; + int dirLength, nativeDirLen; + int matchHidden, matchHiddenPat; + Tcl_StatBuf statBuf; + Tcl_DString ds; /* native encoding of dir */ + Tcl_DString dsOrig; /* utf-8 encoding of dir */ + + Tcl_DStringInit(&dsOrig); + dirName = Tcl_GetStringFromObj(fileNamePtr, &dirLength); + Tcl_DStringAppend(&dsOrig, dirName, dirLength); + + /* + * Make sure that the directory part of the name really is a + * directory. If the directory name is "", use the name "." instead, + * because some UNIX systems don't treat "" like "." automatically. + * Keep the "" for use in generating file names, otherwise "glob + * foo.c" would return "./foo.c". + */ + + if (dirLength == 0) { + dirName = "."; + } else { + dirName = Tcl_DStringValue(&dsOrig); + + /* + * Make sure we have a trailing directory delimiter. + */ + + if (dirName[dirLength-1] != '/') { + dirName = TclDStringAppendLiteral(&dsOrig, "/"); + dirLength++; + } + } + + /* + * Now open the directory for reading and iterate over the contents. + */ + + native = Tcl_UtfToExternalDString(NULL, dirName, -1, &ds); + + if ((TclOSstat(native, &statBuf) != 0) /* INTL: Native. */ + || !S_ISDIR(statBuf.st_mode)) { + Tcl_DStringFree(&dsOrig); + Tcl_DStringFree(&ds); + Tcl_DecrRefCount(fileNamePtr); + return TCL_OK; + } + + d = opendir(native); /* INTL: Native. */ + if (d == NULL) { + Tcl_DStringFree(&ds); + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't read directory \"%s\": %s", + Tcl_DStringValue(&dsOrig), Tcl_PosixError(interp))); + } + Tcl_DStringFree(&dsOrig); + Tcl_DecrRefCount(fileNamePtr); + return TCL_ERROR; + } + + nativeDirLen = Tcl_DStringLength(&ds); + + /* + * Check to see if -type or the pattern requests hidden files. + */ + + matchHiddenPat = (pattern[0] == '.') + || ((pattern[0] == '\\') && (pattern[1] == '.')); + matchHidden = matchHiddenPat + || (types && (types->perm & TCL_GLOB_PERM_HIDDEN)); + while ((entryPtr = TclOSreaddir(d)) != NULL) { /* INTL: Native. */ + Tcl_DString utfDs; + const char *utfname; + + /* + * Skip this file if it doesn't agree with the hidden parameters + * requested by the user (via -type or pattern). + */ + + if (*entryPtr->d_name == '.') { + if (!matchHidden) { + continue; + } + } else { +#ifdef MAC_OSX_TCL + if (matchHiddenPat) { + continue; + } + /* Also need to check HFS hidden flag in TclMacOSXMatchType. */ +#else + if (matchHidden) { + continue; + } +#endif + } + + /* + * Now check to see if the file matches, according to both type + * and pattern. If so, add the file to the result. + */ + + utfname = Tcl_ExternalToUtfDString(NULL, entryPtr->d_name, -1, + &utfDs); + if (Tcl_StringCaseMatch(utfname, pattern, 0)) { + int typeOk = 1; + + if (types != NULL) { + Tcl_DStringSetLength(&ds, nativeDirLen); + native = Tcl_DStringAppend(&ds, entryPtr->d_name, -1); + matchResult = NativeMatchType(interp, native, + entryPtr->d_name, types); + typeOk = (matchResult == 1); + } + if (typeOk) { + Tcl_ListObjAppendElement(interp, resultPtr, + TclNewFSPathObj(pathPtr, utfname, + Tcl_DStringLength(&utfDs))); + } + } + Tcl_DStringFree(&utfDs); + if (matchResult < 0) { + break; + } + } + + closedir(d); + Tcl_DStringFree(&ds); + Tcl_DStringFree(&dsOrig); + Tcl_DecrRefCount(fileNamePtr); + } + if (matchResult < 0) { + return TCL_ERROR; } + return TCL_OK; } /* *---------------------------------------------------------------------- * - * FreeExecutableName -- + * NativeMatchType -- * - * Frees the string stored in the tclExecutableName variable. This - * routine is registered as an exit handler and will be called - * during shutdown. + * This routine is used by the globbing code to check if a file matches a + * given type description. * * Results: - * None. + * The return value is 1, 0 or -1 indicating whether the file matches the + * given criteria, does not match them, or an error occurred (in which + * case an error is left in interp). * * Side effects: - * Frees the memory occuppied by the tclExecutableName value. + * None. * *---------------------------------------------------------------------- */ - /* ARGSUSED */ -static void -FreeExecutableName(clientData) - ClientData clientData; /* Not used. */ +static int +NativeMatchType( + Tcl_Interp *interp, /* Interpreter to receive errors. */ + const char *nativeEntry, /* Native path to check. */ + const char *nativeName, /* Native filename to check. */ + Tcl_GlobTypeData *types) /* Type description to match against. */ { - if (tclExecutableName != (char *) NULL) { - ckfree(tclExecutableName); - tclExecutableName = (char *) NULL; + Tcl_StatBuf buf; + + if (types == NULL) { + /* + * Simply check for the file's existence, but do it with lstat, in + * case it is a link to a file which doesn't exist (since that case + * would not show up if we used 'access' or 'stat') + */ + + if (TclOSlstat(nativeEntry, &buf) != 0) { + return 0; + } + return 1; + } + + if (types->perm != 0) { + if (TclOSstat(nativeEntry, &buf) != 0) { + /* + * Either the file has disappeared between the 'readdir' call and + * the 'stat' call, or the file is a link to a file which doesn't + * exist (which we could ascertain with lstat), or there is some + * other strange problem. In all these cases, we define this to + * mean the file does not match any defined permission, and + * therefore it is not added to the list of files to return. + */ + + return 0; + } + + /* + * readonly means that there are NO write permissions (even for user), + * but execute is OK for anybody OR that the user immutable flag is + * set (where supported). + */ + + if (((types->perm & TCL_GLOB_PERM_RONLY) && +#if defined(HAVE_CHFLAGS) && defined(UF_IMMUTABLE) + !(buf.st_flags & UF_IMMUTABLE) && +#endif + (buf.st_mode & (S_IWOTH|S_IWGRP|S_IWUSR))) || + ((types->perm & TCL_GLOB_PERM_R) && + (access(nativeEntry, R_OK) != 0)) || + ((types->perm & TCL_GLOB_PERM_W) && + (access(nativeEntry, W_OK) != 0)) || + ((types->perm & TCL_GLOB_PERM_X) && + (access(nativeEntry, X_OK) != 0)) +#ifndef MAC_OSX_TCL + || ((types->perm & TCL_GLOB_PERM_HIDDEN) && + (*nativeName != '.')) +#endif /* MAC_OSX_TCL */ + ) { + return 0; + } + } + if (types->type != 0) { + if (types->perm == 0) { + /* + * We haven't yet done a stat on the file. + */ + + if (TclOSstat(nativeEntry, &buf) != 0) { + /* + * Posix error occurred. The only ok case is if this is a link + * to a nonexistent file, and the user did 'glob -l'. So we + * check that here: + */ + + if ((types->type & TCL_GLOB_TYPE_LINK) + && (TclOSlstat(nativeEntry, &buf) == 0) + && S_ISLNK(buf.st_mode)) { + return 1; + } + return 0; + } + } + + /* + * In order bcdpsfl as in 'find -t' + */ + + if ( ((types->type & TCL_GLOB_TYPE_BLOCK)&& S_ISBLK(buf.st_mode)) || + ((types->type & TCL_GLOB_TYPE_CHAR) && S_ISCHR(buf.st_mode)) || + ((types->type & TCL_GLOB_TYPE_DIR) && S_ISDIR(buf.st_mode)) || + ((types->type & TCL_GLOB_TYPE_PIPE) && S_ISFIFO(buf.st_mode))|| +#ifdef S_ISSOCK + ((types->type & TCL_GLOB_TYPE_SOCK) && S_ISSOCK(buf.st_mode))|| +#endif /* S_ISSOCK */ + ((types->type & TCL_GLOB_TYPE_FILE) && S_ISREG(buf.st_mode))) { + /* + * Do nothing - this file is ok. + */ + } else { +#ifdef S_ISLNK + if ((types->type & TCL_GLOB_TYPE_LINK) + && (TclOSlstat(nativeEntry, &buf) == 0) + && S_ISLNK(buf.st_mode)) { + goto filetypeOK; + } +#endif /* S_ISLNK */ + return 0; + } } + filetypeOK: + + /* + * If we're on OSX, we also have to worry about matching the file creator + * code (if specified). Do that now. + */ + +#ifdef MAC_OSX_TCL + if (types->macType != NULL || types->macCreator != NULL || + (types->perm & TCL_GLOB_PERM_HIDDEN)) { + int matchResult; + + if (types->perm == 0 && types->type == 0) { + /* + * We haven't yet done a stat on the file. + */ + + if (TclOSstat(nativeEntry, &buf) != 0) { + return 0; + } + } + + matchResult = TclMacOSXMatchType(interp, nativeEntry, nativeName, + &buf, types); + if (matchResult != 1) { + return matchResult; + } + } +#endif /* MAC_OSX_TCL */ + + return 1; } /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * - * TclChdir -- + * TclpGetUserHome -- * - * Change the current working directory. + * This function takes the specified user name and finds their home + * directory. * * Results: - * The result is a standard Tcl result. If an error occurs and - * interp isn't NULL, an error message is left in interp->result. + * The result is a pointer to a string specifying the user's home + * directory, or NULL if the user's home directory could not be + * determined. Storage for the result string is allocated in bufferPtr; + * the caller must call Tcl_DStringFree() when the result is no longer + * needed. * * Side effects: - * The working directory for this application is changed. Also - * the cache maintained used by TclGetCwd is deallocated and - * set to NULL. + * None. * *---------------------------------------------------------------------- */ -int -TclChdir(interp, dirName) - Tcl_Interp *interp; /* If non NULL, used for error reporting. */ - char *dirName; /* Path to new working directory. */ +const char * +TclpGetUserHome( + const char *name, /* User name for desired home directory. */ + Tcl_DString *bufferPtr) /* Uninitialized or free DString filled with + * name of user's home directory. */ { - if (currentDir != NULL) { - ckfree(currentDir); - currentDir = NULL; + struct passwd *pwPtr; + Tcl_DString ds; + const char *native = Tcl_UtfToExternalDString(NULL, name, -1, &ds); + + pwPtr = TclpGetPwNam(native); /* INTL: Native. */ + Tcl_DStringFree(&ds); + + if (pwPtr == NULL) { + return NULL; } - if (chdir(dirName) != 0) { - if (interp != NULL) { - Tcl_AppendResult(interp, "couldn't change working directory to \"", - dirName, "\": ", Tcl_PosixError(interp), (char *) NULL); - } - return TCL_ERROR; + Tcl_ExternalToUtfDString(NULL, pwPtr->pw_dir, -1, bufferPtr); + return Tcl_DStringValue(bufferPtr); +} + +/* + *--------------------------------------------------------------------------- + * + * TclpObjAccess -- + * + * This function replaces the library version of access(). + * + * Results: + * See access() documentation. + * + * Side effects: + * See access() documentation. + * + *--------------------------------------------------------------------------- + */ + +int +TclpObjAccess( + Tcl_Obj *pathPtr, /* Path of file to access */ + int mode) /* Permission setting. */ +{ + const char *path = Tcl_FSGetNativePath(pathPtr); + + if (path == NULL) { + return -1; } - return TCL_OK; + return access(path, mode); } /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * - * TclGetCwd -- + * TclpObjChdir -- * - * Return the path name of the current working directory. + * This function replaces the library version of chdir(). * * Results: - * The result is the full path name of the current working - * directory, or NULL if an error occurred while figuring it out. - * The returned string is owned by the TclGetCwd routine and must - * not be freed by the caller. If an error occurs and interp - * isn't NULL, an error message is left in interp->result. + * See chdir() documentation. * * Side effects: - * The path name is cached to avoid having to recompute it - * on future calls; if it is already cached, the cached - * value is returned. + * See chdir() documentation. * - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- */ -char * -TclGetCwd(interp) - Tcl_Interp *interp; /* If non NULL, used for error reporting. */ +int +TclpObjChdir( + Tcl_Obj *pathPtr) /* Path to new working directory */ { - char buffer[MAXPATHLEN+1]; + const char *path = Tcl_FSGetNativePath(pathPtr); - if (currentDir == NULL) { - if (!currentDirExitHandlerSet) { - currentDirExitHandlerSet = 1; - Tcl_CreateExitHandler(FreeCurrentDir, (ClientData) NULL); - } -#ifdef USEGETWD - if ((int)getwd(buffer) == (int)NULL) { - if (interp != NULL) { - Tcl_AppendResult(interp, - "error getting working directory name: ", - buffer, (char *)NULL); - } - return NULL; - } -#else - if (getcwd(buffer, MAXPATHLEN+1) == NULL) { - if (interp != NULL) { - if (errno == ERANGE) { - Tcl_SetResult(interp, - "working directory name is too long", - TCL_STATIC); - } else { - Tcl_AppendResult(interp, - "error getting working directory name: ", - Tcl_PosixError(interp), (char *) NULL); - } - } - return NULL; - } -#endif - currentDir = (char *) ckalloc((unsigned) (strlen(buffer) + 1)); - strcpy(currentDir, buffer); + if (path == NULL) { + return -1; } - return currentDir; + return chdir(path); } /* *---------------------------------------------------------------------- * - * Tcl_FindExecutable -- + * TclpObjLstat -- * - * This procedure computes the absolute path name of the current - * application, given its argv[0] value. + * This function replaces the library version of lstat(). * * Results: - * None. + * See lstat() documentation. * * Side effects: - * The variable tclExecutableName gets filled in with the file - * name for the application, if we figured it out. If we couldn't - * figure it out, Tcl_FindExecutable is set to NULL. + * See lstat() documentation. * *---------------------------------------------------------------------- */ -void -Tcl_FindExecutable(argv0) - char *argv0; /* The value of the application's argv[0]. */ +int +TclpObjLstat( + Tcl_Obj *pathPtr, /* Path of file to stat */ + Tcl_StatBuf *bufPtr) /* Filled with results of stat call. */ { - char *name, *p, *cwd; - Tcl_DString buffer; - int length; - struct stat statBuf; - - Tcl_DStringInit(&buffer); - if (tclExecutableName != NULL) { - ckfree(tclExecutableName); - tclExecutableName = NULL; - } + return TclOSlstat(Tcl_FSGetNativePath(pathPtr), bufPtr); +} + +/* + *--------------------------------------------------------------------------- + * + * TclpGetNativeCwd -- + * + * This function replaces the library version of getcwd(). + * + * Results: + * The input and output are filesystem paths in native form. The result + * is either the given clientData, if the working directory hasn't + * changed, or a new clientData (owned by our caller), giving the new + * native path, or NULL if the current directory could not be determined. + * If NULL is returned, the caller can examine the standard posix error + * codes to determine the cause of the problem. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ - name = argv0; - for (p = name; *p != 0; p++) { - if (*p == '/') { - /* - * The name contains a slash, so use the name directly - * without doing a path search. - */ +ClientData +TclpGetNativeCwd( + ClientData clientData) +{ + char buffer[MAXPATHLEN+1]; - goto gotName; - } +#ifdef USEGETWD + if (getwd(buffer) == NULL) { /* INTL: Native. */ + return NULL; } - - p = getenv("PATH"); - if (p == NULL) { - /* - * There's no PATH environment variable; use the default that - * is used by sh. - */ - - p = ":/bin:/usr/bin"; - } else if (*p == '\0') { - /* - * An empty path is equivalent to ".". - */ - - p = "./"; +#else + if (getcwd(buffer, MAXPATHLEN+1) == NULL) { /* INTL: Native. */ + return NULL; } +#endif /* USEGETWD */ - /* - * Search through all the directories named in the PATH variable - * to see if argv[0] is in one of them. If so, use that file - * name. - */ + if ((clientData == NULL) || strcmp(buffer, (const char *) clientData)) { + char *newCd = ckalloc(strlen(buffer) + 1); - while (*p != 0) { - while (isspace(UCHAR(*p))) { - p++; - } - name = p; - while ((*p != ':') && (*p != 0)) { - p++; - } - Tcl_DStringSetLength(&buffer, 0); - if (p != name) { - Tcl_DStringAppend(&buffer, name, p-name); - if (p[-1] != '/') { - Tcl_DStringAppend(&buffer, "/", 1); - } - } - Tcl_DStringAppend(&buffer, argv0, -1); - if ((TclAccess(Tcl_DStringValue(&buffer), X_OK) == 0) - && (TclStat(Tcl_DStringValue(&buffer), &statBuf) == 0) - && S_ISREG(statBuf.st_mode)) { - name = Tcl_DStringValue(&buffer); - goto gotName; - } - if (*p == 0) { - break; - } else if (*(p+1) == 0) { - p = "./"; - } else { - p++; - } + strcpy(newCd, buffer); + return newCd; } - goto done; /* - * If the name starts with "/" then just copy it to tclExecutableName. + * No change to pwd. */ - gotName: - if (name[0] == '/') { - tclExecutableName = (char *) ckalloc((unsigned) (strlen(name) + 1)); - strcpy(tclExecutableName, name); - goto done; - } - - /* - * The name is relative to the current working directory. First - * strip off a leading "./", if any, then add the full path name of - * the current working directory. - */ + return clientData; +} + +/* + *--------------------------------------------------------------------------- + * + * TclpGetCwd -- + * + * This function replaces the library version of getcwd(). (Obsolete + * function, only retained for old extensions which may call it + * directly). + * + * Results: + * The result is a pointer to a string specifying the current directory, + * or NULL if the current directory could not be determined. If NULL is + * returned, an error message is left in the interp's result. Storage for + * the result string is allocated in bufferPtr; the caller must call + * Tcl_DStringFree() when the result is no longer needed. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ - if ((name[0] == '.') && (name[1] == '/')) { - name += 2; - } - cwd = TclGetCwd((Tcl_Interp *) NULL); - if (cwd == NULL) { - tclExecutableName = NULL; - goto done; - } - length = strlen(cwd); - tclExecutableName = (char *) ckalloc((unsigned) - (length + strlen(name) + 2)); - strcpy(tclExecutableName, cwd); - tclExecutableName[length] = '/'; - strcpy(tclExecutableName + length + 1, name); - - done: - Tcl_DStringFree(&buffer); +const char * +TclpGetCwd( + Tcl_Interp *interp, /* If non-NULL, used for error reporting. */ + Tcl_DString *bufferPtr) /* Uninitialized or free DString filled with + * name of current directory. */ +{ + char buffer[MAXPATHLEN+1]; - if (!executableNameExitHandlerSet) { - executableNameExitHandlerSet = 1; - Tcl_CreateExitHandler(FreeExecutableName, (ClientData) NULL); +#ifdef USEGETWD + if (getwd(buffer) == NULL) /* INTL: Native. */ +#else + if (getcwd(buffer, MAXPATHLEN+1) == NULL) /* INTL: Native. */ +#endif /* USEGETWD */ + { + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error getting working directory name: %s", + Tcl_PosixError(interp))); + } + return NULL; } + return Tcl_ExternalToUtfDString(NULL, buffer, -1, bufferPtr); } /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * - * TclGetUserHome -- + * TclpReadlink -- * - * This function takes the passed in user name and finds the - * corresponding home directory specified in the password file. + * This function replaces the library version of readlink(). * * Results: - * The result is a pointer to a static string containing - * the new name. If there was an error in processing the - * user name then the return value is NULL. Otherwise the - * result is stored in bufferPtr, and the caller must call - * Tcl_DStringFree(bufferPtr) to free the result. + * The result is a pointer to a string specifying the contents of the + * symbolic link given by 'path', or NULL if the symbolic link could not + * be read. Storage for the result string is allocated in bufferPtr; the + * caller must call Tcl_DStringFree() when the result is no longer + * needed. * * Side effects: - * Information may be left in bufferPtr. + * See readlink() documentation. * - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- */ char * -TclGetUserHome(name, bufferPtr) - char *name; /* User name to use to find home directory. */ - Tcl_DString *bufferPtr; /* May be used to hold result. Must not hold - * anything at the time of the call, and need - * not even be initialized. */ +TclpReadlink( + const char *path, /* Path of file to readlink (UTF-8). */ + Tcl_DString *linkPtr) /* Uninitialized or free DString filled with + * contents of link (UTF-8). */ { - struct passwd *pwPtr; +#ifndef DJGPP + char link[MAXPATHLEN]; + int length; + const char *native; + Tcl_DString ds; - pwPtr = getpwnam(name); - if (pwPtr == NULL) { - endpwent(); + native = Tcl_UtfToExternalDString(NULL, path, -1, &ds); + length = readlink(native, link, sizeof(link)); /* INTL: Native. */ + Tcl_DStringFree(&ds); + + if (length < 0) { return NULL; } - Tcl_DStringInit(bufferPtr); - Tcl_DStringAppend(bufferPtr, pwPtr->pw_dir, -1); - endpwent(); - return bufferPtr->string; + + Tcl_ExternalToUtfDString(NULL, link, length, linkPtr); + return Tcl_DStringValue(linkPtr); +#else + return NULL; +#endif /* !DJGPP */ } /* *---------------------------------------------------------------------- * - * TclMatchFiles -- + * TclpObjStat -- * - * This routine is used by the globbing code to search a - * directory for all files which match a given pattern. + * This function replaces the library version of stat(). * - * Results: - * If the tail argument is NULL, then the matching files are - * added to the interp->result. Otherwise, TclDoGlob is called - * recursively for each matching subdirectory. The return value - * is a standard Tcl result indicating whether an error occurred - * in globbing. + * Results: + * See stat() documentation. * * Side effects: - * None. + * See stat() documentation. * *---------------------------------------------------------------------- */ int -TclMatchFiles(interp, separators, dirPtr, pattern, tail) - Tcl_Interp *interp; /* Interpreter to receive results. */ - char *separators; /* Path separators to pass to TclDoGlob. */ - Tcl_DString *dirPtr; /* Contains path to directory to search. */ - char *pattern; /* Pattern to match against. */ - char *tail; /* Pointer to end of pattern. */ +TclpObjStat( + Tcl_Obj *pathPtr, /* Path of file to stat */ + Tcl_StatBuf *bufPtr) /* Filled with results of stat call. */ { - char *dirName, *patternEnd = tail; - char savedChar = 0; /* Initialization needed only to prevent - * compiler warning from gcc. */ - DIR *d; - struct stat statBuf; - struct dirent *entryPtr; - int matchHidden; - int result = TCL_OK; - int baseLength = Tcl_DStringLength(dirPtr); - - /* - * Make sure that the directory part of the name really is a - * directory. If the directory name is "", use the name "." - * instead, because some UNIX systems don't treat "" like "." - * automatically. Keep the "" for use in generating file names, - * otherwise "glob foo.c" would return "./foo.c". - */ + const char *path = Tcl_FSGetNativePath(pathPtr); - if (dirPtr->string[0] == '\0') { - dirName = "."; - } else { - dirName = dirPtr->string; - } - if ((TclStat(dirName, &statBuf) != 0) || !S_ISDIR(statBuf.st_mode)) { - return TCL_OK; + if (path == NULL) { + return -1; } + return TclOSstat(path, bufPtr); +} + +#ifdef S_IFLNK - /* - * Check to see if the pattern needs to compare with hidden files. - */ +Tcl_Obj * +TclpObjLink( + Tcl_Obj *pathPtr, + Tcl_Obj *toPtr, + int linkAction) +{ + if (toPtr != NULL) { + const char *src = Tcl_FSGetNativePath(pathPtr); + const char *target = NULL; - if ((pattern[0] == '.') - || ((pattern[0] == '\\') && (pattern[1] == '.'))) { - matchHidden = 1; - } else { - matchHidden = 0; - } + if (src == NULL) { + return NULL; + } - /* - * Now open the directory for reading and iterate over the contents. - */ + /* + * If we're making a symbolic link and the path is relative, then we + * must check whether it exists _relative_ to the directory in which + * the src is found (not relative to the current cwd which is just not + * relevant in this case). + * + * If we're making a hard link, then a relative path is just converted + * to absolute relative to the cwd. + */ + + if ((linkAction & TCL_CREATE_SYMBOLIC_LINK) + && (Tcl_FSGetPathType(toPtr) == TCL_PATH_RELATIVE)) { + Tcl_Obj *dirPtr, *absPtr; + + dirPtr = TclPathPart(NULL, pathPtr, TCL_PATH_DIRNAME); + if (dirPtr == NULL) { + return NULL; + } + absPtr = Tcl_FSJoinToPath(dirPtr, 1, &toPtr); + Tcl_IncrRefCount(absPtr); + if (Tcl_FSAccess(absPtr, F_OK) == -1) { + Tcl_DecrRefCount(absPtr); + Tcl_DecrRefCount(dirPtr); + + /* + * Target doesn't exist. + */ - d = opendir(dirName); - if (d == NULL) { - Tcl_ResetResult(interp); + errno = ENOENT; + return NULL; + } + + /* + * Target exists; we'll construct the relative path we want below. + */ + + Tcl_DecrRefCount(absPtr); + Tcl_DecrRefCount(dirPtr); + } else { + target = Tcl_FSGetNativePath(toPtr); + if (target == NULL) { + return NULL; + } + if (access(target, F_OK) == -1) { + /* + * Target doesn't exist. + */ + + errno = ENOENT; + return NULL; + } + } + + if (access(src, F_OK) != -1) { + /* + * Src exists. + */ + + errno = EEXIST; + return NULL; + } /* - * Strip off a trailing '/' if necessary, before reporting the error. + * Check symbolic link flag first, since we prefer to create these. */ - if (baseLength > 0) { - savedChar = dirPtr->string[baseLength-1]; - if (savedChar == '/') { - dirPtr->string[baseLength-1] = '\0'; + if (linkAction & TCL_CREATE_SYMBOLIC_LINK) { + int targetLen; + Tcl_DString ds; + Tcl_Obj *transPtr; + + /* + * Now we don't want to link to the absolute, normalized path. + * Relative links are quite acceptable (but links to ~user are not + * -- these must be expanded first). + */ + + transPtr = Tcl_FSGetTranslatedPath(NULL, toPtr); + if (transPtr == NULL) { + return NULL; } + target = Tcl_GetStringFromObj(transPtr, &targetLen); + target = Tcl_UtfToExternalDString(NULL, target, targetLen, &ds); + Tcl_DecrRefCount(transPtr); + + if (symlink(target, src) != 0) { + toPtr = NULL; + } + Tcl_DStringFree(&ds); + } else if (linkAction & TCL_CREATE_HARD_LINK) { + if (link(target, src) != 0) { + return NULL; + } + } else { + errno = ENODEV; + return NULL; } - Tcl_AppendResult(interp, "couldn't read directory \"", - dirPtr->string, "\": ", Tcl_PosixError(interp), (char *) NULL); - if (baseLength > 0) { - dirPtr->string[baseLength-1] = savedChar; + return toPtr; + } else { + Tcl_Obj *linkPtr = NULL; + + char link[MAXPATHLEN]; + int length; + Tcl_DString ds; + Tcl_Obj *transPtr; + + transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr); + if (transPtr == NULL) { + return NULL; } - return TCL_ERROR; + Tcl_DecrRefCount(transPtr); + + length = readlink(Tcl_FSGetNativePath(pathPtr), link, sizeof(link)); + if (length < 0) { + return NULL; + } + + Tcl_ExternalToUtfDString(NULL, link, length, &ds); + linkPtr = TclDStringToObj(&ds); + Tcl_IncrRefCount(linkPtr); + return linkPtr; } +} +#endif /* S_IFLNK */ + +/* + *--------------------------------------------------------------------------- + * + * TclpFilesystemPathType -- + * + * This function is part of the native filesystem support, and returns + * the path type of the given path. Right now it simply returns NULL. In + * the future it could return specific path types, like 'nfs', 'samba', + * 'FAT32', etc. + * + * Results: + * NULL at present. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ +Tcl_Obj * +TclpFilesystemPathType( + Tcl_Obj *pathPtr) +{ /* - * Clean up the end of the pattern and the tail pointer. Leave - * the tail pointing to the first character after the path separator - * following the pattern, or NULL. Also, ensure that the pattern - * is null-terminated. + * All native paths are of the same type. */ - if (*tail == '\\') { - tail++; - } - if (*tail == '\0') { - tail = NULL; - } else { - tail++; - } - savedChar = *patternEnd; - *patternEnd = '\0'; + return NULL; +} + +/* + *--------------------------------------------------------------------------- + * + * TclpNativeToNormalized -- + * + * Convert native format to a normalized path object, with refCount of + * zero. + * + * Currently assumes all native paths are actually normalized already, so + * if the path given is not normalized this will actually just convert to + * a valid string path, but not necessarily a normalized one. + * + * Results: + * A valid normalized path. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ - while (1) { - entryPtr = readdir(d); - if (entryPtr == NULL) { - break; - } +Tcl_Obj * +TclpNativeToNormalized( + ClientData clientData) +{ + Tcl_DString ds; + + Tcl_ExternalToUtfDString(NULL, (const char *) clientData, -1, &ds); + return TclDStringToObj(&ds); +} + +/* + *--------------------------------------------------------------------------- + * + * TclNativeCreateNativeRep -- + * + * Create a native representation for the given path. + * + * Results: + * The nativePath representation. + * + * Side effects: + * Memory will be allocated. The path may need to be normalized. + * + *--------------------------------------------------------------------------- + */ +ClientData +TclNativeCreateNativeRep( + Tcl_Obj *pathPtr) +{ + char *nativePathPtr; + const char *str; + Tcl_DString ds; + Tcl_Obj *validPathPtr; + int len; + + if (TclFSCwdIsNative()) { /* - * Don't match names starting with "." unless the "." is - * present in the pattern. + * The cwd is native, which means we can use the translated path + * without worrying about normalization (this will also usually be + * shorter so the utf-to-external conversion will be somewhat faster). */ - if (!matchHidden && (*entryPtr->d_name == '.')) { - continue; + validPathPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr); + if (validPathPtr == NULL) { + return NULL; } - + } else { /* - * Now check to see if the file matches. If there are more - * characters to be processed, then ensure matching files are - * directories before calling TclDoGlob. Otherwise, just add - * the file to the result. + * Make sure the normalized path is set. */ - if (Tcl_StringMatch(entryPtr->d_name, pattern)) { - Tcl_DStringSetLength(dirPtr, baseLength); - Tcl_DStringAppend(dirPtr, entryPtr->d_name, -1); - if (tail == NULL) { - Tcl_AppendElement(interp, dirPtr->string); - } else if ((TclStat(dirPtr->string, &statBuf) == 0) - && S_ISDIR(statBuf.st_mode)) { - Tcl_DStringAppend(dirPtr, "/", 1); - result = TclDoGlob(interp, separators, dirPtr, tail); - if (result != TCL_OK) { - break; - } - } + validPathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr); + if (validPathPtr == NULL) { + return NULL; } + Tcl_IncrRefCount(validPathPtr); } - *patternEnd = savedChar; - closedir(d); - return result; + str = Tcl_GetStringFromObj(validPathPtr, &len); + Tcl_UtfToExternalDString(NULL, str, len, &ds); + len = Tcl_DStringLength(&ds) + sizeof(char); + if (strlen(Tcl_DStringValue(&ds)) < len - sizeof(char)) { + /* See bug [3118489]: NUL in filenames */ + Tcl_DecrRefCount(validPathPtr); + Tcl_DStringFree(&ds); + return NULL; + } + Tcl_DecrRefCount(validPathPtr); + nativePathPtr = ckalloc(len); + memcpy(nativePathPtr, Tcl_DStringValue(&ds), (size_t) len); + + Tcl_DStringFree(&ds); + return nativePathPtr; } /* *--------------------------------------------------------------------------- * - * TclpAccess -- + * TclNativeDupInternalRep -- * - * This function replaces the library version of access(). + * Duplicate the native representation. * * Results: - * See access() documentation. + * The copied native representation, or NULL if it is not possible to + * copy the representation. * * Side effects: - * See access() documentation. + * Memory will be allocated for the copy. * *--------------------------------------------------------------------------- */ -int -TclpAccess(path, mode) - CONST char *path; /* Path of file to access. */ - int mode; /* Permission setting. */ +ClientData +TclNativeDupInternalRep( + ClientData clientData) { - return access(path, mode); + char *copy; + size_t len; + + if (clientData == NULL) { + return NULL; + } + + /* + * ASCII representation when running on Unix. + */ + + len = (strlen((const char*) clientData) + 1) * sizeof(char); + + copy = ckalloc(len); + memcpy(copy, clientData, len); + return copy; } /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * - * TclpStat -- + * TclpUtime -- * - * This function replaces the library version of stat(). + * Set the modification date for a file. * * Results: - * See stat() documentation. + * 0 on success, -1 on error. * * Side effects: - * See stat() documentation. + * None. * - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- */ int -TclpStat(path, bufPtr) - CONST char *path; /* Path of file to stat. */ - struct stat *bufPtr; /* Filled with results of stat call. */ +TclpUtime( + Tcl_Obj *pathPtr, /* File to modify */ + struct utimbuf *tval) /* New modification date structure */ +{ + return utime(Tcl_FSGetNativePath(pathPtr), tval); +} + +#ifdef __CYGWIN__ + +int +TclOSstat( + const char *name, + void *cygstat) { - return stat(path, bufPtr); + struct stat buf; + Tcl_StatBuf *statBuf = cygstat; + int result = stat(name, &buf); + + statBuf->st_mode = buf.st_mode; + statBuf->st_ino = buf.st_ino; + statBuf->st_dev = buf.st_dev; + statBuf->st_rdev = buf.st_rdev; + statBuf->st_nlink = buf.st_nlink; + statBuf->st_uid = buf.st_uid; + statBuf->st_gid = buf.st_gid; + statBuf->st_size = buf.st_size; + statBuf->st_atime = buf.st_atime; + statBuf->st_mtime = buf.st_mtime; + statBuf->st_ctime = buf.st_ctime; + return result; } +int +TclOSlstat( + const char *name, + void *cygstat) +{ + struct stat buf; + Tcl_StatBuf *statBuf = cygstat; + int result = lstat(name, &buf); + + statBuf->st_mode = buf.st_mode; + statBuf->st_ino = buf.st_ino; + statBuf->st_dev = buf.st_dev; + statBuf->st_rdev = buf.st_rdev; + statBuf->st_nlink = buf.st_nlink; + statBuf->st_uid = buf.st_uid; + statBuf->st_gid = buf.st_gid; + statBuf->st_size = buf.st_size; + statBuf->st_atime = buf.st_atime; + statBuf->st_mtime = buf.st_mtime; + statBuf->st_ctime = buf.st_ctime; + return result; +} +#endif /* CYGWIN */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ |