path: root/generic/tclFCmd.c

/*
 * tclFCmd.c
 *
 *      This file implements the generic portion of file manipulation 
 *      subcommands of the "file" command. 
 *
 * Copyright (c) 1996-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: tclFCmd.c,v 1.20.2.2 2005/08/17 17:46:36 hobbs Exp $
 */

#include "tclInt.h"
#include "tclPort.h"

/*
 * Declarations for local procedures defined in this file:
 */

static int		CopyRenameOneFile _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr, 
			    int copyFlag, int force));
static Tcl_Obj *	FileBasename _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *pathPtr));
static int		FileCopyRename _ANSI_ARGS_((Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[], int copyFlag));
static int		FileForceOption _ANSI_ARGS_((Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[], int *forcePtr));

/*
 *---------------------------------------------------------------------------
 *
 * TclFileRenameCmd
 *
 *	This procedure implements the "rename" subcommand of the "file"
 *      command.  Filename arguments need to be translated to native
 *	format before being passed to platform-specific code that
 *	implements rename functionality.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *---------------------------------------------------------------------------
 */

int
TclFileRenameCmd(interp, objc, objv)
    Tcl_Interp *interp;		/* Interp for error reporting. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument strings passed to Tcl_FileCmd. */
{
    return FileCopyRename(interp, objc, objv, 0);
}

/*
 *---------------------------------------------------------------------------
 *
 * TclFileCopyCmd
 *
 *	This procedure implements the "copy" subcommand of the "file"
 *	command.  Filename arguments need to be translated to native
 *	format before being passed to platform-specific code that
 *	implements copy functionality.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *---------------------------------------------------------------------------
 */

int
TclFileCopyCmd(interp, objc, objv)
    Tcl_Interp *interp;		/* Used for error reporting */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument strings passed to Tcl_FileCmd. */
{
    return FileCopyRename(interp, objc, objv, 1);
}

/*
 *---------------------------------------------------------------------------
 *
 * FileCopyRename --
 *
 *	Performs the work of TclFileRenameCmd and TclFileCopyCmd.
 *	See comments for those procedures.
 *
 * Results:
 *	See above.
 *
 * Side effects:
 *	See above.
 *
 *---------------------------------------------------------------------------
 */

static int
FileCopyRename(interp, objc, objv, copyFlag)
    Tcl_Interp *interp;		/* Used for error reporting. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument strings passed to Tcl_FileCmd. */
    int copyFlag;		/* If non-zero, copy source(s).  Otherwise,
				 * rename them. */
{
    int i, result, force;
    Tcl_StatBuf statBuf; 
    Tcl_Obj *target;

    i = FileForceOption(interp, objc - 2, objv + 2, &force);
    if (i < 0) {
	return TCL_ERROR;
    }
    i += 2;
    if ((objc - i) < 2) {
	Tcl_AppendResult(interp, "wrong # args: should be \"", 
		Tcl_GetString(objv[0]), " ", Tcl_GetString(objv[1]), 
		" ?options? source ?source ...? target\"", 
		(char *) NULL);
	return TCL_ERROR;
    }

    /*
     * If target doesn't exist or isn't a directory, try the copy/rename.
     * More than 2 arguments is only valid if the target is an existing
     * directory.
     */

    target = objv[objc - 1];
    if (Tcl_FSConvertToPathType(interp, target) != TCL_OK) {
	return TCL_ERROR;
    }

    result = TCL_OK;

    /*
     * Call Tcl_FSStat() so that if target is a symlink that points to a
     * directory we will put the sources in that directory instead of
     * overwriting the symlink.
     */

    if ((Tcl_FSStat(target, &statBuf) != 0) || !S_ISDIR(statBuf.st_mode)) {
	if ((objc - i) > 2) {
	    errno = ENOTDIR;
	    Tcl_PosixError(interp);
	    Tcl_AppendResult(interp, "error ",
		    ((copyFlag) ? "copying" : "renaming"), ": target \"",
		    Tcl_GetString(target), "\" is not a directory", 
		    (char *) NULL);
	    result = TCL_ERROR;
	} else {
	    /*
	     * Even though already have target == translated(objv[i+1]),
	     * pass the original argument down, so if there's an error, the
	     * error message will reflect the original arguments.
	     */

	    result = CopyRenameOneFile(interp, objv[i], objv[i + 1], copyFlag,
		    force);
	}
	return result;
    }
    
    /*
     * Move each source file into target directory.  Extract the basename
     * from each source, and append it to the end of the target path.
     */

    for ( ; i < objc - 1; i++) {
	Tcl_Obj *jargv[2];
	Tcl_Obj *source, *newFileName;
	Tcl_Obj *temp;
	
	source = FileBasename(interp, objv[i]);
	if (source == NULL) {
	    result = TCL_ERROR;
	    break;
	}
	jargv[0] = objv[objc - 1];
	jargv[1] = source;
	temp = Tcl_NewListObj(2, jargv);
	newFileName = Tcl_FSJoinPath(temp, -1);
	Tcl_IncrRefCount(newFileName);
	result = CopyRenameOneFile(interp, objv[i], newFileName, copyFlag,
		force);
	Tcl_DecrRefCount(newFileName);
	Tcl_DecrRefCount(temp);
	Tcl_DecrRefCount(source);

	if (result == TCL_ERROR) {
	    break;
	}
    }
    return result;
}

