diff -r 000000000000 -r bde4ae8d615e os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclFCmd.c --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclFCmd.c Fri Jun 15 03:10:57 2012 +0200 @@ -0,0 +1,1042 @@ +/* + * 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; +}