/*
|
/*
|
* tclFCmd.c
|
* tclFCmd.c
|
*
|
*
|
* This file implements the generic portion of file manipulation
|
* This file implements the generic portion of file manipulation
|
* subcommands of the "file" command.
|
* subcommands of the "file" command.
|
*
|
*
|
* Copyright (c) 1996-1997 Sun Microsystems, Inc.
|
* Copyright (c) 1996-1997 Sun Microsystems, Inc.
|
*
|
*
|
* See the file "license.terms" for information on usage and redistribution
|
* See the file "license.terms" for information on usage and redistribution
|
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
*
|
*
|
* RCS: @(#) $Id: tclFCmd.c,v 1.1.1.1 2002-01-16 10:25:27 markom Exp $
|
* RCS: @(#) $Id: tclFCmd.c,v 1.1.1.1 2002-01-16 10:25:27 markom Exp $
|
*/
|
*/
|
|
|
#include "tclInt.h"
|
#include "tclInt.h"
|
#include "tclPort.h"
|
#include "tclPort.h"
|
|
|
/*
|
/*
|
* Declarations for local procedures defined in this file:
|
* Declarations for local procedures defined in this file:
|
*/
|
*/
|
|
|
static int CopyRenameOneFile _ANSI_ARGS_((Tcl_Interp *interp,
|
static int CopyRenameOneFile _ANSI_ARGS_((Tcl_Interp *interp,
|
char *source, char *dest, int copyFlag,
|
char *source, char *dest, int copyFlag,
|
int force));
|
int force));
|
static char * FileBasename _ANSI_ARGS_((Tcl_Interp *interp,
|
static char * FileBasename _ANSI_ARGS_((Tcl_Interp *interp,
|
char *path, Tcl_DString *bufferPtr));
|
char *path, Tcl_DString *bufferPtr));
|
static int FileCopyRename _ANSI_ARGS_((Tcl_Interp *interp,
|
static int FileCopyRename _ANSI_ARGS_((Tcl_Interp *interp,
|
int argc, char **argv, int copyFlag));
|
int argc, char **argv, int copyFlag));
|
static int FileForceOption _ANSI_ARGS_((Tcl_Interp *interp,
|
static int FileForceOption _ANSI_ARGS_((Tcl_Interp *interp,
|
int argc, char **argv, int *forcePtr));
|
int argc, char **argv, int *forcePtr));
|
|
|
/*
|
/*
|
*---------------------------------------------------------------------------
|
*---------------------------------------------------------------------------
|
*
|
*
|
* TclFileRenameCmd
|
* TclFileRenameCmd
|
*
|
*
|
* This procedure implements the "rename" subcommand of the "file"
|
* This procedure implements the "rename" subcommand of the "file"
|
* command. Filename arguments need to be translated to native
|
* command. Filename arguments need to be translated to native
|
* format before being passed to platform-specific code that
|
* format before being passed to platform-specific code that
|
* implements rename functionality.
|
* implements rename functionality.
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl result.
|
* A standard Tcl result.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* See the user documentation.
|
* See the user documentation.
|
*
|
*
|
*---------------------------------------------------------------------------
|
*---------------------------------------------------------------------------
|
*/
|
*/
|
|
|
int
|
int
|
TclFileRenameCmd(interp, argc, argv)
|
TclFileRenameCmd(interp, argc, argv)
|
Tcl_Interp *interp; /* Interp for error reporting. */
|
Tcl_Interp *interp; /* Interp for error reporting. */
|
int argc; /* Number of arguments. */
|
int argc; /* Number of arguments. */
|
char **argv; /* Argument strings passed to Tcl_FileCmd. */
|
char **argv; /* Argument strings passed to Tcl_FileCmd. */
|
{
|
{
|
return FileCopyRename(interp, argc, argv, 0);
|
return FileCopyRename(interp, argc, argv, 0);
|
}
|
}
|
|
|
/*
|
/*
|
*---------------------------------------------------------------------------
|
*---------------------------------------------------------------------------
|
*
|
*
|
* TclFileCopyCmd
|
* TclFileCopyCmd
|
*
|
*
|
* This procedure implements the "copy" subcommand of the "file"
|
* This procedure implements the "copy" subcommand of the "file"
|
* command. Filename arguments need to be translated to native
|
* command. Filename arguments need to be translated to native
|
* format before being passed to platform-specific code that
|
* format before being passed to platform-specific code that
|
* implements copy functionality.
|
* implements copy functionality.
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl result.
|
* A standard Tcl result.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* See the user documentation.
|
* See the user documentation.
|
*
|
*
|
*---------------------------------------------------------------------------
|
*---------------------------------------------------------------------------
|
*/
|
*/
|
|
|
int
|
int
|
TclFileCopyCmd(interp, argc, argv)
|
TclFileCopyCmd(interp, argc, argv)
|
Tcl_Interp *interp; /* Used for error reporting */
|
Tcl_Interp *interp; /* Used for error reporting */
|
int argc; /* Number of arguments. */
|
int argc; /* Number of arguments. */
|
char **argv; /* Argument strings passed to Tcl_FileCmd. */
|
char **argv; /* Argument strings passed to Tcl_FileCmd. */
|
{
|
{
|
return FileCopyRename(interp, argc, argv, 1);
|
return FileCopyRename(interp, argc, argv, 1);
|
}
|
}
|
|
|
/*
|
/*
|
*---------------------------------------------------------------------------
|
*---------------------------------------------------------------------------
|
*
|
*
|
* FileCopyRename --
|
* FileCopyRename --
|
*
|
*
|
* Performs the work of TclFileRenameCmd and TclFileCopyCmd.
|
* Performs the work of TclFileRenameCmd and TclFileCopyCmd.
|
* See comments for those procedures.
|
* See comments for those procedures.
|
*
|
*
|
* Results:
|
* Results:
|
* See above.
|
* See above.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* See above.
|
* See above.
|
*
|
*
|
*---------------------------------------------------------------------------
|
*---------------------------------------------------------------------------
|
*/
|
*/
|
|
|
static int
|
static int
|
FileCopyRename(interp, argc, argv, copyFlag)
|
FileCopyRename(interp, argc, argv, copyFlag)
|
Tcl_Interp *interp; /* Used for error reporting. */
|
Tcl_Interp *interp; /* Used for error reporting. */
|
int argc; /* Number of arguments. */
|
int argc; /* Number of arguments. */
|
char **argv; /* Argument strings passed to Tcl_FileCmd. */
|
char **argv; /* Argument strings passed to Tcl_FileCmd. */
|
int copyFlag; /* If non-zero, copy source(s). Otherwise,
|
int copyFlag; /* If non-zero, copy source(s). Otherwise,
|
* rename them. */
|
* rename them. */
|
{
|
{
|
int i, result, force;
|
int i, result, force;
|
struct stat statBuf;
|
struct stat statBuf;
|
Tcl_DString targetBuffer;
|
Tcl_DString targetBuffer;
|
char *target;
|
char *target;
|
|
|
i = FileForceOption(interp, argc - 2, argv + 2, &force);
|
i = FileForceOption(interp, argc - 2, argv + 2, &force);
|
if (i < 0) {
|
if (i < 0) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
i += 2;
|
i += 2;
|
if ((argc - i) < 2) {
|
if ((argc - i) < 2) {
|
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
|
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
|
" ", argv[1], " ?options? source ?source ...? target\"",
|
" ", argv[1], " ?options? source ?source ...? target\"",
|
(char *) NULL);
|
(char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* If target doesn't exist or isn't a directory, try the copy/rename.
|
* 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
|
* More than 2 arguments is only valid if the target is an existing
|
* directory.
|
* directory.
|
*/
|
*/
|
|
|
target = Tcl_TranslateFileName(interp, argv[argc - 1], &targetBuffer);
|
target = Tcl_TranslateFileName(interp, argv[argc - 1], &targetBuffer);
|
if (target == NULL) {
|
if (target == NULL) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
result = TCL_OK;
|
result = TCL_OK;
|
|
|
/*
|
/*
|
* Call TclStat() so that if target is a symlink that points to a
|
* Call TclStat() so that if target is a symlink that points to a
|
* directory we will put the sources in that directory instead of
|
* directory we will put the sources in that directory instead of
|
* overwriting the symlink.
|
* overwriting the symlink.
|
*/
|
*/
|
|
|
if ((TclStat(target, &statBuf) != 0) || !S_ISDIR(statBuf.st_mode)) {
|
if ((TclStat(target, &statBuf) != 0) || !S_ISDIR(statBuf.st_mode)) {
|
if ((argc - i) > 2) {
|
if ((argc - i) > 2) {
|
errno = ENOTDIR;
|
errno = ENOTDIR;
|
Tcl_PosixError(interp);
|
Tcl_PosixError(interp);
|
Tcl_AppendResult(interp, "error ",
|
Tcl_AppendResult(interp, "error ",
|
((copyFlag) ? "copying" : "renaming"), ": target \"",
|
((copyFlag) ? "copying" : "renaming"), ": target \"",
|
argv[argc - 1], "\" is not a directory", (char *) NULL);
|
argv[argc - 1], "\" is not a directory", (char *) NULL);
|
result = TCL_ERROR;
|
result = TCL_ERROR;
|
} else {
|
} else {
|
/*
|
/*
|
* Even though already have target == translated(argv[i+1]),
|
* Even though already have target == translated(argv[i+1]),
|
* pass the original argument down, so if there's an error, the
|
* pass the original argument down, so if there's an error, the
|
* error message will reflect the original arguments.
|
* error message will reflect the original arguments.
|
*/
|
*/
|
|
|
result = CopyRenameOneFile(interp, argv[i], argv[i + 1], copyFlag,
|
result = CopyRenameOneFile(interp, argv[i], argv[i + 1], copyFlag,
|
force);
|
force);
|
}
|
}
|
Tcl_DStringFree(&targetBuffer);
|
Tcl_DStringFree(&targetBuffer);
|
return result;
|
return result;
|
}
|
}
|
|
|
/*
|
/*
|
* Move each source file into target directory. Extract the basename
|
* Move each source file into target directory. Extract the basename
|
* from each source, and append it to the end of the target path.
|
* from each source, and append it to the end of the target path.
|
*/
|
*/
|
|
|
for ( ; i < argc - 1; i++) {
|
for ( ; i < argc - 1; i++) {
|
char *jargv[2];
|
char *jargv[2];
|
char *source, *newFileName;
|
char *source, *newFileName;
|
Tcl_DString sourceBuffer, newFileNameBuffer;
|
Tcl_DString sourceBuffer, newFileNameBuffer;
|
|
|
source = FileBasename(interp, argv[i], &sourceBuffer);
|
source = FileBasename(interp, argv[i], &sourceBuffer);
|
if (source == NULL) {
|
if (source == NULL) {
|
result = TCL_ERROR;
|
result = TCL_ERROR;
|
break;
|
break;
|
}
|
}
|
jargv[0] = argv[argc - 1];
|
jargv[0] = argv[argc - 1];
|
jargv[1] = source;
|
jargv[1] = source;
|
Tcl_DStringInit(&newFileNameBuffer);
|
Tcl_DStringInit(&newFileNameBuffer);
|
newFileName = Tcl_JoinPath(2, jargv, &newFileNameBuffer);
|
newFileName = Tcl_JoinPath(2, jargv, &newFileNameBuffer);
|
result = CopyRenameOneFile(interp, argv[i], newFileName, copyFlag,
|
result = CopyRenameOneFile(interp, argv[i], newFileName, copyFlag,
|
force);
|
force);
|
Tcl_DStringFree(&sourceBuffer);
|
Tcl_DStringFree(&sourceBuffer);
|
Tcl_DStringFree(&newFileNameBuffer);
|
Tcl_DStringFree(&newFileNameBuffer);
|
|
|
if (result == TCL_ERROR) {
|
if (result == TCL_ERROR) {
|
break;
|
break;
|
}
|
}
|
}
|
}
|
Tcl_DStringFree(&targetBuffer);
|
Tcl_DStringFree(&targetBuffer);
|
return result;
|
return result;
|
}
|
}
|
|
|
/*
|
/*
|
*---------------------------------------------------------------------------
|
*---------------------------------------------------------------------------
|
*
|
*
|
* TclFileMakeDirsCmd
|
* TclFileMakeDirsCmd
|
*
|
*
|
* This procedure implements the "mkdir" subcommand of the "file"
|
* This procedure implements the "mkdir" subcommand of the "file"
|
* command. Filename arguments need to be translated to native
|
* command. Filename arguments need to be translated to native
|
* format before being passed to platform-specific code that
|
* format before being passed to platform-specific code that
|
* implements mkdir functionality.
|
* implements mkdir functionality.
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl result.
|
* A standard Tcl result.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* See the user documentation.
|
* See the user documentation.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
int
|
int
|
TclFileMakeDirsCmd(interp, argc, argv)
|
TclFileMakeDirsCmd(interp, argc, argv)
|
Tcl_Interp *interp; /* Used for error reporting. */
|
Tcl_Interp *interp; /* Used for error reporting. */
|
int argc; /* Number of arguments */
|
int argc; /* Number of arguments */
|
char **argv; /* Argument strings passed to Tcl_FileCmd. */
|
char **argv; /* Argument strings passed to Tcl_FileCmd. */
|
{
|
{
|
Tcl_DString nameBuffer, targetBuffer;
|
Tcl_DString nameBuffer, targetBuffer;
|
char *errfile;
|
char *errfile;
|
int result, i, j, pargc;
|
int result, i, j, pargc;
|
char **pargv;
|
char **pargv;
|
struct stat statBuf;
|
struct stat statBuf;
|
|
|
pargv = NULL;
|
pargv = NULL;
|
errfile = NULL;
|
errfile = NULL;
|
Tcl_DStringInit(&nameBuffer);
|
Tcl_DStringInit(&nameBuffer);
|
Tcl_DStringInit(&targetBuffer);
|
Tcl_DStringInit(&targetBuffer);
|
|
|
result = TCL_OK;
|
result = TCL_OK;
|
for (i = 2; i < argc; i++) {
|
for (i = 2; i < argc; i++) {
|
char *name = Tcl_TranslateFileName(interp, argv[i], &nameBuffer);
|
char *name = Tcl_TranslateFileName(interp, argv[i], &nameBuffer);
|
if (name == NULL) {
|
if (name == NULL) {
|
result = TCL_ERROR;
|
result = TCL_ERROR;
|
break;
|
break;
|
}
|
}
|
|
|
Tcl_SplitPath(name, &pargc, &pargv);
|
Tcl_SplitPath(name, &pargc, &pargv);
|
if (pargc == 0) {
|
if (pargc == 0) {
|
errno = ENOENT;
|
errno = ENOENT;
|
errfile = argv[i];
|
errfile = argv[i];
|
break;
|
break;
|
}
|
}
|
for (j = 0; j < pargc; j++) {
|
for (j = 0; j < pargc; j++) {
|
char *target = Tcl_JoinPath(j + 1, pargv, &targetBuffer);
|
char *target = Tcl_JoinPath(j + 1, pargv, &targetBuffer);
|
|
|
/*
|
/*
|
* Call TclStat() so that if target is a symlink that points
|
* Call TclStat() so that if target is a symlink that points
|
* to a directory we will create subdirectories in that
|
* to a directory we will create subdirectories in that
|
* directory.
|
* directory.
|
*/
|
*/
|
|
|
if (TclStat(target, &statBuf) == 0) {
|
if (TclStat(target, &statBuf) == 0) {
|
if (!S_ISDIR(statBuf.st_mode)) {
|
if (!S_ISDIR(statBuf.st_mode)) {
|
errno = EEXIST;
|
errno = EEXIST;
|
errfile = target;
|
errfile = target;
|
goto done;
|
goto done;
|
}
|
}
|
} else if ((errno != ENOENT)
|
} else if ((errno != ENOENT)
|
|| (TclpCreateDirectory(target) != TCL_OK)) {
|
|| (TclpCreateDirectory(target) != TCL_OK)) {
|
errfile = target;
|
errfile = target;
|
goto done;
|
goto done;
|
}
|
}
|
Tcl_DStringFree(&targetBuffer);
|
Tcl_DStringFree(&targetBuffer);
|
}
|
}
|
ckfree((char *) pargv);
|
ckfree((char *) pargv);
|
pargv = NULL;
|
pargv = NULL;
|
Tcl_DStringFree(&nameBuffer);
|
Tcl_DStringFree(&nameBuffer);
|
}
|
}
|
|
|
done:
|
done:
|
if (errfile != NULL) {
|
if (errfile != NULL) {
|
Tcl_AppendResult(interp, "can't create directory \"",
|
Tcl_AppendResult(interp, "can't create directory \"",
|
errfile, "\": ", Tcl_PosixError(interp), (char *) NULL);
|
errfile, "\": ", Tcl_PosixError(interp), (char *) NULL);
|
result = TCL_ERROR;
|
result = TCL_ERROR;
|
}
|
}
|
|
|
Tcl_DStringFree(&nameBuffer);
|
Tcl_DStringFree(&nameBuffer);
|
Tcl_DStringFree(&targetBuffer);
|
Tcl_DStringFree(&targetBuffer);
|
if (pargv != NULL) {
|
if (pargv != NULL) {
|
ckfree((char *) pargv);
|
ckfree((char *) pargv);
|
}
|
}
|
return result;
|
return result;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* TclFileDeleteCmd
|
* TclFileDeleteCmd
|
*
|
*
|
* This procedure implements the "delete" subcommand of the "file"
|
* This procedure implements the "delete" subcommand of the "file"
|
* command.
|
* command.
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl result.
|
* A standard Tcl result.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* See the user documentation.
|
* See the user documentation.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
int
|
int
|
TclFileDeleteCmd(interp, argc, argv)
|
TclFileDeleteCmd(interp, argc, argv)
|
Tcl_Interp *interp; /* Used for error reporting */
|
Tcl_Interp *interp; /* Used for error reporting */
|
int argc; /* Number of arguments */
|
int argc; /* Number of arguments */
|
char **argv; /* Argument strings passed to Tcl_FileCmd. */
|
char **argv; /* Argument strings passed to Tcl_FileCmd. */
|
{
|
{
|
Tcl_DString nameBuffer, errorBuffer;
|
Tcl_DString nameBuffer, errorBuffer;
|
int i, force, result;
|
int i, force, result;
|
char *errfile;
|
char *errfile;
|
|
|
i = FileForceOption(interp, argc - 2, argv + 2, &force);
|
i = FileForceOption(interp, argc - 2, argv + 2, &force);
|
if (i < 0) {
|
if (i < 0) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
i += 2;
|
i += 2;
|
if ((argc - i) < 1) {
|
if ((argc - i) < 1) {
|
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
|
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
|
" ", argv[1], " ?options? file ?file ...?\"", (char *) NULL);
|
" ", argv[1], " ?options? file ?file ...?\"", (char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
errfile = NULL;
|
errfile = NULL;
|
result = TCL_OK;
|
result = TCL_OK;
|
Tcl_DStringInit(&errorBuffer);
|
Tcl_DStringInit(&errorBuffer);
|
Tcl_DStringInit(&nameBuffer);
|
Tcl_DStringInit(&nameBuffer);
|
|
|
for ( ; i < argc; i++) {
|
for ( ; i < argc; i++) {
|
struct stat statBuf;
|
struct stat statBuf;
|
char *name;
|
char *name;
|
|
|
errfile = argv[i];
|
errfile = argv[i];
|
Tcl_DStringSetLength(&nameBuffer, 0);
|
Tcl_DStringSetLength(&nameBuffer, 0);
|
name = Tcl_TranslateFileName(interp, argv[i], &nameBuffer);
|
name = Tcl_TranslateFileName(interp, argv[i], &nameBuffer);
|
if (name == NULL) {
|
if (name == NULL) {
|
result = TCL_ERROR;
|
result = TCL_ERROR;
|
goto done;
|
goto done;
|
}
|
}
|
|
|
/*
|
/*
|
* Call lstat() to get info so can delete symbolic link itself.
|
* Call lstat() to get info so can delete symbolic link itself.
|
*/
|
*/
|
|
|
if (lstat(name, &statBuf) != 0) {
|
if (lstat(name, &statBuf) != 0) {
|
/*
|
/*
|
* Trying to delete a file that does not exist is not
|
* Trying to delete a file that does not exist is not
|
* considered an error, just a no-op
|
* considered an error, just a no-op
|
*/
|
*/
|
|
|
if (errno != ENOENT) {
|
if (errno != ENOENT) {
|
result = TCL_ERROR;
|
result = TCL_ERROR;
|
}
|
}
|
} else if (S_ISDIR(statBuf.st_mode)) {
|
} else if (S_ISDIR(statBuf.st_mode)) {
|
result = TclpRemoveDirectory(name, force, &errorBuffer);
|
result = TclpRemoveDirectory(name, force, &errorBuffer);
|
if (result != TCL_OK) {
|
if (result != TCL_OK) {
|
if ((force == 0) && (errno == EEXIST)) {
|
if ((force == 0) && (errno == EEXIST)) {
|
Tcl_AppendResult(interp, "error deleting \"", argv[i],
|
Tcl_AppendResult(interp, "error deleting \"", argv[i],
|
"\": directory not empty", (char *) NULL);
|
"\": directory not empty", (char *) NULL);
|
Tcl_PosixError(interp);
|
Tcl_PosixError(interp);
|
goto done;
|
goto done;
|
}
|
}
|
|
|
/*
|
/*
|
* If possible, use the untranslated name for the file.
|
* If possible, use the untranslated name for the file.
|
*/
|
*/
|
|
|
errfile = Tcl_DStringValue(&errorBuffer);
|
errfile = Tcl_DStringValue(&errorBuffer);
|
if (strcmp(name, errfile) == 0) {
|
if (strcmp(name, errfile) == 0) {
|
errfile = argv[i];
|
errfile = argv[i];
|
}
|
}
|
}
|
}
|
} else {
|
} else {
|
result = TclpDeleteFile(name);
|
result = TclpDeleteFile(name);
|
}
|
}
|
|
|
if (result == TCL_ERROR) {
|
if (result == TCL_ERROR) {
|
break;
|
break;
|
}
|
}
|
}
|
}
|
if (result != TCL_OK) {
|
if (result != TCL_OK) {
|
Tcl_AppendResult(interp, "error deleting \"", errfile,
|
Tcl_AppendResult(interp, "error deleting \"", errfile,
|
"\": ", Tcl_PosixError(interp), (char *) NULL);
|
"\": ", Tcl_PosixError(interp), (char *) NULL);
|
}
|
}
|
done:
|
done:
|
Tcl_DStringFree(&errorBuffer);
|
Tcl_DStringFree(&errorBuffer);
|
Tcl_DStringFree(&nameBuffer);
|
Tcl_DStringFree(&nameBuffer);
|
return result;
|
return result;
|
}
|
}
|
|
|
/*
|
/*
|
*---------------------------------------------------------------------------
|
*---------------------------------------------------------------------------
|
*
|
*
|
* CopyRenameOneFile
|
* CopyRenameOneFile
|
*
|
*
|
* Copies or renames specified source file or directory hierarchy
|
* Copies or renames specified source file or directory hierarchy
|
* to the specified target.
|
* to the specified target.
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl result.
|
* A standard Tcl result.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Target is overwritten if the force flag is set. Attempting to
|
* Target is overwritten if the force flag is set. Attempting to
|
* copy/rename a file onto a directory or a directory onto a file
|
* copy/rename a file onto a directory or a directory onto a file
|
* will always result in an error.
|
* will always result in an error.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static int
|
static int
|
CopyRenameOneFile(interp, source, target, copyFlag, force)
|
CopyRenameOneFile(interp, source, target, copyFlag, force)
|
Tcl_Interp *interp; /* Used for error reporting. */
|
Tcl_Interp *interp; /* Used for error reporting. */
|
char *source; /* Pathname of file to copy. May need to
|
char *source; /* Pathname of file to copy. May need to
|
* be translated. */
|
* be translated. */
|
char *target; /* Pathname of file to create/overwrite.
|
char *target; /* Pathname of file to create/overwrite.
|
* May need to be translated. */
|
* May need to be translated. */
|
int copyFlag; /* If non-zero, copy files. Otherwise,
|
int copyFlag; /* If non-zero, copy files. Otherwise,
|
* rename them. */
|
* rename them. */
|
int force; /* If non-zero, overwrite target file if it
|
int force; /* If non-zero, overwrite target file if it
|
* exists. Otherwise, error if target already
|
* exists. Otherwise, error if target already
|
* exists. */
|
* exists. */
|
{
|
{
|
int result;
|
int result;
|
Tcl_DString sourcePath, targetPath, errorBuffer;
|
Tcl_DString sourcePath, targetPath, errorBuffer;
|
char *targetName, *sourceName, *errfile;
|
char *targetName, *sourceName, *errfile;
|
struct stat sourceStatBuf, targetStatBuf;
|
struct stat sourceStatBuf, targetStatBuf;
|
|
|
sourceName = Tcl_TranslateFileName(interp, source, &sourcePath);
|
sourceName = Tcl_TranslateFileName(interp, source, &sourcePath);
|
if (sourceName == NULL) {
|
if (sourceName == NULL) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
targetName = Tcl_TranslateFileName(interp, target, &targetPath);
|
targetName = Tcl_TranslateFileName(interp, target, &targetPath);
|
if (targetName == NULL) {
|
if (targetName == NULL) {
|
Tcl_DStringFree(&sourcePath);
|
Tcl_DStringFree(&sourcePath);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
errfile = NULL;
|
errfile = NULL;
|
result = TCL_ERROR;
|
result = TCL_ERROR;
|
Tcl_DStringInit(&errorBuffer);
|
Tcl_DStringInit(&errorBuffer);
|
|
|
/*
|
/*
|
* We want to copy/rename links and not the files they point to, so we
|
* 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
|
* 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
|
* link and not the file it points to, so we also use lstat() on the
|
* target.
|
* target.
|
*/
|
*/
|
|
|
if (lstat(sourceName, &sourceStatBuf) != 0) {
|
if (lstat(sourceName, &sourceStatBuf) != 0) {
|
errfile = source;
|
errfile = source;
|
goto done;
|
goto done;
|
}
|
}
|
if (lstat(targetName, &targetStatBuf) != 0) {
|
if (lstat(targetName, &targetStatBuf) != 0) {
|
if (errno != ENOENT) {
|
if (errno != ENOENT) {
|
errfile = target;
|
errfile = target;
|
goto done;
|
goto done;
|
}
|
}
|
} else {
|
} else {
|
if (force == 0) {
|
if (force == 0) {
|
errno = EEXIST;
|
errno = EEXIST;
|
errfile = target;
|
errfile = target;
|
goto done;
|
goto done;
|
}
|
}
|
|
|
/*
|
/*
|
* Prevent copying or renaming a file onto itself. Under Windows,
|
* Prevent copying or renaming a file onto itself. Under Windows,
|
* stat always returns 0 for st_ino. However, the Windows-specific
|
* 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
|
* 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.
|
* 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 != 0) && (targetStatBuf.st_ino != 0)) {
|
if ((sourceStatBuf.st_ino == targetStatBuf.st_ino) &&
|
if ((sourceStatBuf.st_ino == targetStatBuf.st_ino) &&
|
(sourceStatBuf.st_dev == targetStatBuf.st_dev)) {
|
(sourceStatBuf.st_dev == targetStatBuf.st_dev)) {
|
result = TCL_OK;
|
result = TCL_OK;
|
goto done;
|
goto done;
|
}
|
}
|
}
|
}
|
|
|
/*
|
/*
|
* Prevent copying/renaming a file onto a directory and
|
* Prevent copying/renaming a file onto a directory and
|
* vice-versa. This is a policy decision based on the fact that
|
* vice-versa. This is a policy decision based on the fact that
|
* existing implementations of copy and rename on all platforms
|
* existing implementations of copy and rename on all platforms
|
* also prevent this.
|
* also prevent this.
|
*/
|
*/
|
|
|
if (S_ISDIR(sourceStatBuf.st_mode)
|
if (S_ISDIR(sourceStatBuf.st_mode)
|
&& !S_ISDIR(targetStatBuf.st_mode)) {
|
&& !S_ISDIR(targetStatBuf.st_mode)) {
|
errno = EISDIR;
|
errno = EISDIR;
|
Tcl_AppendResult(interp, "can't overwrite file \"", target,
|
Tcl_AppendResult(interp, "can't overwrite file \"", target,
|
"\" with directory \"", source, "\"", (char *) NULL);
|
"\" with directory \"", source, "\"", (char *) NULL);
|
goto done;
|
goto done;
|
}
|
}
|
if (!S_ISDIR(sourceStatBuf.st_mode)
|
if (!S_ISDIR(sourceStatBuf.st_mode)
|
&& S_ISDIR(targetStatBuf.st_mode)) {
|
&& S_ISDIR(targetStatBuf.st_mode)) {
|
errno = EISDIR;
|
errno = EISDIR;
|
Tcl_AppendResult(interp, "can't overwrite directory \"", target,
|
Tcl_AppendResult(interp, "can't overwrite directory \"", target,
|
"\" with file \"", source, "\"", (char *) NULL);
|
"\" with file \"", source, "\"", (char *) NULL);
|
goto done;
|
goto done;
|
}
|
}
|
}
|
}
|
|
|
if (copyFlag == 0) {
|
if (copyFlag == 0) {
|
result = TclpRenameFile(sourceName, targetName);
|
result = TclpRenameFile(sourceName, targetName);
|
if (result == TCL_OK) {
|
if (result == TCL_OK) {
|
goto done;
|
goto done;
|
}
|
}
|
|
|
if (errno == EINVAL) {
|
if (errno == EINVAL) {
|
Tcl_AppendResult(interp, "error renaming \"", source, "\" to \"",
|
Tcl_AppendResult(interp, "error renaming \"", source, "\" to \"",
|
target, "\": trying to rename a volume or ",
|
target, "\": trying to rename a volume or ",
|
"move a directory into itself", (char *) NULL);
|
"move a directory into itself", (char *) NULL);
|
goto done;
|
goto done;
|
} else if (errno != EXDEV) {
|
} else if (errno != EXDEV) {
|
errfile = target;
|
errfile = target;
|
goto done;
|
goto done;
|
}
|
}
|
|
|
/*
|
/*
|
* The rename failed because the move was across file systems.
|
* The rename failed because the move was across file systems.
|
* Fall through to copy file and then remove original. Note that
|
* Fall through to copy file and then remove original. Note that
|
* the low-level TclpRenameFile is allowed to implement
|
* the low-level TclpRenameFile is allowed to implement
|
* cross-filesystem moves itself.
|
* cross-filesystem moves itself.
|
*/
|
*/
|
}
|
}
|
|
|
if (S_ISDIR(sourceStatBuf.st_mode)) {
|
if (S_ISDIR(sourceStatBuf.st_mode)) {
|
result = TclpCopyDirectory(sourceName, targetName, &errorBuffer);
|
result = TclpCopyDirectory(sourceName, targetName, &errorBuffer);
|
if (result != TCL_OK) {
|
if (result != TCL_OK) {
|
errfile = Tcl_DStringValue(&errorBuffer);
|
errfile = Tcl_DStringValue(&errorBuffer);
|
if (strcmp(errfile, sourceName) == 0) {
|
if (strcmp(errfile, sourceName) == 0) {
|
errfile = source;
|
errfile = source;
|
} else if (strcmp(errfile, targetName) == 0) {
|
} else if (strcmp(errfile, targetName) == 0) {
|
errfile = target;
|
errfile = target;
|
}
|
}
|
}
|
}
|
} else {
|
} else {
|
result = TclpCopyFile(sourceName, targetName);
|
result = TclpCopyFile(sourceName, targetName);
|
if (result != TCL_OK) {
|
if (result != TCL_OK) {
|
/*
|
/*
|
* Well, there really shouldn't be a problem with source,
|
* Well, there really shouldn't be a problem with source,
|
* because up there we checked to see if it was ok to copy it.
|
* because up there we checked to see if it was ok to copy it.
|
*/
|
*/
|
|
|
errfile = target;
|
errfile = target;
|
}
|
}
|
}
|
}
|
if ((copyFlag == 0) && (result == TCL_OK)) {
|
if ((copyFlag == 0) && (result == TCL_OK)) {
|
if (S_ISDIR(sourceStatBuf.st_mode)) {
|
if (S_ISDIR(sourceStatBuf.st_mode)) {
|
result = TclpRemoveDirectory(sourceName, 1, &errorBuffer);
|
result = TclpRemoveDirectory(sourceName, 1, &errorBuffer);
|
if (result != TCL_OK) {
|
if (result != TCL_OK) {
|
errfile = Tcl_DStringValue(&errorBuffer);
|
errfile = Tcl_DStringValue(&errorBuffer);
|
if (strcmp(errfile, sourceName) == 0) {
|
if (strcmp(errfile, sourceName) == 0) {
|
errfile = source;
|
errfile = source;
|
}
|
}
|
}
|
}
|
} else {
|
} else {
|
result = TclpDeleteFile(sourceName);
|
result = TclpDeleteFile(sourceName);
|
if (result != TCL_OK) {
|
if (result != TCL_OK) {
|
errfile = source;
|
errfile = source;
|
}
|
}
|
}
|
}
|
if (result != TCL_OK) {
|
if (result != TCL_OK) {
|
Tcl_AppendResult(interp, "can't unlink \"", errfile, "\": ",
|
Tcl_AppendResult(interp, "can't unlink \"", errfile, "\": ",
|
Tcl_PosixError(interp), (char *) NULL);
|
Tcl_PosixError(interp), (char *) NULL);
|
errfile = NULL;
|
errfile = NULL;
|
}
|
}
|
}
|
}
|
|
|
done:
|
done:
|
if (errfile != NULL) {
|
if (errfile != NULL) {
|
Tcl_AppendResult(interp,
|
Tcl_AppendResult(interp,
|
((copyFlag) ? "error copying \"" : "error renaming \""),
|
((copyFlag) ? "error copying \"" : "error renaming \""),
|
source, (char *) NULL);
|
source, (char *) NULL);
|
if (errfile != source) {
|
if (errfile != source) {
|
Tcl_AppendResult(interp, "\" to \"", target, (char *) NULL);
|
Tcl_AppendResult(interp, "\" to \"", target, (char *) NULL);
|
if (errfile != target) {
|
if (errfile != target) {
|
Tcl_AppendResult(interp, "\": \"", errfile, (char *) NULL);
|
Tcl_AppendResult(interp, "\": \"", errfile, (char *) NULL);
|
}
|
}
|
}
|
}
|
Tcl_AppendResult(interp, "\": ", Tcl_PosixError(interp),
|
Tcl_AppendResult(interp, "\": ", Tcl_PosixError(interp),
|
(char *) NULL);
|
(char *) NULL);
|
}
|
}
|
Tcl_DStringFree(&errorBuffer);
|
Tcl_DStringFree(&errorBuffer);
|
Tcl_DStringFree(&sourcePath);
|
Tcl_DStringFree(&sourcePath);
|
Tcl_DStringFree(&targetPath);
|
Tcl_DStringFree(&targetPath);
|
return result;
|
return result;
|
}
|
}
|
|
|
/*
|
/*
|
*---------------------------------------------------------------------------
|
*---------------------------------------------------------------------------
|
*
|
*
|
* FileForceOption --
|
* FileForceOption --
|
*
|
*
|
* Helps parse command line options for file commands that take
|
* Helps parse command line options for file commands that take
|
* the "-force" and "--" options.
|
* the "-force" and "--" options.
|
*
|
*
|
* Results:
|
* Results:
|
* The return value is how many arguments from argv were consumed
|
* The return value is how many arguments from argv were consumed
|
* by this function, or -1 if there was an error parsing the
|
* by this function, or -1 if there was an error parsing the
|
* options. If an error occurred, an error message is left in
|
* options. If an error occurred, an error message is left in
|
* interp->result.
|
* interp->result.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* None.
|
* None.
|
*
|
*
|
*---------------------------------------------------------------------------
|
*---------------------------------------------------------------------------
|
*/
|
*/
|
|
|
static int
|
static int
|
FileForceOption(interp, argc, argv, forcePtr)
|
FileForceOption(interp, argc, argv, forcePtr)
|
Tcl_Interp *interp; /* Interp, for error return. */
|
Tcl_Interp *interp; /* Interp, for error return. */
|
int argc; /* Number of arguments. */
|
int argc; /* Number of arguments. */
|
char **argv; /* Argument strings. First command line
|
char **argv; /* Argument strings. First command line
|
option, if it exists, begins at */
|
option, if it exists, begins at */
|
int *forcePtr; /* If the "-force" was specified, *forcePtr
|
int *forcePtr; /* If the "-force" was specified, *forcePtr
|
* is filled with 1, otherwise with 0. */
|
* is filled with 1, otherwise with 0. */
|
{
|
{
|
int force, i;
|
int force, i;
|
|
|
force = 0;
|
force = 0;
|
for (i = 0; i < argc; i++) {
|
for (i = 0; i < argc; i++) {
|
if (argv[i][0] != '-') {
|
if (argv[i][0] != '-') {
|
break;
|
break;
|
}
|
}
|
if (strcmp(argv[i], "-force") == 0) {
|
if (strcmp(argv[i], "-force") == 0) {
|
force = 1;
|
force = 1;
|
} else if (strcmp(argv[i], "--") == 0) {
|
} else if (strcmp(argv[i], "--") == 0) {
|
i++;
|
i++;
|
break;
|
break;
|
} else {
|
} else {
|
Tcl_AppendResult(interp, "bad option \"", argv[i],
|
Tcl_AppendResult(interp, "bad option \"", argv[i],
|
"\": should be -force or --", (char *)NULL);
|
"\": should be -force or --", (char *)NULL);
|
return -1;
|
return -1;
|
}
|
}
|
}
|
}
|
*forcePtr = force;
|
*forcePtr = force;
|
return i;
|
return i;
|
}
|
}
|
/*
|
/*
|
*---------------------------------------------------------------------------
|
*---------------------------------------------------------------------------
|
*
|
*
|
* FileBasename --
|
* FileBasename --
|
*
|
*
|
* Given a path in either tcl format (with / separators), or in the
|
* Given a path in either tcl format (with / separators), or in the
|
* platform-specific format for the current platform, return all the
|
* platform-specific format for the current platform, return all the
|
* characters in the path after the last directory separator. But,
|
* characters in the path after the last directory separator. But,
|
* if path is the root directory, returns no characters.
|
* if path is the root directory, returns no characters.
|
*
|
*
|
* Results:
|
* Results:
|
* Appends the string that represents the basename to the end of
|
* Appends the string that represents the basename to the end of
|
* the specified initialized DString, returning a pointer to the
|
* the specified initialized DString, returning a pointer to the
|
* resulting string. If there is an error, an error message is left
|
* resulting string. If there is an error, an error message is left
|
* in interp, NULL is returned, and the Tcl_DString is unmodified.
|
* in interp, NULL is returned, and the Tcl_DString is unmodified.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* None.
|
* None.
|
*
|
*
|
*---------------------------------------------------------------------------
|
*---------------------------------------------------------------------------
|
*/
|
*/
|
|
|
static char *
|
static char *
|
FileBasename(interp, path, bufferPtr)
|
FileBasename(interp, path, bufferPtr)
|
Tcl_Interp *interp; /* Interp, for error return. */
|
Tcl_Interp *interp; /* Interp, for error return. */
|
char *path; /* Path whose basename to extract. */
|
char *path; /* Path whose basename to extract. */
|
Tcl_DString *bufferPtr; /* Initialized DString that receives
|
Tcl_DString *bufferPtr; /* Initialized DString that receives
|
* basename. */
|
* basename. */
|
{
|
{
|
int argc;
|
int argc;
|
char **argv;
|
char **argv;
|
|
|
Tcl_SplitPath(path, &argc, &argv);
|
Tcl_SplitPath(path, &argc, &argv);
|
if (argc == 0) {
|
if (argc == 0) {
|
Tcl_DStringInit(bufferPtr);
|
Tcl_DStringInit(bufferPtr);
|
} else {
|
} else {
|
if ((argc == 1) && (*path == '~')) {
|
if ((argc == 1) && (*path == '~')) {
|
Tcl_DString buffer;
|
Tcl_DString buffer;
|
|
|
ckfree((char *) argv);
|
ckfree((char *) argv);
|
path = Tcl_TranslateFileName(interp, path, &buffer);
|
path = Tcl_TranslateFileName(interp, path, &buffer);
|
if (path == NULL) {
|
if (path == NULL) {
|
return NULL;
|
return NULL;
|
}
|
}
|
Tcl_SplitPath(path, &argc, &argv);
|
Tcl_SplitPath(path, &argc, &argv);
|
Tcl_DStringFree(&buffer);
|
Tcl_DStringFree(&buffer);
|
}
|
}
|
Tcl_DStringInit(bufferPtr);
|
Tcl_DStringInit(bufferPtr);
|
|
|
/*
|
/*
|
* Return the last component, unless it is the only component, and it
|
* Return the last component, unless it is the only component, and it
|
* is the root of an absolute path.
|
* is the root of an absolute path.
|
*/
|
*/
|
|
|
if (argc > 0) {
|
if (argc > 0) {
|
if ((argc > 1)
|
if ((argc > 1)
|
|| (Tcl_GetPathType(argv[0]) == TCL_PATH_RELATIVE)) {
|
|| (Tcl_GetPathType(argv[0]) == TCL_PATH_RELATIVE)) {
|
Tcl_DStringAppend(bufferPtr, argv[argc - 1], -1);
|
Tcl_DStringAppend(bufferPtr, argv[argc - 1], -1);
|
}
|
}
|
}
|
}
|
}
|
}
|
ckfree((char *) argv);
|
ckfree((char *) argv);
|
return Tcl_DStringValue(bufferPtr);
|
return Tcl_DStringValue(bufferPtr);
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* TclFileAttrsCmd --
|
* TclFileAttrsCmd --
|
*
|
*
|
* Sets or gets the platform-specific attributes of a file. The objc-objv
|
* 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.
|
* points to the file name with the rest of the command line following.
|
* This routine uses platform-specific tables of option strings
|
* This routine uses platform-specific tables of option strings
|
* and callbacks. The callback to get the attributes take three
|
* and callbacks. The callback to get the attributes take three
|
* parameters:
|
* parameters:
|
* Tcl_Interp *interp; The interp to report errors with.
|
* Tcl_Interp *interp; The interp to report errors with.
|
* Since this is an object-based API,
|
* Since this is an object-based API,
|
* the object form of the result should be
|
* the object form of the result should be
|
* used.
|
* used.
|
* CONST char *fileName; This is extracted using
|
* CONST char *fileName; This is extracted using
|
* Tcl_TranslateFileName.
|
* Tcl_TranslateFileName.
|
* TclObj **attrObjPtrPtr; A new object to hold the attribute
|
* TclObj **attrObjPtrPtr; A new object to hold the attribute
|
* is allocated and put here.
|
* is allocated and put here.
|
* The first two parameters of the callback used to write out the
|
* The first two parameters of the callback used to write out the
|
* attributes are the same. The third parameter is:
|
* attributes are the same. The third parameter is:
|
* CONST *attrObjPtr; A pointer to the object that has
|
* CONST *attrObjPtr; A pointer to the object that has
|
* the new attribute.
|
* the new attribute.
|
* They both return standard TCL errors; if the routine to get
|
* They both return standard TCL errors; if the routine to get
|
* an attribute fails, no object is allocated and *attrObjPtrPtr
|
* an attribute fails, no object is allocated and *attrObjPtrPtr
|
* is unchanged.
|
* is unchanged.
|
*
|
*
|
* Results:
|
* Results:
|
* Standard TCL error.
|
* Standard TCL error.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* May set file attributes for the file name.
|
* May set file attributes for the file name.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
int
|
int
|
TclFileAttrsCmd(interp, objc, objv)
|
TclFileAttrsCmd(interp, objc, objv)
|
Tcl_Interp *interp; /* The interpreter for error reporting. */
|
Tcl_Interp *interp; /* The interpreter for error reporting. */
|
int objc; /* Number of command line arguments. */
|
int objc; /* Number of command line arguments. */
|
Tcl_Obj *CONST objv[]; /* The command line objects. */
|
Tcl_Obj *CONST objv[]; /* The command line objects. */
|
{
|
{
|
Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
|
Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
|
char *fileName;
|
char *fileName;
|
int length, index;
|
int length, index;
|
Tcl_Obj *listObjPtr;
|
Tcl_Obj *listObjPtr;
|
Tcl_Obj *elementObjPtr;
|
Tcl_Obj *elementObjPtr;
|
Tcl_DString buffer;
|
Tcl_DString buffer;
|
|
|
if ((objc > 2) && ((objc % 2) == 0)) {
|
if ((objc > 2) && ((objc % 2) == 0)) {
|
Tcl_AppendStringsToObj(resultPtr,
|
Tcl_AppendStringsToObj(resultPtr,
|
"wrong # args: must be \"file attributes name ?option? ?value? ?option value? ...\"",
|
"wrong # args: must be \"file attributes name ?option? ?value? ?option value? ...\"",
|
(char *) NULL);
|
(char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
fileName = Tcl_GetStringFromObj(objv[0], &length);
|
fileName = Tcl_GetStringFromObj(objv[0], &length);
|
if (Tcl_TranslateFileName(interp, fileName, &buffer) == NULL) {
|
if (Tcl_TranslateFileName(interp, fileName, &buffer) == NULL) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
fileName = Tcl_DStringValue(&buffer);
|
fileName = Tcl_DStringValue(&buffer);
|
|
|
if (objc == 1) {
|
if (objc == 1) {
|
listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
|
listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
|
|
|
for (index = 0; tclpFileAttrStrings[index] != NULL; index++) {
|
for (index = 0; tclpFileAttrStrings[index] != NULL; index++) {
|
elementObjPtr = Tcl_NewStringObj(tclpFileAttrStrings[index], -1);
|
elementObjPtr = Tcl_NewStringObj(tclpFileAttrStrings[index], -1);
|
Tcl_ListObjAppendElement(interp, listObjPtr, elementObjPtr);
|
Tcl_ListObjAppendElement(interp, listObjPtr, elementObjPtr);
|
if ((*tclpFileAttrProcs[index].getProc)(interp, index, fileName,
|
if ((*tclpFileAttrProcs[index].getProc)(interp, index, fileName,
|
&elementObjPtr) != TCL_OK) {
|
&elementObjPtr) != TCL_OK) {
|
Tcl_DecrRefCount(listObjPtr);
|
Tcl_DecrRefCount(listObjPtr);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
Tcl_ListObjAppendElement(interp, listObjPtr, elementObjPtr);
|
Tcl_ListObjAppendElement(interp, listObjPtr, elementObjPtr);
|
}
|
}
|
Tcl_SetObjResult(interp, listObjPtr);
|
Tcl_SetObjResult(interp, listObjPtr);
|
} else if (objc == 2) {
|
} else if (objc == 2) {
|
if (Tcl_GetIndexFromObj(interp, objv[1], tclpFileAttrStrings, "option",
|
if (Tcl_GetIndexFromObj(interp, objv[1], tclpFileAttrStrings, "option",
|
0, &index) != TCL_OK) {
|
0, &index) != TCL_OK) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
if ((*tclpFileAttrProcs[index].getProc)(interp, index, fileName,
|
if ((*tclpFileAttrProcs[index].getProc)(interp, index, fileName,
|
&elementObjPtr) != TCL_OK) {
|
&elementObjPtr) != TCL_OK) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
Tcl_SetObjResult(interp, elementObjPtr);
|
Tcl_SetObjResult(interp, elementObjPtr);
|
} else {
|
} else {
|
int i;
|
int i;
|
|
|
for (i = 1; i < objc ; i += 2) {
|
for (i = 1; i < objc ; i += 2) {
|
if (Tcl_GetIndexFromObj(interp, objv[i], tclpFileAttrStrings, "option",
|
if (Tcl_GetIndexFromObj(interp, objv[i], tclpFileAttrStrings, "option",
|
0, &index) != TCL_OK) {
|
0, &index) != TCL_OK) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
if ((*tclpFileAttrProcs[index].setProc)(interp, index, fileName,
|
if ((*tclpFileAttrProcs[index].setProc)(interp, index, fileName,
|
objv[i + 1]) != TCL_OK) {
|
objv[i + 1]) != TCL_OK) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
}
|
}
|
}
|
}
|
|
|
Tcl_DStringFree(&buffer);
|
Tcl_DStringFree(&buffer);
|
|
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
