tclfcmd.c

tcl是工具命令语言

/*
 * 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 2002/08/08 10:41:22 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)
		    || (Tcl_FSCreateDirectory(target) != TCL_OK)) {
		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