diff options
Diffstat (limited to 'generic')
| -rw-r--r-- | generic/tcl.decls | 10 | ||||
| -rw-r--r-- | generic/tcl.h | 11 | ||||
| -rw-r--r-- | generic/tclCmdAH.c | 50 | ||||
| -rw-r--r-- | generic/tclDecls.h | 17 | ||||
| -rw-r--r-- | generic/tclFCmd.c | 56 | ||||
| -rw-r--r-- | generic/tclFileName.c | 217 | ||||
| -rw-r--r-- | generic/tclIOUtil.c | 238 | ||||
| -rw-r--r-- | generic/tclInt.h | 13 | ||||
| -rw-r--r-- | generic/tclStubInit.c | 4 | ||||
| -rw-r--r-- | generic/tclTest.c | 156 |
10 files changed, 520 insertions, 252 deletions
diff --git a/generic/tcl.decls b/generic/tcl.decls index 7a93099..f0f64a9 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: tcl.decls,v 1.53 2001/08/30 08:53:14 vincentdarley Exp $ +# RCS: @(#) $Id: tcl.decls,v 1.54 2001/09/04 18:06:34 vincentdarley Exp $ library tcl @@ -1667,7 +1667,13 @@ declare 475 generic { declare 476 generic { char* Tcl_FSGetTranslatedStringPath(Tcl_Interp *interp, Tcl_Obj* pathPtr) } - +declare 477 generic { + Tcl_Filesystem* Tcl_FSGetFileSystemForPath(Tcl_Obj* pathObjPtr) +} +declare 478 generic { + Tcl_PathType Tcl_FSGetPathType (Tcl_Obj *pathObjPtr) +} + ############################################################################## # Define the platform specific public Tcl interface. These functions are diff --git a/generic/tcl.h b/generic/tcl.h index 91e5627..46ef74d 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tcl.h,v 1.97 2001/08/30 15:41:29 dgp Exp $ + * RCS: @(#) $Id: tcl.h,v 1.98 2001/09/04 18:06:34 vincentdarley Exp $ */ #ifndef _TCL @@ -1554,7 +1554,8 @@ typedef int (Tcl_FSLoadFileProc) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj *pathPtr, char * sym1, char * sym2, Tcl_PackageInitProc ** proc1Ptr, Tcl_PackageInitProc ** proc2Ptr, - ClientData * clientDataPtr)); + ClientData * clientDataPtr, + Tcl_FSUnloadFileProc **unloadProcPtr)); typedef int (Tcl_FSPathInFilesystemProc) _ANSI_ARGS_((Tcl_Obj *pathPtr, ClientData *clientDataPtr)); typedef Tcl_Obj* (Tcl_FSFilesystemPathTypeProc) @@ -1739,12 +1740,6 @@ typedef struct Tcl_Filesystem { * implemented, Tcl will fall back on * a copy to native-temp followed by a * Tcl_FSLoadFile on that temporary copy. */ - Tcl_FSUnloadFileProc *unloadFileProc; - /* Function to unload a previously - * successfully loaded file. If load was - * implemented, then this should also be - * implemented, if there is any cleanup - * action required. */ Tcl_FSGetCwdProc *getCwdProc; /* * Function to process a 'Tcl_FSGetCwd()' diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 0793a2e..3ea9aad 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCmdAH.c,v 1.14 2001/08/23 17:37:07 vincentdarley Exp $ + * RCS: @(#) $Id: tclCmdAH.c,v 1.15 2001/09/04 18:06:34 vincentdarley Exp $ */ #include "tclInt.h" @@ -878,48 +878,18 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) return TclFileDeleteCmd(interp, objc, objv); } case FILE_DIRNAME: { - int splitElements; - Tcl_Obj *splitPtr; - Tcl_Obj *splitResultPtr = NULL; - + Tcl_Obj *dirPtr; if (objc != 3) { goto only3Args; } - /* - * The behaviour we want here is slightly different to - * the standard Tcl_FSSplitPath in the handling of home - * directories; Tcl_FSSplitPath preserves the "~" while - * this code computes the actual full path name, if we - * had just a single component. - */ - splitPtr = Tcl_FSSplitPath(objv[2], &splitElements); - if ((splitElements == 1) && (Tcl_GetString(objv[2])[0] == '~')) { - Tcl_DecrRefCount(splitPtr); - splitPtr = Tcl_FSGetNormalizedPath(interp, objv[2]); - if (splitPtr == NULL) { - return TCL_ERROR; - } - splitPtr = Tcl_FSSplitPath(splitPtr, &splitElements); - } - - /* - * Return all but the last component. If there is only one - * component, return it if the path was non-relative, otherwise - * return the current directory. - */ - - if (splitElements > 1) { - splitResultPtr = Tcl_FSJoinPath(splitPtr, splitElements - 1); - } else if (splitElements == 0 || - (Tcl_FSGetPathType(objv[2], NULL, NULL) == TCL_PATH_RELATIVE)) { - splitResultPtr = Tcl_NewStringObj( - ((tclPlatform == TCL_PLATFORM_MAC) ? ":" : "."), 1); + dirPtr = TclFileDirname(interp, objv[2]); + if (dirPtr == NULL) { + return TCL_ERROR; } else { - Tcl_ListObjIndex(NULL, splitPtr, 0, &splitResultPtr); + Tcl_SetObjResult(interp, dirPtr); + Tcl_DecrRefCount(dirPtr); + return TCL_OK; } - Tcl_SetObjResult(interp, splitResultPtr); - Tcl_DecrRefCount(splitPtr); - return TCL_OK; } case FILE_EXECUTABLE: { if (objc != 3) { @@ -1099,7 +1069,7 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) if (objc != 3) { goto only3Args; } - switch (Tcl_FSGetPathType(objv[2], NULL, NULL)) { + switch (Tcl_FSGetPathType(objv[2])) { case TCL_PATH_ABSOLUTE: Tcl_SetStringObj(Tcl_GetObjResult(interp), "absolute", -1); break; @@ -1272,7 +1242,7 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) if (splitElements > 0) { if ((splitElements > 1) - || (Tcl_FSGetPathType(objv[2], NULL, NULL) == TCL_PATH_RELATIVE)) { + || (Tcl_FSGetPathType(objv[2]) == TCL_PATH_RELATIVE)) { Tcl_Obj *tail = NULL; Tcl_ListObjIndex(NULL, splitPtr, splitElements-1, &tail); diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 8aa701d..e7c744a 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclDecls.h,v 1.54 2001/08/23 17:37:07 vincentdarley Exp $ + * RCS: @(#) $Id: tclDecls.h,v 1.55 2001/09/04 18:06:34 vincentdarley Exp $ */ #ifndef _TCLDECLS @@ -1490,6 +1490,11 @@ EXTERN ClientData Tcl_FSData _ANSI_ARGS_((Tcl_Filesystem * fsPtr)); /* 476 */ EXTERN char* Tcl_FSGetTranslatedStringPath _ANSI_ARGS_(( Tcl_Interp * interp, Tcl_Obj* pathPtr)); +/* 477 */ +EXTERN Tcl_Filesystem* Tcl_FSGetFileSystemForPath _ANSI_ARGS_(( + Tcl_Obj* pathObjPtr)); +/* 478 */ +EXTERN Tcl_PathType Tcl_FSGetPathType _ANSI_ARGS_((Tcl_Obj * pathObjPtr)); typedef struct TclStubHooks { struct TclPlatStubs *tclPlatStubs; @@ -2026,6 +2031,8 @@ typedef struct TclStubs { int (*tcl_FSUnregister) _ANSI_ARGS_((Tcl_Filesystem * fsPtr)); /* 474 */ ClientData (*tcl_FSData) _ANSI_ARGS_((Tcl_Filesystem * fsPtr)); /* 475 */ char* (*tcl_FSGetTranslatedStringPath) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj* pathPtr)); /* 476 */ + Tcl_Filesystem* (*tcl_FSGetFileSystemForPath) _ANSI_ARGS_((Tcl_Obj* pathObjPtr)); /* 477 */ + Tcl_PathType (*tcl_FSGetPathType) _ANSI_ARGS_((Tcl_Obj * pathObjPtr)); /* 478 */ } TclStubs; #ifdef __cplusplus @@ -3974,6 +3981,14 @@ extern TclStubs *tclStubsPtr; #define Tcl_FSGetTranslatedStringPath \ (tclStubsPtr->tcl_FSGetTranslatedStringPath) /* 476 */ #endif +#ifndef Tcl_FSGetFileSystemForPath +#define Tcl_FSGetFileSystemForPath \ + (tclStubsPtr->tcl_FSGetFileSystemForPath) /* 477 */ +#endif +#ifndef Tcl_FSGetPathType +#define Tcl_FSGetPathType \ + (tclStubsPtr->tcl_FSGetPathType) /* 478 */ +#endif #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */ diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c index 035446f..c05b7a4 100644 --- a/generic/tclFCmd.c +++ b/generic/tclFCmd.c @@ -9,7 +9,7 @@ * 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.11 2001/08/30 08:53:14 vincentdarley Exp $ + * RCS: @(#) $Id: tclFCmd.c,v 1.12 2001/09/04 18:06:34 vincentdarley Exp $ */ #include "tclInt.h" @@ -599,53 +599,13 @@ CopyRenameOneFile(interp, source, target, copyFlag, force) } } else { result = Tcl_FSCopyFile(source, target); - if ((result != TCL_OK) && (errno == EXDEV)) { - /* - * Well, there really shouldn't be a problem with source, - * because up there we checked to see if it was ok to copy it. - * - * Either there is a problem with target, or we're trying - * to do a cross-filesystem copy. We open the target for - * writing to decide between those two cases. + 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 */ - int prot = 0666; - Tcl_Channel out = Tcl_FSOpenFileChannel(interp, target, "w", prot); - if (out == NULL) { - /* There was a problem with the target */ - errfile = target; - } else { - /* It looks like we can copy it over */ - Tcl_Channel in = Tcl_FSOpenFileChannel(interp, source, - "r", prot); - if (in == NULL) { - /* This is very strange, we checked this above */ - Tcl_Close(interp, out); - errfile = source; - } else { - struct utimbuf tval; - /* - * Copy it synchronously. We might wish to add an - * asynchronous option to support vfs's which are - * slow (e.g. network sockets). - */ - Tcl_SetChannelOption(interp, in, "-translation", "binary"); - Tcl_SetChannelOption(interp, out, "-translation", "binary"); - - if (TclCopyChannel(interp, in, out, -1, NULL) == TCL_OK) { - result = TCL_OK; - } - /* - * If the copy failed, assume that copy channel left - * a good error message. - */ - Tcl_Close(interp, in); - Tcl_Close(interp, out); - /* Set modification date of copied file */ - tval.actime = sourceStatBuf.st_atime; - tval.modtime = sourceStatBuf.st_mtime; - Tcl_FSUtime(source, &tval); - } - } + errfile = target; } } if ((copyFlag == 0) && (result == TCL_OK)) { @@ -792,7 +752,7 @@ FileBasename(interp, pathPtr) if (objc > 0) { Tcl_ListObjIndex(NULL, splitPtr, objc-1, &resultPtr); if ((objc == 1) && - (Tcl_FSGetPathType(resultPtr, NULL, NULL) != TCL_PATH_RELATIVE)) { + (Tcl_FSGetPathType(resultPtr) != TCL_PATH_RELATIVE)) { resultPtr = NULL; } } diff --git a/generic/tclFileName.c b/generic/tclFileName.c index 1839564..3eb9a17 100644 --- a/generic/tclFileName.c +++ b/generic/tclFileName.c @@ -10,25 +10,17 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclFileName.c,v 1.19 2001/08/30 08:53:14 vincentdarley Exp $ + * RCS: @(#) $Id: tclFileName.c,v 1.20 2001/09/04 18:06:34 vincentdarley Exp $ */ #include "tclInt.h" #include "tclPort.h" #include "tclRegexp.h" -/* - * The following regular expression matches the root portion of a Windows - * absolute or volume relative path. It will match both UNC and drive relative - * paths. This pattern is no longer used, since it has been replaced by - * the ExtractWinRoot function. - */ - -#define WIN_ROOT_PATTERN "^(([a-zA-Z]:)|[/\\\\][/\\\\]+([^/\\\\]+)[/\\\\]+([^/\\\\]+)|([/\\\\]))([/\\\\])*" - /* * This define is used to activate Tcl's interpretation of Unix-style - * paths (containing forward slashes) on MacOS. + * paths (containing forward slashes, '.' and '..') on MacOS. A + * side-effect of this is that some paths become ambiguous. */ #define MAC_UNDERSTANDS_UNIX_PATHS @@ -36,19 +28,19 @@ /* * The following regular expression matches the root portion of a Macintosh * absolute path. It will match degenerate Unix-style paths, tilde paths, - * Unix-style paths, and Mac paths. + * Unix-style paths, and Mac paths. The various subexpressions in this + * can be summarised as follows: ^(/..|~user/unix|~user:mac|/unix|mac:dir). + * The subexpression indices which match the root portions, are as follows: + * + * degenerate unix-style: 2 + * unix-tilde: 5 + * mac-tilde: 7 + * unix-style: 9 (or 10 to cut off the irrelevant header). + * mac: 12 + * */ #define MAC_ROOT_PATTERN "^((/+([.][.]?/+)*([.][.]?)?)|(~[^:/]*)(/[^:]*)?|(~[^:]*)(:.*)?|/+([.][.]?/+)*([^:/]+)(/[^:]*)?|([^:]+):.*)$" -#else -/* - * The following regular expression and some code below needs to be updated - * to allow complete removal of unix-style path matching. For the moment - * this regular expression is the same as the one above. - */ - -#define MAC_ROOT_PATTERN "^((/+([.][.]?/+)*([.][.]?)?)|(~[^:/]*)(/[^:]*)?|(~[^:]*)(:.*)?|/+([.][.]?/+)*([^:/]+)(/[^:]*)?|([^:]+):.*)$" -#endif /* * The following variables are used to hold precompiled regular expressions @@ -62,6 +54,11 @@ typedef struct ThreadSpecificData { static Tcl_ThreadDataKey dataKey; +static void FileNameCleanup _ANSI_ARGS_((ClientData clientData)); +static void FileNameInit _ANSI_ARGS_((void)); + +#endif + /* * The following variable is set in the TclPlatformInit call to one * of: TCL_PLATFORM_UNIX, TCL_PLATFORM_MAC, or TCL_PLATFORM_WINDOWS. @@ -78,13 +75,12 @@ static char * DoTildeSubst _ANSI_ARGS_((Tcl_Interp *interp, static CONST char * ExtractWinRoot _ANSI_ARGS_((CONST char *path, Tcl_DString *resultPtr, int offset, Tcl_PathType *typePtr)); -static void FileNameCleanup _ANSI_ARGS_((ClientData clientData)); -static void FileNameInit _ANSI_ARGS_((void)); static int SkipToChar _ANSI_ARGS_((char **stringPtr, char *match)); static Tcl_Obj* SplitMacPath _ANSI_ARGS_((CONST char *path)); static Tcl_Obj* SplitWinPath _ANSI_ARGS_((CONST char *path)); static Tcl_Obj* SplitUnixPath _ANSI_ARGS_((CONST char *path)); +#ifdef MAC_UNDERSTANDS_UNIX_PATHS /* *---------------------------------------------------------------------- @@ -138,6 +134,7 @@ FileNameCleanup(clientData) Tcl_DecrRefCount(tsdPtr->macRootPatternPtr); tsdPtr->initialized = 0; } +#endif /* *---------------------------------------------------------------------- @@ -167,8 +164,6 @@ ExtractWinRoot(path, resultPtr, offset, typePtr) * stored. */ Tcl_PathType *typePtr; /* Where to store pathType result */ { - FileNameInit(); - if (path[0] == '/' || path[0] == '\\') { /* Might be a UNC or Vol-Relative path */ char *host, *share, *tail; @@ -192,7 +187,14 @@ ExtractWinRoot(path, resultPtr, offset, typePtr) /* * The path given is simply of the form * '/foo', '//foo', '/////foo' or the same - * with backslashes. + * with backslashes. If there is exactly + * one leading '/' the path is volume relative + * (see filename man page). If there are more + * than one, we are simply assuming they + * are superfluous and we trim them away. + * (An alternative interpretation would + * be that it is a host name, but we have + * been documented that that is not the case). */ *typePtr = TCL_PATH_VOLUME_RELATIVE; Tcl_DStringAppend(resultPtr, "/", 1); @@ -275,7 +277,7 @@ Tcl_GetPathType(path) Tcl_PathType type; Tcl_Obj *tempObj = Tcl_NewStringObj(path,-1); Tcl_IncrRefCount(tempObj); - type = Tcl_FSGetPathType(tempObj, NULL, NULL); + type = Tcl_FSGetPathType(tempObj); Tcl_DecrRefCount(tempObj); return type; } @@ -362,6 +364,7 @@ TclpGetNativePathType(pathObjPtr, driveNameLengthPtr, driveNameRef) if (path[0] == ':') { type = TCL_PATH_RELATIVE; } else { +#ifdef MAC_UNDERSTANDS_UNIX_PATHS ThreadSpecificData *tsdPtr; Tcl_RegExp re; @@ -380,7 +383,6 @@ TclpGetNativePathType(pathObjPtr, driveNameLengthPtr, driveNameRef) type = TCL_PATH_RELATIVE; } else { char *root, *end; - Tcl_RegExpRange(re, 2, &root, &end); if (root != NULL) { type = TCL_PATH_RELATIVE; @@ -389,7 +391,6 @@ TclpGetNativePathType(pathObjPtr, driveNameLengthPtr, driveNameRef) Tcl_RegExpRange(re, 0, &root, &end); *driveNameLengthPtr = end - root; } -#ifdef MAC_UNDERSTANDS_UNIX_PATHS if (driveNameRef != NULL) { if (*root == '/') { char *c; @@ -416,9 +417,25 @@ TclpGetNativePathType(pathObjPtr, driveNameLengthPtr, driveNameRef) } } } -#endif } } +#else + if (path[0] == '~') { + } else if (path[0] == ':') { + type = TCL_PATH_RELATIVE; + } else { + char *colonPos = strchr(path,':'); + if (colonPos == NULL) { + type = TCL_PATH_RELATIVE; + } else { + } + } + if (type == TCL_PATH_ABSOLUTE) { + if (driveNameLengthPtr != NULL) { + *driveNameLengthPtr = strlen(path); + } + } +#endif } break; @@ -762,14 +779,18 @@ SplitMacPath(path) CONST char *path; /* Pointer to string containing a path. */ { int isMac = 0; /* 1 if is Mac-style, 0 if Unix-style path. */ - int i, length; + int length; CONST char *p, *elementStart; - Tcl_RegExp re; Tcl_Obj *result; +#ifdef MAC_UNDERSTANDS_UNIX_PATHS + Tcl_RegExp re; + int i; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - +#endif + result = Tcl_NewObj(); +#ifdef MAC_UNDERSTANDS_UNIX_PATHS /* * Initialize the path name parser for Macintosh path names. */ @@ -843,13 +864,11 @@ SplitMacPath(path) } } } - Tcl_RegExpRange(re, i, &start, &end); length = end - start; /* - * Append the element and terminate it with a : and a null. Note that - * we are forcing the DString to contain an extra null at the end. + * Append the element and terminate it with a : */ nextElt = Tcl_NewStringObj(start, length); @@ -860,15 +879,49 @@ SplitMacPath(path) isMac = (strchr(path, ':') != NULL); p = path; } +#else + if ((path[0] != ':') && (path[0] == '~' || (strchr(path,':') != NULL))) { + CONST char *end; + Tcl_Obj *nextElt; + + isMac = 1; + + end = strchr(path,':'); + if (end == NULL) { + length = strlen(path); + } else { + length = end - path; + } + + /* + * Append the element and terminate it with a : + */ + + nextElt = Tcl_NewStringObj(path, length); + Tcl_AppendToObj(nextElt, ":", 1); + Tcl_ListObjAppendElement(NULL, result, nextElt); + p = path + length; + } else { + isMac = (strchr(path, ':') != NULL); + isMac = 1; + p = path; + } +#endif if (isMac) { /* * p is pointing at the first colon in the path. There * will always be one, since this is a Mac-style path. + * (This is no longer true if MAC_UNDERSTANDS_UNIX_PATHS + * is false, so we must check whether 'p' points to the + * end of the string.) */ - - elementStart = p++; + elementStart = p; + if (*p == ':') { + p++; + } + while ((p = strchr(p, ':')) != NULL) { length = p - elementStart; if (length == 1) { @@ -891,13 +944,20 @@ SplitMacPath(path) elementStart = p++; } } - if (elementStart[1] != '\0' || elementStart == path) { - if ((elementStart[1] != '~') && (elementStart[1] != '\0') - && (strchr(elementStart+1, '/') == NULL)) { + if (elementStart[0] != ':') { + if (elementStart[0] != '\0') { + Tcl_ListObjAppendElement(NULL, result, + Tcl_NewStringObj(elementStart, -1)); + } + } else { + if (elementStart[1] != '\0' || elementStart == path) { + if ((elementStart[1] != '~') && (elementStart[1] != '\0') + && (strchr(elementStart+1, '/') == NULL)) { elementStart++; + } + Tcl_ListObjAppendElement(NULL, result, + Tcl_NewStringObj(elementStart, -1)); } - Tcl_ListObjAppendElement(NULL, result, - Tcl_NewStringObj(elementStart, -1)); } } else { @@ -1150,6 +1210,11 @@ TclpNativeJoinPath(prefix, joining) */ newLength = strlen(p); + /* + * It may not be good to just do 'Tcl_AppendToObj(prefix, + * p, newLength)' because the object may contain duplicate + * colons which we want to get rid of. + */ Tcl_AppendToObj(prefix, p, newLength); /* Remove spurious trailing single ':' */ @@ -2484,3 +2549,69 @@ TclDoGlob(interp, separators, headPtr, tail, types) return TCL_OK; } } + + +/* + *--------------------------------------------------------------------------- + * + * TclFileDirname + * + * This procedure calculates the directory above a given + * path: basically 'file dirname'. It is used both by + * the 'dirname' subcommand of file and by code in tclIOUtil.c. + * + * Results: + * NULL if an error occurred, otherwise a Tcl_Obj owned by + * the caller (i.e. most likely with refCount 1). + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +Tcl_Obj* +TclFileDirname(interp, pathPtr) + Tcl_Interp *interp; /* Used for error reporting */ + Tcl_Obj *pathPtr; /* Path to take dirname of */ +{ + int splitElements; + Tcl_Obj *splitPtr; + Tcl_Obj *splitResultPtr = NULL; + + /* + * The behaviour we want here is slightly different to + * the standard Tcl_FSSplitPath in the handling of home + * directories; Tcl_FSSplitPath preserves the "~" while + * this code computes the actual full path name, if we + * had just a single component. + */ + splitPtr = Tcl_FSSplitPath(pathPtr, &splitElements); + if ((splitElements == 1) && (Tcl_GetString(pathPtr)[0] == '~')) { + Tcl_DecrRefCount(splitPtr); + splitPtr = Tcl_FSGetNormalizedPath(interp, pathPtr); + if (splitPtr == NULL) { + return NULL; + } + splitPtr = Tcl_FSSplitPath(splitPtr, &splitElements); + } + + /* + * Return all but the last component. If there is only one + * component, return it if the path was non-relative, otherwise + * return the current directory. + */ + + if (splitElements > 1) { + splitResultPtr = Tcl_FSJoinPath(splitPtr, splitElements - 1); + } else if (splitElements == 0 || + (Tcl_FSGetPathType(pathPtr) == TCL_PATH_RELATIVE)) { + splitResultPtr = Tcl_NewStringObj( + ((tclPlatform == TCL_PLATFORM_MAC) ? ":" : "."), 1); + } else { + Tcl_ListObjIndex(NULL, splitPtr, 0, &splitResultPtr); + } + Tcl_IncrRefCount(splitResultPtr); + Tcl_DecrRefCount(splitPtr); + return splitResultPtr; +} diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index 2406215..96a33f8 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -17,7 +17,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIOUtil.c,v 1.17 2001/08/30 08:53:14 vincentdarley Exp $ + * RCS: @(#) $Id: tclIOUtil.c,v 1.18 2001/09/04 18:06:34 vincentdarley Exp $ */ #include "tclInt.h" @@ -41,11 +41,14 @@ static int TclNormalizeToUniquePath static int SetFsPathFromAbsoluteNormalized _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr)); static int FindSplitPos _ANSI_ARGS_((char *path, char *separator)); -static Tcl_Filesystem* Tcl_FSGetFileSystemForPath - _ANSI_ARGS_((Tcl_Obj* pathObjPtr)); +static Tcl_PathType FSGetPathType _ANSI_ARGS_((Tcl_Obj *pathObjPtr, + Tcl_Filesystem **filesystemPtrPtr, + int *driveNameLengthPtr)); static Tcl_PathType GetPathType _ANSI_ARGS_((Tcl_Obj *pathObjPtr, Tcl_Filesystem **filesystemPtrPtr, int *driveNameLengthPtr, Tcl_Obj **driveNameRef)); +static int CrossFilesystemCopy _ANSI_ARGS_((Tcl_Obj *source, + Tcl_Obj *target)); /* * Define the 'path' object type, which Tcl uses to represent @@ -244,7 +247,7 @@ typedef struct FilesystemRecord { * filesystem (can be NULL) */ Tcl_Filesystem *fsPtr; /* Pointer to filesystem dispatch * table. */ - int refCount; /* How many Tcl_Obj's use this + int fileRefCount; /* How many Tcl_Obj's use this * filesystem. */ struct FilesystemRecord *nextPtr; /* The next filesystem registered @@ -337,7 +340,6 @@ static Tcl_Filesystem nativeFilesystem = { &TclpObjRenameFile, &TclpObjCopyDirectory, &TclpLoadFile, - &TclpUnloadFile, &TclpObjGetCwd, &TclpObjChdir }; @@ -534,7 +536,11 @@ Tcl_FSRegister(clientData, fsPtr) newFilesystemPtr->clientData = clientData; newFilesystemPtr->fsPtr = fsPtr; - newFilesystemPtr->refCount = 0; + /* + * We start with a refCount of 1. If this drops to zero, then + * anyone is welcome to ckfree us. + */ + newFilesystemPtr->fileRefCount = 1; /* * Is this lock and wait strictly speaking necessary? Since any @@ -624,8 +630,11 @@ Tcl_FSUnregister(fsPtr) * lead to memory exceptions). */ filesystemEpoch++; - - ckfree((char *)tmpFsRecPtr); + + tmpFsRecPtr->fileRefCount--; + if (tmpFsRecPtr->fileRefCount <= 0) { + ckfree((char *)tmpFsRecPtr); + } retVal = TCL_OK; } else { @@ -862,7 +871,7 @@ TclNormalizeToUniquePath(interp, pathPtr) /* * We could add an efficiency check like this: * - * if (retVal == Tcl_DStringLength(pathPtr)) {break;} + * if (retVal == length-of(pathPtr)) {break;} * * but there's not much benefit. */ @@ -1563,7 +1572,7 @@ Tcl_FSMatchInDirectory(interp, result, pathPtr, pattern, types) cwd = Tcl_FSGetCwd(NULL); if (cwd == NULL) { if (interp != NULL) { - Tcl_SetResult(interp, "glob couldn't determine" + Tcl_SetResult(interp, "glob couldn't determine " "the current working directory", TCL_STATIC); } return TCL_ERROR; @@ -1909,9 +1918,8 @@ NativeFileAttrsGet(interp, index, fileName, objPtrRef) Tcl_Obj *fileName; /* filename we are operating on. */ Tcl_Obj **objPtrRef; /* for output. */ { - Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(NULL, fileName); return (*tclpFileAttrProcs[index].getProc)(interp, index, - transPtr, objPtrRef); + fileName, objPtrRef); } /* @@ -1941,9 +1949,8 @@ NativeFileAttrsSet(interp, index, fileName, objPtr) Tcl_Obj *fileName; /* filename we are operating on. */ Tcl_Obj *objPtr; /* set to this value. */ { - Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(NULL, fileName); return (*tclpFileAttrProcs[index].setProc)(interp, index, - transPtr, objPtr); + fileName, objPtr); } /* @@ -2186,19 +2193,15 @@ Tcl_FSLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr, Tcl_FSLoadFileProc *proc = fsPtr->loadFileProc; if (proc != NULL) { int retVal = (*proc)(interp, pathPtr, sym1, sym2, - proc1Ptr, proc2Ptr, clientDataPtr); - if (retVal != -1) { - /* - * We handled it. Remember which unload file - * proc to use. - */ - (*unloadProcPtr) = fsPtr->unloadFileProc; - } + proc1Ptr, proc2Ptr, clientDataPtr, + unloadProcPtr); return retVal; } else { Tcl_Filesystem *copyFsPtr; - /* Get a temporary filename to use, first to - * copy the file into, and then to load. */ + /* + * Get a temporary filename to use, first to + * copy the file into, and then to load. + */ Tcl_Obj *copyToPtr = TclpTempFileName(); if (copyToPtr == NULL) { return -1; @@ -2207,14 +2210,16 @@ Tcl_FSLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr, copyFsPtr = Tcl_FSGetFileSystemForPath(copyToPtr); if ((copyFsPtr == NULL) || (copyFsPtr == fsPtr)) { - /* We already know we can't use Tcl_FSLoadFile from + /* + * We already know we can't use Tcl_FSLoadFile from * this filesystem, and we must avoid a possible - * infinite loop. */ + * infinite loop. + */ Tcl_DecrRefCount(copyToPtr); return -1; } - if (Tcl_FSCopyFile(pathPtr, copyToPtr) == 0) { + if (CrossFilesystemCopy(pathPtr, copyToPtr) == TCL_OK) { /* * Do we need to set appropriate permissions * on the file? This may be required on some @@ -2427,6 +2432,31 @@ Tcl_FSListVolumes(void) * Tcl_FSGetPathType -- * * Determines whether a given path is relative to the current + * directory, relative to the current volume, or absolute. + * + * Results: + * Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or + * TCL_PATH_VOLUME_RELATIVE. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_PathType +Tcl_FSGetPathType(pathObjPtr) + Tcl_Obj *pathObjPtr; +{ + return FSGetPathType(pathObjPtr, NULL, NULL); +} + +/* + *---------------------------------------------------------------------- + * + * FSGetPathType -- + * + * Determines whether a given path is relative to the current * directory, relative to the current volume, or absolute. If the * caller wishes to know which filesystem claimed the path (in the * case for which the path is absolute), then a reference to a @@ -2445,20 +2475,22 @@ Tcl_FSListVolumes(void) *---------------------------------------------------------------------- */ -Tcl_PathType -Tcl_FSGetPathType(pathObjPtr, filesystemPtrPtr, driveNameLengthPtr) +static Tcl_PathType +FSGetPathType(pathObjPtr, filesystemPtrPtr, driveNameLengthPtr) Tcl_Obj *pathObjPtr; Tcl_Filesystem **filesystemPtrPtr; int *driveNameLengthPtr; { if (Tcl_FSConvertToPathType(NULL, pathObjPtr) != TCL_OK) { - return GetPathType(pathObjPtr, filesystemPtrPtr, driveNameLengthPtr, NULL); + return GetPathType(pathObjPtr, filesystemPtrPtr, + driveNameLengthPtr, NULL); } else { FsPath *fsPathPtr = (FsPath*) pathObjPtr->internalRep.otherValuePtr; if (fsPathPtr->cwdPtr != NULL) { return TCL_PATH_RELATIVE; } else { - return GetPathType(pathObjPtr, filesystemPtrPtr, driveNameLengthPtr, NULL); + return GetPathType(pathObjPtr, filesystemPtrPtr, + driveNameLengthPtr, NULL); } } } @@ -2469,13 +2501,9 @@ Tcl_FSGetPathType(pathObjPtr, filesystemPtrPtr, driveNameLengthPtr) * Tcl_FSSplitPath -- * * This function takes the given Tcl_Obj, which should be a valid - * path, and returns a Tcl List object containing each segment - * of that path as an element. + * path, and returns a Tcl List object containing each segment of + * that path as an element. * - * Note this function currently calls the older Split(Plat)Path - * functions, which require more memory allocation than is - * desirable. - * * Results: * Returns list object with refCount of zero. If the passed in * lenPtr is non-NULL, we use it to return the number of elements @@ -2502,7 +2530,7 @@ Tcl_FSSplitPath(pathPtr, lenPtr) * Perform platform specific splitting. */ - if (Tcl_FSGetPathType(pathPtr, &fsPtr, &driveNameLength) + if (FSGetPathType(pathPtr, &fsPtr, &driveNameLength) == TCL_PATH_ABSOLUTE) { if (fsPtr == &nativeFilesystem) { return TclpNativeSplitPath(pathPtr, lenPtr); @@ -2574,11 +2602,6 @@ Tcl_FSSplitPath(pathPtr, lenPtr) * first 'elements' elements as valid path segments. If elements < 0, * we use the entire list. * - * Note this function currently calls the older Tcl_JoinPath - * routine, which therefore requires more memory allocation and - * deallocation than necessary. We could easily rewrite this for - * greater efficiency. - * * Results: * Returns object with refCount of zero. * @@ -2710,7 +2733,7 @@ Tcl_FSJoinPath(listObj, elements) * * GetPathType -- * - * Helper function used by Tcl_FSGetPathType. + * Helper function used by FSGetPathType. * * Results: * Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or @@ -2817,7 +2840,8 @@ GetPathType(pathObjPtr, filesystemPtrPtr, driveNameLengthPtr, driveNameRef) FsReleaseIterator(); if (type != TCL_PATH_ABSOLUTE) { - type = TclpGetNativePathType(pathObjPtr, driveNameLengthPtr, driveNameRef); + type = TclpGetNativePathType(pathObjPtr, driveNameLengthPtr, + driveNameRef); if ((type == TCL_PATH_ABSOLUTE) && (filesystemPtrPtr != NULL)) { *filesystemPtrPtr = &nativeFilesystem; } @@ -2904,12 +2928,80 @@ Tcl_FSCopyFile(srcPathPtr, destPathPtr) if (retVal == -1) { Tcl_SetErrno(EXDEV); } + if ((retVal != TCL_OK) && (errno == EXDEV)) { + retVal = CrossFilesystemCopy(srcPathPtr, destPathPtr); + } return retVal; } /* *--------------------------------------------------------------------------- * + * CrossFilesystemCopy -- + * + * Helper for above function, and for Tcl_FSLoadFile, to copy + * files from one filesystem to another. This function will + * overwrite the target file if it already exists. + * + * Results: + * Standard Tcl error code. + * + * Side effects: + * A file may be created. + * + *--------------------------------------------------------------------------- + */ +static int +CrossFilesystemCopy(source, target) + Tcl_Obj *source; /* Pathname of file to be copied (UTF-8). */ + Tcl_Obj *target; /* Pathname of file to copy to (UTF-8). */ +{ + int result = TCL_ERROR; + int prot = 0666; + + Tcl_Channel out = Tcl_FSOpenFileChannel(NULL, target, "w", prot); + if (out != NULL) { + /* It looks like we can copy it over */ + Tcl_Channel in = Tcl_FSOpenFileChannel(NULL, source, + "r", prot); + if (in == NULL) { + /* This is very strange, we checked this above */ + Tcl_Close(NULL, out); + } else { + struct stat sourceStatBuf; + struct utimbuf tval; + /* + * Copy it synchronously. We might wish to add an + * asynchronous option to support vfs's which are + * slow (e.g. network sockets). + */ + Tcl_SetChannelOption(NULL, in, "-translation", "binary"); + Tcl_SetChannelOption(NULL, out, "-translation", "binary"); + + if (TclCopyChannel(NULL, in, out, -1, NULL) == TCL_OK) { + result = TCL_OK; + } + /* + * If the copy failed, assume that copy channel left + * a good error message. + */ + Tcl_Close(NULL, in); + Tcl_Close(NULL, out); + + /* Set modification date of copied file */ + if (Tcl_FSLstat(source, &sourceStatBuf) != 0) { + tval.actime = sourceStatBuf.st_atime; + tval.modtime = sourceStatBuf.st_mtime; + Tcl_FSUtime(source, &tval); + } + } + } + return result; +} + +/* + *--------------------------------------------------------------------------- + * * Tcl_FSDeleteFile -- * * The appropriate function for the filesystem to which pathPtr @@ -2972,7 +3064,7 @@ Tcl_FSCreateDirectory(pathPtr) /* *--------------------------------------------------------------------------- * - * Tcl_FSRenameFile -- + * Tcl_FSCopyDirectory -- * * If the two paths given belong to the same filesystem, we call * that filesystems copy-directory function. Otherwise we simply @@ -3045,6 +3137,33 @@ Tcl_FSRemoveDirectory(pathPtr, recursive, errorPtr) if (fsPtr != NULL) { Tcl_FSRemoveDirectoryProc *proc = fsPtr->removeDirectoryProc; if (proc != NULL) { + if (recursive) { + /* + * We check whether the cwd lies inside this directory + * and move it if it does. + */ + Tcl_Obj *cwdPtr = Tcl_FSGetCwd(NULL); + if (cwdPtr != NULL) { + char *cwdStr, *normPathStr; + int cwdLen, normLen; + Tcl_Obj *normPath = Tcl_FSGetNormalizedPath(NULL, pathPtr); + if (normPath != NULL) { + normPathStr = Tcl_GetStringFromObj(normPath, &normLen); + cwdStr = Tcl_GetStringFromObj(cwdPtr, &cwdLen); + if ((cwdLen >= normLen) && (strncmp(normPathStr, + cwdStr, (size_t) normLen) == 0)) { + /* + * the cwd is inside the directory, so we + * perform a 'cd [file dirname $path]' + */ + Tcl_Obj *dirPtr = TclFileDirname(NULL, pathPtr); + Tcl_FSChdir(dirPtr); + Tcl_DecrRefCount(dirPtr); + } + } + Tcl_DecrRefCount(cwdPtr); + } + } return (*proc)(pathPtr, recursive, errorPtr); } } @@ -3449,7 +3568,11 @@ FreeFsPathInternalRep(pathObjPtr) } } if (fsPathPtr->fsRecPtr != NULL) { - fsPathPtr->fsRecPtr->refCount--; + fsPathPtr->fsRecPtr->fileRefCount--; + if (fsPathPtr->fsRecPtr->fileRefCount <= 0) { + /* It has been unregistered already */ + ckfree((char *)fsPathPtr->fsRecPtr); + } } ckfree((char*) fsPathPtr); @@ -3506,7 +3629,7 @@ DupFsPathInternalRep(srcPtr, copyPtr) copyFsPathPtr->fsRecPtr = srcFsPathPtr->fsRecPtr; copyFsPathPtr->filesystemEpoch = srcFsPathPtr->filesystemEpoch; if (copyFsPathPtr->fsRecPtr != NULL) { - copyFsPathPtr->fsRecPtr->refCount++; + copyFsPathPtr->fsRecPtr->fileRefCount++; } copyPtr->typePtr = &tclFsPathType; @@ -3633,7 +3756,7 @@ Tcl_FSGetNormalizedPath(interp, pathObjPtr) * action, which might loop back through here. */ if ((path[0] != '\0') && - (Tcl_FSGetPathType(pathObjPtr, NULL, NULL) == TCL_PATH_RELATIVE)) { + (Tcl_FSGetPathType(pathObjPtr) == TCL_PATH_RELATIVE)) { Tcl_Obj *cwd = Tcl_FSGetCwd(interp); if (cwd == NULL) { @@ -3749,6 +3872,17 @@ Tcl_FSGetInternalRep(pathObjPtr, fsPtr) } if (fsPtr != srcFsPathPtr->fsRecPtr->fsPtr) { + /* + * There is still one possibility we should consider; if the + * file belongs to a different filesystem, perhaps it is + * actually linked through to a file in our own filesystem + * which we do care about. The way we can check for this + * is we ask what filesystem this path belongs to. + */ + Tcl_Filesystem *actualFs = Tcl_FSGetFileSystemForPath(pathObjPtr); + if (actualFs == fsPtr) { + return Tcl_FSGetInternalRep(pathObjPtr, fsPtr); + } return NULL; } @@ -4129,7 +4263,7 @@ NativeFilesystemPathType(pathObjPtr) * as a valid file path, then NULL is returned. * * Results: - * NULL or a filesystem which will accept this path. +.* NULL or a filesystem which will accept this path. * * Side effects: * The object may be converted to a path type. @@ -4137,7 +4271,7 @@ NativeFilesystemPathType(pathObjPtr) *--------------------------------------------------------------------------- */ -static Tcl_Filesystem* +Tcl_Filesystem* Tcl_FSGetFileSystemForPath(pathObjPtr) Tcl_Obj* pathObjPtr; { @@ -4213,7 +4347,7 @@ Tcl_FSGetFileSystemForPath(pathObjPtr) srcFsPathPtr->fsRecPtr = fsRecPtr; srcFsPathPtr->nativePathPtr = clientData; srcFsPathPtr->filesystemEpoch = filesystemEpoch; - fsRecPtr->refCount++; + fsRecPtr->fileRefCount++; retVal = fsRecPtr->fsPtr; } } diff --git a/generic/tclInt.h b/generic/tclInt.h index fce4832..f14e415 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclInt.h,v 1.62 2001/09/01 00:51:31 hobbs Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.63 2001/09/04 18:06:34 vincentdarley Exp $ */ #ifndef _TCLINT @@ -1804,7 +1804,8 @@ EXTERN int TclpLoadFile _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *pathPtr, char *sym1, char *sym2, Tcl_PackageInitProc **proc1Ptr, Tcl_PackageInitProc **proc2Ptr, - ClientData *clientDataPtr)); + ClientData *clientDataPtr, + Tcl_FSUnloadFileProc **unloadProcPtr)); EXTERN Tcl_Obj* TclpObjListVolumes _ANSI_ARGS_((void)); EXTERN void TclpMasterLock _ANSI_ARGS_((void)); EXTERN void TclpMasterUnlock _ANSI_ARGS_((void)); @@ -1814,8 +1815,6 @@ EXTERN int TclpMatchFiles _ANSI_ARGS_((Tcl_Interp *interp, EXTERN int TclpObjNormalizePath _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *pathPtr, int nextCheckpoint)); EXTERN int TclpObjCreateDirectory _ANSI_ARGS_((Tcl_Obj *pathPtr)); -EXTERN Tcl_PathType Tcl_FSGetPathType _ANSI_ARGS_((Tcl_Obj *pathObjPtr, - Tcl_Filesystem **fsPtrPtr, int *driveNameLengthPtr)); EXTERN void TclpNativeJoinPath _ANSI_ARGS_((Tcl_Obj *prefix, char *joining)); EXTERN Tcl_Obj* TclpNativeSplitPath _ANSI_ARGS_((Tcl_Obj *pathPtr, @@ -1831,10 +1830,14 @@ EXTERN int TclpObjRemoveDirectory _ANSI_ARGS_((Tcl_Obj *pathPtr, int recursive, Tcl_Obj **errorPtr)); EXTERN int TclpObjRenameFile _ANSI_ARGS_((Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr)); -EXTERN int TclpMatchInDirectory _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *resultPtr, Tcl_Obj *pathPtr, char *pattern, Tcl_GlobTypeData *types)); +EXTERN int TclpMatchInDirectory _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *resultPtr, Tcl_Obj *pathPtr, + char *pattern, Tcl_GlobTypeData *types)); EXTERN Tcl_Obj* TclpObjGetCwd _ANSI_ARGS_((Tcl_Interp *interp)); EXTERN Tcl_Obj* TclpObjLink _ANSI_ARGS_((Tcl_Obj *pathPtr, Tcl_Obj *toPtr)); EXTERN int TclpObjChdir _ANSI_ARGS_((Tcl_Obj *pathPtr)); +EXTERN Tcl_Obj* TclFileDirname _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj*pathPtr)); EXTERN int TclpObjStat _ANSI_ARGS_((Tcl_Obj *pathPtr, struct stat *buf)); EXTERN Tcl_Channel TclpOpenFileChannel _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *pathPtr, char *modeString, diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 932a61b..ab2d80b 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclStubInit.c,v 1.56 2001/08/30 08:53:15 vincentdarley Exp $ + * RCS: @(#) $Id: tclStubInit.c,v 1.57 2001/09/04 18:06:34 vincentdarley Exp $ */ #include "tclInt.h" @@ -873,6 +873,8 @@ TclStubs tclStubs = { Tcl_FSUnregister, /* 474 */ Tcl_FSData, /* 475 */ Tcl_FSGetTranslatedStringPath, /* 476 */ + Tcl_FSGetFileSystemForPath, /* 477 */ + Tcl_FSGetPathType, /* 478 */ }; /* !END!: Do not edit above this line. */ diff --git a/generic/tclTest.c b/generic/tclTest.c index f88412a..af93ff6 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -13,7 +13,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclTest.c,v 1.28 2001/08/30 08:53:15 vincentdarley Exp $ + * RCS: @(#) $Id: tclTest.c,v 1.29 2001/09/04 18:06:34 vincentdarley Exp $ */ #define TCL_TEST @@ -319,7 +319,6 @@ static Tcl_FSStatProc TestReportStat; static Tcl_FSAccessProc TestReportAccess; static Tcl_FSOpenFileChannelProc TestReportOpenFileChannel; static Tcl_FSMatchInDirectoryProc TestReportMatchInDirectory; -static Tcl_FSGetCwdProc TestReportGetCwd; static Tcl_FSChdirProc TestReportChdir; static Tcl_FSLstatProc TestReportLstat; static Tcl_FSCopyFileProc TestReportCopyFile; @@ -331,20 +330,22 @@ static Tcl_FSRemoveDirectoryProc TestReportRemoveDirectory; static Tcl_FSLoadFileProc TestReportLoadFile; static Tcl_FSUnloadFileProc TestReportUnloadFile; static Tcl_FSLinkProc TestReportLink; -static Tcl_FSListVolumesProc TestReportListVolumes; static Tcl_FSFileAttrStringsProc TestReportFileAttrStrings; static Tcl_FSFileAttrsGetProc TestReportFileAttrsGet; static Tcl_FSFileAttrsSetProc TestReportFileAttrsSet; static Tcl_FSUtimeProc TestReportUtime; static Tcl_FSNormalizePathProc TestReportNormalizePath; +static Tcl_FSPathInFilesystemProc TestReportInFilesystem; +static Tcl_FSFreeInternalRepProc TestReportFreeInternalRep; +static Tcl_FSDupInternalRepProc TestReportDupInternalRep; static Tcl_Filesystem testReportingFilesystem = { "reporting", sizeof(Tcl_Filesystem), TCL_FILESYSTEM_VERSION_1, - NULL, /* path in */ - NULL, /* native dup */ - NULL, /* native free */ + &TestReportInFilesystem, /* path in */ + &TestReportDupInternalRep, + &TestReportFreeInternalRep, NULL, /* native to norm */ NULL, /* convert to native */ &TestReportNormalizePath, @@ -356,7 +357,7 @@ static Tcl_Filesystem testReportingFilesystem = { &TestReportMatchInDirectory, &TestReportUtime, &TestReportLink, - &TestReportListVolumes, + NULL /* list volumes */, &TestReportFileAttrStrings, &TestReportFileAttrsGet, &TestReportFileAttrsSet, @@ -368,8 +369,7 @@ static Tcl_Filesystem testReportingFilesystem = { &TestReportRenameFile, &TestReportCopyDirectory, &TestReportLoadFile, - &TestReportUnloadFile, - &TestReportGetCwd, + NULL /* cwd */, &TestReportChdir }; @@ -5257,10 +5257,62 @@ TestFilesystemObjCmd(dummy, interp, objc, objv) return res; } +static int +TestReportInFilesystem(Tcl_Obj *pathPtr, ClientData *clientDataPtr) { + static Tcl_Obj* lastPathPtr = NULL; + + if (pathPtr == lastPathPtr) { + /* Reject all files second time around */ + return -1; + } else { + Tcl_Obj * newPathPtr; + /* Try to claim all files first time around */ + + newPathPtr = Tcl_DuplicateObj(pathPtr); + lastPathPtr = newPathPtr; + Tcl_IncrRefCount(newPathPtr); + if (Tcl_FSGetFileSystemForPath(newPathPtr) == NULL) { + /* Nothing claimed it. Therefore we don't either */ + Tcl_DecrRefCount(newPathPtr); + lastPathPtr = NULL; + return -1; + } else { + lastPathPtr = NULL; + *clientDataPtr = (ClientData) newPathPtr; + return TCL_OK; + } + } +} + +/* + * Simple helper function to extract the native vfs representation of a + * path object, or NULL if no such representation exists. + */ +Tcl_Obj* +TestReportGetNativePath(Tcl_Obj* pathObjPtr) { + return (Tcl_Obj*) Tcl_FSGetInternalRep(pathObjPtr, &testReportingFilesystem); +} + +void +TestReportFreeInternalRep(ClientData clientData) { + Tcl_Obj *nativeRep = (Tcl_Obj*)clientData; + if (nativeRep != NULL) { + /* Free the path */ + Tcl_DecrRefCount(nativeRep); + } +} + +ClientData +TestReportDupInternalRep(ClientData clientData) { + Tcl_Obj *original = (Tcl_Obj*)clientData; + Tcl_IncrRefCount(original); + return clientData; +} + static void -TestReport(cmd, arg1, arg2) +TestReport(cmd, path, arg2) CONST char* cmd; - Tcl_Obj* arg1; + Tcl_Obj* path; Tcl_Obj* arg2; { Tcl_Interp* interp = (Tcl_Interp*) Tcl_FSData(&testReportingFilesystem); @@ -5273,8 +5325,8 @@ TestReport(cmd, arg1, arg2) Tcl_DStringAppend(&ds, "puts stderr ",-1); Tcl_DStringStartSublist(&ds); Tcl_DStringAppendElement(&ds, cmd); - if (arg1 != NULL) { - Tcl_DStringAppendElement(&ds, Tcl_GetString(arg1)); + if (path != NULL) { + Tcl_DStringAppendElement(&ds, Tcl_GetString(path)); } if (arg2 != NULL) { Tcl_DStringAppendElement(&ds, Tcl_GetString(arg2)); @@ -5292,7 +5344,7 @@ TestReportStat(path, buf) struct stat *buf; /* Filled with results of stat call. */ { TestReport("stat",path, NULL); - return -1; + return Tcl_FSStat(TestReportGetNativePath(path),buf); } static int TestReportLstat(path, buf) @@ -5300,7 +5352,7 @@ TestReportLstat(path, buf) struct stat *buf; /* Filled with results of stat call. */ { TestReport("lstat",path, NULL); - return -1; + return Tcl_FSLstat(TestReportGetNativePath(path),buf); } static int TestReportAccess(path, mode) @@ -5308,7 +5360,7 @@ TestReportAccess(path, mode) int mode; /* Permission setting. */ { TestReport("access",path,NULL); - return -1; + return Tcl_FSAccess(TestReportGetNativePath(path),mode); } static Tcl_Channel TestReportOpenFileChannel(interp, fileName, modeString, permissions) @@ -5322,7 +5374,8 @@ TestReportOpenFileChannel(interp, fileName, modeString, permissions) * it? */ { TestReport("open",fileName, NULL); - return NULL; + return Tcl_FSOpenFileChannel(interp, TestReportGetNativePath(fileName), + modeString, permissions); } static int @@ -5335,24 +5388,20 @@ TestReportMatchInDirectory(interp, resultPtr, dirPtr, pattern, types) * May be NULL. */ { TestReport("matchindirectory",dirPtr, NULL); - return -1; -} -static Tcl_Obj * -TestReportGetCwd(interp) - Tcl_Interp *interp; -{ - TestReport("cwd",NULL,NULL); - return NULL; + return Tcl_FSMatchInDirectory(interp, resultPtr, + TestReportGetNativePath(dirPtr), pattern, + types); } static int TestReportChdir(dirName) Tcl_Obj *dirName; { TestReport("chdir",dirName,NULL); - return -1; + return Tcl_FSChdir(TestReportGetNativePath(dirName)); } static int -TestReportLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr, clientDataPtr) +TestReportLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr, + clientDataPtr, unloadProcPtr) Tcl_Interp *interp; /* Used for error reporting. */ Tcl_Obj *fileName; /* Name of the file containing the desired * code. */ @@ -5363,10 +5412,15 @@ TestReportLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr, clientDataP * to sym1 and sym2. */ ClientData *clientDataPtr; /* Filled with token for dynamically loaded * file which will be passed back to - * TclpUnloadFile() to unload the file. */ + * (*unloadProcPtr)() to unload the file. */ + Tcl_FSUnloadFileProc **unloadProcPtr; + /* Filled with address of Tcl_FSUnloadFileProc + * function which should be used for + * this file. */ { TestReport("loadfile",fileName,NULL); - return -1; + return Tcl_FSLoadFile(interp, TestReportGetNativePath(fileName), sym1, sym2, + proc1Ptr, proc2Ptr, clientDataPtr, unloadProcPtr); } static void TestReportUnloadFile(clientData) @@ -5383,13 +5437,7 @@ TestReportLink(path, to) Tcl_Obj *to; /* Path of file to link to, or NULL */ { TestReport("link",path,NULL); - return NULL; -} -static Tcl_Obj * -TestReportListVolumes() -{ - TestReport("listvolumes",NULL,NULL); - return NULL; + return Tcl_FSLink(TestReportGetNativePath(path),NULL); } static int TestReportRenameFile(src, dst) @@ -5399,7 +5447,8 @@ TestReportRenameFile(src, dst) * (UTF-8). */ { TestReport("renamefile",src,dst); - return -1; + return Tcl_FSRenameFile(TestReportGetNativePath(src), + TestReportGetNativePath(dst)); } static int TestReportCopyFile(src, dst) @@ -5407,33 +5456,34 @@ TestReportCopyFile(src, dst) Tcl_Obj *dst; /* Pathname of file to copy to (UTF-8). */ { TestReport("copyfile",src,dst); - return -1; + return Tcl_FSCopyFile(TestReportGetNativePath(src), + TestReportGetNativePath(dst)); } static int TestReportDeleteFile(path) Tcl_Obj *path; /* Pathname of file to be removed (UTF-8). */ { TestReport("deletefile",path,NULL); - return -1; + return Tcl_FSDeleteFile(TestReportGetNativePath(path)); } static int TestReportCreateDirectory(path) Tcl_Obj *path; /* Pathname of directory to create (UTF-8). */ { TestReport("createdirectory",path,NULL); - return -1; + return Tcl_FSCreateDirectory(TestReportGetNativePath(path)); } static int TestReportCopyDirectory(src, dst, errorPtr) Tcl_Obj *src; /* Pathname of directory to be copied * (UTF-8). */ Tcl_Obj *dst; /* Pathname of target directory (UTF-8). */ - Tcl_Obj **errorPtr; /* If non-NULL, uninitialized or free - * DString filled with UTF-8 name of file - * causing error. */ + Tcl_Obj **errorPtr; /* If non-NULL, to be filled with UTF-8 name + * of file causing error. */ { TestReport("copydirectory",src,dst); - return -1; + return Tcl_FSCopyDirectory(TestReportGetNativePath(src), + TestReportGetNativePath(dst), errorPtr); } static int TestReportRemoveDirectory(path, recursive, errorPtr) @@ -5442,12 +5492,12 @@ TestReportRemoveDirectory(path, recursive, errorPtr) int recursive; /* If non-zero, removes directories that * are nonempty. Otherwise, will only remove * empty directories. */ - Tcl_Obj **errorPtr; /* If non-NULL, uninitialized or free - * DString filled with UTF-8 name of file - * causing error. */ + Tcl_Obj **errorPtr; /* If non-NULL, to be filled with UTF-8 name + * of file causing error. */ { TestReport("removedirectory",path,NULL); - return -1; + return Tcl_FSRemoveDirectory(TestReportGetNativePath(path), recursive, + errorPtr); } static char** TestReportFileAttrStrings(fileName, objPtrRef) @@ -5455,7 +5505,7 @@ TestReportFileAttrStrings(fileName, objPtrRef) Tcl_Obj** objPtrRef; { TestReport("fileattributestrings",fileName,NULL); - return NULL; + return Tcl_FSFileAttrStrings(TestReportGetNativePath(fileName), objPtrRef); } static int TestReportFileAttrsGet(interp, index, fileName, objPtrRef) @@ -5465,7 +5515,8 @@ TestReportFileAttrsGet(interp, index, fileName, objPtrRef) Tcl_Obj **objPtrRef; /* for output. */ { TestReport("fileattributesget",fileName,NULL); - return -1; + return Tcl_FSFileAttrsGet(interp, index, + TestReportGetNativePath(fileName), objPtrRef); } static int TestReportFileAttrsSet(interp, index, fileName, objPtr) @@ -5475,7 +5526,8 @@ TestReportFileAttrsSet(interp, index, fileName, objPtr) Tcl_Obj *objPtr; /* for input. */ { TestReport("fileattributesset",fileName,objPtr); - return -1; + return Tcl_FSFileAttrsSet(interp, index, + TestReportGetNativePath(fileName), objPtr); } static int TestReportUtime (fileName, tval) @@ -5483,7 +5535,7 @@ TestReportUtime (fileName, tval) struct utimbuf *tval; { TestReport("utime",fileName,NULL); - return -1; + return Tcl_FSUtime(TestReportGetNativePath(fileName), tval); } static int TestReportNormalizePath(interp, pathPtr, nextCheckpoint) |