? tests/efile ? tests/outdata ? win/b ? win/config.cache ? win/config.log ? win/config.status Index: generic/tcl.decls =================================================================== RCS file: /cvsroot/tcl/generic/tcl.decls,v retrieving revision 1.42 diff -c -r1.42 tcl.decls *** tcl.decls 2000/11/03 18:46:10 1.42 --- tcl.decls 2000/11/21 17:07:25 *************** *** 594,600 **** } declare 168 generic { ! Tcl_PathType Tcl_GetPathType(char *path) } declare 169 generic { int Tcl_Gets(Tcl_Channel chan, Tcl_DString *dsPtr) --- 594,600 ---- } declare 168 generic { ! Tcl_PathType Tcl_GetPathType(CONST char *path) } declare 169 generic { int Tcl_Gets(Tcl_Channel chan, Tcl_DString *dsPtr) *************** *** 649,655 **** int Tcl_IsSafe(Tcl_Interp *interp) } declare 186 generic { ! char * Tcl_JoinPath(int argc, char **argv, Tcl_DString *resultPtr) } declare 187 generic { int Tcl_LinkVar(Tcl_Interp *interp, char *varName, char *addr, int type) --- 649,655 ---- int Tcl_IsSafe(Tcl_Interp *interp) } declare 186 generic { ! char * Tcl_JoinPath(int argc, CONST char **argv, Tcl_DString *resultPtr) } declare 187 generic { int Tcl_LinkVar(Tcl_Interp *interp, char *varName, char *addr, int type) Index: generic/tclCmdAH.c =================================================================== RCS file: /cvsroot/tcl/generic/tclCmdAH.c,v retrieving revision 1.12 diff -c -r1.12 tclCmdAH.c *** tclCmdAH.c 2000/01/21 02:25:26 1.12 --- tclCmdAH.c 2000/11/21 17:07:25 *************** *** 795,801 **** "delete", "dirname", "executable", "exists", "extension", "isdirectory", "isfile", "join", "lstat", ! "mtime", "mkdir", "nativename", "owned", "pathtype", "readable", "readlink", "rename", "rootname", "size", "split", "stat", "tail", "type", "volumes", "writable", --- 795,802 ---- "delete", "dirname", "executable", "exists", "extension", "isdirectory", "isfile", "join", "lstat", ! "mtime", "mkdir", "nativename", ! "normalize", "owned", "pathtype", "readable", "readlink", "rename", "rootname", "size", "split", "stat", "tail", "type", "volumes", "writable", *************** *** 806,812 **** FILE_DELETE, FILE_DIRNAME, FILE_EXECUTABLE, FILE_EXISTS, FILE_EXTENSION, FILE_ISDIRECTORY, FILE_ISFILE, FILE_JOIN, FILE_LSTAT, ! FILE_MTIME, FILE_MKDIR, FILE_NATIVENAME, FILE_OWNED, FILE_PATHTYPE, FILE_READABLE, FILE_READLINK, FILE_RENAME, FILE_ROOTNAME, FILE_SIZE, FILE_SPLIT, FILE_STAT, FILE_TAIL, FILE_TYPE, FILE_VOLUMES, FILE_WRITABLE --- 807,814 ---- FILE_DELETE, FILE_DIRNAME, FILE_EXECUTABLE, FILE_EXISTS, FILE_EXTENSION, FILE_ISDIRECTORY, FILE_ISFILE, FILE_JOIN, FILE_LSTAT, ! FILE_MTIME, FILE_MKDIR, FILE_NATIVENAME, ! FILE_NORMALIZE, FILE_OWNED, FILE_PATHTYPE, FILE_READABLE, FILE_READLINK, FILE_RENAME, FILE_ROOTNAME, FILE_SIZE, FILE_SPLIT, FILE_STAT, FILE_TAIL, FILE_TYPE, FILE_VOLUMES, FILE_WRITABLE *************** *** 843,849 **** tval.actime = buf.st_atime; tval.modtime = buf.st_mtime; fileName = Tcl_GetString(objv[2]); ! if (utime(fileName, &tval) != 0) { Tcl_AppendStringsToObj(resultPtr, "could not set access time for file \"", fileName, "\": ", --- 845,851 ---- tval.actime = buf.st_atime; tval.modtime = buf.st_mtime; fileName = Tcl_GetString(objv[2]); ! if (TclUtime(fileName, &tval) != 0) { Tcl_AppendStringsToObj(resultPtr, "could not set access time for file \"", fileName, "\": ", *************** *** 1004,1010 **** Tcl_WrongNumArgs(interp, 2, objv, "name varName"); return TCL_ERROR; } ! if (GetStatBuf(interp, objv[2], TclpLstat, &buf) != TCL_OK) { return TCL_ERROR; } varName = Tcl_GetString(objv[3]); --- 1006,1012 ---- Tcl_WrongNumArgs(interp, 2, objv, "name varName"); return TCL_ERROR; } ! if (GetStatBuf(interp, objv[2], TclLstat, &buf) != TCL_OK) { return TCL_ERROR; } varName = Tcl_GetString(objv[3]); *************** *** 1030,1036 **** tval.actime = buf.st_atime; tval.modtime = buf.st_mtime; fileName = Tcl_GetString(objv[2]); ! if (utime(fileName, &tval) != 0) { Tcl_AppendStringsToObj(resultPtr, "could not set modification time for file \"", fileName, "\": ", --- 1032,1038 ---- tval.actime = buf.st_atime; tval.modtime = buf.st_mtime; fileName = Tcl_GetString(objv[2]); ! if (TclUtime(fileName, &tval) != 0) { Tcl_AppendStringsToObj(resultPtr, "could not set modification time for file \"", fileName, "\": ", *************** *** 1079,1084 **** --- 1081,1102 ---- Tcl_DStringFree(&ds); return TCL_OK; } + case FILE_NORMALIZE: { + Tcl_DString path; + char *fileName; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "filename"); + return TCL_ERROR; + } + + fileName = Tcl_GetStringFromObj(objv[2], (int *) NULL); + TclNormalizePath(interp, fileName, &path); + + Tcl_DStringResult(interp, &path); + Tcl_DStringFree(&path); + return TCL_OK; + } case FILE_OWNED: { int value; struct stat buf; *************** *** 1141,1161 **** if (fileName == NULL) { return TCL_ERROR; } - - /* - * If S_IFLNK isn't defined it means that the machine doesn't - * support symbolic links, so the file can't possibly be a - * symbolic link. Generate an EINVAL error, which is what - * happens on machines that do support symbolic links when - * you invoke readlink on a file that isn't a symbolic link. - */ ! #ifndef S_IFLNK ! contents = NULL; ! errno = EINVAL; ! #else ! contents = TclpReadlink(fileName, &link); ! #endif /* S_IFLNK */ Tcl_DStringFree(&name); if (contents == NULL) { --- 1159,1166 ---- if (fileName == NULL) { return TCL_ERROR; } ! contents = TclReadlink(fileName, &link); Tcl_DStringFree(&name); if (contents == NULL) { *************** *** 1268,1274 **** if (objc != 3) { goto only3Args; } ! if (GetStatBuf(interp, objv[2], TclpLstat, &buf) != TCL_OK) { return TCL_ERROR; } Tcl_SetStringObj(resultPtr, --- 1273,1279 ---- if (objc != 3) { goto only3Args; } ! if (GetStatBuf(interp, objv[2], TclLstat, &buf) != TCL_OK) { return TCL_ERROR; } Tcl_SetStringObj(resultPtr, *************** *** 1280,1286 **** Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; } ! return TclpListVolumes(interp); } case FILE_WRITABLE: { if (objc != 3) { --- 1285,1291 ---- Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; } ! return TclListVolumes(interp); } case FILE_WRITABLE: { if (objc != 3) { Index: generic/tclDecls.h =================================================================== RCS file: /cvsroot/tcl/generic/tclDecls.h,v retrieving revision 1.43 diff -c -r1.43 tclDecls.h *** tclDecls.h 2000/11/03 18:46:11 1.43 --- tclDecls.h 2000/11/21 17:07:26 *************** *** 545,551 **** ClientData * filePtr)); #endif /* UNIX */ /* 168 */ ! EXTERN Tcl_PathType Tcl_GetPathType _ANSI_ARGS_((char * path)); /* 169 */ EXTERN int Tcl_Gets _ANSI_ARGS_((Tcl_Channel chan, Tcl_DString * dsPtr)); --- 545,551 ---- ClientData * filePtr)); #endif /* UNIX */ /* 168 */ ! EXTERN Tcl_PathType Tcl_GetPathType _ANSI_ARGS_((CONST char * path)); /* 169 */ EXTERN int Tcl_Gets _ANSI_ARGS_((Tcl_Channel chan, Tcl_DString * dsPtr)); *************** *** 590,597 **** /* 185 */ EXTERN int Tcl_IsSafe _ANSI_ARGS_((Tcl_Interp * interp)); /* 186 */ ! EXTERN char * Tcl_JoinPath _ANSI_ARGS_((int argc, char ** argv, ! Tcl_DString * resultPtr)); /* 187 */ EXTERN int Tcl_LinkVar _ANSI_ARGS_((Tcl_Interp * interp, char * varName, char * addr, int type)); --- 590,597 ---- /* 185 */ EXTERN int Tcl_IsSafe _ANSI_ARGS_((Tcl_Interp * interp)); /* 186 */ ! EXTERN char * Tcl_JoinPath _ANSI_ARGS_((int argc, ! CONST char ** argv, Tcl_DString * resultPtr)); /* 187 */ EXTERN int Tcl_LinkVar _ANSI_ARGS_((Tcl_Interp * interp, char * varName, char * addr, int type)); *************** *** 1561,1567 **** #ifdef MAC_TCL void *reserved167; #endif /* MAC_TCL */ ! Tcl_PathType (*tcl_GetPathType) _ANSI_ARGS_((char * path)); /* 168 */ int (*tcl_Gets) _ANSI_ARGS_((Tcl_Channel chan, Tcl_DString * dsPtr)); /* 169 */ int (*tcl_GetsObj) _ANSI_ARGS_((Tcl_Channel chan, Tcl_Obj * objPtr)); /* 170 */ int (*tcl_GetServiceMode) _ANSI_ARGS_((void)); /* 171 */ --- 1561,1567 ---- #ifdef MAC_TCL void *reserved167; #endif /* MAC_TCL */ ! Tcl_PathType (*tcl_GetPathType) _ANSI_ARGS_((CONST char * path)); /* 168 */ int (*tcl_Gets) _ANSI_ARGS_((Tcl_Channel chan, Tcl_DString * dsPtr)); /* 169 */ int (*tcl_GetsObj) _ANSI_ARGS_((Tcl_Channel chan, Tcl_Obj * objPtr)); /* 170 */ int (*tcl_GetServiceMode) _ANSI_ARGS_((void)); /* 171 */ *************** *** 1579,1585 **** int (*tcl_InputBuffered) _ANSI_ARGS_((Tcl_Channel chan)); /* 183 */ int (*tcl_InterpDeleted) _ANSI_ARGS_((Tcl_Interp * interp)); /* 184 */ int (*tcl_IsSafe) _ANSI_ARGS_((Tcl_Interp * interp)); /* 185 */ ! char * (*tcl_JoinPath) _ANSI_ARGS_((int argc, char ** argv, Tcl_DString * resultPtr)); /* 186 */ int (*tcl_LinkVar) _ANSI_ARGS_((Tcl_Interp * interp, char * varName, char * addr, int type)); /* 187 */ void *reserved188; Tcl_Channel (*tcl_MakeFileChannel) _ANSI_ARGS_((ClientData handle, int mode)); /* 189 */ --- 1579,1585 ---- int (*tcl_InputBuffered) _ANSI_ARGS_((Tcl_Channel chan)); /* 183 */ int (*tcl_InterpDeleted) _ANSI_ARGS_((Tcl_Interp * interp)); /* 184 */ int (*tcl_IsSafe) _ANSI_ARGS_((Tcl_Interp * interp)); /* 185 */ ! char * (*tcl_JoinPath) _ANSI_ARGS_((int argc, CONST char ** argv, Tcl_DString * resultPtr)); /* 186 */ int (*tcl_LinkVar) _ANSI_ARGS_((Tcl_Interp * interp, char * varName, char * addr, int type)); /* 187 */ void *reserved188; Tcl_Channel (*tcl_MakeFileChannel) _ANSI_ARGS_((ClientData handle, int mode)); /* 189 */ Index: generic/tclEncoding.c =================================================================== RCS file: /cvsroot/tcl/generic/tclEncoding.c,v retrieving revision 1.5 diff -c -r1.5 tclEncoding.c *** tclEncoding.c 2000/01/21 02:25:26 1.5 --- tclEncoding.c 2000/11/21 17:07:26 *************** *** 563,582 **** if (pathPtr != NULL) { int i, objc; Tcl_Obj **objv; - Tcl_DString pwdString; char globArgString[10]; ! objc = 0; Tcl_ListObjGetElements(NULL, pathPtr, &objc, &objv); - Tcl_GetCwd(interp, &pwdString); - for (i = 0; i < objc; i++) { char *string; int j, objc2, length; Tcl_Obj **objv2; ! string = Tcl_GetStringFromObj(objv[i], NULL); Tcl_ResetResult(interp); /* --- 563,590 ---- if (pathPtr != NULL) { int i, objc; Tcl_Obj **objv; char globArgString[10]; ! char encodingStr[10] = "encoding"; ! objc = 0; Tcl_ListObjGetElements(NULL, pathPtr, &objc, &objv); for (i = 0; i < objc; i++) { char *string; int j, objc2, length; Tcl_Obj **objv2; ! Tcl_DString ds; ! char * pathToJoin[2]; ! ! /* ! * Construct the path from the element of pathPtr, ! * joined with 'encoding'. ! */ string = Tcl_GetStringFromObj(objv[i], NULL); + Tcl_DStringInit(&ds); + pathToJoin[0] = string; + pathToJoin[1] = encodingStr; + Tcl_JoinPath(2,pathToJoin,&ds); Tcl_ResetResult(interp); /* *************** *** 586,594 **** */ strcpy(globArgString, "*.enc"); ! if ((Tcl_Chdir(string) == 0) ! && (Tcl_Chdir("encoding") == 0) ! && (TclGlob(interp, globArgString, NULL, 0, NULL) == TCL_OK)) { objc2 = 0; Tcl_ListObjGetElements(NULL, Tcl_GetObjResult(interp), &objc2, --- 594,605 ---- */ strcpy(globArgString, "*.enc"); ! /* ! * The GLOBMODE_TAILS flag returns just the tail of each file ! * which is the encoding name with a .enc extension ! */ ! if ((TclGlob(interp, globArgString, Tcl_DStringValue(&ds), ! GLOBMODE_TAILS, NULL) == TCL_OK)) { objc2 = 0; Tcl_ListObjGetElements(NULL, Tcl_GetObjResult(interp), &objc2, *************** *** 604,612 **** } } } ! Tcl_Chdir(Tcl_DStringValue(&pwdString)); } - Tcl_DStringFree(&pwdString); } /* --- 615,622 ---- } } } ! Tcl_DStringFree(&ds); } } /* Index: generic/tclFCmd.c =================================================================== RCS file: /cvsroot/tcl/generic/tclFCmd.c,v retrieving revision 1.6 diff -c -r1.6 tclFCmd.c *** tclFCmd.c 1999/07/01 23:21:07 1.6 --- tclFCmd.c 2000/11/21 17:07:27 *************** *** 265,271 **** goto done; } } else if ((errno != ENOENT) ! || (TclpCreateDirectory(target) != TCL_OK)) { errfile = target; goto done; } --- 265,271 ---- goto done; } } else if ((errno != ENOENT) ! || (TclCreateDirectory(target) != TCL_OK)) { errfile = target; goto done; } *************** *** 350,356 **** * 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 --- 350,356 ---- * Call lstat() to get info so can delete symbolic link itself. */ ! if (TclLstat(name, &statBuf) != 0) { /* * Trying to delete a file that does not exist is not * considered an error, just a no-op *************** *** 360,366 **** 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], --- 360,366 ---- result = TCL_ERROR; } } else if (S_ISDIR(statBuf.st_mode)) { ! result = TclRemoveDirectory(name, force, &errorBuffer); if (result != TCL_OK) { if ((force == 0) && (errno == EEXIST)) { Tcl_AppendResult(interp, "error deleting \"", argv[i], *************** *** 379,385 **** } } } else { ! result = TclpDeleteFile(name); } if (result == TCL_ERROR) { --- 379,385 ---- } } } else { ! result = TclDeleteFile(name); } if (result == TCL_ERROR) { *************** *** 454,464 **** * target. */ ! if (TclpLstat(sourceName, &sourceStatBuf) != 0) { errfile = source; goto done; } ! if (TclpLstat(targetName, &targetStatBuf) != 0) { if (errno != ENOENT) { errfile = target; goto done; --- 454,464 ---- * target. */ ! if (TclLstat(sourceName, &sourceStatBuf) != 0) { errfile = source; goto done; } ! if (TclLstat(targetName, &targetStatBuf) != 0) { if (errno != ENOENT) { errfile = target; goto done; *************** *** 509,515 **** } if (copyFlag == 0) { ! result = TclpRenameFile(sourceName, targetName); if (result == TCL_OK) { goto done; } --- 509,515 ---- } if (copyFlag == 0) { ! result = TclRenameFile(sourceName, targetName); if (result == TCL_OK) { goto done; } *************** *** 533,540 **** } 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; --- 533,544 ---- } if (S_ISDIR(sourceStatBuf.st_mode)) { ! result = TclCopyDirectory(sourceName, targetName, &errorBuffer); if (result != TCL_OK) { + /* + * It could be we're trying to do a cross-filesystem copy. + * This case is currently unimplemented. + */ errfile = Tcl_DStringValue(&errorBuffer); if (strcmp(errfile, sourceName) == 0) { errfile = source; *************** *** 543,561 **** } } } 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) { --- 547,597 ---- } } } else { ! result = TclCopyFile(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. + * + * 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. */ ! int prot = 0666; ! Tcl_Channel out = Tcl_OpenFileChannel(interp, targetName, "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_OpenFileChannel(interp, sourceName, ! "r", prot); ! if (in == NULL) { ! /* This is very strange, we checked this above */ ! Tcl_Close(interp, out); ! errfile = source; ! } else { ! /* ! * Copy it synchronously. We might wish to add an ! * asynchronous option to support vfs's which are ! * slow (e.g. network sockets). ! */ ! 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); ! } ! } } } if ((copyFlag == 0) && (result == TCL_OK)) { if (S_ISDIR(sourceStatBuf.st_mode)) { ! result = TclRemoveDirectory(sourceName, 1, &errorBuffer); if (result != TCL_OK) { errfile = Tcl_DStringValue(&errorBuffer); if (strcmp(errfile, sourceName) == 0) { *************** *** 563,569 **** } } } else { ! result = TclpDeleteFile(sourceName); if (result != TCL_OK) { errfile = source; } --- 599,605 ---- } } } else { ! result = TclDeleteFile(sourceName); if (result != TCL_OK) { errfile = source; } *************** *** 784,790 **** 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; --- 820,826 ---- objPtr = Tcl_NewStringObj(tclpFileAttrStrings[index], -1); Tcl_ListObjAppendElement(interp, listPtr, objPtr); ! if (TclFileAttrsCallProc(interp, 1, index, fileName, &objPtr) != TCL_OK) { Tcl_DecrRefCount(listPtr); goto end; *************** *** 804,810 **** "option", 0, &index) != TCL_OK) { goto end; } ! if ((*tclpFileAttrProcs[index].getProc)(interp, index, fileName, &objPtr) != TCL_OK) { goto end; } --- 840,846 ---- "option", 0, &index) != TCL_OK) { goto end; } ! if (TclFileAttrsCallProc(interp, 1, index, fileName, &objPtr) != TCL_OK) { goto end; } *************** *** 827,834 **** (char *) NULL); goto end; } ! if ((*tclpFileAttrProcs[index].setProc)(interp, index, fileName, ! objv[i + 1]) != TCL_OK) { goto end; } } --- 863,875 ---- (char *) NULL); goto end; } ! /* ! * We shouldn't really be casting (Tcl_Obj**) here: should ! * look into how to share the same proc for both 'get' and ! * 'set' attributes methods without requiring a cast. ! */ ! if (TclFileAttrsCallProc(interp, 0, index, fileName, ! (Tcl_Obj**)&objv[i + 1]) != TCL_OK) { goto end; } } Index: generic/tclFileName.c =================================================================== RCS file: /cvsroot/tcl/generic/tclFileName.c,v retrieving revision 1.13 diff -c -r1.13 tclFileName.c *** tclFileName.c 2000/04/19 23:24:52 1.13 --- tclFileName.c 2000/11/21 17:07:27 *************** *** 53,67 **** TclPlatformType tclPlatform = TCL_PLATFORM_UNIX; /* - * The "globParameters" argument of the globbing functions is an - * or'ed combination of the following values: - */ - - #define GLOBMODE_NO_COMPLAIN 1 - #define GLOBMODE_JOIN 2 - #define GLOBMODE_DIR 4 - - /* * Prototypes for local procedures defined in this file: */ --- 53,58 ---- *************** *** 256,262 **** Tcl_PathType Tcl_GetPathType(path) ! char *path; { ThreadSpecificData *tsdPtr; Tcl_PathType type = TCL_PATH_ABSOLUTE; --- 247,253 ---- Tcl_PathType Tcl_GetPathType(path) ! CONST char *path; { ThreadSpecificData *tsdPtr; Tcl_PathType type = TCL_PATH_ABSOLUTE; *************** *** 760,766 **** char * Tcl_JoinPath(argc, argv, resultPtr) int argc; ! char **argv; Tcl_DString *resultPtr; /* Pointer to previously initialized DString. */ { int oldLength, length, i, needsSep; --- 751,757 ---- char * Tcl_JoinPath(argc, argv, resultPtr) int argc; ! CONST char **argv; Tcl_DString *resultPtr; /* Pointer to previously initialized DString. */ { int oldLength, length, i, needsSep; *************** *** 1220,1229 **** Tcl_Obj *typePtr, *resultPtr, *look; Tcl_DString prefix, directory; static char *options[] = { ! "-directory", "-join", "-nocomplain", "-path", "-types", "--", NULL }; enum options { ! GLOB_DIR, GLOB_JOIN, GLOB_NOCOMPLAIN, GLOB_PATH, GLOB_TYPE, GLOB_LAST }; enum pathDirOptions {PATH_NONE = -1 , PATH_GENERAL = 0, PATH_DIR = 1}; GlobTypeData *globTypes = NULL; --- 1211,1222 ---- Tcl_Obj *typePtr, *resultPtr, *look; Tcl_DString prefix, directory; static char *options[] = { ! "-directory", "-join", "-nocomplain", "-path", "-types", ! "-tails", "--", NULL }; enum options { ! GLOB_DIR, GLOB_JOIN, GLOB_NOCOMPLAIN, GLOB_PATH, GLOB_TYPE, ! GLOB_TAILS, GLOB_LAST }; enum pathDirOptions {PATH_NONE = -1 , PATH_GENERAL = 0, PATH_DIR = 1}; GlobTypeData *globTypes = NULL; *************** *** 1277,1282 **** --- 1270,1278 ---- case GLOB_JOIN: /* -join */ join = 1; break; + case GLOB_TAILS: /* -tails */ + globFlags |= GLOBMODE_TAILS; + break; case GLOB_PATH: /* -path */ if (i == (objc-1)) { Tcl_AppendToObj(resultPtr, *************** *** 1626,1632 **** char *separators; char *head, *tail, *start; char c; ! int result; Tcl_DString buffer; separators = NULL; /* lint. */ --- 1622,1628 ---- char *separators; char *head, *tail, *start; char c; ! int result, prefixLen; Tcl_DString buffer; separators = NULL; /* lint. */ *************** *** 1729,1747 **** Tcl_DStringAppend(&buffer,unquotedPrefix,-1); } } ! /* ! * If the prefix is a directory, make sure it ends in a directory ! * separator. ! */ if (unquotedPrefix != NULL) { ! if (globFlags & GLOBMODE_DIR) { ! c = Tcl_DStringValue(&buffer)[Tcl_DStringLength(&buffer)-1]; ! if (strchr(separators, c) == NULL) { ! Tcl_DStringAppend(&buffer,separators,1); } } } ! result = TclDoGlob(interp, separators, &buffer, tail, types); Tcl_DStringFree(&buffer); if (result != TCL_OK) { --- 1725,1756 ---- Tcl_DStringAppend(&buffer,unquotedPrefix,-1); } } ! ! prefixLen = 0; /* lint */ ! if (unquotedPrefix != NULL) { ! if (globFlags & (GLOBMODE_DIR | GLOBMODE_TAILS)) { ! /* ! * We want to remember the length of the current prefix, ! * in case we are using GLOBMODE_TAILS ! */ ! prefixLen = Tcl_DStringLength(&buffer); ! if (prefixLen > 0) { ! c = Tcl_DStringValue(&buffer)[prefixLen-1]; ! if (strchr(separators, c) == NULL) { ! /* ! * If the prefix is a directory, make sure it ends in a ! * directory separator. ! */ ! if (globFlags & GLOBMODE_DIR) { ! Tcl_DStringAppend(&buffer,separators,1); ! } ! prefixLen++; ! } } } } ! result = TclDoGlob(interp, separators, &buffer, tail, types); Tcl_DStringFree(&buffer); if (result != TCL_OK) { *************** *** 1749,1754 **** --- 1758,1788 ---- Tcl_ResetResult(interp); return TCL_OK; } + } else { + /* + * If we only want the tails, we must strip off the prefix now. + * It may seem more efficient to pass the tails flag down into + * TclDoGlob, TclMatchFilesTypes, but those functions are + * continually adjusting the prefix as the various pieces of + * the pattern are assimilated, so that would add a lot of + * complexity to the code. This way is a little slower (when + * the -tails flag is given), but much simpler to code. + */ + if (globFlags & GLOBMODE_TAILS) { + int objc, i; + Tcl_Obj **objv; + Tcl_Obj *tailResult; + Tcl_ListObjGetElements(NULL, Tcl_GetObjResult(interp), &objc, &objv); + tailResult = Tcl_NewListObj(0,NULL); + for (i = 0; i< objc; i++) { + int len; + char *oldStr = Tcl_GetStringFromObj(objv[i],&len); + Tcl_Obj* str = Tcl_NewStringObj(oldStr + prefixLen, + len - prefixLen); + Tcl_ListObjAppendElement(interp, tailResult, str); + } + Tcl_SetObjResult(interp, tailResult); + } } return result; } *************** *** 2043,2049 **** * are more characters to be processed. */ ! return TclpMatchFilesTypes(interp, separators, headPtr, tail, p, types); } Tcl_DStringAppend(headPtr, tail, p-tail); if (*p != '\0') { --- 2077,2083 ---- * are more characters to be processed. */ ! return TclMatchFilesTypes(interp, separators, headPtr, tail, p, types); } Tcl_DStringAppend(headPtr, tail, p-tail); if (*p != '\0') { *************** *** 2062,2068 **** Tcl_DStringAppend(headPtr, ":", 1); } name = Tcl_DStringValue(headPtr); ! if (TclpAccess(name, F_OK) == 0) { if ((name[1] != '\0') && (strchr(name+1, ':') == NULL)) { Tcl_ListObjAppendElement(interp, Tcl_GetObjResult(interp), Tcl_NewStringObj(name + 1,-1)); --- 2096,2102 ---- Tcl_DStringAppend(headPtr, ":", 1); } name = Tcl_DStringValue(headPtr); ! if (TclAccess(name, F_OK) == 0) { if ((name[1] != '\0') && (strchr(name+1, ':') == NULL)) { Tcl_ListObjAppendElement(interp, Tcl_GetObjResult(interp), Tcl_NewStringObj(name + 1,-1)); *************** *** 2097,2103 **** } } name = Tcl_DStringValue(headPtr); ! exists = (TclpAccess(name, F_OK) == 0); for (p = name; *p != '\0'; p++) { if (*p == '\\') { --- 2131,2137 ---- } } name = Tcl_DStringValue(headPtr); ! exists = (TclAccess(name, F_OK) == 0); for (p = name; *p != '\0'; p++) { if (*p == '\\') { *************** *** 2119,2125 **** } } name = Tcl_DStringValue(headPtr); ! if (TclpAccess(name, F_OK) == 0) { Tcl_ListObjAppendElement(interp, Tcl_GetObjResult(interp), Tcl_NewStringObj(name,-1)); } --- 2153,2159 ---- } } name = Tcl_DStringValue(headPtr); ! if (TclAccess(name, F_OK) == 0) { Tcl_ListObjAppendElement(interp, Tcl_GetObjResult(interp), Tcl_NewStringObj(name,-1)); } Index: generic/tclIOUtil.c =================================================================== RCS file: /cvsroot/tcl/generic/tclIOUtil.c,v retrieving revision 1.11 diff -c -r1.11 tclIOUtil.c *** tclIOUtil.c 2000/05/27 23:58:01 1.11 --- tclIOUtil.c 2000/11/21 17:07:28 *************** *** 18,24 **** --- 18,34 ---- #include "tclInt.h" #include "tclPort.h" + + /* + * The 3 hooks for Stat, Access and OpenFileChannel are obsolete. + * The hooked filesystem APIs should be used instead. This + * define decides whether to include the obsolete hooks and + * related code. + */ + #define USE_OBSOLETE_FS_HOOKS + + #ifdef USE_OBSOLETE_FS_HOOKS /* * The following typedef declarations allow for hooking into the chain * of functions maintained for 'Tcl_Stat(...)', 'Tcl_Access(...)' & *************** *** 59,83 **** * All three lists are protected by a global hookMutex. */ ! static StatProc defaultStatProc = { ! &TclpStat, NULL }; - static StatProc *statProcList = &defaultStatProc; ! static AccessProc defaultAccessProc = { ! &TclpAccess, NULL }; - static AccessProc *accessProcList = &defaultAccessProc; ! static OpenFileChannelProc defaultOpenFileChannelProc = { ! &TclpOpenFileChannel, NULL ! }; ! static OpenFileChannelProc *openFileChannelProcList = ! &defaultOpenFileChannelProc; TCL_DECLARE_MUTEX(hookMutex) /* *--------------------------------------------------------------------------- * * TclGetOpenMode -- --- 69,376 ---- * All three lists are protected by a global hookMutex. */ ! static StatProc *statProcList = NULL; ! static AccessProc *accessProcList = NULL; ! static OpenFileChannelProc *openFileChannelProcList = NULL; ! ! #endif /* USE_OBSOLETE_FS_HOOKS */ ! ! /* Used to implement Tcl_GetCwd in a file-system independent way */ ! static Tcl_DString cwdPath; ! static Tcl_DString* cwdPathPtr = NULL; ! ! typedef struct Tcl_FilesystemRecord { ! ClientData clientData; /* client specific data for the new ! * filesystem. */ ! Tcl_Filesystem *fsPtr; ! struct Tcl_FilesystemRecord *nextPtr; /* The next filesystem to try */ ! } Tcl_FilesystemRecord; ! ! static Tcl_Filesystem defaultFilesystem = { ! "native", ! TCL_FILESYSTEM_VERSION_1, ! &TclpStat, ! &TclpAccess, ! &TclpOpenFileChannel, ! &TclpMatchFilesTypes, ! &TclpGetCwd, ! &TclpChdir, ! &TclpLstat, ! &TclpCopyFile, ! &TclpDeleteFile, ! &TclpRenameFile, ! &TclpCreateDirectory, ! &TclpCopyDirectory, ! &TclpRemoveDirectory, ! &TclpLoadFile, ! &TclpUnloadFile, ! #ifndef S_IFLNK ! NULL, ! #else ! &TclpReadlink, ! #endif /* S_IFLNK */ ! &TclpListVolumes, ! &TclpFileAttrsCallProc, ! &utime, }; ! static Tcl_FilesystemRecord defaultFilesystemRecord = { ! NULL, ! &defaultFilesystem, ! NULL }; ! static Tcl_FilesystemRecord *filesystemList = &defaultFilesystemRecord; TCL_DECLARE_MUTEX(hookMutex) /* + *---------------------------------------------------------------------- + * + * TclRegisterFilesystem -- + * + * Insert the filesystem function table at the head of the list of + * functions which are used during calls to all file-system + * operations. The filesystem will be added even if it is + * already in the list. (You can use TclFilesystemData to + * check if it is in the list, provided the ClientData used was + * not NULL). + * + * Note that the filesystem handling is head-to-tail of the list. + * Each filesystem is asked in turn whether it can handle a + * particular request, _until_ one of them says 'yes'. At that + * point no further filesystems are asked. + * + * In particular this means if you want to add a diagnostic + * filesystem (which simply reports all fs activity), it must be + * at the head of the list: i.e. it must be the last registered. + * + * Results: + * Normally TCL_OK; TCL_ERROR if memory for a new node in the list + * could not be allocated. + * + * Side effects: + * Memory allocataed and modifies the link list for filesystems. + * + *---------------------------------------------------------------------- + */ + + int + TclRegisterFilesystem(clientData, fsPtr) + ClientData clientData; + Tcl_Filesystem *fsPtr; /* The filesystem record for the new fs. */ + { + int retVal = TCL_ERROR; + + if (fsPtr != NULL) { + Tcl_FilesystemRecord *newFilesystemPtr; + + newFilesystemPtr = (Tcl_FilesystemRecord *)ckalloc(sizeof(Tcl_FilesystemRecord)); + + if (newFilesystemPtr != NULL) { + newFilesystemPtr->clientData = clientData; + newFilesystemPtr->fsPtr = fsPtr; + Tcl_MutexLock(&hookMutex); + newFilesystemPtr->nextPtr = filesystemList; + filesystemList = newFilesystemPtr; + Tcl_MutexUnlock(&hookMutex); + + retVal = TCL_OK; + } + } + + return (retVal); + } + + /* + *---------------------------------------------------------------------- + * + * TclUnregisterFilesystem -- + * + * Remove the passed filesystem from the list of filesystem + * function tables. It also ensures that the built-in + * (native) filesystem is not removable, although we may wish + * to change that decision in the future to allow a smaller + * Tcl core, in which the native filesystem is not used at + * all (we could, say, initialise Tcl completely over a network + * connection). + * + * Results: + * TCL_OK if the procedure pointer was successfully removed, + * TCL_ERROR otherwise. + * + * Side effects: + * Memory is deallocated and the respective list updated. + * + *---------------------------------------------------------------------- + */ + + int + TclUnregisterFilesystem(fsPtr) + Tcl_Filesystem *fsPtr; /* The filesystem record to remove. */ + { + int retVal = TCL_ERROR; + Tcl_FilesystemRecord *tmpFsRecPtr; + Tcl_FilesystemRecord *prevFsRecPtr = NULL; + + Tcl_MutexLock(&hookMutex); + tmpFsRecPtr = filesystemList; + /* + * Traverse the 'filesystemList' looking for the particular node + * whose 'fsPtr' member matches 'fsPtr' and remove that one from + * the list. Ensure that the "default" node cannot be removed. + */ + + while ((retVal == TCL_ERROR) && (tmpFsRecPtr != &defaultFilesystemRecord)) { + if (tmpFsRecPtr->fsPtr == fsPtr) { + if (prevFsRecPtr == NULL) { + filesystemList = filesystemList->nextPtr; + } else { + prevFsRecPtr->nextPtr = tmpFsRecPtr->nextPtr; + } + + Tcl_Free((char *)tmpFsRecPtr); + + retVal = TCL_OK; + } else { + prevFsRecPtr = tmpFsRecPtr; + tmpFsRecPtr = tmpFsRecPtr->nextPtr; + } + } + + Tcl_MutexUnlock(&hookMutex); + return (retVal); + } + + /* + *---------------------------------------------------------------------- + * + * TclFilesystemData -- + * + * Retrieve the clientData field for the filesystem given, + * or NULL if that filesystem is not registered. + * + * Results: + * A clientData value, or NULL. Note that if the filesystem + * was registered with a NULL clientData field, this function + * will return that NULL value. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + + ClientData + TclFilesystemData(fsPtr) + Tcl_Filesystem *fsPtr; /* The filesystem record to remove. */ + { + ClientData retVal = NULL; + Tcl_FilesystemRecord *tmpFsRecPtr; + + Tcl_MutexLock(&hookMutex); + tmpFsRecPtr = filesystemList; + /* + * Traverse the 'filesystemList' looking for the particular node + * whose 'fsPtr' member matches 'fsPtr' and remove that one from + * the list. Ensure that the "default" node cannot be removed. + */ + + while ((retVal == NULL) && (tmpFsRecPtr != NULL)) { + if (tmpFsRecPtr->fsPtr == fsPtr) { + retVal = tmpFsRecPtr->clientData; + } + tmpFsRecPtr = tmpFsRecPtr->nextPtr; + } + + Tcl_MutexUnlock(&hookMutex); + return (retVal); + } + + /* + *--------------------------------------------------------------------------- + * + * TclNormalizePath -- + * + * Description: + * Takes a path specification and computes a 'normalized' absolute + * path from it. 'retPtr' should be a free or uninitialized DString. + * + * A normalized path is one which is absolute (i.e. we prepend + * the cwd if not path is relative), and which has all '../', './' + * removed. + * + * Results: + * The result string is placed in the DString provided. It must + * be freed by the caller when no longer needed. + * + * Side effects: + * None (beyond the memory allocation for the result). + * + * Special note: + * This code is based on code from Matt Newman and Jean-Claude + * Wippler, and is copyright those respective authors. + * + *--------------------------------------------------------------------------- + */ + + char* + TclNormalizePath(interp, path, retPtr) + Tcl_Interp* interp; + CONST char *path; + Tcl_DString* retPtr; + { + char **sp = NULL, *np[BUFSIZ]; + int splen = 0, nplen, i; + int relative = 0; + + Tcl_DStringInit(retPtr); + + if (Tcl_GetPathType(path) == TCL_PATH_RELATIVE) { + Tcl_DString ds; + char *cwd = Tcl_GetCwd(interp, &ds); + + if (cwd) { + CONST char * pair[2]; + + pair[0] = cwd; + pair[1] = path; + + Tcl_JoinPath(2, pair, retPtr); + Tcl_DStringFree(&ds); + } + path = Tcl_DStringValue(retPtr); + + relative = 1; + } + Tcl_SplitPath(path, &splen, &sp); + if (relative) { + Tcl_DStringFree(retPtr); + } + + nplen = 0; + for (i = 0;i < splen;i++) { + if (strcmp(sp[i], ".") == 0) + continue; + + if (strcmp(sp[i], "..") == 0) { + if (nplen > 1) nplen--; + } else { + np[nplen++] = sp[i]; + } + } + if (nplen > 0) { + Tcl_DStringInit(retPtr); + Tcl_JoinPath(nplen, np, retPtr); + } else { + /* Init to an empty string */ + Tcl_DStringInit(retPtr); + } + Tcl_Free( (char*) sp); + return Tcl_DStringValue(retPtr); + } + + /* *--------------------------------------------------------------------------- * * TclGetOpenMode -- *************** *** 439,446 **** * * This procedure replaces the library version of stat and lsat. * The chain of functions that have been "inserted" into the ! * 'statProcList' will be called in succession until either ! * a value of zero is returned, or the entire list is visited. * * Results: * See stat documentation. --- 732,739 ---- * * This procedure replaces the library version of stat and lsat. * The chain of functions that have been "inserted" into the ! * filesystem will be called in succession until either ! * a value other than -1 is returned, or the entire list is visited. * * Results: * See stat documentation. *************** *** 456,462 **** --- 749,758 ---- CONST char *path; /* Path of file to stat (in current CP). */ struct stat *buf; /* Filled with results of stat call. */ { + #ifdef USE_OBSOLETE_FS_HOOKS StatProc *statProcPtr; + #endif /* USE_OBSOLETE_FS_HOOKS */ + Tcl_FilesystemRecord *fsRecPtr; int retVal = -1; /* *************** *** 465,475 **** --- 761,827 ---- */ Tcl_MutexLock(&hookMutex); + #ifdef USE_OBSOLETE_FS_HOOKS statProcPtr = statProcList; while ((retVal == -1) && (statProcPtr != NULL)) { retVal = (*statProcPtr->proc)(path, buf); statProcPtr = statProcPtr->nextPtr; } + #endif /* USE_OBSOLETE_FS_HOOKS */ + fsRecPtr = filesystemList; + while ((retVal == -1) && (fsRecPtr != NULL)) { + TclStatProc_ *proc = fsRecPtr->fsPtr->statProc; + if (proc != NULL) { + retVal = (*proc)(path, buf); + } + fsRecPtr = fsRecPtr->nextPtr; + } + Tcl_MutexUnlock(&hookMutex); + + return (retVal); + } + + /* + *---------------------------------------------------------------------- + * + * TclLstat -- + * + * This procedure replaces the library version of lstat. + * The chain of functions that have been "inserted" into the + * filesystem will be called in succession until either + * a value other than -1 is returned, or the entire list is visited. + * + * Results: + * See stat documentation. + * + * Side effects: + * See stat documentation. + * + *---------------------------------------------------------------------- + */ + + int + TclLstat(path, buf) + CONST char *path; /* Path of file to stat (in current CP). */ + struct stat *buf; /* Filled with results of stat call. */ + { + Tcl_FilesystemRecord *fsRecPtr; + int retVal = -1; + + /* + * Call each of the "lstat" function in succession. A non-return + * value of -1 indicates the particular function has succeeded. + */ + + Tcl_MutexLock(&hookMutex); + fsRecPtr = filesystemList; + while ((retVal == -1) && (fsRecPtr != NULL)) { + TclLstatProc_ *proc = fsRecPtr->fsPtr->lstatProc; + if (proc != NULL) { + retVal = (*proc)(path, buf); + } + fsRecPtr = fsRecPtr->nextPtr; + } Tcl_MutexUnlock(&hookMutex); return (retVal); *************** *** 482,489 **** * * This procedure replaces the library version of access. * The chain of functions that have been "inserted" into the ! * 'accessProcList' will be called in succession until either ! * a value of zero is returned, or the entire list is visited. * * Results: * See access documentation. --- 834,841 ---- * * This procedure replaces the library version of access. * The chain of functions that have been "inserted" into the ! * filesystem will be called in succession until either ! * a value other than -1 is returned, or the entire list is visited. * * Results: * See access documentation. *************** *** 499,505 **** --- 851,860 ---- CONST char *path; /* Path of file to access (in current CP). */ int mode; /* Permission setting. */ { + #ifdef USE_OBSOLETE_FS_HOOKS AccessProc *accessProcPtr; + #endif /* USE_OBSOLETE_FS_HOOKS */ + Tcl_FilesystemRecord *fsRecPtr; int retVal = -1; /* *************** *** 508,518 **** --- 863,883 ---- */ Tcl_MutexLock(&hookMutex); + #ifdef USE_OBSOLETE_FS_HOOKS accessProcPtr = accessProcList; while ((retVal == -1) && (accessProcPtr != NULL)) { retVal = (*accessProcPtr->proc)(path, mode); accessProcPtr = accessProcPtr->nextPtr; } + #endif /* USE_OBSOLETE_FS_HOOKS */ + fsRecPtr = filesystemList; + while ((retVal == -1) && (fsRecPtr != NULL)) { + TclAccessProc_ *proc = fsRecPtr->fsPtr->accessProc; + if (proc != NULL) { + retVal = (*proc)(path, mode); + } + fsRecPtr = fsRecPtr->nextPtr; + } Tcl_MutexUnlock(&hookMutex); return (retVal); *************** *** 524,532 **** * Tcl_OpenFileChannel -- * * The chain of functions that have been "inserted" into the ! * 'openFileChannelProcList' will be called in succession until ! * either a valid file channel is returned, or the entire list is ! * visited. * * Results: * The new channel or NULL, if the named file could not be opened. --- 889,896 ---- * Tcl_OpenFileChannel -- * * The chain of functions that have been "inserted" into the ! * filesystem will be called in succession until either a valid ! * file channel is returned, or the entire list is visited. * * Results: * The new channel or NULL, if the named file could not be opened. *************** *** 549,555 **** --- 913,922 ---- * file, with what modes to create * it? */ { + #ifdef USE_OBSOLETE_FS_HOOKS OpenFileChannelProc *openFileChannelProcPtr; + #endif /* USE_OBSOLETE_FS_HOOKS */ + Tcl_FilesystemRecord *fsRecPtr; Tcl_Channel retVal = NULL; /* *************** *** 559,618 **** */ Tcl_MutexLock(&hookMutex); openFileChannelProcPtr = openFileChannelProcList; while ((retVal == NULL) && (openFileChannelProcPtr != NULL)) { retVal = (*openFileChannelProcPtr->proc)(interp, fileName, modeString, permissions); openFileChannelProcPtr = openFileChannelProcPtr->nextPtr; } Tcl_MutexUnlock(&hookMutex); return (retVal); } /* *---------------------------------------------------------------------- * ! * TclStatInsertProc -- * ! * Insert the passed procedure pointer at the head of the list of ! * functions which are used during a call to 'TclStat(...)'. The ! * passed function should be have exactly like 'TclStat' when called ! * during that time (see 'TclStat(...)' for more informatin). ! * The function will be added even if it already in the list. * ! * Results: ! * Normally TCL_OK; TCL_ERROR if memory for a new node in the list ! * could not be allocated. * * Side effects: ! * Memory allocataed and modifies the link list for 'TclStat' ! * functions. * ! *---------------------------------------------------------------------- ! */ int ! TclStatInsertProc (proc) ! TclStatProc_ *proc; { ! int retVal = TCL_ERROR; ! ! if (proc != NULL) { ! StatProc *newStatProcPtr; ! ! newStatProcPtr = (StatProc *)ckalloc(sizeof(StatProc)); ! if (newStatProcPtr != NULL) { ! newStatProcPtr->proc = proc; ! Tcl_MutexLock(&hookMutex); ! newStatProcPtr->nextPtr = statProcList; ! statProcList = newStatProcPtr; ! Tcl_MutexUnlock(&hookMutex); ! retVal = TCL_OK; } } return (retVal); } --- 926,1027 ---- */ Tcl_MutexLock(&hookMutex); + #ifdef USE_OBSOLETE_FS_HOOKS openFileChannelProcPtr = openFileChannelProcList; while ((retVal == NULL) && (openFileChannelProcPtr != NULL)) { retVal = (*openFileChannelProcPtr->proc)(interp, fileName, modeString, permissions); openFileChannelProcPtr = openFileChannelProcPtr->nextPtr; } + #endif /* USE_OBSOLETE_FS_HOOKS */ + fsRecPtr = filesystemList; + while ((retVal == NULL) && (fsRecPtr != NULL)) { + TclOpenFileChannelProc_ *proc = fsRecPtr->fsPtr->openFileChannelProc; + if (proc != NULL) { + retVal = (*proc)(interp, fileName, modeString, permissions); + } + fsRecPtr = fsRecPtr->nextPtr; + } Tcl_MutexUnlock(&hookMutex); return (retVal); } + /* + * TclpMatchFiles -- + * + * This function is now obsolete. Call the function + * 'TclMatchFilesTypes' instead (or TclpMatchFilesTypes if you must + * avoid the hooks). + */ + int + TclpMatchFiles( + Tcl_Interp *interp, /* Interpreter to receive results. */ + char *separators, /* Directory separators to pass to TclDoGlob. */ + Tcl_DString *dirPtr, /* Contains path to directory to search. */ + char *pattern, /* Pattern to match against. */ + char *tail) /* Pointer to end of pattern. Tail must + * point to a location in pattern and must + * not be static.*/ + { + return TclMatchFilesTypes(interp,separators,dirPtr,pattern,tail,NULL); + } + /* *---------------------------------------------------------------------- * ! * TclMatchFilesTypes -- * ! * This routine is used by the globbing code to search a ! * directory for all files which match a given pattern. ! * The chain of functions that have been "inserted" into the ! * filesystem will be called in succession until either ! * a value other than -1 is returned, or the entire list is visited. * ! * Results: ! * If the tail argument is NULL, then the matching files are ! * added to the the interp's result. Otherwise, TclDoGlob is called ! * recursively for each matching subdirectory. The return value ! * is a standard Tcl result indicating whether an error occurred ! * in globbing. * * Side effects: ! * None. * ! *---------------------------------------------------------------------- */ int ! TclMatchFilesTypes( ! Tcl_Interp *interp, /* Interpreter to receive results. */ ! char *separators, /* Directory separators to pass to TclDoGlob. */ ! Tcl_DString *dirPtr, /* Contains path to directory to search. */ ! char *pattern, /* Pattern to match against. */ ! char *tail, /* Pointer to end of pattern. Tail must ! * point to a location in pattern and must ! * not be static.*/ ! GlobTypeData *types) /* Object containing list of acceptable types. ! * May be NULL. */ { ! Tcl_FilesystemRecord *fsRecPtr; ! int retVal = -1; ! /* ! * Call each of the "TclMatchFilesTypes" function in succession. A ! * non-return value of -1 indicates the particular function has ! * succeeded. ! */ ! Tcl_MutexLock(&hookMutex); ! fsRecPtr = filesystemList; ! while ((retVal == -1) && (fsRecPtr != NULL)) { ! TclMatchFilesTypesProc_ *proc = fsRecPtr->fsPtr->matchFilesTypesProc; ! if (proc != NULL) { ! retVal = (*proc)(interp, separators, dirPtr, ! pattern, tail, types); } + fsRecPtr = fsRecPtr->nextPtr; } + Tcl_MutexUnlock(&hookMutex); return (retVal); } *************** *** 620,691 **** /* *---------------------------------------------------------------------- * ! * TclStatDeleteProc -- * ! * Removed the passed function pointer from the list of 'TclStat' ! * functions. Ensures that the built-in stat function is not ! * removvable. * * Results: ! * TCL_OK if the procedure pointer was successfully removed, ! * TCL_ERROR otherwise. * * Side effects: ! * Memory is deallocated and the respective list updated. * *---------------------------------------------------------------------- */ ! int ! TclStatDeleteProc (proc) ! TclStatProc_ *proc; { ! int retVal = TCL_ERROR; ! StatProc *tmpStatProcPtr; ! StatProc *prevStatProcPtr = NULL; ! Tcl_MutexLock(&hookMutex); - tmpStatProcPtr = statProcList; - /* - * Traverse the 'statProcList' looking for the particular node - * whose 'proc' member matches 'proc' and remove that one from - * the list. Ensure that the "default" node cannot be removed. - */ - - while ((retVal == TCL_ERROR) && (tmpStatProcPtr != &defaultStatProc)) { - if (tmpStatProcPtr->proc == proc) { - if (prevStatProcPtr == NULL) { - statProcList = tmpStatProcPtr->nextPtr; - } else { - prevStatProcPtr->nextPtr = tmpStatProcPtr->nextPtr; - } ! Tcl_Free((char *)tmpStatProcPtr); ! retVal = TCL_OK; ! } else { ! prevStatProcPtr = tmpStatProcPtr; ! tmpStatProcPtr = tmpStatProcPtr->nextPtr; } } Tcl_MutexUnlock(&hookMutex); return (retVal); } /* *---------------------------------------------------------------------- * ! * TclAccessInsertProc -- * ! * Insert the passed procedure pointer at the head of the list of ! * functions which are used during a call to 'TclAccess(...)'. The ! * passed function should be have exactly like 'TclAccess' when ! * called during that time (see 'TclAccess(...)' for more informatin). ! * The function will be added even if it already in the list. * * Results: ! * Normally TCL_OK; TCL_ERROR if memory for a new node in the list * could not be allocated. * * Side effects: --- 1029,1774 ---- /* *---------------------------------------------------------------------- * ! * Tcl_GetCwd -- * ! * This function replaces the library version of getcwd(). ! * The chain of functions that have been "inserted" into the ! * filesystem will be called in succession until either ! * a value other than NULL is returned, or the entire list is visited. * * Results: ! * The result is a pointer to a string specifying the current ! * directory, or NULL if the current directory could not be ! * determined. If NULL is returned, an error message is left in the ! * interp's result. Storage for the result string is allocated in ! * bufferPtr; the caller must call Tcl_DStringFree() when the result ! * is no longer needed. * * Side effects: ! * None. * *---------------------------------------------------------------------- */ ! char * ! Tcl_GetCwd(interp, cwdPtr) ! Tcl_Interp *interp; ! Tcl_DString *cwdPtr; { ! Tcl_FilesystemRecord *fsRecPtr; ! char* retVal = NULL; Tcl_MutexLock(&hookMutex); ! if (cwdPathPtr == NULL) { ! /* ! * We've never been called before, try to find a cwd. ! * First initialise the global path storage. ! */ ! cwdPathPtr = &cwdPath; ! ! /* ! * Call each of the "Tcl_GetCwd" function in succession. ! * A non-NULL return value indicates the particular function has ! * succeeded. ! */ ! fsRecPtr = filesystemList; ! while ((retVal == NULL) && (fsRecPtr != NULL)) { ! TclGetCwdProc_ *proc = fsRecPtr->fsPtr->getCwdProc; ! if (proc != NULL) { ! retVal = (*proc)(interp, cwdPathPtr); ! } ! fsRecPtr = fsRecPtr->nextPtr; } + } else { + retVal = Tcl_DStringValue(cwdPathPtr); } + + if (retVal != NULL) { + /* + * We found a cwd, which is now in our global storage. We must + * make a copy. + */ + Tcl_DStringInit(cwdPtr); + Tcl_DStringAppend(cwdPtr, Tcl_DStringValue(cwdPathPtr), + Tcl_DStringLength(cwdPathPtr)); + /* Now make the retVal point to the copy */ + retVal = Tcl_DStringValue(cwdPtr); + } Tcl_MutexUnlock(&hookMutex); + return (retVal); } /* *---------------------------------------------------------------------- * ! * TclUtime -- * ! * This procedure replaces the library version of utime. ! * The chain of functions that have been "inserted" into the ! * filesystem will be called in succession until either ! * a value other than -1 is returned, or the entire list is visited. * * Results: ! * See utime documentation. ! * ! * Side effects: ! * See utime documentation. ! * ! *---------------------------------------------------------------------- ! */ ! ! int ! TclUtime (fileName, tval) ! CONST char* fileName; ! struct utimbuf *tval; ! { ! Tcl_FilesystemRecord *fsRecPtr; ! int retVal = -1; ! ! /* ! * Call each of the "utime" functions in succession. A non-return ! * value of -1 indicates the particular function has succeeded. ! */ ! ! Tcl_MutexLock(&hookMutex); ! fsRecPtr = filesystemList; ! while ((retVal == -1) && (fsRecPtr != NULL)) { ! TclUtimeProc_ *proc = fsRecPtr->fsPtr->utimeProc; ! if (proc != NULL) { ! retVal = (*proc)(fileName, tval); ! } ! fsRecPtr = fsRecPtr->nextPtr; ! } ! Tcl_MutexUnlock(&hookMutex); ! ! return (retVal); ! } ! ! ! /* ! *---------------------------------------------------------------------- ! * ! * TclpFileAttrsCallProc -- ! * ! * This procedure implements the platform dependent ! * 'file attributes' subcommand, for the native ! * filesystem. ! * ! * Results: ! * Standard Tcl return code. ! * ! * Side effects: ! * None. ! * ! *---------------------------------------------------------------------- ! */ ! ! int ! TclpFileAttrsCallProc(interp, get, index, fileName, objPtrRef) ! Tcl_Interp *interp; /* The interpreter for error reporting. */ ! int get; /* boolean, 'get' if 1, else 'set'. */ ! int index; /* index of the attribute command. */ ! char *fileName; /* filename we are operating on. */ ! Tcl_Obj **objPtrRef; /* Either for input or output. */ ! { ! if (get) { ! return (*tclpFileAttrProcs[index].getProc)(interp, index, fileName, ! objPtrRef); ! } else { ! return (*tclpFileAttrProcs[index].setProc)(interp, index, fileName, ! *objPtrRef); ! } ! } ! ! /* ! *---------------------------------------------------------------------- ! * ! * TclFileAttrsCallProc -- ! * ! * This procedure implements the hookable ! * 'file attributes' subcommand, which calls each registered ! * filesystem in turn, until one declares it has handled the ! * command. ! * ! * Results: ! * Standard Tcl return code. ! * ! * Side effects: ! * None. ! * ! *---------------------------------------------------------------------- ! */ ! ! int ! TclFileAttrsCallProc(interp, get, index, fileName, objPtrRef) ! Tcl_Interp *interp; /* The interpreter for error reporting. */ ! int get; /* boolean, 'get' if 1, else 'set'. */ ! int index; /* index of the attribute command. */ ! char *fileName; /* filename we are operating on. */ ! Tcl_Obj **objPtrRef; /* Either for input or output. */ ! { ! Tcl_FilesystemRecord *fsRecPtr; ! int retVal = -1; ! ! /* ! * Call each of the "fileattrscallproc" functions in succession. A ! * non-return value of -1 indicates the particular function has ! * succeeded. ! */ ! ! Tcl_MutexLock(&hookMutex); ! fsRecPtr = filesystemList; ! while ((retVal == -1) && (fsRecPtr != NULL)) { ! TclFileAttrsCallProc_ *proc = fsRecPtr->fsPtr->fileAttrsCallProc; ! if (proc != NULL) { ! retVal = (*proc)(interp, get, index, fileName, objPtrRef); ! } ! fsRecPtr = fsRecPtr->nextPtr; ! } ! Tcl_MutexUnlock(&hookMutex); ! ! return (retVal); ! } ! ! /* ! *---------------------------------------------------------------------- ! * ! * Tcl_Chdir -- ! * ! * This function replaces the library version of chdir(). ! * The chain of functions that have been "inserted" into the ! * filesystem will be called in succession until either ! * a value other than -1 is returned, or the entire list is visited. ! * ! * Results: ! * See chdir() documentation. ! * ! * Side effects: ! * See chdir() documentation. ! * ! *---------------------------------------------------------------------- ! */ ! int ! Tcl_Chdir(dirName) ! CONST char *dirName; ! { ! Tcl_FilesystemRecord *fsRecPtr; ! Tcl_DString cwd; ! int retVal = -1; ! char *normDirName; ! ! normDirName = TclNormalizePath(NULL, dirName, &cwd); ! ! /* ! * Call each of the "chdir" function in succession. A non-return ! * value of -1 indicates the particular function has succeeded. ! */ ! ! Tcl_MutexLock(&hookMutex); ! fsRecPtr = filesystemList; ! while ((retVal == -1) && (fsRecPtr != NULL)) { ! TclChdirProc_ *proc = fsRecPtr->fsPtr->chdirProc; ! if (proc != NULL) { ! retVal = (*proc)(normDirName); ! } ! fsRecPtr = fsRecPtr->nextPtr; ! } ! ! if (retVal != -1) { ! /* ! * The cwd changed. We must assume that is was actually ! * changed to the normalized value we calculated above. ! */ ! if (cwdPathPtr == NULL) { ! /* We've never used cwdPathPtr before */ ! cwdPathPtr = &cwdPath; ! } else { ! /* Free up the previous cwd we stored */ ! Tcl_DStringFree(cwdPathPtr); ! } ! /* Now remember the current cwd */ ! Tcl_DStringInit(cwdPathPtr); ! Tcl_DStringAppend(cwdPathPtr, Tcl_DStringValue(&cwd), ! Tcl_DStringLength(&cwd)); ! ! } ! ! Tcl_MutexUnlock(&hookMutex); ! ! return (retVal); ! } ! ! /* ! *---------------------------------------------------------------------- ! * ! * TclLoadFile -- ! * ! * Dynamically loads a binary code file into memory and returns ! * the addresses of two procedures within that file, if they ! * are defined. ! * The chain of functions that have been "inserted" into the ! * filesystem will be called in succession until either ! * a value other than -1 is returned, or the entire list is visited. ! * ! * Results: ! * A standard Tcl completion code. If an error occurs, an error ! * message is left in the interp's result. ! * ! * Side effects: ! * New code suddenly appears in memory. We remember which ! * filesystem loaded the code, so that we can use that filesystem's ! * unloadProc to unload the code when that occurs. ! * ! *---------------------------------------------------------------------- ! */ ! ! int ! TclLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr, clientDataPtr, unloadProcPtr) ! Tcl_Interp *interp; /* Used for error reporting. */ ! char *fileName; /* Name of the file containing the desired ! * code. */ ! char *sym1, *sym2; /* Names of two procedures to look up in ! * the file's symbol table. */ ! Tcl_PackageInitProc **proc1Ptr, **proc2Ptr; ! /* Where to return the addresses corresponding ! * to sym1 and sym2. */ ! ClientData *clientDataPtr; /* Filled with token for dynamically loaded ! * file which will be passed back to ! * (*unloadProcPtr)() to unload the file. */ ! TclUnloadFileProc_ **unloadProcPtr; ! /* Filled with address of TclpUnloadFile ! * function which should be used for ! * this file. */ ! { ! Tcl_FilesystemRecord *fsRecPtr; ! int retVal = -1; ! ! /* ! * Call each of the "load" functions in succession. A non-return ! * value of -1 indicates the particular function has succeeded. ! */ ! ! Tcl_MutexLock(&hookMutex); ! fsRecPtr = filesystemList; ! while ((retVal == -1) && (fsRecPtr != NULL)) { ! TclLoadFileProc_ *proc = fsRecPtr->fsPtr->loadFileProc; ! if (proc != NULL) { ! retVal = (*proc)(interp, fileName, sym1, sym2, ! proc1Ptr, proc2Ptr, clientDataPtr); ! if (retVal != -1) { ! /* ! * We handled it. Remember which unload file ! * proc to use. ! */ ! (*unloadProcPtr) = fsRecPtr->fsPtr->unloadFileProc; ! } ! } ! fsRecPtr = fsRecPtr->nextPtr; ! } ! Tcl_MutexUnlock(&hookMutex); ! ! return (retVal); ! } ! ! /* ! *--------------------------------------------------------------------------- ! * ! * TclReadlink -- ! * ! * This function replaces the library version of readlink(). ! * The chain of functions that have been "inserted" into the ! * filesystem will be called in succession until either ! * a value other than NULL is returned, or the entire list is visited. ! * ! * Results: ! * The result is a pointer to a string specifying the contents ! * of the symbolic link given by 'path', or NULL if the symbolic ! * link could not be read. Storage for the result string is ! * allocated in bufferPtr; the caller must call Tcl_DStringFree() ! * when the result is no longer needed. ! * ! * Side effects: ! * See readlink() documentation. ! * ! *--------------------------------------------------------------------------- ! */ ! ! char * ! TclReadlink(path, linkPtr) ! CONST char *path; /* Path of file to readlink (UTF-8). */ ! Tcl_DString *linkPtr; /* Uninitialized or free DString filled ! * with contents of link (UTF-8). */ ! { ! Tcl_FilesystemRecord *fsRecPtr; ! char* retVal = NULL; ! ! /* ! * Call each of the "readlink" function in succession. ! * A non-NULL return value indicates the particular function has ! * succeeded. ! */ ! ! Tcl_MutexLock(&hookMutex); ! fsRecPtr = filesystemList; ! while ((retVal == NULL) && (fsRecPtr != NULL)) { ! TclReadlinkProc_ *proc = fsRecPtr->fsPtr->readlinkProc; ! if (proc != NULL) { ! retVal = (*proc)(path, linkPtr); ! } ! fsRecPtr = fsRecPtr->nextPtr; ! } ! Tcl_MutexUnlock(&hookMutex); ! ! /* ! * If S_IFLNK isn't defined it means that the machine doesn't ! * support symbolic links, so the file can't possibly be a ! * symbolic link. Generate an EINVAL error, which is what ! * happens on machines that do support symbolic links when ! * you invoke readlink on a file that isn't a symbolic link. ! */ ! #ifndef S_IFLNK ! if (retVal == NULL) { ! errno = EINVAL; ! } ! #endif /* S_IFLNK */ ! return (retVal); ! } ! ! /* ! *--------------------------------------------------------------------------- ! * ! * TclListVolumes -- ! * ! * Lists the currently mounted volumes. ! * The chain of functions that have been "inserted" into the ! * filesystem will be called in succession; each may add to ! * the Tcl result, until all mounted file systems are listed. ! * ! * Results: ! * A standard Tcl result. Will always be TCL_OK, since there is no way ! * that this command can fail. Also, the interpreter's result is set to ! * the list of volumes. ! * ! * Side effects: ! * None ! * ! *--------------------------------------------------------------------------- ! */ ! ! int ! TclListVolumes( ! Tcl_Interp *interp) /* Interpreter for returning volume list. */ ! { ! Tcl_FilesystemRecord *fsRecPtr; ! ! /* ! * Call each of the "listVolumes" function in succession. ! * A non-NULL return value indicates the particular function has ! * succeeded. We call all the functions registered, since we want ! * a list of all drives from all filesystems. ! */ ! ! Tcl_MutexLock(&hookMutex); ! fsRecPtr = filesystemList; ! while (fsRecPtr != NULL) { ! TclListVolumesProc_ *proc = fsRecPtr->fsPtr->listVolumesProc; ! if (proc != NULL) { ! /* Ignore return value */ ! (*proc)(interp); ! } ! fsRecPtr = fsRecPtr->nextPtr; ! } ! Tcl_MutexUnlock(&hookMutex); ! ! return TCL_OK; ! } ! int ! TclRenameFile( ! CONST char *src, /* Pathname of file or dir to be renamed ! * (UTF-8). */ ! CONST char *dst) /* New pathname of file or directory ! * (UTF-8). */ ! { ! Tcl_FilesystemRecord *fsRecPtr; ! int retVal = -1; ! ! /* ! * Call each of the "renameFile" functions in succession. A non-return ! * value of -1 indicates the particular function has succeeded. ! */ ! ! Tcl_MutexLock(&hookMutex); ! fsRecPtr = filesystemList; ! while ((retVal == -1) && (fsRecPtr != NULL)) { ! TclRenameFileProc_ *proc = fsRecPtr->fsPtr->renameFileProc; ! if (proc != NULL) { ! retVal = (*proc)(src, dst); ! } ! fsRecPtr = fsRecPtr->nextPtr; ! } ! Tcl_MutexUnlock(&hookMutex); ! ! return (retVal); ! } ! int ! TclCopyFile( ! CONST char *src, /* Pathname of file to be copied (UTF-8). */ ! CONST char *dst) /* Pathname of file to copy to (UTF-8). */ ! { ! Tcl_FilesystemRecord *fsRecPtr; ! int retVal = -1; ! ! /* ! * Call each of the "copyFile" functions in succession. A non-return ! * value of -1 indicates the particular function has succeeded. ! */ ! ! Tcl_MutexLock(&hookMutex); ! fsRecPtr = filesystemList; ! while ((retVal == -1) && (fsRecPtr != NULL)) { ! TclCopyFileProc_ *proc = fsRecPtr->fsPtr->copyFileProc; ! if (proc != NULL) { ! retVal = (*proc)(src, dst); ! } ! fsRecPtr = fsRecPtr->nextPtr; ! } ! Tcl_MutexUnlock(&hookMutex); ! ! return (retVal); ! } ! int ! TclDeleteFile( ! CONST char *path) /* Pathname of file to be removed (UTF-8). */ ! { ! Tcl_FilesystemRecord *fsRecPtr; ! int retVal = -1; ! ! /* ! * Call each of the "deleteFile" functions in succession. A non-return ! * value of -1 indicates the particular function has succeeded. ! */ ! ! Tcl_MutexLock(&hookMutex); ! fsRecPtr = filesystemList; ! while ((retVal == -1) && (fsRecPtr != NULL)) { ! TclDeleteFileProc_ *proc = fsRecPtr->fsPtr->deleteFileProc; ! if (proc != NULL) { ! retVal = (*proc)(path); ! } ! fsRecPtr = fsRecPtr->nextPtr; ! } ! Tcl_MutexUnlock(&hookMutex); ! ! return (retVal); ! } ! int ! TclCreateDirectory( ! CONST char *path) /* Pathname of directory to create (UTF-8). */ ! { ! Tcl_FilesystemRecord *fsRecPtr; ! int retVal = -1; ! ! /* ! * Call each of the "createDirectory" functions in succession. A non-return ! * value of -1 indicates the particular function has succeeded. ! */ ! ! Tcl_MutexLock(&hookMutex); ! fsRecPtr = filesystemList; ! while ((retVal == -1) && (fsRecPtr != NULL)) { ! TclCreateDirectoryProc_ *proc = fsRecPtr->fsPtr->createDirectoryProc; ! if (proc != NULL) { ! retVal = (*proc)(path); ! } ! fsRecPtr = fsRecPtr->nextPtr; ! } ! Tcl_MutexUnlock(&hookMutex); ! ! return (retVal); ! } ! int ! TclCopyDirectory( ! CONST char *src, /* Pathname of directory to be copied ! * (UTF-8). */ ! CONST char *dst, /* Pathname of target directory (UTF-8). */ ! Tcl_DString *errorPtr) /* If non-NULL, uninitialized or free ! * DString filled with UTF-8 name of file ! * causing error. */ ! { ! Tcl_FilesystemRecord *fsRecPtr; ! int retVal = -1; ! ! /* ! * Call each of the "copyDirectory" functions in succession. A non-return ! * value of -1 indicates the particular function has succeeded. ! */ ! ! Tcl_MutexLock(&hookMutex); ! fsRecPtr = filesystemList; ! while ((retVal == -1) && (fsRecPtr != NULL)) { ! TclCopyDirectoryProc_ *proc = fsRecPtr->fsPtr->copyDirectoryProc; ! if (proc != NULL) { ! retVal = (*proc)(src, dst, errorPtr); ! } ! fsRecPtr = fsRecPtr->nextPtr; ! } ! Tcl_MutexUnlock(&hookMutex); ! ! return (retVal); ! } ! int ! TclRemoveDirectory( ! CONST char *path, /* Pathname of directory to be removed ! * (UTF-8). */ ! int recursive, /* If non-zero, removes directories that ! * are nonempty. Otherwise, will only remove ! * empty directories. */ ! Tcl_DString *errorPtr) /* If non-NULL, uninitialized or free ! * DString filled with UTF-8 name of file ! * causing error. */ ! { ! Tcl_FilesystemRecord *fsRecPtr; ! int retVal = -1; ! ! /* ! * Call each of the "removeDirectory" functions in succession. A non-return ! * value of -1 indicates the particular function has succeeded. ! */ ! ! Tcl_MutexLock(&hookMutex); ! fsRecPtr = filesystemList; ! while ((retVal == -1) && (fsRecPtr != NULL)) { ! TclRemoveDirectoryProc_ *proc = fsRecPtr->fsPtr->removeDirectoryProc; ! if (proc != NULL) { ! retVal = (*proc)(path, recursive, errorPtr); ! } ! fsRecPtr = fsRecPtr->nextPtr; ! } ! Tcl_MutexUnlock(&hookMutex); ! ! return (retVal); ! } ! #ifdef USE_OBSOLETE_FS_HOOKS ! ! /* ! *---------------------------------------------------------------------- ! * ! * TclStatInsertProc -- ! * ! * Insert the passed procedure pointer at the head of the list of ! * functions which are used during a call to 'TclStat(...)'. The ! * passed function should be have exactly like 'TclStat' when called ! * during that time (see 'TclStat(...)' for more informatin). ! * The function will be added even if it already in the list. ! * ! * Results: ! * Normally TCL_OK; TCL_ERROR if memory for a new node in the list ! * could not be allocated. ! * ! * Side effects: ! * Memory allocataed and modifies the link list for 'TclStat' ! * functions. ! * ! *---------------------------------------------------------------------- ! */ ! ! int ! TclStatInsertProc (proc) ! TclStatProc_ *proc; ! { ! int retVal = TCL_ERROR; ! ! if (proc != NULL) { ! StatProc *newStatProcPtr; ! ! newStatProcPtr = (StatProc *)ckalloc(sizeof(StatProc)); ! ! if (newStatProcPtr != NULL) { ! newStatProcPtr->proc = proc; ! Tcl_MutexLock(&hookMutex); ! newStatProcPtr->nextPtr = statProcList; ! statProcList = newStatProcPtr; ! Tcl_MutexUnlock(&hookMutex); ! ! retVal = TCL_OK; ! } ! } ! ! return (retVal); ! } ! ! /* ! *---------------------------------------------------------------------- ! * ! * TclStatDeleteProc -- ! * ! * Removed the passed function pointer from the list of 'TclStat' ! * functions. Ensures that the built-in stat function is not ! * removvable. ! * ! * Results: ! * TCL_OK if the procedure pointer was successfully removed, ! * TCL_ERROR otherwise. ! * ! * Side effects: ! * Memory is deallocated and the respective list updated. ! * ! *---------------------------------------------------------------------- ! */ ! ! int ! TclStatDeleteProc (proc) ! TclStatProc_ *proc; ! { ! int retVal = TCL_ERROR; ! StatProc *tmpStatProcPtr; ! StatProc *prevStatProcPtr = NULL; ! ! Tcl_MutexLock(&hookMutex); ! tmpStatProcPtr = statProcList; ! /* ! * Traverse the 'statProcList' looking for the particular node ! * whose 'proc' member matches 'proc' and remove that one from ! * the list. Ensure that the "default" node cannot be removed. ! */ ! ! while ((retVal == TCL_ERROR) && (tmpStatProcPtr != NULL)) { ! if (tmpStatProcPtr->proc == proc) { ! if (prevStatProcPtr == NULL) { ! statProcList = tmpStatProcPtr->nextPtr; ! } else { ! prevStatProcPtr->nextPtr = tmpStatProcPtr->nextPtr; ! } ! ! Tcl_Free((char *)tmpStatProcPtr); ! ! retVal = TCL_OK; ! } else { ! prevStatProcPtr = tmpStatProcPtr; ! tmpStatProcPtr = tmpStatProcPtr->nextPtr; ! } ! } ! ! Tcl_MutexUnlock(&hookMutex); ! return (retVal); ! } ! ! /* ! *---------------------------------------------------------------------- ! * ! * TclAccessInsertProc -- ! * ! * Insert the passed procedure pointer at the head of the list of ! * functions which are used during a call to 'TclAccess(...)'. The ! * passed function should be have exactly like 'TclAccess' when ! * called during that time (see 'TclAccess(...)' for more informatin). ! * The function will be added even if it already in the list. ! * ! * Results: ! * Normally TCL_OK; TCL_ERROR if memory for a new node in the list * could not be allocated. * * Side effects: *************** *** 755,761 **** Tcl_MutexLock(&hookMutex); tmpAccessProcPtr = accessProcList; ! while ((retVal == TCL_ERROR) && (tmpAccessProcPtr != &defaultAccessProc)) { if (tmpAccessProcPtr->proc == proc) { if (prevAccessProcPtr == NULL) { accessProcList = tmpAccessProcPtr->nextPtr; --- 1838,1844 ---- Tcl_MutexLock(&hookMutex); tmpAccessProcPtr = accessProcList; ! while ((retVal == TCL_ERROR) && (tmpAccessProcPtr != NULL)) { if (tmpAccessProcPtr->proc == proc) { if (prevAccessProcPtr == NULL) { accessProcList = tmpAccessProcPtr->nextPtr; *************** *** 855,867 **** /* * Traverse the 'openFileChannelProcList' looking for the particular * node whose 'proc' member matches 'proc' and remove that one from ! * the list. Ensure that the "default" node cannot be removed. */ Tcl_MutexLock(&hookMutex); tmpOpenFileChannelProcPtr = openFileChannelProcList; while ((retVal == TCL_ERROR) && ! (tmpOpenFileChannelProcPtr != &defaultOpenFileChannelProc)) { if (tmpOpenFileChannelProcPtr->proc == proc) { if (prevOpenFileChannelProcPtr == NULL) { openFileChannelProcList = tmpOpenFileChannelProcPtr->nextPtr; --- 1938,1950 ---- /* * Traverse the 'openFileChannelProcList' looking for the particular * node whose 'proc' member matches 'proc' and remove that one from ! * the list. */ Tcl_MutexLock(&hookMutex); tmpOpenFileChannelProcPtr = openFileChannelProcList; while ((retVal == TCL_ERROR) && ! (tmpOpenFileChannelProcPtr != NULL)) { if (tmpOpenFileChannelProcPtr->proc == proc) { if (prevOpenFileChannelProcPtr == NULL) { openFileChannelProcList = tmpOpenFileChannelProcPtr->nextPtr; *************** *** 882,884 **** --- 1965,1968 ---- return (retVal); } + #endif /* USE_OBSOLETE_FS_HOOKS */ Index: generic/tclInt.decls =================================================================== RCS file: /cvsroot/tcl/generic/tclInt.decls,v retrieving revision 1.23 diff -c -r1.23 tclInt.decls *** tclInt.decls 2000/09/28 06:38:21 1.23 --- tclInt.decls 2000/11/21 17:07:28 *************** *** 613,618 **** --- 613,622 ---- declare 162 generic { void TclChannelEventScriptInvoker(ClientData clientData, int flags) } + declare 163 generic { + char* TclNormalizePath(Tcl_Interp* interp, CONST char *path, \ + Tcl_DString* retPtr) + } ############################################################################## Index: generic/tclInt.h =================================================================== RCS file: /cvsroot/tcl/generic/tclInt.h,v retrieving revision 1.50 diff -c -r1.50 tclInt.h *** tclInt.h 2000/08/25 02:04:29 1.50 --- tclInt.h 2000/11/21 17:07:30 *************** *** 1503,1526 **** typedef struct TclFile_ *TclFile; /* - *---------------------------------------------------------------- - * Data structures related to hooking 'TclStat(...)' and - * 'TclAccess(...)'. - *---------------------------------------------------------------- - */ - - typedef int (TclStatProc_) _ANSI_ARGS_((CONST char *path, struct stat *buf)); - typedef int (TclAccessProc_) _ANSI_ARGS_((CONST char *path, int mode)); - typedef Tcl_Channel (TclOpenFileChannelProc_) _ANSI_ARGS_((Tcl_Interp *interp, - char *fileName, char *modeString, - int permissions)); - - typedef int (*TclCmdProcType) _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char *argv[])); - typedef int (*TclObjCmdProcType) _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, struct Tcl_Obj * CONST objv[])); - - /* * Opaque names for platform specific types. */ --- 1503,1508 ---- *************** *** 1528,1534 **** /* * The following structure is used to pass glob type data amongst ! * the various glob routines and TclpMatchFilesTypes. Currently * most of the fields are ignored. However they will be used in * a future release to implement glob's ability to find files * of particular types/permissions/etc only. --- 1510,1516 ---- /* * The following structure is used to pass glob type data amongst ! * the various glob routines and TclMatchFilesTypes. Currently * most of the fields are ignored. However they will be used in * a future release to implement glob's ability to find files * of particular types/permissions/etc only. *************** *** 1562,1568 **** --- 1544,1682 ---- #define TCL_GLOB_PERM_X (1<<4) /* + * The "globParameters" argument of the function TclGlob is an + * or'ed combination of the following values: + */ + + #define GLOBMODE_NO_COMPLAIN 1 + #define GLOBMODE_JOIN 2 + #define GLOBMODE_DIR 4 + #define GLOBMODE_TAILS 8 + + /* + *---------------------------------------------------------------- + * Data structures related to hooking into the filesystem *---------------------------------------------------------------- + */ + + typedef int (TclStatProc_) _ANSI_ARGS_((CONST char *path, struct stat *buf)); + typedef int (TclLstatProc_) _ANSI_ARGS_((CONST char *path, struct stat *buf)); + typedef int (TclAccessProc_) _ANSI_ARGS_((CONST char *path, int mode)); + typedef Tcl_Channel (TclOpenFileChannelProc_) _ANSI_ARGS_((Tcl_Interp *interp, + char *fileName, char *modeString, + int permissions)); + typedef int (TclMatchFilesTypesProc_) _ANSI_ARGS_((Tcl_Interp *interp, + char *separators, Tcl_DString *dirPtr, + char *pattern, char *tail, GlobTypeData * types)); + /* + * Most filesystems need not implement this. It will usually only be + * called once, if 'getcwd' is called before 'chdir' is ever called. + */ + typedef char* (TclGetCwdProc_) _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_DString *cwdPtr)); + /* + * Virtual filesystems need only respond to this with a positive + * return result if the dirName is a valid directory in their + * filesystem. They need not remember the result, since that + * will be automatically remembered for use by GetCwd. + * Real filesystems should carry out the correct action. + */ + typedef int (TclChdirProc_) _ANSI_ARGS_((CONST char *dirName)); + typedef int (TclCreateDirectoryProc_) _ANSI_ARGS_((CONST char *path)); + typedef int (TclDeleteFileProc_) _ANSI_ARGS_((CONST char *path)); + typedef int (TclCopyDirectoryProc_) _ANSI_ARGS_((CONST char *source, + CONST char *dest, Tcl_DString *errorPtr)); + typedef int (TclCopyFileProc_) _ANSI_ARGS_((CONST char *source, + CONST char *dest)); + typedef int (TclRemoveDirectoryProc_) _ANSI_ARGS_((CONST char *path, + int recursive, Tcl_DString *errorPtr)); + typedef int (TclRenameFileProc_) _ANSI_ARGS_((CONST char *source, + CONST char *dest)); + typedef void (TclUnloadFileProc_) _ANSI_ARGS_((ClientData clientData)); + typedef int (TclListVolumesProc_) _ANSI_ARGS_((Tcl_Interp *interp)); + /* Declare utime structure */ + struct utimbuf; + typedef int (TclUtimeProc_) _ANSI_ARGS_((CONST char* fileName, struct utimbuf *tval)); + typedef int (TclFileAttrsCallProc_) _ANSI_ARGS_((Tcl_Interp *interp, + int get, int index, char *fileName, + Tcl_Obj **objPtrRef)); + typedef char * (TclReadlinkProc_) _ANSI_ARGS_((CONST char *fileName, + Tcl_DString *linkPtr)); + typedef int (TclLoadFileProc_) _ANSI_ARGS_((Tcl_Interp * interp, + char * fileName, char * sym1, char * sym2, + Tcl_PackageInitProc ** proc1Ptr, + Tcl_PackageInitProc ** proc2Ptr, + ClientData * clientDataPtr)); + + typedef struct Tcl_FilesystemVersion_ *Tcl_FilesystemVersion; + /* + * Filesystem version tag. This was introduced in 8.4. + */ + + #define TCL_FILESYSTEM_VERSION_1 ((Tcl_FilesystemVersion) 0x1) + + /* + * struct Tcl_Filesystem: + * + * One such structure exists for each type (kind) of filesystem. + * It collects together in one place all the functions that are + * part of the specific filesystem. Tcl always accesses the + * filesystem through one of these structures. + * + * Not all entries need be non-NULL; any which are NULL are simply + * ignored. However, a complete filesystem must provide all of + * these functions. + */ + + typedef struct Tcl_Filesystem { + CONST char *typeName; /* The name of the filesystem. */ + Tcl_FilesystemVersion version; /* Version of the filesystem type. */ + TclStatProc_ *statProc; /* Function to process a 'TclStat()' call */ + TclAccessProc_ *accessProc; /* Function to process a 'TclAccess()' call */ + TclOpenFileChannelProc_ *openFileChannelProc; + /* Function to process a 'Tcl_OpenFileChannel()' call */ + TclMatchFilesTypesProc_ *matchFilesTypesProc; + /* Function to process a 'TclMatchFilesTypes()' */ + TclGetCwdProc_ *getCwdProc; /* Function to process a 'Tcl_GetCwd()' call */ + TclChdirProc_ *chdirProc; /* Function to process a 'Tcl_Chdir()' call */ + TclLstatProc_ *lstatProc; /* Function to process a 'TclLstat()' call */ + TclCopyFileProc_ *copyFileProc; /* Function to process a 'TclCopyFile()' call */ + TclDeleteFileProc_ *deleteFileProc; + /* Function to process a 'TclDeleteFile()' call */ + TclRenameFileProc_ *renameFileProc; + /* Function to process a 'TclRenameFile()' call */ + TclCreateDirectoryProc_ *createDirectoryProc; + /* Function to process a 'TclCreateDirectory()' call */ + TclCopyDirectoryProc_ *copyDirectoryProc; + /* Function to process a 'TclCopyDirectory()' call */ + TclRemoveDirectoryProc_ *removeDirectoryProc; + /* Function to process a 'TclRemoveDirectory()' call */ + TclLoadFileProc_ *loadFileProc; /* Function to process a 'TclLoadFile()' call */ + TclUnloadFileProc_ *unloadFileProc; + /* Function to unload a previously successfully + * loaded file */ + TclReadlinkProc_ *readlinkProc; /* Function to process a 'TclReadlink()' call */ + TclListVolumesProc_ *listVolumesProc; + /* Function to list any filesystem volumes added + * by this filesystem */ + TclFileAttrsCallProc_ *fileAttrsCallProc; + /* Function to process a 'TclFileAttrsCallProc()' call */ + TclUtimeProc_ *utimeProc; /* Function to process a 'TclUtime()' call */ + } Tcl_Filesystem; + + /* + *---------------------------------------------------------------- + * Data structures related to procedures + *---------------------------------------------------------------- + */ + + typedef int (*TclCmdProcType) _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char *argv[])); + typedef int (*TclObjCmdProcType) _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, struct Tcl_Obj * CONST objv[])); + + /* + *---------------------------------------------------------------- * Variables shared among Tcl modules but not used by the outside world. *---------------------------------------------------------------- */ *************** *** 1668,1673 **** --- 1782,1793 ---- Tcl_Parse *parsePtr)); EXTERN void TclExprFloatError _ANSI_ARGS_((Tcl_Interp *interp, double value)); + EXTERN int TclpFileAttrsCallProc _ANSI_ARGS_((Tcl_Interp *interp, + int get, int index, char *fileName, + Tcl_Obj **objPtrRef)); + EXTERN int TclFileAttrsCallProc _ANSI_ARGS_((Tcl_Interp *interp, + int get, int index, char *fileName, + Tcl_Obj **objPtrRef)); EXTERN int TclFileAttrsCmd _ANSI_ARGS_((Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int TclFileCopyCmd _ANSI_ARGS_((Tcl_Interp *interp, *************** *** 1767,1776 **** --- 1887,1906 ---- EXTERN Proc * TclIsProc _ANSI_ARGS_((Command *cmdPtr)); EXTERN int TclJoinThread _ANSI_ARGS_((Tcl_ThreadId id, int* result)); + EXTERN int TclLoadFile _ANSI_ARGS_((Tcl_Interp * interp, + char * fileName, char * sym1, char * sym2, + Tcl_PackageInitProc ** proc1Ptr, + Tcl_PackageInitProc ** proc2Ptr, + ClientData * clientDataPtr, + TclUnloadFileProc_ **unloadProcPtr)); EXTERN Var * TclLookupVar _ANSI_ARGS_((Tcl_Interp *interp, char *part1, char *part2, int flags, char *msg, int createPart1, int createPart2, Var **arrayPtrPtr)); + EXTERN int TclMatchFilesTypes _ANSI_ARGS_((Tcl_Interp * interp, + char * separators, Tcl_DString * dirPtr, + char * pattern, char * tail, + GlobTypeData * types)); EXTERN int TclMathInProgress _ANSI_ARGS_((void)); EXTERN int TclNeedSpace _ANSI_ARGS_((char *start, char *end)); EXTERN Tcl_Obj * TclNewProcBodyObj _ANSI_ARGS_((Proc *procPtr)); *************** *** 1796,1801 **** --- 1926,1937 ---- CONST char *dest, Tcl_DString *errorPtr)); EXTERN int TclpCreateDirectory _ANSI_ARGS_((CONST char *path)); EXTERN int TclpDeleteFile _ANSI_ARGS_((CONST char *path)); + EXTERN int TclCopyFile _ANSI_ARGS_((CONST char *source, + CONST char *dest)); + EXTERN int TclCopyDirectory _ANSI_ARGS_((CONST char *source, + CONST char *dest, Tcl_DString *errorPtr)); + EXTERN int TclCreateDirectory _ANSI_ARGS_((CONST char *path)); + EXTERN int TclDeleteFile _ANSI_ARGS_((CONST char *path)); EXTERN void TclpExit _ANSI_ARGS_((int status)); EXTERN void TclpFinalizeCondition _ANSI_ARGS_(( Tcl_Condition *condPtr)); *************** *** 1822,1827 **** --- 1958,1964 ---- EXTERN void TclpInitPlatform _ANSI_ARGS_((void)); EXTERN void TclpInitUnlock _ANSI_ARGS_((void)); EXTERN int TclpListVolumes _ANSI_ARGS_((Tcl_Interp *interp)); + EXTERN int TclListVolumes _ANSI_ARGS_((Tcl_Interp *interp)); EXTERN void TclpMasterLock _ANSI_ARGS_((void)); EXTERN void TclpMasterUnlock _ANSI_ARGS_((void)); EXTERN int TclpMatchFiles _ANSI_ARGS_((Tcl_Interp *interp, *************** *** 1832,1837 **** --- 1969,1976 ---- int permissions)); EXTERN char * TclpReadlink _ANSI_ARGS_((CONST char *fileName, Tcl_DString *linkPtr)); + EXTERN char * TclReadlink _ANSI_ARGS_((CONST char *fileName, + Tcl_DString *linkPtr)); EXTERN char * TclpRealloc _ANSI_ARGS_((char *ptr, unsigned int size)); EXTERN void TclpReleaseFile _ANSI_ARGS_((TclFile file)); *************** *** 1839,1844 **** --- 1978,1991 ---- int recursive, Tcl_DString *errorPtr)); EXTERN int TclpRenameFile _ANSI_ARGS_((CONST char *source, CONST char *dest)); + EXTERN int TclRemoveDirectory _ANSI_ARGS_((CONST char *path, + int recursive, Tcl_DString *errorPtr)); + EXTERN int TclRenameFile _ANSI_ARGS_((CONST char *source, + CONST char *dest)); + EXTERN int TclRegisterFilesystem _ANSI_ARGS_((ClientData clientData, + Tcl_Filesystem *fsPtr)); + EXTERN int TclUnregisterFilesystem _ANSI_ARGS_((Tcl_Filesystem *fsPtr)); + EXTERN ClientData TclFilesystemData _ANSI_ARGS_((Tcl_Filesystem *fsPtr)); EXTERN void TclpSetInitialEncodings _ANSI_ARGS_((void)); EXTERN void TclpSetVariables _ANSI_ARGS_((Tcl_Interp *interp)); EXTERN VOID * TclpSysAlloc _ANSI_ARGS_((long size, int isBin)); *************** *** 1889,1894 **** --- 2036,2043 ---- char *string, char *proto, int *portPtr)); EXTERN int TclSockMinimumBuffers _ANSI_ARGS_((int sock, int size)); + EXTERN int TclLstat _ANSI_ARGS_((CONST char *path, + struct stat *buf)); EXTERN int TclStat _ANSI_ARGS_((CONST char *path, struct stat *buf)); EXTERN int TclStatDeleteProc _ANSI_ARGS_((TclStatProc_ *proc)); *************** *** 1897,1902 **** --- 2046,2052 ---- EXTERN void TclTransferResult _ANSI_ARGS_((Tcl_Interp *sourceInterp, int result, Tcl_Interp *targetInterp)); EXTERN int TclUpdateReturnInfo _ANSI_ARGS_((Interp *iPtr)); + EXTERN int TclUtime _ANSI_ARGS_((CONST char* fileName, struct utimbuf *tval)); /* *---------------------------------------------------------------- Index: generic/tclIntDecls.h =================================================================== RCS file: /cvsroot/tcl/generic/tclIntDecls.h,v retrieving revision 1.21 diff -c -r1.21 tclIntDecls.h *** tclIntDecls.h 2000/09/28 06:38:21 1.21 --- tclIntDecls.h 2000/11/21 17:07:30 *************** *** 530,535 **** --- 530,538 ---- /* 162 */ EXTERN void TclChannelEventScriptInvoker _ANSI_ARGS_(( ClientData clientData, int flags)); + /* 163 */ + EXTERN char* TclNormalizePath _ANSI_ARGS_((Tcl_Interp* interp, + CONST char * path, Tcl_DString* retPtr)); typedef struct TclIntStubs { int magic; *************** *** 730,735 **** --- 733,739 ---- int (*tclpMatchFilesTypes) _ANSI_ARGS_((Tcl_Interp * interp, char * separators, Tcl_DString * dirPtr, char * pattern, char * tail, GlobTypeData * types)); /* 160 */ int (*tclChannelTransform) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan, Tcl_Obj * cmdObjPtr)); /* 161 */ void (*tclChannelEventScriptInvoker) _ANSI_ARGS_((ClientData clientData, int flags)); /* 162 */ + char* (*tclNormalizePath) _ANSI_ARGS_((Tcl_Interp* interp, CONST char * path, Tcl_DString* retPtr)); /* 163 */ } TclIntStubs; #ifdef __cplusplus *************** *** 1384,1389 **** --- 1388,1397 ---- #ifndef TclChannelEventScriptInvoker #define TclChannelEventScriptInvoker \ (tclIntStubsPtr->tclChannelEventScriptInvoker) /* 162 */ + #endif + #ifndef TclNormalizePath + #define TclNormalizePath \ + (tclIntStubsPtr->tclNormalizePath) /* 163 */ #endif #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */ Index: generic/tclLoad.c =================================================================== RCS file: /cvsroot/tcl/generic/tclLoad.c,v retrieving revision 1.4 diff -c -r1.4 tclLoad.c *** tclLoad.c 1999/12/01 00:08:28 1.4 --- tclLoad.c 2000/11/21 17:07:30 *************** *** 19,25 **** * either dynamically (with the "load" command) or statically (as * indicated by a call to TclGetLoadedPackages). All such packages * are linked together into a single list for the process. Packages ! * are never unloaded, so these structures are never freed. */ typedef struct LoadedPackage { --- 19,26 ---- * either dynamically (with the "load" command) or statically (as * indicated by a call to TclGetLoadedPackages). All such packages * are linked together into a single list for the process. Packages ! * are never unloaded, until the application exits, when ! * TclFinalizeLoad is called, and these structures are freed. */ typedef struct LoadedPackage { *************** *** 32,38 **** * others LC), no "_", as in "Net". * Malloc-ed. */ ClientData clientData; /* Token for the loaded file which should be ! * passed to TclpUnloadFile() when the file * is no longer needed. If fileName is NULL, * then this field is irrelevant. */ Tcl_PackageInitProc *initProc; --- 33,39 ---- * others LC), no "_", as in "Net". * Malloc-ed. */ ClientData clientData; /* Token for the loaded file which should be ! * passed to (*unLoadProcPtr)() when the file * is no longer needed. If fileName is NULL, * then this field is irrelevant. */ Tcl_PackageInitProc *initProc; *************** *** 46,51 **** --- 47,57 ---- * untrusted scripts). NULL means the * package can't be used in unsafe * interpreters. */ + TclUnloadFileProc_ *unLoadProcPtr; + /* Procedure to use to unload this package. + * If NULL, then we do not attempt to unload + * the package. If fileName is NULL, then + * this field is irrelevant. */ struct LoadedPackage *nextPtr; /* Next in list of all packages loaded into * this application process. NULL means *************** *** 119,124 **** --- 125,131 ---- int code, namesMatch, filesMatch; char *p, *tempString, *fullFileName, *packageName; ClientData clientData; + TclUnloadFileProc_ *unLoadProcPtr = NULL; Tcl_UniChar ch; int offset; *************** *** 328,336 **** */ Tcl_MutexLock(&packageMutex); ! code = TclpLoadFile(interp, fullFileName, Tcl_DStringValue(&initName), Tcl_DStringValue(&safeInitName), &initProc, &safeInitProc, ! &clientData); Tcl_MutexUnlock(&packageMutex); if (code != TCL_OK) { goto done; --- 335,343 ---- */ Tcl_MutexLock(&packageMutex); ! code = TclLoadFile(interp, fullFileName, Tcl_DStringValue(&initName), Tcl_DStringValue(&safeInitName), &initProc, &safeInitProc, ! &clientData,&unLoadProcPtr); Tcl_MutexUnlock(&packageMutex); if (code != TCL_OK) { goto done; *************** *** 338,344 **** if (initProc == NULL) { Tcl_AppendResult(interp, "couldn't find procedure ", Tcl_DStringValue(&initName), (char *) NULL); ! TclpUnloadFile(clientData); code = TCL_ERROR; goto done; } --- 345,353 ---- if (initProc == NULL) { Tcl_AppendResult(interp, "couldn't find procedure ", Tcl_DStringValue(&initName), (char *) NULL); ! if (unLoadProcPtr != NULL) { ! (*unLoadProcPtr)(clientData); ! } code = TCL_ERROR; goto done; } *************** *** 355,360 **** --- 364,370 ---- (Tcl_DStringLength(&pkgName) + 1)); strcpy(pkgPtr->packageName, Tcl_DStringValue(&pkgName)); pkgPtr->clientData = clientData; + pkgPtr->unLoadProcPtr = unLoadProcPtr; pkgPtr->initProc = initProc; pkgPtr->safeInitProc = safeInitProc; Tcl_MutexLock(&packageMutex); *************** *** 653,659 **** * call a function in the dll after it's been unloaded. */ if (pkgPtr->fileName[0] != '\0') { ! TclpUnloadFile(pkgPtr->clientData); } #endif ckfree(pkgPtr->fileName); --- 663,672 ---- * call a function in the dll after it's been unloaded. */ if (pkgPtr->fileName[0] != '\0') { ! TclUnloadFileProc_ *unLoadProcPtr = pkgPtr->unLoadProcPtr; ! if (unLoadProcPtr != NULL) { ! (*unLoadProcPtr)(pkgPtr->clientData); ! } } #endif ckfree(pkgPtr->fileName); Index: generic/tclLoadNone.c =================================================================== RCS file: /cvsroot/tcl/generic/tclLoadNone.c,v retrieving revision 1.4 diff -c -r1.4 tclLoadNone.c *** tclLoadNone.c 1999/05/07 20:07:40 1.4 --- tclLoadNone.c 2000/11/21 17:07:30 *************** *** 109,112 **** --- 109,113 ---- * a token that represents the loaded * file. */ { + return TCL_OK; } Index: generic/tclStubInit.c =================================================================== RCS file: /cvsroot/tcl/generic/tclStubInit.c,v retrieving revision 1.46 diff -c -r1.46 tclStubInit.c *** tclStubInit.c 2000/11/03 18:46:12 1.46 --- tclStubInit.c 2000/11/21 17:07:31 *************** *** 242,247 **** --- 242,248 ---- TclpMatchFilesTypes, /* 160 */ TclChannelTransform, /* 161 */ TclChannelEventScriptInvoker, /* 162 */ + TclNormalizePath, /* 163 */ }; TclIntPlatStubs tclIntPlatStubs = { Index: generic/tclTest.c =================================================================== RCS file: /cvsroot/tcl/generic/tclTest.c,v retrieving revision 1.21 diff -c -r1.21 tclTest.c *** tclTest.c 2000/09/28 06:38:22 1.21 --- tclTest.c 2000/11/21 17:07:33 *************** *** 296,302 **** --- 296,398 ---- Tcl_Interp *interp, int argc, char **argv)); static int TestChannelEventCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); + /* Filesystem testing */ + static int TestFilesystemObjCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); + static int VfsFilesystemObjCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); + + static TclStatProc_ TestReportStat; + static TclAccessProc_ TestReportAccess; + static TclOpenFileChannelProc_ TestReportOpenFileChannel; + static TclMatchFilesTypesProc_ TestReportMatchFilesTypes; + static TclGetCwdProc_ TestReportGetCwd; + static TclChdirProc_ TestReportChdir; + static TclLstatProc_ TestReportLstat; + static TclCopyFileProc_ TestReportCopyFile; + static TclDeleteFileProc_ TestReportDeleteFile; + static TclRenameFileProc_ TestReportRenameFile; + static TclCreateDirectoryProc_ TestReportCreateDirectory; + static TclCopyDirectoryProc_ TestReportCopyDirectory; + static TclRemoveDirectoryProc_ TestReportRemoveDirectory; + static TclLoadFileProc_ TestReportLoadFile; + static TclUnloadFileProc_ TestReportUnloadFile; + static TclReadlinkProc_ TestReportReadlink; + static TclListVolumesProc_ TestReportListVolumes; + static TclFileAttrsCallProc_ TestReportFileAttrsCallProc; + static TclUtimeProc_ TestReportUtime; + + static Tcl_Filesystem testReportingFilesystem = { + "reporting", + TCL_FILESYSTEM_VERSION_1, + &TestReportStat, + &TestReportAccess, + &TestReportOpenFileChannel, + &TestReportMatchFilesTypes, + &TestReportGetCwd, + &TestReportChdir, + &TestReportLstat, + &TestReportCopyFile, + &TestReportDeleteFile, + &TestReportRenameFile, + &TestReportCreateDirectory, + &TestReportCopyDirectory, + &TestReportRemoveDirectory, + &TestReportLoadFile, + &TestReportUnloadFile, + &TestReportReadlink, + &TestReportListVolumes, + &TestReportFileAttrsCallProc, + &TestReportUtime + }; + + static TclStatProc_ TclVfsStat; + static TclAccessProc_ TclVfsAccess; + static TclOpenFileChannelProc_ TclVfsOpenFileChannel; + static TclMatchFilesTypesProc_ TclVfsMatchFilesTypes; + static TclChdirProc_ TclVfsChdir; + static TclCopyFileProc_ TclVfsCopyFile; + static TclDeleteFileProc_ TclVfsDeleteFile; + static TclRenameFileProc_ TclVfsRenameFile; + static TclCreateDirectoryProc_ TclVfsCreateDirectory; + static TclCopyDirectoryProc_ TclVfsCopyDirectory; + static TclRemoveDirectoryProc_ TclVfsRemoveDirectory; + static TclLoadFileProc_ TclVfsLoadFile; + static TclUnloadFileProc_ TclVfsUnloadFile; + static TclFileAttrsCallProc_ TclVfsFileAttrsCallProc; + static TclUtimeProc_ TclVfsUtime; + + static Tcl_Filesystem tclVfsFilesystem = { + "tclvfs", + TCL_FILESYSTEM_VERSION_1, + &TclVfsStat, + &TclVfsAccess, + &TclVfsOpenFileChannel, + &TclVfsMatchFilesTypes, + /* We don't need a getcwd */ + NULL, + &TclVfsChdir, + /* Use stat for lstat */ + &TclVfsStat, + &TclVfsCopyFile, + &TclVfsDeleteFile, + &TclVfsRenameFile, + &TclVfsCreateDirectory, + &TclVfsCopyDirectory, + &TclVfsRemoveDirectory, + &TclVfsLoadFile, + &TclVfsUnloadFile, + /* readlink and listvolumes are not important */ + NULL, + NULL, + &TclVfsFileAttrsCallProc, + &TclVfsUtime + }; + + /* * External (platform specific) initialization routine, these declarations * explicitly don't use EXTERN since this code does not get compiled *************** *** 347,352 **** --- 443,452 ---- (Tcl_CmdDeleteProc *) NULL); Tcl_CreateObjCommand(interp, "testwrongnumargs", TestWrongNumArgsObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateObjCommand(interp, "tclvfs::filesystem", VfsFilesystemObjCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateObjCommand(interp, "testfilesystem", TestFilesystemObjCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateCommand(interp, "testaccessproc", TestaccessprocCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateCommand(interp, "testasync", TestasyncCmd, (ClientData) 0, *************** *** 4946,4949 **** --- 5046,5891 ---- Tcl_WrongNumArgs(interp, i, &(objv[3]), msg); return TCL_OK; + } + + /* + *---------------------------------------------------------------------- + * + * TestFilesystemObjCmd -- + * + * This procedure implements the "testfilesystem" command. It is used + * to test TclRegisterFilesystem, TclUnregisterFilesystem, and can + * be used to test that the pluggable filesystem works. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Inserts or removes a filesystem from Tcl's stack. + * + *---------------------------------------------------------------------- + */ + + static int + TestFilesystemObjCmd(dummy, interp, objc, objv) + ClientData dummy; + Tcl_Interp *interp; + int objc; + Tcl_Obj *CONST objv[]; + { + int res; + int onOff; + + if (objc != 2) { + char *cmd = Tcl_GetString(objv[0]); + Tcl_AppendResult(interp, "wrong # args: should be \"", cmd, + " (1 or 0)\"", (char *) NULL); + return TCL_ERROR; + } + if (Tcl_GetBooleanFromObj(interp, objv[1], &onOff) != TCL_OK) { + return TCL_ERROR; + } + if (onOff) { + res = TclRegisterFilesystem((ClientData)interp, &testReportingFilesystem); + if (res == TCL_OK) { + Tcl_SetResult(interp, "registered", TCL_STATIC); + } else { + Tcl_SetResult(interp, "failed", TCL_STATIC); + } + } else { + res = TclUnregisterFilesystem(&testReportingFilesystem); + if (res == TCL_OK) { + Tcl_SetResult(interp, "unregistered", TCL_STATIC); + } else { + Tcl_SetResult(interp, "failed", TCL_STATIC); + } + } + return res; + } + + void TestReport(CONST char* cmd, CONST char* arg1, CONST char* arg2) { + Tcl_Interp* interp = (Tcl_Interp*) TclFilesystemData(&testReportingFilesystem); + if (interp == NULL) { + /* This is bad, but not much we can do about it */ + } else { + Tcl_DString ds; + Tcl_DStringInit(&ds); + Tcl_DStringAppend(&ds, "puts stderr ",-1); + Tcl_DStringStartSublist(&ds); + Tcl_DStringAppendElement(&ds, cmd); + Tcl_DStringAppendElement(&ds, arg1); + Tcl_DStringAppendElement(&ds, arg2); + Tcl_DStringEndSublist(&ds); + Tcl_Eval(interp, Tcl_DStringValue(&ds)); + Tcl_DStringFree(&ds); + } + } + int + TestReportStat(path, buf) + CONST char *path; /* Path of file to stat (in current CP). */ + struct stat *buf; /* Filled with results of stat call. */ + { + TestReport("stat",path, NULL); + return -1; + } + int + TestReportLstat(path, buf) + CONST char *path; /* Path of file to stat (in current CP). */ + struct stat *buf; /* Filled with results of stat call. */ + { + TestReport("lstat",path, NULL); + return -1; + } + int + TestReportAccess(path, mode) + CONST char *path; /* Path of file to access (in current CP). */ + int mode; /* Permission setting. */ + { + TestReport("access",path,NULL); + return -1; + } + Tcl_Channel + TestReportOpenFileChannel(interp, fileName, modeString, permissions) + Tcl_Interp *interp; /* Interpreter for error reporting; + * can be NULL. */ + char *fileName; /* Name of file to open. */ + char *modeString; /* A list of POSIX open modes or + * a string such as "rw". */ + int permissions; /* If the open involves creating a + * file, with what modes to create + * it? */ + { + TestReport("open",fileName, modeString); + return NULL; + } + + int + TestReportMatchFilesTypes( + Tcl_Interp *interp, /* Interpreter to receive results. */ + char *separators, /* Directory separators to pass to TclDoGlob. */ + Tcl_DString *dirPtr, /* Contains path to directory to search. */ + char *pattern, /* Pattern to match against. */ + char *tail, /* Pointer to end of pattern. Tail must + * point to a location in pattern and must + * not be static.*/ + GlobTypeData *types) /* Object containing list of acceptable types. + * May be NULL. */ + { + TestReport("matchfilestypes",(dirPtr == NULL ? "" : Tcl_DStringValue(dirPtr)), + pattern); + return -1; + } + char * + TestReportGetCwd(interp, cwdPtr) + Tcl_Interp *interp; + Tcl_DString *cwdPtr; + { + TestReport("cwd",NULL,NULL); + return NULL; + } + int + TestReportChdir(dirName) + CONST char *dirName; + { + TestReport("chdir",dirName,NULL); + return -1; + } + int + TestReportLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr, clientDataPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + char *fileName; /* Name of the file containing the desired + * code. */ + char *sym1, *sym2; /* Names of two procedures to look up in + * the file's symbol table. */ + Tcl_PackageInitProc **proc1Ptr, **proc2Ptr; + /* Where to return the addresses corresponding + * to sym1 and sym2. */ + ClientData *clientDataPtr; /* Filled with token for dynamically loaded + * file which will be passed back to + * TclpUnloadFile() to unload the file. */ + { + TestReport("loadfile",fileName,NULL); + return -1; + } + void + TestReportUnloadFile(clientData) + ClientData clientData; /* ClientData returned by a previous call + * to TclpLoadFile(). The clientData is + * a token that represents the loaded + * file. */ + { + TestReport("unloadfile",NULL,NULL); + } + char * + TestReportReadlink(path, linkPtr) + CONST char *path; /* Path of file to readlink (UTF-8). */ + Tcl_DString *linkPtr; /* Uninitialized or free DString filled + * with contents of link (UTF-8). */ + { + TestReport("readlink",path,NULL); + return NULL; + } + int + TestReportListVolumes( + Tcl_Interp *interp) /* Interpreter for returning volume list. */ + { + TestReport("listvolumes",NULL,NULL); + return TCL_OK; + } + int + TestReportRenameFile( + CONST char *src, /* Pathname of file or dir to be renamed + * (UTF-8). */ + CONST char *dst) /* New pathname of file or directory + * (UTF-8). */ + { + TestReport("renamefile",src,dst); + return -1; + } + int + TestReportCopyFile( + CONST char *src, /* Pathname of file to be copied (UTF-8). */ + CONST char *dst) /* Pathname of file to copy to (UTF-8). */ + { + TestReport("copyfile",src,dst); + return -1; + } + int + TestReportDeleteFile( + CONST char *path) /* Pathname of file to be removed (UTF-8). */ + { + TestReport("deletefile",path,NULL); + return -1; + } + int + TestReportCreateDirectory( + CONST char *path) /* Pathname of directory to create (UTF-8). */ + { + TestReport("createdirectory",path,NULL); + return -1; + } + int + TestReportCopyDirectory( + CONST char *src, /* Pathname of directory to be copied + * (UTF-8). */ + CONST char *dst, /* Pathname of target directory (UTF-8). */ + Tcl_DString *errorPtr) /* If non-NULL, uninitialized or free + * DString filled with UTF-8 name of file + * causing error. */ + { + TestReport("copydirectory",src,dst); + return -1; + } + int + TestReportRemoveDirectory( + CONST char *path, /* Pathname of directory to be removed + * (UTF-8). */ + int recursive, /* If non-zero, removes directories that + * are nonempty. Otherwise, will only remove + * empty directories. */ + Tcl_DString *errorPtr) /* If non-NULL, uninitialized or free + * DString filled with UTF-8 name of file + * causing error. */ + { + TestReport("removedirectory",path,NULL); + return -1; + } + int + TestReportFileAttrsCallProc(interp, get, index, fileName, objPtrRef) + Tcl_Interp *interp; /* The interpreter for error reporting. */ + int get; /* boolean, 'get' if 1, else 'set'. */ + int index; /* index of the attribute command. */ + char *fileName; /* filename we are operating on. */ + Tcl_Obj **objPtrRef; /* Either for input or output. */ + { + if (get) { + TestReport("fileattributesget",fileName,NULL); + } else { + TestReport("fileattributesset",fileName,Tcl_GetString(*objPtrRef)); + } + return -1; + } + int + TestReportUtime (fileName, tval) + CONST char* fileName; + struct utimbuf *tval; + { + TestReport("utime",fileName,NULL); + return -1; + } + + /* + *---------------------------------------------------------------------- + * + * VfsFilesystemObjCmd -- + * + * This procedure implements the "vfsfilesystem" command. It is used + * to (un)register the vfs filesystem, and to mount/unmount + * particular interfaces to new filesystems, or to query those + * what is mounted where. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Inserts or removes a filesystem from Tcl's stack. + * + *---------------------------------------------------------------------- + */ + + static int + VfsFilesystemObjCmd(dummy, interp, objc, objv) + ClientData dummy; + Tcl_Interp *interp; + int objc; + Tcl_Obj *CONST objv[]; + { + int index; + + static char *optionStrings[] = { + "info", "mount", "register", "unmount", + NULL + }; + enum options { + VFS_INFO, VFS_MOUNT, VFS_REGISTER, VFS_UNMOUNT + }; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?"); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0, + &index) != TCL_OK) { + return TCL_ERROR; + } + + switch ((enum options) index) { + case VFS_REGISTER: { + int onOff; + int res = TCL_OK; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "(1 or 0)"); + return TCL_ERROR; + } + if (Tcl_GetBooleanFromObj(interp, objv[2], &onOff) != TCL_OK) { + return TCL_ERROR; + } + if (onOff) { + ClientData clientData = TclFilesystemData(&tclVfsFilesystem); + if (clientData != NULL) { + Tcl_SetResult(interp, "already registered", TCL_STATIC); + res = TCL_ERROR; + } else { + res = TclRegisterFilesystem((ClientData)interp, &tclVfsFilesystem); + if (res == TCL_OK) { + Tcl_SetResult(interp, "registered", TCL_STATIC); + } else { + Tcl_SetResult(interp, "failed", TCL_STATIC); + } + } + } else { + res = TclUnregisterFilesystem(&tclVfsFilesystem); + if (res == TCL_OK) { + Tcl_SetResult(interp, "unregistered", TCL_STATIC); + } else { + Tcl_SetResult(interp, "failed", TCL_STATIC); + } + } + return res; + } + case VFS_MOUNT: { + char * path; + Tcl_Interp* vfsInterp; + Tcl_DString ds; + if (objc != 4) { + Tcl_WrongNumArgs(interp, 1, objv, "mount path cmd"); + return TCL_ERROR; + } + vfsInterp = (Tcl_Interp*) TclFilesystemData(&tclVfsFilesystem); + if (vfsInterp == NULL) { + Tcl_SetResult(interp, "tclvfs not registered", TCL_STATIC); + return TCL_ERROR; + } + path = TclNormalizePath(interp, Tcl_GetString(objv[2]), &ds); + if (Tcl_SetVar2Ex(vfsInterp, "tclvfs::mount", path, objv[3], + TCL_LEAVE_ERR_MSG | TCL_GLOBAL_ONLY) == NULL) { + Tcl_DStringFree(&ds); + return TCL_ERROR; + } + Tcl_DStringFree(&ds); + break; + } + case VFS_INFO: { + char * path; + Tcl_Interp* vfsInterp; + Tcl_DString ds; + Tcl_Obj * val; + if (objc > 3) { + Tcl_WrongNumArgs(interp, 2, objv, "path"); + return TCL_ERROR; + } + vfsInterp = (Tcl_Interp*) TclFilesystemData(&tclVfsFilesystem); + if (vfsInterp == NULL) { + Tcl_SetResult(interp, "tclvfs not registered", TCL_STATIC); + return TCL_ERROR; + } + if (objc == 2) { + /* List all vfs paths */ + Tcl_GlobalEval(interp, "array names ::tclvfs::mount"); + } else { + path = TclNormalizePath(interp, Tcl_GetString(objv[2]), &ds); + val = Tcl_GetVar2Ex(vfsInterp, "tclvfs::mount", path, + TCL_LEAVE_ERR_MSG | TCL_GLOBAL_ONLY); + + Tcl_DStringFree(&ds); + if (val == NULL) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, val); + } + break; + } + case VFS_UNMOUNT: { + char * path; + Tcl_Interp* vfsInterp; + Tcl_DString ds; + int res; + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "path"); + return TCL_ERROR; + } + vfsInterp = (Tcl_Interp*) TclFilesystemData(&tclVfsFilesystem); + if (vfsInterp == NULL) { + Tcl_SetResult(interp, "tclvfs not registered", TCL_STATIC); + return TCL_ERROR; + } + path = TclNormalizePath(interp, Tcl_GetString(objv[2]), &ds); + res = Tcl_UnsetVar2(vfsInterp, "tclvfs::mount", path, + TCL_LEAVE_ERR_MSG | TCL_GLOBAL_ONLY); + Tcl_DStringFree(&ds); + return res; + } + } + return TCL_OK; + } + + enum returnTypes { NOTHING = 0, CHANNEL = 1, STAT = 2, RESULT = 3 }; + + + int TclVfs(CONST char* cmd, CONST char* path, CONST char* arg2, + int intArg, int returnType, void** returnPtr) { + Tcl_DString normPath; + + char *normed; + Tcl_Obj *mountCmd = NULL; + Tcl_SavedResult savedResult; + int len; + int splitPosition; + int dummyLen; + int returnVal; + + Tcl_Interp* interp = (Tcl_Interp*) TclFilesystemData(&tclVfsFilesystem); + if (interp == NULL) { + /* This is bad, but not much we can do about it */ + return -1; + } + normed = TclNormalizePath(interp, path, &normPath); + len = Tcl_DStringLength(&normPath); + splitPosition = len; + + while (mountCmd == NULL) { + mountCmd = Tcl_GetVar2Ex(interp, "tclvfs::mount", normed, + TCL_GLOBAL_ONLY); + + if (mountCmd != NULL) break; + /* This is platform specific at present */ + if (splitPosition != len) { + normed[splitPosition] = '/'; + } + while ((splitPosition > 0) && (normed[--splitPosition] != '/')) { + /* Do nothing */ + } + /* Terminate the string there */ + if (splitPosition == 0) { + break; + } + normed[splitPosition] = 0; + } + + /* Now either splitPosition is zero, or we found a mount point */ + /* Test for both, just to be sure */ + if ((splitPosition == 0) || (mountCmd == NULL)) { + Tcl_DStringFree(&normPath); + return -1; + } + mountCmd = Tcl_DuplicateObj(mountCmd); + Tcl_IncrRefCount(mountCmd); + if (Tcl_ListObjLength(interp, mountCmd, &dummyLen) == TCL_ERROR) { + return -1; + } + Tcl_ListObjAppendElement(interp, mountCmd, Tcl_NewStringObj(cmd,-1)); + Tcl_ListObjAppendElement(interp, mountCmd, Tcl_NewStringObj(normed,-1)); + if (splitPosition == len) { + Tcl_ListObjAppendElement(interp, mountCmd, Tcl_NewStringObj("",0)); + } else { + Tcl_ListObjAppendElement(interp, mountCmd, Tcl_NewStringObj(normed + splitPosition +1,-1)); + } + Tcl_ListObjAppendElement(interp, mountCmd, Tcl_NewStringObj(arg2,-1)); + Tcl_ListObjAppendElement(interp, mountCmd, Tcl_NewIntObj(intArg)); + + Tcl_SaveResult(interp, &savedResult); + returnVal = Tcl_EvalObjEx(interp, mountCmd, TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT); + if (returnVal == TCL_OK) { + switch ((enum returnTypes)returnType) { + case NOTHING: { + break; + } + case CHANNEL: { + (*returnPtr) = (void*)Tcl_GetChannel(interp, Tcl_GetStringResult(interp), 0); + break; + } + case STAT: { + struct stat* bufPtr = (struct stat*)returnPtr; + int statListLength; + Tcl_Obj* resPtr = Tcl_GetObjResult(interp); + if (Tcl_ListObjLength(interp, resPtr, &statListLength) == TCL_ERROR) { + returnVal = TCL_ERROR; + break; + } + if (statListLength & 1) { + /* It is odd! */ + returnVal = TCL_ERROR; + break; + } + while (statListLength > 0) { + Tcl_Obj *field, *val; + char *fieldName; + statListLength -= 2; + Tcl_ListObjIndex(interp, resPtr, statListLength, &field); + Tcl_ListObjIndex(interp, resPtr, statListLength+1, &val); + fieldName = Tcl_GetString(field); + if (!strcmp(fieldName,"dev")) { + long v; + if (Tcl_GetLongFromObj(interp, val, &v) != TCL_OK) { + returnVal = TCL_ERROR; + break; + } + bufPtr->st_dev = v; + } else if (!strcmp(fieldName,"ino")) { + long v; + if (Tcl_GetLongFromObj(interp, val, &v) != TCL_OK) { + returnVal = TCL_ERROR; + break; + } + bufPtr->st_ino = (unsigned short)v; + } else if (!strcmp(fieldName,"mode")) { + int v; + if (Tcl_GetIntFromObj(interp, val, &v) != TCL_OK) { + returnVal = TCL_ERROR; + break; + } + bufPtr->st_mode = v; + } else if (!strcmp(fieldName,"nlink")) { + long v; + if (Tcl_GetLongFromObj(interp, val, &v) != TCL_OK) { + returnVal = TCL_ERROR; + break; + } + bufPtr->st_nlink = (short)v; + } else if (!strcmp(fieldName,"uid")) { + long v; + if (Tcl_GetLongFromObj(interp, val, &v) != TCL_OK) { + returnVal = TCL_ERROR; + break; + } + bufPtr->st_uid = (short)v; + } else if (!strcmp(fieldName,"gid")) { + long v; + if (Tcl_GetLongFromObj(interp, val, &v) != TCL_OK) { + returnVal = TCL_ERROR; + break; + } + bufPtr->st_gid = (short)v; + } else if (!strcmp(fieldName,"size")) { + long v; + if (Tcl_GetLongFromObj(interp, val, &v) != TCL_OK) { + returnVal = TCL_ERROR; + break; + } + bufPtr->st_size = v; + } else if (!strcmp(fieldName,"atime")) { + long v; + if (Tcl_GetLongFromObj(interp, val, &v) != TCL_OK) { + returnVal = TCL_ERROR; + break; + } + bufPtr->st_atime = v; + } else if (!strcmp(fieldName,"mtime")) { + long v; + if (Tcl_GetLongFromObj(interp, val, &v) != TCL_OK) { + returnVal = TCL_ERROR; + break; + } + bufPtr->st_mtime = v; + } else if (!strcmp(fieldName,"ctime")) { + long v; + if (Tcl_GetLongFromObj(interp, val, &v) != TCL_OK) { + returnVal = TCL_ERROR; + break; + } + bufPtr->st_ctime = v; + } else if (!strcmp(fieldName,"type")) { + long v; + if (Tcl_GetLongFromObj(interp, val, &v) != TCL_OK) { + returnVal = TCL_ERROR; + break; + } + /* Mode already set in 'mode' section */ + /*bufPtr->st_mode = (unsigned short)v;*/ + } else { + returnVal = TCL_ERROR; + break; + } + } + break; + } + case RESULT: { + (*returnPtr) = (void*)Tcl_DuplicateObj(Tcl_GetObjResult(interp)); + break; + } + } + } + Tcl_RestoreResult(interp, &savedResult); + Tcl_DecrRefCount(mountCmd); + /* Restore the DString */ + if (splitPosition != len) { + normed[splitPosition] = '/'; + } + Tcl_DStringFree(&normPath); + return returnVal; + } + + int + TclVfsStat(path, buf) + CONST char *path; /* Path of file to stat (in current CP). */ + struct stat *buf; /* Filled with results of stat call. */ + { + return TclVfs("stat",path, NULL, 0, STAT ,&buf); + } + int + TclVfsAccess(path, mode) + CONST char *path; /* Path of file to access (in current CP). */ + int mode; /* Permission setting. */ + { + return TclVfs("access",path,NULL, 0, NOTHING ,0); + } + Tcl_Channel + TclVfsOpenFileChannel(interp, fileName, modeString, permissions) + Tcl_Interp *interp; /* Interpreter for error reporting; + * can be NULL. */ + char *fileName; /* Name of file to open. */ + char *modeString; /* A list of POSIX open modes or + * a string such as "rw". */ + int permissions; /* If the open involves creating a + * file, with what modes to create + * it? */ + { + Tcl_Channel result = NULL; + TclVfs("open",fileName, modeString, permissions, CHANNEL, &result); + return result; + } + int + TclVfsMatchFilesTypes( + Tcl_Interp *interp, /* Interpreter to receive results. */ + char *separators, /* Directory separators to pass to TclDoGlob. */ + Tcl_DString *dirPtr, /* Contains path to directory to search. */ + char *pattern, /* Pattern to match against. */ + char *tail, /* Pointer to end of pattern. Tail must + * point to a location in pattern and must + * not be static.*/ + GlobTypeData *types) /* Object containing list of acceptable types. + * May be NULL. */ + { + Tcl_Obj *resultPtr; + int retVal; + + if ((retVal = TclVfs("matchfilestypes",(dirPtr == NULL ? "" : Tcl_DStringValue(dirPtr)), + pattern, 0, RESULT ,(void**)&resultPtr)) != -1) { + Tcl_SetObjResult(interp, resultPtr); + } + return retVal; + + } + int + TclVfsChdir(dirName) + CONST char *dirName; + { + return TclVfs("chdir",dirName,NULL,0, NOTHING ,0); + } + + typedef struct TclVfsDivertLoad { + ClientData clientData; + TclUnloadFileProc_ *unloadProcPtr; + Tcl_Obj *divertedFile; + } TclVfsDivertLoad; + + int + TclVfsLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr, clientDataPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + char *fileName; /* Name of the file containing the desired + * code. */ + char *sym1, *sym2; /* Names of two procedures to look up in + * the file's symbol table. */ + Tcl_PackageInitProc **proc1Ptr, **proc2Ptr; + /* Where to return the addresses corresponding + * to sym1 and sym2. */ + ClientData *clientDataPtr; /* Filled with token for dynamically loaded + * file which will be passed back to + * TclpUnloadFile() to unload the file. */ + { + Tcl_Obj *resultPtr; + int retVal; + + if ((retVal = TclVfs("loadfile",fileName,sym1,0, RESULT,(void**)&resultPtr)) != -1) { + if (retVal == TCL_OK) { + int len; + char *str; + str = Tcl_GetStringFromObj(resultPtr, &len); + if (len != 0) { + ClientData newClientData; + TclUnloadFileProc_ *unloadProcPtr; + TclVfsDivertLoad *tvdlPtr; + + /* We want this if the load succeeds */ + Tcl_IncrRefCount(resultPtr); + + /* It is a filename for a file we must try to load */ + retVal = TclLoadFile(interp, str, sym1, sym2, proc1Ptr, + proc2Ptr, &newClientData, &unloadProcPtr); + if (retVal == -1) { + /* This is very strange! */ + return -1; + } + /* When we unload this file, we need to divert the unloading */ + tvdlPtr = (TclVfsDivertLoad*) ckalloc(sizeof(TclVfsDivertLoad)); + + /* + * Remember all of this information. This allows us to + * cleanup the diverted load completely, on platforms + * which allow proper unloading of code. + */ + tvdlPtr->clientData = newClientData; + tvdlPtr->unloadProcPtr = unloadProcPtr; + tvdlPtr->divertedFile = resultPtr; + Tcl_IncrRefCount(resultPtr); + (*clientDataPtr) = (ClientData) tvdlPtr; + if (retVal == TCL_OK) { + Tcl_ResetResult(interp); + } + } + } else { + Tcl_SetObjResult(interp, resultPtr); + } + } + return retVal; + } + void + TclVfsUnloadFile(clientData) + ClientData clientData; /* ClientData returned by a previous call + * to TclpLoadFile(). The clientData is + * a token that represents the loaded + * file. */ + { + /* This test should always be true */ + if (clientData != NULL) { + TclVfsDivertLoad * tvdlPtr = (TclVfsDivertLoad*)clientData; + /* Call the real 'unloadfile' proc we actually used. */ + (*tvdlPtr->unloadProcPtr)(tvdlPtr->clientData); + + /* Now carry out our own action */ + TclVfs("unloadfile",Tcl_GetString(tvdlPtr->divertedFile),NULL,0,NOTHING,0); + /* And free up the allocations */ + Tcl_DecrRefCount(tvdlPtr->divertedFile); + Tcl_Free((char*)tvdlPtr); + } + } + int + TclVfsRenameFile( + CONST char *src, /* Pathname of file or dir to be renamed + * (UTF-8). */ + CONST char *dst) /* New pathname of file or directory + * (UTF-8). */ + { + return TclVfs("renamefile",src,dst,0, NOTHING ,0); + } + int + TclVfsCopyFile( + CONST char *src, /* Pathname of file to be copied (UTF-8). */ + CONST char *dst) /* Pathname of file to copy to (UTF-8). */ + { + return TclVfs("copyfile",src,dst,0, NOTHING ,0); + } + int + TclVfsDeleteFile( + CONST char *path) /* Pathname of file to be removed (UTF-8). */ + { + return TclVfs("deletefile",path,NULL,0, NOTHING,0); + } + int + TclVfsCreateDirectory( + CONST char *path) /* Pathname of directory to create (UTF-8). */ + { + return TclVfs("createdirectory",path,NULL,0, NOTHING ,0); + } + int + TclVfsCopyDirectory( + CONST char *src, /* Pathname of directory to be copied + * (UTF-8). */ + CONST char *dst, /* Pathname of target directory (UTF-8). */ + Tcl_DString *errorPtr) /* If non-NULL, uninitialized or free + * DString filled with UTF-8 name of file + * causing error. */ + { + return TclVfs("copydirectory",src,dst,0, NOTHING ,0); + } + int + TclVfsRemoveDirectory( + CONST char *path, /* Pathname of directory to be removed + * (UTF-8). */ + int recursive, /* If non-zero, removes directories that + * are nonempty. Otherwise, will only remove + * empty directories. */ + Tcl_DString *errorPtr) /* If non-NULL, uninitialized or free + * DString filled with UTF-8 name of file + * causing error. */ + { + return TclVfs("removedirectory",path,NULL, recursive, NOTHING ,0); + } + int + TclVfsFileAttrsCallProc(interp, get, index, fileName, objPtrRef) + Tcl_Interp *interp; /* The interpreter for error reporting. */ + int get; /* boolean, 'get' if 1, else 'set'. */ + int index; /* index of the attribute command. */ + char *fileName; /* filename we are operating on. */ + Tcl_Obj **objPtrRef; /* Either for input or output. */ + { + if (get) { + int retVal; + if ((retVal = TclVfs("fileattributesget",fileName,NULL, index, RESULT,objPtrRef)) != -1) { + Tcl_SetObjResult(interp, *objPtrRef); + } + return retVal; + } else { + return TclVfs("fileattributesset",fileName,Tcl_GetString(*objPtrRef), index, NOTHING ,0); + } + } + int + TclVfsUtime(fileName, tval) + CONST char* fileName; + struct utimbuf *tval; + { + char string[TCL_INTEGER_SPACE]; + TclFormatInt(string, (long) tval->actime); + return TclVfs("utime",fileName,string, tval->modtime, NOTHING ,0); } Index: generic/tclUtil.c =================================================================== RCS file: /cvsroot/tcl/generic/tclUtil.c,v retrieving revision 1.18 diff -c -r1.18 tclUtil.c *** tclUtil.c 2000/05/08 21:59:59 1.18 --- tclUtil.c 2000/11/21 17:07:50 *************** *** 2276,2333 **** /* *---------------------------------------------------------------------- * - * Tcl_GetCwd -- - * - * This function replaces the library version of getcwd(). - * - * Results: - * The result is a pointer to a string specifying the current - * directory, or NULL if the current directory could not be - * determined. If NULL is returned, an error message is left in the - * interp's result. Storage for the result string is allocated in - * bufferPtr; the caller must call Tcl_DStringFree() when the result - * is no longer needed. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - - char * - Tcl_GetCwd(interp, cwdPtr) - Tcl_Interp *interp; - Tcl_DString *cwdPtr; - { - return TclpGetCwd(interp, cwdPtr); - } - - /* - *---------------------------------------------------------------------- - * - * Tcl_Chdir -- - * - * This function replaces the library version of chdir(). - * - * Results: - * See chdir() documentation. - * - * Side effects: - * See chdir() documentation. - * - *---------------------------------------------------------------------- - */ - - int - Tcl_Chdir(dirName) - CONST char *dirName; - { - return TclpChdir(dirName); - } - - /* - *---------------------------------------------------------------------- - * * Tcl_Access -- * * This function replaces the library version of access(). --- 2276,2281 ---- Index: library/dde/pkgIndex.tcl =================================================================== RCS file: /cvsroot/tcl/library/dde/pkgIndex.tcl,v retrieving revision 1.4 diff -c -r1.4 pkgIndex.tcl *** pkgIndex.tcl 2000/04/20 01:30:19 1.4 --- pkgIndex.tcl 2000/11/21 17:07:51 *************** *** 1,5 **** if {[info exists tcl_platform(debug)]} { ! package ifneeded dde 1.1 [list load [file join $dir tcldde83d.dll] dde] } else { ! package ifneeded dde 1.1 [list load [file join $dir tcldde83.dll] dde] } --- 1,5 ---- if {[info exists tcl_platform(debug)]} { ! package ifneeded dde 1.1 [list load [file join $dir tcldde84d.dll] dde] } else { ! package ifneeded dde 1.1 [list load [file join $dir tcldde84.dll] dde] } Index: mac/tclMacFile.c =================================================================== RCS file: /cvsroot/tcl/mac/tclMacFile.c,v retrieving revision 1.9 diff -c -r1.9 tclMacFile.c *** tclMacFile.c 1999/12/12 22:46:45 1.9 --- tclMacFile.c 2000/11/21 17:07:53 *************** *** 312,336 **** return result; } - /* - * TclpMatchFiles -- - * - * This function is now obsolete. Call the above function - * 'TclpMatchFilesTypes' instead. - */ - int - TclpMatchFiles( - Tcl_Interp *interp, /* Interpreter to receive results. */ - char *separators, /* Directory separators to pass to TclDoGlob. */ - Tcl_DString *dirPtr, /* Contains path to directory to search. */ - char *pattern, /* Pattern to match against. */ - char *tail) /* Pointer to end of pattern. Tail must - * point to a location in pattern and must - * not be static.*/ - { - return TclpMatchFilesTypes(interp,separators,dirPtr,pattern,tail,NULL); - } - /* *---------------------------------------------------------------------- * --- 312,317 ---- Index: unix/tclUnixFile.c =================================================================== RCS file: /cvsroot/tcl/unix/tclUnixFile.c,v retrieving revision 1.9 diff -c -r1.9 tclUnixFile.c *** tclUnixFile.c 2000/01/11 22:09:19 1.9 --- tclUnixFile.c 2000/11/21 17:07:54 *************** *** 417,441 **** return result; } - /* - * TclpMatchFiles -- - * - * This function is now obsolete. Call the above function - * 'TclpMatchFilesTypes' instead. - */ - int - TclpMatchFiles(interp, separators, dirPtr, pattern, tail) - Tcl_Interp *interp; /* Interpreter to receive results. */ - char *separators; /* Directory separators to pass to TclDoGlob */ - Tcl_DString *dirPtr; /* Contains path to directory to search. */ - char *pattern; /* Pattern to match against. */ - char *tail; /* Pointer to end of pattern. Tail must - * point to a location in pattern and must - * not be static. */ - { - return TclpMatchFilesTypes(interp,separators,dirPtr,pattern,tail,NULL); - } - /* *--------------------------------------------------------------------------- * --- 417,422 ---- Index: win/makefile.vc =================================================================== RCS file: /cvsroot/tcl/win/makefile.vc,v retrieving revision 1.59 diff -c -r1.59 makefile.vc *** makefile.vc 2000/11/03 21:23:28 1.59 --- makefile.vc 2000/11/21 17:07:54 *************** *** 49,60 **** !ELSE # Visual Studio 5 default ! #TOOLS32 = C:\Progra~1\devstudio\vc ! #TOOLS32_rc = C:\Progra~1\devstudio\sharedide # Visual Studio 6 default ! TOOLS32 = C:\Progra~1\Microsoft Visual Studio\VC98 ! TOOLS32_rc = C:\Progra~1\Microsoft Visual Studio\common\MSDev98 cc32 = "$(TOOLS32)\bin\cl.exe" link32 = "$(TOOLS32)\bin\link.exe" --- 49,60 ---- !ELSE # Visual Studio 5 default ! TOOLS32 = C:\Progra~1\devstudio\vc ! TOOLS32_rc = C:\Progra~1\devstudio\sharedide # Visual Studio 6 default ! #TOOLS32 = C:\Progra~1\Microsoft Visual Studio\VC98 ! #TOOLS32_rc = C:\Progra~1\Microsoft Visual Studio\common\MSDev98 cc32 = "$(TOOLS32)\bin\cl.exe" link32 = "$(TOOLS32)\bin\link.exe" *************** *** 70,76 **** #THREADDEFINES = -DTCL_THREADS=1 # Set NODEBUG to 0 to compile with symbols ! NODEBUG = 1 # The following defines can be used to control the amount of debugging # code that is added to the compilation. --- 70,76 ---- #THREADDEFINES = -DTCL_THREADS=1 # Set NODEBUG to 0 to compile with symbols ! NODEBUG = 0 # The following defines can be used to control the amount of debugging # code that is added to the compilation. Index: win/tclWinFile.c =================================================================== RCS file: /cvsroot/tcl/win/tclWinFile.c,v retrieving revision 1.9 diff -c -r1.9 tclWinFile.c *** tclWinFile.c 2000/10/27 01:58:00 1.9 --- tclWinFile.c 2000/11/21 17:07:54 *************** *** 430,454 **** return TCL_ERROR; } - /* - * TclpMatchFiles -- - * - * This function is now obsolete. Call the above function - * 'TclpMatchFilesTypes' instead. - */ - int - TclpMatchFiles( - Tcl_Interp *interp, /* Interpreter to receive results. */ - char *separators, /* Directory separators to pass to TclDoGlob. */ - Tcl_DString *dirPtr, /* Contains path to directory to search. */ - char *pattern, /* Pattern to match against. */ - char *tail) /* Pointer to end of pattern. Tail must - * point to a location in pattern and must - * not be static.*/ - { - return TclpMatchFilesTypes(interp,separators,dirPtr,pattern,tail,NULL); - } - /* *---------------------------------------------------------------------- * --- 430,435 ----