/* * tclUnixFile.c -- * * This file contains wrappers around UNIX file handling functions. * These wrappers mask differences between Windows and UNIX. * * 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.37 2004/01/21 19:59:34 vincentdarley Exp $ */ #include "tclInt.h" #include "tclPort.h" static int NativeMatchType(CONST char* nativeName, Tcl_GlobTypeData *types); /* *--------------------------------------------------------------------------- * * TclpFindExecutable -- * * This procedure computes the absolute path name of the current * application, given its argv[0] value. * * Results: * A dirty UTF string that is the path to the executable. At this * point we may not know the system encoding. Convert the native * string value to UTF using the default encoding. The assumption * is that we will still be able to parse the path given the path * name contains ASCII string and '/' chars do not conflict with * other UTF chars. * * Side effects: * The variable tclNativeExecutableName gets filled in with the file * name for the application, if we figured it out. If we couldn't * figure it out, tclNativeExecutableName is set to NULL. * *--------------------------------------------------------------------------- */ char * TclpFindExecutable(argv0) CONST char *argv0; /* The value of the application's argv[0] * (native). */ { CONST char *name, *p; Tcl_StatBuf statBuf; int length; Tcl_DString buffer, nameString; if (argv0 == NULL) { return NULL; } if (tclNativeExecutableName != NULL) { return tclNativeExecutableName; } Tcl_DStringInit(&buffer); 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. */ goto gotName; } } p = getenv("PATH"); /* INTL: Native. */ 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 = "./"; } /* * 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 (isspace(UCHAR(*p))) { /* INTL: BUG */ 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); } } 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++; } } goto done; /* * If the name starts with "/" then just copy it to tclExecutableName. */ gotName: #ifdef DJGPP if (name[1] == ':') { #else if (name[0] == '/') { #endif Tcl_ExternalToUtfDString(NULL, name, -1, &nameString); tclNativeExecutableName = (char *) ckalloc((unsigned) (Tcl_DStringLength(&nameString) + 1)); strcpy(tclNativeExecutableName, Tcl_DStringValue(&nameString)); Tcl_DStringFree(&nameString); 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_ExternalToUtfDString(NULL, name, -1, &nameString); Tcl_DStringFree(&buffer); TclpGetCwd(NULL, &buffer); length = Tcl_DStringLength(&buffer) + Tcl_DStringLength(&nameString) + 2; tclNativeExecutableName = (char *) ckalloc((unsigned) length); strcpy(tclNativeExecutableName, Tcl_DStringValue(&buffer)); tclNativeExecutableName[Tcl_DStringLength(&buffer)] = '/'; strcpy(tclNativeExecutableName + Tcl_DStringLength(&buffer) + 1, Tcl_DStringValue(&nameString)); Tcl_DStringFree(&nameString); done: Tcl_DStringFree(&buffer); return tclNativeExecutableName; } /* *---------------------------------------------------------------------- * * TclpMatchInDirectory -- * * This routine is used by the globbing code to search a * directory for all files which match a given pattern. * * Results: * The return value is a standard Tcl result indicating whether an * error occurred in globbing. Errors are left in interp, good * results are lappended to resultPtr (which must be a valid object) * * Side effects: * None. * *---------------------------------------------------------------------- */ int TclpMatchInDirectory(interp, resultPtr, pathPtr, pattern, types) 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. */ { CONST char *native; Tcl_Obj *fileNamePtr; fileNamePtr = Tcl_FSGetTranslatedPath(interp, pathPtr); if (fileNamePtr == NULL) { return TCL_ERROR; } if (pattern == NULL || (*pattern == '\0')) { /* Match a file directly */ native = (CONST char*) Tcl_FSGetNativePath(pathPtr); if (NativeMatchType(native, types)) { Tcl_ListObjAppendElement(interp, resultPtr, pathPtr); } Tcl_DecrRefCount(fileNamePtr); return TCL_OK; } else { DIR *d; Tcl_DirEntry *entryPtr; CONST char *dirName; int dirLength; int matchHidden; int nativeDirLen; 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 = Tcl_DStringAppend(&dsOrig, "/", 1); 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); Tcl_ResetResult(interp); Tcl_AppendResult(interp, "couldn't read directory \"", Tcl_DStringValue(&dsOrig), "\": ", Tcl_PosixError(interp), (char *) NULL); Tcl_DStringFree(&dsOrig); Tcl_DecrRefCount(fileNamePtr); return TCL_ERROR; } nativeDirLen = Tcl_DStringLength(&ds); /* * Check to see if -type or the pattern requests hidden files. */ matchHidden = ((types && (types->perm & TCL_GLOB_PERM_HIDDEN)) || ((pattern[0] == '.') || ((pattern[0] == '\\') && (pattern[1] == '.')))); 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 { if (matchHidden) continue; } /* * 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); typeOk = NativeMatchType(native, types); } if (typeOk) { Tcl_ListObjAppendElement(interp, resultPtr, TclNewFSPathObj(pathPtr, utfname, Tcl_DStringLength(&utfDs))); } } Tcl_DStringFree(&utfDs); } closedir(d); Tcl_DStringFree(&ds); Tcl_DStringFree(&dsOrig); Tcl_DecrRefCount(fileNamePtr); return TCL_OK; } } static int NativeMatchType( CONST char* nativeEntry, /* Native path to check */ Tcl_GlobTypeData *types) /* Type description to match against */ { 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; } } else { 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 */ if (((types->perm & TCL_GLOB_PERM_RONLY) && (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)) ) { 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) { if (TclOSlstat(nativeEntry, &buf) == 0) { if (S_ISLNK(buf.st_mode)) { return 1; } } } return 0; } } /* * In order bcdpfls as in 'find -t' */ if ( ((types->type & TCL_GLOB_TYPE_BLOCK) && S_ISBLK(buf.st_mode)) || ((types->type & TCL_GLOB_TYPE_CHAR) && S_ISCHR(buf.st_mode)) || ((types->type & TCL_GLOB_TYPE_DIR) && S_ISDIR(buf.st_mode)) || ((types->type & TCL_GLOB_TYPE_PIPE) && S_ISFIFO(buf.st_mode)) || ((types->type & TCL_GLOB_TYPE_FILE) && S_ISREG(buf.st_mode)) #ifdef S_ISSOCK || ((types->type & TCL_GLOB_TYPE_SOCK) && S_ISSOCK(buf.st_mode)) #endif /* S_ISSOCK */ ) { /* Do nothing -- this file is ok */ } else { #ifdef S_ISLNK if (types->type & TCL_GLOB_TYPE_LINK) { if (TclOSlstat(nativeEntry, &buf) == 0) { if (S_ISLNK(buf.st_mode)) { return 1; } } } #endif /* S_ISLNK */ return 0; } } } return 1; } /* *--------------------------------------------------------------------------- * * TclpGetUserHome -- * * This function takes the specified user name and finds their * home directory. * * Results: * The result is a pointer to a string specifying the user's home * directory, or NULL if the user's home directory could not be * determined. Storage for the result string is allocated in * bufferPtr; the caller must call Tcl_DStringFree() when the result * is no longer needed. * * Side effects: * None. * *---------------------------------------------------------------------- */ char * TclpGetUserHome(name, bufferPtr) CONST char *name; /* User name for desired home directory. */ Tcl_DString *bufferPtr; /* Uninitialized or free DString filled * with name of user's home directory. */ { struct passwd *pwPtr; Tcl_DString ds; CONST char *native; native = Tcl_UtfToExternalDString(NULL, name, -1, &ds); pwPtr = getpwnam(native); /* INTL: Native. */ Tcl_DStringFree(&ds); if (pwPtr == NULL) { endpwent(); return NULL; } Tcl_ExternalToUtfDString(NULL, pwPtr->pw_dir, -1, bufferPtr); endpwent(); return Tcl_DStringValue(bufferPtr); } /* *--------------------------------------------------------------------------- * * TclpObjAccess -- * * This function replaces the library version of access(). * * Results: * See access() documentation. * * Side effects: * See access() documentation. * *--------------------------------------------------------------------------- */ int TclpObjAccess(pathPtr, mode) Tcl_Obj *pathPtr; /* Path of file to access */ int mode; /* Permission setting. */ { CONST char *path = Tcl_FSGetNativePath(pathPtr); if (path == NULL) { return -1; } else { return access(path, mode); } } /* *--------------------------------------------------------------------------- * * TclpObjChdir -- * * This function replaces the library version of chdir(). * * Results: * See chdir() documentation. * * Side effects: * See chdir() documentation. * *--------------------------------------------------------------------------- */ int TclpObjChdir(pathPtr) Tcl_Obj *pathPtr; /* Path to new working directory */ { CONST char *path = Tcl_FSGetNativePath(pathPtr); if (path == NULL) { return -1; } else { return chdir(path); } } /* *---------------------------------------------------------------------- * * TclpObjLstat -- * * This function replaces the library version of lstat(). * * Results: * See lstat() documentation. * * Side effects: * See lstat() documentation. * *---------------------------------------------------------------------- */ int TclpObjLstat(pathPtr, bufPtr) Tcl_Obj *pathPtr; /* Path of file to stat */ Tcl_StatBuf *bufPtr; /* Filled with results of stat call. */ { 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. * *---------------------------------------------------------------------- */ ClientData TclpGetNativeCwd(clientData) ClientData clientData; { char buffer[MAXPATHLEN+1]; #ifdef USEGETWD if (getwd(buffer) == NULL) { /* INTL: Native. */ #else if (getcwd(buffer, MAXPATHLEN + 1) == NULL) { /* INTL: Native. */ #endif return NULL; } if ((clientData != NULL) && strcmp(buffer, (CONST char*)clientData) == 0) { /* No change to pwd */ return clientData; } else { char *newCd = (char *) ckalloc((unsigned) (strlen(buffer) + 1)); strcpy(newCd, buffer); return (ClientData) newCd; } } /* *--------------------------------------------------------------------------- * * 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. * *---------------------------------------------------------------------- */ CONST char * TclpGetCwd(interp, bufferPtr) Tcl_Interp *interp; /* If non-NULL, used for error reporting. */ Tcl_DString *bufferPtr; /* Uninitialized or free DString filled * with name of current directory. */ { char buffer[MAXPATHLEN+1]; #ifdef USEGETWD if (getwd(buffer) == NULL) { /* INTL: Native. */ #else if (getcwd(buffer, MAXPATHLEN + 1) == NULL) { /* INTL: Native. */ #endif if (interp != NULL) { Tcl_AppendResult(interp, "error getting working directory name: ", Tcl_PosixError(interp), (char *) NULL); } return NULL; } return Tcl_ExternalToUtfDString(NULL, buffer, -1, bufferPtr); } /* *--------------------------------------------------------------------------- * * TclpReadlink -- * * This function replaces the library version of readlink(). * * Results: * 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: * See readlink() documentation. * *--------------------------------------------------------------------------- */ char * TclpReadlink(path, linkPtr) CONST char *path; /* Path of file to readlink (UTF-8). */ Tcl_DString *linkPtr; /* Uninitialized or free DString filled * with contents of link (UTF-8). */ { #ifndef DJGPP char link[MAXPATHLEN]; int length; CONST char *native; Tcl_DString ds; native = Tcl_UtfToExternalDString(NULL, path, -1, &ds); length = readlink(native, link, sizeof(link)); /* INTL: Native. */ Tcl_DStringFree(&ds); if (length < 0) { return NULL; } Tcl_ExternalToUtfDString(NULL, link, length, linkPtr); return Tcl_DStringValue(linkPtr); #else return NULL; #endif } /* *---------------------------------------------------------------------- * * TclpObjStat -- * * This function replaces the library version of stat(). * * Results: * See stat() documentation. * * Side effects: * See stat() documentation. * *---------------------------------------------------------------------- */ int TclpObjStat(pathPtr, bufPtr) Tcl_Obj *pathPtr; /* Path of file to stat */ Tcl_StatBuf *bufPtr; /* Filled with results of stat call. */ { CONST char *path = Tcl_FSGetNativePath(pathPtr); if (path == NULL) { return -1; } else { return TclOSstat(path, bufPtr); } } #ifdef S_IFLNK Tcl_Obj* TclpObjLink(pathPtr, toPtr, linkAction) Tcl_Obj *pathPtr; Tcl_Obj *toPtr; int linkAction; { if (toPtr != NULL) { CONST char *src = Tcl_FSGetNativePath(pathPtr); CONST char *target = NULL; if (src == NULL) return NULL; /* * 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 */ 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 (access(target, F_OK) == -1) { /* target doesn't exist */ errno = ENOENT; return NULL; } if (target == NULL) { return NULL; } } if (access(src, F_OK) != -1) { /* src exists */ errno = EEXIST; return NULL; } /* * Check symbolic link flag first, since we prefer to * create these. */ 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; } 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; } Tcl_DecrRefCount(transPtr); length = readlink(Tcl_FSGetNativePath(pathPtr), link, sizeof(link)); if (length < 0) { return NULL; } Tcl_ExternalToUtfDString(NULL, link, length, &ds); linkPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), Tcl_DStringLength(&ds)); Tcl_DStringFree(&ds); if (linkPtr != NULL) { Tcl_IncrRefCount(linkPtr); } return linkPtr; } } #endif /* *--------------------------------------------------------------------------- * * 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(pathPtr) Tcl_Obj* pathPtr; { /* All native paths are of the same type */ return NULL; } /* *--------------------------------------------------------------------------- * * TclpUtime -- * * Set the modification date for a file. * * Results: * 0 on success, -1 on error. * * Side effects: * None. * *--------------------------------------------------------------------------- */ int TclpUtime(pathPtr, tval) Tcl_Obj *pathPtr; /* File to modify */ struct utimbuf *tval; /* New modification date structure */ { return utime(Tcl_FSGetNativePath(pathPtr),tval); }