/[dtapublic]/projs/ets/trunk/src/c_tcl_base_7_5_w_mods/tclfcmd.c
ViewVC logotype

Diff of /projs/ets/trunk/src/c_tcl_base_7_5_w_mods/tclfcmd.c

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclfcmd.c revision 44 by dashley, Fri Oct 14 02:09:58 2016 UTC projs/ets/trunk/src/c_tcl_base_7_5_w_mods/tclfcmd.c revision 220 by dashley, Sun Jul 22 15:58:07 2018 UTC
# Line 1  Line 1 
 /* $Header: /cvsroot/esrg/sfesrg/esrgpcpj/shared/tcl_base/tclfcmd.c,v 1.1.1.1 2001/06/13 04:39:01 dtashley Exp $ */  
   
 /*  
  * 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.1.1.1 2001/06/13 04:39:01 dtashley Exp $  
  */  
   
 #include "tclInt.h"  
 #include "tclPort.h"  
   
 /*  
  * Declarations for local procedures defined in this file:  
  */  
   
 static int              CopyRenameOneFile _ANSI_ARGS_((Tcl_Interp *interp,  
                             char *source, char *dest, int copyFlag,  
                             int force));  
 static char *           FileBasename _ANSI_ARGS_((Tcl_Interp *interp,  
                             char *path, Tcl_DString *bufferPtr));  
 static int              FileCopyRename _ANSI_ARGS_((Tcl_Interp *interp,  
                             int argc, char **argv, int copyFlag));  
 static int              FileForceOption _ANSI_ARGS_((Tcl_Interp *interp,  
                             int argc, char **argv, 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, argc, argv)  
     Tcl_Interp *interp;         /* Interp for error reporting. */  
     int argc;                   /* Number of arguments. */  
     char **argv;                /* Argument strings passed to Tcl_FileCmd. */  
 {  
     return FileCopyRename(interp, argc, argv, 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, argc, argv)  
     Tcl_Interp *interp;         /* Used for error reporting */  
     int argc;                   /* Number of arguments. */  
     char **argv;                /* Argument strings passed to Tcl_FileCmd. */  
 {  
     return FileCopyRename(interp, argc, argv, 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, argc, argv, copyFlag)  
     Tcl_Interp *interp;         /* Used for error reporting. */  
     int argc;                   /* Number of arguments. */  
     char **argv;                /* Argument strings passed to Tcl_FileCmd. */  
     int copyFlag;               /* If non-zero, copy source(s).  Otherwise,  
                                  * rename them. */  
 {  
     int i, result, force;  
     struct stat statBuf;  
     Tcl_DString targetBuffer;  
     char *target;  
   
     i = FileForceOption(interp, argc - 2, argv + 2, &force);  
     if (i < 0) {  
         return TCL_ERROR;  
     }  
     i += 2;  
     if ((argc - i) < 2) {  
         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],  
                 " ", argv[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 = Tcl_TranslateFileName(interp, argv[argc - 1], &targetBuffer);  
     if (target == NULL) {  
         return TCL_ERROR;  
     }  
   
     result = TCL_OK;  
   
     /*  
      * Call TclStat() 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 ((TclStat(target, &statBuf) != 0) || !S_ISDIR(statBuf.st_mode)) {  
         if ((argc - i) > 2) {  
             errno = ENOTDIR;  
             Tcl_PosixError(interp);  
             Tcl_AppendResult(interp, "error ",  
                     ((copyFlag) ? "copying" : "renaming"), ": target \"",  
                     argv[argc - 1], "\" is not a directory", (char *) NULL);  
             result = TCL_ERROR;  
         } else {  
             /*  
              * Even though already have target == translated(argv[i+1]),  
              * pass the original argument down, so if there's an error, the  
              * error message will reflect the original arguments.  
              */  
   
             result = CopyRenameOneFile(interp, argv[i], argv[i + 1], copyFlag,  
                     force);  
         }  
         Tcl_DStringFree(&targetBuffer);  
         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 < argc - 1; i++) {  
         char *jargv[2];  
         char *source, *newFileName;  
         Tcl_DString sourceBuffer, newFileNameBuffer;  
   
         source = FileBasename(interp, argv[i], &sourceBuffer);  
         if (source == NULL) {  
             result = TCL_ERROR;  
             break;  
         }  
         jargv[0] = argv[argc - 1];  
         jargv[1] = source;  
         Tcl_DStringInit(&newFileNameBuffer);  
         newFileName = Tcl_JoinPath(2, jargv, &newFileNameBuffer);  
         result = CopyRenameOneFile(interp, argv[i], newFileName, copyFlag,  
                 force);  
         Tcl_DStringFree(&sourceBuffer);  
         Tcl_DStringFree(&newFileNameBuffer);  
   
         if (result == TCL_ERROR) {  
             break;  
         }  
     }  
     Tcl_DStringFree(&targetBuffer);  
     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, argc, argv)  
     Tcl_Interp *interp;         /* Used for error reporting. */  
     int argc;                   /* Number of arguments */  
     char **argv;                /* Argument strings passed to Tcl_FileCmd. */  
 {  
     Tcl_DString nameBuffer, targetBuffer;  
     char *errfile;  
     int result, i, j, pargc;  
     char **pargv;  
     struct stat statBuf;  
   
     pargv = NULL;  
     errfile = NULL;  
     Tcl_DStringInit(&nameBuffer);  
     Tcl_DStringInit(&targetBuffer);  
   
     result = TCL_OK;  
     for (i = 2; i < argc; i++) {  
         char *name = Tcl_TranslateFileName(interp, argv[i], &nameBuffer);  
         if (name == NULL) {  
             result = TCL_ERROR;  
             break;  
         }  
   
         Tcl_SplitPath(name, &pargc, &pargv);  
         if (pargc == 0) {  
             errno = ENOENT;  
             errfile = argv[i];  
             break;  
         }  
         for (j = 0; j < pargc; j++) {  
             char *target = Tcl_JoinPath(j + 1, pargv, &targetBuffer);  
   
             /*  
              * Call TclStat() so that if target is a symlink that points  
              * to a directory we will create subdirectories in that  
              * directory.  
              */  
   
             if (TclStat(target, &statBuf) == 0) {  
                 if (!S_ISDIR(statBuf.st_mode)) {  
                     errno = EEXIST;  
                     errfile = target;  
                     goto done;  
                 }  
             } else if ((errno != ENOENT)  
                     || (TclpCreateDirectory(target) != TCL_OK)) {  
                 errfile = target;  
                 goto done;  
             }  
             Tcl_DStringFree(&targetBuffer);  
         }  
         ckfree((char *) pargv);  
         pargv = NULL;  
         Tcl_DStringFree(&nameBuffer);  
     }  
           
     done:  
     if (errfile != NULL) {  
         Tcl_AppendResult(interp, "can't create directory \"",  
                 errfile, "\": ", Tcl_PosixError(interp), (char *) NULL);  
         result = TCL_ERROR;  
     }  
   
     Tcl_DStringFree(&nameBuffer);  
     Tcl_DStringFree(&targetBuffer);  
     if (pargv != NULL) {  
         ckfree((char *) pargv);  
     }  
     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, argc, argv)  
     Tcl_Interp *interp;         /* Used for error reporting */  
     int argc;                   /* Number of arguments */  
     char **argv;                /* Argument strings passed to Tcl_FileCmd. */  
 {  
     Tcl_DString nameBuffer, errorBuffer;  
     int i, force, result;  
     char *errfile;  
       
     i = FileForceOption(interp, argc - 2, argv + 2, &force);  
     if (i < 0) {  
         return TCL_ERROR;  
     }  
     i += 2;  
     if ((argc - i) < 1) {  
         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],  
                 " ", argv[1], " ?options? file ?file ...?\"", (char *) NULL);  
         return TCL_ERROR;  
     }  
   
     errfile = NULL;  
     result = TCL_OK;  
     Tcl_DStringInit(&errorBuffer);  
     Tcl_DStringInit(&nameBuffer);  
   
     for ( ; i < argc; i++) {  
         struct stat statBuf;  
         char *name;  
   
         errfile = argv[i];  
         Tcl_DStringSetLength(&nameBuffer, 0);  
         name = Tcl_TranslateFileName(interp, argv[i], &nameBuffer);  
         if (name == NULL) {  
             result = TCL_ERROR;  
             goto done;  
         }  
   
         /*  
          * Call lstat() to get info so can delete symbolic link itself.  
          */  
   
         if (TclpLstat(name, &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)) {  
             result = TclpRemoveDirectory(name, force, &errorBuffer);  
             if (result != TCL_OK) {  
                 if ((force == 0) && (errno == EEXIST)) {  
                     Tcl_AppendResult(interp, "error deleting \"", argv[i],  
                             "\": directory not empty", (char *) NULL);  
                     Tcl_PosixError(interp);  
                     goto done;  
                 }  
   
                 /*  
                  * If possible, use the untranslated name for the file.  
                  */  
                   
                 errfile = Tcl_DStringValue(&errorBuffer);  
                 if (strcmp(name, errfile) == 0) {  
                     errfile = argv[i];  
                 }  
             }  
         } else {  
             result = TclpDeleteFile(name);  
         }  
           
         if (result == TCL_ERROR) {  
             break;  
         }  
     }  
     if (result != TCL_OK) {  
         Tcl_AppendResult(interp, "error deleting \"", errfile,  
                 "\": ", Tcl_PosixError(interp), (char *) NULL);  
     }  
     done:  
     Tcl_DStringFree(&errorBuffer);  
     Tcl_DStringFree(&nameBuffer);  
     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. */  
     char *source;               /* Pathname of file to copy.  May need to  
                                  * be translated. */  
     char *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_DString sourcePath, targetPath, errorBuffer;  
     char *targetName, *sourceName, *errfile;  
     struct stat sourceStatBuf, targetStatBuf;  
   
     sourceName = Tcl_TranslateFileName(interp, source, &sourcePath);  
     if (sourceName == NULL) {  
         return TCL_ERROR;  
     }  
     targetName = Tcl_TranslateFileName(interp, target, &targetPath);  
     if (targetName == NULL) {  
         Tcl_DStringFree(&sourcePath);  
         return TCL_ERROR;  
     }  
       
     errfile = NULL;  
     result = TCL_ERROR;  
     Tcl_DStringInit(&errorBuffer);  
       
     /*  
      * 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 (TclpLstat(sourceName, &sourceStatBuf) != 0) {  
         errfile = source;  
         goto done;  
     }  
     if (TclpLstat(targetName, &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 \"", target,  
                     "\" with directory \"", 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 \"", target,  
                     "\" with file \"", source, "\"", (char *) NULL);  
             goto done;  
         }  
     }  
   
     if (copyFlag == 0) {  
         result = TclpRenameFile(sourceName, targetName);  
         if (result == TCL_OK) {  
             goto done;  
         }  
               
         if (errno == EINVAL) {  
             Tcl_AppendResult(interp, "error renaming \"", source, "\" to \"",  
                     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 TclpRenameFile is allowed to implement  
          * cross-filesystem moves itself.  
          */  
     }  
   
     if (S_ISDIR(sourceStatBuf.st_mode)) {  
         result = TclpCopyDirectory(sourceName, targetName, &errorBuffer);  
         if (result != TCL_OK) {  
             errfile = Tcl_DStringValue(&errorBuffer);  
             if (strcmp(errfile, sourceName) == 0) {  
                 errfile = source;  
             } else if (strcmp(errfile, targetName) == 0) {  
                 errfile = target;  
             }  
         }  
     } else {  
         result = TclpCopyFile(sourceName, targetName);  
         if (result != TCL_OK) {  
             /*  
              * Well, there really shouldn't be a problem with source,  
              * because up there we checked to see if it was ok to copy it.  
              */  
   
             errfile = target;  
         }  
     }  
     if ((copyFlag == 0) && (result == TCL_OK)) {  
         if (S_ISDIR(sourceStatBuf.st_mode)) {  
             result = TclpRemoveDirectory(sourceName, 1, &errorBuffer);  
             if (result != TCL_OK) {  
                 errfile = Tcl_DStringValue(&errorBuffer);  
                 if (strcmp(errfile, sourceName) == 0) {  
                     errfile = source;  
                 }  
             }  
         } else {  
             result = TclpDeleteFile(sourceName);  
             if (result != TCL_OK) {  
                 errfile = source;  
             }  
         }  
         if (result != TCL_OK) {  
             Tcl_AppendResult(interp, "can't unlink \"", errfile, "\": ",  
                     Tcl_PosixError(interp), (char *) NULL);  
             errfile = NULL;  
         }  
     }  
       
     done:  
     if (errfile != NULL) {  
         Tcl_AppendResult(interp,  
                 ((copyFlag) ? "error copying \"" : "error renaming \""),  
                 source, (char *) NULL);  
         if (errfile != source) {  
             Tcl_AppendResult(interp, "\" to \"", target, (char *) NULL);  
             if (errfile != target) {  
                 Tcl_AppendResult(interp, "\": \"", errfile, (char *) NULL);  
             }  
         }  
         Tcl_AppendResult(interp, "\": ", Tcl_PosixError(interp),  
                 (char *) NULL);  
     }  
     Tcl_DStringFree(&errorBuffer);  
     Tcl_DStringFree(&sourcePath);  
     Tcl_DStringFree(&targetPath);  
     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, argc, argv, forcePtr)  
     Tcl_Interp *interp;         /* Interp, for error return. */  
     int argc;                   /* Number of arguments. */  
     char **argv;                /* 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 < argc; i++) {  
         if (argv[i][0] != '-') {  
             break;  
         }  
         if (strcmp(argv[i], "-force") == 0) {  
             force = 1;  
         } else if (strcmp(argv[i], "--") == 0) {  
             i++;  
             break;  
         } else {  
             Tcl_AppendResult(interp, "bad option \"", argv[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:  
  *      Appends the string that represents the basename to the end of  
  *      the specified initialized DString, returning a pointer to the  
  *      resulting string.  If there is an error, an error message is left  
  *      in interp, NULL is returned, and the Tcl_DString is unmodified.  
  *  
  * Side effects:  
  *      None.  
  *  
  *---------------------------------------------------------------------------  
  */  
   
 static char *  
 FileBasename(interp, path, bufferPtr)  
     Tcl_Interp *interp;         /* Interp, for error return. */  
     char *path;                 /* Path whose basename to extract. */  
     Tcl_DString *bufferPtr;     /* Initialized DString that receives  
                                  * basename. */  
 {  
     int argc;  
     char **argv;  
       
     Tcl_SplitPath(path, &argc, &argv);  
     if (argc == 0) {  
         Tcl_DStringInit(bufferPtr);  
     } else {  
         if ((argc == 1) && (*path == '~')) {  
             Tcl_DString buffer;  
               
             ckfree((char *) argv);  
             path = Tcl_TranslateFileName(interp, path, &buffer);  
             if (path == NULL) {  
                 return NULL;  
             }  
             Tcl_SplitPath(path, &argc, &argv);  
             Tcl_DStringFree(&buffer);  
         }  
         Tcl_DStringInit(bufferPtr);  
   
         /*  
          * Return the last component, unless it is the only component, and it  
          * is the root of an absolute path.  
          */  
   
         if (argc > 0) {  
             if ((argc > 1)  
                     || (Tcl_GetPathType(argv[0]) == TCL_PATH_RELATIVE)) {  
                 Tcl_DStringAppend(bufferPtr, argv[argc - 1], -1);  
             }  
         }  
     }  
     ckfree((char *) argv);  
     return Tcl_DStringValue(bufferPtr);  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * 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. */  
 {  
     char *fileName;  
     int result;  
     Tcl_DString buffer;  
   
     if (objc < 3) {  
         Tcl_WrongNumArgs(interp, 2, objv,  
                 "name ?option? ?value? ?option value ...?");  
         return TCL_ERROR;  
     }  
   
     fileName = Tcl_GetString(objv[2]);  
     fileName = Tcl_TranslateFileName(interp, fileName, &buffer);  
     if (fileName == NULL) {  
         return TCL_ERROR;  
     }  
       
     objc -= 3;  
     objv += 3;  
     result = TCL_ERROR;  
   
     if (objc == 0) {  
         /*  
          * Get all attributes.  
          */  
   
         int index;  
         Tcl_Obj *listPtr, *objPtr;  
           
         listPtr = Tcl_NewListObj(0, NULL);  
         for (index = 0; tclpFileAttrStrings[index] != NULL; index++) {  
             objPtr = Tcl_NewStringObj(tclpFileAttrStrings[index], -1);  
             Tcl_ListObjAppendElement(interp, listPtr, objPtr);  
   
             if ((*tclpFileAttrProcs[index].getProc)(interp, index, fileName,  
                     &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;  
           
         if (Tcl_GetIndexFromObj(interp, objv[0], tclpFileAttrStrings,  
                 "option", 0, &index) != TCL_OK) {  
             goto end;  
         }  
         if ((*tclpFileAttrProcs[index].getProc)(interp, index, fileName,  
                 &objPtr) != TCL_OK) {  
             goto end;  
         }  
         Tcl_SetObjResult(interp, objPtr);  
     } else {  
         /*  
          * Set option/value pairs.  
          */  
   
         int i, index;  
           
         for (i = 0; i < objc ; i += 2) {  
             if (Tcl_GetIndexFromObj(interp, objv[i], tclpFileAttrStrings,  
                     "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 ((*tclpFileAttrProcs[index].setProc)(interp, index, fileName,  
                     objv[i + 1]) != TCL_OK) {  
                 goto end;  
             }  
         }  
     }  
     result = TCL_OK;  
   
     end:  
     Tcl_DStringFree(&buffer);  
     return result;  
 }  
   
   
 /* $History: tclfcmd.c $  
  *  
  * *****************  Version 1  *****************  
  * User: Dtashley     Date: 1/02/01    Time: 1:31a  
  * Created in $/IjuScripter, IjuConsole/Source/Tcl Base  
  * Initial check-in.  
  */  
   
 /* End of TCLFCMD.C */  
1    /* $Header$ */
2    /*
3     * tclFCmd.c
4     *
5     *      This file implements the generic portion of file manipulation
6     *      subcommands of the "file" command.
7     *
8     * Copyright (c) 1996-1998 Sun Microsystems, Inc.
9     *
10     * See the file "license.terms" for information on usage and redistribution
11     * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
12     *
13     * RCS: @(#) $Id: tclfcmd.c,v 1.1.1.1 2001/06/13 04:39:01 dtashley Exp $
14     */
15    
16    #include "tclInt.h"
17    #include "tclPort.h"
18    
19    /*
20     * Declarations for local procedures defined in this file:
21     */
22    
23    static int              CopyRenameOneFile _ANSI_ARGS_((Tcl_Interp *interp,
24                                char *source, char *dest, int copyFlag,
25                                int force));
26    static char *           FileBasename _ANSI_ARGS_((Tcl_Interp *interp,
27                                char *path, Tcl_DString *bufferPtr));
28    static int              FileCopyRename _ANSI_ARGS_((Tcl_Interp *interp,
29                                int argc, char **argv, int copyFlag));
30    static int              FileForceOption _ANSI_ARGS_((Tcl_Interp *interp,
31                                int argc, char **argv, int *forcePtr));
32    
33    /*
34     *---------------------------------------------------------------------------
35     *
36     * TclFileRenameCmd
37     *
38     *      This procedure implements the "rename" subcommand of the "file"
39     *      command.  Filename arguments need to be translated to native
40     *      format before being passed to platform-specific code that
41     *      implements rename functionality.
42     *
43     * Results:
44     *      A standard Tcl result.
45     *
46     * Side effects:
47     *      See the user documentation.
48     *
49     *---------------------------------------------------------------------------
50     */
51    
52    int
53    TclFileRenameCmd(interp, argc, argv)
54        Tcl_Interp *interp;         /* Interp for error reporting. */
55        int argc;                   /* Number of arguments. */
56        char **argv;                /* Argument strings passed to Tcl_FileCmd. */
57    {
58        return FileCopyRename(interp, argc, argv, 0);
59    }
60    
61    /*
62     *---------------------------------------------------------------------------
63     *
64     * TclFileCopyCmd
65     *
66     *      This procedure implements the "copy" subcommand of the "file"
67     *      command.  Filename arguments need to be translated to native
68     *      format before being passed to platform-specific code that
69     *      implements copy functionality.
70     *
71     * Results:
72     *      A standard Tcl result.
73     *
74     * Side effects:
75     *      See the user documentation.
76     *
77     *---------------------------------------------------------------------------
78     */
79    
80    int
81    TclFileCopyCmd(interp, argc, argv)
82        Tcl_Interp *interp;         /* Used for error reporting */
83        int argc;                   /* Number of arguments. */
84        char **argv;                /* Argument strings passed to Tcl_FileCmd. */
85    {
86        return FileCopyRename(interp, argc, argv, 1);
87    }
88    
89    /*
90     *---------------------------------------------------------------------------
91     *
92     * FileCopyRename --
93     *
94     *      Performs the work of TclFileRenameCmd and TclFileCopyCmd.
95     *      See comments for those procedures.
96     *
97     * Results:
98     *      See above.
99     *
100     * Side effects:
101     *      See above.
102     *
103     *---------------------------------------------------------------------------
104     */
105    
106    static int
107    FileCopyRename(interp, argc, argv, copyFlag)
108        Tcl_Interp *interp;         /* Used for error reporting. */
109        int argc;                   /* Number of arguments. */
110        char **argv;                /* Argument strings passed to Tcl_FileCmd. */
111        int copyFlag;               /* If non-zero, copy source(s).  Otherwise,
112                                     * rename them. */
113    {
114        int i, result, force;
115        struct stat statBuf;
116        Tcl_DString targetBuffer;
117        char *target;
118    
119        i = FileForceOption(interp, argc - 2, argv + 2, &force);
120        if (i < 0) {
121            return TCL_ERROR;
122        }
123        i += 2;
124        if ((argc - i) < 2) {
125            Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
126                    " ", argv[1], " ?options? source ?source ...? target\"",
127                    (char *) NULL);
128            return TCL_ERROR;
129        }
130    
131        /*
132         * If target doesn't exist or isn't a directory, try the copy/rename.
133         * More than 2 arguments is only valid if the target is an existing
134         * directory.
135         */
136    
137        target = Tcl_TranslateFileName(interp, argv[argc - 1], &targetBuffer);
138        if (target == NULL) {
139            return TCL_ERROR;
140        }
141    
142        result = TCL_OK;
143    
144        /*
145         * Call TclStat() so that if target is a symlink that points to a
146         * directory we will put the sources in that directory instead of
147         * overwriting the symlink.
148         */
149    
150        if ((TclStat(target, &statBuf) != 0) || !S_ISDIR(statBuf.st_mode)) {
151            if ((argc - i) > 2) {
152                errno = ENOTDIR;
153                Tcl_PosixError(interp);
154                Tcl_AppendResult(interp, "error ",
155                        ((copyFlag) ? "copying" : "renaming"), ": target \"",
156                        argv[argc - 1], "\" is not a directory", (char *) NULL);
157                result = TCL_ERROR;
158            } else {
159                /*
160                 * Even though already have target == translated(argv[i+1]),
161                 * pass the original argument down, so if there's an error, the
162                 * error message will reflect the original arguments.
163                 */
164    
165                result = CopyRenameOneFile(interp, argv[i], argv[i + 1], copyFlag,
166                        force);
167            }
168            Tcl_DStringFree(&targetBuffer);
169            return result;
170        }
171        
172        /*
173         * Move each source file into target directory.  Extract the basename
174         * from each source, and append it to the end of the target path.
175         */
176    
177        for ( ; i < argc - 1; i++) {
178            char *jargv[2];
179            char *source, *newFileName;
180            Tcl_DString sourceBuffer, newFileNameBuffer;
181    
182            source = FileBasename(interp, argv[i], &sourceBuffer);
183            if (source == NULL) {
184                result = TCL_ERROR;
185                break;
186            }
187            jargv[0] = argv[argc - 1];
188            jargv[1] = source;
189            Tcl_DStringInit(&newFileNameBuffer);
190            newFileName = Tcl_JoinPath(2, jargv, &newFileNameBuffer);
191            result = CopyRenameOneFile(interp, argv[i], newFileName, copyFlag,
192                    force);
193            Tcl_DStringFree(&sourceBuffer);
194            Tcl_DStringFree(&newFileNameBuffer);
195    
196            if (result == TCL_ERROR) {
197                break;
198            }
199        }
200        Tcl_DStringFree(&targetBuffer);
201        return result;
202    }
203    
204    /*
205     *---------------------------------------------------------------------------
206     *
207     * TclFileMakeDirsCmd
208     *
209     *      This procedure implements the "mkdir" subcommand of the "file"
210     *      command.  Filename arguments need to be translated to native
211     *      format before being passed to platform-specific code that
212     *      implements mkdir functionality.
213     *
214     * Results:
215     *      A standard Tcl result.
216     *
217     * Side effects:
218     *      See the user documentation.
219     *
220     *----------------------------------------------------------------------
221     */
222    int
223    TclFileMakeDirsCmd(interp, argc, argv)
224        Tcl_Interp *interp;         /* Used for error reporting. */
225        int argc;                   /* Number of arguments */
226        char **argv;                /* Argument strings passed to Tcl_FileCmd. */
227    {
228        Tcl_DString nameBuffer, targetBuffer;
229        char *errfile;
230        int result, i, j, pargc;
231        char **pargv;
232        struct stat statBuf;
233    
234        pargv = NULL;
235        errfile = NULL;
236        Tcl_DStringInit(&nameBuffer);
237        Tcl_DStringInit(&targetBuffer);
238    
239        result = TCL_OK;
240        for (i = 2; i < argc; i++) {
241            char *name = Tcl_TranslateFileName(interp, argv[i], &nameBuffer);
242            if (name == NULL) {
243                result = TCL_ERROR;
244                break;
245            }
246    
247            Tcl_SplitPath(name, &pargc, &pargv);
248            if (pargc == 0) {
249                errno = ENOENT;
250                errfile = argv[i];
251                break;
252            }
253            for (j = 0; j < pargc; j++) {
254                char *target = Tcl_JoinPath(j + 1, pargv, &targetBuffer);
255    
256                /*
257                 * Call TclStat() so that if target is a symlink that points
258                 * to a directory we will create subdirectories in that
259                 * directory.
260                 */
261    
262                if (TclStat(target, &statBuf) == 0) {
263                    if (!S_ISDIR(statBuf.st_mode)) {
264                        errno = EEXIST;
265                        errfile = target;
266                        goto done;
267                    }
268                } else if ((errno != ENOENT)
269                        || (TclpCreateDirectory(target) != TCL_OK)) {
270                    errfile = target;
271                    goto done;
272                }
273                Tcl_DStringFree(&targetBuffer);
274            }
275            ckfree((char *) pargv);
276            pargv = NULL;
277            Tcl_DStringFree(&nameBuffer);
278        }
279            
280        done:
281        if (errfile != NULL) {
282            Tcl_AppendResult(interp, "can't create directory \"",
283                    errfile, "\": ", Tcl_PosixError(interp), (char *) NULL);
284            result = TCL_ERROR;
285        }
286    
287        Tcl_DStringFree(&nameBuffer);
288        Tcl_DStringFree(&targetBuffer);
289        if (pargv != NULL) {
290            ckfree((char *) pargv);
291        }
292        return result;
293    }
294    
295    /*
296     *----------------------------------------------------------------------
297     *
298     * TclFileDeleteCmd
299     *
300     *      This procedure implements the "delete" subcommand of the "file"
301     *      command.
302     *
303     * Results:
304     *      A standard Tcl result.
305     *
306     * Side effects:
307     *      See the user documentation.
308     *
309     *----------------------------------------------------------------------
310     */
311    
312    int
313    TclFileDeleteCmd(interp, argc, argv)
314        Tcl_Interp *interp;         /* Used for error reporting */
315        int argc;                   /* Number of arguments */
316        char **argv;                /* Argument strings passed to Tcl_FileCmd. */
317    {
318        Tcl_DString nameBuffer, errorBuffer;
319        int i, force, result;
320        char *errfile;
321        
322        i = FileForceOption(interp, argc - 2, argv + 2, &force);
323        if (i < 0) {
324            return TCL_ERROR;
325        }
326        i += 2;
327        if ((argc - i) < 1) {
328            Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
329                    " ", argv[1], " ?options? file ?file ...?\"", (char *) NULL);
330            return TCL_ERROR;
331        }
332    
333        errfile = NULL;
334        result = TCL_OK;
335        Tcl_DStringInit(&errorBuffer);
336        Tcl_DStringInit(&nameBuffer);
337    
338        for ( ; i < argc; i++) {
339            struct stat statBuf;
340            char *name;
341    
342            errfile = argv[i];
343            Tcl_DStringSetLength(&nameBuffer, 0);
344            name = Tcl_TranslateFileName(interp, argv[i], &nameBuffer);
345            if (name == NULL) {
346                result = TCL_ERROR;
347                goto done;
348            }
349    
350            /*
351             * Call lstat() to get info so can delete symbolic link itself.
352             */
353    
354            if (TclpLstat(name, &statBuf) != 0) {
355                /*
356                 * Trying to delete a file that does not exist is not
357                 * considered an error, just a no-op
358                 */
359    
360                if (errno != ENOENT) {
361                    result = TCL_ERROR;
362                }
363            } else if (S_ISDIR(statBuf.st_mode)) {
364                result = TclpRemoveDirectory(name, force, &errorBuffer);
365                if (result != TCL_OK) {
366                    if ((force == 0) && (errno == EEXIST)) {
367                        Tcl_AppendResult(interp, "error deleting \"", argv[i],
368                                "\": directory not empty", (char *) NULL);
369                        Tcl_PosixError(interp);
370                        goto done;
371                    }
372    
373                    /*
374                     * If possible, use the untranslated name for the file.
375                     */
376                    
377                    errfile = Tcl_DStringValue(&errorBuffer);
378                    if (strcmp(name, errfile) == 0) {
379                        errfile = argv[i];
380                    }
381                }
382            } else {
383                result = TclpDeleteFile(name);
384            }
385            
386            if (result == TCL_ERROR) {
387                break;
388            }
389        }
390        if (result != TCL_OK) {
391            Tcl_AppendResult(interp, "error deleting \"", errfile,
392                    "\": ", Tcl_PosixError(interp), (char *) NULL);
393        }
394        done:
395        Tcl_DStringFree(&errorBuffer);
396        Tcl_DStringFree(&nameBuffer);
397        return result;
398    }
399    
400    /*
401     *---------------------------------------------------------------------------
402     *
403     * CopyRenameOneFile
404     *
405     *      Copies or renames specified source file or directory hierarchy
406     *      to the specified target.  
407     *
408     * Results:
409     *      A standard Tcl result.
410     *
411     * Side effects:
412     *      Target is overwritten if the force flag is set.  Attempting to
413     *      copy/rename a file onto a directory or a directory onto a file
414     *      will always result in an error.  
415     *
416     *----------------------------------------------------------------------
417     */
418    
419    static int
420    CopyRenameOneFile(interp, source, target, copyFlag, force)
421        Tcl_Interp *interp;         /* Used for error reporting. */
422        char *source;               /* Pathname of file to copy.  May need to
423                                     * be translated. */
424        char *target;               /* Pathname of file to create/overwrite.
425                                     * May need to be translated. */
426        int copyFlag;               /* If non-zero, copy files.  Otherwise,
427                                     * rename them. */
428        int force;                  /* If non-zero, overwrite target file if it
429                                     * exists.  Otherwise, error if target already
430                                     * exists. */
431    {
432        int result;
433        Tcl_DString sourcePath, targetPath, errorBuffer;
434        char *targetName, *sourceName, *errfile;
435        struct stat sourceStatBuf, targetStatBuf;
436    
437        sourceName = Tcl_TranslateFileName(interp, source, &sourcePath);
438        if (sourceName == NULL) {
439            return TCL_ERROR;
440        }
441        targetName = Tcl_TranslateFileName(interp, target, &targetPath);
442        if (targetName == NULL) {
443            Tcl_DStringFree(&sourcePath);
444            return TCL_ERROR;
445        }
446        
447        errfile = NULL;
448        result = TCL_ERROR;
449        Tcl_DStringInit(&errorBuffer);
450        
451        /*
452         * We want to copy/rename links and not the files they point to, so we
453         * use lstat(). If target is a link, we also want to replace the
454         * link and not the file it points to, so we also use lstat() on the
455         * target.
456         */
457    
458        if (TclpLstat(sourceName, &sourceStatBuf) != 0) {
459            errfile = source;
460            goto done;
461        }
462        if (TclpLstat(targetName, &targetStatBuf) != 0) {
463            if (errno != ENOENT) {
464                errfile = target;
465                goto done;
466            }
467        } else {
468            if (force == 0) {
469                errno = EEXIST;
470                errfile = target;
471                goto done;
472            }
473    
474            /*
475             * Prevent copying or renaming a file onto itself.  Under Windows,
476             * stat always returns 0 for st_ino.  However, the Windows-specific
477             * code knows how to deal with copying or renaming a file on top of
478             * itself.  It might be a good idea to write a stat that worked.
479             */
480        
481            if ((sourceStatBuf.st_ino != 0) && (targetStatBuf.st_ino != 0)) {
482                if ((sourceStatBuf.st_ino == targetStatBuf.st_ino) &&
483                        (sourceStatBuf.st_dev == targetStatBuf.st_dev)) {
484                    result = TCL_OK;
485                    goto done;
486                }
487            }
488    
489            /*
490             * Prevent copying/renaming a file onto a directory and
491             * vice-versa.  This is a policy decision based on the fact that
492             * existing implementations of copy and rename on all platforms
493             * also prevent this.
494             */
495    
496            if (S_ISDIR(sourceStatBuf.st_mode)
497                    && !S_ISDIR(targetStatBuf.st_mode)) {
498                errno = EISDIR;
499                Tcl_AppendResult(interp, "can't overwrite file \"", target,
500                        "\" with directory \"", source, "\"", (char *) NULL);
501                goto done;
502            }
503            if (!S_ISDIR(sourceStatBuf.st_mode)
504                    && S_ISDIR(targetStatBuf.st_mode)) {
505                errno = EISDIR;
506                Tcl_AppendResult(interp, "can't overwrite directory \"", target,
507                        "\" with file \"", source, "\"", (char *) NULL);
508                goto done;
509            }
510        }
511    
512        if (copyFlag == 0) {
513            result = TclpRenameFile(sourceName, targetName);
514            if (result == TCL_OK) {
515                goto done;
516            }
517                
518            if (errno == EINVAL) {
519                Tcl_AppendResult(interp, "error renaming \"", source, "\" to \"",
520                        target, "\": trying to rename a volume or ",
521                        "move a directory into itself", (char *) NULL);
522                goto done;
523            } else if (errno != EXDEV) {
524                errfile = target;
525                goto done;
526            }
527            
528            /*
529             * The rename failed because the move was across file systems.
530             * Fall through to copy file and then remove original.  Note that
531             * the low-level TclpRenameFile is allowed to implement
532             * cross-filesystem moves itself.
533             */
534        }
535    
536        if (S_ISDIR(sourceStatBuf.st_mode)) {
537            result = TclpCopyDirectory(sourceName, targetName, &errorBuffer);
538            if (result != TCL_OK) {
539                errfile = Tcl_DStringValue(&errorBuffer);
540                if (strcmp(errfile, sourceName) == 0) {
541                    errfile = source;
542                } else if (strcmp(errfile, targetName) == 0) {
543                    errfile = target;
544                }
545            }
546        } else {
547            result = TclpCopyFile(sourceName, targetName);
548            if (result != TCL_OK) {
549                /*
550                 * Well, there really shouldn't be a problem with source,
551                 * because up there we checked to see if it was ok to copy it.
552                 */
553    
554                errfile = target;
555            }
556        }
557        if ((copyFlag == 0) && (result == TCL_OK)) {
558            if (S_ISDIR(sourceStatBuf.st_mode)) {
559                result = TclpRemoveDirectory(sourceName, 1, &errorBuffer);
560                if (result != TCL_OK) {
561                    errfile = Tcl_DStringValue(&errorBuffer);
562                    if (strcmp(errfile, sourceName) == 0) {
563                        errfile = source;
564                    }
565                }
566            } else {
567                result = TclpDeleteFile(sourceName);
568                if (result != TCL_OK) {
569                    errfile = source;
570                }
571            }
572            if (result != TCL_OK) {
573                Tcl_AppendResult(interp, "can't unlink \"", errfile, "\": ",
574                        Tcl_PosixError(interp), (char *) NULL);
575                errfile = NULL;
576            }
577        }
578        
579        done:
580        if (errfile != NULL) {
581            Tcl_AppendResult(interp,
582                    ((copyFlag) ? "error copying \"" : "error renaming \""),
583                    source, (char *) NULL);
584            if (errfile != source) {
585                Tcl_AppendResult(interp, "\" to \"", target, (char *) NULL);
586                if (errfile != target) {
587                    Tcl_AppendResult(interp, "\": \"", errfile, (char *) NULL);
588                }
589            }
590            Tcl_AppendResult(interp, "\": ", Tcl_PosixError(interp),
591                    (char *) NULL);
592        }
593        Tcl_DStringFree(&errorBuffer);
594        Tcl_DStringFree(&sourcePath);
595        Tcl_DStringFree(&targetPath);
596        return result;
597    }
598    
599    /*
600     *---------------------------------------------------------------------------
601     *
602     * FileForceOption --
603     *
604     *      Helps parse command line options for file commands that take
605     *      the "-force" and "--" options.
606     *
607     * Results:
608     *      The return value is how many arguments from argv were consumed
609     *      by this function, or -1 if there was an error parsing the
610     *      options.  If an error occurred, an error message is left in the
611     *      interp's result.
612     *
613     * Side effects:
614     *      None.
615     *
616     *---------------------------------------------------------------------------
617     */
618    
619    static int
620    FileForceOption(interp, argc, argv, forcePtr)
621        Tcl_Interp *interp;         /* Interp, for error return. */
622        int argc;                   /* Number of arguments. */
623        char **argv;                /* Argument strings.  First command line
624                                     * option, if it exists, begins at 0. */
625        int *forcePtr;              /* If the "-force" was specified, *forcePtr
626                                     * is filled with 1, otherwise with 0. */
627    {
628        int force, i;
629        
630        force = 0;
631        for (i = 0; i < argc; i++) {
632            if (argv[i][0] != '-') {
633                break;
634            }
635            if (strcmp(argv[i], "-force") == 0) {
636                force = 1;
637            } else if (strcmp(argv[i], "--") == 0) {
638                i++;
639                break;
640            } else {
641                Tcl_AppendResult(interp, "bad option \"", argv[i],
642                        "\": should be -force or --", (char *)NULL);
643                return -1;
644            }
645        }
646        *forcePtr = force;
647        return i;
648    }
649    /*
650     *---------------------------------------------------------------------------
651     *
652     * FileBasename --
653     *
654     *      Given a path in either tcl format (with / separators), or in the
655     *      platform-specific format for the current platform, return all the
656     *      characters in the path after the last directory separator.  But,
657     *      if path is the root directory, returns no characters.
658     *
659     * Results:
660     *      Appends the string that represents the basename to the end of
661     *      the specified initialized DString, returning a pointer to the
662     *      resulting string.  If there is an error, an error message is left
663     *      in interp, NULL is returned, and the Tcl_DString is unmodified.
664     *
665     * Side effects:
666     *      None.
667     *
668     *---------------------------------------------------------------------------
669     */
670    
671    static char *
672    FileBasename(interp, path, bufferPtr)
673        Tcl_Interp *interp;         /* Interp, for error return. */
674        char *path;                 /* Path whose basename to extract. */
675        Tcl_DString *bufferPtr;     /* Initialized DString that receives
676                                     * basename. */
677    {
678        int argc;
679        char **argv;
680        
681        Tcl_SplitPath(path, &argc, &argv);
682        if (argc == 0) {
683            Tcl_DStringInit(bufferPtr);
684        } else {
685            if ((argc == 1) && (*path == '~')) {
686                Tcl_DString buffer;
687                
688                ckfree((char *) argv);
689                path = Tcl_TranslateFileName(interp, path, &buffer);
690                if (path == NULL) {
691                    return NULL;
692                }
693                Tcl_SplitPath(path, &argc, &argv);
694                Tcl_DStringFree(&buffer);
695            }
696            Tcl_DStringInit(bufferPtr);
697    
698            /*
699             * Return the last component, unless it is the only component, and it
700             * is the root of an absolute path.
701             */
702    
703            if (argc > 0) {
704                if ((argc > 1)
705                        || (Tcl_GetPathType(argv[0]) == TCL_PATH_RELATIVE)) {
706                    Tcl_DStringAppend(bufferPtr, argv[argc - 1], -1);
707                }
708            }
709        }
710        ckfree((char *) argv);
711        return Tcl_DStringValue(bufferPtr);
712    }
713    
714    /*
715     *----------------------------------------------------------------------
716     *
717     * TclFileAttrsCmd --
718     *
719     *      Sets or gets the platform-specific attributes of a file. The objc-objv
720     *      points to the file name with the rest of the command line following.
721     *      This routine uses platform-specific tables of option strings
722     *      and callbacks. The callback to get the attributes take three
723     *      parameters:
724     *          Tcl_Interp *interp;     The interp to report errors with.
725     *                                  Since this is an object-based API,
726     *                                  the object form of the result should be
727     *                                  used.
728     *          CONST char *fileName;   This is extracted using
729     *                                  Tcl_TranslateFileName.
730     *          TclObj **attrObjPtrPtr; A new object to hold the attribute
731     *                                  is allocated and put here.
732     *      The first two parameters of the callback used to write out the
733     *      attributes are the same. The third parameter is:
734     *          CONST *attrObjPtr;      A pointer to the object that has
735     *                                  the new attribute.
736     *      They both return standard TCL errors; if the routine to get
737     *      an attribute fails, no object is allocated and *attrObjPtrPtr
738     *      is unchanged.
739     *
740     * Results:
741     *      Standard TCL error.
742     *
743     * Side effects:
744     *      May set file attributes for the file name.
745     *      
746     *----------------------------------------------------------------------
747     */
748    
749    int
750    TclFileAttrsCmd(interp, objc, objv)
751        Tcl_Interp *interp;         /* The interpreter for error reporting. */
752        int objc;                   /* Number of command line arguments. */
753        Tcl_Obj *CONST objv[];      /* The command line objects. */
754    {
755        char *fileName;
756        int result;
757        Tcl_DString buffer;
758    
759        if (objc < 3) {
760            Tcl_WrongNumArgs(interp, 2, objv,
761                    "name ?option? ?value? ?option value ...?");
762            return TCL_ERROR;
763        }
764    
765        fileName = Tcl_GetString(objv[2]);
766        fileName = Tcl_TranslateFileName(interp, fileName, &buffer);
767        if (fileName == NULL) {
768            return TCL_ERROR;
769        }
770        
771        objc -= 3;
772        objv += 3;
773        result = TCL_ERROR;
774    
775        if (objc == 0) {
776            /*
777             * Get all attributes.
778             */
779    
780            int index;
781            Tcl_Obj *listPtr, *objPtr;
782            
783            listPtr = Tcl_NewListObj(0, NULL);
784            for (index = 0; tclpFileAttrStrings[index] != NULL; index++) {
785                objPtr = Tcl_NewStringObj(tclpFileAttrStrings[index], -1);
786                Tcl_ListObjAppendElement(interp, listPtr, objPtr);
787    
788                if ((*tclpFileAttrProcs[index].getProc)(interp, index, fileName,
789                        &objPtr) != TCL_OK) {
790                    Tcl_DecrRefCount(listPtr);
791                    goto end;
792                }
793                Tcl_ListObjAppendElement(interp, listPtr, objPtr);
794            }
795            Tcl_SetObjResult(interp, listPtr);
796        } else if (objc == 1) {
797            /*
798             * Get one attribute.
799             */
800    
801            int index;
802            Tcl_Obj *objPtr;
803            
804            if (Tcl_GetIndexFromObj(interp, objv[0], tclpFileAttrStrings,
805                    "option", 0, &index) != TCL_OK) {
806                goto end;
807            }
808            if ((*tclpFileAttrProcs[index].getProc)(interp, index, fileName,
809                    &objPtr) != TCL_OK) {
810                goto end;
811            }
812            Tcl_SetObjResult(interp, objPtr);
813        } else {
814            /*
815             * Set option/value pairs.
816             */
817    
818            int i, index;
819            
820            for (i = 0; i < objc ; i += 2) {
821                if (Tcl_GetIndexFromObj(interp, objv[i], tclpFileAttrStrings,
822                        "option", 0, &index) != TCL_OK) {
823                    goto end;
824                }
825                if (i + 1 == objc) {
826                    Tcl_AppendResult(interp, "value for \"",
827                            Tcl_GetString(objv[i]), "\" missing",
828                            (char *) NULL);
829                    goto end;
830                }
831                if ((*tclpFileAttrProcs[index].setProc)(interp, index, fileName,
832                        objv[i + 1]) != TCL_OK) {
833                    goto end;
834                }
835            }
836        }
837        result = TCL_OK;
838    
839        end:
840        Tcl_DStringFree(&buffer);
841        return result;
842    }
843    
844    /* End of tclfcmd.c */
Legend:
Removed from v.44  
changed lines
  Added in v.220
dashley@gmail.com
 ViewVC Help
Powered by ViewVC 1.1.25