tclunixfile.c

tcl是工具命令语言

/* 
 * 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.32 2003/02/12 18:57:52 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);
	}
	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);
	    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);
	    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);
	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)) ||