source: downloads/tcl8.5.2/unix/tclUnixFile.c @ 25

/*
 * 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.52 2007/12/13 15:28:42 dgp Exp $
 */

#include "tclInt.h"
#include "tclFileSystem.h"

static int NativeMatchType(Tcl_Interp *interp, CONST char* nativeEntry,
        CONST char* nativeName, Tcl_GlobTypeData *types);

/*
 *---------------------------------------------------------------------------
 *
 * TclpFindExecutable --
 *
 *      This function computes the absolute path name of the current
 *      application, given its argv[0] value.
 *
 * Results:
 *      None.
 *
 * Side effects:
 *      The computed path name is stored as a ProcessGlobalValue.
 *
 *---------------------------------------------------------------------------
 */

void
TclpFindExecutable(
    CONST char *argv0)          /* The value of the application's argv[0]
                                 * (native). */
{
    CONST char *name, *p;
    Tcl_StatBuf statBuf;
    Tcl_DString buffer, nameString, cwd, utfName;
    Tcl_Encoding encoding;

    if (argv0 == NULL) {
        return;
    }
    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++;
        }
    }
    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] != '/') {
        Tcl_DStringAppend(&buffer, "/", 1);
    }
    Tcl_DStringFree(&cwd);
    Tcl_DStringAppend(&buffer, Tcl_DStringValue(&nameString),
            Tcl_DStringLength(&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);
}

/*
 *----------------------------------------------------------------------
 *
 * 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
 *      [lappend]ed to resultPtr (which must be a valid object).
 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */

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. */
{
    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 = (CONST char*) Tcl_FSGetNativePath(pathPtr);
        tailPtr = TclPathPart(interp, pathPtr, TCL_PATH_TAIL);
        nativeTail = (CONST char*) 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;
        int matchHidden, matchHiddenPat;
        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);
            if (interp != NULL) {
                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.
         */

        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;
    } else {
        return TCL_OK;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * NativeMatchType --
 *
 *      This routine is used by the globbing code to check if a file
 *      matches a given type description.
 *
 * Results:
 *      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 wich case an error is left in interp).
 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */

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. */
{
    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 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
                ) {
                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)) {
                            goto filetypeOK;
                        }
                    }
                }
#endif /* S_ISLNK */
                return 0;
            }
        }
    filetypeOK: ;
#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
    }
    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(
    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(
    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(
    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(
    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)
{
    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(
    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), 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(
    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(
    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(
    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 (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;
        }

        /*
         * 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 /* 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)
{
    /*
     * All native paths are of the same type.
     */

    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.
 *
 *---------------------------------------------------------------------------
 */

Tcl_Obj *
TclpNativeToNormalized(
    ClientData clientData)
{
    Tcl_DString ds;
    Tcl_Obj *objPtr;
    int len;

    CONST char *copy;
    Tcl_ExternalToUtfDString(NULL, (CONST char*)clientData, -1, &ds);

    copy = Tcl_DStringValue(&ds);
    len = Tcl_DStringLength(&ds);

    objPtr = Tcl_NewStringObj(copy,len);
    Tcl_DStringFree(&ds);

    return objPtr;
}

/*
 *---------------------------------------------------------------------------
 *
 * 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;
    Tcl_DString ds;
    Tcl_Obj *validPathPtr;
    int len;
    char *str;

    if (TclFSCwdIsNative()) {
        /*
         * 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).
         */

        validPathPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr);
        if (validPathPtr == NULL) {
            return NULL;
        }
    } else {
        /*
         * Make sure the normalized path is set.
         */

        validPathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
        if (validPathPtr == NULL) {
            return NULL;
        }
        Tcl_IncrRefCount(validPathPtr);
    }

    str = Tcl_GetStringFromObj(validPathPtr, &len);
    Tcl_UtfToExternalDString(NULL, str, len, &ds);
    len = Tcl_DStringLength(&ds) + sizeof(char);
    Tcl_DecrRefCount(validPathPtr);
    nativePathPtr = ckalloc((unsigned) len);
    memcpy((void*)nativePathPtr, (void*)Tcl_DStringValue(&ds), (size_t) len);

    Tcl_DStringFree(&ds);
    return (ClientData)nativePathPtr;
}

/*
 *---------------------------------------------------------------------------
 *
 * TclNativeDupInternalRep --
 *
 *      Duplicate the native representation.
 *
 * Results:
 *      The copied native representation, or NULL if it is not possible to
 *      copy the representation.
 *
 * Side effects:
 *      Memory will be allocated for the copy.
 *
 *---------------------------------------------------------------------------
 */

ClientData
TclNativeDupInternalRep(
    ClientData clientData)
{
    char *copy;
    size_t len;

    if (clientData == NULL) {
        return NULL;
    }

    /*
     * ASCII representation when running on Unix.
     */

    len = sizeof(char) + (strlen((CONST char*) clientData) * sizeof(char));

    copy = (char *) ckalloc(len);
    memcpy((void *) copy, (void *) clientData, len);
    return (ClientData)copy;
}

/*
 *---------------------------------------------------------------------------
 *
 * TclpUtime --
 *
 *      Set the modification date for a file.
 *
 * Results:
 *      0 on success, -1 on error.
 *
 * Side effects:
 *      None.
 *
 *---------------------------------------------------------------------------
 */

int
TclpUtime(
    Tcl_Obj *pathPtr,           /* File to modify */
    struct utimbuf *tval)       /* New modification date structure */
{
    return utime(Tcl_FSGetNativePath(pathPtr), tval);
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */