os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclFCmd.c
1.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2 +++ b/os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclFCmd.c Fri Jun 15 03:10:57 2012 +0200
1.3 @@ -0,0 +1,1042 @@
1.4 +/*
1.5 + * tclFCmd.c
1.6 + *
1.7 + * This file implements the generic portion of file manipulation
1.8 + * subcommands of the "file" command.
1.9 + *
1.10 + * Copyright (c) 1996-1998 Sun Microsystems, Inc.
1.11 + *
1.12 + * See the file "license.terms" for information on usage and redistribution
1.13 + * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
1.14 + *
1.15 + * RCS: @(#) $Id: tclFCmd.c,v 1.20.2.2 2005/08/17 17:46:36 hobbs Exp $
1.16 + */
1.17 +
1.18 +#include "tclInt.h"
1.19 +#include "tclPort.h"
1.20 +
1.21 +/*
1.22 + * Declarations for local procedures defined in this file:
1.23 + */
1.24 +
1.25 +static int CopyRenameOneFile _ANSI_ARGS_((Tcl_Interp *interp,
1.26 + Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr,
1.27 + int copyFlag, int force));
1.28 +static Tcl_Obj * FileBasename _ANSI_ARGS_((Tcl_Interp *interp,
1.29 + Tcl_Obj *pathPtr));
1.30 +static int FileCopyRename _ANSI_ARGS_((Tcl_Interp *interp,
1.31 + int objc, Tcl_Obj *CONST objv[], int copyFlag));
1.32 +static int FileForceOption _ANSI_ARGS_((Tcl_Interp *interp,
1.33 + int objc, Tcl_Obj *CONST objv[], int *forcePtr));
1.34 +
1.35 +/*
1.36 + *---------------------------------------------------------------------------
1.37 + *
1.38 + * TclFileRenameCmd
1.39 + *
1.40 + * This procedure implements the "rename" subcommand of the "file"
1.41 + * command. Filename arguments need to be translated to native
1.42 + * format before being passed to platform-specific code that
1.43 + * implements rename functionality.
1.44 + *
1.45 + * Results:
1.46 + * A standard Tcl result.
1.47 + *
1.48 + * Side effects:
1.49 + * See the user documentation.
1.50 + *
1.51 + *---------------------------------------------------------------------------
1.52 + */
1.53 +
1.54 +int
1.55 +TclFileRenameCmd(interp, objc, objv)
1.56 + Tcl_Interp *interp; /* Interp for error reporting. */
1.57 + int objc; /* Number of arguments. */
1.58 + Tcl_Obj *CONST objv[]; /* Argument strings passed to Tcl_FileCmd. */
1.59 +{
1.60 + return FileCopyRename(interp, objc, objv, 0);
1.61 +}
1.62 +
1.63 +/*
1.64 + *---------------------------------------------------------------------------
1.65 + *
1.66 + * TclFileCopyCmd
1.67 + *
1.68 + * This procedure implements the "copy" subcommand of the "file"
1.69 + * command. Filename arguments need to be translated to native
1.70 + * format before being passed to platform-specific code that
1.71 + * implements copy functionality.
1.72 + *
1.73 + * Results:
1.74 + * A standard Tcl result.
1.75 + *
1.76 + * Side effects:
1.77 + * See the user documentation.
1.78 + *
1.79 + *---------------------------------------------------------------------------
1.80 + */
1.81 +
1.82 +int
1.83 +TclFileCopyCmd(interp, objc, objv)
1.84 + Tcl_Interp *interp; /* Used for error reporting */
1.85 + int objc; /* Number of arguments. */
1.86 + Tcl_Obj *CONST objv[]; /* Argument strings passed to Tcl_FileCmd. */
1.87 +{
1.88 + return FileCopyRename(interp, objc, objv, 1);
1.89 +}
1.90 +
1.91 +/*
1.92 + *---------------------------------------------------------------------------
1.93 + *
1.94 + * FileCopyRename --
1.95 + *
1.96 + * Performs the work of TclFileRenameCmd and TclFileCopyCmd.
1.97 + * See comments for those procedures.
1.98 + *
1.99 + * Results:
1.100 + * See above.
1.101 + *
1.102 + * Side effects:
1.103 + * See above.
1.104 + *
1.105 + *---------------------------------------------------------------------------
1.106 + */
1.107 +
1.108 +static int
1.109 +FileCopyRename(interp, objc, objv, copyFlag)
1.110 + Tcl_Interp *interp; /* Used for error reporting. */
1.111 + int objc; /* Number of arguments. */
1.112 + Tcl_Obj *CONST objv[]; /* Argument strings passed to Tcl_FileCmd. */
1.113 + int copyFlag; /* If non-zero, copy source(s). Otherwise,
1.114 + * rename them. */
1.115 +{
1.116 + int i, result, force;
1.117 + Tcl_StatBuf statBuf;
1.118 + Tcl_Obj *target;
1.119 +
1.120 + i = FileForceOption(interp, objc - 2, objv + 2, &force);
1.121 + if (i < 0) {
1.122 + return TCL_ERROR;
1.123 + }
1.124 + i += 2;
1.125 + if ((objc - i) < 2) {
1.126 + Tcl_AppendResult(interp, "wrong # args: should be \"",
1.127 + Tcl_GetString(objv[0]), " ", Tcl_GetString(objv[1]),
1.128 + " ?options? source ?source ...? target\"",
1.129 + (char *) NULL);
1.130 + return TCL_ERROR;
1.131 + }
1.132 +
1.133 + /*
1.134 + * If target doesn't exist or isn't a directory, try the copy/rename.
1.135 + * More than 2 arguments is only valid if the target is an existing
1.136 + * directory.
1.137 + */
1.138 +
1.139 + target = objv[objc - 1];
1.140 + if (Tcl_FSConvertToPathType(interp, target) != TCL_OK) {
1.141 + return TCL_ERROR;
1.142 + }
1.143 +
1.144 + result = TCL_OK;
1.145 +
1.146 + /*
1.147 + * Call Tcl_FSStat() so that if target is a symlink that points to a
1.148 + * directory we will put the sources in that directory instead of
1.149 + * overwriting the symlink.
1.150 + */
1.151 +
1.152 + if ((Tcl_FSStat(target, &statBuf) != 0) || !S_ISDIR(statBuf.st_mode)) {
1.153 + if ((objc - i) > 2) {
1.154 + errno = ENOTDIR;
1.155 + Tcl_PosixError(interp);
1.156 + Tcl_AppendResult(interp, "error ",
1.157 + ((copyFlag) ? "copying" : "renaming"), ": target \"",
1.158 + Tcl_GetString(target), "\" is not a directory",
1.159 + (char *) NULL);
1.160 + result = TCL_ERROR;
1.161 + } else {
1.162 + /*
1.163 + * Even though already have target == translated(objv[i+1]),
1.164 + * pass the original argument down, so if there's an error, the
1.165 + * error message will reflect the original arguments.
1.166 + */
1.167 +
1.168 + result = CopyRenameOneFile(interp, objv[i], objv[i + 1], copyFlag,
1.169 + force);
1.170 + }
1.171 + return result;
1.172 + }
1.173 +
1.174 + /*
1.175 + * Move each source file into target directory. Extract the basename
1.176 + * from each source, and append it to the end of the target path.
1.177 + */
1.178 +
1.179 + for ( ; i < objc - 1; i++) {
1.180 + Tcl_Obj *jargv[2];
1.181 + Tcl_Obj *source, *newFileName;
1.182 + Tcl_Obj *temp;
1.183 +
1.184 + source = FileBasename(interp, objv[i]);
1.185 + if (source == NULL) {
1.186 + result = TCL_ERROR;
1.187 + break;
1.188 + }
1.189 + jargv[0] = objv[objc - 1];
1.190 + jargv[1] = source;
1.191 + temp = Tcl_NewListObj(2, jargv);
1.192 + newFileName = Tcl_FSJoinPath(temp, -1);
1.193 + Tcl_IncrRefCount(newFileName);
1.194 + result = CopyRenameOneFile(interp, objv[i], newFileName, copyFlag,
1.195 + force);
1.196 + Tcl_DecrRefCount(newFileName);
1.197 + Tcl_DecrRefCount(temp);
1.198 + Tcl_DecrRefCount(source);
1.199 +
1.200 + if (result == TCL_ERROR) {
1.201 + break;
1.202 + }
1.203 + }
1.204 + return result;
1.205 +}
1.206 +
1.207 +/*
1.208 + *---------------------------------------------------------------------------
1.209 + *
1.210 + * TclFileMakeDirsCmd
1.211 + *
1.212 + * This procedure implements the "mkdir" subcommand of the "file"
1.213 + * command. Filename arguments need to be translated to native
1.214 + * format before being passed to platform-specific code that
1.215 + * implements mkdir functionality.
1.216 + *
1.217 + * Results:
1.218 + * A standard Tcl result.
1.219 + *
1.220 + * Side effects:
1.221 + * See the user documentation.
1.222 + *
1.223 + *----------------------------------------------------------------------
1.224 + */
1.225 +int
1.226 +TclFileMakeDirsCmd(interp, objc, objv)
1.227 + Tcl_Interp *interp; /* Used for error reporting. */
1.228 + int objc; /* Number of arguments */
1.229 + Tcl_Obj *CONST objv[]; /* Argument strings passed to Tcl_FileCmd. */
1.230 +{
1.231 + Tcl_Obj *errfile;
1.232 + int result, i, j, pobjc;
1.233 + Tcl_Obj *split = NULL;
1.234 + Tcl_Obj *target = NULL;
1.235 + Tcl_StatBuf statBuf;
1.236 +
1.237 + errfile = NULL;
1.238 +
1.239 + result = TCL_OK;
1.240 + for (i = 2; i < objc; i++) {
1.241 + if (Tcl_FSConvertToPathType(interp, objv[i]) != TCL_OK) {
1.242 + result = TCL_ERROR;
1.243 + break;
1.244 + }
1.245 +
1.246 + split = Tcl_FSSplitPath(objv[i],&pobjc);
1.247 + if (pobjc == 0) {
1.248 + errno = ENOENT;
1.249 + errfile = objv[i];
1.250 + break;
1.251 + }
1.252 + for (j = 0; j < pobjc; j++) {
1.253 + target = Tcl_FSJoinPath(split, j + 1);
1.254 + Tcl_IncrRefCount(target);
1.255 + /*
1.256 + * Call Tcl_FSStat() so that if target is a symlink that
1.257 + * points to a directory we will create subdirectories in
1.258 + * that directory.
1.259 + */
1.260 +
1.261 + if (Tcl_FSStat(target, &statBuf) == 0) {
1.262 + if (!S_ISDIR(statBuf.st_mode)) {
1.263 + errno = EEXIST;
1.264 + errfile = target;
1.265 + goto done;
1.266 + }
1.267 + } else if (errno != ENOENT) {
1.268 + /*
1.269 + * If Tcl_FSStat() failed and the error is anything
1.270 + * other than non-existence of the target, throw the
1.271 + * error.
1.272 + */
1.273 + errfile = target;
1.274 + goto done;
1.275 + } else if (Tcl_FSCreateDirectory(target) != TCL_OK) {
1.276 + /*
1.277 + * Create might have failed because of being in a race
1.278 + * condition with another process trying to create the
1.279 + * same subdirectory.
1.280 + */
1.281 + if (errno == EEXIST) {
1.282 + if ((Tcl_FSStat(target, &statBuf) == 0)
1.283 + && S_ISDIR(statBuf.st_mode)) {
1.284 + /*
1.285 + * It is a directory that wasn't there before,
1.286 + * so keep going without error.
1.287 + */
1.288 + Tcl_ResetResult(interp);
1.289 + } else {
1.290 + errfile = target;
1.291 + goto done;
1.292 + }
1.293 + } else {
1.294 + errfile = target;
1.295 + goto done;
1.296 + }
1.297 + }
1.298 + /* Forget about this sub-path */
1.299 + Tcl_DecrRefCount(target);
1.300 + target = NULL;
1.301 + }
1.302 + Tcl_DecrRefCount(split);
1.303 + split = NULL;
1.304 + }
1.305 +
1.306 + done:
1.307 + if (errfile != NULL) {
1.308 + Tcl_AppendResult(interp, "can't create directory \"",
1.309 + Tcl_GetString(errfile), "\": ", Tcl_PosixError(interp),
1.310 + (char *) NULL);
1.311 + result = TCL_ERROR;
1.312 + }
1.313 + if (split != NULL) {
1.314 + Tcl_DecrRefCount(split);
1.315 + }
1.316 + if (target != NULL) {
1.317 + Tcl_DecrRefCount(target);
1.318 + }
1.319 + return result;
1.320 +}
1.321 +
1.322 +/*
1.323 + *----------------------------------------------------------------------
1.324 + *
1.325 + * TclFileDeleteCmd
1.326 + *
1.327 + * This procedure implements the "delete" subcommand of the "file"
1.328 + * command.
1.329 + *
1.330 + * Results:
1.331 + * A standard Tcl result.
1.332 + *
1.333 + * Side effects:
1.334 + * See the user documentation.
1.335 + *
1.336 + *----------------------------------------------------------------------
1.337 + */
1.338 +
1.339 +int
1.340 +TclFileDeleteCmd(interp, objc, objv)
1.341 + Tcl_Interp *interp; /* Used for error reporting */
1.342 + int objc; /* Number of arguments */
1.343 + Tcl_Obj *CONST objv[]; /* Argument strings passed to Tcl_FileCmd. */
1.344 +{
1.345 + int i, force, result;
1.346 + Tcl_Obj *errfile;
1.347 + Tcl_Obj *errorBuffer = NULL;
1.348 +
1.349 + i = FileForceOption(interp, objc - 2, objv + 2, &force);
1.350 + if (i < 0) {
1.351 + return TCL_ERROR;
1.352 + }
1.353 + i += 2;
1.354 + if ((objc - i) < 1) {
1.355 + Tcl_AppendResult(interp, "wrong # args: should be \"",
1.356 + Tcl_GetString(objv[0]), " ", Tcl_GetString(objv[1]),
1.357 + " ?options? file ?file ...?\"", (char *) NULL);
1.358 + return TCL_ERROR;
1.359 + }
1.360 +
1.361 + errfile = NULL;
1.362 + result = TCL_OK;
1.363 +
1.364 + for ( ; i < objc; i++) {
1.365 + Tcl_StatBuf statBuf;
1.366 +
1.367 + errfile = objv[i];
1.368 + if (Tcl_FSConvertToPathType(interp, objv[i]) != TCL_OK) {
1.369 + result = TCL_ERROR;
1.370 + goto done;
1.371 + }
1.372 +
1.373 + /*
1.374 + * Call lstat() to get info so can delete symbolic link itself.
1.375 + */
1.376 +
1.377 + if (Tcl_FSLstat(objv[i], &statBuf) != 0) {
1.378 + /*
1.379 + * Trying to delete a file that does not exist is not
1.380 + * considered an error, just a no-op
1.381 + */
1.382 +
1.383 + if (errno != ENOENT) {
1.384 + result = TCL_ERROR;
1.385 + }
1.386 + } else if (S_ISDIR(statBuf.st_mode)) {
1.387 + /*
1.388 + * We own a reference count on errorBuffer, if it was set
1.389 + * as a result of this call.
1.390 + */
1.391 + result = Tcl_FSRemoveDirectory(objv[i], force, &errorBuffer);
1.392 + if (result != TCL_OK) {
1.393 + if ((force == 0) && (errno == EEXIST)) {
1.394 + Tcl_AppendResult(interp, "error deleting \"",
1.395 + Tcl_GetString(objv[i]),
1.396 + "\": directory not empty", (char *) NULL);
1.397 + Tcl_PosixError(interp);
1.398 + goto done;
1.399 + }
1.400 +
1.401 + /*
1.402 + * If possible, use the untranslated name for the file.
1.403 + */
1.404 +
1.405 + errfile = errorBuffer;
1.406 + /* FS supposed to check between translated objv and errfile */
1.407 + if (Tcl_FSEqualPaths(objv[i], errfile)) {
1.408 + errfile = objv[i];
1.409 + }
1.410 + }
1.411 + } else {
1.412 + result = Tcl_FSDeleteFile(objv[i]);
1.413 + }
1.414 +
1.415 + if (result != TCL_OK) {
1.416 + result = TCL_ERROR;
1.417 + /*
1.418 + * It is important that we break on error, otherwise we
1.419 + * might end up owning reference counts on numerous
1.420 + * errorBuffers.
1.421 + */
1.422 + break;
1.423 + }
1.424 + }
1.425 + if (result != TCL_OK) {
1.426 + if (errfile == NULL) {
1.427 + /*
1.428 + * We try to accomodate poor error results from our
1.429 + * Tcl_FS calls
1.430 + */
1.431 + Tcl_AppendResult(interp, "error deleting unknown file: ",
1.432 + Tcl_PosixError(interp), (char *) NULL);
1.433 + } else {
1.434 + Tcl_AppendResult(interp, "error deleting \"",
1.435 + Tcl_GetString(errfile), "\": ",
1.436 + Tcl_PosixError(interp), (char *) NULL);
1.437 + }
1.438 + }
1.439 + done:
1.440 + if (errorBuffer != NULL) {
1.441 + Tcl_DecrRefCount(errorBuffer);
1.442 + }
1.443 + return result;
1.444 +}
1.445 +
1.446 +/*
1.447 + *---------------------------------------------------------------------------
1.448 + *
1.449 + * CopyRenameOneFile
1.450 + *
1.451 + * Copies or renames specified source file or directory hierarchy
1.452 + * to the specified target.
1.453 + *
1.454 + * Results:
1.455 + * A standard Tcl result.
1.456 + *
1.457 + * Side effects:
1.458 + * Target is overwritten if the force flag is set. Attempting to
1.459 + * copy/rename a file onto a directory or a directory onto a file
1.460 + * will always result in an error.
1.461 + *
1.462 + *----------------------------------------------------------------------
1.463 + */
1.464 +
1.465 +static int
1.466 +CopyRenameOneFile(interp, source, target, copyFlag, force)
1.467 + Tcl_Interp *interp; /* Used for error reporting. */
1.468 + Tcl_Obj *source; /* Pathname of file to copy. May need to
1.469 + * be translated. */
1.470 + Tcl_Obj *target; /* Pathname of file to create/overwrite.
1.471 + * May need to be translated. */
1.472 + int copyFlag; /* If non-zero, copy files. Otherwise,
1.473 + * rename them. */
1.474 + int force; /* If non-zero, overwrite target file if it
1.475 + * exists. Otherwise, error if target already
1.476 + * exists. */
1.477 +{
1.478 + int result;
1.479 + Tcl_Obj *errfile, *errorBuffer;
1.480 + /* If source is a link, then this is the real file/directory */
1.481 + Tcl_Obj *actualSource = NULL;
1.482 + Tcl_StatBuf sourceStatBuf, targetStatBuf;
1.483 +
1.484 + if (Tcl_FSConvertToPathType(interp, source) != TCL_OK) {
1.485 + return TCL_ERROR;
1.486 + }
1.487 + if (Tcl_FSConvertToPathType(interp, target) != TCL_OK) {
1.488 + return TCL_ERROR;
1.489 + }
1.490 +
1.491 + errfile = NULL;
1.492 + errorBuffer = NULL;
1.493 + result = TCL_ERROR;
1.494 +
1.495 + /*
1.496 + * We want to copy/rename links and not the files they point to, so we
1.497 + * use lstat(). If target is a link, we also want to replace the
1.498 + * link and not the file it points to, so we also use lstat() on the
1.499 + * target.
1.500 + */
1.501 +
1.502 + if (Tcl_FSLstat(source, &sourceStatBuf) != 0) {
1.503 + errfile = source;
1.504 + goto done;
1.505 + }
1.506 + if (Tcl_FSLstat(target, &targetStatBuf) != 0) {
1.507 + if (errno != ENOENT) {
1.508 + errfile = target;
1.509 + goto done;
1.510 + }
1.511 + } else {
1.512 + if (force == 0) {
1.513 + errno = EEXIST;
1.514 + errfile = target;
1.515 + goto done;
1.516 + }
1.517 +
1.518 + /*
1.519 + * Prevent copying or renaming a file onto itself. Under Windows,
1.520 + * stat always returns 0 for st_ino. However, the Windows-specific
1.521 + * code knows how to deal with copying or renaming a file on top of
1.522 + * itself. It might be a good idea to write a stat that worked.
1.523 + */
1.524 +
1.525 + if ((sourceStatBuf.st_ino != 0) && (targetStatBuf.st_ino != 0)) {
1.526 + if ((sourceStatBuf.st_ino == targetStatBuf.st_ino) &&
1.527 + (sourceStatBuf.st_dev == targetStatBuf.st_dev)) {
1.528 + result = TCL_OK;
1.529 + goto done;
1.530 + }
1.531 + }
1.532 +
1.533 + /*
1.534 + * Prevent copying/renaming a file onto a directory and
1.535 + * vice-versa. This is a policy decision based on the fact that
1.536 + * existing implementations of copy and rename on all platforms
1.537 + * also prevent this.
1.538 + */
1.539 +
1.540 + if (S_ISDIR(sourceStatBuf.st_mode)
1.541 + && !S_ISDIR(targetStatBuf.st_mode)) {
1.542 + errno = EISDIR;
1.543 + Tcl_AppendResult(interp, "can't overwrite file \"",
1.544 + Tcl_GetString(target), "\" with directory \"",
1.545 + Tcl_GetString(source), "\"", (char *) NULL);
1.546 + goto done;
1.547 + }
1.548 + if (!S_ISDIR(sourceStatBuf.st_mode)
1.549 + && S_ISDIR(targetStatBuf.st_mode)) {
1.550 + errno = EISDIR;
1.551 + Tcl_AppendResult(interp, "can't overwrite directory \"",
1.552 + Tcl_GetString(target), "\" with file \"",
1.553 + Tcl_GetString(source), "\"", (char *) NULL);
1.554 + goto done;
1.555 + }
1.556 + }
1.557 +
1.558 + if (copyFlag == 0) {
1.559 + result = Tcl_FSRenameFile(source, target);
1.560 + if (result == TCL_OK) {
1.561 + goto done;
1.562 + }
1.563 +
1.564 + if (errno == EINVAL) {
1.565 + Tcl_AppendResult(interp, "error renaming \"",
1.566 + Tcl_GetString(source), "\" to \"",
1.567 + Tcl_GetString(target), "\": trying to rename a volume or ",
1.568 + "move a directory into itself", (char *) NULL);
1.569 + goto done;
1.570 + } else if (errno != EXDEV) {
1.571 + errfile = target;
1.572 + goto done;
1.573 + }
1.574 +
1.575 + /*
1.576 + * The rename failed because the move was across file systems.
1.577 + * Fall through to copy file and then remove original. Note that
1.578 + * the low-level Tcl_FSRenameFileProc in the filesystem is allowed
1.579 + * to implement cross-filesystem moves itself, if it desires.
1.580 + */
1.581 + }
1.582 +
1.583 + actualSource = source;
1.584 + Tcl_IncrRefCount(actualSource);
1.585 +#if 0
1.586 +#ifdef S_ISLNK
1.587 + /*
1.588 + * To add a flag to make 'copy' copy links instead of files, we could
1.589 + * add a condition to ignore this 'if' here.
1.590 + */
1.591 + if (copyFlag && S_ISLNK(sourceStatBuf.st_mode)) {
1.592 + /*
1.593 + * We want to copy files not links. Therefore we must follow the
1.594 + * link. There are two purposes to this 'stat' call here. First
1.595 + * we want to know if the linked-file/dir actually exists, and
1.596 + * second, in the block of code which follows, some 20 lines
1.597 + * down, we want to check if the thing is a file or directory.
1.598 + */
1.599 + if (Tcl_FSStat(source, &sourceStatBuf) != 0) {
1.600 + /* Actual file doesn't exist */
1.601 + Tcl_AppendResult(interp,
1.602 + "error copying \"", Tcl_GetString(source),
1.603 + "\": the target of this link doesn't exist",
1.604 + (char *) NULL);
1.605 + goto done;
1.606 + } else {
1.607 + int counter = 0;
1.608 + while (1) {
1.609 + Tcl_Obj *path = Tcl_FSLink(actualSource, NULL, 0);
1.610 + if (path == NULL) {
1.611 + break;
1.612 + }
1.613 + Tcl_DecrRefCount(actualSource);
1.614 + actualSource = path;
1.615 + counter++;
1.616 + /* Arbitrary limit of 20 links to follow */
1.617 + if (counter > 20) {
1.618 + /* Too many links */
1.619 + Tcl_SetErrno(EMLINK);
1.620 + errfile = source;
1.621 + goto done;
1.622 + }
1.623 + }
1.624 + /* Now 'actualSource' is the correct file */
1.625 + }
1.626 + }
1.627 +#endif
1.628 +#endif
1.629 +
1.630 + if (S_ISDIR(sourceStatBuf.st_mode)) {
1.631 + result = Tcl_FSCopyDirectory(actualSource, target, &errorBuffer);
1.632 + if (result != TCL_OK) {
1.633 + if (errno == EXDEV) {
1.634 + /*
1.635 + * The copy failed because we're trying to do a
1.636 + * cross-filesystem copy. We do this through our Tcl
1.637 + * library.
1.638 + */
1.639 + Tcl_SavedResult savedResult;
1.640 + Tcl_Obj *copyCommand = Tcl_NewListObj(0,NULL);
1.641 + Tcl_IncrRefCount(copyCommand);
1.642 + Tcl_ListObjAppendElement(interp, copyCommand,
1.643 + Tcl_NewStringObj("::tcl::CopyDirectory",-1));
1.644 + if (copyFlag) {
1.645 + Tcl_ListObjAppendElement(interp, copyCommand,
1.646 + Tcl_NewStringObj("copying",-1));
1.647 + } else {
1.648 + Tcl_ListObjAppendElement(interp, copyCommand,
1.649 + Tcl_NewStringObj("renaming",-1));
1.650 + }
1.651 + Tcl_ListObjAppendElement(interp, copyCommand, source);
1.652 + Tcl_ListObjAppendElement(interp, copyCommand, target);
1.653 + Tcl_SaveResult(interp, &savedResult);
1.654 + result = Tcl_EvalObjEx(interp, copyCommand,
1.655 + TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT);
1.656 + Tcl_DecrRefCount(copyCommand);
1.657 + if (result != TCL_OK) {
1.658 + /*
1.659 + * There was an error in the Tcl-level copy.
1.660 + * We will pass on the Tcl error message and
1.661 + * can ensure this by setting errfile to NULL
1.662 + */
1.663 + Tcl_DiscardResult(&savedResult);
1.664 + errfile = NULL;
1.665 + } else {
1.666 + /* The copy was successful */
1.667 + Tcl_RestoreResult(interp, &savedResult);
1.668 + }
1.669 + } else {
1.670 + errfile = errorBuffer;
1.671 + if (Tcl_FSEqualPaths(errfile, source)) {
1.672 + errfile = source;
1.673 + } else if (Tcl_FSEqualPaths(errfile, target)) {
1.674 + errfile = target;
1.675 + }
1.676 + }
1.677 + }
1.678 + } else {
1.679 + result = Tcl_FSCopyFile(actualSource, target);
1.680 + if ((result != TCL_OK) && (errno == EXDEV)) {
1.681 + result = TclCrossFilesystemCopy(interp, source, target);
1.682 + }
1.683 + if (result != TCL_OK) {
1.684 + /*
1.685 + * We could examine 'errno' to double-check if the problem
1.686 + * was with the target, but we checked the source above,
1.687 + * so it should be quite clear
1.688 + */
1.689 + errfile = target;
1.690 + /*
1.691 + * We now need to reset the result, because the above call,
1.692 + * if it failed, may have put an error message in place.
1.693 + * (Ideally we would prefer not to pass an interpreter in
1.694 + * above, but the channel IO code used by
1.695 + * TclCrossFilesystemCopy currently requires one)
1.696 + */
1.697 + Tcl_ResetResult(interp);
1.698 + }
1.699 + }
1.700 + if ((copyFlag == 0) && (result == TCL_OK)) {
1.701 + if (S_ISDIR(sourceStatBuf.st_mode)) {
1.702 + result = Tcl_FSRemoveDirectory(source, 1, &errorBuffer);
1.703 + if (result != TCL_OK) {
1.704 + if (Tcl_FSEqualPaths(errfile, source) == 0) {
1.705 + errfile = source;
1.706 + }
1.707 + }
1.708 + } else {
1.709 + result = Tcl_FSDeleteFile(source);
1.710 + if (result != TCL_OK) {
1.711 + errfile = source;
1.712 + }
1.713 + }
1.714 + if (result != TCL_OK) {
1.715 + Tcl_AppendResult(interp, "can't unlink \"",
1.716 + Tcl_GetString(errfile), "\": ",
1.717 + Tcl_PosixError(interp), (char *) NULL);
1.718 + errfile = NULL;
1.719 + }
1.720 + }
1.721 +
1.722 + done:
1.723 + if (errfile != NULL) {
1.724 + Tcl_AppendResult(interp,
1.725 + ((copyFlag) ? "error copying \"" : "error renaming \""),
1.726 + Tcl_GetString(source), (char *) NULL);
1.727 + if (errfile != source) {
1.728 + Tcl_AppendResult(interp, "\" to \"", Tcl_GetString(target),
1.729 + (char *) NULL);
1.730 + if (errfile != target) {
1.731 + Tcl_AppendResult(interp, "\": \"", Tcl_GetString(errfile),
1.732 + (char *) NULL);
1.733 + }
1.734 + }
1.735 + Tcl_AppendResult(interp, "\": ", Tcl_PosixError(interp),
1.736 + (char *) NULL);
1.737 + }
1.738 + if (errorBuffer != NULL) {
1.739 + Tcl_DecrRefCount(errorBuffer);
1.740 + }
1.741 + if (actualSource != NULL) {
1.742 + Tcl_DecrRefCount(actualSource);
1.743 + }
1.744 + return result;
1.745 +}
1.746 +
1.747 +/*
1.748 + *---------------------------------------------------------------------------
1.749 + *
1.750 + * FileForceOption --
1.751 + *
1.752 + * Helps parse command line options for file commands that take
1.753 + * the "-force" and "--" options.
1.754 + *
1.755 + * Results:
1.756 + * The return value is how many arguments from argv were consumed
1.757 + * by this function, or -1 if there was an error parsing the
1.758 + * options. If an error occurred, an error message is left in the
1.759 + * interp's result.
1.760 + *
1.761 + * Side effects:
1.762 + * None.
1.763 + *
1.764 + *---------------------------------------------------------------------------
1.765 + */
1.766 +
1.767 +static int
1.768 +FileForceOption(interp, objc, objv, forcePtr)
1.769 + Tcl_Interp *interp; /* Interp, for error return. */
1.770 + int objc; /* Number of arguments. */
1.771 + Tcl_Obj *CONST objv[]; /* Argument strings. First command line
1.772 + * option, if it exists, begins at 0. */
1.773 + int *forcePtr; /* If the "-force" was specified, *forcePtr
1.774 + * is filled with 1, otherwise with 0. */
1.775 +{
1.776 + int force, i;
1.777 +
1.778 + force = 0;
1.779 + for (i = 0; i < objc; i++) {
1.780 + if (Tcl_GetString(objv[i])[0] != '-') {
1.781 + break;
1.782 + }
1.783 + if (strcmp(Tcl_GetString(objv[i]), "-force") == 0) {
1.784 + force = 1;
1.785 + } else if (strcmp(Tcl_GetString(objv[i]), "--") == 0) {
1.786 + i++;
1.787 + break;
1.788 + } else {
1.789 + Tcl_AppendResult(interp, "bad option \"", Tcl_GetString(objv[i]),
1.790 + "\": should be -force or --", (char *)NULL);
1.791 + return -1;
1.792 + }
1.793 + }
1.794 + *forcePtr = force;
1.795 + return i;
1.796 +}
1.797 +/*
1.798 + *---------------------------------------------------------------------------
1.799 + *
1.800 + * FileBasename --
1.801 + *
1.802 + * Given a path in either tcl format (with / separators), or in the
1.803 + * platform-specific format for the current platform, return all the
1.804 + * characters in the path after the last directory separator. But,
1.805 + * if path is the root directory, returns no characters.
1.806 + *
1.807 + * Results:
1.808 + * Returns the string object that represents the basename. If there
1.809 + * is an error, an error message is left in interp, and NULL is
1.810 + * returned.
1.811 + *
1.812 + * Side effects:
1.813 + * None.
1.814 + *
1.815 + *---------------------------------------------------------------------------
1.816 + */
1.817 +
1.818 +static Tcl_Obj *
1.819 +FileBasename(interp, pathPtr)
1.820 + Tcl_Interp *interp; /* Interp, for error return. */
1.821 + Tcl_Obj *pathPtr; /* Path whose basename to extract. */
1.822 +{
1.823 + int objc;
1.824 + Tcl_Obj *splitPtr;
1.825 + Tcl_Obj *resultPtr = NULL;
1.826 +
1.827 + splitPtr = Tcl_FSSplitPath(pathPtr, &objc);
1.828 +
1.829 + if (objc != 0) {
1.830 + if ((objc == 1) && (*Tcl_GetString(pathPtr) == '~')) {
1.831 + Tcl_DecrRefCount(splitPtr);
1.832 + if (Tcl_FSConvertToPathType(interp, pathPtr) != TCL_OK) {
1.833 + return NULL;
1.834 + }
1.835 + splitPtr = Tcl_FSSplitPath(pathPtr, &objc);
1.836 + }
1.837 +
1.838 + /*
1.839 + * Return the last component, unless it is the only component, and it
1.840 + * is the root of an absolute path.
1.841 + */
1.842 +
1.843 + if (objc > 0) {
1.844 + Tcl_ListObjIndex(NULL, splitPtr, objc-1, &resultPtr);
1.845 + if ((objc == 1) &&
1.846 + (Tcl_FSGetPathType(resultPtr) != TCL_PATH_RELATIVE)) {
1.847 + resultPtr = NULL;
1.848 + }
1.849 + }
1.850 + }
1.851 + if (resultPtr == NULL) {
1.852 + resultPtr = Tcl_NewObj();
1.853 + }
1.854 + Tcl_IncrRefCount(resultPtr);
1.855 + Tcl_DecrRefCount(splitPtr);
1.856 + return resultPtr;
1.857 +}
1.858 +
1.859 +/*
1.860 + *----------------------------------------------------------------------
1.861 + *
1.862 + * TclFileAttrsCmd --
1.863 + *
1.864 + * Sets or gets the platform-specific attributes of a file. The
1.865 + * objc-objv points to the file name with the rest of the command
1.866 + * line following. This routine uses platform-specific tables of
1.867 + * option strings and callbacks. The callback to get the
1.868 + * attributes take three parameters:
1.869 + * Tcl_Interp *interp; The interp to report errors with.
1.870 + * Since this is an object-based API,
1.871 + * the object form of the result should
1.872 + * be used.
1.873 + * CONST char *fileName; This is extracted using
1.874 + * Tcl_TranslateFileName.
1.875 + * TclObj **attrObjPtrPtr; A new object to hold the attribute
1.876 + * is allocated and put here.
1.877 + * The first two parameters of the callback used to write out the
1.878 + * attributes are the same. The third parameter is:
1.879 + * CONST *attrObjPtr; A pointer to the object that has
1.880 + * the new attribute.
1.881 + * They both return standard TCL errors; if the routine to get
1.882 + * an attribute fails, no object is allocated and *attrObjPtrPtr
1.883 + * is unchanged.
1.884 + *
1.885 + * Results:
1.886 + * Standard TCL error.
1.887 + *
1.888 + * Side effects:
1.889 + * May set file attributes for the file name.
1.890 + *
1.891 + *----------------------------------------------------------------------
1.892 + */
1.893 +
1.894 +int
1.895 +TclFileAttrsCmd(interp, objc, objv)
1.896 + Tcl_Interp *interp; /* The interpreter for error reporting. */
1.897 + int objc; /* Number of command line arguments. */
1.898 + Tcl_Obj *CONST objv[]; /* The command line objects. */
1.899 +{
1.900 + int result;
1.901 + CONST char ** attributeStrings;
1.902 + Tcl_Obj* objStrings = NULL;
1.903 + int numObjStrings = -1;
1.904 + Tcl_Obj *filePtr;
1.905 +
1.906 + if (objc < 3) {
1.907 + Tcl_WrongNumArgs(interp, 2, objv,
1.908 + "name ?option? ?value? ?option value ...?");
1.909 + return TCL_ERROR;
1.910 + }
1.911 +
1.912 + filePtr = objv[2];
1.913 + if (Tcl_FSConvertToPathType(interp, filePtr) != TCL_OK) {
1.914 + return TCL_ERROR;
1.915 + }
1.916 +
1.917 + objc -= 3;
1.918 + objv += 3;
1.919 + result = TCL_ERROR;
1.920 + Tcl_SetErrno(0);
1.921 + attributeStrings = Tcl_FSFileAttrStrings(filePtr, &objStrings);
1.922 + if (attributeStrings == NULL) {
1.923 + int index;
1.924 + Tcl_Obj *objPtr;
1.925 + if (objStrings == NULL) {
1.926 + if (Tcl_GetErrno() != 0) {
1.927 + /*
1.928 + * There was an error, probably that the filePtr is
1.929 + * not accepted by any filesystem
1.930 + */
1.931 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.932 + "could not read \"", Tcl_GetString(filePtr),
1.933 + "\": ", Tcl_PosixError(interp),
1.934 + (char *) NULL);
1.935 + return TCL_ERROR;
1.936 + }
1.937 + goto end;
1.938 + }
1.939 + /* We own the object now */
1.940 + Tcl_IncrRefCount(objStrings);
1.941 + /* Use objStrings as a list object */
1.942 + if (Tcl_ListObjLength(interp, objStrings, &numObjStrings) != TCL_OK) {
1.943 + goto end;
1.944 + }
1.945 + attributeStrings = (CONST char **)
1.946 + ckalloc ((1+numObjStrings) * sizeof(char*));
1.947 + for (index = 0; index < numObjStrings; index++) {
1.948 + Tcl_ListObjIndex(interp, objStrings, index, &objPtr);
1.949 + attributeStrings[index] = Tcl_GetString(objPtr);
1.950 + }
1.951 + attributeStrings[index] = NULL;
1.952 + }
1.953 + if (objc == 0) {
1.954 + /*
1.955 + * Get all attributes.
1.956 + */
1.957 +
1.958 + int index;
1.959 + Tcl_Obj *listPtr;
1.960 +
1.961 + listPtr = Tcl_NewListObj(0, NULL);
1.962 + for (index = 0; attributeStrings[index] != NULL; index++) {
1.963 + Tcl_Obj *objPtr = Tcl_NewStringObj(attributeStrings[index], -1);
1.964 + Tcl_ListObjAppendElement(interp, listPtr, objPtr);
1.965 + /* We now forget about objPtr, it is in the list */
1.966 + objPtr = NULL;
1.967 + if (Tcl_FSFileAttrsGet(interp, index, filePtr,
1.968 + &objPtr) != TCL_OK) {
1.969 + Tcl_DecrRefCount(listPtr);
1.970 + goto end;
1.971 + }
1.972 + Tcl_ListObjAppendElement(interp, listPtr, objPtr);
1.973 + }
1.974 + Tcl_SetObjResult(interp, listPtr);
1.975 + } else if (objc == 1) {
1.976 + /*
1.977 + * Get one attribute.
1.978 + */
1.979 +
1.980 + int index;
1.981 + Tcl_Obj *objPtr = NULL;
1.982 +
1.983 + if (numObjStrings == 0) {
1.984 + Tcl_AppendResult(interp, "bad option \"",
1.985 + Tcl_GetString(objv[0]), "\", there are no file attributes"
1.986 + " in this filesystem.", (char *) NULL);
1.987 + goto end;
1.988 + }
1.989 +
1.990 + if (Tcl_GetIndexFromObj(interp, objv[0], attributeStrings,
1.991 + "option", 0, &index) != TCL_OK) {
1.992 + goto end;
1.993 + }
1.994 + if (Tcl_FSFileAttrsGet(interp, index, filePtr,
1.995 + &objPtr) != TCL_OK) {
1.996 + goto end;
1.997 + }
1.998 + Tcl_SetObjResult(interp, objPtr);
1.999 + } else {
1.1000 + /*
1.1001 + * Set option/value pairs.
1.1002 + */
1.1003 +
1.1004 + int i, index;
1.1005 +
1.1006 + if (numObjStrings == 0) {
1.1007 + Tcl_AppendResult(interp, "bad option \"",
1.1008 + Tcl_GetString(objv[0]), "\", there are no file attributes"
1.1009 + " in this filesystem.", (char *) NULL);
1.1010 + goto end;
1.1011 + }
1.1012 +
1.1013 + for (i = 0; i < objc ; i += 2) {
1.1014 + if (Tcl_GetIndexFromObj(interp, objv[i], attributeStrings,
1.1015 + "option", 0, &index) != TCL_OK) {
1.1016 + goto end;
1.1017 + }
1.1018 + if (i + 1 == objc) {
1.1019 + Tcl_AppendResult(interp, "value for \"",
1.1020 + Tcl_GetString(objv[i]), "\" missing",
1.1021 + (char *) NULL);
1.1022 + goto end;
1.1023 + }
1.1024 + if (Tcl_FSFileAttrsSet(interp, index, filePtr,
1.1025 + objv[i + 1]) != TCL_OK) {
1.1026 + goto end;
1.1027 + }
1.1028 + }
1.1029 + }
1.1030 + result = TCL_OK;
1.1031 +
1.1032 + end:
1.1033 + if (numObjStrings != -1) {
1.1034 + /* Free up the array we allocated */
1.1035 + ckfree((char*)attributeStrings);
1.1036 + /*
1.1037 + * We don't need this object that was passed to us
1.1038 + * any more.
1.1039 + */
1.1040 + if (objStrings != NULL) {
1.1041 + Tcl_DecrRefCount(objStrings);
1.1042 + }
1.1043 + }
1.1044 + return result;
1.1045 +}