/*
 *---------------------------------------------------------------------------
 *
 * TclFileMakeDirsCmd
 *
 *	This procedure implements the "mkdir" subcommand of the "file"
 *      command.  Filename arguments need to be translated to native
 *	format before being passed to platform-specific code that
 *	implements mkdir functionality.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */
int
TclFileMakeDirsCmd(interp, objc, objv)
    Tcl_Interp *interp;		/* Used for error reporting. */
    int objc;			/* Number of arguments */
    Tcl_Obj *CONST objv[];	/* Argument strings passed to Tcl_FileCmd. */
{
    Tcl_Obj *errfile;
    int result, i, j, pobjc;
    Tcl_Obj *split = NULL;
    Tcl_Obj *target = NULL;
    Tcl_StatBuf statBuf;

    errfile = NULL;

    result = TCL_OK;
    for (i = 2; i < objc; i++) {
	if (Tcl_FSConvertToPathType(interp, objv[i]) != TCL_OK) {
	    result = TCL_ERROR;
	    break;
	}

	split = Tcl_FSSplitPath(objv[i],&pobjc);
	if (pobjc == 0) {
	    errno = ENOENT;
	    errfile = objv[i];
	    break;
	}
	for (j = 0; j < pobjc; j++) {
	    target = Tcl_FSJoinPath(split, j + 1);
	    Tcl_IncrRefCount(target);
	    /*
	     * Call Tcl_FSStat() so that if target is a symlink that
	     * points to a directory we will create subdirectories in
	     * that directory.
	     */

	    if (Tcl_FSStat(target, &statBuf) == 0) {
		if (!S_ISDIR(statBuf.st_mode)) {
		    errno = EEXIST;
		    errfile = target;
		    goto done;
		}
	    } else if (errno != ENOENT) {
		/*
		 * If Tcl_FSStat() failed and the error is anything
		 * other than non-existence of the target, throw the
		 * error.
		 */
		errfile = target;
		goto done;
	    } else if (Tcl_FSCreateDirectory(target) != TCL_OK) {
		/*
		 * Create might have failed because of being in a race
		 * condition with another process trying to create the
		 * same subdirectory.
		 */
		if (errno == EEXIST) {
		    if ((Tcl_FSStat(target, &statBuf) == 0)
			    && S_ISDIR(statBuf.st_mode)) {
			/*
			 * It is a directory that wasn't there before,
			 * so keep going without error.
			 */
			Tcl_ResetResult(interp);
		    } else {
			errfile = target;
			goto done;
		    }
		} else {
		    errfile = target;
		    goto done;
		}
	    }
 	    /* Forget about this sub-path */
	    Tcl_DecrRefCount(target);
	    target = NULL;
	}
	Tcl_DecrRefCount(split);
	split = NULL;
    }

    done:
    if (errfile != NULL) {
	Tcl_AppendResult(interp, "can't create directory \"",
		Tcl_GetString(errfile), "\": ", Tcl_PosixError(interp), 
		(char *) NULL);
	result = TCL_ERROR;
    }
    if (split != NULL) {
	Tcl_DecrRefCount(split);
    }
    if (target != NULL) {
	Tcl_DecrRefCount(target);
    }
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * TclFileDeleteCmd
 *
 *	This procedure implements the "delete" subcommand of the "file"
 *      command.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

int
TclFileDeleteCmd(interp, objc, objv)
    Tcl_Interp *interp;		/* Used for error reporting */
    int objc;			/* Number of arguments */
    Tcl_Obj *CONST objv[];	/* Argument strings passed to Tcl_FileCmd. */
{
    int i, force, result;
    Tcl_Obj *errfile;
    Tcl_Obj *errorBuffer = NULL;
    
    i = FileForceOption(interp, objc - 2, objv + 2, &force);
    if (i < 0) {
	return TCL_ERROR;
    }
    i += 2;
    if ((objc - i) < 1) {
	Tcl_AppendResult(interp, "wrong # args: should be \"", 
		Tcl_GetString(objv[0]), " ", Tcl_GetString(objv[1]), 
		" ?options? file ?file ...?\"", (char *) NULL);
	return TCL_ERROR;
    }

    errfile = NULL;
    result = TCL_OK;

    for ( ; i < objc; i++) {
	Tcl_StatBuf statBuf;

	errfile = objv[i];
	if (Tcl_FSConvertToPathType(interp, objv[i]) != TCL_OK) {
	    result = TCL_ERROR;
	    goto done;
	}

	/*
	 * Call lstat() to get info so can delete symbolic link itself.
	 */

	if (Tcl_FSLstat(objv[i], &statBuf) != 0) {
	    /*
	     * Trying to delete a file that does not exist is not
	     * considered an error, just a no-op
	     */

	    if (errno != ENOENT) {
		result = TCL_ERROR;
	    }
	} else if (S_ISDIR(statBuf.st_mode)) {
	    /* 
	     * We own a reference count on errorBuffer, if it was set
	     * as a result of this call. 
	     */
	    result = Tcl_FSRemoveDirectory(objv[i], force, &errorBuffer);
	    if (result != TCL_OK) {
		if ((force == 0) && (errno == EEXIST)) {
		    Tcl_AppendResult(interp, "error deleting \"", 
			    Tcl_GetString(objv[i]),
			    "\": directory not empty", (char *) NULL);
		    Tcl_PosixError(interp);
		    goto done;
		}

		/* 
		 * If possible, use the untranslated name for the file.
		 */
		 
		errfile = errorBuffer;
		/* FS supposed to check between translated objv and errfile */
		if (Tcl_FSEqualPaths(objv[i], errfile)) {
		    errfile = objv[i];
		}
	    }
	} else {
	    result = Tcl_FSDeleteFile(objv[i]);
	}
	
	if (result != TCL_OK) {
	    result = TCL_ERROR;
	    /* 
	     * It is important that we break on error, otherwise we
	     * might end up owning reference counts on numerous
	     * errorBuffers.
	     */
	    break;
	}
    }
    if (result != TCL_OK) {
	if (errfile == NULL) {
	    /* 
	     * We try to accomodate poor error results from our 
	     * Tcl_FS calls 
	     */
	    Tcl_AppendResult(interp, "error deleting unknown file: ", 
		    Tcl_PosixError(interp), (char *) NULL);
	} else {
	    Tcl_AppendResult(interp, "error deleting \"", 
		    Tcl_GetString(errfile), "\": ", 
		    Tcl_PosixError(interp), (char *) NULL);
	}
    } 
    done:
    if (errorBuffer != NULL) {
	Tcl_DecrRefCount(errorBuffer);
    }
    return result;
}

/*
 *---------------------------------------------------------------------------
 *
 * CopyRenameOneFile
 *
 *	Copies or renames specified source file or directory hierarchy
 *	to the specified target.  
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	Target is overwritten if the force flag is set.  Attempting to
 *	copy/rename a file onto a directory or a directory onto a file
 *	will always result in an error.  
 *
 *----------------------------------------------------------------------
 */

static int
CopyRenameOneFile(interp, source, target, copyFlag, force) 
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Obj *source;		/* Pathname of file to copy.  May need to
				 * be translated. */
    Tcl_Obj *target;		/* Pathname of file to create/overwrite.
				 * May need to be translated. */
    int copyFlag;		/* If non-zero, copy files.  Otherwise,
				 * rename them. */
    int force;			/* If non-zero, overwrite target file if it
				 * exists.  Otherwise, error if target already
				 * exists. */
{
    int result;
    Tcl_Obj *errfile, *errorBuffer;
    /* If source is a link, then this is the real file/directory */
    Tcl_Obj *actualSource = NULL;
    Tcl_StatBuf sourceStatBuf, targetStatBuf;

    if (Tcl_FSConvertToPathType(interp, source) != TCL_OK) {
	return TCL_ERROR;
    }
    if (Tcl_FSConvertToPathType(interp, target) != TCL_OK) {
	return TCL_ERROR;
    }
    
    errfile = NULL;
    errorBuffer = NULL;
    result = TCL_ERROR;
    
    /*
     * We want to copy/rename links and not the files they point to, so we
     * use lstat(). If target is a link, we also want to replace the 
     * link and not the file it points to, so we also use lstat() on the
     * target.
     */

    if (Tcl_FSLstat(source, &sourceStatBuf) != 0) {
	errfile = source;
	goto done;
    }
    if (Tcl_FSLstat(target, &targetStatBuf) != 0) {
	if (errno != ENOENT) {
	    errfile = target;
	    goto done;
	}
    } else {
	if (force == 0) {
	    errno = EEXIST;
	    errfile = target;
	    goto done;
	}

        /* 
         * Prevent copying or renaming a file onto itself.  Under Windows, 
         * stat always returns 0 for st_ino.  However, the Windows-specific 
         * code knows how to deal with copying or renaming a file on top of
         * itself.  It might be a good idea to write a stat that worked.
         */
     
        if ((sourceStatBuf.st_ino != 0) && (targetStatBuf.st_ino != 0)) {
            if ((sourceStatBuf.st_ino == targetStatBuf.st_ino) &&
            	    (sourceStatBuf.st_dev == targetStatBuf.st_dev)) {
            	result = TCL_OK;
            	goto done;
            }
        }

	/*
	 * Prevent copying/renaming a file onto a directory and
	 * vice-versa.  This is a policy decision based on the fact that
	 * existing implementations of copy and rename on all platforms
	 * also prevent this.
	 */

	if (S_ISDIR(sourceStatBuf.st_mode)
                && !S_ISDIR(targetStatBuf.st_mode)) {
	    errno = EISDIR;
	    Tcl_AppendResult(interp, "can't overwrite file \"", 
		    Tcl_GetString(target), "\" with directory \"", 
		    Tcl_GetString(source), "\"", (char *) NULL);
	    goto done;
	}
	if (!S_ISDIR(sourceStatBuf.st_mode)
	        && S_ISDIR(targetStatBuf.st_mode)) {
	    errno = EISDIR;
	    Tcl_AppendResult(interp, "can't overwrite directory \"", 
		    Tcl_GetString(target), "\" with file \"", 
		    Tcl_GetString(source), "\"", (char *) NULL);
	    goto done;
	}
    }

    if (copyFlag == 0) {
	result = Tcl_FSRenameFile(source, target);
	if (result == TCL_OK) {
	    goto done;
	}
	    
	if (errno == EINVAL) {
	    Tcl_AppendResult(interp, "error renaming \"", 
		    Tcl_GetString(source), "\" to \"",
		    Tcl_GetString(target), "\": trying to rename a volume or ",
		    "move a directory into itself", (char *) NULL);
	    goto done;
	} else if (errno != EXDEV) {
	    errfile = target;
	    goto done;
	}
	
	/*
	 * The rename failed because the move was across file systems.
	 * Fall through to copy file and then remove original.  Note that
	 * the low-level Tcl_FSRenameFileProc in the filesystem is allowed 
	 * to implement cross-filesystem moves itself, if it desires.
	 */
    }

    actualSource = source;
    Tcl_IncrRefCount(actualSource);
#if 0
#ifdef S_ISLNK
    /* 
     * To add a flag to make 'copy' copy links instead of files, we could
     * add a condition to ignore this 'if' here.
     */
    if (copyFlag && S_ISLNK(sourceStatBuf.st_mode)) {
	/* 
	 * We want to copy files not links.  Therefore we must follow the
	 * link.  There are two purposes to this 'stat' call here.  First
	 * we want to know if the linked-file/dir actually exists, and
	 * second, in the block of code which follows, some 20 lines
	 * down, we want to check if the thing is a file or directory.
	 */
	if (Tcl_FSStat(source, &sourceStatBuf) != 0) {
	    /* Actual file doesn't exist */
	    Tcl_AppendResult(interp, 
		    "error copying \"", Tcl_GetString(source), 
		    "\": the target of this link doesn't exist",
		    (char *) NULL);
	    goto done;
	} else {
	    int counter = 0;
	    while (1) {
		Tcl_Obj *path = Tcl_FSLink(actualSource, NULL, 0);
		if (path == NULL) {
		    break;
		}
		Tcl_DecrRefCount(actualSource);
		actualSource = path;
		counter++;
		/* Arbitrary limit of 20 links to follow */
		if (counter > 20) {
		    /* Too many links */
		    Tcl_SetErrno(EMLINK);
		    errfile = source;
		    goto done;
		}
	    }
	    /* Now 'actualSource' is the correct file */
	}
    }
#endif
#endif

    if (S_ISDIR(sourceStatBuf.st_mode)) {
	result = Tcl_FSCopyDirectory(actualSource, target, &errorBuffer);
	if (result != TCL_OK) {
	    if (errno == EXDEV) {
		/* 
		 * The copy failed because we're trying to do a
		 * cross-filesystem copy.  We do this through our Tcl
		 * library.
		 */
		Tcl_SavedResult savedResult;
		Tcl_Obj *copyCommand = Tcl_NewListObj(0,NULL);
		Tcl_IncrRefCount(copyCommand);
		Tcl_ListObjAppendElement(interp, copyCommand, 
			Tcl_NewStringObj("::tcl::CopyDirectory",-1));
		if (copyFlag) {
		    Tcl_ListObjAppendElement(interp, copyCommand, 
					     Tcl_NewStringObj("copying",-1));
		} else {
		    Tcl_ListObjAppendElement(interp, copyCommand, 
					     Tcl_NewStringObj("renaming",-1));
		}
		Tcl_ListObjAppendElement(interp, copyCommand, source);
		Tcl_ListObjAppendElement(interp, copyCommand, target);
		Tcl_SaveResult(interp, &savedResult);
		result = Tcl_EvalObjEx(interp, copyCommand, 
				       TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT);
		Tcl_DecrRefCount(copyCommand);
		if (result != TCL_OK) {
		    /* 
		     * There was an error in the Tcl-level copy.
		     * We will pass on the Tcl error message and
		     * can ensure this by setting errfile to NULL
		     */
		    Tcl_DiscardResult(&savedResult);
		    errfile = NULL;
		} else {
		    /* The copy was successful */
		    Tcl_RestoreResult(interp, &savedResult);
		}
	    } else {
		errfile = errorBuffer;
		if (Tcl_FSEqualPaths(errfile, source)) {
		    errfile = source;
		} else if (Tcl_FSEqualPaths(errfile, target)) {
		    errfile = target;
		}
	    }
	}
    } else {
	result = Tcl_FSCopyFile(actualSource, target);
	if ((result != TCL_OK) && (errno == EXDEV)) {
	    result = TclCrossFilesystemCopy(interp, source, target);
	}
	if (result != TCL_OK) {
	    /* 
	     * We could examine 'errno' to double-check if the problem
	     * was with the target, but we checked the source above,
	     * so it should be quite clear 
	     */
	    errfile = target;
	    /* 
	     * We now need to reset the result, because the above call,
	     * if it failed, may have put an error message in place.
	     * (Ideally we would prefer not to pass an interpreter in
	     * above, but the channel IO code used by
	     * TclCrossFilesystemCopy currently requires one)
	     */
	    Tcl_ResetResult(interp);
	}
    }
    if ((copyFlag == 0) && (result == TCL_OK)) {
	if (S_ISDIR(sourceStatBuf.st_mode)) {
	    result = Tcl_FSRemoveDirectory(source, 1, &errorBuffer);
	    if (result != TCL_OK) {
		if (Tcl_FSEqualPaths(errfile, source) == 0) {
		    errfile = source;
		}
	    }
	} else {
	    result = Tcl_FSDeleteFile(source);
	    if (result != TCL_OK) {
		errfile = source;
	    }
	}
	if (result != TCL_OK) {
	    Tcl_AppendResult(interp, "can't unlink \"", 
		Tcl_GetString(errfile), "\": ",
		Tcl_PosixError(interp), (char *) NULL);
	    errfile = NULL;
	}
    }
    
    done:
    if (errfile != NULL) {
	Tcl_AppendResult(interp, 
		((copyFlag) ? "error copying \"" : "error renaming \""),
		 Tcl_GetString(source), (char *) NULL);
	if (errfile != source) {
	    Tcl_AppendResult(interp, "\" to \"", Tcl_GetString(target), 
			     (char *) NULL);
	    if (errfile != target) {
		Tcl_AppendResult(interp, "\": \"", Tcl_GetString(errfile), 
				 (char *) NULL);
	    }
	}
	Tcl_AppendResult(interp, "\": ", Tcl_PosixError(interp),
		(char *) NULL);
    }
    if (errorBuffer != NULL) {
        Tcl_DecrRefCount(errorBuffer);
    }
    if (actualSource != NULL) {
	Tcl_DecrRefCount(actualSource);
    }
    return result;
}

/*
 *---------------------------------------------------------------------------
 *
 * FileForceOption --
 *
 *	Helps parse command line options for file commands that take
 *	the "-force" and "--" options.
 *
 * Results:
 *	The return value is how many arguments from argv were consumed
 *	by this function, or -1 if there was an error parsing the
 *	options.  If an error occurred, an error message is left in the
 *	interp's result.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

static int
FileForceOption(interp, objc, objv, forcePtr)
    Tcl_Interp *interp;		/* Interp, for error return. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument strings.  First command line
				 * option, if it exists, begins at 0. */
    int *forcePtr;		/* If the "-force" was specified, *forcePtr
				 * is filled with 1, otherwise with 0. */
{
    int force, i;
    
    force = 0;
    for (i = 0; i < objc; i++) {
	if (Tcl_GetString(objv[i])[0] != '-') {
	    break;
	}
	if (strcmp(Tcl_GetString(objv[i]), "-force") == 0) {
	    force = 1;
	} else if (strcmp(Tcl_GetString(objv[i]), "--") == 0) {
	    i++;
	    break;
	} else {
	    Tcl_AppendResult(interp, "bad option \"", Tcl_GetString(objv[i]), 
		    "\": should be -force or --", (char *)NULL);
	    return -1;
	}
    }
    *forcePtr = force;
    return i;
}
/*
 *---------------------------------------------------------------------------
 *
 * FileBasename --
 *
 *	Given a path in either tcl format (with / separators), or in the
 *	platform-specific format for the current platform, return all the
 *	characters in the path after the last directory separator.  But,
 *	if path is the root directory, returns no characters.
 *
 * Results:
 *	Returns the string object that represents the basename.  If there 
 *	is an error, an error message is left in interp, and NULL is 
 *	returned.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

static Tcl_Obj *
FileBasename(interp, pathPtr)
    Tcl_Interp *interp;		/* Interp, for error return. */
    Tcl_Obj *pathPtr;		/* Path whose basename to extract. */
{
    int objc;
    Tcl_Obj *splitPtr;
    Tcl_Obj *resultPtr = NULL;
    
    splitPtr = Tcl_FSSplitPath(pathPtr, &objc);

    if (objc != 0) {
	if ((objc == 1) && (*Tcl_GetString(pathPtr) == '~')) {
	    Tcl_DecrRefCount(splitPtr);
	    if (Tcl_FSConvertToPathType(interp, pathPtr) != TCL_OK) {
		return NULL;
	    }
	    splitPtr = Tcl_FSSplitPath(pathPtr, &objc);
	}

	/*
	 * Return the last component, unless it is the only component, and it
	 * is the root of an absolute path.
	 */

	if (objc > 0) {
	    Tcl_ListObjIndex(NULL, splitPtr, objc-1, &resultPtr);
	    if ((objc == 1) &&
	      (Tcl_FSGetPathType(resultPtr) != TCL_PATH_RELATIVE)) {
		resultPtr = NULL;
	    }
	}
    }
    if (resultPtr == NULL) {
	resultPtr = Tcl_NewObj();
    }
    Tcl_IncrRefCount(resultPtr);
    Tcl_DecrRefCount(splitPtr);
    return resultPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * TclFileAttrsCmd --
 *
 *      Sets or gets the platform-specific attributes of a file.  The
 *      objc-objv points to the file name with the rest of the command
 *      line following.  This routine uses platform-specific tables of
 *      option strings and callbacks.  The callback to get the
 *      attributes take three parameters:
 *	    Tcl_Interp *interp;	    The interp to report errors with.
 *				    Since this is an object-based API,
 *				    the object form of the result should 
 *				    be used.
 *	    CONST char *fileName;   This is extracted using
 *				    Tcl_TranslateFileName.
 *	    TclObj **attrObjPtrPtr; A new object to hold the attribute
 *				    is allocated and put here.
 *	The first two parameters of the callback used to write out the
 *	attributes are the same. The third parameter is:
 *	    CONST *attrObjPtr;	    A pointer to the object that has
 *				    the new attribute.
 *	They both return standard TCL errors; if the routine to get
 *	an attribute fails, no object is allocated and *attrObjPtrPtr
 *	is unchanged.
 *
 * Results:
 *      Standard TCL error.
 *
 * Side effects:
 *      May set file attributes for the file name.
 *      
 *----------------------------------------------------------------------
 */

int
TclFileAttrsCmd(interp, objc, objv)
    Tcl_Interp *interp;		/* The interpreter for error reporting. */
    int objc;			/* Number of command line arguments. */
    Tcl_Obj *CONST objv[];	/* The command line objects. */
{
    int result;
    CONST char ** attributeStrings;
    Tcl_Obj* objStrings = NULL;
    int numObjStrings = -1;
    Tcl_Obj *filePtr;
    
    if (objc < 3) {
	Tcl_WrongNumArgs(interp, 2, objv,
		"name ?option? ?value? ?option value ...?");
	return TCL_ERROR;
    }

    filePtr = objv[2];
    if (Tcl_FSConvertToPathType(interp, filePtr) != TCL_OK) {
    	return TCL_ERROR;
    }
    
    objc -= 3;
    objv += 3;
    result = TCL_ERROR;
    Tcl_SetErrno(0);
    attributeStrings = Tcl_FSFileAttrStrings(filePtr, &objStrings);
    if (attributeStrings == NULL) {
	int index;
	Tcl_Obj *objPtr;
	if (objStrings == NULL) {
	    if (Tcl_GetErrno() != 0) {
		/* 
		 * There was an error, probably that the filePtr is
		 * not accepted by any filesystem
		 */
		Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), 
			"could not read \"", Tcl_GetString(filePtr), 
			"\": ", Tcl_PosixError(interp), 
			(char *) NULL);
		return TCL_ERROR;
	    }
	    goto end;
	}
	/* We own the object now */
	Tcl_IncrRefCount(objStrings);
        /* Use objStrings as a list object */
	if (Tcl_ListObjLength(interp, objStrings, &numObjStrings) != TCL_OK) {
	    goto end;
	}
	attributeStrings = (CONST char **)
		ckalloc ((1+numObjStrings) * sizeof(char*));
	for (index = 0; index < numObjStrings; index++) {
	    Tcl_ListObjIndex(interp, objStrings, index, &objPtr);
	    attributeStrings[index] = Tcl_GetString(objPtr);
	}
	attributeStrings[index] = NULL;
    }
    if (objc == 0) {
	/*
	 * Get all attributes.
	 */

	int index;
	Tcl_Obj *listPtr;
	 
	listPtr = Tcl_NewListObj(0, NULL);
	for (index = 0; attributeStrings[index] != NULL; index++) {
	    Tcl_Obj *objPtr = Tcl_NewStringObj(attributeStrings[index], -1);
	    Tcl_ListObjAppendElement(interp, listPtr, objPtr);
	    /* We now forget about objPtr, it is in the list */
	    objPtr = NULL;
	    if (Tcl_FSFileAttrsGet(interp, index, filePtr,
		    &objPtr) != TCL_OK) {
		Tcl_DecrRefCount(listPtr);
		goto end;
	    }
	    Tcl_ListObjAppendElement(interp, listPtr, objPtr);
	}
    	Tcl_SetObjResult(interp, listPtr);
    } else if (objc == 1) {
	/*
	 * Get one attribute.
	 */

	int index;
	Tcl_Obj *objPtr = NULL;

	if (numObjStrings == 0) {
	    Tcl_AppendResult(interp, "bad option \"",
		    Tcl_GetString(objv[0]), "\", there are no file attributes"
			     " in this filesystem.", (char *) NULL);
	    goto end;
	}

	if (Tcl_GetIndexFromObj(interp, objv[0], attributeStrings,
		"option", 0, &index) != TCL_OK) {
	    goto end;
	}
	if (Tcl_FSFileAttrsGet(interp, index, filePtr,
		&objPtr) != TCL_OK) {
	    goto end;
	}
	Tcl_SetObjResult(interp, objPtr);
    } else {
	/*
	 * Set option/value pairs.
	 */

	int i, index;
        
	if (numObjStrings == 0) {
	    Tcl_AppendResult(interp, "bad option \"",
		    Tcl_GetString(objv[0]), "\", there are no file attributes"
			     " in this filesystem.", (char *) NULL);
	    goto end;
	}

    	for (i = 0; i < objc ; i += 2) {
    	    if (Tcl_GetIndexFromObj(interp, objv[i], attributeStrings,
		    "option", 0, &index) != TCL_OK) {
		goto end;
    	    }
	    if (i + 1 == objc) {
		Tcl_AppendResult(interp, "value for \"",
			Tcl_GetString(objv[i]), "\" missing",
			(char *) NULL);
		goto end;
	    }
    	    if (Tcl_FSFileAttrsSet(interp, index, filePtr,
    	    	    objv[i + 1]) != TCL_OK) {
		goto end;
    	    }
    	}
    }
    result = TCL_OK;

    end:
    if (numObjStrings != -1) {
	/* Free up the array we allocated */
	ckfree((char*)attributeStrings);
	/* 
	 * We don't need this object that was passed to us
	 * any more.
	 */
	if (objStrings != NULL) {
	    Tcl_DecrRefCount(objStrings);
	}
    }
    return result;
}