? doc/FileSystem.3 ? tests/dirtestdir ? tests/load.tcl ? tests/makecore.tcl ? tests/printerror.tcl ? tests/singleprocdir ? tests/test.tcl ? win/httpd Index: doc/file.n =================================================================== RCS file: /cvsroot/tcl/tcl/doc/file.n,v retrieving revision 1.6 diff -c -r1.6 file.n *** doc/file.n 2000/09/07 14:27:47 1.6 --- doc/file.n 2001/03/16 17:08:06 *************** *** 216,221 **** --- 216,231 ---- filename is needed to pass to a platform-specific call, such as exec under Windows or AppleScript on the Macintosh. .TP + \fBfile normalize \fIname\fR + . + Returns a unique normalised path representation for the file, whose string + value can be used as a unique identifier for the it. A normalized path is + one which has all '../', './' removed. Also it is one which is in the + 'standard' format for the native platform. On MacOS, Unix, this means the + path must be free of symbolic links/aliases, and on Windows it means we want + the long form, with the long form's case-dependence (which gives us a + unique, case-dependent path). + .TP \fBfile owned \fIname\fR . Returns \fB1\fR if file \fIname\fR is owned by the current user, \fB0\fR *************** *** 267,272 **** --- 277,290 ---- last ``.'' character in the last component of name. If the last component of \fIname\fR doesn't contain a dot, then returns \fIname\fR. .TP + \fBfile separator ?\fIname\fR? + . + If no argument is given, returns the character which is used to separate + path segments for native files on this platform. If a path is given, + the filesystem responsible for that path is asked to return its + separator character. If no file system accepts \fIname\fR, an error + is generated. + .TP \fBfile size \fIname\fR . Returns a decimal string giving the size of file \fIname\fR in bytes. If *************** *** 302,307 **** --- 320,337 ---- values. The \fBtype\fR element gives the type of the file in the same form returned by the command \fBfile type\fR. This command returns an empty string. + .TP + \fBfile system \fIname\fR + . + Returns a list of two elements, the first of which is the name of + the filesystem to use for the file, and the second the type of the + file within that filesystem. For example the native files have a first + element 'native', and a second element which is a platform-specific + type name for the file (e.g. 'networked'), or possibly the empty string. + A virtual file system might return the list 'vfs ftp' to represent a + file on a remote ftp site mounted as a virtual filesystem through the vfs + extension. + If the file does not belong to any filesystem, an error is generated. .TP \fBfile tail \fIname\fR . Index: doc/glob.n =================================================================== RCS file: /cvsroot/tcl/tcl/doc/glob.n,v retrieving revision 1.8 diff -c -r1.8 glob.n *** doc/glob.n 2000/09/07 14:27:48 1.8 --- doc/glob.n 2001/03/16 17:08:06 *************** *** 52,57 **** --- 52,66 ---- characters. This option may not be used in conjunction with \fB\-directory\fR. .TP + \fB\-tails\fR + Only return the part of each file found which follows the last directory + named in any \fB\-directory\fR or \fB\-path\fR path specification. + Thus \fBglob -tails -dir $dir *\fR is equivalent to + \fBset pwd [pwd] ; cd $dir ; glob *; cd $pwd\fR. For + \fB\-path\fR specifications, the returned names will include the last + path segment, so \fBglob -tails -path /usr/loc */*\fR will return paths + like \fBlocal/bin local/lib\fR etc. + .TP \fB\-types\fR \fItypeList\fR Only list files or directories which match \fItypeList\fR, where the items in the list have two forms. The first form is like the \-type option of Index: generic/tcl.decls =================================================================== RCS file: /cvsroot/tcl/tcl/generic/tcl.decls,v retrieving revision 1.42 diff -c -r1.42 tcl.decls *** generic/tcl.decls 2000/11/03 18:46:10 1.42 --- generic/tcl.decls 2001/03/16 17:08:06 *************** *** 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) *************** *** 1501,1507 **** declare 432 generic { int Tcl_AttemptSetObjLength(Tcl_Obj *objPtr, int length) } ! ############################################################################## # Define the platform specific public Tcl interface. These functions are --- 1501,1512 ---- declare 432 generic { int Tcl_AttemptSetObjLength(Tcl_Obj *objPtr, int length) } ! declare 433 generic { ! int Tcl_DetachChannel(Tcl_Interp* interp, Tcl_Channel channel) ! } ! declare 434 generic { ! int Tcl_IsStandardChannel(Tcl_Channel channel) ! } ############################################################################## # Define the platform specific public Tcl interface. These functions are Index: generic/tclCkalloc.c =================================================================== RCS file: /cvsroot/tcl/tcl/generic/tclCkalloc.c,v retrieving revision 1.10 diff -c -r1.10 tclCkalloc.c *** generic/tclCkalloc.c 2000/12/08 04:22:43 1.10 --- generic/tclCkalloc.c 2001/03/16 17:08:06 *************** *** 1219,1224 **** --- 1219,1225 ---- } if (curTagPtr != NULL) { TclpFree((char *) curTagPtr); + curTagPtr = NULL; } allocHead = NULL; Tcl_MutexUnlock(ckallocMutexPtr); Index: generic/tclCmdAH.c =================================================================== RCS file: /cvsroot/tcl/tcl/generic/tclCmdAH.c,v retrieving revision 1.12 diff -c -r1.12 tclCmdAH.c *** generic/tclCmdAH.c 2000/01/21 02:25:26 1.12 --- generic/tclCmdAH.c 2001/03/16 17:08:07 *************** *** 18,24 **** #include "tclPort.h" #include ! typedef int (StatProc)_ANSI_ARGS_((CONST char *path, struct stat *buf)); /* * Prototypes for local procedures defined in this file: --- 18,24 ---- #include "tclPort.h" #include ! typedef int (StatProc) _ANSI_ARGS_((CONST char *path, struct stat *buf)); /* * Prototypes for local procedures defined in this file: *************** *** 27,41 **** static int CheckAccess _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr, int mode)); static int GetStatBuf _ANSI_ARGS_((Tcl_Interp *interp, ! Tcl_Obj *objPtr, StatProc *statProc, struct stat *statPtr)); static char * GetTypeFromMode _ANSI_ARGS_((int mode)); static int SplitPath _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr, int *argcPtr, char ***argvPtr)); static int StoreStatData _ANSI_ARGS_((Tcl_Interp *interp, char *varName, struct stat *statPtr)); - static char ** StringifyObjects _ANSI_ARGS_((int objc, - Tcl_Obj *CONST objv[])); /* *---------------------------------------------------------------------- --- 27,39 ---- static int CheckAccess _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr, int mode)); static int GetStatBuf _ANSI_ARGS_((Tcl_Interp *interp, ! Tcl_Obj *objPtr, TclfsStatProc_ *statProc, struct stat *statPtr)); static char * GetTypeFromMode _ANSI_ARGS_((int mode)); static int SplitPath _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr, int *argcPtr, char ***argvPtr)); static int StoreStatData _ANSI_ARGS_((Tcl_Interp *interp, char *varName, struct stat *statPtr)); /* *---------------------------------------------------------------------- *************** *** 307,314 **** int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { ! char *dirName; ! Tcl_DString ds; int result; if (objc > 2) { --- 305,311 ---- int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { ! Tcl_Obj *dir; int result; if (objc > 2) { *************** *** 317,339 **** } if (objc == 2) { ! dirName = Tcl_GetString(objv[1]); } else { ! dirName = "~"; } ! if (Tcl_TranslateFileName(interp, dirName, &ds) == NULL) { ! return TCL_ERROR; } ! ! result = Tcl_Chdir(Tcl_DStringValue(&ds)); ! Tcl_DStringFree(&ds); ! ! if (result != 0) { ! Tcl_AppendResult(interp, "couldn't change working directory to \"", ! dirName, "\": ", Tcl_PosixError(interp), (char *) NULL); ! return TCL_ERROR; } ! return TCL_OK; } /* --- 314,338 ---- } if (objc == 2) { ! dir = objv[1]; } else { ! dir = Tcl_NewStringObj("~",1); ! Tcl_IncrRefCount(dir); } ! if (Tcl_FSConvertToPathType(interp, dir) != TCL_OK) { ! result = TCL_ERROR; ! } else { ! result = Tcl_FSChdir(dir); ! if (result != TCL_OK) { ! Tcl_AppendResult(interp, "couldn't change working directory to \"", ! Tcl_GetString(dir), "\": ", Tcl_PosixError(interp), (char *) NULL); ! result = TCL_ERROR; ! } } ! if (objc != 2) { ! Tcl_DecrRefCount(dir); } ! return result; } /* *************** *** 765,771 **** * See the user documentation for details on what it does. * PLEASE NOTE THAT THIS FAILS WITH FILENAMES AND PATHS WITH * EMBEDDED NULLS, WHICH COULD THEORETICALLY HAPPEN ON A MAC. ! * * Results: * A standard Tcl result. * --- 764,772 ---- * See the user documentation for details on what it does. * PLEASE NOTE THAT THIS FAILS WITH FILENAMES AND PATHS WITH * EMBEDDED NULLS, WHICH COULD THEORETICALLY HAPPEN ON A MAC. ! * With the object-based Tcl_FS APIs, the above NOTE may no ! * longer be true. In any case this assertion should be tested. ! * * Results: * A standard Tcl result. * *************** *** 795,803 **** "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", (char *) NULL }; --- 796,806 ---- "delete", "dirname", "executable", "exists", "extension", "isdirectory", "isfile", "join", "lstat", ! "mtime", "mkdir", "nativename", ! "normalize", "owned", "pathtype", "readable", "readlink", "rename", ! "rootname", "separator", "size", "split", ! "stat", "system", "tail", "type", "volumes", "writable", (char *) NULL }; *************** *** 806,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_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 }; --- 809,819 ---- 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_SEPARATOR, FILE_SIZE, FILE_SPLIT, ! FILE_STAT, FILE_SYSTEM, FILE_TAIL, FILE_TYPE, FILE_VOLUMES, FILE_WRITABLE }; *************** *** 825,838 **** switch ((enum options) index) { case FILE_ATIME: { struct stat buf; - char *fileName; struct utimbuf tval; if ((objc < 3) || (objc > 4)) { Tcl_WrongNumArgs(interp, 2, objv, "name ?time?"); return TCL_ERROR; } ! if (GetStatBuf(interp, objv[2], TclStat, &buf) != TCL_OK) { return TCL_ERROR; } if (objc == 4) { --- 830,842 ---- switch ((enum options) index) { case FILE_ATIME: { struct stat buf; struct utimbuf tval; if ((objc < 3) || (objc > 4)) { Tcl_WrongNumArgs(interp, 2, objv, "name ?time?"); return TCL_ERROR; } ! if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) { return TCL_ERROR; } if (objc == 4) { *************** *** 842,852 **** } 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, "\": ", Tcl_PosixError(interp), (char *) NULL); return TCL_ERROR; } --- 846,855 ---- } tval.actime = buf.st_atime; tval.modtime = buf.st_mtime; ! if (Tcl_FSUtime(objv[2], &tval) != 0) { Tcl_AppendStringsToObj(resultPtr, "could not set access time for file \"", ! Tcl_GetString(objv[2]), "\": ", Tcl_PosixError(interp), (char *) NULL); return TCL_ERROR; } *************** *** 856,862 **** * one we sent in. However, fs's like FAT don't * even know what atime is. */ ! if (GetStatBuf(interp, objv[2], TclStat, &buf) != TCL_OK) { return TCL_ERROR; } } --- 859,865 ---- * one we sent in. However, fs's like FAT don't * even know what atime is. */ ! if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) { return TCL_ERROR; } } *************** *** 875,900 **** ((objc == 2) ? NULL : Tcl_GetString(objv[2]))); } case FILE_COPY: { ! int result; ! char **argv; ! ! argv = StringifyObjects(objc, objv); ! result = TclFileCopyCmd(interp, objc, argv); ! ckfree((char *) argv); ! return result; } case FILE_DELETE: { ! int result; ! char **argv; ! ! argv = StringifyObjects(objc, objv); ! result = TclFileDeleteCmd(interp, objc, argv); ! ckfree((char *) argv); ! return result; } case FILE_DIRNAME: { int argc; ! char **argv; if (objc != 3) { goto only3Args; --- 878,891 ---- ((objc == 2) ? NULL : Tcl_GetString(objv[2]))); } case FILE_COPY: { ! return TclFileCopyCmd(interp, objc, objv); } case FILE_DELETE: { ! return TclFileDeleteCmd(interp, objc, objv); } case FILE_DIRNAME: { int argc; ! char ** argv; if (objc != 3) { goto only3Args; *************** *** 913,919 **** Tcl_DString ds; Tcl_DStringInit(&ds); ! Tcl_JoinPath(argc - 1, argv, &ds); Tcl_SetStringObj(resultPtr, Tcl_DStringValue(&ds), Tcl_DStringLength(&ds)); Tcl_DStringFree(&ds); --- 904,910 ---- Tcl_DString ds; Tcl_DStringInit(&ds); ! Tcl_JoinPath(argc - 1, (CONST char **)argv, &ds); Tcl_SetStringObj(resultPtr, Tcl_DStringValue(&ds), Tcl_DStringLength(&ds)); Tcl_DStringFree(&ds); *************** *** 959,965 **** goto only3Args; } value = 0; ! if (GetStatBuf(NULL, objv[2], TclStat, &buf) == TCL_OK) { value = S_ISDIR(buf.st_mode); } Tcl_SetBooleanObj(resultPtr, value); --- 950,956 ---- goto only3Args; } value = 0; ! if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) { value = S_ISDIR(buf.st_mode); } Tcl_SetBooleanObj(resultPtr, value); *************** *** 973,999 **** goto only3Args; } value = 0; ! if (GetStatBuf(NULL, objv[2], TclStat, &buf) == TCL_OK) { value = S_ISREG(buf.st_mode); } Tcl_SetBooleanObj(resultPtr, value); return TCL_OK; } case FILE_JOIN: { ! char **argv; ! Tcl_DString ds; if (objc < 3) { Tcl_WrongNumArgs(interp, 2, objv, "name ?name ...?"); return TCL_ERROR; } ! argv = StringifyObjects(objc - 2, objv + 2); ! Tcl_DStringInit(&ds); ! Tcl_JoinPath(objc - 2, argv, &ds); ! Tcl_SetStringObj(resultPtr, Tcl_DStringValue(&ds), ! Tcl_DStringLength(&ds)); ! Tcl_DStringFree(&ds); ! ckfree((char *) argv); return TCL_OK; } case FILE_LSTAT: { --- 964,984 ---- goto only3Args; } value = 0; ! if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) { value = S_ISREG(buf.st_mode); } Tcl_SetBooleanObj(resultPtr, value); return TCL_OK; } case FILE_JOIN: { ! Tcl_Obj *resObj; if (objc < 3) { Tcl_WrongNumArgs(interp, 2, objv, "name ?name ...?"); return TCL_ERROR; } ! resObj = Tcl_FSJoinToPath(NULL, objc - 2, objv + 2); ! Tcl_SetObjResult(interp, resObj); return TCL_OK; } case FILE_LSTAT: { *************** *** 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]); --- 989,995 ---- Tcl_WrongNumArgs(interp, 2, objv, "name varName"); return TCL_ERROR; } ! if (GetStatBuf(interp, objv[2], Tcl_FSLstat, &buf) != TCL_OK) { return TCL_ERROR; } varName = Tcl_GetString(objv[3]); *************** *** 1012,1025 **** } case FILE_MTIME: { struct stat buf; - char *fileName; struct utimbuf tval; if ((objc < 3) || (objc > 4)) { Tcl_WrongNumArgs(interp, 2, objv, "name ?time?"); return TCL_ERROR; } ! if (GetStatBuf(interp, objv[2], TclStat, &buf) != TCL_OK) { return TCL_ERROR; } if (objc == 4) { --- 997,1009 ---- } case FILE_MTIME: { struct stat buf; struct utimbuf tval; if ((objc < 3) || (objc > 4)) { Tcl_WrongNumArgs(interp, 2, objv, "name ?time?"); return TCL_ERROR; } ! if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) { return TCL_ERROR; } if (objc == 4) { *************** *** 1029,1039 **** } 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, "\": ", Tcl_PosixError(interp), (char *) NULL); return TCL_ERROR; } --- 1013,1022 ---- } tval.actime = buf.st_atime; tval.modtime = buf.st_mtime; ! if (Tcl_FSUtime(objv[2], &tval) != 0) { Tcl_AppendStringsToObj(resultPtr, "could not set modification time for file \"", ! Tcl_GetString(objv[2]), "\": ", Tcl_PosixError(interp), (char *) NULL); return TCL_ERROR; } *************** *** 1043,1049 **** * one we sent in. However, fs's like FAT don't * even know what atime is. */ ! if (GetStatBuf(interp, objv[2], TclStat, &buf) != TCL_OK) { return TCL_ERROR; } } --- 1026,1032 ---- * one we sent in. However, fs's like FAT don't * even know what atime is. */ ! if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) { return TCL_ERROR; } } *************** *** 1051,1067 **** return TCL_OK; } case FILE_MKDIR: { - char **argv; - int result; - if (objc < 3) { Tcl_WrongNumArgs(interp, 2, objv, "name ?name ...?"); return TCL_ERROR; } ! argv = StringifyObjects(objc, objv); ! result = TclFileMakeDirsCmd(interp, objc, argv); ! ckfree((char *) argv); ! return result; } case FILE_NATIVENAME: { char *fileName; --- 1034,1044 ---- return TCL_OK; } case FILE_MKDIR: { if (objc < 3) { Tcl_WrongNumArgs(interp, 2, objv, "name ?name ...?"); return TCL_ERROR; } ! return TclFileMakeDirsCmd(interp, objc, objv); } case FILE_NATIVENAME: { char *fileName; *************** *** 1079,1084 **** --- 1056,1073 ---- Tcl_DStringFree(&ds); return TCL_OK; } + case FILE_NORMALIZE: { + Tcl_Obj *fileName; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "filename"); + return TCL_ERROR; + } + + fileName = Tcl_FSGetNormalizedPath(interp, objv[2]); + Tcl_SetObjResult(interp, fileName); + return TCL_OK; + } case FILE_OWNED: { int value; struct stat buf; *************** *** 1087,1093 **** goto only3Args; } value = 0; ! if (GetStatBuf(NULL, objv[2], TclStat, &buf) == TCL_OK) { /* * For Windows and Macintosh, there are no user ids * associated with a file, so we always return 1. --- 1076,1082 ---- goto only3Args; } value = 0; ! if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) { /* * For Windows and Macintosh, there are no user ids * associated with a file, so we always return 1. *************** *** 1129,1180 **** return CheckAccess(interp, objv[2], R_OK); } case FILE_READLINK: { ! char *fileName, *contents; ! Tcl_DString name, link; if (objc != 3) { goto only3Args; } ! fileName = Tcl_GetString(objv[2]); ! fileName = Tcl_TranslateFileName(interp, fileName, &name); ! 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) { Tcl_AppendResult(interp, "could not readlink \"", Tcl_GetString(objv[2]), "\": ", Tcl_PosixError(interp), (char *) NULL); return TCL_ERROR; } ! Tcl_DStringResult(interp, &link); return TCL_OK; } case FILE_RENAME: { ! int result; ! char **argv; ! ! argv = StringifyObjects(objc, objv); ! result = TclFileRenameCmd(interp, objc, argv); ! ckfree((char *) argv); ! return result; } case FILE_ROOTNAME: { int length; --- 1118,1147 ---- return CheckAccess(interp, objv[2], R_OK); } case FILE_READLINK: { ! Tcl_Obj *contents; if (objc != 3) { goto only3Args; } ! if (Tcl_FSConvertToPathType(interp, objv[2]) != TCL_OK) { return TCL_ERROR; } ! contents = Tcl_FSReadlink(objv[2]); if (contents == NULL) { Tcl_AppendResult(interp, "could not readlink \"", Tcl_GetString(objv[2]), "\": ", Tcl_PosixError(interp), (char *) NULL); return TCL_ERROR; } ! Tcl_SetObjResult(interp, contents); ! Tcl_DecrRefCount(contents); return TCL_OK; } case FILE_RENAME: { ! return TclFileRenameCmd(interp, objc, objv); } case FILE_ROOTNAME: { int length; *************** *** 1193,1226 **** } return TCL_OK; } case FILE_SIZE: { struct stat buf; if (objc != 3) { goto only3Args; } ! if (GetStatBuf(interp, objv[2], TclStat, &buf) != TCL_OK) { return TCL_ERROR; } Tcl_SetLongObj(resultPtr, (long) buf.st_size); return TCL_OK; } case FILE_SPLIT: { - int i, argc; - char **argv; - char *fileName; - Tcl_Obj *objPtr; - if (objc != 3) { goto only3Args; } ! fileName = Tcl_GetString(objv[2]); ! Tcl_SplitPath(fileName, &argc, &argv); ! for (i = 0; i < argc; i++) { ! objPtr = Tcl_NewStringObj(argv[i], -1); ! Tcl_ListObjAppendElement(NULL, resultPtr, objPtr); ! } ! ckfree((char *) argv); return TCL_OK; } case FILE_STAT: { --- 1160,1213 ---- } return TCL_OK; } + case FILE_SEPARATOR: { + if ((objc < 2) || (objc > 3)) { + Tcl_WrongNumArgs(interp, 2, objv, "?name?"); + return TCL_ERROR; + } + if (objc == 2) { + char *separator = NULL; /* lint */ + switch (tclPlatform) { + case TCL_PLATFORM_UNIX: + separator = "/"; + break; + case TCL_PLATFORM_WINDOWS: + separator = "\\"; + break; + case TCL_PLATFORM_MAC: + separator = ":"; + break; + } + Tcl_SetObjResult(interp, Tcl_NewStringObj(separator,1)); + } else { + Tcl_Obj *separatorObj = Tcl_FSPathSeparator(objv[2]); + if (separatorObj != NULL) { + Tcl_SetObjResult(interp, separatorObj); + } else { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("Unrecognised path",-1)); + return TCL_ERROR; + } + } + return TCL_OK; + } case FILE_SIZE: { struct stat buf; if (objc != 3) { goto only3Args; } ! if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) { return TCL_ERROR; } Tcl_SetLongObj(resultPtr, (long) buf.st_size); return TCL_OK; } case FILE_SPLIT: { if (objc != 3) { goto only3Args; } ! Tcl_SetObjResult(interp, Tcl_FSSplitPath(objv[2], NULL)); return TCL_OK; } case FILE_STAT: { *************** *** 1231,1242 **** Tcl_WrongNumArgs(interp, 1, objv, "stat name varName"); return TCL_ERROR; } ! if (GetStatBuf(interp, objv[2], TclStat, &buf) != TCL_OK) { return TCL_ERROR; } varName = Tcl_GetString(objv[3]); return StoreStatData(interp, varName, &buf); } case FILE_TAIL: { int argc; char **argv; --- 1218,1244 ---- Tcl_WrongNumArgs(interp, 1, objv, "stat name varName"); return TCL_ERROR; } ! if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) { return TCL_ERROR; } varName = Tcl_GetString(objv[3]); return StoreStatData(interp, varName, &buf); } + case FILE_SYSTEM: { + Tcl_Obj* fsInfo; + if (objc != 3) { + goto only3Args; + } + fsInfo = Tcl_FSFileSystemInfo(objv[2]); + if (fsInfo != NULL) { + Tcl_SetObjResult(interp, fsInfo); + return TCL_OK; + } else { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("Unrecognised path",-1)); + return TCL_ERROR; + } + } case FILE_TAIL: { int argc; char **argv; *************** *** 1268,1274 **** if (objc != 3) { goto only3Args; } ! if (GetStatBuf(interp, objv[2], TclpLstat, &buf) != TCL_OK) { return TCL_ERROR; } Tcl_SetStringObj(resultPtr, --- 1270,1276 ---- if (objc != 3) { goto only3Args; } ! if (GetStatBuf(interp, objv[2], Tcl_FSLstat, &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) { --- 1282,1288 ---- Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; } ! return Tcl_FSListVolumes(interp); } case FILE_WRITABLE: { if (objc != 3) { *************** *** 1379,1394 **** * access(). */ { int value; - char *fileName; - Tcl_DString ds; ! fileName = Tcl_GetString(objPtr); ! fileName = Tcl_TranslateFileName(interp, fileName, &ds); ! if (fileName == NULL) { value = 0; } else { ! value = (TclAccess(fileName, mode) == 0); ! Tcl_DStringFree(&ds); } Tcl_SetBooleanObj(Tcl_GetObjResult(interp), value); --- 1381,1391 ---- * access(). */ { int value; ! if (Tcl_FSConvertToPathType(interp, objPtr) != TCL_OK) { value = 0; } else { ! value = (Tcl_FSAccess(objPtr, mode) == 0); } Tcl_SetBooleanObj(Tcl_GetObjResult(interp), value); *************** *** 1419,1441 **** GetStatBuf(interp, objPtr, statProc, statPtr) Tcl_Interp *interp; /* Interp for error return. May be NULL. */ Tcl_Obj *objPtr; /* Path name to examine. */ ! StatProc *statProc; /* Either stat() or lstat() depending on * desired behavior. */ struct stat *statPtr; /* Filled with info about file obtained by * calling (*statProc)(). */ { - char *fileName; - Tcl_DString ds; int status; ! fileName = Tcl_GetString(objPtr); ! fileName = Tcl_TranslateFileName(interp, fileName, &ds); ! if (fileName == NULL) { return TCL_ERROR; } ! status = (*statProc)(Tcl_DStringValue(&ds), statPtr); ! Tcl_DStringFree(&ds); if (status < 0) { if (interp != NULL) { --- 1416,1433 ---- GetStatBuf(interp, objPtr, statProc, statPtr) Tcl_Interp *interp; /* Interp for error return. May be NULL. */ Tcl_Obj *objPtr; /* Path name to examine. */ ! TclfsStatProc_ *statProc; /* Either stat() or lstat() depending on * desired behavior. */ struct stat *statPtr; /* Filled with info about file obtained by * calling (*statProc)(). */ { int status; ! if (Tcl_FSConvertToPathType(interp, objPtr) != TCL_OK) { return TCL_ERROR; } ! status = (*statProc)(objPtr, statPtr); if (status < 0) { if (interp != NULL) { *************** *** 2344,2387 **** } Tcl_DecrRefCount(resultPtr); return TCL_ERROR; - } - - /* - *--------------------------------------------------------------------------- - * - * StringifyObjects -- - * - * Helper function to bridge the gap between an object-based procedure - * and an older string-based procedure. - * - * Given an array of objects, allocate an array that consists of the - * string representations of those objects. - * - * Results: - * The return value is a pointer to the newly allocated array of - * strings. Elements 0 to (objc-1) of the string array point to the - * string representation of the corresponding element in the source - * object array; element objc of the string array is NULL. - * - * Side effects: - * Memory allocated. The caller must eventually free this memory - * by calling ckfree() on the return value. - * - *--------------------------------------------------------------------------- - */ - - static char ** - StringifyObjects(objc, objv) - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ - { - int i; - char **argv; - - argv = (char **) ckalloc((objc + 1) * sizeof(char *)); - for (i = 0; i < objc; i++) { - argv[i] = Tcl_GetString(objv[i]); - } - argv[i] = NULL; - return argv; } --- 2336,2339 ---- Index: generic/tclCmdIL.c =================================================================== RCS file: /cvsroot/tcl/tcl/generic/tclCmdIL.c,v retrieving revision 1.29 diff -c -r1.29 tclCmdIL.c *** generic/tclCmdIL.c 2000/11/23 15:53:26 1.29 --- generic/tclCmdIL.c 2001/03/16 17:08:07 *************** *** 1607,1623 **** } if (objc == 3) { - int length; - char *filename = Tcl_GetStringFromObj(objv[2], &length); - if (iPtr->scriptFile != NULL) { ! ckfree(iPtr->scriptFile); } ! iPtr->scriptFile = ckalloc((unsigned) (length + 1)); ! strcpy(iPtr->scriptFile, filename); } if (iPtr->scriptFile != NULL) { ! Tcl_SetStringObj(Tcl_GetObjResult(interp), iPtr->scriptFile, -1); } return TCL_OK; } --- 1607,1620 ---- } if (objc == 3) { if (iPtr->scriptFile != NULL) { ! Tcl_DecrRefCount(iPtr->scriptFile); } ! iPtr->scriptFile = objv[2]; ! Tcl_IncrRefCount(iPtr->scriptFile); } if (iPtr->scriptFile != NULL) { ! Tcl_SetObjResult(interp, iPtr->scriptFile); } return TCL_OK; } Index: generic/tclCmdMZ.c =================================================================== RCS file: /cvsroot/tcl/tcl/generic/tclCmdMZ.c,v retrieving revision 1.30 diff -c -r1.30 tclCmdMZ.c *** generic/tclCmdMZ.c 2000/09/20 01:50:38 1.30 --- generic/tclCmdMZ.c 2001/03/16 17:08:07 *************** *** 118,134 **** int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { ! Tcl_DString ds; if (objc != 1) { Tcl_WrongNumArgs(interp, 1, objv, NULL); return TCL_ERROR; } ! if (Tcl_GetCwd(interp, &ds) == NULL) { return TCL_ERROR; } ! Tcl_DStringResult(interp, &ds); return TCL_OK; } --- 118,136 ---- int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { ! Tcl_Obj *retVal; if (objc != 1) { Tcl_WrongNumArgs(interp, 1, objv, NULL); return TCL_ERROR; } ! retVal = Tcl_FSGetCwd(interp); ! if (retVal == NULL) { return TCL_ERROR; } ! Tcl_SetObjResult(interp, retVal); ! Tcl_DecrRefCount(retVal); return TCL_OK; } *************** *** 876,892 **** int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { - char *bytes; - int result; - if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "fileName"); return TCL_ERROR; } ! bytes = Tcl_GetString(objv[1]); ! result = Tcl_EvalFile(interp, bytes); ! return result; } /* --- 878,889 ---- int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "fileName"); return TCL_ERROR; } ! return Tcl_FSEvalFile(interp, objv[1]); } /* Index: generic/tclDecls.h =================================================================== RCS file: /cvsroot/tcl/tcl/generic/tclDecls.h,v retrieving revision 1.43 diff -c -r1.43 tclDecls.h *** generic/tclDecls.h 2000/11/03 18:46:11 1.43 --- generic/tclDecls.h 2001/03/16 17:08:08 *************** *** 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)); *************** *** 1350,1355 **** --- 1350,1361 ---- /* 432 */ EXTERN int Tcl_AttemptSetObjLength _ANSI_ARGS_(( Tcl_Obj * objPtr, int length)); + /* 433 */ + EXTERN int Tcl_DetachChannel _ANSI_ARGS_((Tcl_Interp* interp, + Tcl_Channel channel)); + /* 434 */ + EXTERN int Tcl_IsStandardChannel _ANSI_ARGS_(( + Tcl_Channel channel)); typedef struct TclStubHooks { struct TclPlatStubs *tclPlatStubs; *************** *** 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 */ --- 1567,1573 ---- #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 */ --- 1585,1591 ---- 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 */ *************** *** 1850,1855 **** --- 1856,1863 ---- char * (*tcl_AttemptRealloc) _ANSI_ARGS_((char * ptr, unsigned int size)); /* 430 */ char * (*tcl_AttemptDbCkrealloc) _ANSI_ARGS_((char * ptr, unsigned int size, char * file, int line)); /* 431 */ int (*tcl_AttemptSetObjLength) _ANSI_ARGS_((Tcl_Obj * objPtr, int length)); /* 432 */ + int (*tcl_DetachChannel) _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Channel channel)); /* 433 */ + int (*tcl_IsStandardChannel) _ANSI_ARGS_((Tcl_Channel channel)); /* 434 */ } TclStubs; #ifdef __cplusplus *************** *** 3629,3634 **** --- 3637,3650 ---- #ifndef Tcl_AttemptSetObjLength #define Tcl_AttemptSetObjLength \ (tclStubsPtr->tcl_AttemptSetObjLength) /* 432 */ + #endif + #ifndef Tcl_DetachChannel + #define Tcl_DetachChannel \ + (tclStubsPtr->tcl_DetachChannel) /* 433 */ + #endif + #ifndef Tcl_IsStandardChannel + #define Tcl_IsStandardChannel \ + (tclStubsPtr->tcl_IsStandardChannel) /* 434 */ #endif #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */ Index: generic/tclEncoding.c =================================================================== RCS file: /cvsroot/tcl/tcl/generic/tclEncoding.c,v retrieving revision 1.6 diff -c -r1.6 tclEncoding.c *** generic/tclEncoding.c 2000/12/08 18:55:58 1.6 --- generic/tclEncoding.c 2001/03/16 17:08:08 *************** *** 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,584 ---- if (pathPtr != NULL) { int i, objc; Tcl_Obj **objv; char globArgString[10]; ! Tcl_Obj* encodingObj = Tcl_NewStringObj("encoding",-1); ! Tcl_IncrRefCount(encodingObj); ! objc = 0; Tcl_ListObjGetElements(NULL, pathPtr, &objc, &objv); for (i = 0; i < objc; i++) { ! Tcl_Obj *searchIn; ! ! /* ! * Construct the path from the element of pathPtr, ! * joined with 'encoding'. ! */ ! searchIn = Tcl_FSJoinToPath(objv[i],1,&encodingObj); ! Tcl_IncrRefCount(searchIn); Tcl_ResetResult(interp); /* *************** *** 586,600 **** */ 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, &objv2); for (j = 0; j < objc2; j++) { string = Tcl_GetStringFromObj(objv2[j], &length); length -= 4; if (length > 0) { --- 588,609 ---- */ 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, searchIn, ! GLOBMODE_TAILS, NULL) == TCL_OK)) { ! int objc2 = 0; ! Tcl_Obj **objv2; ! int j; Tcl_ListObjGetElements(NULL, Tcl_GetObjResult(interp), &objc2, &objv2); for (j = 0; j < objc2; j++) { + int length; + char *string; string = Tcl_GetStringFromObj(objv2[j], &length); length -= 4; if (length > 0) { *************** *** 604,612 **** } } } ! Tcl_Chdir(Tcl_DStringValue(&pwdString)); } ! Tcl_DStringFree(&pwdString); } /* --- 613,621 ---- } } } ! Tcl_DecrRefCount(searchIn); } ! Tcl_DecrRefCount(encodingObj); } /* *************** *** 1271,1280 **** CONST char *name; { ! char *argv[3]; Tcl_DString pathString; char *path; Tcl_Channel chan; argv[0] = (char *) dir; argv[1] = "encoding"; --- 1280,1290 ---- CONST char *name; { ! CONST char *argv[3]; Tcl_DString pathString; char *path; Tcl_Channel chan; + Tcl_Obj *pathPtr; argv[0] = (char *) dir; argv[1] = "encoding"; *************** *** 1283,1289 **** Tcl_DStringInit(&pathString); Tcl_JoinPath(3, argv, &pathString); path = Tcl_DStringAppend(&pathString, ".enc", -1); ! chan = Tcl_OpenFileChannel(NULL, path, "r", 0); Tcl_DStringFree(&pathString); return chan; --- 1293,1304 ---- Tcl_DStringInit(&pathString); Tcl_JoinPath(3, argv, &pathString); path = Tcl_DStringAppend(&pathString, ".enc", -1); ! pathPtr = Tcl_NewStringObj(path,-1); ! ! Tcl_IncrRefCount(pathPtr); ! chan = Tcl_FSOpenFileChannel(NULL, pathPtr, "r", 0); ! Tcl_DecrRefCount(pathPtr); ! Tcl_DStringFree(&pathString); return chan; Index: generic/tclEvent.c =================================================================== RCS file: /cvsroot/tcl/tcl/generic/tclEvent.c,v retrieving revision 1.10 diff -c -r1.10 tclEvent.c *** generic/tclEvent.c 2000/11/02 23:34:34 1.10 --- generic/tclEvent.c 2001/03/16 17:08:08 *************** *** 766,775 **** ThreadSpecificData *tsdPtr; TclpInitLock(); - tsdPtr = TCL_TSD_INIT(&dataKey); if (subsystemsInitialized != 0) { subsystemsInitialized = 0; /* * Invoke exit handlers first. */ --- 766,776 ---- ThreadSpecificData *tsdPtr; TclpInitLock(); if (subsystemsInitialized != 0) { subsystemsInitialized = 0; + tsdPtr = TCL_TSD_INIT(&dataKey); + /* * Invoke exit handlers first. */ *************** *** 934,941 **** int TclInExit() { ! ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); ! return tsdPtr->inExit; } /* --- 935,946 ---- int TclInExit() { ! ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); ! if (tsdPtr == NULL) { ! return inFinalize; ! } else { ! return tsdPtr->inExit; ! } } /* Index: generic/tclFCmd.c =================================================================== RCS file: /cvsroot/tcl/tcl/generic/tclFCmd.c,v retrieving revision 1.6 diff -c -r1.6 tclFCmd.c *** generic/tclFCmd.c 1999/07/01 23:21:07 1.6 --- generic/tclFCmd.c 2001/03/16 17:08:08 *************** *** 20,33 **** */ static int CopyRenameOneFile _ANSI_ARGS_((Tcl_Interp *interp, ! char *source, char *dest, int copyFlag, ! int force)); ! static char * FileBasename _ANSI_ARGS_((Tcl_Interp *interp, ! char *path, Tcl_DString *bufferPtr)); static int FileCopyRename _ANSI_ARGS_((Tcl_Interp *interp, ! int argc, char **argv, int copyFlag)); static int FileForceOption _ANSI_ARGS_((Tcl_Interp *interp, ! int argc, char **argv, int *forcePtr)); /* *--------------------------------------------------------------------------- --- 20,33 ---- */ static int CopyRenameOneFile _ANSI_ARGS_((Tcl_Interp *interp, ! Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr, ! int copyFlag, int force)); ! static Tcl_Obj * FileBasename _ANSI_ARGS_((Tcl_Interp *interp, ! Tcl_Obj *pathPtr)); static int FileCopyRename _ANSI_ARGS_((Tcl_Interp *interp, ! int objc, Tcl_Obj *CONST objv[], int copyFlag)); static int FileForceOption _ANSI_ARGS_((Tcl_Interp *interp, ! int objc, Tcl_Obj *CONST objv[], int *forcePtr)); /* *--------------------------------------------------------------------------- *************** *** 49,60 **** */ int ! TclFileRenameCmd(interp, argc, argv) Tcl_Interp *interp; /* Interp for error reporting. */ ! int argc; /* Number of arguments. */ ! char **argv; /* Argument strings passed to Tcl_FileCmd. */ { ! return FileCopyRename(interp, argc, argv, 0); } /* --- 49,60 ---- */ int ! TclFileRenameCmd(interp, objc, objv) Tcl_Interp *interp; /* Interp for error reporting. */ ! int objc; /* Number of arguments. */ ! Tcl_Obj *CONST objv[]; /* Argument strings passed to Tcl_FileCmd. */ { ! return FileCopyRename(interp, objc, objv, 0); } /* *************** *** 77,88 **** */ int ! TclFileCopyCmd(interp, argc, argv) Tcl_Interp *interp; /* Used for error reporting */ ! int argc; /* Number of arguments. */ ! char **argv; /* Argument strings passed to Tcl_FileCmd. */ { ! return FileCopyRename(interp, argc, argv, 1); } /* --- 77,88 ---- */ int ! TclFileCopyCmd(interp, objc, objv) Tcl_Interp *interp; /* Used for error reporting */ ! int objc; /* Number of arguments. */ ! Tcl_Obj *CONST objv[]; /* Argument strings passed to Tcl_FileCmd. */ { ! return FileCopyRename(interp, objc, objv, 1); } /* *************** *** 103,128 **** */ static int ! FileCopyRename(interp, argc, argv, copyFlag) Tcl_Interp *interp; /* Used for error reporting. */ ! int argc; /* Number of arguments. */ ! char **argv; /* Argument strings passed to Tcl_FileCmd. */ int copyFlag; /* If non-zero, copy source(s). Otherwise, * rename them. */ { int i, result, force; struct stat statBuf; ! Tcl_DString targetBuffer; ! char *target; ! i = FileForceOption(interp, argc - 2, argv + 2, &force); if (i < 0) { return TCL_ERROR; } i += 2; ! if ((argc - i) < 2) { ! Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], ! " ", argv[1], " ?options? source ?source ...? target\"", (char *) NULL); return TCL_ERROR; } --- 103,127 ---- */ static int ! FileCopyRename(interp, objc, objv, copyFlag) Tcl_Interp *interp; /* Used for error reporting. */ ! int objc; /* Number of arguments. */ ! Tcl_Obj *CONST objv[]; /* Argument strings passed to Tcl_FileCmd. */ int copyFlag; /* If non-zero, copy source(s). Otherwise, * rename them. */ { int i, result, force; struct stat statBuf; ! Tcl_Obj *target; ! i = FileForceOption(interp, objc - 2, objv + 2, &force); if (i < 0) { return TCL_ERROR; } i += 2; ! if ((objc - i) < 2) { ! Tcl_AppendResult(interp, "wrong # args: should be \"", Tcl_GetString(objv[0]), ! " ", Tcl_GetString(objv[1]), " ?options? source ?source ...? target\"", (char *) NULL); return TCL_ERROR; } *************** *** 133,170 **** * directory. */ ! target = Tcl_TranslateFileName(interp, argv[argc - 1], &targetBuffer); ! if (target == NULL) { return TCL_ERROR; } result = TCL_OK; /* ! * Call TclStat() so that if target is a symlink that points to a * directory we will put the sources in that directory instead of * overwriting the symlink. */ ! if ((TclStat(target, &statBuf) != 0) || !S_ISDIR(statBuf.st_mode)) { ! if ((argc - i) > 2) { errno = ENOTDIR; Tcl_PosixError(interp); Tcl_AppendResult(interp, "error ", ((copyFlag) ? "copying" : "renaming"), ": target \"", ! argv[argc - 1], "\" is not a directory", (char *) NULL); result = TCL_ERROR; } else { /* ! * Even though already have target == translated(argv[i+1]), * pass the original argument down, so if there's an error, the * error message will reflect the original arguments. */ ! result = CopyRenameOneFile(interp, argv[i], argv[i + 1], copyFlag, force); } - Tcl_DStringFree(&targetBuffer); return result; } --- 132,168 ---- * directory. */ ! target = objv[objc - 1]; ! if (Tcl_FSConvertToPathType(interp, target) != TCL_OK) { return TCL_ERROR; } result = TCL_OK; /* ! * Call Tcl_FSStat() so that if target is a symlink that points to a * directory we will put the sources in that directory instead of * overwriting the symlink. */ ! if ((Tcl_FSStat(target, &statBuf) != 0) || !S_ISDIR(statBuf.st_mode)) { ! if ((objc - i) > 2) { errno = ENOTDIR; Tcl_PosixError(interp); Tcl_AppendResult(interp, "error ", ((copyFlag) ? "copying" : "renaming"), ": target \"", ! Tcl_GetString(target), "\" is not a directory", (char *) NULL); result = TCL_ERROR; } else { /* ! * Even though already have target == translated(objv[i+1]), * pass the original argument down, so if there's an error, the * error message will reflect the original arguments. */ ! result = CopyRenameOneFile(interp, objv[i], objv[i + 1], copyFlag, force); } return result; } *************** *** 173,202 **** * from each source, and append it to the end of the target path. */ ! for ( ; i < argc - 1; i++) { ! char *jargv[2]; ! char *source, *newFileName; ! Tcl_DString sourceBuffer, newFileNameBuffer; ! ! source = FileBasename(interp, argv[i], &sourceBuffer); if (source == NULL) { result = TCL_ERROR; break; } ! jargv[0] = argv[argc - 1]; jargv[1] = source; ! Tcl_DStringInit(&newFileNameBuffer); ! newFileName = Tcl_JoinPath(2, jargv, &newFileNameBuffer); ! result = CopyRenameOneFile(interp, argv[i], newFileName, copyFlag, force); ! Tcl_DStringFree(&sourceBuffer); ! Tcl_DStringFree(&newFileNameBuffer); ! if (result == TCL_ERROR) { break; } } - Tcl_DStringFree(&targetBuffer); return result; } --- 171,200 ---- * from each source, and append it to the end of the target path. */ ! for ( ; i < objc - 1; i++) { ! Tcl_Obj *jargv[2]; ! Tcl_Obj *source, *newFileName; ! Tcl_Obj *temp; ! ! source = FileBasename(interp, objv[i]); if (source == NULL) { result = TCL_ERROR; break; } ! jargv[0] = objv[objc - 1]; jargv[1] = source; ! temp = Tcl_NewListObj(2, jargv); ! newFileName = Tcl_FSJoinPath(temp, -1); ! Tcl_IncrRefCount(newFileName); ! Tcl_DecrRefCount(temp); ! ! result = CopyRenameOneFile(interp, objv[i], newFileName, copyFlag, force); ! Tcl_DecrRefCount(newFileName); if (result == TCL_ERROR) { break; } } return result; } *************** *** 219,292 **** *---------------------------------------------------------------------- */ int ! TclFileMakeDirsCmd(interp, argc, argv) Tcl_Interp *interp; /* Used for error reporting. */ ! int argc; /* Number of arguments */ ! char **argv; /* Argument strings passed to Tcl_FileCmd. */ { ! Tcl_DString nameBuffer, targetBuffer; ! char *errfile; ! int result, i, j, pargc; ! char **pargv; struct stat statBuf; - pargv = NULL; errfile = NULL; - Tcl_DStringInit(&nameBuffer); - Tcl_DStringInit(&targetBuffer); result = TCL_OK; ! for (i = 2; i < argc; i++) { ! char *name = Tcl_TranslateFileName(interp, argv[i], &nameBuffer); ! if (name == NULL) { result = TCL_ERROR; break; } ! Tcl_SplitPath(name, &pargc, &pargv); ! if (pargc == 0) { errno = ENOENT; ! errfile = argv[i]; break; } ! for (j = 0; j < pargc; j++) { ! char *target = Tcl_JoinPath(j + 1, pargv, &targetBuffer); ! /* ! * Call TclStat() so that if target is a symlink that points * to a directory we will create subdirectories in that * directory. */ ! if (TclStat(target, &statBuf) == 0) { if (!S_ISDIR(statBuf.st_mode)) { errno = EEXIST; errfile = target; goto done; } } else if ((errno != ENOENT) ! || (TclpCreateDirectory(target) != TCL_OK)) { errfile = target; goto done; } ! Tcl_DStringFree(&targetBuffer); } ! ckfree((char *) pargv); ! pargv = NULL; ! Tcl_DStringFree(&nameBuffer); } done: if (errfile != NULL) { Tcl_AppendResult(interp, "can't create directory \"", ! errfile, "\": ", Tcl_PosixError(interp), (char *) NULL); result = TCL_ERROR; } ! ! Tcl_DStringFree(&nameBuffer); ! Tcl_DStringFree(&targetBuffer); ! if (pargv != NULL) { ! ckfree((char *) pargv); } return result; } --- 217,287 ---- *---------------------------------------------------------------------- */ int ! TclFileMakeDirsCmd(interp, objc, objv) Tcl_Interp *interp; /* Used for error reporting. */ ! int objc; /* Number of arguments */ ! Tcl_Obj *CONST objv[]; /* Argument strings passed to Tcl_FileCmd. */ { ! Tcl_Obj *errfile; ! int result, i, j, pobjc; ! Tcl_Obj *split = NULL; ! Tcl_Obj *target = NULL; struct stat statBuf; errfile = NULL; result = TCL_OK; ! for (i = 2; i < objc; i++) { ! if (Tcl_FSConvertToPathType(interp, objv[i]) != TCL_OK) { result = TCL_ERROR; break; } ! split = Tcl_FSSplitPath(objv[i],&pobjc); ! if (pobjc == 0) { errno = ENOENT; ! errfile = objv[i]; break; } ! for (j = 0; j < pobjc; j++) { ! target = Tcl_FSJoinPath(split, j + 1); ! Tcl_IncrRefCount(target); /* ! * Call Tcl_Stat() so that if target is a symlink that points * to a directory we will create subdirectories in that * directory. */ ! if (Tcl_FSStat(target, &statBuf) == 0) { if (!S_ISDIR(statBuf.st_mode)) { errno = EEXIST; errfile = target; goto done; } } else if ((errno != ENOENT) ! || (Tcl_FSCreateDirectory(target) != TCL_OK)) { errfile = target; goto done; } ! /* Forget about this sub-path */ ! Tcl_DecrRefCount(target); ! target = NULL; } ! Tcl_DecrRefCount(split); ! split = NULL; } done: if (errfile != NULL) { Tcl_AppendResult(interp, "can't create directory \"", ! Tcl_GetString(errfile), "\": ", Tcl_PosixError(interp), (char *) NULL); result = TCL_ERROR; } ! if (split != NULL) { ! Tcl_DecrRefCount(split); ! } ! if (target != NULL) { ! Tcl_DecrRefCount(target); } return result; } *************** *** 309,347 **** */ int ! TclFileDeleteCmd(interp, argc, argv) Tcl_Interp *interp; /* Used for error reporting */ ! int argc; /* Number of arguments */ ! char **argv; /* Argument strings passed to Tcl_FileCmd. */ { - Tcl_DString nameBuffer, errorBuffer; int i, force, result; ! char *errfile; ! i = FileForceOption(interp, argc - 2, argv + 2, &force); if (i < 0) { return TCL_ERROR; } i += 2; ! if ((argc - i) < 1) { ! Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], ! " ", argv[1], " ?options? file ?file ...?\"", (char *) NULL); return TCL_ERROR; } errfile = NULL; result = TCL_OK; - Tcl_DStringInit(&errorBuffer); - Tcl_DStringInit(&nameBuffer); ! for ( ; i < argc; i++) { struct stat statBuf; - char *name; ! errfile = argv[i]; ! Tcl_DStringSetLength(&nameBuffer, 0); ! name = Tcl_TranslateFileName(interp, argv[i], &nameBuffer); ! if (name == NULL) { result = TCL_ERROR; goto done; } --- 304,336 ---- */ int ! TclFileDeleteCmd(interp, objc, objv) Tcl_Interp *interp; /* Used for error reporting */ ! int objc; /* Number of arguments */ ! Tcl_Obj *CONST objv[]; /* Argument strings passed to Tcl_FileCmd. */ { int i, force, result; ! Tcl_Obj *errfile; ! i = FileForceOption(interp, objc - 2, objv + 2, &force); if (i < 0) { return TCL_ERROR; } i += 2; ! if ((objc - i) < 1) { ! Tcl_AppendResult(interp, "wrong # args: should be \"", Tcl_GetString(objv[0]), ! " ", Tcl_GetString(objv[1]), " ?options? file ?file ...?\"", (char *) NULL); return TCL_ERROR; } errfile = NULL; result = TCL_OK; ! for ( ; i < objc; i++) { struct stat statBuf; ! errfile = objv[i]; ! if (Tcl_FSConvertToPathType(interp, objv[i]) != TCL_OK) { result = TCL_ERROR; 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 --- 339,345 ---- * Call lstat() to get info so can delete symbolic link itself. */ ! if (Tcl_FSLstat(objv[i], &statBuf) != 0) { /* * Trying to delete a file that does not exist is not * considered an error, just a no-op *************** *** 360,369 **** result = TCL_ERROR; } } else if (S_ISDIR(statBuf.st_mode)) { ! result = TclpRemoveDirectory(name, force, &errorBuffer); if (result != TCL_OK) { if ((force == 0) && (errno == EEXIST)) { ! Tcl_AppendResult(interp, "error deleting \"", argv[i], "\": directory not empty", (char *) NULL); Tcl_PosixError(interp); goto done; --- 349,359 ---- result = TCL_ERROR; } } else if (S_ISDIR(statBuf.st_mode)) { ! Tcl_Obj *errorBuffer = NULL; ! result = Tcl_FSRemoveDirectory(objv[i], force, &errorBuffer); if (result != TCL_OK) { if ((force == 0) && (errno == EEXIST)) { ! Tcl_AppendResult(interp, "error deleting \"", Tcl_GetString(objv[i]), "\": directory not empty", (char *) NULL); Tcl_PosixError(interp); goto done; *************** *** 373,385 **** * If possible, use the untranslated name for the file. */ ! errfile = Tcl_DStringValue(&errorBuffer); ! if (strcmp(name, errfile) == 0) { ! errfile = argv[i]; } } } else { ! result = TclpDeleteFile(name); } if (result == TCL_ERROR) { --- 363,376 ---- * If possible, use the untranslated name for the file. */ ! errfile = errorBuffer; ! /* FS supposed to check between translated objv and errfile */ ! if (Tcl_FSEqualPaths(objv[i], errfile)) { ! errfile = objv[i]; } } } else { ! result = Tcl_FSDeleteFile(objv[i]); } if (result == TCL_ERROR) { *************** *** 387,398 **** } } if (result != TCL_OK) { ! Tcl_AppendResult(interp, "error deleting \"", errfile, ! "\": ", Tcl_PosixError(interp), (char *) NULL); } done: - Tcl_DStringFree(&errorBuffer); - Tcl_DStringFree(&nameBuffer); return result; } --- 378,393 ---- } } if (result != TCL_OK) { ! if (errfile == NULL) { ! /* We try to accomodate poor error results from our Tcl_FS calls */ ! Tcl_AppendResult(interp, "error deleting unknown file: ", ! Tcl_PosixError(interp), (char *) NULL); ! } else { ! Tcl_AppendResult(interp, "error deleting \"", Tcl_GetString(errfile), ! "\": ", Tcl_PosixError(interp), (char *) NULL); ! } } done: return result; } *************** *** 418,426 **** static int CopyRenameOneFile(interp, source, target, copyFlag, force) Tcl_Interp *interp; /* Used for error reporting. */ ! char *source; /* Pathname of file to copy. May need to * be translated. */ ! char *target; /* Pathname of file to create/overwrite. * May need to be translated. */ int copyFlag; /* If non-zero, copy files. Otherwise, * rename them. */ --- 413,421 ---- static int CopyRenameOneFile(interp, source, target, copyFlag, force) Tcl_Interp *interp; /* Used for error reporting. */ ! Tcl_Obj *source; /* Pathname of file to copy. May need to * be translated. */ ! Tcl_Obj *target; /* Pathname of file to create/overwrite. * May need to be translated. */ int copyFlag; /* If non-zero, copy files. Otherwise, * rename them. */ *************** *** 429,451 **** * exists. */ { int result; ! Tcl_DString sourcePath, targetPath, errorBuffer; ! char *targetName, *sourceName, *errfile; struct stat sourceStatBuf, targetStatBuf; ! sourceName = Tcl_TranslateFileName(interp, source, &sourcePath); ! if (sourceName == NULL) { return TCL_ERROR; } ! targetName = Tcl_TranslateFileName(interp, target, &targetPath); ! if (targetName == NULL) { ! Tcl_DStringFree(&sourcePath); return TCL_ERROR; } errfile = NULL; result = TCL_ERROR; - Tcl_DStringInit(&errorBuffer); /* * We want to copy/rename links and not the files they point to, so we --- 424,442 ---- * exists. */ { int result; ! Tcl_Obj *errfile, *errorBuffer; struct stat sourceStatBuf, targetStatBuf; ! if (Tcl_FSConvertToPathType(interp, source) != TCL_OK) { return TCL_ERROR; } ! if (Tcl_FSConvertToPathType(interp, target) != TCL_OK) { return TCL_ERROR; } errfile = NULL; + errorBuffer = NULL; result = TCL_ERROR; /* * We want to copy/rename links and not the files they point to, so we *************** *** 454,464 **** * target. */ ! if (TclpLstat(sourceName, &sourceStatBuf) != 0) { errfile = source; goto done; } ! if (TclpLstat(targetName, &targetStatBuf) != 0) { if (errno != ENOENT) { errfile = target; goto done; --- 445,455 ---- * target. */ ! if (Tcl_FSLstat(source, &sourceStatBuf) != 0) { errfile = source; goto done; } ! if (Tcl_FSLstat(target, &targetStatBuf) != 0) { if (errno != ENOENT) { errfile = target; goto done; *************** *** 495,522 **** if (S_ISDIR(sourceStatBuf.st_mode) && !S_ISDIR(targetStatBuf.st_mode)) { errno = EISDIR; ! Tcl_AppendResult(interp, "can't overwrite file \"", target, ! "\" with directory \"", source, "\"", (char *) NULL); goto done; } if (!S_ISDIR(sourceStatBuf.st_mode) && S_ISDIR(targetStatBuf.st_mode)) { errno = EISDIR; ! Tcl_AppendResult(interp, "can't overwrite directory \"", target, ! "\" with file \"", source, "\"", (char *) NULL); goto done; } } if (copyFlag == 0) { ! result = TclpRenameFile(sourceName, targetName); if (result == TCL_OK) { goto done; } if (errno == EINVAL) { ! Tcl_AppendResult(interp, "error renaming \"", source, "\" to \"", ! target, "\": trying to rename a volume or ", "move a directory into itself", (char *) NULL); goto done; } else if (errno != EXDEV) { --- 486,513 ---- if (S_ISDIR(sourceStatBuf.st_mode) && !S_ISDIR(targetStatBuf.st_mode)) { errno = EISDIR; ! Tcl_AppendResult(interp, "can't overwrite file \"", Tcl_GetString(target), ! "\" with directory \"", Tcl_GetString(source), "\"", (char *) NULL); goto done; } if (!S_ISDIR(sourceStatBuf.st_mode) && S_ISDIR(targetStatBuf.st_mode)) { errno = EISDIR; ! Tcl_AppendResult(interp, "can't overwrite directory \"", Tcl_GetString(target), ! "\" with file \"", Tcl_GetString(source), "\"", (char *) NULL); goto done; } } if (copyFlag == 0) { ! result = Tcl_FSRenameFile(source, target); if (result == TCL_OK) { goto done; } if (errno == EINVAL) { ! Tcl_AppendResult(interp, "error renaming \"", Tcl_GetString(source), "\" to \"", ! Tcl_GetString(target), "\": trying to rename a volume or ", "move a directory into itself", (char *) NULL); goto done; } else if (errno != EXDEV) { *************** *** 533,575 **** } if (S_ISDIR(sourceStatBuf.st_mode)) { ! result = TclpCopyDirectory(sourceName, targetName, &errorBuffer); if (result != TCL_OK) { ! errfile = Tcl_DStringValue(&errorBuffer); ! if (strcmp(errfile, sourceName) == 0) { ! errfile = source; ! } else if (strcmp(errfile, targetName) == 0) { ! errfile = target; } } } else { ! result = TclpCopyFile(sourceName, targetName); ! if (result != TCL_OK) { /* * Well, there really shouldn't be a problem with source, * because up there we checked to see if it was ok to copy it. */ ! ! errfile = target; } } if ((copyFlag == 0) && (result == TCL_OK)) { if (S_ISDIR(sourceStatBuf.st_mode)) { ! result = TclpRemoveDirectory(sourceName, 1, &errorBuffer); if (result != TCL_OK) { ! errfile = Tcl_DStringValue(&errorBuffer); ! if (strcmp(errfile, sourceName) == 0) { errfile = source; } } } else { ! result = TclpDeleteFile(sourceName); if (result != TCL_OK) { errfile = source; } } if (result != TCL_OK) { ! Tcl_AppendResult(interp, "can't unlink \"", errfile, "\": ", Tcl_PosixError(interp), (char *) NULL); errfile = NULL; } --- 524,639 ---- } if (S_ISDIR(sourceStatBuf.st_mode)) { ! result = Tcl_FSCopyDirectory(source, target, &errorBuffer); if (result != TCL_OK) { ! if (errno == EXDEV) { ! /* ! * The copy failed because we're trying to do a ! * cross-filesystem copy. We do this through our Tcl ! * library. ! */ ! Tcl_SavedResult savedResult; ! Tcl_Obj *copyCommand = Tcl_NewListObj(0,NULL); ! Tcl_IncrRefCount(copyCommand); ! Tcl_ListObjAppendElement(interp, copyCommand, Tcl_NewStringObj("::tcl::copyDirectory",-1)); ! if (copyFlag) { ! Tcl_ListObjAppendElement(interp, copyCommand, Tcl_NewStringObj("copying",-1)); ! } else { ! Tcl_ListObjAppendElement(interp, copyCommand, Tcl_NewStringObj("renaming",-1)); ! } ! Tcl_ListObjAppendElement(interp, copyCommand, source); ! Tcl_ListObjAppendElement(interp, copyCommand, target); ! Tcl_SaveResult(interp, &savedResult); ! result = Tcl_EvalObjEx(interp, copyCommand, TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT); ! Tcl_DecrRefCount(copyCommand); ! if (result != TCL_OK) { ! /* ! * There was an error in the Tcl-level copy. ! * We will pass on the Tcl error message and ! * can ensure this by setting errfile to NULL ! */ ! Tcl_DiscardResult(&savedResult); ! errfile = NULL; ! } else { ! /* The copy was successful */ ! Tcl_RestoreResult(interp, &savedResult); ! } ! } else { ! errfile = errorBuffer; ! if (Tcl_FSEqualPaths(errfile, source)) { ! errfile = source; ! } else if (Tcl_FSEqualPaths(errfile, target)) { ! errfile = target; ! } } } } else { ! result = Tcl_FSCopyFile(source, target); ! if ((result != TCL_OK) && (errno == EXDEV)) { /* * Well, there really shouldn't be a problem with source, * because up there we checked to see if it was ok to copy it. + * + * Either there is a problem with target, or we're trying + * to do a cross-filesystem copy. We open the target for + * writing to decide between those two cases. */ ! int prot = 0666; ! Tcl_Channel out = Tcl_FSOpenFileChannel(interp, target, "w", prot); ! if (out == NULL) { ! /* There was a problem with the target */ ! errfile = target; ! } else { ! /* It looks like we can copy it over */ ! Tcl_Channel in = Tcl_FSOpenFileChannel(interp, source, ! "r", prot); ! if (in == NULL) { ! /* This is very strange, we checked this above */ ! Tcl_Close(interp, out); ! errfile = source; ! } else { ! struct utimbuf tval; ! /* ! * Copy it synchronously. We might wish to add an ! * asynchronous option to support vfs's which are ! * slow (e.g. network sockets). ! */ ! Tcl_SetChannelOption(interp, in, "-translation", "binary"); ! Tcl_SetChannelOption(interp, out, "-translation", "binary"); ! ! if (TclCopyChannel(interp, in, out, -1, NULL) == TCL_OK) { ! result = TCL_OK; ! } ! /* ! * If the copy failed, assume that copy channel left ! * a good error message. ! */ ! Tcl_Close(interp, in); ! Tcl_Close(interp, out); ! /* Set modification date of copied file */ ! tval.actime = sourceStatBuf.st_atime; ! tval.modtime = sourceStatBuf.st_mtime; ! Tcl_FSUtime(source, &tval); ! } ! } } } if ((copyFlag == 0) && (result == TCL_OK)) { if (S_ISDIR(sourceStatBuf.st_mode)) { ! result = Tcl_FSRemoveDirectory(source, 1, &errorBuffer); if (result != TCL_OK) { ! if (Tcl_FSEqualPaths(errfile, source) == 0) { errfile = source; } } } else { ! result = Tcl_FSDeleteFile(source); if (result != TCL_OK) { errfile = source; } } if (result != TCL_OK) { ! Tcl_AppendResult(interp, "can't unlink \"", Tcl_GetString(errfile), "\": ", Tcl_PosixError(interp), (char *) NULL); errfile = NULL; } *************** *** 579,597 **** if (errfile != NULL) { Tcl_AppendResult(interp, ((copyFlag) ? "error copying \"" : "error renaming \""), ! source, (char *) NULL); if (errfile != source) { ! Tcl_AppendResult(interp, "\" to \"", target, (char *) NULL); if (errfile != target) { ! Tcl_AppendResult(interp, "\": \"", errfile, (char *) NULL); } } Tcl_AppendResult(interp, "\": ", Tcl_PosixError(interp), (char *) NULL); } - Tcl_DStringFree(&errorBuffer); - Tcl_DStringFree(&sourcePath); - Tcl_DStringFree(&targetPath); return result; } --- 643,661 ---- if (errfile != NULL) { Tcl_AppendResult(interp, ((copyFlag) ? "error copying \"" : "error renaming \""), ! Tcl_GetString(source), (char *) NULL); if (errfile != source) { ! Tcl_AppendResult(interp, "\" to \"", Tcl_GetString(target), (char *) NULL); if (errfile != target) { ! Tcl_AppendResult(interp, "\": \"", Tcl_GetString(errfile), (char *) NULL); } } Tcl_AppendResult(interp, "\": ", Tcl_PosixError(interp), (char *) NULL); + } + if (errorBuffer != NULL) { + Tcl_DecrRefCount(errorBuffer); } return result; } *************** *** 616,625 **** */ static int ! FileForceOption(interp, argc, argv, forcePtr) Tcl_Interp *interp; /* Interp, for error return. */ ! int argc; /* Number of arguments. */ ! char **argv; /* Argument strings. First command line * option, if it exists, begins at 0. */ int *forcePtr; /* If the "-force" was specified, *forcePtr * is filled with 1, otherwise with 0. */ --- 680,689 ---- */ static int ! FileForceOption(interp, objc, objv, forcePtr) Tcl_Interp *interp; /* Interp, for error return. */ ! int objc; /* Number of arguments. */ ! Tcl_Obj *CONST objv[]; /* Argument strings. First command line * option, if it exists, begins at 0. */ int *forcePtr; /* If the "-force" was specified, *forcePtr * is filled with 1, otherwise with 0. */ *************** *** 627,643 **** int force, i; force = 0; ! for (i = 0; i < argc; i++) { ! if (argv[i][0] != '-') { break; } ! if (strcmp(argv[i], "-force") == 0) { force = 1; ! } else if (strcmp(argv[i], "--") == 0) { i++; break; } else { ! Tcl_AppendResult(interp, "bad option \"", argv[i], "\": should be -force or --", (char *)NULL); return -1; } --- 691,707 ---- int force, i; force = 0; ! for (i = 0; i < objc; i++) { ! if (Tcl_GetString(objv[i])[0] != '-') { break; } ! if (strcmp(Tcl_GetString(objv[i]), "-force") == 0) { force = 1; ! } else if (strcmp(Tcl_GetString(objv[i]), "--") == 0) { i++; break; } else { ! Tcl_AppendResult(interp, "bad option \"", Tcl_GetString(objv[i]), "\": should be -force or --", (char *)NULL); return -1; } *************** *** 667,713 **** *--------------------------------------------------------------------------- */ ! static char * ! FileBasename(interp, path, bufferPtr) Tcl_Interp *interp; /* Interp, for error return. */ ! char *path; /* Path whose basename to extract. */ ! Tcl_DString *bufferPtr; /* Initialized DString that receives ! * basename. */ { ! int argc; ! char **argv; ! Tcl_SplitPath(path, &argc, &argv); ! if (argc == 0) { ! Tcl_DStringInit(bufferPtr); ! } else { ! if ((argc == 1) && (*path == '~')) { ! Tcl_DString buffer; ! ckfree((char *) argv); ! path = Tcl_TranslateFileName(interp, path, &buffer); ! if (path == NULL) { return NULL; } ! Tcl_SplitPath(path, &argc, &argv); ! Tcl_DStringFree(&buffer); } - Tcl_DStringInit(bufferPtr); /* * Return the last component, unless it is the only component, and it * is the root of an absolute path. */ ! if (argc > 0) { ! if ((argc > 1) ! || (Tcl_GetPathType(argv[0]) == TCL_PATH_RELATIVE)) { ! Tcl_DStringAppend(bufferPtr, argv[argc - 1], -1); } } } ! ckfree((char *) argv); ! return Tcl_DStringValue(bufferPtr); } /* --- 731,781 ---- *--------------------------------------------------------------------------- */ ! static Tcl_Obj * ! FileBasename(interp, pathPtr) Tcl_Interp *interp; /* Interp, for error return. */ ! Tcl_Obj *pathPtr; /* Path whose basename to extract. */ { ! int objc; ! Tcl_Obj *split; ! Tcl_Obj *resPtr = NULL; ! split = Tcl_FSSplitPath(pathPtr, &objc); ! ! if (objc != 0) { ! if ((objc == 1) && (*Tcl_GetString(pathPtr) == '~')) { ! if (Tcl_FSConvertToPathType(interp, pathPtr) != TCL_OK) { ! Tcl_DecrRefCount(split); return NULL; } ! Tcl_DecrRefCount(split); ! split = Tcl_FSSplitPath(pathPtr, &objc); } /* * Return the last component, unless it is the only component, and it * is the root of an absolute path. */ ! if (objc > 0) { ! if (objc > 1) { ! Tcl_ListObjIndex(NULL, split, objc-1, &resPtr); ! } else { ! Tcl_Obj *temp; ! Tcl_ListObjIndex(NULL, split, 0, &temp); ! if (Tcl_GetPathType(Tcl_GetString(temp)) == TCL_PATH_RELATIVE) { ! Tcl_ListObjIndex(NULL, split, objc-1, &resPtr); ! } } } + } + if (resPtr == NULL) { + resPtr = Tcl_NewStringObj("",0); } ! Tcl_IncrRefCount(resPtr); ! Tcl_DecrRefCount(split); ! return resPtr; } /* *************** *** 751,796 **** int objc; /* Number of command line arguments. */ Tcl_Obj *CONST objv[]; /* The command line objects. */ { - char *fileName; int result; ! Tcl_DString buffer; ! if (objc < 3) { Tcl_WrongNumArgs(interp, 2, objv, "name ?option? ?value? ?option value ...?"); return TCL_ERROR; } ! fileName = Tcl_GetString(objv[2]); ! fileName = Tcl_TranslateFileName(interp, fileName, &buffer); ! if (fileName == NULL) { return TCL_ERROR; } objc -= 3; objv += 3; result = TCL_ERROR; ! if (objc == 0) { /* * Get all attributes. */ int index; ! Tcl_Obj *listPtr, *objPtr; listPtr = Tcl_NewListObj(0, NULL); ! for (index = 0; tclpFileAttrStrings[index] != NULL; index++) { ! objPtr = Tcl_NewStringObj(tclpFileAttrStrings[index], -1); Tcl_ListObjAppendElement(interp, listPtr, objPtr); ! ! if ((*tclpFileAttrProcs[index].getProc)(interp, index, fileName, ! &objPtr) != TCL_OK) { Tcl_DecrRefCount(listPtr); goto end; } Tcl_ListObjAppendElement(interp, listPtr, objPtr); ! } Tcl_SetObjResult(interp, listPtr); } else if (objc == 1) { /* --- 819,885 ---- int objc; /* Number of command line arguments. */ Tcl_Obj *CONST objv[]; /* The command line objects. */ { int result; ! char ** attributeStrings; ! Tcl_Obj* objStrings = NULL; ! int numObjStrings = -1; ! Tcl_Obj *filePtr; ! if (objc < 3) { Tcl_WrongNumArgs(interp, 2, objv, "name ?option? ?value? ?option value ...?"); return TCL_ERROR; } ! filePtr = objv[2]; ! if (Tcl_FSConvertToPathType(interp, filePtr) != TCL_OK) { return TCL_ERROR; } objc -= 3; objv += 3; result = TCL_ERROR; ! attributeStrings = Tcl_FSFileAttrStrings(filePtr, &objStrings); ! if (attributeStrings == NULL) { ! int index; ! Tcl_Obj *objPtr; ! if (objStrings == NULL) { ! goto end; ! } ! /* We own the object now */ ! Tcl_IncrRefCount(objStrings); ! /* Use objStrings as a list object */ ! if (Tcl_ListObjLength(interp, objStrings, &numObjStrings) != TCL_OK) { ! goto end; ! } ! attributeStrings = (char**)ckalloc((1+numObjStrings)*sizeof(char*)); ! for (index = 0; index < numObjStrings; index++) { ! Tcl_ListObjIndex(interp, objStrings, index, &objPtr); ! attributeStrings[index] = Tcl_GetString(objPtr); ! } ! attributeStrings[index] = NULL; ! } if (objc == 0) { /* * Get all attributes. */ int index; ! Tcl_Obj *listPtr; listPtr = Tcl_NewListObj(0, NULL); ! for (index = 0; attributeStrings[index] != NULL; index++) { ! Tcl_Obj *objPtr = Tcl_NewStringObj(attributeStrings[index], -1); Tcl_ListObjAppendElement(interp, listPtr, objPtr); ! /* We now forget about objPtr, it is in the list */ ! objPtr = NULL; ! if (Tcl_FSFileAttrsGet(interp, index, filePtr, ! &objPtr) != TCL_OK) { Tcl_DecrRefCount(listPtr); goto end; } Tcl_ListObjAppendElement(interp, listPtr, objPtr); ! } Tcl_SetObjResult(interp, listPtr); } else if (objc == 1) { /* *************** *** 798,810 **** */ int index; ! Tcl_Obj *objPtr; ! ! if (Tcl_GetIndexFromObj(interp, objv[0], tclpFileAttrStrings, "option", 0, &index) != TCL_OK) { goto end; ! } ! if ((*tclpFileAttrProcs[index].getProc)(interp, index, fileName, &objPtr) != TCL_OK) { goto end; } --- 887,899 ---- */ int index; ! Tcl_Obj *objPtr = NULL; ! ! if (Tcl_GetIndexFromObj(interp, objv[0], attributeStrings, "option", 0, &index) != TCL_OK) { goto end; ! } ! if (Tcl_FSFileAttrsGet(interp, index, filePtr, &objPtr) != TCL_OK) { goto end; } *************** *** 817,823 **** int i, index; for (i = 0; i < objc ; i += 2) { ! if (Tcl_GetIndexFromObj(interp, objv[i], tclpFileAttrStrings, "option", 0, &index) != TCL_OK) { goto end; } --- 906,912 ---- int i, index; for (i = 0; i < objc ; i += 2) { ! if (Tcl_GetIndexFromObj(interp, objv[i], attributeStrings, "option", 0, &index) != TCL_OK) { goto end; } *************** *** 827,833 **** (char *) NULL); goto end; } ! if ((*tclpFileAttrProcs[index].setProc)(interp, index, fileName, objv[i + 1]) != TCL_OK) { goto end; } --- 916,922 ---- (char *) NULL); goto end; } ! if (Tcl_FSFileAttrsSet(interp, index, filePtr, objv[i + 1]) != TCL_OK) { goto end; } *************** *** 836,841 **** result = TCL_OK; end: ! Tcl_DStringFree(&buffer); return result; } --- 925,938 ---- result = TCL_OK; end: ! if (numObjStrings != -1) { ! /* Free up the array we allocated */ ! ckfree((char*)attributeStrings); ! /* ! * We don't need this object that was passed to us ! * any more. ! */ ! Tcl_DecrRefCount(objStrings); ! } return result; } Index: generic/tclFileName.c =================================================================== RCS file: /cvsroot/tcl/tcl/generic/tclFileName.c,v retrieving revision 1.13 diff -c -r1.13 tclFileName.c *** generic/tclFileName.c 2000/04/19 23:24:52 1.13 --- generic/tclFileName.c 2001/03/16 17:08:09 *************** *** 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; *************** *** 315,320 **** --- 306,354 ---- } /* + *--------------------------------------------------------------------------- + * + * Tcl_FSSplitPath -- + * + * This function takes the given Tcl_Obj, which should be a valid + * path, and returns a Tcl List object containing each segment + * of that path as an element. + * + * Note this function currently calls the older Tcl_SplitPath + * routine, which therefore requires more memory allocation and + * deallocation than necessary. We could easily rewrite this for + * greater efficiency. + * + * Results: + * Returns list object with refCount of zero. If the passed in + * lenPtr is non-NULL, we use it to return the number of elements + * in the returned list. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + + Tcl_Obj* + Tcl_FSSplitPath(Tcl_Obj* pathPtr, int *lenPtr) { + int argc, i; + char** argv; + Tcl_Obj* res; + + Tcl_SplitPath(Tcl_GetString(pathPtr),&argc,&argv); + if (lenPtr != NULL) { + *lenPtr = argc; + } + res = Tcl_NewListObj(0,NULL); + for (i=0;imacType != NULL) { Tcl_DecrRefCount(globTypes->macType); --- 1708,1717 ---- endOfGlob: if (join || (dir == PATH_GENERAL)) { Tcl_DStringFree(&prefix); } + if (pathOrDir != NULL) { + Tcl_DecrRefCount(pathOrDir); + } if (globTypes != NULL) { if (globTypes->macType != NULL) { Tcl_DecrRefCount(globTypes->macType); *************** *** 1617,1624 **** * or appending list of matching file names. */ char *pattern; /* Glob pattern to match. Must not refer * to a static string. */ ! char *unquotedPrefix; /* Prefix to glob pattern, if non-null, which ! * is considered literally. May be static. */ int globFlags; /* Stores or'ed combination of flags */ GlobTypeData *types; /* Struct containing acceptable types. * May be NULL. */ --- 1753,1760 ---- * or appending list of matching file names. */ char *pattern; /* Glob pattern to match. Must not refer * to a static string. */ ! Tcl_Obj *unquotedPrefix; /* Prefix to glob pattern, if non-null, which ! * is considered literally. */ int globFlags; /* Stores or'ed combination of flags */ GlobTypeData *types; /* Struct containing acceptable types. * May be NULL. */ *************** *** 1626,1632 **** char *separators; char *head, *tail, *start; char c; ! int result; Tcl_DString buffer; separators = NULL; /* lint. */ --- 1762,1768 ---- char *separators; char *head, *tail, *start; char c; ! int result, prefixLen; Tcl_DString buffer; separators = NULL; /* lint. */ *************** *** 1648,1654 **** Tcl_DStringInit(&buffer); if (unquotedPrefix != NULL) { ! start = unquotedPrefix; } else { start = pattern; } --- 1784,1790 ---- Tcl_DStringInit(&buffer); if (unquotedPrefix != NULL) { ! start = Tcl_GetString(unquotedPrefix); } else { start = pattern; } *************** *** 1673,1704 **** } /* ! * Determine the home directory for the specified user. Note that ! * we don't allow special characters in the user name. */ c = *tail; *tail = '\0'; - /* - * I don't think we need to worry about special characters in - * the user name anymore (Vince Darley, June 1999), since the - * new code is designed to handle special chars. - */ - #ifndef NOT_NEEDED_ANYMORE head = DoTildeSubst(interp, start+1, &buffer); - #else - - if (strpbrk(start+1, "\\[]*?{}") == NULL) { - head = DoTildeSubst(interp, start+1, &buffer); - } else { - if (!(globFlags & GLOBMODE_NO_COMPLAIN)) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "globbing characters not ", - "supported in user names", (char *) NULL); - } - head = NULL; - } - #endif *tail = c; if (head == NULL) { if (globFlags & GLOBMODE_NO_COMPLAIN) { --- 1809,1820 ---- } /* ! * Determine the home directory for the specified user. */ c = *tail; *tail = '\0'; head = DoTildeSubst(interp, start+1, &buffer); *tail = c; if (head == NULL) { if (globFlags & GLOBMODE_NO_COMPLAIN) { *************** *** 1726,1747 **** } else { tail = pattern; if (unquotedPrefix != NULL) { ! 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) { --- 1842,1876 ---- } else { tail = pattern; if (unquotedPrefix != NULL) { ! Tcl_DStringAppend(&buffer,Tcl_GetString(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 **** --- 1878,1908 ---- 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, TclMatchInDirectory, 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; } *************** *** 2026,2035 **** * if the string is a static. */ ! savedChar = *p; ! *p = '\0'; ! firstSpecialChar = strpbrk(tail, "*[]?\\"); ! *p = savedChar; } else { firstSpecialChar = strpbrk(tail, "*[]?\\"); } --- 2180,2189 ---- * if the string is a static. */ ! savedChar = *p; ! *p = '\0'; ! firstSpecialChar = strpbrk(tail, "*[]?\\"); ! *p = savedChar; } else { firstSpecialChar = strpbrk(tail, "*[]?\\"); } *************** *** 2037,2049 **** if (firstSpecialChar != NULL) { /* * Look for matching files in the current directory. The ! * implementation of this function is platform specific, but may ! * recursively call TclDoGlob. For each file that matches, it will ! * add the match onto the interp's result, or call TclDoGlob if there ! * are more characters to be processed. */ ! ! return TclpMatchFilesTypes(interp, separators, headPtr, tail, p, types); } Tcl_DStringAppend(headPtr, tail, p-tail); if (*p != '\0') { --- 2191,2237 ---- if (firstSpecialChar != NULL) { /* * Look for matching files in the current directory. The ! * implementation of this function is platform specific. For ! * each file that matches, it will add the match onto the ! * resultPtr given. */ ! int ret; ! Tcl_Obj * head = Tcl_NewStringObj(Tcl_DStringValue(headPtr),-1); ! Tcl_IncrRefCount(head); ! if (*p == '\0') { ! ret = Tcl_FSMatchInDirectory(interp, Tcl_GetObjResult(interp), head, tail, 0, types); ! } else { ! Tcl_Obj* resultPtr; ! /* We do the recursion ourselves */ ! char save = *p; ! *p = '\0'; ! resultPtr = Tcl_NewListObj(0, NULL); ! ret = Tcl_FSMatchInDirectory(interp, resultPtr, head, tail, 1, NULL); ! *p = save; ! if (ret == TCL_OK) { ! int resLength; ! ret = Tcl_ListObjLength(interp, resultPtr, &resLength); ! if (ret == TCL_OK) { ! int i; ! for (i =0; i< resLength; i++) { ! Tcl_Obj *elt; ! Tcl_DString ds; ! Tcl_ListObjIndex(interp, resultPtr, i, &elt); ! Tcl_DStringInit(&ds); ! Tcl_DStringAppend(&ds, Tcl_GetString(elt), -1); ! Tcl_DStringAppend(&ds, "/",1); ! ret = TclDoGlob(interp, separators, &ds, p+1, types); ! Tcl_DStringFree(&ds); ! if (ret != TCL_OK) { ! break; ! } ! } ! } ! } ! Tcl_DecrRefCount(resultPtr); ! } ! Tcl_DecrRefCount(head); ! return ret; } 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)); --- 2250,2256 ---- Tcl_DStringAppend(headPtr, ":", 1); } name = Tcl_DStringValue(headPtr); ! if (Tcl_Access(name, F_OK) == 0) { if ((name[1] != '\0') && (strchr(name+1, ':') == NULL)) { Tcl_ListObjAppendElement(interp, Tcl_GetObjResult(interp), Tcl_NewStringObj(name + 1,-1)); *************** *** 2080,2085 **** --- 2268,2276 ---- * We need to convert slashes to backslashes before checking * for the existence of the file. Once we are done, we need * to convert the slashes back. + * + * This backslash/forward slash conversion may no longer + * be necessary, since we have dropped Win3.1 support. */ if (Tcl_DStringLength(headPtr) == 0) { *************** *** 2097,2103 **** } } name = Tcl_DStringValue(headPtr); ! exists = (TclpAccess(name, F_OK) == 0); for (p = name; *p != '\0'; p++) { if (*p == '\\') { --- 2288,2294 ---- } } name = Tcl_DStringValue(headPtr); ! exists = (Tcl_Access(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)); } --- 2310,2316 ---- } } name = Tcl_DStringValue(headPtr); ! if (Tcl_Access(name, F_OK) == 0) { Tcl_ListObjAppendElement(interp, Tcl_GetObjResult(interp), Tcl_NewStringObj(name,-1)); } Index: generic/tclIO.c =================================================================== RCS file: /cvsroot/tcl/tcl/generic/tclIO.c,v retrieving revision 1.27 diff -c -r1.27 tclIO.c *** generic/tclIO.c 2000/10/28 00:29:20 1.27 --- generic/tclIO.c 2001/03/16 17:08:09 *************** *** 104,109 **** --- 104,111 ---- ClientData clientData, Tcl_Interp *interp)); static void DeleteScriptRecord _ANSI_ARGS_((Tcl_Interp *interp, Channel *chanPtr, int mask)); + static int DetachChannel _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Channel chan)); static void DiscardInputQueued _ANSI_ARGS_((ChannelState *statePtr, int discardSavedBuffers)); static void DiscardOutputQueued _ANSI_ARGS_(( *************** *** 683,688 **** --- 685,722 ---- /* *---------------------------------------------------------------------- * + * Tcl_IsStandardChannel -- + * + * Test if the given channel is a standard channel. No attempt + * is made to check if the channel or the standard channels + * are initialized or otherwise valid. + * + * Results: + * Returns 1 if true, 0 if false. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + int + Tcl_IsStandardChannel(chan) + Tcl_Channel chan; /* Channel to check. */ + { + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + + if ((chan == tsdPtr->stdinChannel) + || (chan == tsdPtr->stdoutChannel) + || (chan == tsdPtr->stderrChannel)) { + return 1; + } else { + return 0; + } + } + + /* + *---------------------------------------------------------------------- + * * Tcl_RegisterChannel -- * * Adds an already-open channel to the channel table of an interpreter. *************** *** 743,755 **** * * Deletes the hash entry for a channel associated with an interpreter. * If the interpreter given as argument is NULL, it only decrements the ! * reference count. * * Results: * A standard Tcl result. * * Side effects: ! * Deletes the hash entry for a channel associated with an interpreter. * *---------------------------------------------------------------------- */ --- 777,797 ---- * * Deletes the hash entry for a channel associated with an interpreter. * If the interpreter given as argument is NULL, it only decrements the ! * reference count. (This all happens in the Tcl_DetachChannel helper ! * function). ! * ! * Finally, if the reference count of the channel drops to zero, ! * it is deleted. * * Results: * A standard Tcl result. * * Side effects: ! * Calls Tcl_DetachChannel which deletes the hash entry for a channel ! * associated with an interpreter. ! * ! * May delete the channel, which can have a variety of consequences, ! * especially if we are forced to close the channel. * *---------------------------------------------------------------------- */ *************** *** 759,804 **** Tcl_Interp *interp; /* Interpreter in which channel is defined. */ Tcl_Channel chan; /* Channel to delete. */ { - Tcl_HashTable *hTblPtr; /* Hash table of channels. */ - Tcl_HashEntry *hPtr; /* Search variable. */ - Channel *chanPtr; /* The real IO channel. */ ChannelState *statePtr; /* State of the real channel. */ ! /* ! * Always (un)register bottom-most channel in the stack. This makes ! * management of the channel list easier because no manipulation is ! * necessary during (un)stack operation. ! */ ! chanPtr = ((Channel *) chan)->state->bottomChanPtr; ! statePtr = chanPtr->state; ! ! if (interp != (Tcl_Interp *) NULL) { ! hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL); ! if (hTblPtr == (Tcl_HashTable *) NULL) { ! return TCL_OK; ! } ! hPtr = Tcl_FindHashEntry(hTblPtr, statePtr->channelName); ! if (hPtr == (Tcl_HashEntry *) NULL) { ! return TCL_OK; ! } ! if ((Channel *) Tcl_GetHashValue(hPtr) != chanPtr) { ! return TCL_OK; ! } ! Tcl_DeleteHashEntry(hPtr); ! ! /* ! * Remove channel handlers that refer to this interpreter, so that they ! * will not be present if the actual close is delayed and more events ! * happen on the channel. This may occur if the channel is shared ! * between several interpreters, or if the channel has async ! * flushing active. ! */ ! ! CleanupChannelHandlers(interp, chanPtr); } - - statePtr->refCount--; /* * Perform special handling for standard channels being closed. If the * refCount is now 1 it means that the last reference to the standard --- 801,814 ---- Tcl_Interp *interp; /* Interpreter in which channel is defined. */ Tcl_Channel chan; /* Channel to delete. */ { ChannelState *statePtr; /* State of the real channel. */ ! if (DetachChannel(interp, chan) != TCL_OK) { ! return TCL_OK; } + statePtr = ((Channel *) chan)->state->bottomChanPtr->state; + /* * Perform special handling for standard channels being closed. If the * refCount is now 1 it means that the last reference to the standard *************** *** 825,839 **** statePtr->curOutPtr->nextRemoved)) { statePtr->flags |= BUFFER_READY; } - statePtr->flags |= CHANNEL_CLOSED; if (!(statePtr->flags & BG_FLUSH_SCHEDULED)) { ! if (Tcl_Close(interp, chan) != TCL_OK) { ! return TCL_ERROR; ! } } } return TCL_OK; } /* *--------------------------------------------------------------------------- --- 835,972 ---- statePtr->curOutPtr->nextRemoved)) { statePtr->flags |= BUFFER_READY; } if (!(statePtr->flags & BG_FLUSH_SCHEDULED)) { ! /* We don't want to re-enter Tcl_Close */ ! if (!(statePtr->flags & CHANNEL_CLOSED)) { ! if (Tcl_Close(interp, chan) != TCL_OK) { ! statePtr->flags |= CHANNEL_CLOSED; ! return TCL_ERROR; ! } ! } } + statePtr->flags |= CHANNEL_CLOSED; } return TCL_OK; } + + /* + *---------------------------------------------------------------------- + * + * Tcl_DetachChannel -- + * + * Deletes the hash entry for a channel associated with an interpreter. + * If the interpreter given as argument is NULL, it only decrements the + * reference count. Even if the ref count drops to zero, the + * channel is NOT closed or cleaned up. This allows a channel to + * be detached from an interpreter and left in the same state it + * was in when it was originally returned by 'Tcl_OpenFileChannel', + * for example. + * + * This function cannot be used on the standard channels, and + * will return TCL_ERROR if that is attempted. + * + * This function should only be necessary for special purposes + * in which you need to generate a pristine channel from one + * that has already been used. All ordinary purposes will almost + * always want to use Tcl_UnregisterChannel instead. + * + * Results: + * A standard Tcl result. If the channel is not currently registered + * with the given interpreter, TCL_ERROR is returned, otherwise + * TCL_OK. However no error messages are left in the interp's result. + * + * Side effects: + * Deletes the hash entry for a channel associated with an + * interpreter. + * + *---------------------------------------------------------------------- + */ + + int + Tcl_DetachChannel(interp, chan) + Tcl_Interp *interp; /* Interpreter in which channel is defined. */ + Tcl_Channel chan; /* Channel to delete. */ + { + if (Tcl_IsStandardChannel(chan)) { + return TCL_ERROR; + } + + return DetachChannel(interp, chan); + } + + /* + *---------------------------------------------------------------------- + * + * DetachChannel -- + * + * Deletes the hash entry for a channel associated with an interpreter. + * If the interpreter given as argument is NULL, it only decrements the + * reference count. Even if the ref count drops to zero, the + * channel is NOT closed or cleaned up. This allows a channel to + * be detached from an interpreter and left in the same state it + * was in when it was originally returned by 'Tcl_OpenFileChannel', + * for example. + * + * Results: + * A standard Tcl result. If the channel is not currently registered + * with the given interpreter, TCL_ERROR is returned, otherwise + * TCL_OK. However no error messages are left in the interp's result. + * + * Side effects: + * Deletes the hash entry for a channel associated with an + * interpreter. + * + *---------------------------------------------------------------------- + */ + + int + DetachChannel(interp, chan) + Tcl_Interp *interp; /* Interpreter in which channel is defined. */ + Tcl_Channel chan; /* Channel to delete. */ + { + Tcl_HashTable *hTblPtr; /* Hash table of channels. */ + Tcl_HashEntry *hPtr; /* Search variable. */ + Channel *chanPtr; /* The real IO channel. */ + ChannelState *statePtr; /* State of the real channel. */ + + /* + * Always (un)register bottom-most channel in the stack. This makes + * management of the channel list easier because no manipulation is + * necessary during (un)stack operation. + */ + chanPtr = ((Channel *) chan)->state->bottomChanPtr; + statePtr = chanPtr->state; + + if (interp != (Tcl_Interp *) NULL) { + hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL); + if (hTblPtr == (Tcl_HashTable *) NULL) { + return TCL_ERROR; + } + hPtr = Tcl_FindHashEntry(hTblPtr, statePtr->channelName); + if (hPtr == (Tcl_HashEntry *) NULL) { + return TCL_ERROR; + } + if ((Channel *) Tcl_GetHashValue(hPtr) != chanPtr) { + return TCL_ERROR; + } + Tcl_DeleteHashEntry(hPtr); + + /* + * Remove channel handlers that refer to this interpreter, so that they + * will not be present if the actual close is delayed and more events + * happen on the channel. This may occur if the channel is shared + * between several interpreters, or if the channel has async + * flushing active. + */ + + CleanupChannelHandlers(interp, chanPtr); + } + + statePtr->refCount--; + + return TCL_OK; + } + /* *--------------------------------------------------------------------------- Index: generic/tclIOCmd.c =================================================================== RCS file: /cvsroot/tcl/tcl/generic/tclIOCmd.c,v retrieving revision 1.7 diff -c -r1.7 tclIOCmd.c *** generic/tclIOCmd.c 1999/09/21 04:20:40 1.7 --- generic/tclIOCmd.c 2001/03/16 17:08:09 *************** *** 953,959 **** */ if (!pipeline) { ! chan = Tcl_OpenFileChannel(interp, what, modeString, prot); } else { #ifdef MAC_TCL Tcl_AppendResult(interp, --- 953,959 ---- */ if (!pipeline) { ! chan = Tcl_FSOpenFileChannel(interp, objv[1], modeString, prot); } else { #ifdef MAC_TCL Tcl_AppendResult(interp, Index: generic/tclIOUtil.c =================================================================== RCS file: /cvsroot/tcl/tcl/generic/tclIOUtil.c,v retrieving revision 1.11 diff -c -r1.11 tclIOUtil.c *** generic/tclIOUtil.c 2000/05/27 23:58:01 1.11 --- generic/tclIOUtil.c 2001/03/16 17:08:10 *************** *** 1,8 **** /* * tclIOUtil.c -- * ! * This file contains a collection of utility procedures that ! * are shared by the platform specific IO drivers. * * Parts of this file are based on code contributed by Karl * Lehenbauer, Mark Diekhans and Peter da Silva. --- 1,12 ---- /* * tclIOUtil.c -- * ! * This file contains the implementation of Tcl's generic ! * filesystem code, which supports a pluggable filesystem ! * architecture allowing both platform specific filesystems and ! * 'virtual filesystems'. All filesystem access should go through ! * the functions defined in this file. Most of this code was ! * contributed by Vince Darley. * * Parts of this file are based on code contributed by Karl * Lehenbauer, Mark Diekhans and Peter da Silva. *************** *** 18,24 **** --- 22,193 ---- #include "tclInt.h" #include "tclPort.h" + + /* + * Prototypes for procedures defined later in this file: + */ + + static void DupFsPathInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr, + Tcl_Obj *copyPtr)); + static void FreeFsPathInternalRep _ANSI_ARGS_((Tcl_Obj *listPtr)); + static int SetFsPathFromAny _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr)); + static Tcl_Filesystem* Tcl_FSGetFileSystemForPath _ANSI_ARGS_((Tcl_Obj* pathObjPtr)); + static Tcl_Obj* Tcl_FSNormalizeAbsolutePath _ANSI_ARGS_((Tcl_Interp* interp, char *path)); + static int TclNormalizeToUniquePath _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *pathPtr)); + static int SetFsPathFromAbsoluteNormalized _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr)); + static int FindSplitPos _ANSI_ARGS_((char *path)); + + /* + * Define the 'path' object type, which Tcl uses to represent + * file paths internally. + */ + Tcl_ObjType tclFsPathType = { + "path", /* name */ + FreeFsPathInternalRep, /* freeIntRepProc */ + DupFsPathInternalRep, /* dupIntRepProc */ + NULL, /* updateStringProc */ + SetFsPathFromAny /* setFromAnyProc */ + }; + + /* + * These form part of the native filesystem support. They are needed + * here because we have a few native filesystem functions (which are + * the same for mac/win/unix) in this file. There is no need to place + * them in tclInt.h, because they are not (and should not be) used + * anywhere else. + */ + extern char * tclpFileAttrStrings[]; + extern CONST TclFileAttrProcs tclpFileAttrProcs[]; + + /* + * The following functions are obsolete string based APIs, and should + * be removed in a future release. + */ + + /* Obsolete */ + int + TclStat(path, buf) + CONST char *path; /* Path of file to stat (in current CP). */ + struct stat *buf; /* Filled with results of stat call. */ + { + return Tcl_Stat(path,buf); + } + + /* Obsolete */ + int + TclAccess(path, mode) + CONST char *path; /* Path of file to access (in current CP). */ + int mode; /* Permission setting. */ + { + return Tcl_Access(path, mode); + } + + /* Obsolete */ + int + Tcl_Stat(path, buf) + CONST char *path; /* Path of file to stat (in current CP). */ + struct stat *buf; /* Filled with results of stat call. */ + { + int ret; + Tcl_Obj *pathPtr = Tcl_NewStringObj(path,-1); + Tcl_IncrRefCount(pathPtr); + ret = Tcl_FSStat(pathPtr,buf); + Tcl_DecrRefCount(pathPtr); + return ret; + } + + /* Obsolete */ + int + Tcl_Access(path, mode) + CONST char *path; /* Path of file to access (in current CP). */ + int mode; /* Permission setting. */ + { + int ret; + Tcl_Obj *pathPtr = Tcl_NewStringObj(path,-1); + Tcl_IncrRefCount(pathPtr); + ret = Tcl_FSAccess(pathPtr,mode); + Tcl_DecrRefCount(pathPtr); + return ret; + } + + /* Obsolete */ + Tcl_Channel + Tcl_OpenFileChannel(interp, path, modeString, permissions) + Tcl_Interp *interp; /* Interpreter for error reporting; + * can be NULL. */ + char *path; /* 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 ret; + Tcl_Obj *pathPtr = Tcl_NewStringObj(path,-1); + Tcl_IncrRefCount(pathPtr); + ret = Tcl_FSOpenFileChannel(interp, pathPtr, modeString, permissions); + Tcl_DecrRefCount(pathPtr); + return ret; + + } + + /* Obsolete */ + int Tcl_Chdir(CONST char *dirName) { + int ret; + Tcl_Obj *pathPtr = Tcl_NewStringObj(dirName,-1); + Tcl_IncrRefCount(pathPtr); + ret = Tcl_FSChdir(pathPtr); + Tcl_DecrRefCount(pathPtr); + return ret; + } + + /* Obsolete */ + char * + Tcl_GetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr) { + Tcl_Obj *cwd; + cwd = Tcl_FSGetCwd(interp); + if (cwd == NULL) { + return NULL; + } else { + Tcl_DStringInit(cwdPtr); + Tcl_DStringAppend(cwdPtr, Tcl_GetString(cwd), -1); + Tcl_DecrRefCount(cwd); + return Tcl_DStringValue(cwdPtr); + } + } + + /* Obsolete */ + int + Tcl_EvalFile(interp, fileName) + Tcl_Interp *interp; /* Interpreter in which to process file. */ + char *fileName; /* Name of file to process. Tilde-substitution + * will be performed on this name. */ + { + int ret; + Tcl_Obj *pathPtr = Tcl_NewStringObj(fileName,-1); + Tcl_IncrRefCount(pathPtr); + ret = Tcl_FSEvalFile(interp, pathPtr); + Tcl_DecrRefCount(pathPtr); + return ret; + } + + + /* + * The 3 hooks for Stat, Access and OpenFileChannel are obsolete. The + * complete, general hooked filesystem APIs should be used instead. + * This define decides whether to include the obsolete hooks and + * related code. If these are removed, we'll also want to remove them + * from stubs/tclInt. The only known user of these APIs is prowrap. + * New code/extensions should not use them, since they will be removed + * once prowrap no longer requires them. + */ + #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(...)' & *************** *** 45,54 **** } OpenFileChannelProc; /* ! * For each type of hookable function, a static node is declared to ! * hold the function pointer for the "built-in" routine (e.g. ! * 'TclpStat(...)') and the respective list is initialized as a pointer ! * to that node. * * The "delete" functions (e.g. 'TclStatDeleteProc(...)') ensure that * these statically declared list entry cannot be inadvertently removed. --- 214,223 ---- } OpenFileChannelProc; /* ! * For each type of (obsolete) hookable function, a static node is ! * declared to hold the function pointer for the "built-in" routine ! * (e.g. 'TclpStat(...)') and the respective list is initialized as a ! * pointer to that node. * * The "delete" functions (e.g. 'TclStatDeleteProc(...)') ensure that * these statically declared list entry cannot be inadvertently removed. *************** *** 56,81 **** * This method avoids the need to call any sort of "initialization" * function. * ! * 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) /* *--------------------------------------------------------------------------- --- 225,740 ---- * This method avoids the need to call any sort of "initialization" * function. * ! * All three lists are protected by a global filesystemMutex. */ ! static StatProc *statProcList = NULL; ! static AccessProc *accessProcList = NULL; ! static OpenFileChannelProc *openFileChannelProcList = NULL; ! ! #endif /* USE_OBSOLETE_FS_HOOKS */ ! ! /* ! * A filesystem record is used to keep track of each ! * filesystem currently registered with the core, ! * in a linked list. ! */ ! typedef struct Tcl_FilesystemRecord { ! ClientData clientData; /* Client specific data for the new ! * filesystem (can be NULL) */ ! Tcl_Filesystem *fsPtr; /* Pointer to filesystem dispatch ! * table. */ ! int refCount; /* How many Tcl_Obj's use this ! * filesystem. */ ! struct Tcl_FilesystemRecord *nextPtr; ! /* The next filesystem registered ! * to Tcl, or NULL if no more. */ ! } Tcl_FilesystemRecord; ! ! /* ! * Declare the native filesystem support. These functions should ! * be considered private to Tcl, and should really not be called ! * directly by any code other than this file (i.e. neither by ! * Tcl's core nor by extensions). Similarly, the old string-based ! * Tclp... native filesystem functions should not be called. ! * ! * The correct API to use now is the Tclfs... set of functions, ! * which ensure correct and complete virtual filesystem support. ! */ ! TclfsPathInFilesystem_ TclpPathInNativeFilesystem; ! TclfsFilesystemPathType_ TclpFilesystemPathType; ! TclfsFilesystemSeparatorProc_ TclpFilesystemSeparator; ! TclfsFreeInternalRep_ TclpNativeFreeInternalRep; ! TclfsDupInternalRep_ TclpNativeDupInternalRep; ! TclfsStatProc_ TclpObjStat; ! TclfsAccessProc_ TclpObjAccess; ! TclfsOpenFileChannelProc_ TclpObjOpenFileChannel; ! TclfsMatchInDirectoryProc_ TclpMatchInDirectory; ! TclfsGetCwdProc_ TclpObjGetCwd; ! TclfsChdirProc_ TclpObjChdir; ! TclfsLstatProc_ TclpObjLstat; ! TclfsCopyFileProc_ TclpObjCopyFile; ! TclfsDeleteFileProc_ TclpObjDeleteFile; ! TclfsRenameFileProc_ TclpObjRenameFile; ! TclfsCreateDirectoryProc_ TclpObjCreateDirectory; ! TclfsCopyDirectoryProc_ TclpObjCopyDirectory; ! TclfsRemoveDirectoryProc_ TclpObjRemoveDirectory; ! TclfsLoadFileProc_ TclpObjLoadFile; ! TclfsUnloadFileProc_ TclpUnloadFile; ! TclfsReadlinkProc_ TclpObjReadlink; ! TclfsListVolumesProc_ TclpListVolumes; ! TclfsFileAttrStringsProc_ TclpObjFileAttrStrings; ! TclfsFileAttrsGetProc_ TclpObjFileAttrsGet; ! TclfsFileAttrsSetProc_ TclpObjFileAttrsSet; ! TclfsUtimeProc_ TclpObjUtime; ! TclfsInternalToNormalizedProc_ TclpNativeToNormalized; ! TclfsConvertToInternalProc_ TclpConvertToNative; ! ! /* Define the native filesystem dispatch table */ ! static Tcl_Filesystem nativeFilesystem = { ! "native", ! sizeof(Tcl_Filesystem), ! TCL_FILESYSTEM_VERSION_1, ! &TclpPathInNativeFilesystem, ! &TclpFilesystemPathType, ! &TclpFilesystemSeparator, ! &TclpNativeDupInternalRep, ! &TclpNativeFreeInternalRep, ! &TclpNativeToNormalized, ! &TclpConvertToNative, ! &TclpObjStat, ! &TclpObjAccess, ! &TclpObjOpenFileChannel, ! &TclpMatchInDirectory, ! &TclpObjGetCwd, ! &TclpObjChdir, ! &TclpObjLstat, ! &TclpObjCopyFile, ! &TclpObjDeleteFile, ! &TclpObjRenameFile, ! &TclpObjCreateDirectory, ! &TclpObjCopyDirectory, ! &TclpObjRemoveDirectory, ! &TclpObjLoadFile, ! &TclpUnloadFile, ! #ifndef S_IFLNK ! NULL, ! #else ! &TclpObjReadlink, ! #endif /* S_IFLNK */ ! &TclpListVolumes, ! &TclpObjFileAttrStrings, ! &TclpObjFileAttrsGet, ! &TclpObjFileAttrsSet, ! &TclpObjUtime, ! &TclpObjNormalizePath }; ! /* ! * Define the tail of the linked list. Note that for unconventional ! * uses of Tcl without a native filesystem, we may in the future wish ! * to modify the current approach of hard-coding the native filesystem ! * in the lookup list 'filesystemList' below. ! */ ! static Tcl_FilesystemRecord nativeFilesystemRecord = { ! NULL, ! &nativeFilesystem, ! 1, ! NULL }; ! /* ! * The following two variables are protected by the ! * filesystemMutex below. ! */ ! ! int filesystemEpoch = 0; ! /* Stores the linked list of filesystems.*/ ! static Tcl_FilesystemRecord *filesystemList = &nativeFilesystemRecord; ! ! TCL_DECLARE_MUTEX(filesystemMutex) ! ! /* ! * struct FsPath -- ! * ! * Internal representation of a Tcl_Obj of "path" type. This ! * can be used to represent relative or absolute paths, and has ! * certain optimisations when used to represent paths which are ! * already normalized and absolute. ! * ! * Note that 'normPathPtr' can be a circular reference to the ! * container Tcl_Obj of this FsPath. ! */ ! typedef struct FsPath { ! char *translatedPathPtr; /* Name without any ~user sequences. ! * If this is NULL, then this is a ! * pure normalized, absolute path ! * object, in which the parent Tcl_Obj's ! * string rep is already both translated ! * and normalized. */ ! Tcl_Obj *normPathPtr; /* Normalized absolute path, without ! * ., .. or ~user sequences. If the ! * Tcl_Obj containing ! * this FsPath is already normalized, ! * this may be a circular reference back ! * to the container. If that is NOT the ! * case, we have a refCount on the object. */ ! Tcl_Obj *cwdPtr; /* If null, path is absolute, else ! * this points to the cwd object used ! * for this path. We have a refCount ! * on the object. */ ! ClientData nativePathPtr; /* Native representation of this path, ! * which is filesystem dependent. */ ! int filesystemEpoch; /* Used to ensure the path representation ! * was generated during the correct ! * filesystem epoch. The epoch changes ! * when filesystem-mounts are changed. */ ! struct Tcl_FilesystemRecord *fsRecPtr; ! /* Pointer to the filesystem record ! * entry to use for this path. */ ! } FsPath; ! ! /* ! * Used to implement Tcl_FSGetCwd in a file-system independent way. ! * This is protected by the cwdMutex below. ! */ ! static Tcl_Obj* cwdPathPtr = NULL; ! TCL_DECLARE_MUTEX(cwdMutex) ! ! ! /* ! *---------------------------------------------------------------------- ! * ! * 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(&filesystemMutex); ! newFilesystemPtr->nextPtr = filesystemList; ! filesystemList = newFilesystemPtr; ! Tcl_MutexUnlock(&filesystemMutex); ! ! 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(&filesystemMutex); ! 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 != &nativeFilesystemRecord)) { ! if (tmpFsRecPtr->fsPtr == fsPtr) { ! if (prevFsRecPtr == NULL) { ! filesystemList = filesystemList->nextPtr; ! } else { ! prevFsRecPtr->nextPtr = tmpFsRecPtr->nextPtr; ! } ! ckfree((char *)tmpFsRecPtr); ! ! retVal = TCL_OK; ! } else { ! prevFsRecPtr = tmpFsRecPtr; ! tmpFsRecPtr = tmpFsRecPtr->nextPtr; ! } ! } ! ! Tcl_MutexUnlock(&filesystemMutex); ! 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 query. */ ! { ! ClientData retVal = NULL; ! Tcl_FilesystemRecord *tmpFsRecPtr; ! ! Tcl_MutexLock(&filesystemMutex); ! 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(&filesystemMutex); ! return (retVal); ! } ! ! /* ! *--------------------------------------------------------------------------- ! * ! * Tcl_FSNormalizeAbsolutePath -- ! * ! * Description: ! * Takes an absolute path specification and computes a 'normalized' ! * path from it. 'retPtr' should be a pointer to a free or ! * uninitialized DString. ! * ! * A normalized path is one which has all '../', './' removed. ! * Also it is one which is in the 'standard' format for the native ! * platform. On MacOS, Unix, this means the path must be free of ! * symbolic links/aliases, and on Windows it means we want the ! * long form, with that long form's case-dependence (which gives ! * us a unique, case-dependent path). ! * ! * Results: ! * The result is returned in a Tcl_Obj with a refCount of 1, ! * which is therefore owned by the caller. It must be ! * freed (with Tcl_DecrRefCount) 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, with additions from Vince Darley and is copyright ! * those respective authors. ! * ! *--------------------------------------------------------------------------- ! */ ! static Tcl_Obj* ! Tcl_FSNormalizeAbsolutePath(interp, path) ! Tcl_Interp* interp; ! char *path; ! { ! char **sp = NULL, *np[BUFSIZ]; ! int splen = 0, nplen, i; ! Tcl_Obj *retVal; ! ! Tcl_SplitPath(path, &splen, &sp); ! ! 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_DString dtemp; ! Tcl_DStringInit(&dtemp); ! Tcl_JoinPath(nplen, (CONST char **)np, &dtemp); ! /* ! * Now we have an absolute path, with no '..', '.' sequences, ! * but it still may not be in 'unique' form, depending on the ! * platform. For instance, Unix is case-sensitive, so the ! * path is ok. Windows is case-insensitive, and also has the ! * weird 'longname/shortname' thing (e.g. C:/Program Files/ and ! * C:/Progra~1/ are equivalent). MacOS is case-insensitive. ! * ! * Virtual file systems which may be registered may have ! * other criteria for normalizing a path. ! */ ! retVal = Tcl_NewStringObj(Tcl_DStringValue(&dtemp),-1); ! Tcl_DStringFree(&dtemp); ! Tcl_IncrRefCount(retVal); ! TclNormalizeToUniquePath(interp, retVal); ! /* ! * Since we know it is a normalized path, we can ! * actually convert this object into an FsPath for ! * greater efficiency ! */ ! SetFsPathFromAbsoluteNormalized(interp, retVal); ! } else { ! /* Init to an empty string */ ! retVal = Tcl_NewStringObj("",0); ! Tcl_IncrRefCount(retVal); ! } ! ckfree((char*) sp); ! ! /* This has a refCount of 1 for the caller */ ! return retVal; ! } ! ! /* ! *--------------------------------------------------------------------------- ! * ! * TclNormalizeToUniquePath -- ! * ! * Description: ! * Takes a path specification containing no ../, ./ sequences, ! * and converts it into a unique path for the given platform. ! * On MacOS, Unix, this means the path must be free of ! * symbolic links/aliases, and on Windows it means we want the ! * long form, with that long form's case-dependence (which gives ! * us a unique, case-dependent path). ! * ! * Results: ! * The result is returned in a Tcl_Obj with a refCount of 1, ! * which is therefore owned by the caller. It must be ! * freed (with Tcl_DecrRefCount) by the caller when no longer needed. ! * ! * Side effects: ! * None (beyond the memory allocation for the result). ! * ! * Special note: ! * This is only used by the above function. Also if the ! * filesystem-specific normalizePathProcs can re-introduce ! * ../, ./ sequences into the path, then this function will ! * not return the correct result. This may be possible with ! * symbolic links on unix/macos. ! * ! *--------------------------------------------------------------------------- ! */ ! static int ! TclNormalizeToUniquePath(interp, pathPtr) ! Tcl_Interp *interp; ! Tcl_Obj *pathPtr; ! { ! Tcl_FilesystemRecord *fsRecPtr; ! int retVal = 0; ! ! /* ! * Call each of the "normalise path" functions in succession. This is ! * a special case, in which if we have a native filesystem handler, ! * we call it first. This is because the root of Tcl's filesystem ! * is always a native filesystem (i.e. '/' on unix is native). ! */ ! ! Tcl_MutexLock(&filesystemMutex); ! fsRecPtr = filesystemList; ! while (fsRecPtr != NULL) { ! if (fsRecPtr == &nativeFilesystemRecord) { ! TclfsNormalizePathProc_ *proc = fsRecPtr->fsPtr->normalizePathProc; ! if (proc != NULL) { ! retVal = (*proc)(interp, pathPtr, retVal); ! } ! break; ! } ! fsRecPtr = fsRecPtr->nextPtr; ! } ! fsRecPtr = filesystemList; ! while (fsRecPtr != NULL) { ! /* Skip the native system next time through */ ! if (fsRecPtr != &nativeFilesystemRecord) { ! TclfsNormalizePathProc_ *proc = fsRecPtr->fsPtr->normalizePathProc; ! if (proc != NULL) { ! retVal = (*proc)(interp, pathPtr, retVal); ! } ! /* ! * We could add an efficiency check like this: ! * ! * if (retVal == Tcl_DStringLength(pathPtr)) {break;} ! * ! * but there's not much benefit. ! */ ! } ! fsRecPtr = fsRecPtr->nextPtr; ! } ! Tcl_MutexUnlock(&filesystemMutex); ! ! return (retVal); ! } /* *--------------------------------------------------------------------------- *************** *** 255,261 **** /* *---------------------------------------------------------------------- * ! * Tcl_EvalFile -- * * Read in a file and process the entire file as one gigantic * Tcl command. --- 914,920 ---- /* *---------------------------------------------------------------------- * ! * Tcl_FSEvalFile -- * * Read in a file and process the entire file as one gigantic * Tcl command. *************** *** 265,308 **** * the file or an error indicating why the file couldn't be read. * * Side effects: ! * Depends on the commands in the file. * *---------------------------------------------------------------------- */ int ! Tcl_EvalFile(interp, fileName) Tcl_Interp *interp; /* Interpreter in which to process file. */ ! char *fileName; /* Name of file to process. Tilde-substitution * will be performed on this name. */ { int result, length; struct stat statBuf; ! char *oldScriptFile; Interp *iPtr; ! Tcl_DString nameString; ! char *name, *string; Tcl_Channel chan; Tcl_Obj *objPtr; ! name = Tcl_TranslateFileName(interp, fileName, &nameString); ! if (name == NULL) { return TCL_ERROR; } result = TCL_ERROR; objPtr = Tcl_NewObj(); ! if (TclStat(name, &statBuf) == -1) { Tcl_SetErrno(errno); ! Tcl_AppendResult(interp, "couldn't read file \"", fileName, "\": ", Tcl_PosixError(interp), (char *) NULL); goto end; } ! chan = Tcl_OpenFileChannel(interp, name, "r", 0644); if (chan == (Tcl_Channel) NULL) { Tcl_ResetResult(interp); ! Tcl_AppendResult(interp, "couldn't read file \"", fileName, "\": ", Tcl_PosixError(interp), (char *) NULL); goto end; } --- 924,968 ---- * the file or an error indicating why the file couldn't be read. * * Side effects: ! * Depends on the commands in the file. During the evaluation ! * of the contents of the file, iPtr->scriptFile is made to ! * point to fileName (the old value is cached and replaced when ! * this function returns). * *---------------------------------------------------------------------- */ int ! Tcl_FSEvalFile(interp, fileName) Tcl_Interp *interp; /* Interpreter in which to process file. */ ! Tcl_Obj *fileName; /* Name of file to process. Tilde-substitution * will be performed on this name. */ { int result, length; struct stat statBuf; ! Tcl_Obj *oldScriptFile; Interp *iPtr; ! char *string; Tcl_Channel chan; Tcl_Obj *objPtr; ! if (Tcl_FSGetTranslatedPath(interp, fileName) == NULL) { return TCL_ERROR; } result = TCL_ERROR; objPtr = Tcl_NewObj(); ! if (Tcl_FSStat(fileName, &statBuf) == -1) { Tcl_SetErrno(errno); ! Tcl_AppendResult(interp, "couldn't read file \"", Tcl_GetString(fileName), "\": ", Tcl_PosixError(interp), (char *) NULL); goto end; } ! chan = Tcl_FSOpenFileChannel(interp, fileName, "r", 0644); if (chan == (Tcl_Channel) NULL) { Tcl_ResetResult(interp); ! Tcl_AppendResult(interp, "couldn't read file \"", Tcl_GetString(fileName), "\": ", Tcl_PosixError(interp), (char *) NULL); goto end; } *************** *** 314,320 **** Tcl_SetChannelOption(interp, chan, "-eofchar", "\32"); if (Tcl_ReadChars(chan, objPtr, -1, 0) < 0) { Tcl_Close(interp, chan); ! Tcl_AppendResult(interp, "couldn't read file \"", fileName, "\": ", Tcl_PosixError(interp), (char *) NULL); goto end; } --- 974,980 ---- Tcl_SetChannelOption(interp, chan, "-eofchar", "\32"); if (Tcl_ReadChars(chan, objPtr, -1, 0) < 0) { Tcl_Close(interp, chan); ! Tcl_AppendResult(interp, "couldn't read file \"", Tcl_GetString(fileName), "\": ", Tcl_PosixError(interp), (char *) NULL); goto end; } *************** *** 324,334 **** iPtr = (Interp *) interp; oldScriptFile = iPtr->scriptFile; ! iPtr->scriptFile = ckalloc((unsigned) (strlen(fileName) + 1)); ! strcpy(iPtr->scriptFile, fileName); string = Tcl_GetStringFromObj(objPtr, &length); result = Tcl_EvalEx(interp, string, length, 0); ! ckfree(iPtr->scriptFile); iPtr->scriptFile = oldScriptFile; if (result == TCL_RETURN) { --- 984,1001 ---- iPtr = (Interp *) interp; oldScriptFile = iPtr->scriptFile; ! iPtr->scriptFile = fileName; ! Tcl_IncrRefCount(iPtr->scriptFile); string = Tcl_GetStringFromObj(objPtr, &length); result = Tcl_EvalEx(interp, string, length, 0); ! /* ! * Now we have to be careful; the script may have changed the ! * iPtr->scriptFile value, so we must reset it without ! * assuming it still points to 'fileName'. ! */ ! if (iPtr->scriptFile != NULL) { ! Tcl_DecrRefCount(iPtr->scriptFile); ! } iPtr->scriptFile = oldScriptFile; if (result == TCL_RETURN) { *************** *** 340,353 **** * Record information telling where the error occurred. */ ! sprintf(msg, "\n (file \"%.150s\" line %d)", fileName, interp->errorLine); Tcl_AddErrorInfo(interp, msg); } end: Tcl_DecrRefCount(objPtr); - Tcl_DStringFree(&nameString); return result; } --- 1007,1019 ---- * Record information telling where the error occurred. */ ! sprintf(msg, "\n (file \"%.150s\" line %d)", Tcl_GetString(fileName), interp->errorLine); Tcl_AddErrorInfo(interp, msg); } end: Tcl_DecrRefCount(objPtr); return result; } *************** *** 435,446 **** /* *---------------------------------------------------------------------- * ! * TclStat -- * * 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. --- 1101,1112 ---- /* *---------------------------------------------------------------------- * ! * Tcl_FSStat -- * * This procedure replaces the library version of stat and lsat. ! * ! * The appropriate function for the filesystem to which pathPtr ! * belongs will be called. * * Results: * See stat documentation. *************** *** 452,489 **** */ int ! TclStat(path, buf) ! CONST char *path; /* Path of file to stat (in current CP). */ struct stat *buf; /* Filled with results of stat call. */ { StatProc *statProcPtr; int retVal = -1; /* * Call each of the "stat" function in succession. A non-return * value of -1 indicates the particular function has succeeded. */ ! Tcl_MutexLock(&hookMutex); statProcPtr = statProcList; while ((retVal == -1) && (statProcPtr != NULL)) { retVal = (*statProcPtr->proc)(path, buf); statProcPtr = statProcPtr->nextPtr; } ! Tcl_MutexUnlock(&hookMutex); ! return (retVal); } /* *---------------------------------------------------------------------- * ! * TclAccess -- * * 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. --- 1118,1213 ---- */ int ! Tcl_FSStat(pathPtr, buf) ! Tcl_Obj *pathPtr; /* 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 */ int retVal = -1; + char *path = Tcl_FSGetTranslatedPath(NULL, pathPtr); /* * Call each of the "stat" function in succession. A non-return * value of -1 indicates the particular function has succeeded. */ ! Tcl_MutexLock(&filesystemMutex); ! #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 */ ! if (retVal == -1) { ! Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); ! if (fsPtr != NULL) { ! TclfsStatProc_ *proc = fsPtr->statProc; ! if (proc != NULL) { ! retVal = (*proc)(pathPtr, buf); ! } ! } ! } ! if (retVal != 0) { ! retVal = -1; ! Tcl_SetErrno(ENOENT); ! } return (retVal); } /* *---------------------------------------------------------------------- + * + * Tcl_FSLstat -- + * + * This procedure replaces the library version of lstat. + * The appropriate function for the filesystem to which pathPtr + * belongs will be called. + * + * Results: + * See lstat documentation. + * + * Side effects: + * See lstat documentation. + * + *---------------------------------------------------------------------- + */ + + int + Tcl_FSLstat(pathPtr, buf) + Tcl_Obj *pathPtr; /* Path of file to stat (in current CP). */ + struct stat *buf; /* Filled with results of stat call. */ + { + int retVal = -1; + Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); + if (fsPtr != NULL) { + TclfsLstatProc_ *proc = fsPtr->lstatProc; + if (proc != NULL) { + retVal = (*proc)(pathPtr, buf); + } + } + /* + * Some code in Tcl's core actually checks specifically for a + * zero or non-zero return code from lstat, which is perhaps + * not a good idea. + */ + if (retVal != 0 && retVal != -1) { + retVal = -1; + Tcl_SetErrno(ENOENT); + } + return retVal; + } + + /* + *---------------------------------------------------------------------- * ! * Tcl_FSAccess -- * * This procedure replaces the library version of access. ! * The appropriate function for the filesystem to which pathPtr ! * belongs will be called. * * Results: * See access documentation. *************** *** 495,519 **** */ int ! TclAccess(path, mode) ! CONST char *path; /* Path of file to access (in current CP). */ int mode; /* Permission setting. */ { AccessProc *accessProcPtr; int retVal = -1; /* * Call each of the "access" function in succession. A non-return * value of -1 indicates the particular function has succeeded. */ ! Tcl_MutexLock(&hookMutex); accessProcPtr = accessProcList; while ((retVal == -1) && (accessProcPtr != NULL)) { retVal = (*accessProcPtr->proc)(path, mode); accessProcPtr = accessProcPtr->nextPtr; } - Tcl_MutexUnlock(&hookMutex); return (retVal); } --- 1219,1256 ---- */ int ! Tcl_FSAccess(pathPtr, mode) ! Tcl_Obj *pathPtr; /* Path of file to access (in current CP). */ int mode; /* Permission setting. */ { + #ifdef USE_OBSOLETE_FS_HOOKS AccessProc *accessProcPtr; + #endif /* USE_OBSOLETE_FS_HOOKS */ int retVal = -1; + char *path = Tcl_FSGetTranslatedPath(NULL, pathPtr); /* * Call each of the "access" function in succession. A non-return * value of -1 indicates the particular function has succeeded. */ ! Tcl_MutexLock(&filesystemMutex); ! #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 */ + if (retVal == -1) { + Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); + if (fsPtr != NULL) { + TclfsAccessProc_ *proc = fsPtr->accessProc; + if (proc != NULL) { + return (*proc)(pathPtr, mode); + } + } } return (retVal); } *************** *** 521,574 **** /* *---------------------------------------------------------------------- * ! * 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. * * Side effects: ! * May open the channel and may cause creation of a file on the ! * file system. * ! *---------------------------------------------------------------------- */ - - Tcl_Channel - Tcl_OpenFileChannel(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? */ - { - OpenFileChannelProc *openFileChannelProcPtr; - Tcl_Channel retVal = NULL; /* ! * Call each of the "Tcl_OpenFileChannel" function in succession. ! * A non-NULL return value indicates the particular function has * succeeded. */ ! 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); } /* *---------------------------------------------------------------------- --- 1258,3369 ---- /* *---------------------------------------------------------------------- * ! * Tcl_FSOpenFileChannel -- * ! * The appropriate function for the filesystem to which pathPtr ! * belongs will be called. ! * ! * Results: ! * The new channel or NULL, if the named file could not be opened. ! * ! * Side effects: ! * May open the channel and may cause creation of a file on the ! * file system. ! * ! *---------------------------------------------------------------------- ! */ ! ! Tcl_Channel ! Tcl_FSOpenFileChannel(interp, pathPtr, modeString, permissions) ! Tcl_Interp *interp; /* Interpreter for error reporting; ! * can be NULL. */ ! Tcl_Obj *pathPtr; /* 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? */ ! { ! #ifdef USE_OBSOLETE_FS_HOOKS ! OpenFileChannelProc *openFileChannelProcPtr; ! #endif /* USE_OBSOLETE_FS_HOOKS */ ! Tcl_Channel retVal = NULL; ! char *path = Tcl_FSGetTranslatedPath(interp, pathPtr); ! if (path == NULL) { ! return NULL; ! } ! ! /* ! * Call each of the "Tcl_OpenFileChannel" function in succession. ! * A non-NULL return value indicates the particular function has ! * succeeded. ! */ ! ! Tcl_MutexLock(&filesystemMutex); ! #ifdef USE_OBSOLETE_FS_HOOKS ! openFileChannelProcPtr = openFileChannelProcList; ! while ((retVal == NULL) && (openFileChannelProcPtr != NULL)) { ! retVal = (*openFileChannelProcPtr->proc)(interp, path, ! modeString, permissions); ! openFileChannelProcPtr = openFileChannelProcPtr->nextPtr; ! } ! #endif /* USE_OBSOLETE_FS_HOOKS */ ! if (retVal == NULL) { ! Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); ! if (fsPtr != NULL) { ! TclfsOpenFileChannelProc_ *proc = fsPtr->openFileChannelProc; ! if (proc != NULL) { ! return (*proc)(interp, pathPtr, modeString, permissions); ! } ! } ! } ! return (retVal); ! } ! ! /* ! *---------------------------------------------------------------------- ! * ! * Tcl_FSMatchInDirectory -- ! * ! * This routine is used by the globbing code to search a ! * directory for all files which match a given pattern. ! * The appropriate function for the filesystem to which pathPtr ! * belongs will be called. ! * ! * Results: ! * ! * The return value is a standard Tcl result indicating whether an ! * error occurred in globbing. Error messages are placed in ! * interp, but good results are placed in the resultPtr given. ! * ! * If dirOnly is 1, the information in 'types' is ignored and ! * we simply return directories which match the given pattern. ! * This is used internally by the 'glob' code to implement ! * the recursive nature of some searches, e.g. ! * ! * glob -dir $dir -join * pkgIndex.tcl ! * ! * which must recurse through each directory matching '*'. ! * ! * Side effects: ! * The interpreter may have an error message inserted into it. ! * ! *---------------------------------------------------------------------- ! */ ! ! int ! Tcl_FSMatchInDirectory( ! Tcl_Interp *interp, /* Interpreter to receive results. */ ! Tcl_Obj *result, /* Interpreter to receive results. */ ! Tcl_Obj *pathPtr, /* Contains path to directory to search. */ ! char *pattern, /* Pattern to match against. */ ! int dirOnly, ! GlobTypeData *types) /* Object containing list of acceptable types. ! * May be NULL. */ ! { ! Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); ! if (fsPtr != NULL) { ! TclfsMatchInDirectoryProc_ *proc = fsPtr->matchInDirectoryProc; ! if (proc != NULL) { ! return (*proc)(interp, result, pathPtr, pattern, dirOnly, types); ! } ! } ! return -1; ! } ! ! /* ! *---------------------------------------------------------------------- ! * ! * Tcl_FSGetCwd -- ! * ! * This function replaces the library version of getcwd(). ! * ! * Most VFS's will *not* implement a 'cwdProc'. Tcl now maintains ! * its own record (in a Tcl_Obj) of the cwd, and an attempt ! * is made to synchronise this with the cwd's containing filesystem, ! * if that filesystem provides a cwdProc (e.g. the native filesystem). ! * ! * Note that if Tcl's cwd is not in the native filesystem, then of ! * course Tcl's cwd and the native cwd are different: extensions ! * should therefore ensure they only access the cwd through this ! * function to avoid confusion. ! * ! * If a global cwdPathPtr already exists, it is returned, subject ! * to a synchronisation attempt in that cwdPathPtr's fs. ! * Otherwise, 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 Tcl_Obj 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. + * + * The result already has its refCount incremented for the caller. + * When it is no longer needed, that refCount should be decremented. + * This is needed for thread-safety purposes, to allow multiple + * threads to access this and related functions, while ensuring the + * results are always valid. + * + * Of course it is probably a bad idea for multiple threads to + * be *setting* the cwd anyway, but we can at least try to + * help the case of multiple reads with occasional sets. + * + * Side effects: + * Various objects may be freed and allocated. + * + *---------------------------------------------------------------------- + */ + + Tcl_Obj* + Tcl_FSGetCwd(interp) + Tcl_Interp *interp; + { + Tcl_Obj *cwdToReturn; + + Tcl_MutexLock(&cwdMutex); + + if (cwdPathPtr == NULL) { + Tcl_FilesystemRecord *fsRecPtr; + Tcl_Obj* retVal = NULL; + + Tcl_MutexLock(&filesystemMutex); + /* + * We've never been called before, try to find a cwd. 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)) { + TclfsGetCwdProc_ *proc = fsRecPtr->fsPtr->getCwdProc; + if (proc != NULL) { + retVal = (*proc)(interp); + } + fsRecPtr = fsRecPtr->nextPtr; + } + /* + * Now the 'cwd' may NOT be normalized, at least on some + * platforms. For the sake of efficiency, we want a completely + * normalized cwd at all times. + * + * Finally, if retVal is NULL, we do not have a cwd, which + * could be problematic. We assume in this case that the + * DString does not need to be freed. + */ + if (retVal != NULL) { + Tcl_Obj *norm = Tcl_FSNormalizeAbsolutePath(interp, Tcl_GetString(retVal)); + if (norm != NULL) { + /* + * We found a cwd, which is now in our global storage. We must + * make a copy. Norm already has a refCount of 1 + */ + cwdPathPtr = norm; + } + Tcl_DecrRefCount(retVal); + } + Tcl_MutexUnlock(&filesystemMutex); + } else { + /* + * We already have a cwd cached, but we want to give the + * filesystem it is in a chance to check whether that cwd + * has changed, or is perhaps no longer accessible + */ + Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(cwdPathPtr); + /* + * If the filesystem couldn't be found, or if no cwd function exists for + * this filesystem, then we simply assume the cached cwd is ok. If + * we do call a cwd, we must watch for errors (if the cwd returns + * NULL). This ensures that, say, on Unix if the permissions of the cwd + * change, 'pwd' does actually throw the correct error in Tcl. + * (This is tested for in the test suite on unix). + */ + if (fsPtr != NULL) { + TclfsGetCwdProc_ *proc = fsPtr->getCwdProc; + if (proc != NULL) { + Tcl_Obj* retVal = (*proc)(interp); + if (retVal != NULL) { + Tcl_Obj *norm = Tcl_FSNormalizeAbsolutePath(interp, Tcl_GetString(retVal)); + if (norm == NULL || Tcl_FSEqualPaths(cwdPathPtr, norm)) { + /* + * Path hasn't changed. Really 'norm' shouldn't be null. The + * check for equal paths is simply an efficiency thing, to + * share Tcl_Obj representations as much as possible. + */ + if (norm != NULL) { + Tcl_DecrRefCount(norm); + } + } else { + /* Path has changed */ + Tcl_DecrRefCount(cwdPathPtr); + cwdPathPtr = norm; + } + Tcl_DecrRefCount(retVal); + } else { + /* The 'cwd' function returned an error */ + Tcl_DecrRefCount(cwdPathPtr); + cwdPathPtr = NULL; + } + } + } + } + + cwdToReturn = cwdPathPtr; + if (cwdToReturn != NULL) { + Tcl_IncrRefCount(cwdToReturn); + } + + Tcl_MutexUnlock(&cwdMutex); + + return (cwdToReturn); + } + + /* + *---------------------------------------------------------------------- + * + * Tcl_FSUtime -- + * + * This procedure replaces the library version of utime. + * The appropriate function for the filesystem to which pathPtr + * belongs will be called. + * + * Results: + * See utime documentation. + * + * Side effects: + * See utime documentation. + * + *---------------------------------------------------------------------- + */ + + int + Tcl_FSUtime (pathPtr, tval) + Tcl_Obj *pathPtr; + struct utimbuf *tval; + { + Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); + if (fsPtr != NULL) { + TclfsUtimeProc_ *proc = fsPtr->utimeProc; + if (proc != NULL) { + return (*proc)(pathPtr, tval); + } + } + return -1; + } + + /* + *---------------------------------------------------------------------- + * + * TclpObjFileAttrStrings -- + * + * This procedure implements the platform dependent 'file + * attributes' subcommand, for the native filesystem, for listing + * the set of possible attribute strings. This function is part + * of Tcl's native filesystem support, and is placed here because + * it is shared by Unix, MacOS and Windows code. + * + * Results: + * An array of strings + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + + char** TclpObjFileAttrStrings(Tcl_Obj *pathPtr, Tcl_Obj** objPtrRef) { + return tclpFileAttrStrings; + } + + /* + *---------------------------------------------------------------------- + * + * TclpObjFileAttrsGet -- + * + * This procedure implements the platform dependent + * 'file attributes' subcommand, for the native + * filesystem, for 'get' operations. This function is part + * of Tcl's native filesystem support, and is placed here + * because it is shared by Unix, MacOS and Windows code. + * + * Results: + * Standard Tcl return code. The object placed in objPtrRef + * (if TCL_OK was returned) is likely to have a refCount of zero. + * Either way we must either store it somewhere (e.g. the Tcl + * result), or Incr/Decr its refCount to ensure it is properly + * freed. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + + int + TclpObjFileAttrsGet(interp, index, fileName, objPtrRef) + Tcl_Interp *interp; /* The interpreter for error reporting. */ + int index; /* index of the attribute command. */ + Tcl_Obj *fileName; /* filename we are operating on. */ + Tcl_Obj **objPtrRef; /* for output. */ + { + return (*tclpFileAttrProcs[index].getProc)(interp, index, + Tcl_FSGetTranslatedPath(NULL, fileName), + objPtrRef); + } + + /* + *---------------------------------------------------------------------- + * + * TclpObjFileAttrsSet -- + * + * This procedure implements the platform dependent + * 'file attributes' subcommand, for the native + * filesystem, for 'set' operations. This function is part + * of Tcl's native filesystem support, and is placed here + * because it is shared by Unix, MacOS and Windows code. + * + * Results: + * Standard Tcl return code. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + + int + TclpObjFileAttrsSet(interp, index, fileName, objPtr) + Tcl_Interp *interp; /* The interpreter for error reporting. */ + int index; /* index of the attribute command. */ + Tcl_Obj *fileName; /* filename we are operating on. */ + Tcl_Obj *objPtr; /* set to this value. */ + { + return (*tclpFileAttrProcs[index].setProc)(interp, index, + Tcl_FSGetTranslatedPath(NULL, fileName), + objPtr); + } + + /* + *---------------------------------------------------------------------- + * + * Tcl_FSFileAttrStrings -- + * + * This procedure implements part of the hookable 'file + * attributes' subcommand. The appropriate function for the + * filesystem to which pathPtr belongs will be called. + * + * Results: + * The called procedure may either return an array of strings, + * or may instead return NULL and place a Tcl list into the + * given objPtrRef. Tcl will take that list and first increment + * its refCount before using it. On completion of that use, Tcl + * will decrement its refCount. Hence if the list should be + * disposed of by Tcl when done, it should have a refCount of zero, + * and if the list should not be disposed of, the filesystem + * should ensure it retains a refCount on the object. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + + char** + Tcl_FSFileAttrStrings(pathPtr, objPtrRef) + Tcl_Obj* pathPtr; + Tcl_Obj** objPtrRef; + { + Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); + if (fsPtr != NULL) { + TclfsFileAttrStringsProc_ *proc = fsPtr->fileAttrStringsProc; + if (proc != NULL) { + return (*proc)(pathPtr, objPtrRef); + } + } + return NULL; + } + + /* + *---------------------------------------------------------------------- + * + * Tcl_FSFileAttrsGet -- + * + * This procedure implements read access for the hookable 'file + * attributes' subcommand. The appropriate function for the + * filesystem to which pathPtr belongs will be called. + * + * Results: + * Standard Tcl return code. The object placed in objPtrRef + * (if TCL_OK was returned) is likely to have a refCount of zero. + * Either way we must either store it somewhere (e.g. the Tcl + * result), or Incr/Decr its refCount to ensure it is properly + * freed. + + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + + int + Tcl_FSFileAttrsGet(interp, index, pathPtr, objPtrRef) + Tcl_Interp *interp; /* The interpreter for error reporting. */ + int index; /* index of the attribute command. */ + Tcl_Obj *pathPtr; /* filename we are operating on. */ + Tcl_Obj **objPtrRef; /* for output. */ + { + Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); + if (fsPtr != NULL) { + TclfsFileAttrsGetProc_ *proc = fsPtr->fileAttrsGetProc; + if (proc != NULL) { + return (*proc)(interp, index, pathPtr, objPtrRef); + } + } + return -1; + } + + /* + *---------------------------------------------------------------------- + * + * Tcl_FSFileAttrsSet -- + * + * This procedure implements write access for the hookable 'file + * attributes' subcommand. The appropriate function for the + * filesystem to which pathPtr belongs will be called. + * + * Results: + * Standard Tcl return code. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + + int + Tcl_FSFileAttrsSet(interp, index, pathPtr, objPtr) + Tcl_Interp *interp; /* The interpreter for error reporting. */ + int index; /* index of the attribute command. */ + Tcl_Obj *pathPtr; /* filename we are operating on. */ + Tcl_Obj *objPtr; /* Input value. */ + { + Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); + if (fsPtr != NULL) { + TclfsFileAttrsSetProc_ *proc = fsPtr->fileAttrsSetProc; + if (proc != NULL) { + return (*proc)(interp, index, pathPtr, objPtr); + } + } + return -1; + } + + /* + *---------------------------------------------------------------------- + * + * Tcl_FSChdir -- + * + * This function replaces the library version of chdir(). + * + * The path is normalized and then passed to the filesystem + * which claims it. + * + * Results: + * See chdir() documentation. If successful, we keep a + * record of the successful path in cwdPathPtr for subsequent + * calls to getcwd. + * + * Side effects: + * See chdir() documentation. The global cwdPathPtr may + * change value. + * + *---------------------------------------------------------------------- + */ + int + Tcl_FSChdir(pathPtr) + Tcl_Obj *pathPtr; + { + Tcl_Filesystem *fsPtr; + int retVal = -1; + Tcl_Obj *normDirName; + + normDirName = Tcl_FSGetNormalizedPath(NULL, pathPtr); + if (normDirName == NULL) { + return TCL_ERROR; + } + + fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); + if (fsPtr != NULL) { + TclfsChdirProc_ *proc = fsPtr->chdirProc; + if (proc != NULL) { + retVal = (*proc)(pathPtr); + } + } + + if (retVal != -1) { + /* + * The cwd changed, or an error was thrown. If an error was + * thrown, we can just continue (and that will report the error + * to the user). If there was no error we must assume that the + * cwd was actually changed to the normalized value we + * calculated above, and we must therefore cache that + * information. + */ + if (retVal == TCL_OK) { + Tcl_MutexLock(&cwdMutex); + /* Free up the previous cwd we stored */ + if (cwdPathPtr != NULL) { + Tcl_DecrRefCount(cwdPathPtr); + } + /* Now remember the current cwd */ + cwdPathPtr = normDirName; + Tcl_IncrRefCount(cwdPathPtr); + Tcl_MutexUnlock(&cwdMutex); + } + } + + return (retVal); + } + + /* + *---------------------------------------------------------------------- + * + * Tcl_FSLoadFile -- + * + * Dynamically loads a binary code file into memory and returns + * the addresses of two procedures within that file, if they are + * defined. The appropriate function for the filesystem to which + * pathPtr belongs will be called. + * + * 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 + Tcl_FSLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr, clientDataPtr, unloadProcPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + Tcl_Obj *pathPtr; /* 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. */ + TclfsUnloadFileProc_ **unloadProcPtr; + /* Filled with address of TclfsUnloadFileProc_ + * function which should be used for + * this file. */ + { + Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); + if (fsPtr != NULL) { + TclfsLoadFileProc_ *proc = fsPtr->loadFileProc; + if (proc != NULL) { + int retVal = (*proc)(interp, pathPtr, sym1, sym2, + proc1Ptr, proc2Ptr, clientDataPtr); + if (retVal != -1) { + /* + * We handled it. Remember which unload file + * proc to use. + */ + (*unloadProcPtr) = fsPtr->unloadFileProc; + } + return retVal; + } + } + return -1; + } + + /* + *--------------------------------------------------------------------------- + * + * Tcl_FSReadlink -- + * + * This function replaces the library version of readlink(). + * The appropriate function for the filesystem to which pathPtr + * belongs will be called. + * + * Results: + * The result is a Tcl_Obj specifying the contents + * of the symbolic link given by 'path', or NULL if the symbolic + * link could not be read. The result is owned by the caller, + * which should call Tcl_DecrRefCount when the result is no longer + * needed. + * + * Side effects: + * See readlink() documentation. + * + *--------------------------------------------------------------------------- + */ + + Tcl_Obj * + Tcl_FSReadlink(pathPtr) + Tcl_Obj *pathPtr; /* Path of file to readlink (UTF-8). */ + { + Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); + if (fsPtr != NULL) { + TclfsReadlinkProc_ *proc = fsPtr->readlinkProc; + if (proc != NULL) { + return (*proc)(pathPtr); + } + } + /* + * 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 + errno = EINVAL; + #endif /* S_IFLNK */ + return NULL; + } + + /* + *--------------------------------------------------------------------------- + * + * Tcl_FSListVolumes -- + * + * 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 + Tcl_FSListVolumes( + 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(&filesystemMutex); + fsRecPtr = filesystemList; + while (fsRecPtr != NULL) { + TclfsListVolumesProc_ *proc = fsRecPtr->fsPtr->listVolumesProc; + if (proc != NULL) { + /* Ignore return value */ + (*proc)(interp); + } + fsRecPtr = fsRecPtr->nextPtr; + } + Tcl_MutexUnlock(&filesystemMutex); + + return TCL_OK; + } + + /* + *--------------------------------------------------------------------------- + * + * Tcl_FSRenameFile -- + * + * If the two paths given belong to the same filesystem, we call + * that filesystems rename function. Otherwise we simply + * return the posix error 'EXDEV', and -1. + * + * Results: + * Standard Tcl error code if a function was called. + * + * Side effects: + * A file may be renamed. + * + *--------------------------------------------------------------------------- + */ + + int + Tcl_FSRenameFile( + Tcl_Obj* srcPathPtr, /* Pathname of file or dir to be renamed + * (UTF-8). */ + Tcl_Obj *destPathPtr) /* New pathname of file or directory + * (UTF-8). */ + { + int retVal = -1; + Tcl_Filesystem *fsPtr, *fsPtr2; + fsPtr = Tcl_FSGetFileSystemForPath(srcPathPtr); + fsPtr2 = Tcl_FSGetFileSystemForPath(destPathPtr); + + if (fsPtr == fsPtr2 && fsPtr != NULL) { + TclfsRenameFileProc_ *proc = fsPtr->renameFileProc; + if (proc != NULL) { + retVal = (*proc)(srcPathPtr, destPathPtr); + } + } + if (retVal == -1) { + Tcl_SetErrno(EXDEV); + } + return retVal; + } + + /* + *--------------------------------------------------------------------------- + * + * Tcl_FSCopyFile -- + * + * If the two paths given belong to the same filesystem, we call + * that filesystem's copy function. Otherwise we simply + * return the posix error 'EXDEV', and -1. + * + * Results: + * Standard Tcl error code if a function was called. + * + * Side effects: + * A file may be copied. + * + *--------------------------------------------------------------------------- + */ + + int + Tcl_FSCopyFile( + Tcl_Obj* srcPathPtr, /* Pathname of file to be copied (UTF-8). */ + Tcl_Obj *destPathPtr) /* Pathname of file to copy to (UTF-8). */ + { + int retVal = -1; + Tcl_Filesystem *fsPtr, *fsPtr2; + fsPtr = Tcl_FSGetFileSystemForPath(srcPathPtr); + fsPtr2 = Tcl_FSGetFileSystemForPath(destPathPtr); + + if (fsPtr == fsPtr2 && fsPtr != NULL) { + TclfsCopyFileProc_ *proc = fsPtr->copyFileProc; + if (proc != NULL) { + retVal = (*proc)(srcPathPtr, destPathPtr); + } + } + if (retVal == -1) { + Tcl_SetErrno(EXDEV); + } + return retVal; + } + + /* + *--------------------------------------------------------------------------- + * + * Tcl_FSDeleteFile -- + * + * The appropriate function for the filesystem to which pathPtr + * belongs will be called. + * + * Results: + * Standard Tcl error code. + * + * Side effects: + * A file may be deleted. + * + *--------------------------------------------------------------------------- + */ + + int + Tcl_FSDeleteFile( + Tcl_Obj *pathPtr) /* Pathname of file to be removed (UTF-8). */ + { + Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); + if (fsPtr != NULL) { + TclfsDeleteFileProc_ *proc = fsPtr->deleteFileProc; + if (proc != NULL) { + return (*proc)(pathPtr); + } + } + return -1; + } + + /* + *--------------------------------------------------------------------------- + * + * Tcl_FSCreateDirectory -- + * + * The appropriate function for the filesystem to which pathPtr + * belongs will be called. + * + * Results: + * Standard Tcl error code. + * + * Side effects: + * A directory may be created. + * + *--------------------------------------------------------------------------- + */ + + int + Tcl_FSCreateDirectory( + Tcl_Obj *pathPtr) /* Pathname of directory to create (UTF-8). */ + { + Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); + if (fsPtr != NULL) { + TclfsCreateDirectoryProc_ *proc = fsPtr->createDirectoryProc; + if (proc != NULL) { + return (*proc)(pathPtr); + } + } + return -1; + } + + /* + *--------------------------------------------------------------------------- + * + * Tcl_FSRenameFile -- + * + * If the two paths given belong to the same filesystem, we call + * that filesystems copy-directory function. Otherwise we simply + * return the posix error 'EXDEV', and -1. + * + * Results: + * Standard Tcl error code if a function was called. + * + * Side effects: + * A directory may be copied. + * + *--------------------------------------------------------------------------- + */ + + int + Tcl_FSCopyDirectory( + Tcl_Obj* srcPathPtr, /* Pathname of directory to be copied + * (UTF-8). */ + Tcl_Obj *destPathPtr, /* Pathname of target directory (UTF-8). */ + Tcl_Obj **errorPtr) /* If non-NULL, then will be set to a + * new object containing name of file + * causing error, with refCount 1. */ + { + int retVal = -1; + Tcl_Filesystem *fsPtr, *fsPtr2; + fsPtr = Tcl_FSGetFileSystemForPath(srcPathPtr); + fsPtr2 = Tcl_FSGetFileSystemForPath(destPathPtr); + + if (fsPtr == fsPtr2 && fsPtr != NULL) { + TclfsCopyDirectoryProc_ *proc = fsPtr->copyDirectoryProc; + if (proc != NULL) { + retVal = (*proc)(srcPathPtr, destPathPtr, errorPtr); + } + } + if (retVal == -1) { + Tcl_SetErrno(EXDEV); + } + return retVal; + } + + /* + *--------------------------------------------------------------------------- + * + * Tcl_FSRemoveDirectory -- + * + * The appropriate function for the filesystem to which pathPtr + * belongs will be called. + * + * Results: + * Standard Tcl error code. + * + * Side effects: + * A directory may be deleted. + * + *--------------------------------------------------------------------------- + */ + + int + Tcl_FSRemoveDirectory( + Tcl_Obj *pathPtr, /* 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_Obj **errorPtr) /* If non-NULL, then will be set to a + * new object containing name of file + * causing error, with refCount 1. */ + { + Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); + if (fsPtr != NULL) { + TclfsRemoveDirectoryProc_ *proc = fsPtr->removeDirectoryProc; + if (proc != NULL) { + return (*proc)(pathPtr, recursive, errorPtr); + } + } + return -1; + } + + + /* + *--------------------------------------------------------------------------- + * + * Tcl_FSConvertToPathType -- + * + * This function tries to convert the given Tcl_Obj to a valid + * Tcl path type, taking account of the fact that the cwd may + * have changed even if this object is already supposedly of + * the correct type. + * + * The filename may begin with "~" (to indicate current user's + * home directory) or "~" (to indicate any user's home + * directory). + * + * Results: + * Standard Tcl error code. + * + * Side effects: + * The old representation may be freed, and new memory allocated. + * + *--------------------------------------------------------------------------- + */ + + int Tcl_FSConvertToPathType(interp, objPtr) + Tcl_Interp *interp; /* Interpreter in which to store error + * message (if necessary). */ + Tcl_Obj *objPtr; /* Object to convert to a valid, current + * path type. */ + { + /* + * While it is bad practice to examine an object's type directly, + * this is actually the best thing to do here. The reason is that + * if we are converting this object to FsPath type for the first + * time, we don't need to worry whether the 'cwd' has changed. + * On the other hand, if this object is already of FsPath type, + * and is a relative path, we do have to worry about the cwd. + * If the cwd has changed, we must recompute the path. + */ + if (objPtr->typePtr == &tclFsPathType) { + FsPath *fsPathPtr = (FsPath*) objPtr->internalRep.otherValuePtr; + if (fsPathPtr->cwdPtr == NULL) { + return TCL_OK; + } else { + int retVal; + Tcl_MutexLock(&cwdMutex); + if (cwdPathPtr != fsPathPtr->cwdPtr) { + FreeFsPathInternalRep(objPtr); + objPtr->typePtr = NULL; + retVal = Tcl_ConvertToType(interp, objPtr, &tclFsPathType); + } else { + retVal = TCL_OK; + } + Tcl_MutexUnlock(&cwdMutex); + return retVal; + } + } else { + return Tcl_ConvertToType(interp, objPtr, &tclFsPathType); + } + } + + + /* + * Helper function for SetFsPathFromAny. Returns position of first + * directory delimiter in the path. + */ + static int + FindSplitPos(char *path) { + int count = 0; + switch (tclPlatform) { + case TCL_PLATFORM_UNIX: + while (path[count] != 0) { + if (path[count] == '/') { + return count; + } + count++; + } + break; + + case TCL_PLATFORM_MAC: + while (path[count] != 0) { + if (path[count] == ':') { + return count; + } + count++; + } + break; + + case TCL_PLATFORM_WINDOWS: + while (path[count] != 0) { + if (path[count] == '/' || path[count] == '\\') { + return count; + } + count++; + } + break; + } + return count; + } + + /* + *--------------------------------------------------------------------------- + * + * SetFsPathFromAbsoluteNormalized -- + * + * Like SetFsPathFromAny, but assumes the given object is an + * absolute normalized path. Only for internal use. + * + * Results: + * Standard Tcl error code. + * + * Side effects: + * The old representation may be freed, and new memory allocated. + * + *--------------------------------------------------------------------------- + */ + + static int + SetFsPathFromAbsoluteNormalized(interp, objPtr) + Tcl_Interp *interp; /* Used for error reporting if not NULL. */ + Tcl_Obj *objPtr; /* The object to convert. */ + { + FsPath *fsPathPtr; + + if (objPtr->typePtr == &tclFsPathType) { + return TCL_OK; + } + + /* Free old representation */ + if (objPtr->typePtr != NULL) { + if (objPtr->bytes == NULL) { + objPtr->typePtr->updateStringProc(objPtr); + } + if ((objPtr->typePtr->freeIntRepProc) != NULL) { + (*objPtr->typePtr->freeIntRepProc)(objPtr); + } + } + + fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath)); + /* It's a pure normalized absolute path */ + fsPathPtr->translatedPathPtr = NULL; + fsPathPtr->normPathPtr = objPtr; + fsPathPtr->cwdPtr = NULL; + fsPathPtr->nativePathPtr = NULL; + fsPathPtr->fsRecPtr = NULL; + fsPathPtr->filesystemEpoch = -1; + + objPtr->internalRep.otherValuePtr = fsPathPtr; + objPtr->typePtr = &tclFsPathType; + + return TCL_OK; + } + + /* + *--------------------------------------------------------------------------- + * + * SetFsPathFromAny -- + * + * This function tries to convert the given Tcl_Obj to a valid + * Tcl path type. + * + * The filename may begin with "~" (to indicate current user's + * home directory) or "~" (to indicate any user's home + * directory). + * + * Results: + * Standard Tcl error code. + * + * Side effects: + * The old representation may be freed, and new memory allocated. + * + *--------------------------------------------------------------------------- + */ + + static int + SetFsPathFromAny(interp, objPtr) + Tcl_Interp *interp; /* Used for error reporting if not NULL. */ + Tcl_Obj *objPtr; /* The object to convert. */ + { + int len; + FsPath *fsPathPtr; + Tcl_DString buffer; + char *name; + + if (objPtr->typePtr == &tclFsPathType) { + return TCL_OK; + } + + /* Free old representation */ + if (objPtr->typePtr != NULL) { + if (objPtr->bytes == NULL) { + objPtr->typePtr->updateStringProc(objPtr); + } + if ((objPtr->typePtr->freeIntRepProc) != NULL) { + (*objPtr->typePtr->freeIntRepProc)(objPtr); + } + } + + /* + * First step is to translate the filename. This is similar to + * Tcl_TranslateFilename, but shouldn't convert everything to + * windows backslashes on that platform. The current + * implementation of this piece is a slightly optimised version + * of the various Tilde/Split/Join stuff to avoid multiple + * split/join operations. + * + * We remove any trailing directory separator. + * + * However, the split/join routines are quite complex, and + * one has to make sure not to break anything on Unix, Win + * or MacOS (fCmd.test, fileName.test and cmdAH.test exercise + * most of the code). + */ + name = Tcl_GetStringFromObj(objPtr,&len); + + /* + * Handle tilde substitutions, if needed. + */ + if (name[0] == '~') { + char *expandedUser; + Tcl_DString temp; + int split = FindSplitPos(name); + if (split != len) { + /* We have multiple pieces '~user/foo/bar...' */ + name[split] = '\0'; + } + /* Do some tilde substitution */ + if (name[1] == '\0') { + /* We have just '~' */ + const char *dir; + Tcl_DString dirString; + if (split != len) { name[split] = '/'; } + + dir = TclGetEnv("HOME", &dirString); + if (dir == NULL) { + if (interp) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "couldn't find HOME environment ", + "variable to expand path", (char *) NULL); + } + return TCL_ERROR; + } + Tcl_DStringInit(&temp); + Tcl_JoinPath(1, &dir, &temp); + Tcl_DStringFree(&dirString); + } else { + /* We have a user name '~user' */ + Tcl_DStringInit(&temp); + if (TclpGetUserHome(name+1, &temp) == NULL) { + if (interp) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "user \"", (name+1), + "\" doesn't exist", (char *) NULL); + } + Tcl_DStringFree(&temp); + if (split != len) { name[split] = '/'; } + return TCL_ERROR; + } + if (split != len) { name[split] = '/'; } + } + expandedUser = Tcl_DStringValue(&temp); + + Tcl_DStringInit(&buffer); + if (split == len) { + /* We have the result we need in the wrong DString */ + Tcl_DStringAppend(&buffer, expandedUser, Tcl_DStringLength(&temp)); + } else { + /* + * Build a simple 2 element list and join it up with + * the tilde substitution in place + */ + CONST char *argv[] = { expandedUser, name+split+1 }; + Tcl_JoinPath(2, (CONST char **)argv, &buffer); + } + Tcl_DStringFree(&temp); + } else { + Tcl_DStringInit(&buffer); + Tcl_JoinPath(1, (CONST char **) &name, &buffer); + } + + len = Tcl_DStringLength(&buffer); + + /* + * Now we have a translated filename in 'buffer', of + * length 'len'. This will have forward slashes on + * Windows, and will not contain any ~user sequences. + */ + + fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath)); + fsPathPtr->translatedPathPtr = ckalloc((unsigned)(1+len)); + strcpy(fsPathPtr->translatedPathPtr, Tcl_DStringValue(&buffer)); + Tcl_DStringFree(&buffer); + fsPathPtr->normPathPtr = NULL; + fsPathPtr->cwdPtr = NULL; + fsPathPtr->nativePathPtr = NULL; + fsPathPtr->fsRecPtr = NULL; + fsPathPtr->filesystemEpoch = -1; + + objPtr->internalRep.otherValuePtr = fsPathPtr; + objPtr->typePtr = &tclFsPathType; + + return TCL_OK; + } + + /* + *--------------------------------------------------------------------------- + * + * Tcl_FSNewNativePath -- + * + * This function performs the something like that reverse of the + * usual obj->path->nativerep conversions. If some code retrieves + * a path in native form (from, e.g. readlink or a native dialog), + * and that path is to be used at the Tcl level, then calling + * this function is an efficient way of creating the appropriate + * path object type. + * + * Results: + * NULL or a valid path object pointer, with refCount zero. + * + * Side effects: + * New memory may be allocated. + * + *--------------------------------------------------------------------------- + */ + + Tcl_Obj * + Tcl_FSNewNativePath(Tcl_Obj* fromFilesystem, ClientData clientData) { + Tcl_Obj *objPtr; + FsPath *fsPathPtr, *fsFromPtr; + TclfsInternalToNormalizedProc_ *proc; + + if (Tcl_FSConvertToPathType(NULL, fromFilesystem) != TCL_OK) { + return NULL; + } + + fsFromPtr = (FsPath*) fromFilesystem->internalRep.otherValuePtr; + + proc = fsFromPtr->fsRecPtr->fsPtr->internalToNormalizedProc_; + + if (proc == NULL) { + return NULL; + } + + objPtr = (*proc)(clientData); + if (objPtr == NULL) { + return NULL; + } + + /* + * Free old representation; shouldn't normally be any, + * but best to be safe. + */ + if (objPtr->typePtr != NULL) { + if (objPtr->bytes == NULL) { + objPtr->typePtr->updateStringProc(objPtr); + } + if ((objPtr->typePtr->freeIntRepProc) != NULL) { + (*objPtr->typePtr->freeIntRepProc)(objPtr); + } + } + + fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath)); + fsPathPtr->translatedPathPtr = NULL; + /* Circular reference, by design */ + fsPathPtr->normPathPtr = objPtr; + fsPathPtr->cwdPtr = NULL; + fsPathPtr->nativePathPtr = clientData; + fsPathPtr->fsRecPtr = fsFromPtr->fsRecPtr; + fsPathPtr->filesystemEpoch = fsFromPtr->filesystemEpoch; + + objPtr->internalRep.otherValuePtr = fsPathPtr; + objPtr->typePtr = &tclFsPathType; + return objPtr; + } + + static void + FreeFsPathInternalRep(pathObjPtr) + Tcl_Obj *pathObjPtr; /* Path object with internal rep to free. */ + { + register FsPath* fsPathPtr = (FsPath*) pathObjPtr->internalRep.otherValuePtr; + + if (fsPathPtr->translatedPathPtr != NULL) { + ckfree((char *) fsPathPtr->translatedPathPtr); + } + if (fsPathPtr->normPathPtr != NULL) { + if (fsPathPtr->normPathPtr != pathObjPtr) { + Tcl_DecrRefCount(fsPathPtr->normPathPtr); + } + fsPathPtr->normPathPtr = NULL; + } + if (fsPathPtr->cwdPtr != NULL) { + Tcl_DecrRefCount(fsPathPtr->cwdPtr); + } + if (fsPathPtr->nativePathPtr != NULL) { + if (fsPathPtr->fsRecPtr != NULL) { + if (fsPathPtr->fsRecPtr->fsPtr->freeInternalRepProc != NULL) { + (*fsPathPtr->fsRecPtr->fsPtr->freeInternalRepProc)(fsPathPtr->nativePathPtr); + fsPathPtr->nativePathPtr = NULL; + } + } + } + if (fsPathPtr->fsRecPtr != NULL) { + fsPathPtr->fsRecPtr->refCount--; + } + + ckfree((char*) fsPathPtr); + } + + static void + DupFsPathInternalRep(srcPtr, copyPtr) + Tcl_Obj *srcPtr; /* Path obj with internal rep to copy. */ + Tcl_Obj *copyPtr; /* Path obj with internal rep to set. */ + { + register FsPath* srcFsPathPtr = (FsPath*) srcPtr->internalRep.otherValuePtr; + register FsPath* copyFsPathPtr = (FsPath*) ckalloc((unsigned)sizeof(FsPath)); + TclfsDupInternalRep_ *dupProc; + + copyPtr->internalRep.otherValuePtr = copyFsPathPtr; + + if (srcFsPathPtr->translatedPathPtr != NULL) { + copyFsPathPtr->translatedPathPtr = ckalloc(1+strlen(srcFsPathPtr->translatedPathPtr)); + strcpy(copyFsPathPtr->translatedPathPtr, srcFsPathPtr->translatedPathPtr); + } else { + copyFsPathPtr->translatedPathPtr = NULL; + } + + if (srcFsPathPtr->normPathPtr != NULL) { + copyFsPathPtr->normPathPtr = srcFsPathPtr->normPathPtr; + if (copyFsPathPtr->normPathPtr != copyPtr) { + Tcl_IncrRefCount(copyFsPathPtr->normPathPtr); + } + } else { + copyFsPathPtr->normPathPtr = NULL; + } + + if (srcFsPathPtr->cwdPtr != NULL) { + copyFsPathPtr->cwdPtr = srcFsPathPtr->cwdPtr; + Tcl_IncrRefCount(copyFsPathPtr->cwdPtr); + } else { + copyFsPathPtr->cwdPtr = NULL; + } + + if (srcFsPathPtr->fsRecPtr != NULL && srcFsPathPtr->nativePathPtr != NULL) { + dupProc = srcFsPathPtr->fsRecPtr->fsPtr->dupInternalRepProc; + if (dupProc != NULL) { + copyFsPathPtr->nativePathPtr = (*dupProc)(srcFsPathPtr->nativePathPtr); + } else { + copyFsPathPtr->nativePathPtr = NULL; + } + } else { + copyFsPathPtr->nativePathPtr = NULL; + } + copyFsPathPtr->fsRecPtr = srcFsPathPtr->fsRecPtr; + copyFsPathPtr->filesystemEpoch = srcFsPathPtr->filesystemEpoch; + if (copyFsPathPtr->fsRecPtr != NULL) { + copyFsPathPtr->fsRecPtr->refCount++; + } + + copyPtr->typePtr = &tclFsPathType; + } + + /* + *--------------------------------------------------------------------------- + * + * Tcl_FSGetTranslatedPath -- + * + * This function attempts to extract the translated path string + * from the given Tcl_Obj. If the translation succeeds (i.e. the + * object is a valid path), then it is returned. Otherwise NULL + * will be returned, and an error message may be left in the + * interpreter. + * + * Results: + * NULL or a valid string. + * + * Side effects: + * Only those of 'Tcl_FSConvertToPathType' + * + *--------------------------------------------------------------------------- + */ + + char* + Tcl_FSGetTranslatedPath(Tcl_Interp *interp, Tcl_Obj* pathPtr) { + register FsPath* srcFsPathPtr; + if (Tcl_FSConvertToPathType(interp, pathPtr) != TCL_OK) { + return NULL; + } + srcFsPathPtr = (FsPath*) pathPtr->internalRep.otherValuePtr; + if (srcFsPathPtr->translatedPathPtr == NULL) { + /* + * It is a pure absolute, normalized path object. + * This is something like being a 'pure list'. The + * object's string, translatedPath and normalizedPath + * are all identical. + */ + return Tcl_GetString(srcFsPathPtr->normPathPtr); + } else { + /* It is an ordinary path object */ + return srcFsPathPtr->translatedPathPtr; + } + } + + /* + *--------------------------------------------------------------------------- + * + * Tcl_FSGetNormalizedPath -- + * + * This important function attempts to extract from the given Tcl_Obj + * a unique normalised path representation, whose string value can + * be used as a unique identifier for the file. + * + * Results: + * NULL or a valid path object pointer. + * + * Side effects: + * New memory may be allocated. The Tcl 'errno' may be modified + * in the process of trying to examine various path possibilities. + * + *--------------------------------------------------------------------------- + */ + + Tcl_Obj* + Tcl_FSGetNormalizedPath(Tcl_Interp *interp, Tcl_Obj* pathObjPtr) { + register FsPath* srcFsPathPtr; + if (Tcl_FSConvertToPathType(interp, pathObjPtr) != TCL_OK) { + return NULL; + } + srcFsPathPtr = (FsPath*) pathObjPtr->internalRep.otherValuePtr; + if (srcFsPathPtr->normPathPtr == NULL) { + int relative = 0; + char *path = srcFsPathPtr->translatedPathPtr; + Tcl_DString atemp; + + if (Tcl_GetPathType(path) == TCL_PATH_RELATIVE) { + CONST char * pair[2]; + Tcl_Obj *cwd = Tcl_FSGetCwd(interp); + + if (cwd == NULL) { + return NULL; + } + + /* + * The efficiency of this piece of code could + * be improved, given the new object interfaces. + */ + pair[0] = Tcl_GetString(cwd); + pair[1] = path; + + Tcl_DStringInit(&atemp); + Tcl_JoinPath(2, pair, &atemp); + path = Tcl_DStringValue(&atemp); + Tcl_DecrRefCount(cwd); + + relative = 1; + } + + /* Already has refCount incremented */ + srcFsPathPtr->normPathPtr = Tcl_FSNormalizeAbsolutePath(interp, path); + if (!strcmp(Tcl_GetString(srcFsPathPtr->normPathPtr),Tcl_GetString(pathObjPtr))) { + /* The path was already normalized. Get rid of the duplicate */ + Tcl_DecrRefCount(srcFsPathPtr->normPathPtr); + /* We do *not* increment the refCount for this circular reference */ + srcFsPathPtr->normPathPtr = pathObjPtr; + } + if (relative) { + Tcl_DStringFree(&atemp); + + Tcl_MutexLock(&cwdMutex); + srcFsPathPtr->cwdPtr = cwdPathPtr; + Tcl_IncrRefCount(srcFsPathPtr->cwdPtr); + Tcl_MutexUnlock(&cwdMutex); + } + } + return srcFsPathPtr->normPathPtr; + } + + /* + *--------------------------------------------------------------------------- + * + * Tcl_FSGetInternalRep -- + * + * Extract the internal representation of a given path object, + * in the given filesystem. If the path object belongs to a + * different filesystem, we return NULL. + * + * If the internal representation is currently NULL, we attempt + * to generate it, by calling the filesystem's + * 'TclfsConvertToInternalProc_'. + * + * Results: + * NULL or a valid internal representation. + * + * Side effects: + * An attempt may be made to convert the object. + * + *--------------------------------------------------------------------------- + */ + + ClientData + Tcl_FSGetInternalRep(Tcl_Obj* pathObjPtr, Tcl_Filesystem *fsPtr) { + register FsPath* srcFsPathPtr; + + if (Tcl_FSConvertToPathType(NULL, pathObjPtr) != TCL_OK) { + return NULL; + } + srcFsPathPtr = (FsPath*) pathObjPtr->internalRep.otherValuePtr; + + /* + * We will only return the native representation for the caller's + * filesystem. Otherwise we will simply return NULL. This means + * that there must be a unique bi-directional mapping between paths + * and filesystems, and that this mapping will not allow 'remapped' + * files -- files which are in one filesystem but mapped into + * another. Another way of putting this is that 'stacked' + * filesystems are not allowed. We recognise that this is a + * potentially useful feature for the future. + * + * Even something simple like a 'pass through' filesystem which + * logs all activity and passes the calls onto the native system + * would be nice, but not easily achievable with the current + * implementation. + */ + if (srcFsPathPtr->fsRecPtr == NULL) { + /* + * This only usually happens in wrappers like TclpStat which + * create a string object and pass it to TclpObjStat. Code + * which calls the Tcl_FS.. functions should always have a + * filesystem already set. Whether this code path is legal or + * not depends on whether we decide to allow external code to + * call the native filesystem directly. It is at least safer + * to allow this sub-optimal routing. + */ + Tcl_FSGetFileSystemForPath(pathObjPtr); + } + + if (fsPtr != srcFsPathPtr->fsRecPtr->fsPtr) { + return NULL; + } + + if (srcFsPathPtr->nativePathPtr == NULL) { + TclfsConvertToInternalProc_ *proc; + proc = srcFsPathPtr->fsRecPtr->fsPtr->convertToInternalProc_; + + if (proc == NULL) { + return NULL; + } + (*proc)(pathObjPtr); + } + return srcFsPathPtr->nativePathPtr; + } + + /* + *--------------------------------------------------------------------------- + * + * Tcl_FSGetNativePath -- + * + * This function is for use by the Win/Unix/MacOS native filesystems, + * so that they can easily retrieve the native (char* or TCHAR*) + * representation of a path. Other filesystems will probably + * want to implement similar functions. They basically act as a + * safety net around Tcl_FSGetInternalRep. Normally your file- + * system procedures will always be called with path objects + * already converted to the correct filesystem, but if for + * some reason they are called directly (i.e. by procedures + * not in this file), then one cannot necessarily guarantee that + * the path object pointer is from the correct filesystem. + * + * Note: in the future it might be desireable to have separate + * versions of this function with different signatures, for + * example Tcl_FSGetNativeMacPath, Tcl_FSGetNativeUnixPath etc. + * Right now, since native paths are all string based, we use just + * one function. On MacOS we could possibly use an FSSpec or + * FSRef as the native representation. + * * Results: ! * NULL or a valid native path. * * Side effects: ! * See Tcl_FSGetInternalRep. * ! *--------------------------------------------------------------------------- */ + char* + Tcl_FSGetNativePath(Tcl_Obj* pathObjPtr) { + return (char*)Tcl_FSGetInternalRep(pathObjPtr, &nativeFilesystem); + } + + /* + *--------------------------------------------------------------------------- + * + * TclpConvertToNative -- + * + * Convert the given path to native form. + * + * Results: + * None. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + void + TclpConvertToNative(Tcl_Obj* pathObjPtr) { + FsPath* srcFsPathPtr; + char *nativePathPtr; + Tcl_DString ds; + int len; + char *str; + + srcFsPathPtr = (FsPath*) pathObjPtr->internalRep.otherValuePtr; + + /* Make sure the normalized path is set */ + Tcl_FSGetNormalizedPath(NULL, pathObjPtr); + + str = Tcl_GetStringFromObj(srcFsPathPtr->normPathPtr,&len); + #ifdef __WIN32__ + nativePathPtr = Tcl_WinUtfToTChar(str, len, &ds); + srcFsPathPtr->nativePathPtr = (ClientData)ckalloc(2+Tcl_DStringLength(&ds)); + memcpy((VOID*)srcFsPathPtr->nativePathPtr, (VOID*)nativePathPtr, + (size_t) (2+Tcl_DStringLength(&ds))); + #else + nativePathPtr = Tcl_UtfToExternalDString(NULL, str, len, &ds); + srcFsPathPtr->nativePathPtr = (ClientData)ckalloc((unsigned)(1+Tcl_DStringLength(&ds))); + memcpy((VOID*)srcFsPathPtr->nativePathPtr, (VOID*)nativePathPtr, + (size_t) (1+Tcl_DStringLength(&ds))); + #endif + Tcl_DStringFree(&ds); + } + + /* + *--------------------------------------------------------------------------- + * + * TclpNativeToNormalized -- + * + * Convert native format to a normalized path object, with refCount + * of zero. + * + * Results: + * A valid normalized path. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + Tcl_Obj* + TclpNativeToNormalized(ClientData clientData) { + Tcl_DString ds; + Tcl_Obj *objPtr; + + #ifdef __WIN32__ + Tcl_WinTCharToUtf((char*)clientData, -1, &ds); + #else + Tcl_ExternalToUtfDString(NULL, (char*)clientData, -1, &ds); + #endif + objPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds),Tcl_DStringLength(&ds)); + Tcl_DStringFree(&ds); + + return objPtr; + } + + /* + *--------------------------------------------------------------------------- + * + * TclpNativeDupInternalRep -- + * + * Duplicate the native representation. + * + * Results: + * The copied native representation, or NULL if it is not possible + * to copy the representation. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + ClientData + TclpNativeDupInternalRep(ClientData clientData) { + #ifdef __WIN32__ + /* Copying internal representations is complicated with multi-byte TChars */ + return NULL; + #else + char *native = (char*)clientData; + ClientData ret = (ClientData)ckalloc((unsigned)(1+strlen(native))); + strcpy((char*)ret,native); + return ret; + #endif + } + + /* + *--------------------------------------------------------------------------- + * + * TclpPathInNativeFilesystem -- + * + * Any path object is acceptable to the native filesystem, by + * default (we will throw errors when illegal paths are actually + * tried to be used). + * + * Results: + * TCL_OK, to indicate 'yes'. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + int + TclpPathInNativeFilesystem(Tcl_Obj *pathPtr, ClientData *clientDataPtr) { + /* We accept any path as valid */ + return TCL_OK; + } + + /* + *--------------------------------------------------------------------------- + * + * TclpNativeFreeInternalRep -- + * + * Free a native internal representation, which will be non-NULL. + * + * Results: + * None. + * + * Side effects: + * Memory is released. + * + *--------------------------------------------------------------------------- + */ + void + TclpNativeFreeInternalRep(ClientData clientData) { + ckfree((char*)clientData); + } + + /* + *--------------------------------------------------------------------------- + * + * Tcl_FSFileSystemInfo -- + * + * This function returns a list of two elements. The first + * element is the name of the filesystem (e.g. "native" or "vfs"), + * and the second is the particular type of the given path within + * that filesystem. + * + * Results: + * A list of two elements. + * + * Side effects: + * The object may be converted to a path type. + * + *--------------------------------------------------------------------------- + */ + Tcl_Obj* + Tcl_FSFileSystemInfo(Tcl_Obj* pathObjPtr) { + Tcl_Obj *resPtr; + TclfsFilesystemPathType_ *proc; + Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathObjPtr); + + if (fsPtr == NULL) { + return NULL; + } + + resPtr = Tcl_NewListObj(0,NULL); + + Tcl_ListObjAppendElement(NULL, resPtr, Tcl_NewStringObj(fsPtr->typeName,-1)); + + proc = fsPtr->filesystemPathTypeProc; + if (proc != NULL) { + Tcl_Obj *typePtr = (*proc)(pathObjPtr); + if (typePtr != NULL) { + Tcl_ListObjAppendElement(NULL, resPtr, typePtr); + } + } + + return resPtr; + } + + /* + *--------------------------------------------------------------------------- + * + * Tcl_FSPathSeparator -- + * + * This function returns the separator to be used for a given + * path. The object returned should have a refCount of zero + * + * Results: + * A Tcl object, with a refCount of zero. If the caller + * needs to retain a reference to the object, it should + * call Tcl_IncrRefCount. + * + * Side effects: + * The path object may be converted to a path type. + * + *--------------------------------------------------------------------------- + */ + Tcl_Obj* + Tcl_FSPathSeparator(Tcl_Obj* pathObjPtr) { + Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathObjPtr); + + if (fsPtr == NULL) { + return NULL; + } + if (fsPtr->filesystemSeparatorProc != NULL) { + return (*fsPtr->filesystemSeparatorProc)(pathObjPtr); + } + + return NULL; + } + + /* + *--------------------------------------------------------------------------- + * + * TclpFilesystemSeparator -- + * + * This function is part of the native filesystem support, and + * returns the separator for the given path. + * + * Results: + * String object containing the separator character. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + Tcl_Obj* + TclpFilesystemSeparator(Tcl_Obj* pathObjPtr) { + char *separator = NULL; /* lint */ + switch (tclPlatform) { + case TCL_PLATFORM_UNIX: + separator = "/"; + break; + case TCL_PLATFORM_WINDOWS: + separator = "\\"; + break; + case TCL_PLATFORM_MAC: + separator = ":"; + break; + } + return Tcl_NewStringObj(separator,1); + } + + /* + *--------------------------------------------------------------------------- + * + * TclpFilesystemPathType -- + * + * This function is part of the native filesystem support, and + * returns the path type of the given path. Right now it simply + * returns NULL. In the future it could return specific path + * types, like 'network' for a natively-networked path, etc. + * + * Results: + * NULL at present. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + Tcl_Obj* + TclpFilesystemPathType(Tcl_Obj* pathObjPtr) { + /* All native paths are of the same type */ + return NULL; + } + + /* + *--------------------------------------------------------------------------- + * + * Tcl_FSGetFileSystemForPath -- + * + * This function determines which filesystem to use for a + * particular path object, and returns the filesystem which + * accepts this file. If no filesystem will accept this object + * as a valid file path, then NULL is returned. + * + * Results: + * NULL or a filesystem which will accept this path. + * + * Side effects: + * The object may be converted to a path type. + * + *--------------------------------------------------------------------------- + */ + + static Tcl_Filesystem* + Tcl_FSGetFileSystemForPath(Tcl_Obj* pathObjPtr) { + Tcl_FilesystemRecord *fsRecPtr; + Tcl_Filesystem* retVal = NULL; + FsPath* srcFsPathPtr; + + /* Make sure pathObjPtr is of our type */ + + if (Tcl_FSConvertToPathType(NULL, pathObjPtr) != TCL_OK) { + return NULL; + } + + if (Tcl_FSGetNormalizedPath(NULL, pathObjPtr) == NULL) { + return NULL; + } + + /* Get a lock on filesystemEpoch and the filesystemList */ + Tcl_MutexLock(&filesystemMutex); + + /* Make sure pathObjPtr is of the correct epoch */ + + srcFsPathPtr = (FsPath*) pathObjPtr->internalRep.otherValuePtr; + + if (srcFsPathPtr->filesystemEpoch != -1) { + /* + * Check if the filesystem has changed in some way since + * this object's internal representation was calculated. + */ + if (srcFsPathPtr->filesystemEpoch != filesystemEpoch) { + /* + * We have to discard the stale representation and + * recalculate it + */ + FreeFsPathInternalRep(pathObjPtr); + pathObjPtr->typePtr = NULL; + if (SetFsPathFromAny(NULL, pathObjPtr) != TCL_OK) { + goto done; + } + srcFsPathPtr = (FsPath*) pathObjPtr->internalRep.otherValuePtr; + } + } + + /* Check whether the object is already assigned to a fs */ + if (srcFsPathPtr->fsRecPtr != NULL) { + retVal = srcFsPathPtr->fsRecPtr->fsPtr; + goto done; + } + /* ! * Call each of the "pathInFilesystem" functions in succession. A ! * non-return value of -1 indicates the particular function has * succeeded. */ ! fsRecPtr = filesystemList; ! while ((retVal == NULL) && (fsRecPtr != NULL)) { ! TclfsPathInFilesystem_ *proc = fsRecPtr->fsPtr->pathInFilesystemProc; ! if (proc != NULL) { ! ClientData clientData = NULL; ! int ret = (*proc)(pathObjPtr, &clientData); ! if (ret != -1) { ! /* ! * We assume the srcFsPathPtr hasn't been changed ! * by the above call to the pathInFilesystemProc. ! */ ! srcFsPathPtr->fsRecPtr = fsRecPtr; ! srcFsPathPtr->nativePathPtr = clientData; ! srcFsPathPtr->filesystemEpoch = filesystemEpoch; ! fsRecPtr->refCount++; ! retVal = fsRecPtr->fsPtr; ! } ! } ! fsRecPtr = fsRecPtr->nextPtr; } ! Tcl_MutexUnlock(&filesystemMutex); ! done: ! return retVal; ! } ! ! /* ! *--------------------------------------------------------------------------- ! * ! * Tcl_FSEqualPaths -- ! * ! * This function tests whether the two paths given are equal path ! * objects. ! * ! * Results: ! * 1 or 0. ! * ! * Side effects: ! * None. ! * ! *--------------------------------------------------------------------------- ! */ ! ! int ! Tcl_FSEqualPaths(Tcl_Obj* firstPtr, Tcl_Obj* secondPtr) { ! if (firstPtr == secondPtr) { ! return 1; ! } else { ! int tempErrno; ! ! if (firstPtr == NULL || secondPtr == NULL) { ! return 0; ! } ! if (!(strcmp(Tcl_GetString(firstPtr), Tcl_GetString(secondPtr)))) { ! return 1; ! } ! /* ! * Try the most thorough, correct method of comparing fully ! * normalized paths ! */ ! ! tempErrno = Tcl_GetErrno(); ! firstPtr = Tcl_FSGetNormalizedPath(NULL, firstPtr); ! secondPtr = Tcl_FSGetNormalizedPath(NULL, secondPtr); ! Tcl_SetErrno(tempErrno); ! ! if (firstPtr == NULL || secondPtr == NULL) { ! return 0; ! } ! if (!(strcmp(Tcl_GetString(firstPtr), Tcl_GetString(secondPtr)))) { ! return 1; ! } ! } ! return 0; ! } ! ! /* Wrappers */ ! ! Tcl_Channel ! TclpObjOpenFileChannel(Tcl_Interp *interp, ! Tcl_Obj *pathPtr, char *modeString, ! int permissions) { ! char *trans = Tcl_FSGetTranslatedPath(interp, pathPtr); ! if (trans == NULL) { ! return NULL; ! } ! return TclpOpenFileChannel(interp, trans, modeString, permissions); } + + /* + * utime wants a normalized, NOT native path. I assume a native + * version of 'utime' doesn't exist (at least under that name) on NT/2000. + * If a native function does exist somewhere, then we could use: + * + * return native_utime(Tcl_FSGetNativePath(pathPtr),tval); + * + * This seems rather strange when compared with stat, lstat, access, etc. + * all of which want a native path. + */ + int + TclpObjUtime(Tcl_Obj *pathPtr, struct utimbuf *tval) { + return utime(Tcl_GetString(Tcl_FSGetNormalizedPath(NULL,pathPtr)),tval); + } + + int + TclpObjLoadFile(Tcl_Interp * interp, + Tcl_Obj *pathPtr, char * sym1, char * sym2, + Tcl_PackageInitProc ** proc1Ptr, + Tcl_PackageInitProc ** proc2Ptr, + ClientData * clientDataPtr) { + return TclpLoadFile(interp, Tcl_FSGetTranslatedPath(NULL, pathPtr), sym1, sym2, + proc1Ptr,proc2Ptr,clientDataPtr); + } + + /* Everything from here on should be removed in the future */ + #ifdef USE_OBSOLETE_FS_HOOKS /* *---------------------------------------------------------------------- *************** *** 605,614 **** if (newStatProcPtr != NULL) { newStatProcPtr->proc = proc; ! Tcl_MutexLock(&hookMutex); newStatProcPtr->nextPtr = statProcList; statProcList = newStatProcPtr; ! Tcl_MutexUnlock(&hookMutex); retVal = TCL_OK; } --- 3400,3409 ---- if (newStatProcPtr != NULL) { newStatProcPtr->proc = proc; ! Tcl_MutexLock(&filesystemMutex); newStatProcPtr->nextPtr = statProcList; statProcList = newStatProcPtr; ! Tcl_MutexUnlock(&filesystemMutex); retVal = TCL_OK; } *************** *** 644,650 **** StatProc *tmpStatProcPtr; StatProc *prevStatProcPtr = NULL; ! Tcl_MutexLock(&hookMutex); tmpStatProcPtr = statProcList; /* * Traverse the 'statProcList' looking for the particular node --- 3439,3445 ---- StatProc *tmpStatProcPtr; StatProc *prevStatProcPtr = NULL; ! Tcl_MutexLock(&filesystemMutex); tmpStatProcPtr = statProcList; /* * Traverse the 'statProcList' looking for the particular node *************** *** 652,658 **** * 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; --- 3447,3453 ---- * 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; *************** *** 660,666 **** prevStatProcPtr->nextPtr = tmpStatProcPtr->nextPtr; } ! Tcl_Free((char *)tmpStatProcPtr); retVal = TCL_OK; } else { --- 3455,3461 ---- prevStatProcPtr->nextPtr = tmpStatProcPtr->nextPtr; } ! ckfree((char *)tmpStatProcPtr); retVal = TCL_OK; } else { *************** *** 669,675 **** } } ! Tcl_MutexUnlock(&hookMutex); return (retVal); } --- 3464,3470 ---- } } ! Tcl_MutexUnlock(&filesystemMutex); return (retVal); } *************** *** 708,717 **** if (newAccessProcPtr != NULL) { newAccessProcPtr->proc = proc; ! Tcl_MutexLock(&hookMutex); newAccessProcPtr->nextPtr = accessProcList; accessProcList = newAccessProcPtr; ! Tcl_MutexUnlock(&hookMutex); retVal = TCL_OK; } --- 3503,3512 ---- if (newAccessProcPtr != NULL) { newAccessProcPtr->proc = proc; ! Tcl_MutexLock(&filesystemMutex); newAccessProcPtr->nextPtr = accessProcList; accessProcList = newAccessProcPtr; ! Tcl_MutexUnlock(&filesystemMutex); retVal = TCL_OK; } *************** *** 753,761 **** * the list. Ensure that the "default" node cannot be removed. */ ! Tcl_MutexLock(&hookMutex); tmpAccessProcPtr = accessProcList; ! while ((retVal == TCL_ERROR) && (tmpAccessProcPtr != &defaultAccessProc)) { if (tmpAccessProcPtr->proc == proc) { if (prevAccessProcPtr == NULL) { accessProcList = tmpAccessProcPtr->nextPtr; --- 3548,3556 ---- * the list. Ensure that the "default" node cannot be removed. */ ! Tcl_MutexLock(&filesystemMutex); tmpAccessProcPtr = accessProcList; ! while ((retVal == TCL_ERROR) && (tmpAccessProcPtr != NULL)) { if (tmpAccessProcPtr->proc == proc) { if (prevAccessProcPtr == NULL) { accessProcList = tmpAccessProcPtr->nextPtr; *************** *** 763,769 **** prevAccessProcPtr->nextPtr = tmpAccessProcPtr->nextPtr; } ! Tcl_Free((char *)tmpAccessProcPtr); retVal = TCL_OK; } else { --- 3558,3564 ---- prevAccessProcPtr->nextPtr = tmpAccessProcPtr->nextPtr; } ! ckfree((char *)tmpAccessProcPtr); retVal = TCL_OK; } else { *************** *** 771,777 **** tmpAccessProcPtr = tmpAccessProcPtr->nextPtr; } } ! Tcl_MutexUnlock(&hookMutex); return (retVal); } --- 3566,3572 ---- tmpAccessProcPtr = tmpAccessProcPtr->nextPtr; } } ! Tcl_MutexUnlock(&filesystemMutex); return (retVal); } *************** *** 813,822 **** if (newOpenFileChannelProcPtr != NULL) { newOpenFileChannelProcPtr->proc = proc; ! Tcl_MutexLock(&hookMutex); newOpenFileChannelProcPtr->nextPtr = openFileChannelProcList; openFileChannelProcList = newOpenFileChannelProcPtr; ! Tcl_MutexUnlock(&hookMutex); retVal = TCL_OK; } --- 3608,3617 ---- if (newOpenFileChannelProcPtr != NULL) { newOpenFileChannelProcPtr->proc = proc; ! Tcl_MutexLock(&filesystemMutex); newOpenFileChannelProcPtr->nextPtr = openFileChannelProcList; openFileChannelProcList = newOpenFileChannelProcPtr; ! Tcl_MutexUnlock(&filesystemMutex); retVal = TCL_OK; } *************** *** 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; --- 3650,3662 ---- /* * Traverse the 'openFileChannelProcList' looking for the particular * node whose 'proc' member matches 'proc' and remove that one from ! * the list. */ ! Tcl_MutexLock(&filesystemMutex); tmpOpenFileChannelProcPtr = openFileChannelProcList; while ((retVal == TCL_ERROR) && ! (tmpOpenFileChannelProcPtr != NULL)) { if (tmpOpenFileChannelProcPtr->proc == proc) { if (prevOpenFileChannelProcPtr == NULL) { openFileChannelProcList = tmpOpenFileChannelProcPtr->nextPtr; *************** *** 870,876 **** tmpOpenFileChannelProcPtr->nextPtr; } ! Tcl_Free((char *)tmpOpenFileChannelProcPtr); retVal = TCL_OK; } else { --- 3665,3671 ---- tmpOpenFileChannelProcPtr->nextPtr; } ! ckfree((char *)tmpOpenFileChannelProcPtr); retVal = TCL_OK; } else { *************** *** 878,884 **** tmpOpenFileChannelProcPtr = tmpOpenFileChannelProcPtr->nextPtr; } } ! Tcl_MutexUnlock(&hookMutex); return (retVal); } --- 3673,3680 ---- tmpOpenFileChannelProcPtr = tmpOpenFileChannelProcPtr->nextPtr; } } ! Tcl_MutexUnlock(&filesystemMutex); return (retVal); } + #endif /* USE_OBSOLETE_FS_HOOKS */ Index: generic/tclInt.decls =================================================================== RCS file: /cvsroot/tcl/tcl/generic/tclInt.decls,v retrieving revision 1.23 diff -c -r1.23 tclInt.decls *** generic/tclInt.decls 2000/09/28 06:38:21 1.23 --- generic/tclInt.decls 2001/03/16 17:08:10 *************** *** 1,871 **** ! # tclInt.decls -- ! # ! # This file contains the declarations for all unsupported ! # functions that are exported by the Tcl library. This file ! # is used to generate the tclIntDecls.h, tclIntPlatDecls.h, ! # tclIntStub.c, tclPlatStub.c, tclCompileDecls.h and tclCompileStub.c ! # files ! # ! # Copyright (c) 1998-1999 by Scriptics Corporation. ! # See the file "license.terms" for information on usage and redistribution ! # of this file, and for a DISCLAIMER OF ALL WARRANTIES. ! # ! # RCS: @(#) $Id: tclInt.decls,v 1.23 2000/09/28 06:38:21 hobbs Exp $ ! ! library tcl ! ! # Define the unsupported generic interfaces. ! ! interface tclInt ! ! # Declare each of the functions in the unsupported internal Tcl ! # interface. These interfaces are allowed to changed between versions. ! # Use at your own risk. Note that the position of functions should not ! # be changed between versions to avoid gratuitous incompatibilities. ! ! declare 0 generic { ! int TclAccess(CONST char *path, int mode) ! } ! declare 1 generic { ! int TclAccessDeleteProc(TclAccessProc_ *proc) ! } ! declare 2 generic { ! int TclAccessInsertProc(TclAccessProc_ *proc) ! } ! declare 3 generic { ! void TclAllocateFreeObjects(void) ! } ! # Replaced by TclpChdir in 8.1: ! # declare 4 generic { ! # int TclChdir(Tcl_Interp *interp, char *dirName) ! # } ! declare 5 {unix win} { ! int TclCleanupChildren(Tcl_Interp *interp, int numPids, Tcl_Pid *pidPtr, \ ! Tcl_Channel errorChan) ! } ! declare 6 generic { ! void TclCleanupCommand(Command *cmdPtr) ! } ! declare 7 generic { ! int TclCopyAndCollapse(int count, CONST char *src, char *dst) ! } ! declare 8 generic { ! int TclCopyChannel(Tcl_Interp *interp, Tcl_Channel inChan, \ ! Tcl_Channel outChan, int toRead, Tcl_Obj *cmdPtr) ! } ! ! # TclCreatePipeline unofficially exported for use by BLT. ! ! declare 9 {unix win} { ! int TclCreatePipeline(Tcl_Interp *interp, int argc, char **argv, \ ! Tcl_Pid **pidArrayPtr, TclFile *inPipePtr, TclFile *outPipePtr, \ ! TclFile *errFilePtr) ! } ! declare 10 generic { ! int TclCreateProc(Tcl_Interp *interp, Namespace *nsPtr, char *procName, \ ! Tcl_Obj *argsPtr, Tcl_Obj *bodyPtr, Proc **procPtrPtr) ! } ! declare 11 generic { ! void TclDeleteCompiledLocalVars(Interp *iPtr, CallFrame *framePtr) ! } ! declare 12 generic { ! void TclDeleteVars(Interp *iPtr, Tcl_HashTable *tablePtr) ! } ! declare 13 generic { ! int TclDoGlob(Tcl_Interp *interp, char *separators, \ ! Tcl_DString *headPtr, char *tail, GlobTypeData *types) ! } ! declare 14 generic { ! void TclDumpMemoryInfo(FILE *outFile) ! } ! # Removed in 8.1: ! # declare 15 generic { ! # void TclExpandParseValue(ParseValue *pvPtr, int needed) ! # } ! declare 16 generic { ! void TclExprFloatError(Tcl_Interp *interp, double value) ! } ! declare 17 generic { ! int TclFileAttrsCmd(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) ! } ! declare 18 generic { ! int TclFileCopyCmd(Tcl_Interp *interp, int argc, char **argv) ! } ! declare 19 generic { ! int TclFileDeleteCmd(Tcl_Interp *interp, int argc, char **argv) ! } ! declare 20 generic { ! int TclFileMakeDirsCmd(Tcl_Interp *interp, int argc, char **argv) ! } ! declare 21 generic { ! int TclFileRenameCmd(Tcl_Interp *interp, int argc, char **argv) ! } ! declare 22 generic { ! int TclFindElement(Tcl_Interp *interp, CONST char *listStr, \ ! int listLength, CONST char **elementPtr, CONST char **nextPtr, \ ! int *sizePtr, int *bracePtr) ! } ! declare 23 generic { ! Proc * TclFindProc(Interp *iPtr, char *procName) ! } ! declare 24 generic { ! int TclFormatInt(char *buffer, long n) ! } ! declare 25 generic { ! void TclFreePackageInfo(Interp *iPtr) ! } ! # Removed in 8.1: ! # declare 26 generic { ! # char * TclGetCwd(Tcl_Interp *interp) ! # } ! declare 27 generic { ! int TclGetDate(char *p, unsigned long now, long zone, \ ! unsigned long *timePtr) ! } ! declare 28 generic { ! Tcl_Channel TclpGetDefaultStdChannel(int type) ! } ! declare 29 generic { ! Tcl_Obj * TclGetElementOfIndexedArray(Tcl_Interp *interp, \ ! int localIndex, Tcl_Obj *elemPtr, int leaveErrorMsg) ! } ! # Replaced by char * TclGetEnv(CONST char *name, Tcl_DString *valuePtr) in 8.1: ! # declare 30 generic { ! # char * TclGetEnv(CONST char *name) ! # } ! declare 31 generic { ! char * TclGetExtension(char *name) ! } ! declare 32 generic { ! int TclGetFrame(Tcl_Interp *interp, char *str, CallFrame **framePtrPtr) ! } ! declare 33 generic { ! TclCmdProcType TclGetInterpProc(void) ! } ! declare 34 generic { ! int TclGetIntForIndex(Tcl_Interp *interp, Tcl_Obj *objPtr, \ ! int endValue, int *indexPtr) ! } ! declare 35 generic { ! Tcl_Obj * TclGetIndexedScalar(Tcl_Interp *interp, int localIndex, \ ! int leaveErrorMsg) ! } ! declare 36 generic { ! int TclGetLong(Tcl_Interp *interp, char *str, long *longPtr) ! } ! declare 37 generic { ! int TclGetLoadedPackages(Tcl_Interp *interp, char *targetName) ! } ! declare 38 generic { ! int TclGetNamespaceForQualName(Tcl_Interp *interp, char *qualName, \ ! Namespace *cxtNsPtr, int flags, Namespace **nsPtrPtr, \ ! Namespace **altNsPtrPtr, Namespace **actualCxtPtrPtr, \ ! char **simpleNamePtr) ! } ! declare 39 generic { ! TclObjCmdProcType TclGetObjInterpProc(void) ! } ! declare 40 generic { ! int TclGetOpenMode(Tcl_Interp *interp, char *str, int *seekFlagPtr) ! } ! declare 41 generic { ! Tcl_Command TclGetOriginalCommand(Tcl_Command command) ! } ! declare 42 generic { ! char * TclpGetUserHome(CONST char *name, Tcl_DString *bufferPtr) ! } ! declare 43 generic { ! int TclGlobalInvoke(Tcl_Interp *interp, int argc, char **argv, int flags) ! } ! declare 44 generic { ! int TclGuessPackageName(char *fileName, Tcl_DString *bufPtr) ! } ! declare 45 generic { ! int TclHideUnsafeCommands(Tcl_Interp *interp) ! } ! declare 46 generic { ! int TclInExit(void) ! } ! declare 47 generic { ! Tcl_Obj * TclIncrElementOfIndexedArray(Tcl_Interp *interp, \ ! int localIndex, Tcl_Obj *elemPtr, long incrAmount) ! } ! declare 48 generic { ! Tcl_Obj * TclIncrIndexedScalar(Tcl_Interp *interp, int localIndex, \ ! long incrAmount) ! } ! declare 49 generic { ! Tcl_Obj * TclIncrVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, \ ! Tcl_Obj *part2Ptr, long incrAmount, int part1NotParsed) ! } ! declare 50 generic { ! void TclInitCompiledLocals(Tcl_Interp *interp, CallFrame *framePtr, \ ! Namespace *nsPtr) ! } ! declare 51 generic { ! int TclInterpInit(Tcl_Interp *interp) ! } ! declare 52 generic { ! int TclInvoke(Tcl_Interp *interp, int argc, char **argv, int flags) ! } ! declare 53 generic { ! int TclInvokeObjectCommand(ClientData clientData, Tcl_Interp *interp, \ ! int argc, char **argv) ! } ! declare 54 generic { ! int TclInvokeStringCommand(ClientData clientData, Tcl_Interp *interp, \ ! int objc, Tcl_Obj *CONST objv[]) ! } ! declare 55 generic { ! Proc * TclIsProc(Command *cmdPtr) ! } ! # Replaced with TclpLoadFile in 8.1: ! # declare 56 generic { ! # int TclLoadFile(Tcl_Interp *interp, char *fileName, char *sym1, \ ! # char *sym2, Tcl_PackageInitProc **proc1Ptr, \ ! # Tcl_PackageInitProc **proc2Ptr) ! # } ! # Signature changed to take a length in 8.1: ! # declare 57 generic { ! # int TclLooksLikeInt(char *p) ! # } ! declare 58 generic { ! Var * TclLookupVar(Tcl_Interp *interp, char *part1, char *part2, \ ! int flags, char *msg, int createPart1, int createPart2, \ ! Var **arrayPtrPtr) ! } ! declare 59 generic { ! int TclpMatchFiles(Tcl_Interp *interp, char *separators, \ ! Tcl_DString *dirPtr, char *pattern, char *tail) ! } ! declare 60 generic { ! int TclNeedSpace(char *start, char *end) ! } ! declare 61 generic { ! Tcl_Obj * TclNewProcBodyObj(Proc *procPtr) ! } ! declare 62 generic { ! int TclObjCommandComplete(Tcl_Obj *cmdPtr) ! } ! declare 63 generic { ! int TclObjInterpProc(ClientData clientData, Tcl_Interp *interp, \ ! int objc, Tcl_Obj *CONST objv[]) ! } ! declare 64 generic { ! int TclObjInvoke(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], \ ! int flags) ! } ! declare 65 generic { ! int TclObjInvokeGlobal(Tcl_Interp *interp, int objc, \ ! Tcl_Obj *CONST objv[], int flags) ! } ! declare 66 generic { ! int TclOpenFileChannelDeleteProc(TclOpenFileChannelProc_ *proc) ! } ! declare 67 generic { ! int TclOpenFileChannelInsertProc(TclOpenFileChannelProc_ *proc) ! } ! declare 68 generic { ! int TclpAccess(CONST char *path, int mode) ! } ! declare 69 generic { ! char * TclpAlloc(unsigned int size) ! } ! declare 70 generic { ! int TclpCopyFile(CONST char *source, CONST char *dest) ! } ! declare 71 generic { ! int TclpCopyDirectory(CONST char *source, CONST char *dest, \ ! Tcl_DString *errorPtr) ! } ! declare 72 generic { ! int TclpCreateDirectory(CONST char *path) ! } ! declare 73 generic { ! int TclpDeleteFile(CONST char *path) ! } ! declare 74 generic { ! void TclpFree(char *ptr) ! } ! declare 75 generic { ! unsigned long TclpGetClicks(void) ! } ! declare 76 generic { ! unsigned long TclpGetSeconds(void) ! } ! declare 77 generic { ! void TclpGetTime(Tcl_Time *time) ! } ! declare 78 generic { ! int TclpGetTimeZone(unsigned long time) ! } ! declare 79 generic { ! int TclpListVolumes(Tcl_Interp *interp) ! } ! declare 80 generic { ! Tcl_Channel TclpOpenFileChannel(Tcl_Interp *interp, char *fileName, \ ! char *modeString, int permissions) ! } ! declare 81 generic { ! char * TclpRealloc(char *ptr, unsigned int size) ! } ! declare 82 generic { ! int TclpRemoveDirectory(CONST char *path, int recursive, \ ! Tcl_DString *errorPtr) ! } ! declare 83 generic { ! int TclpRenameFile(CONST char *source, CONST char *dest) ! } ! # Removed in 8.1: ! # declare 84 generic { ! # int TclParseBraces(Tcl_Interp *interp, char *str, char **termPtr, \ ! # ParseValue *pvPtr) ! # } ! # declare 85 generic { ! # int TclParseNestedCmd(Tcl_Interp *interp, char *str, int flags, \ ! # char **termPtr, ParseValue *pvPtr) ! # } ! # declare 86 generic { ! # int TclParseQuotes(Tcl_Interp *interp, char *str, int termChar, \ ! # int flags, char **termPtr, ParseValue *pvPtr) ! # } ! # declare 87 generic { ! # void TclPlatformInit(Tcl_Interp *interp) ! # } ! declare 88 generic { ! char * TclPrecTraceProc(ClientData clientData, Tcl_Interp *interp, \ ! char *name1, char *name2, int flags) ! } ! declare 89 generic { ! int TclPreventAliasLoop(Tcl_Interp *interp, Tcl_Interp *cmdInterp, \ ! Tcl_Command cmd) ! } ! # Removed in 8.1 (only available if compiled with TCL_COMPILE_DEBUG): ! # declare 90 generic { ! # void TclPrintByteCodeObj(Tcl_Interp *interp, Tcl_Obj *objPtr) ! # } ! declare 91 generic { ! void TclProcCleanupProc(Proc *procPtr) ! } ! declare 92 generic { ! int TclProcCompileProc(Tcl_Interp *interp, Proc *procPtr, \ ! Tcl_Obj *bodyPtr, Namespace *nsPtr, CONST char *description, \ ! CONST char *procName) ! } ! declare 93 generic { ! void TclProcDeleteProc(ClientData clientData) ! } ! declare 94 generic { ! int TclProcInterpProc(ClientData clientData, Tcl_Interp *interp, \ ! int argc, char **argv) ! } ! declare 95 generic { ! int TclpStat(CONST char *path, struct stat *buf) ! } ! declare 96 generic { ! int TclRenameCommand(Tcl_Interp *interp, char *oldName, char *newName) ! } ! declare 97 generic { ! void TclResetShadowedCmdRefs(Tcl_Interp *interp, Command *newCmdPtr) ! } ! declare 98 generic { ! int TclServiceIdle(void) ! } ! declare 99 generic { ! Tcl_Obj * TclSetElementOfIndexedArray(Tcl_Interp *interp, \ ! int localIndex, Tcl_Obj *elemPtr, Tcl_Obj *objPtr, int leaveErrorMsg) ! } ! declare 100 generic { ! Tcl_Obj * TclSetIndexedScalar(Tcl_Interp *interp, int localIndex, \ ! Tcl_Obj *objPtr, int leaveErrorMsg) ! } ! declare 101 {unix win} { ! char * TclSetPreInitScript(char *string) ! } ! declare 102 generic { ! void TclSetupEnv(Tcl_Interp *interp) ! } ! declare 103 generic { ! int TclSockGetPort(Tcl_Interp *interp, char *str, char *proto, \ ! int *portPtr) ! } ! declare 104 {unix win} { ! int TclSockMinimumBuffers(int sock, int size) ! } ! declare 105 generic { ! int TclStat(CONST char *path, struct stat *buf) ! } ! declare 106 generic { ! int TclStatDeleteProc(TclStatProc_ *proc) ! } ! declare 107 generic { ! int TclStatInsertProc(TclStatProc_ *proc) ! } ! declare 108 generic { ! void TclTeardownNamespace(Namespace *nsPtr) ! } ! declare 109 generic { ! int TclUpdateReturnInfo(Interp *iPtr) ! } ! # Removed in 8.1: ! # declare 110 generic { ! # char * TclWordEnd(char *start, char *lastChar, int nested, int *semiPtr) ! # } ! ! # Procedures used in conjunction with Tcl namespaces. They are ! # defined here instead of in tcl.decls since they are not stable yet. ! ! declare 111 generic { ! void Tcl_AddInterpResolvers(Tcl_Interp *interp, char *name, \ ! Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, \ ! Tcl_ResolveCompiledVarProc *compiledVarProc) ! } ! declare 112 generic { ! int Tcl_AppendExportList(Tcl_Interp *interp, Tcl_Namespace *nsPtr, \ ! Tcl_Obj *objPtr) ! } ! declare 113 generic { ! Tcl_Namespace * Tcl_CreateNamespace(Tcl_Interp *interp, char *name, \ ! ClientData clientData, Tcl_NamespaceDeleteProc *deleteProc) ! } ! declare 114 generic { ! void Tcl_DeleteNamespace(Tcl_Namespace *nsPtr) ! } ! declare 115 generic { ! int Tcl_Export(Tcl_Interp *interp, Tcl_Namespace *nsPtr, char *pattern, \ ! int resetListFirst) ! } ! declare 116 generic { ! Tcl_Command Tcl_FindCommand(Tcl_Interp *interp, char *name, \ ! Tcl_Namespace *contextNsPtr, int flags) ! } ! declare 117 generic { ! Tcl_Namespace * Tcl_FindNamespace(Tcl_Interp *interp, char *name, \ ! Tcl_Namespace *contextNsPtr, int flags) ! } ! declare 118 generic { ! int Tcl_GetInterpResolvers(Tcl_Interp *interp, char *name, \ ! Tcl_ResolverInfo *resInfo) ! } ! declare 119 generic { ! int Tcl_GetNamespaceResolvers(Tcl_Namespace *namespacePtr, \ ! Tcl_ResolverInfo *resInfo) ! } ! declare 120 generic { ! Tcl_Var Tcl_FindNamespaceVar(Tcl_Interp *interp, char *name, \ ! Tcl_Namespace *contextNsPtr, int flags) ! } ! declare 121 generic { ! int Tcl_ForgetImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr, \ ! char *pattern) ! } ! declare 122 generic { ! Tcl_Command Tcl_GetCommandFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr) ! } ! declare 123 generic { ! void Tcl_GetCommandFullName(Tcl_Interp *interp, Tcl_Command command, \ ! Tcl_Obj *objPtr) ! } ! declare 124 generic { ! Tcl_Namespace * Tcl_GetCurrentNamespace(Tcl_Interp *interp) ! } ! declare 125 generic { ! Tcl_Namespace * Tcl_GetGlobalNamespace(Tcl_Interp *interp) ! } ! declare 126 generic { ! void Tcl_GetVariableFullName(Tcl_Interp *interp, Tcl_Var variable, \ ! Tcl_Obj *objPtr) ! } ! declare 127 generic { ! int Tcl_Import(Tcl_Interp *interp, Tcl_Namespace *nsPtr, \ ! char *pattern, int allowOverwrite) ! } ! declare 128 generic { ! void Tcl_PopCallFrame(Tcl_Interp* interp) ! } ! declare 129 generic { ! int Tcl_PushCallFrame(Tcl_Interp* interp, Tcl_CallFrame *framePtr, \ ! Tcl_Namespace *nsPtr, int isProcCallFrame) ! } ! declare 130 generic { ! int Tcl_RemoveInterpResolvers(Tcl_Interp *interp, char *name) ! } ! declare 131 generic { ! void Tcl_SetNamespaceResolvers(Tcl_Namespace *namespacePtr, \ ! Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, \ ! Tcl_ResolveCompiledVarProc *compiledVarProc) ! } ! declare 132 generic { ! int TclpHasSockets(Tcl_Interp *interp) ! } ! declare 133 generic { ! struct tm * TclpGetDate(TclpTime_t time, int useGMT) ! } ! declare 134 generic { ! size_t TclpStrftime(char *s, size_t maxsize, CONST char *format, \ ! CONST struct tm *t) ! } ! declare 135 generic { ! int TclpCheckStackSpace(void) ! } ! ! # Added in 8.1: ! ! declare 137 generic { ! int TclpChdir(CONST char *dirName) ! } ! declare 138 generic { ! char * TclGetEnv(CONST char *name, Tcl_DString *valuePtr) ! } ! declare 139 generic { ! int TclpLoadFile(Tcl_Interp *interp, char *fileName, char *sym1, \ ! char *sym2, Tcl_PackageInitProc **proc1Ptr, \ ! Tcl_PackageInitProc **proc2Ptr, ClientData *clientDataPtr) ! } ! declare 140 generic { ! int TclLooksLikeInt(char *bytes, int length) ! } ! declare 141 generic { ! char *TclpGetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr) ! } ! declare 142 generic { ! int TclSetByteCodeFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr, \ ! CompileHookProc *hookProc, ClientData clientData) ! } ! declare 143 generic { ! int TclAddLiteralObj(struct CompileEnv *envPtr, Tcl_Obj *objPtr, \ ! LiteralEntry **litPtrPtr) ! } ! declare 144 generic { ! void TclHideLiteral(Tcl_Interp *interp, struct CompileEnv *envPtr, \ ! int index) ! } ! declare 145 generic { ! struct AuxDataType *TclGetAuxDataType(char *typeName) ! } ! ! declare 146 generic { ! TclHandle TclHandleCreate(VOID *ptr) ! } ! ! declare 147 generic { ! void TclHandleFree(TclHandle handle) ! } ! ! declare 148 generic { ! TclHandle TclHandlePreserve(TclHandle handle) ! } ! ! declare 149 generic { ! void TclHandleRelease(TclHandle handle) ! } ! ! # Added for Tcl 8.2 ! ! declare 150 generic { ! int TclRegAbout(Tcl_Interp *interp, Tcl_RegExp re) ! } ! declare 151 generic { ! void TclRegExpRangeUniChar(Tcl_RegExp re, int index, int *startPtr, \ ! int *endPtr) ! } ! ! declare 152 generic { ! void TclSetLibraryPath(Tcl_Obj *pathPtr) ! } ! declare 153 generic { ! Tcl_Obj *TclGetLibraryPath(void) ! } ! ! # moved to tclTest.c (static) in 8.3.2/8.4a2 ! #declare 154 generic { ! # int TclTestChannelCmd(ClientData clientData, ! # Tcl_Interp *interp, int argc, char **argv) ! #} ! #declare 155 generic { ! # int TclTestChannelEventCmd(ClientData clientData, \ ! # Tcl_Interp *interp, int argc, char **argv) ! #} ! ! declare 156 generic { ! void TclRegError (Tcl_Interp *interp, char *msg, \ ! int status) ! } ! declare 157 generic { ! Var * TclVarTraceExists (Tcl_Interp *interp, char *varName) ! } ! declare 158 generic { ! void TclSetStartupScriptFileName(char *filename) ! } ! declare 159 generic { ! char *TclGetStartupScriptFileName(void) ! } ! declare 160 generic { ! int TclpMatchFilesTypes(Tcl_Interp *interp, char *separators, \ ! Tcl_DString *dirPtr, char *pattern, char *tail, GlobTypeData *types) ! } ! ! # new in 8.3.2/8.4a2 ! declare 161 generic { ! int TclChannelTransform(Tcl_Interp *interp, Tcl_Channel chan, \ ! Tcl_Obj *cmdObjPtr) ! } ! declare 162 generic { ! void TclChannelEventScriptInvoker(ClientData clientData, int flags) ! } ! ! ############################################################################## ! ! # Define the platform specific internal Tcl interface. These functions are ! # only available on the designated platform. ! ! interface tclIntPlat ! ! ######################## ! # Mac specific internals ! ! declare 0 mac { ! VOID * TclpSysAlloc(long size, int isBin) ! } ! declare 1 mac { ! void TclpSysFree(VOID *ptr) ! } ! declare 2 mac { ! VOID * TclpSysRealloc(VOID *cp, unsigned int size) ! } ! declare 3 mac { ! void TclpExit(int status) ! } ! ! # Prototypes for functions found in the tclMacUtil.c compatability library. ! ! declare 4 mac { ! int FSpGetDefaultDir(FSSpecPtr theSpec) ! } ! declare 5 mac { ! int FSpSetDefaultDir(FSSpecPtr theSpec) ! } ! declare 6 mac { ! OSErr FSpFindFolder(short vRefNum, OSType folderType, \ ! Boolean createFolder, FSSpec *spec) ! } ! declare 7 mac { ! void GetGlobalMouse(Point *mouse) ! } ! ! # The following routines are utility functions in Tcl. They are exported ! # here because they are needed in Tk. They are not officially supported, ! # however. The first set are from the MoreFiles package. ! ! declare 8 mac { ! pascal OSErr FSpGetDirectoryID(CONST FSSpec *spec, long *theDirID, \ ! Boolean *isDirectory) ! } ! declare 9 mac { ! pascal short FSpOpenResFileCompat(CONST FSSpec *spec, \ ! SignedByte permission) ! } ! declare 10 mac { ! pascal void FSpCreateResFileCompat(CONST FSSpec *spec, OSType creator, \ ! OSType fileType, ScriptCode scriptTag) ! } ! ! # Like the MoreFiles routines these fix problems in the standard ! # Mac calls. These routines are from tclMacUtils.h. ! ! declare 11 mac { ! int FSpLocationFromPath(int length, CONST char *path, FSSpecPtr theSpec) ! } ! declare 12 mac { ! OSErr FSpPathFromLocation(FSSpecPtr theSpec, int *length, \ ! Handle *fullPath) ! } ! ! # Prototypes of Mac only internal functions. ! ! declare 13 mac { ! void TclMacExitHandler(void) ! } ! declare 14 mac { ! void TclMacInitExitToShell(int usePatch) ! } ! declare 15 mac { ! OSErr TclMacInstallExitToShellPatch(ExitToShellProcPtr newProc) ! } ! declare 16 mac { ! int TclMacOSErrorToPosixError(int error) ! } ! declare 17 mac { ! void TclMacRemoveTimer(void *timerToken) ! } ! declare 18 mac { ! void * TclMacStartTimer(long ms) ! } ! declare 19 mac { ! int TclMacTimerExpired(void *timerToken) ! } ! declare 20 mac { ! int TclMacRegisterResourceFork(short fileRef, Tcl_Obj *tokenPtr, \ ! int insert) ! } ! declare 21 mac { ! short TclMacUnRegisterResourceFork(char *tokenPtr, Tcl_Obj *resultPtr) ! } ! declare 22 mac { ! int TclMacCreateEnv(void) ! } ! declare 23 mac { ! FILE * TclMacFOpenHack(CONST char *path, CONST char *mode) ! } ! # Replaced in 8.1 by TclpReadLink: ! # declare 24 mac { ! # int TclMacReadlink(char *path, char *buf, int size) ! # } ! declare 25 mac { ! int TclMacChmod(char *path, int mode) ! } ! ! ############################ ! # Windows specific internals ! ! declare 0 win { ! void TclWinConvertError(DWORD errCode) ! } ! declare 1 win { ! void TclWinConvertWSAError(DWORD errCode) ! } ! declare 2 win { ! struct servent * TclWinGetServByName(CONST char *nm, \ ! CONST char *proto) ! } ! declare 3 win { ! int TclWinGetSockOpt(SOCKET s, int level, int optname, \ ! char FAR * optval, int FAR *optlen) ! } ! declare 4 win { ! HINSTANCE TclWinGetTclInstance(void) ! } ! # Removed in 8.1: ! # declare 5 win { ! # HINSTANCE TclWinLoadLibrary(char *name) ! # } ! declare 6 win { ! u_short TclWinNToHS(u_short ns) ! } ! declare 7 win { ! int TclWinSetSockOpt(SOCKET s, int level, int optname, \ ! CONST char FAR * optval, int optlen) ! } ! declare 8 win { ! unsigned long TclpGetPid(Tcl_Pid pid) ! } ! declare 9 win { ! int TclWinGetPlatformId(void) ! } ! # Removed in 8.3.1 (for Win32s only) ! #declare 10 win { ! # int TclWinSynchSpawn(void *args, int type, void **trans, Tcl_Pid *pidPtr) ! #} ! ! # Pipe channel functions ! ! declare 11 win { ! void TclGetAndDetachPids(Tcl_Interp *interp, Tcl_Channel chan) ! } ! declare 12 win { ! int TclpCloseFile(TclFile file) ! } ! declare 13 win { ! Tcl_Channel TclpCreateCommandChannel(TclFile readFile, \ ! TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr) ! } ! declare 14 win { ! int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe) ! } ! declare 15 win { ! int TclpCreateProcess(Tcl_Interp *interp, int argc, char **argv, \ ! TclFile inputFile, TclFile outputFile, TclFile errorFile, \ ! Tcl_Pid *pidPtr) ! } ! # Signature changed in 8.1: ! # declare 16 win { ! # TclFile TclpCreateTempFile(char *contents, Tcl_DString *namePtr) ! # } ! # declare 17 win { ! # char * TclpGetTZName(void) ! # } ! declare 18 win { ! TclFile TclpMakeFile(Tcl_Channel channel, int direction) ! } ! declare 19 win { ! TclFile TclpOpenFile(CONST char *fname, int mode) ! } ! declare 20 win { ! void TclWinAddProcess(HANDLE hProcess, DWORD id) ! } ! ! # removed permanently for 8.4 ! #declare 21 win { ! # void TclpAsyncMark(Tcl_AsyncHandler async) ! #} ! ! # Added in 8.1: ! declare 22 win { ! TclFile TclpCreateTempFile(CONST char *contents) ! } ! declare 23 win { ! char * TclpGetTZName(int isdst) ! } ! declare 24 win { ! char * TclWinNoBackslash(char *path) ! } ! declare 25 win { ! TclPlatformType *TclWinGetPlatform(void) ! } ! declare 26 win { ! void TclWinSetInterfaces(int wide) ! } ! ! ######################### ! # Unix specific internals ! ! # Pipe channel functions ! ! declare 0 unix { ! void TclGetAndDetachPids(Tcl_Interp *interp, Tcl_Channel chan) ! } ! declare 1 unix { ! int TclpCloseFile(TclFile file) ! } ! declare 2 unix { ! Tcl_Channel TclpCreateCommandChannel(TclFile readFile, \ ! TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr) ! } ! declare 3 unix { ! int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe) ! } ! declare 4 unix { ! int TclpCreateProcess(Tcl_Interp *interp, int argc, char **argv, \ ! TclFile inputFile, TclFile outputFile, TclFile errorFile, \ ! Tcl_Pid *pidPtr) ! } ! # Signature changed in 8.1: ! # declare 5 unix { ! # TclFile TclpCreateTempFile(char *contents, ! # Tcl_DString *namePtr) ! # } ! declare 6 unix { ! TclFile TclpMakeFile(Tcl_Channel channel, int direction) ! } ! declare 7 unix { ! TclFile TclpOpenFile(CONST char *fname, int mode) ! } ! declare 8 unix { ! int TclUnixWaitForFile(int fd, int mask, int timeout) ! } ! ! # Added in 8.1: ! ! declare 9 unix { ! TclFile TclpCreateTempFile(CONST char *contents) ! } --- 1 ---- ! # tclInt.decls -- # # This file contains the declarations for all unsupported # functions that are exported by the Tcl library. This file # is used to generate the tclIntDecls.h, tclIntPlatDecls.h, # tclIntStub.c, tclPlatStub.c, tclCompileDecls.h and tclCompileStub.c # files # # Copyright (c) 1998-1999 by Scriptics Corporation. # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: tclInt.decls,v 1.23 2000/09/28 06:38:21 hobbs Exp $ library tcl # Define the unsupported generic interfaces. interface tclInt # Declare each of the functions in the unsupported internal Tcl # interface. These interfaces are allowed to changed between versions. # Use at your own risk. Note that the position of functions should not # be changed between versions to avoid gratuitous incompatibilities. declare 0 generic { int TclAccess(CONST char *path, int mode) } declare 1 generic { int TclAccessDeleteProc(TclAccessProc_ *proc) } declare 2 generic { int TclAccessInsertProc(TclAccessProc_ *proc) } declare 3 generic { void TclAllocateFreeObjects(void) } # Replaced by TclpChdir in 8.1: # declare 4 generic { # int TclChdir(Tcl_Interp *interp, char *dirName) # } declare 5 {unix win} { int TclCleanupChildren(Tcl_Interp *interp, int numPids, Tcl_Pid *pidPtr, \ Tcl_Channel errorChan) } declare 6 generic { void TclCleanupCommand(Command *cmdPtr) } declare 7 generic { int TclCopyAndCollapse(int count, CONST char *src, char *dst) } declare 8 generic { int TclCopyChannel(Tcl_Interp *interp, Tcl_Channel inChan, \ Tcl_Channel outChan, int toRead, Tcl_Obj *cmdPtr) } # TclCreatePipeline unofficially exported for use by BLT. declare 9 {unix win} { int TclCreatePipeline(Tcl_Interp *interp, int argc, char **argv, \ Tcl_Pid **pidArrayPtr, TclFile *inPipePtr, TclFile *outPipePtr, \ TclFile *errFilePtr) } declare 10 generic { int TclCreateProc(Tcl_Interp *interp, Namespace *nsPtr, char *procName, \ Tcl_Obj *argsPtr, Tcl_Obj *bodyPtr, Proc **procPtrPtr) } declare 11 generic { void TclDeleteCompiledLocalVars(Interp *iPtr, CallFrame *framePtr) } declare 12 generic { void TclDeleteVars(Interp *iPtr, Tcl_HashTable *tablePtr) } declare 13 generic { int TclDoGlob(Tcl_Interp *interp, char *separators, \ Tcl_DString *headPtr, char *tail, GlobTypeData *types) } declare 14 generic { void TclDumpMemoryInfo(FILE *outFile) } # Removed in 8.1: # declare 15 generic { # void TclExpandParseValue(ParseValue *pvPtr, int needed) # } declare 16 generic { void TclExprFloatError(Tcl_Interp *interp, double value) } # Removed in 8.4 #declare 17 generic { # int TclFileAttrsCmd(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) #} #declare 18 generic { # int TclFileCopyCmd(Tcl_Interp *interp, int argc, char **argv) #} #declare 19 generic { # int TclFileDeleteCmd(Tcl_Interp *interp, int argc, char **argv) #} #declare 20 generic { # int TclFileMakeDirsCmd(Tcl_Interp *interp, int argc, char **argv) #} #declare 21 generic { # int TclFileRenameCmd(Tcl_Interp *interp, int argc, char **argv) #} declare 22 generic { int TclFindElement(Tcl_Interp *interp, CONST char *listStr, \ int listLength, CONST char **elementPtr, CONST char **nextPtr, \ int *sizePtr, int *bracePtr) } declare 23 generic { Proc * TclFindProc(Interp *iPtr, char *procName) } declare 24 generic { int TclFormatInt(char *buffer, long n) } declare 25 generic { void TclFreePackageInfo(Interp *iPtr) } # Removed in 8.1: # declare 26 generic { # char * TclGetCwd(Tcl_Interp *interp) # } declare 27 generic { int TclGetDate(char *p, unsigned long now, long zone, \ unsigned long *timePtr) } declare 28 generic { Tcl_Channel TclpGetDefaultStdChannel(int type) } declare 29 generic { Tcl_Obj * TclGetElementOfIndexedArray(Tcl_Interp *interp, \ int localIndex, Tcl_Obj *elemPtr, int leaveErrorMsg) } # Replaced by char * TclGetEnv(CONST char *name, Tcl_DString *valuePtr) in 8.1: # declare 30 generic { # char * TclGetEnv(CONST char *name) # } declare 31 generic { char * TclGetExtension(char *name) } declare 32 generic { int TclGetFrame(Tcl_Interp *interp, char *str, CallFrame **framePtrPtr) } declare 33 generic { TclCmdProcType TclGetInterpProc(void) } declare 34 generic { int TclGetIntForIndex(Tcl_Interp *interp, Tcl_Obj *objPtr, \ int endValue, int *indexPtr) } declare 35 generic { Tcl_Obj * TclGetIndexedScalar(Tcl_Interp *interp, int localIndex, \ int leaveErrorMsg) } declare 36 generic { int TclGetLong(Tcl_Interp *interp, char *str, long *longPtr) } declare 37 generic { int TclGetLoadedPackages(Tcl_Interp *interp, char *targetName) } declare 38 generic { int TclGetNamespaceForQualName(Tcl_Interp *interp, char *qualName, \ Namespace *cxtNsPtr, int flags, Namespace **nsPtrPtr, \ Namespace **altNsPtrPtr, Namespace **actualCxtPtrPtr, \ char **simpleNamePtr) } declare 39 generic { TclObjCmdProcType TclGetObjInterpProc(void) } declare 40 generic { int TclGetOpenMode(Tcl_Interp *interp, char *str, int *seekFlagPtr) } declare 41 generic { Tcl_Command TclGetOriginalCommand(Tcl_Command command) } declare 42 generic { char * TclpGetUserHome(CONST char *name, Tcl_DString *bufferPtr) } declare 43 generic { int TclGlobalInvoke(Tcl_Interp *interp, int argc, char **argv, int flags) } declare 44 generic { int TclGuessPackageName(char *fileName, Tcl_DString *bufPtr) } declare 45 generic { int TclHideUnsafeCommands(Tcl_Interp *interp) } declare 46 generic { int TclInExit(void) } declare 47 generic { Tcl_Obj * TclIncrElementOfIndexedArray(Tcl_Interp *interp, \ int localIndex, Tcl_Obj *elemPtr, long incrAmount) } declare 48 generic { Tcl_Obj * TclIncrIndexedScalar(Tcl_Interp *interp, int localIndex, \ long incrAmount) } declare 49 generic { Tcl_Obj * TclIncrVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, \ Tcl_Obj *part2Ptr, long incrAmount, int part1NotParsed) } declare 50 generic { void TclInitCompiledLocals(Tcl_Interp *interp, CallFrame *framePtr, \ Namespace *nsPtr) } declare 51 generic { int TclInterpInit(Tcl_Interp *interp) } declare 52 generic { int TclInvoke(Tcl_Interp *interp, int argc, char **argv, int flags) } declare 53 generic { int TclInvokeObjectCommand(ClientData clientData, Tcl_Interp *interp, \ int argc, char **argv) } declare 54 generic { int TclInvokeStringCommand(ClientData clientData, Tcl_Interp *interp, \ int objc, Tcl_Obj *CONST objv[]) } declare 55 generic { Proc * TclIsProc(Command *cmdPtr) } # Replaced with TclpLoadFile in 8.1: # declare 56 generic { # int TclLoadFile(Tcl_Interp *interp, char *fileName, char *sym1, \ # char *sym2, Tcl_PackageInitProc **proc1Ptr, \ # Tcl_PackageInitProc **proc2Ptr) # } # Signature changed to take a length in 8.1: # declare 57 generic { # int TclLooksLikeInt(char *p) # } declare 58 generic { Var * TclLookupVar(Tcl_Interp *interp, char *part1, char *part2, \ int flags, char *msg, int createPart1, int createPart2, \ Var **arrayPtrPtr) } # Replaced by Tcl_FSMatchInDirectory in 8.4 #declare 59 generic { # int TclpMatchFiles(Tcl_Interp *interp, char *separators, \ # Tcl_DString *dirPtr, char *pattern, char *tail) #} declare 60 generic { int TclNeedSpace(char *start, char *end) } declare 61 generic { Tcl_Obj * TclNewProcBodyObj(Proc *procPtr) } declare 62 generic { int TclObjCommandComplete(Tcl_Obj *cmdPtr) } declare 63 generic { int TclObjInterpProc(ClientData clientData, Tcl_Interp *interp, \ int objc, Tcl_Obj *CONST objv[]) } declare 64 generic { int TclObjInvoke(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], \ int flags) } declare 65 generic { int TclObjInvokeGlobal(Tcl_Interp *interp, int objc, \ Tcl_Obj *CONST objv[], int flags) } declare 66 generic { int TclOpenFileChannelDeleteProc(TclOpenFileChannelProc_ *proc) } declare 67 generic { int TclOpenFileChannelInsertProc(TclOpenFileChannelProc_ *proc) } declare 68 generic { int TclpAccess(CONST char *path, int mode) } declare 69 generic { char * TclpAlloc(unsigned int size) } #declare 70 generic { # int TclpCopyFile(CONST char *source, CONST char *dest) #} #declare 71 generic { # int TclpCopyDirectory(CONST char *source, CONST char *dest, \ # Tcl_DString *errorPtr) #} #declare 72 generic { # int TclpCreateDirectory(CONST char *path) #} #declare 73 generic { # int TclpDeleteFile(CONST char *path) #} declare 74 generic { void TclpFree(char *ptr) } declare 75 generic { unsigned long TclpGetClicks(void) } declare 76 generic { unsigned long TclpGetSeconds(void) } declare 77 generic { void TclpGetTime(Tcl_Time *time) } declare 78 generic { int TclpGetTimeZone(unsigned long time) } declare 79 generic { int TclpListVolumes(Tcl_Interp *interp) } declare 80 generic { Tcl_Channel TclpOpenFileChannel(Tcl_Interp *interp, char *fileName, \ char *modeString, int permissions) } declare 81 generic { char * TclpRealloc(char *ptr, unsigned int size) } #declare 82 generic { # int TclpRemoveDirectory(CONST char *path, int recursive, \ # Tcl_DString *errorPtr) #} #declare 83 generic { # int TclpRenameFile(CONST char *source, CONST char *dest) #} # Removed in 8.1: # declare 84 generic { # int TclParseBraces(Tcl_Interp *interp, char *str, char **termPtr, \ # ParseValue *pvPtr) # } # declare 85 generic { # int TclParseNestedCmd(Tcl_Interp *interp, char *str, int flags, \ # char **termPtr, ParseValue *pvPtr) # } # declare 86 generic { # int TclParseQuotes(Tcl_Interp *interp, char *str, int termChar, \ # int flags, char **termPtr, ParseValue *pvPtr) # } # declare 87 generic { # void TclPlatformInit(Tcl_Interp *interp) # } declare 88 generic { char * TclPrecTraceProc(ClientData clientData, Tcl_Interp *interp, \ char *name1, char *name2, int flags) } declare 89 generic { int TclPreventAliasLoop(Tcl_Interp *interp, Tcl_Interp *cmdInterp, \ Tcl_Command cmd) } # Removed in 8.1 (only available if compiled with TCL_COMPILE_DEBUG): # declare 90 generic { # void TclPrintByteCodeObj(Tcl_Interp *interp, Tcl_Obj *objPtr) # } declare 91 generic { void TclProcCleanupProc(Proc *procPtr) } declare 92 generic { int TclProcCompileProc(Tcl_Interp *interp, Proc *procPtr, \ Tcl_Obj *bodyPtr, Namespace *nsPtr, CONST char *description, \ CONST char *procName) } declare 93 generic { void TclProcDeleteProc(ClientData clientData) } declare 94 generic { int TclProcInterpProc(ClientData clientData, Tcl_Interp *interp, \ int argc, char **argv) } declare 95 generic { int TclpStat(CONST char *path, struct stat *buf) } declare 96 generic { int TclRenameCommand(Tcl_Interp *interp, char *oldName, char *newName) } declare 97 generic { void TclResetShadowedCmdRefs(Tcl_Interp *interp, Command *newCmdPtr) } declare 98 generic { int TclServiceIdle(void) } declare 99 generic { Tcl_Obj * TclSetElementOfIndexedArray(Tcl_Interp *interp, \ int localIndex, Tcl_Obj *elemPtr, Tcl_Obj *objPtr, int leaveErrorMsg) } declare 100 generic { Tcl_Obj * TclSetIndexedScalar(Tcl_Interp *interp, int localIndex, \ Tcl_Obj *objPtr, int leaveErrorMsg) } declare 101 {unix win} { char * TclSetPreInitScript(char *string) } declare 102 generic { void TclSetupEnv(Tcl_Interp *interp) } declare 103 generic { int TclSockGetPort(Tcl_Interp *interp, char *str, char *proto, \ int *portPtr) } declare 104 {unix win} { int TclSockMinimumBuffers(int sock, int size) } declare 105 generic { int TclStat(CONST char *path, struct stat *buf) } declare 106 generic { int TclStatDeleteProc(TclStatProc_ *proc) } declare 107 generic { int TclStatInsertProc(TclStatProc_ *proc) } declare 108 generic { void TclTeardownNamespace(Namespace *nsPtr) } declare 109 generic { int TclUpdateReturnInfo(Interp *iPtr) } # Removed in 8.1: # declare 110 generic { # char * TclWordEnd(char *start, char *lastChar, int nested, int *semiPtr) # } # Procedures used in conjunction with Tcl namespaces. They are # defined here instead of in tcl.decls since they are not stable yet. declare 111 generic { void Tcl_AddInterpResolvers(Tcl_Interp *interp, char *name, \ Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, \ Tcl_ResolveCompiledVarProc *compiledVarProc) } declare 112 generic { int Tcl_AppendExportList(Tcl_Interp *interp, Tcl_Namespace *nsPtr, \ Tcl_Obj *objPtr) } declare 113 generic { Tcl_Namespace * Tcl_CreateNamespace(Tcl_Interp *interp, char *name, \ ClientData clientData, Tcl_NamespaceDeleteProc *deleteProc) } declare 114 generic { void Tcl_DeleteNamespace(Tcl_Namespace *nsPtr) } declare 115 generic { int Tcl_Export(Tcl_Interp *interp, Tcl_Namespace *nsPtr, char *pattern, \ int resetListFirst) } declare 116 generic { Tcl_Command Tcl_FindCommand(Tcl_Interp *interp, char *name, \ Tcl_Namespace *contextNsPtr, int flags) } declare 117 generic { Tcl_Namespace * Tcl_FindNamespace(Tcl_Interp *interp, char *name, \ Tcl_Namespace *contextNsPtr, int flags) } declare 118 generic { int Tcl_GetInterpResolvers(Tcl_Interp *interp, char *name, \ Tcl_ResolverInfo *resInfo) } declare 119 generic { int Tcl_GetNamespaceResolvers(Tcl_Namespace *namespacePtr, \ Tcl_ResolverInfo *resInfo) } declare 120 generic { Tcl_Var Tcl_FindNamespaceVar(Tcl_Interp *interp, char *name, \ Tcl_Namespace *contextNsPtr, int flags) } declare 121 generic { int Tcl_ForgetImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr, \ char *pattern) } declare 122 generic { Tcl_Command Tcl_GetCommandFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr) } declare 123 generic { void Tcl_GetCommandFullName(Tcl_Interp *interp, Tcl_Command command, \ Tcl_Obj *objPtr) } declare 124 generic { Tcl_Namespace * Tcl_GetCurrentNamespace(Tcl_Interp *interp) } declare 125 generic { Tcl_Namespace * Tcl_GetGlobalNamespace(Tcl_Interp *interp) } declare 126 generic { void Tcl_GetVariableFullName(Tcl_Interp *interp, Tcl_Var variable, \ Tcl_Obj *objPtr) } declare 127 generic { int Tcl_Import(Tcl_Interp *interp, Tcl_Namespace *nsPtr, \ char *pattern, int allowOverwrite) } declare 128 generic { void Tcl_PopCallFrame(Tcl_Interp* interp) } declare 129 generic { int Tcl_PushCallFrame(Tcl_Interp* interp, Tcl_CallFrame *framePtr, \ Tcl_Namespace *nsPtr, int isProcCallFrame) } declare 130 generic { int Tcl_RemoveInterpResolvers(Tcl_Interp *interp, char *name) } declare 131 generic { void Tcl_SetNamespaceResolvers(Tcl_Namespace *namespacePtr, \ Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, \ Tcl_ResolveCompiledVarProc *compiledVarProc) } declare 132 generic { int TclpHasSockets(Tcl_Interp *interp) } declare 133 generic { struct tm * TclpGetDate(TclpTime_t time, int useGMT) } declare 134 generic { size_t TclpStrftime(char *s, size_t maxsize, CONST char *format, \ CONST struct tm *t) } declare 135 generic { int TclpCheckStackSpace(void) } # Added in 8.1: #declare 137 generic { # int TclpChdir(CONST char *dirName) #} declare 138 generic { char * TclGetEnv(CONST char *name, Tcl_DString *valuePtr) } declare 139 generic { int TclpLoadFile(Tcl_Interp *interp, char *fileName, char *sym1, \ char *sym2, Tcl_PackageInitProc **proc1Ptr, \ Tcl_PackageInitProc **proc2Ptr, ClientData *clientDataPtr) } declare 140 generic { int TclLooksLikeInt(char *bytes, int length) } #declare 141 generic { # char *TclpGetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr) #} declare 142 generic { int TclSetByteCodeFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr, \ CompileHookProc *hookProc, ClientData clientData) } declare 143 generic { int TclAddLiteralObj(struct CompileEnv *envPtr, Tcl_Obj *objPtr, \ LiteralEntry **litPtrPtr) } declare 144 generic { void TclHideLiteral(Tcl_Interp *interp, struct CompileEnv *envPtr, \ int index) } declare 145 generic { struct AuxDataType *TclGetAuxDataType(char *typeName) } declare 146 generic { TclHandle TclHandleCreate(VOID *ptr) } declare 147 generic { void TclHandleFree(TclHandle handle) } declare 148 generic { TclHandle TclHandlePreserve(TclHandle handle) } declare 149 generic { void TclHandleRelease(TclHandle handle) } # Added for Tcl 8.2 declare 150 generic { int TclRegAbout(Tcl_Interp *interp, Tcl_RegExp re) } declare 151 generic { void TclRegExpRangeUniChar(Tcl_RegExp re, int index, int *startPtr, \ int *endPtr) } declare 152 generic { void TclSetLibraryPath(Tcl_Obj *pathPtr) } declare 153 generic { Tcl_Obj *TclGetLibraryPath(void) } # moved to tclTest.c (static) in 8.3.2/8.4a2 #declare 154 generic { # int TclTestChannelCmd(ClientData clientData, # Tcl_Interp *interp, int argc, char **argv) #} #declare 155 generic { # int TclTestChannelEventCmd(ClientData clientData, \ # Tcl_Interp *interp, int argc, char **argv) #} declare 156 generic { void TclRegError (Tcl_Interp *interp, char *msg, \ int status) } declare 157 generic { Var * TclVarTraceExists (Tcl_Interp *interp, char *varName) } declare 158 generic { void TclSetStartupScriptFileName(char *filename) } declare 159 generic { char *TclGetStartupScriptFileName(void) } #declare 160 generic { # int TclpMatchFilesTypes(Tcl_Interp *interp, char *separators, \ # Tcl_DString *dirPtr, char *pattern, char *tail, GlobTypeData *types) #} # new in 8.3.2/8.4a2 declare 161 generic { int TclChannelTransform(Tcl_Interp *interp, Tcl_Channel chan, \ Tcl_Obj *cmdObjPtr) } declare 162 generic { void TclChannelEventScriptInvoker(ClientData clientData, int flags) } # for virtual filesystem support. These should eventually be moved to # Tcl's external API and properly documented, to allow extension writers # to use them easily (hence providing automatic VFS support to all # extensions) declare 163 generic { void TclpVerifyInitialEncodings(void) } declare 164 generic { int Tcl_FSCopyFile(Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr) } declare 165 generic { int Tcl_FSCopyDirectory(Tcl_Obj *srcPathPtr, \ Tcl_Obj *destPathPtr, Tcl_Obj **errorPtr) } declare 166 generic { int Tcl_FSCreateDirectory(Tcl_Obj *pathPtr) } declare 167 generic { int Tcl_FSDeleteFile(Tcl_Obj *pathPtr) } declare 168 generic { int Tcl_FSListVolumes(Tcl_Interp *interp) } declare 169 generic { int Tcl_FSLoadFile(Tcl_Interp * interp, \ Tcl_Obj *pathPtr, char * sym1, char * sym2, \ Tcl_PackageInitProc ** proc1Ptr, \ Tcl_PackageInitProc ** proc2Ptr, \ ClientData * clientDataPtr, \ TclfsUnloadFileProc_ **unloadProcPtr) } declare 170 generic { int Tcl_FSMatchInDirectory(Tcl_Interp *interp, Tcl_Obj * result, \ Tcl_Obj *pathPtr, \ char * pattern, int dirOnly, \ GlobTypeData * types) } declare 171 generic { Tcl_Obj* Tcl_FSReadlink(Tcl_Obj *pathPtr) } declare 172 generic { int Tcl_FSRemoveDirectory(Tcl_Obj *pathPtr, \ int recursive, Tcl_Obj **errorPtr) } declare 173 generic { int Tcl_FSRenameFile(Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr) } declare 174 generic { int Tcl_FSLstat(Tcl_Obj *pathPtr, struct stat *buf) } declare 175 generic { int Tcl_FSUtime(Tcl_Obj *pathPtr, struct utimbuf *tval) } declare 176 generic { int Tcl_FSFileAttrsGet(Tcl_Interp *interp, \ int index, Tcl_Obj *pathPtr, \ Tcl_Obj **objPtrRef) } declare 177 generic { int Tcl_FSFileAttrsSet(Tcl_Interp *interp, \ int index, Tcl_Obj *pathPtr, \ Tcl_Obj *objPtr) } declare 178 generic { char** Tcl_FSFileAttrStrings(Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef) } declare 179 generic { int Tcl_FSStat(Tcl_Obj *pathPtr, struct stat *buf) } declare 180 generic { int Tcl_FSAccess(Tcl_Obj *pathPtr, int mode) } declare 181 generic { Tcl_Channel Tcl_FSOpenFileChannel(Tcl_Interp *interp, Tcl_Obj *pathPtr, \ char *modeString, int permissions) } declare 182 generic { Tcl_Obj* Tcl_FSGetCwd(Tcl_Interp *interp) } declare 183 generic { int Tcl_FSChdir(Tcl_Obj *pathPtr) } declare 184 generic { int Tcl_FSConvertToPathType(Tcl_Interp *interp, Tcl_Obj *pathPtr) } declare 185 generic { int TclFileCopyCmd(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) } declare 186 generic { int TclFileRenameCmd(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) } declare 187 generic { Tcl_Obj* Tcl_FSJoinPath(Tcl_Obj *listObj, int elements) } declare 188 generic { int TclFileDeleteCmd(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) } declare 189 generic { int TclFileMakeDirsCmd(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) } declare 190 generic { int TclFileAttrsCmd(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) } declare 191 generic { Tcl_Obj* Tcl_FSSplitPath(Tcl_Obj* pathPtr, int *lenPtr) } declare 192 generic { int Tcl_FSEqualPaths(Tcl_Obj* firstPtr, Tcl_Obj* secondPtr) } declare 193 generic { Tcl_Obj* Tcl_FSGetNormalizedPath(Tcl_Interp *interp, Tcl_Obj* pathObjPtr) } declare 194 generic { Tcl_Obj* Tcl_FSJoinToPath(Tcl_Obj *basePtr, int objc, Tcl_Obj *CONST objv[]) } declare 195 generic { ClientData Tcl_FSGetInternalRep(Tcl_Obj* pathObjPtr, Tcl_Filesystem *fsPtr) } declare 196 generic { char* Tcl_FSGetTranslatedPath(Tcl_Interp *interp, Tcl_Obj* pathPtr) } declare 197 generic { int Tcl_FSEvalFile(Tcl_Interp *interp, Tcl_Obj *fileName) } declare 198 generic { Tcl_Obj* Tcl_FSNewNativePath(Tcl_Obj* fromFilesystem, ClientData clientData) } declare 199 generic { char* Tcl_FSGetNativePath(Tcl_Obj* pathObjPtr) } declare 200 generic { Tcl_Obj* Tcl_FSFileSystemInfo(Tcl_Obj* pathObjPtr) } declare 201 generic { Tcl_Obj* Tcl_FSPathSeparator(Tcl_Obj* pathObjPtr) } ############################################################################## # Define the platform specific internal Tcl interface. These functions are # only available on the designated platform. interface tclIntPlat ######################## # Mac specific internals declare 0 mac { VOID * TclpSysAlloc(long size, int isBin) } declare 1 mac { void TclpSysFree(VOID *ptr) } declare 2 mac { VOID * TclpSysRealloc(VOID *cp, unsigned int size) } declare 3 mac { void TclpExit(int status) } # Prototypes for functions found in the tclMacUtil.c compatability library. declare 4 mac { int FSpGetDefaultDir(FSSpecPtr theSpec) } declare 5 mac { int FSpSetDefaultDir(FSSpecPtr theSpec) } declare 6 mac { OSErr FSpFindFolder(short vRefNum, OSType folderType, \ Boolean createFolder, FSSpec *spec) } declare 7 mac { void GetGlobalMouse(Point *mouse) } # The following routines are utility functions in Tcl. They are exported # here because they are needed in Tk. They are not officially supported, # however. The first set are from the MoreFiles package. declare 8 mac { pascal OSErr FSpGetDirectoryID(CONST FSSpec *spec, long *theDirID, \ Boolean *isDirectory) } declare 9 mac { pascal short FSpOpenResFileCompat(CONST FSSpec *spec, \ SignedByte permission) } declare 10 mac { pascal void FSpCreateResFileCompat(CONST FSSpec *spec, OSType creator, \ OSType fileType, ScriptCode scriptTag) } # Like the MoreFiles routines these fix problems in the standard # Mac calls. These routines are from tclMacUtils.h. declare 11 mac { int FSpLocationFromPath(int length, CONST char *path, FSSpecPtr theSpec) } declare 12 mac { OSErr FSpPathFromLocation(FSSpecPtr theSpec, int *length, \ Handle *fullPath) } # Prototypes of Mac only internal functions. declare 13 mac { void TclMacExitHandler(void) } declare 14 mac { void TclMacInitExitToShell(int usePatch) } declare 15 mac { OSErr TclMacInstallExitToShellPatch(ExitToShellProcPtr newProc) } declare 16 mac { int TclMacOSErrorToPosixError(int error) } declare 17 mac { void TclMacRemoveTimer(void *timerToken) } declare 18 mac { void * TclMacStartTimer(long ms) } declare 19 mac { int TclMacTimerExpired(void *timerToken) } declare 20 mac { int TclMacRegisterResourceFork(short fileRef, Tcl_Obj *tokenPtr, \ int insert) } declare 21 mac { short TclMacUnRegisterResourceFork(char *tokenPtr, Tcl_Obj *resultPtr) } declare 22 mac { int TclMacCreateEnv(void) } declare 23 mac { FILE * TclMacFOpenHack(CONST char *path, CONST char *mode) } # Replaced in 8.1 by TclpReadLink: # declare 24 mac { # int TclMacReadlink(char *path, char *buf, int size) # } declare 25 mac { int TclMacChmod(char *path, int mode) } ############################ # Windows specific internals declare 0 win { void TclWinConvertError(DWORD errCode) } declare 1 win { void TclWinConvertWSAError(DWORD errCode) } declare 2 win { struct servent * TclWinGetServByName(CONST char *nm, \ CONST char *proto) } declare 3 win { int TclWinGetSockOpt(SOCKET s, int level, int optname, \ char FAR * optval, int FAR *optlen) } declare 4 win { HINSTANCE TclWinGetTclInstance(void) } # Removed in 8.1: # declare 5 win { # HINSTANCE TclWinLoadLibrary(char *name) # } declare 6 win { u_short TclWinNToHS(u_short ns) } declare 7 win { int TclWinSetSockOpt(SOCKET s, int level, int optname, \ CONST char FAR * optval, int optlen) } declare 8 win { unsigned long TclpGetPid(Tcl_Pid pid) } declare 9 win { int TclWinGetPlatformId(void) } # Removed in 8.3.1 (for Win32s only) #declare 10 win { # int TclWinSynchSpawn(void *args, int type, void **trans, Tcl_Pid *pidPtr) #} # Pipe channel functions declare 11 win { void TclGetAndDetachPids(Tcl_Interp *interp, Tcl_Channel chan) } declare 12 win { int TclpCloseFile(TclFile file) } declare 13 win { Tcl_Channel TclpCreateCommandChannel(TclFile readFile, \ TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr) } declare 14 win { int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe) } declare 15 win { int TclpCreateProcess(Tcl_Interp *interp, int argc, char **argv, \ TclFile inputFile, TclFile outputFile, TclFile errorFile, \ Tcl_Pid *pidPtr) } # Signature changed in 8.1: # declare 16 win { # TclFile TclpCreateTempFile(char *contents, Tcl_DString *namePtr) # } # declare 17 win { # char * TclpGetTZName(void) # } declare 18 win { TclFile TclpMakeFile(Tcl_Channel channel, int direction) } declare 19 win { TclFile TclpOpenFile(CONST char *fname, int mode) } declare 20 win { void TclWinAddProcess(HANDLE hProcess, DWORD id) } # removed permanently for 8.4 #declare 21 win { # void TclpAsyncMark(Tcl_AsyncHandler async) #} # Added in 8.1: declare 22 win { TclFile TclpCreateTempFile(CONST char *contents) } declare 23 win { char * TclpGetTZName(int isdst) } declare 24 win { char * TclWinNoBackslash(char *path) } declare 25 win { TclPlatformType *TclWinGetPlatform(void) } declare 26 win { void TclWinSetInterfaces(int wide) } ######################### # Unix specific internals # Pipe channel functions declare 0 unix { void TclGetAndDetachPids(Tcl_Interp *interp, Tcl_Channel chan) } declare 1 unix { int TclpCloseFile(TclFile file) } declare 2 unix { Tcl_Channel TclpCreateCommandChannel(TclFile readFile, \ TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr) } declare 3 unix { int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe) } declare 4 unix { int TclpCreateProcess(Tcl_Interp *interp, int argc, char **argv, \ TclFile inputFile, TclFile outputFile, TclFile errorFile, \ Tcl_Pid *pidPtr) } # Signature changed in 8.1: # declare 5 unix { # TclFile TclpCreateTempFile(char *contents, # Tcl_DString *namePtr) # } declare 6 unix { TclFile TclpMakeFile(Tcl_Channel channel, int direction) } declare 7 unix { TclFile TclpOpenFile(CONST char *fname, int mode) } declare 8 unix { int TclUnixWaitForFile(int fd, int mask, int timeout) } # Added in 8.1: declare 9 unix { TclFile TclpCreateTempFile(CONST char *contents) } \ No newline at end of file Index: generic/tclInt.h =================================================================== RCS file: /cvsroot/tcl/tcl/generic/tclInt.h,v retrieving revision 1.50 diff -c -r1.50 tclInt.h *** generic/tclInt.h 2000/08/25 02:04:29 1.50 --- generic/tclInt.h 2001/03/16 17:08:11 *************** *** 1272,1282 **** * are added/removed by calling * Tcl_AddInterpResolvers and * Tcl_RemoveInterpResolver. */ ! char *scriptFile; /* NULL means there is no nested source * command active; otherwise this points to ! * the name of the file being sourced (it's ! * not malloc-ed: it points to an argument ! * to Tcl_EvalFile. */ int flags; /* Various flag bits. See below. */ long randSeed; /* Seed used for rand() function. */ Trace *tracePtr; /* List of traces for this interpreter. */ --- 1272,1280 ---- * are added/removed by calling * Tcl_AddInterpResolvers and * Tcl_RemoveInterpResolver. */ ! Tcl_Obj *scriptFile; /* NULL means there is no nested source * command active; otherwise this points to ! * pathPtr of the file being sourced. */ int flags; /* Various flag bits. See below. */ long randSeed; /* Seed used for rand() function. */ Trace *tracePtr; /* List of traces for this interpreter. */ *************** *** 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. */ --- 1501,1506 ---- *************** *** 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. --- 1508,1514 ---- /* * 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 **** --- 1542,1742 ---- #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 obsolete filesystem hooks + *---------------------------------------------------------------- + */ + + 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)); + /* *---------------------------------------------------------------- + * Data structures related to hooking into the filesystem + *---------------------------------------------------------------- + */ + + typedef int (TclfsStatProc_) _ANSI_ARGS_((Tcl_Obj *pathPtr, struct stat *buf)); + typedef int (TclfsAccessProc_) _ANSI_ARGS_((Tcl_Obj *pathPtr, int mode)); + typedef Tcl_Channel (TclfsOpenFileChannelProc_) _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *pathPtr, char *modeString, + int permissions)); + typedef int (TclfsMatchInDirectoryProc_) _ANSI_ARGS_((Tcl_Interp* interp, + Tcl_Obj *result, Tcl_Obj *pathPtr, char *pattern, int dirOnly, + GlobTypeData * types)); + /* + * Most filesystems need not implement this. It will usually only be + * called once, if 'getcwd' is called before 'chdir'. + */ + typedef Tcl_Obj* (TclfsGetCwdProc_) _ANSI_ARGS_((Tcl_Interp *interp)); + /* + * 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 (TclfsChdirProc_) _ANSI_ARGS_((Tcl_Obj *pathPtr)); + typedef int (TclfsLstatProc_) _ANSI_ARGS_((Tcl_Obj *pathPtr, struct stat *buf)); + typedef int (TclfsCreateDirectoryProc_) _ANSI_ARGS_((Tcl_Obj *pathPtr)); + typedef int (TclfsDeleteFileProc_) _ANSI_ARGS_((Tcl_Obj *pathPtr)); + typedef int (TclfsCopyDirectoryProc_) _ANSI_ARGS_((Tcl_Obj *srcPathPtr, + Tcl_Obj *destPathPtr, Tcl_Obj **errorPtr)); + typedef int (TclfsCopyFileProc_) _ANSI_ARGS_((Tcl_Obj *srcPathPtr, + Tcl_Obj *destPathPtr)); + typedef int (TclfsRemoveDirectoryProc_) _ANSI_ARGS_((Tcl_Obj *pathPtr, + int recursive, Tcl_Obj **errorPtr)); + typedef int (TclfsRenameFileProc_) _ANSI_ARGS_((Tcl_Obj *srcPathPtr, + Tcl_Obj *destPathPtr)); + typedef void (TclfsUnloadFileProc_) _ANSI_ARGS_((ClientData clientData)); + typedef int (TclfsListVolumesProc_) _ANSI_ARGS_((Tcl_Interp *interp)); + /* Declare utime structure */ + struct utimbuf; + typedef int (TclfsUtimeProc_) _ANSI_ARGS_((Tcl_Obj *pathPtr, struct utimbuf *tval)); + typedef int (TclfsNormalizePathProc_) _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *pathPtr, int nextCheckpoint)); + typedef int (TclfsFileAttrsGetProc_) _ANSI_ARGS_((Tcl_Interp *interp, + int index, Tcl_Obj *pathPtr, + Tcl_Obj **objPtrRef)); + typedef char** (TclfsFileAttrStringsProc_) _ANSI_ARGS_((Tcl_Obj *pathPtr, Tcl_Obj** objPtrRef)); + typedef int (TclfsFileAttrsSetProc_) _ANSI_ARGS_((Tcl_Interp *interp, + int index, Tcl_Obj *pathPtr, + Tcl_Obj *objPtrRef)); + typedef Tcl_Obj* (TclfsReadlinkProc_) _ANSI_ARGS_((Tcl_Obj *pathPtr)); + typedef int (TclfsLoadFileProc_) _ANSI_ARGS_((Tcl_Interp * interp, + Tcl_Obj *pathPtr, char * sym1, char * sym2, + Tcl_PackageInitProc ** proc1Ptr, + Tcl_PackageInitProc ** proc2Ptr, + ClientData * clientDataPtr)); + typedef int (TclfsPathInFilesystem_) _ANSI_ARGS_((Tcl_Obj *pathPtr, + ClientData *clientDataPtr)); + typedef Tcl_Obj* (TclfsFilesystemPathType_) _ANSI_ARGS_((Tcl_Obj *pathPtr)); + typedef Tcl_Obj* (TclfsFilesystemSeparatorProc_) _ANSI_ARGS_((Tcl_Obj *pathPtr)); + typedef void (TclfsFreeInternalRep_) _ANSI_ARGS_((ClientData clientData)); + typedef ClientData (TclfsDupInternalRep_) _ANSI_ARGS_((ClientData clientData)); + typedef Tcl_Obj* (TclfsInternalToNormalizedProc_) _ANSI_ARGS_((ClientData clientData)); + typedef void (TclfsConvertToInternalProc_) _ANSI_ARGS_((Tcl_Obj *pathPtr)); + + 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 should provide all of + * these functions. + */ + + typedef struct Tcl_Filesystem { + CONST char *typeName; /* The name of the filesystem. */ + int structureLength; /* Length of this structure, so future + * binary compatibility can be assured. */ + Tcl_FilesystemVersion version; + /* Version of the filesystem type. */ + TclfsPathInFilesystem_ *pathInFilesystemProc; + /* Function to check whether a path is in this + * filesystem */ + TclfsFilesystemPathType_ *filesystemPathTypeProc; + /* Function to determine the type of a filesystem + * for a given path */ + TclfsFilesystemSeparatorProc_ *filesystemSeparatorProc; + /* Function to return the separator character(s) + * for this filesystem */ + TclfsDupInternalRep_ *dupInternalRepProc; + /* Function to duplicate internal fs rep */ + TclfsFreeInternalRep_ *freeInternalRepProc; + /* Function to free internal fs rep */ + TclfsInternalToNormalizedProc_ *internalToNormalizedProc_; + /* Function to convert internal representation + * to a normalized path */ + TclfsConvertToInternalProc_ *convertToInternalProc_; + /* Function to convert object to an + * internal representation */ + TclfsStatProc_ *statProc; + /* Function to process a 'Tcl_FSStat()' call */ + TclfsAccessProc_ *accessProc; + /* Function to process a 'Tcl_FSAccess()' call */ + TclfsOpenFileChannelProc_ *openFileChannelProc; + /* Function to process a 'Tcl_FSOpenFileChannel()' call */ + TclfsMatchInDirectoryProc_ *matchInDirectoryProc; + /* Function to process a 'Tcl_FSMatchInDirectory()' */ + TclfsGetCwdProc_ *getCwdProc; + /* Function to process a 'Tcl_FSGetCwd()' call */ + TclfsChdirProc_ *chdirProc; + /* Function to process a 'Tcl_FSChdir()' call */ + TclfsLstatProc_ *lstatProc; + /* Function to process a 'Tcl_FSLstat()' call */ + TclfsCopyFileProc_ *copyFileProc; + /* Function to process a 'Tcl_FSCopyFile()' call */ + TclfsDeleteFileProc_ *deleteFileProc; + /* Function to process a 'Tcl_FSDeleteFile()' call */ + TclfsRenameFileProc_ *renameFileProc; + /* Function to process a 'Tcl_FSRenameFile()' call */ + TclfsCreateDirectoryProc_ *createDirectoryProc; + /* Function to process a 'Tcl_FSCreateDirectory()' call */ + TclfsCopyDirectoryProc_ *copyDirectoryProc; + /* Function to process a 'Tcl_FSCopyDirectory()' call */ + TclfsRemoveDirectoryProc_ *removeDirectoryProc; + /* Function to process a 'Tcl_FSRemoveDirectory()' call */ + TclfsLoadFileProc_ *loadFileProc; + /* Function to process a 'Tcl_FSLoadFile()' call */ + TclfsUnloadFileProc_ *unloadFileProc; + /* Function to unload a previously successfully + * loaded file */ + TclfsReadlinkProc_ *readlinkProc; + /* Function to process a 'Tcl_FSReadlink()' call */ + TclfsListVolumesProc_ *listVolumesProc; + /* Function to list any filesystem volumes added + * by this filesystem */ + TclfsFileAttrStringsProc_ *fileAttrStringsProc; + /* Function to list all attributes strings which + * are valid for this filesystem */ + TclfsFileAttrsGetProc_ *fileAttrsGetProc; + /* Function to process a 'Tcl_FSFileAttrsGet()' call */ + TclfsFileAttrsSetProc_ *fileAttrsSetProc; + /* Function to process a 'Tcl_FSFileAttrsSet()' call */ + TclfsUtimeProc_ *utimeProc; + /* Function to process a 'Tcl_FSUtime()' call */ + TclfsNormalizePathProc_ *normalizePathProc; + /* Function to normalize a path */ + } 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. *---------------------------------------------------------------- */ *************** *** 1575,1582 **** extern Tcl_ChannelType tclFileChannelType; extern char * tclMemDumpFileName; extern TclPlatformType tclPlatform; - extern char * tclpFileAttrStrings[]; - extern CONST TclFileAttrProcs tclpFileAttrProcs[]; /* * Variables denoting the Tcl object types defined in the core. --- 1749,1754 ---- *************** *** 1629,1636 **** *---------------------------------------------------------------- */ - EXTERN int TclAccess _ANSI_ARGS_((CONST char *path, - int mode)); EXTERN int TclAccessDeleteProc _ANSI_ARGS_((TclAccessProc_ *proc)); EXTERN int TclAccessInsertProc _ANSI_ARGS_((TclAccessProc_ *proc)); EXTERN void TclAllocateFreeObjects _ANSI_ARGS_((void)); --- 1801,1806 ---- *************** *** 1671,1683 **** EXTERN int TclFileAttrsCmd _ANSI_ARGS_((Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int TclFileCopyCmd _ANSI_ARGS_((Tcl_Interp *interp, ! int argc, char **argv)) ; EXTERN int TclFileDeleteCmd _ANSI_ARGS_((Tcl_Interp *interp, ! int argc, char **argv)); EXTERN int TclFileMakeDirsCmd _ANSI_ARGS_((Tcl_Interp *interp, ! int argc, char **argv)) ; EXTERN int TclFileRenameCmd _ANSI_ARGS_((Tcl_Interp *interp, ! int argc, char **argv)) ; EXTERN void TclFinalizeAllocSubsystem _ANSI_ARGS_((void)); EXTERN void TclFinalizeCompExecEnv _ANSI_ARGS_((void)); EXTERN void TclFinalizeCompilation _ANSI_ARGS_((void)); --- 1841,1853 ---- EXTERN int TclFileAttrsCmd _ANSI_ARGS_((Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int TclFileCopyCmd _ANSI_ARGS_((Tcl_Interp *interp, ! int objc, Tcl_Obj *CONST objv[])) ; EXTERN int TclFileDeleteCmd _ANSI_ARGS_((Tcl_Interp *interp, ! int objc, Tcl_Obj *CONST objv[])); EXTERN int TclFileMakeDirsCmd _ANSI_ARGS_((Tcl_Interp *interp, ! int objc, Tcl_Obj *CONST objv[])) ; EXTERN int TclFileRenameCmd _ANSI_ARGS_((Tcl_Interp *interp, ! int objc, Tcl_Obj *CONST objv[])) ; EXTERN void TclFinalizeAllocSubsystem _ANSI_ARGS_((void)); EXTERN void TclFinalizeCompExecEnv _ANSI_ARGS_((void)); EXTERN void TclFinalizeCompilation _ANSI_ARGS_((void)); *************** *** 1725,1731 **** EXTERN Tcl_Command TclGetOriginalCommand _ANSI_ARGS_(( Tcl_Command command)); EXTERN int TclGlob _ANSI_ARGS_((Tcl_Interp *interp, ! char *pattern, char *unquotedPrefix, int globFlags, GlobTypeData* types)); EXTERN int TclGlobalInvoke _ANSI_ARGS_((Tcl_Interp *interp, int argc, char **argv, int flags)); --- 1895,1901 ---- EXTERN Tcl_Command TclGetOriginalCommand _ANSI_ARGS_(( Tcl_Command command)); EXTERN int TclGlob _ANSI_ARGS_((Tcl_Interp *interp, ! char *pattern, Tcl_Obj *unquotedPrefix, int globFlags, GlobTypeData* types)); EXTERN int TclGlobalInvoke _ANSI_ARGS_((Tcl_Interp *interp, int argc, char **argv, int flags)); *************** *** 1786,1793 **** TclOpenFileChannelProc_ *proc)); EXTERN int TclOpenFileChannelInsertProc _ANSI_ARGS_(( TclOpenFileChannelProc_ *proc)); ! EXTERN int TclpAccess _ANSI_ARGS_((CONST char *filename, int mode)); EXTERN char * TclpAlloc _ANSI_ARGS_((unsigned int size)); EXTERN int TclpCheckStackSpace _ANSI_ARGS_((void)); EXTERN int TclpCopyFile _ANSI_ARGS_((CONST char *source, --- 1956,1965 ---- TclOpenFileChannelProc_ *proc)); EXTERN int TclOpenFileChannelInsertProc _ANSI_ARGS_(( TclOpenFileChannelProc_ *proc)); ! EXTERN int TclpObjAccess _ANSI_ARGS_((Tcl_Obj *filename, int mode)); + EXTERN int TclpObjLstat _ANSI_ARGS_((Tcl_Obj *pathPtr, + struct stat *buf)); EXTERN char * TclpAlloc _ANSI_ARGS_((unsigned int size)); EXTERN int TclpCheckStackSpace _ANSI_ARGS_((void)); EXTERN int TclpCopyFile _ANSI_ARGS_((CONST char *source, *************** *** 1827,1832 **** --- 1999,2006 ---- EXTERN int TclpMatchFiles _ANSI_ARGS_((Tcl_Interp *interp, char *separators, Tcl_DString *dirPtr, char *pattern, char *tail)); + EXTERN int TclpObjNormalizePath _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *pathPtr, int nextCheckpoint)); EXTERN Tcl_Channel TclpOpenFileChannel _ANSI_ARGS_((Tcl_Interp *interp, char *fileName, char *modeString, int permissions)); *************** *** 1839,1844 **** --- 2013,2022 ---- int recursive, Tcl_DString *errorPtr)); EXTERN int TclpRenameFile _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,1902 **** char *string, char *proto, int *portPtr)); EXTERN int TclSockMinimumBuffers _ANSI_ARGS_((int sock, int size)); - EXTERN int TclStat _ANSI_ARGS_((CONST char *path, - struct stat *buf)); EXTERN int TclStatDeleteProc _ANSI_ARGS_((TclStatProc_ *proc)); EXTERN int TclStatInsertProc _ANSI_ARGS_((TclStatProc_ *proc)); EXTERN void TclTeardownNamespace _ANSI_ARGS_((Namespace *nsPtr)); EXTERN void TclTransferResult _ANSI_ARGS_((Tcl_Interp *sourceInterp, int result, Tcl_Interp *targetInterp)); EXTERN int TclUpdateReturnInfo _ANSI_ARGS_((Interp *iPtr)); /* *---------------------------------------------------------------- --- 2067,2086 ---- char *string, char *proto, int *portPtr)); EXTERN int TclSockMinimumBuffers _ANSI_ARGS_((int sock, int size)); EXTERN int TclStatDeleteProc _ANSI_ARGS_((TclStatProc_ *proc)); EXTERN int TclStatInsertProc _ANSI_ARGS_((TclStatProc_ *proc)); EXTERN void TclTeardownNamespace _ANSI_ARGS_((Namespace *nsPtr)); EXTERN void TclTransferResult _ANSI_ARGS_((Tcl_Interp *sourceInterp, int result, Tcl_Interp *targetInterp)); EXTERN int TclUpdateReturnInfo _ANSI_ARGS_((Interp *iPtr)); + EXTERN char* Tcl_FSGetTranslatedPath _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj* pathPtr)); + EXTERN Tcl_Obj* Tcl_FSGetNormalizedPath _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj* pathObjPtr)); + EXTERN ClientData Tcl_FSGetInternalRep _ANSI_ARGS_((Tcl_Obj* pathObjPtr, + Tcl_Filesystem* fsPtr)); + EXTERN char* Tcl_FSGetNativePath _ANSI_ARGS_((Tcl_Obj* pathObjPtr)); + /* *---------------------------------------------------------------- Index: generic/tclIntDecls.h =================================================================== RCS file: /cvsroot/tcl/tcl/generic/tclIntDecls.h,v retrieving revision 1.21 diff -c -r1.21 tclIntDecls.h *** generic/tclIntDecls.h 2000/09/28 06:38:21 1.21 --- generic/tclIntDecls.h 2001/03/16 17:08:11 *************** *** 96,116 **** /* 16 */ EXTERN void TclExprFloatError _ANSI_ARGS_((Tcl_Interp * interp, double value)); ! /* 17 */ ! EXTERN int TclFileAttrsCmd _ANSI_ARGS_((Tcl_Interp * interp, ! int objc, Tcl_Obj *CONST objv[])); ! /* 18 */ ! EXTERN int TclFileCopyCmd _ANSI_ARGS_((Tcl_Interp * interp, ! int argc, char ** argv)); ! /* 19 */ ! EXTERN int TclFileDeleteCmd _ANSI_ARGS_((Tcl_Interp * interp, ! int argc, char ** argv)); ! /* 20 */ ! EXTERN int TclFileMakeDirsCmd _ANSI_ARGS_((Tcl_Interp * interp, ! int argc, char ** argv)); ! /* 21 */ ! EXTERN int TclFileRenameCmd _ANSI_ARGS_((Tcl_Interp * interp, ! int argc, char ** argv)); /* 22 */ EXTERN int TclFindElement _ANSI_ARGS_((Tcl_Interp * interp, CONST char * listStr, int listLength, --- 96,106 ---- /* 16 */ EXTERN void TclExprFloatError _ANSI_ARGS_((Tcl_Interp * interp, double value)); ! /* Slot 17 is reserved */ ! /* Slot 18 is reserved */ ! /* Slot 19 is reserved */ ! /* Slot 20 is reserved */ ! /* Slot 21 is reserved */ /* 22 */ EXTERN int TclFindElement _ANSI_ARGS_((Tcl_Interp * interp, CONST char * listStr, int listLength, *************** *** 223,232 **** char * part1, char * part2, int flags, char * msg, int createPart1, int createPart2, Var ** arrayPtrPtr)); ! /* 59 */ ! EXTERN int TclpMatchFiles _ANSI_ARGS_((Tcl_Interp * interp, ! char * separators, Tcl_DString * dirPtr, ! char * pattern, char * tail)); /* 60 */ EXTERN int TclNeedSpace _ANSI_ARGS_((char * start, char * end)); /* 61 */ --- 213,219 ---- char * part1, char * part2, int flags, char * msg, int createPart1, int createPart2, Var ** arrayPtrPtr)); ! /* Slot 59 is reserved */ /* 60 */ EXTERN int TclNeedSpace _ANSI_ARGS_((char * start, char * end)); /* 61 */ *************** *** 253,268 **** EXTERN int TclpAccess _ANSI_ARGS_((CONST char * path, int mode)); /* 69 */ EXTERN char * TclpAlloc _ANSI_ARGS_((unsigned int size)); ! /* 70 */ ! EXTERN int TclpCopyFile _ANSI_ARGS_((CONST char * source, ! CONST char * dest)); ! /* 71 */ ! EXTERN int TclpCopyDirectory _ANSI_ARGS_((CONST char * source, ! CONST char * dest, Tcl_DString * errorPtr)); ! /* 72 */ ! EXTERN int TclpCreateDirectory _ANSI_ARGS_((CONST char * path)); ! /* 73 */ ! EXTERN int TclpDeleteFile _ANSI_ARGS_((CONST char * path)); /* 74 */ EXTERN void TclpFree _ANSI_ARGS_((char * ptr)); /* 75 */ --- 240,249 ---- EXTERN int TclpAccess _ANSI_ARGS_((CONST char * path, int mode)); /* 69 */ EXTERN char * TclpAlloc _ANSI_ARGS_((unsigned int size)); ! /* Slot 70 is reserved */ ! /* Slot 71 is reserved */ ! /* Slot 72 is reserved */ ! /* Slot 73 is reserved */ /* 74 */ EXTERN void TclpFree _ANSI_ARGS_((char * ptr)); /* 75 */ *************** *** 282,293 **** /* 81 */ EXTERN char * TclpRealloc _ANSI_ARGS_((char * ptr, unsigned int size)); ! /* 82 */ ! EXTERN int TclpRemoveDirectory _ANSI_ARGS_((CONST char * path, ! int recursive, Tcl_DString * errorPtr)); ! /* 83 */ ! EXTERN int TclpRenameFile _ANSI_ARGS_((CONST char * source, ! CONST char * dest)); /* Slot 84 is reserved */ /* Slot 85 is reserved */ /* Slot 86 is reserved */ --- 263,270 ---- /* 81 */ EXTERN char * TclpRealloc _ANSI_ARGS_((char * ptr, unsigned int size)); ! /* Slot 82 is reserved */ ! /* Slot 83 is reserved */ /* Slot 84 is reserved */ /* Slot 85 is reserved */ /* Slot 86 is reserved */ *************** *** 457,464 **** /* 135 */ EXTERN int TclpCheckStackSpace _ANSI_ARGS_((void)); /* Slot 136 is reserved */ ! /* 137 */ ! EXTERN int TclpChdir _ANSI_ARGS_((CONST char * dirName)); /* 138 */ EXTERN char * TclGetEnv _ANSI_ARGS_((CONST char * name, Tcl_DString * valuePtr)); --- 434,440 ---- /* 135 */ EXTERN int TclpCheckStackSpace _ANSI_ARGS_((void)); /* Slot 136 is reserved */ ! /* Slot 137 is reserved */ /* 138 */ EXTERN char * TclGetEnv _ANSI_ARGS_((CONST char * name, Tcl_DString * valuePtr)); *************** *** 471,479 **** /* 140 */ EXTERN int TclLooksLikeInt _ANSI_ARGS_((char * bytes, int length)); ! /* 141 */ ! EXTERN char * TclpGetCwd _ANSI_ARGS_((Tcl_Interp * interp, ! Tcl_DString * cwdPtr)); /* 142 */ EXTERN int TclSetByteCodeFromAny _ANSI_ARGS_(( Tcl_Interp * interp, Tcl_Obj * objPtr, --- 447,453 ---- /* 140 */ EXTERN int TclLooksLikeInt _ANSI_ARGS_((char * bytes, int length)); ! /* Slot 141 is reserved */ /* 142 */ EXTERN int TclSetByteCodeFromAny _ANSI_ARGS_(( Tcl_Interp * interp, Tcl_Obj * objPtr, *************** *** 519,535 **** char * filename)); /* 159 */ EXTERN char * TclGetStartupScriptFileName _ANSI_ARGS_((void)); ! /* 160 */ ! EXTERN int TclpMatchFilesTypes _ANSI_ARGS_((Tcl_Interp * interp, ! char * separators, Tcl_DString * dirPtr, ! char * pattern, char * tail, ! GlobTypeData * types)); /* 161 */ EXTERN int TclChannelTransform _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan, Tcl_Obj * cmdObjPtr)); /* 162 */ EXTERN void TclChannelEventScriptInvoker _ANSI_ARGS_(( ClientData clientData, int flags)); typedef struct TclIntStubs { int magic; --- 493,624 ---- char * filename)); /* 159 */ EXTERN char * TclGetStartupScriptFileName _ANSI_ARGS_((void)); ! /* Slot 160 is reserved */ /* 161 */ EXTERN int TclChannelTransform _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan, Tcl_Obj * cmdObjPtr)); /* 162 */ EXTERN void TclChannelEventScriptInvoker _ANSI_ARGS_(( ClientData clientData, int flags)); + /* 163 */ + EXTERN void TclpVerifyInitialEncodings _ANSI_ARGS_((void)); + /* 164 */ + EXTERN int Tcl_FSCopyFile _ANSI_ARGS_((Tcl_Obj * srcPathPtr, + Tcl_Obj * destPathPtr)); + /* 165 */ + EXTERN int Tcl_FSCopyDirectory _ANSI_ARGS_(( + Tcl_Obj * srcPathPtr, Tcl_Obj * destPathPtr, + Tcl_Obj ** errorPtr)); + /* 166 */ + EXTERN int Tcl_FSCreateDirectory _ANSI_ARGS_((Tcl_Obj * pathPtr)); + /* 167 */ + EXTERN int Tcl_FSDeleteFile _ANSI_ARGS_((Tcl_Obj * pathPtr)); + /* 168 */ + EXTERN int Tcl_FSListVolumes _ANSI_ARGS_((Tcl_Interp * interp)); + /* 169 */ + EXTERN int Tcl_FSLoadFile _ANSI_ARGS_((Tcl_Interp * interp, + Tcl_Obj * pathPtr, char * sym1, char * sym2, + Tcl_PackageInitProc ** proc1Ptr, + Tcl_PackageInitProc ** proc2Ptr, + ClientData * clientDataPtr, + TclfsUnloadFileProc_ ** unloadProcPtr)); + /* 170 */ + EXTERN int Tcl_FSMatchInDirectory _ANSI_ARGS_(( + Tcl_Interp * interp, Tcl_Obj * result, + Tcl_Obj * pathPtr, char * pattern, + int dirOnly, GlobTypeData * types)); + /* 171 */ + EXTERN Tcl_Obj* Tcl_FSReadlink _ANSI_ARGS_((Tcl_Obj * pathPtr)); + /* 172 */ + EXTERN int Tcl_FSRemoveDirectory _ANSI_ARGS_((Tcl_Obj * pathPtr, + int recursive, Tcl_Obj ** errorPtr)); + /* 173 */ + EXTERN int Tcl_FSRenameFile _ANSI_ARGS_((Tcl_Obj * srcPathPtr, + Tcl_Obj * destPathPtr)); + /* 174 */ + EXTERN int Tcl_FSLstat _ANSI_ARGS_((Tcl_Obj * pathPtr, + struct stat * buf)); + /* 175 */ + EXTERN int Tcl_FSUtime _ANSI_ARGS_((Tcl_Obj * pathPtr, + struct utimbuf * tval)); + /* 176 */ + EXTERN int Tcl_FSFileAttrsGet _ANSI_ARGS_((Tcl_Interp * interp, + int index, Tcl_Obj * pathPtr, + Tcl_Obj ** objPtrRef)); + /* 177 */ + EXTERN int Tcl_FSFileAttrsSet _ANSI_ARGS_((Tcl_Interp * interp, + int index, Tcl_Obj * pathPtr, + Tcl_Obj * objPtr)); + /* 178 */ + EXTERN char** Tcl_FSFileAttrStrings _ANSI_ARGS_((Tcl_Obj * pathPtr, + Tcl_Obj ** objPtrRef)); + /* 179 */ + EXTERN int Tcl_FSStat _ANSI_ARGS_((Tcl_Obj * pathPtr, + struct stat * buf)); + /* 180 */ + EXTERN int Tcl_FSAccess _ANSI_ARGS_((Tcl_Obj * pathPtr, + int mode)); + /* 181 */ + EXTERN Tcl_Channel Tcl_FSOpenFileChannel _ANSI_ARGS_(( + Tcl_Interp * interp, Tcl_Obj * pathPtr, + char * modeString, int permissions)); + /* 182 */ + EXTERN Tcl_Obj* Tcl_FSGetCwd _ANSI_ARGS_((Tcl_Interp * interp)); + /* 183 */ + EXTERN int Tcl_FSChdir _ANSI_ARGS_((Tcl_Obj * pathPtr)); + /* 184 */ + EXTERN int Tcl_FSConvertToPathType _ANSI_ARGS_(( + Tcl_Interp * interp, Tcl_Obj * pathPtr)); + /* 185 */ + EXTERN int TclFileCopyCmd _ANSI_ARGS_((Tcl_Interp * interp, + int objc, Tcl_Obj *CONST objv[])); + /* 186 */ + EXTERN int TclFileRenameCmd _ANSI_ARGS_((Tcl_Interp * interp, + int objc, Tcl_Obj *CONST objv[])); + /* 187 */ + EXTERN Tcl_Obj* Tcl_FSJoinPath _ANSI_ARGS_((Tcl_Obj * listObj, + int elements)); + /* 188 */ + EXTERN int TclFileDeleteCmd _ANSI_ARGS_((Tcl_Interp * interp, + int objc, Tcl_Obj *CONST objv[])); + /* 189 */ + EXTERN int TclFileMakeDirsCmd _ANSI_ARGS_((Tcl_Interp * interp, + int objc, Tcl_Obj *CONST objv[])); + /* 190 */ + EXTERN int TclFileAttrsCmd _ANSI_ARGS_((Tcl_Interp * interp, + int objc, Tcl_Obj *CONST objv[])); + /* 191 */ + EXTERN Tcl_Obj* Tcl_FSSplitPath _ANSI_ARGS_((Tcl_Obj* pathPtr, + int * lenPtr)); + /* 192 */ + EXTERN int Tcl_FSEqualPaths _ANSI_ARGS_((Tcl_Obj* firstPtr, + Tcl_Obj* secondPtr)); + /* 193 */ + EXTERN Tcl_Obj* Tcl_FSGetNormalizedPath _ANSI_ARGS_(( + Tcl_Interp * interp, Tcl_Obj* pathObjPtr)); + /* 194 */ + EXTERN Tcl_Obj* Tcl_FSJoinToPath _ANSI_ARGS_((Tcl_Obj * basePtr, + int objc, Tcl_Obj *CONST objv[])); + /* 195 */ + EXTERN ClientData Tcl_FSGetInternalRep _ANSI_ARGS_(( + Tcl_Obj* pathObjPtr, Tcl_Filesystem * fsPtr)); + /* 196 */ + EXTERN char* Tcl_FSGetTranslatedPath _ANSI_ARGS_(( + Tcl_Interp * interp, Tcl_Obj* pathPtr)); + /* 197 */ + EXTERN int Tcl_FSEvalFile _ANSI_ARGS_((Tcl_Interp * interp, + Tcl_Obj * fileName)); + /* 198 */ + EXTERN Tcl_Obj* Tcl_FSNewNativePath _ANSI_ARGS_(( + Tcl_Obj* fromFilesystem, + ClientData clientData)); + /* 199 */ + EXTERN char* Tcl_FSGetNativePath _ANSI_ARGS_((Tcl_Obj* pathObjPtr)); + /* 200 */ + EXTERN Tcl_Obj* Tcl_FSFileSystemInfo _ANSI_ARGS_(( + Tcl_Obj* pathObjPtr)); + /* 201 */ + EXTERN Tcl_Obj* Tcl_FSPathSeparator _ANSI_ARGS_((Tcl_Obj* pathObjPtr)); typedef struct TclIntStubs { int magic; *************** *** 568,578 **** void (*tclDumpMemoryInfo) _ANSI_ARGS_((FILE * outFile)); /* 14 */ void *reserved15; void (*tclExprFloatError) _ANSI_ARGS_((Tcl_Interp * interp, double value)); /* 16 */ ! int (*tclFileAttrsCmd) _ANSI_ARGS_((Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 17 */ ! int (*tclFileCopyCmd) _ANSI_ARGS_((Tcl_Interp * interp, int argc, char ** argv)); /* 18 */ ! int (*tclFileDeleteCmd) _ANSI_ARGS_((Tcl_Interp * interp, int argc, char ** argv)); /* 19 */ ! int (*tclFileMakeDirsCmd) _ANSI_ARGS_((Tcl_Interp * interp, int argc, char ** argv)); /* 20 */ ! int (*tclFileRenameCmd) _ANSI_ARGS_((Tcl_Interp * interp, int argc, char ** argv)); /* 21 */ int (*tclFindElement) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * listStr, int listLength, CONST char ** elementPtr, CONST char ** nextPtr, int * sizePtr, int * bracePtr)); /* 22 */ Proc * (*tclFindProc) _ANSI_ARGS_((Interp * iPtr, char * procName)); /* 23 */ int (*tclFormatInt) _ANSI_ARGS_((char * buffer, long n)); /* 24 */ --- 657,667 ---- void (*tclDumpMemoryInfo) _ANSI_ARGS_((FILE * outFile)); /* 14 */ void *reserved15; void (*tclExprFloatError) _ANSI_ARGS_((Tcl_Interp * interp, double value)); /* 16 */ ! void *reserved17; ! void *reserved18; ! void *reserved19; ! void *reserved20; ! void *reserved21; int (*tclFindElement) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * listStr, int listLength, CONST char ** elementPtr, CONST char ** nextPtr, int * sizePtr, int * bracePtr)); /* 22 */ Proc * (*tclFindProc) _ANSI_ARGS_((Interp * iPtr, char * procName)); /* 23 */ int (*tclFormatInt) _ANSI_ARGS_((char * buffer, long n)); /* 24 */ *************** *** 610,616 **** void *reserved56; void *reserved57; Var * (*tclLookupVar) _ANSI_ARGS_((Tcl_Interp * interp, char * part1, char * part2, int flags, char * msg, int createPart1, int createPart2, Var ** arrayPtrPtr)); /* 58 */ ! int (*tclpMatchFiles) _ANSI_ARGS_((Tcl_Interp * interp, char * separators, Tcl_DString * dirPtr, char * pattern, char * tail)); /* 59 */ int (*tclNeedSpace) _ANSI_ARGS_((char * start, char * end)); /* 60 */ Tcl_Obj * (*tclNewProcBodyObj) _ANSI_ARGS_((Proc * procPtr)); /* 61 */ int (*tclObjCommandComplete) _ANSI_ARGS_((Tcl_Obj * cmdPtr)); /* 62 */ --- 699,705 ---- void *reserved56; void *reserved57; Var * (*tclLookupVar) _ANSI_ARGS_((Tcl_Interp * interp, char * part1, char * part2, int flags, char * msg, int createPart1, int createPart2, Var ** arrayPtrPtr)); /* 58 */ ! void *reserved59; int (*tclNeedSpace) _ANSI_ARGS_((char * start, char * end)); /* 60 */ Tcl_Obj * (*tclNewProcBodyObj) _ANSI_ARGS_((Proc * procPtr)); /* 61 */ int (*tclObjCommandComplete) _ANSI_ARGS_((Tcl_Obj * cmdPtr)); /* 62 */ *************** *** 621,630 **** int (*tclOpenFileChannelInsertProc) _ANSI_ARGS_((TclOpenFileChannelProc_ * proc)); /* 67 */ int (*tclpAccess) _ANSI_ARGS_((CONST char * path, int mode)); /* 68 */ char * (*tclpAlloc) _ANSI_ARGS_((unsigned int size)); /* 69 */ ! int (*tclpCopyFile) _ANSI_ARGS_((CONST char * source, CONST char * dest)); /* 70 */ ! int (*tclpCopyDirectory) _ANSI_ARGS_((CONST char * source, CONST char * dest, Tcl_DString * errorPtr)); /* 71 */ ! int (*tclpCreateDirectory) _ANSI_ARGS_((CONST char * path)); /* 72 */ ! int (*tclpDeleteFile) _ANSI_ARGS_((CONST char * path)); /* 73 */ void (*tclpFree) _ANSI_ARGS_((char * ptr)); /* 74 */ unsigned long (*tclpGetClicks) _ANSI_ARGS_((void)); /* 75 */ unsigned long (*tclpGetSeconds) _ANSI_ARGS_((void)); /* 76 */ --- 710,719 ---- int (*tclOpenFileChannelInsertProc) _ANSI_ARGS_((TclOpenFileChannelProc_ * proc)); /* 67 */ int (*tclpAccess) _ANSI_ARGS_((CONST char * path, int mode)); /* 68 */ char * (*tclpAlloc) _ANSI_ARGS_((unsigned int size)); /* 69 */ ! void *reserved70; ! void *reserved71; ! void *reserved72; ! void *reserved73; void (*tclpFree) _ANSI_ARGS_((char * ptr)); /* 74 */ unsigned long (*tclpGetClicks) _ANSI_ARGS_((void)); /* 75 */ unsigned long (*tclpGetSeconds) _ANSI_ARGS_((void)); /* 76 */ *************** *** 633,640 **** int (*tclpListVolumes) _ANSI_ARGS_((Tcl_Interp * interp)); /* 79 */ Tcl_Channel (*tclpOpenFileChannel) _ANSI_ARGS_((Tcl_Interp * interp, char * fileName, char * modeString, int permissions)); /* 80 */ char * (*tclpRealloc) _ANSI_ARGS_((char * ptr, unsigned int size)); /* 81 */ ! int (*tclpRemoveDirectory) _ANSI_ARGS_((CONST char * path, int recursive, Tcl_DString * errorPtr)); /* 82 */ ! int (*tclpRenameFile) _ANSI_ARGS_((CONST char * source, CONST char * dest)); /* 83 */ void *reserved84; void *reserved85; void *reserved86; --- 722,729 ---- int (*tclpListVolumes) _ANSI_ARGS_((Tcl_Interp * interp)); /* 79 */ Tcl_Channel (*tclpOpenFileChannel) _ANSI_ARGS_((Tcl_Interp * interp, char * fileName, char * modeString, int permissions)); /* 80 */ char * (*tclpRealloc) _ANSI_ARGS_((char * ptr, unsigned int size)); /* 81 */ ! void *reserved82; ! void *reserved83; void *reserved84; void *reserved85; void *reserved86; *************** *** 704,714 **** size_t (*tclpStrftime) _ANSI_ARGS_((char * s, size_t maxsize, CONST char * format, CONST struct tm * t)); /* 134 */ int (*tclpCheckStackSpace) _ANSI_ARGS_((void)); /* 135 */ void *reserved136; ! int (*tclpChdir) _ANSI_ARGS_((CONST char * dirName)); /* 137 */ char * (*tclGetEnv) _ANSI_ARGS_((CONST char * name, Tcl_DString * valuePtr)); /* 138 */ int (*tclpLoadFile) _ANSI_ARGS_((Tcl_Interp * interp, char * fileName, char * sym1, char * sym2, Tcl_PackageInitProc ** proc1Ptr, Tcl_PackageInitProc ** proc2Ptr, ClientData * clientDataPtr)); /* 139 */ int (*tclLooksLikeInt) _ANSI_ARGS_((char * bytes, int length)); /* 140 */ ! char * (*tclpGetCwd) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_DString * cwdPtr)); /* 141 */ int (*tclSetByteCodeFromAny) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, CompileHookProc * hookProc, ClientData clientData)); /* 142 */ int (*tclAddLiteralObj) _ANSI_ARGS_((struct CompileEnv * envPtr, Tcl_Obj * objPtr, LiteralEntry ** litPtrPtr)); /* 143 */ void (*tclHideLiteral) _ANSI_ARGS_((Tcl_Interp * interp, struct CompileEnv * envPtr, int index)); /* 144 */ --- 793,803 ---- size_t (*tclpStrftime) _ANSI_ARGS_((char * s, size_t maxsize, CONST char * format, CONST struct tm * t)); /* 134 */ int (*tclpCheckStackSpace) _ANSI_ARGS_((void)); /* 135 */ void *reserved136; ! void *reserved137; char * (*tclGetEnv) _ANSI_ARGS_((CONST char * name, Tcl_DString * valuePtr)); /* 138 */ int (*tclpLoadFile) _ANSI_ARGS_((Tcl_Interp * interp, char * fileName, char * sym1, char * sym2, Tcl_PackageInitProc ** proc1Ptr, Tcl_PackageInitProc ** proc2Ptr, ClientData * clientDataPtr)); /* 139 */ int (*tclLooksLikeInt) _ANSI_ARGS_((char * bytes, int length)); /* 140 */ ! void *reserved141; int (*tclSetByteCodeFromAny) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, CompileHookProc * hookProc, ClientData clientData)); /* 142 */ int (*tclAddLiteralObj) _ANSI_ARGS_((struct CompileEnv * envPtr, Tcl_Obj * objPtr, LiteralEntry ** litPtrPtr)); /* 143 */ void (*tclHideLiteral) _ANSI_ARGS_((Tcl_Interp * interp, struct CompileEnv * envPtr, int index)); /* 144 */ *************** *** 727,735 **** Var * (*tclVarTraceExists) _ANSI_ARGS_((Tcl_Interp * interp, char * varName)); /* 157 */ void (*tclSetStartupScriptFileName) _ANSI_ARGS_((char * filename)); /* 158 */ char * (*tclGetStartupScriptFileName) _ANSI_ARGS_((void)); /* 159 */ ! 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 */ } TclIntStubs; #ifdef __cplusplus --- 816,863 ---- Var * (*tclVarTraceExists) _ANSI_ARGS_((Tcl_Interp * interp, char * varName)); /* 157 */ void (*tclSetStartupScriptFileName) _ANSI_ARGS_((char * filename)); /* 158 */ char * (*tclGetStartupScriptFileName) _ANSI_ARGS_((void)); /* 159 */ ! void *reserved160; int (*tclChannelTransform) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan, Tcl_Obj * cmdObjPtr)); /* 161 */ void (*tclChannelEventScriptInvoker) _ANSI_ARGS_((ClientData clientData, int flags)); /* 162 */ + void (*tclpVerifyInitialEncodings) _ANSI_ARGS_((void)); /* 163 */ + int (*tcl_FSCopyFile) _ANSI_ARGS_((Tcl_Obj * srcPathPtr, Tcl_Obj * destPathPtr)); /* 164 */ + int (*tcl_FSCopyDirectory) _ANSI_ARGS_((Tcl_Obj * srcPathPtr, Tcl_Obj * destPathPtr, Tcl_Obj ** errorPtr)); /* 165 */ + int (*tcl_FSCreateDirectory) _ANSI_ARGS_((Tcl_Obj * pathPtr)); /* 166 */ + int (*tcl_FSDeleteFile) _ANSI_ARGS_((Tcl_Obj * pathPtr)); /* 167 */ + int (*tcl_FSListVolumes) _ANSI_ARGS_((Tcl_Interp * interp)); /* 168 */ + int (*tcl_FSLoadFile) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * pathPtr, char * sym1, char * sym2, Tcl_PackageInitProc ** proc1Ptr, Tcl_PackageInitProc ** proc2Ptr, ClientData * clientDataPtr, TclfsUnloadFileProc_ ** unloadProcPtr)); /* 169 */ + int (*tcl_FSMatchInDirectory) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * result, Tcl_Obj * pathPtr, char * pattern, int dirOnly, GlobTypeData * types)); /* 170 */ + Tcl_Obj* (*tcl_FSReadlink) _ANSI_ARGS_((Tcl_Obj * pathPtr)); /* 171 */ + int (*tcl_FSRemoveDirectory) _ANSI_ARGS_((Tcl_Obj * pathPtr, int recursive, Tcl_Obj ** errorPtr)); /* 172 */ + int (*tcl_FSRenameFile) _ANSI_ARGS_((Tcl_Obj * srcPathPtr, Tcl_Obj * destPathPtr)); /* 173 */ + int (*tcl_FSLstat) _ANSI_ARGS_((Tcl_Obj * pathPtr, struct stat * buf)); /* 174 */ + int (*tcl_FSUtime) _ANSI_ARGS_((Tcl_Obj * pathPtr, struct utimbuf * tval)); /* 175 */ + int (*tcl_FSFileAttrsGet) _ANSI_ARGS_((Tcl_Interp * interp, int index, Tcl_Obj * pathPtr, Tcl_Obj ** objPtrRef)); /* 176 */ + int (*tcl_FSFileAttrsSet) _ANSI_ARGS_((Tcl_Interp * interp, int index, Tcl_Obj * pathPtr, Tcl_Obj * objPtr)); /* 177 */ + char** (*tcl_FSFileAttrStrings) _ANSI_ARGS_((Tcl_Obj * pathPtr, Tcl_Obj ** objPtrRef)); /* 178 */ + int (*tcl_FSStat) _ANSI_ARGS_((Tcl_Obj * pathPtr, struct stat * buf)); /* 179 */ + int (*tcl_FSAccess) _ANSI_ARGS_((Tcl_Obj * pathPtr, int mode)); /* 180 */ + Tcl_Channel (*tcl_FSOpenFileChannel) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * pathPtr, char * modeString, int permissions)); /* 181 */ + Tcl_Obj* (*tcl_FSGetCwd) _ANSI_ARGS_((Tcl_Interp * interp)); /* 182 */ + int (*tcl_FSChdir) _ANSI_ARGS_((Tcl_Obj * pathPtr)); /* 183 */ + int (*tcl_FSConvertToPathType) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * pathPtr)); /* 184 */ + int (*tclFileCopyCmd) _ANSI_ARGS_((Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 185 */ + int (*tclFileRenameCmd) _ANSI_ARGS_((Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 186 */ + Tcl_Obj* (*tcl_FSJoinPath) _ANSI_ARGS_((Tcl_Obj * listObj, int elements)); /* 187 */ + int (*tclFileDeleteCmd) _ANSI_ARGS_((Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 188 */ + int (*tclFileMakeDirsCmd) _ANSI_ARGS_((Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 189 */ + int (*tclFileAttrsCmd) _ANSI_ARGS_((Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 190 */ + Tcl_Obj* (*tcl_FSSplitPath) _ANSI_ARGS_((Tcl_Obj* pathPtr, int * lenPtr)); /* 191 */ + int (*tcl_FSEqualPaths) _ANSI_ARGS_((Tcl_Obj* firstPtr, Tcl_Obj* secondPtr)); /* 192 */ + Tcl_Obj* (*tcl_FSGetNormalizedPath) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj* pathObjPtr)); /* 193 */ + Tcl_Obj* (*tcl_FSJoinToPath) _ANSI_ARGS_((Tcl_Obj * basePtr, int objc, Tcl_Obj *CONST objv[])); /* 194 */ + ClientData (*tcl_FSGetInternalRep) _ANSI_ARGS_((Tcl_Obj* pathObjPtr, Tcl_Filesystem * fsPtr)); /* 195 */ + char* (*tcl_FSGetTranslatedPath) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj* pathPtr)); /* 196 */ + int (*tcl_FSEvalFile) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * fileName)); /* 197 */ + Tcl_Obj* (*tcl_FSNewNativePath) _ANSI_ARGS_((Tcl_Obj* fromFilesystem, ClientData clientData)); /* 198 */ + char* (*tcl_FSGetNativePath) _ANSI_ARGS_((Tcl_Obj* pathObjPtr)); /* 199 */ + Tcl_Obj* (*tcl_FSFileSystemInfo) _ANSI_ARGS_((Tcl_Obj* pathObjPtr)); /* 200 */ + Tcl_Obj* (*tcl_FSPathSeparator) _ANSI_ARGS_((Tcl_Obj* pathObjPtr)); /* 201 */ } TclIntStubs; #ifdef __cplusplus *************** *** 823,849 **** #ifndef TclExprFloatError #define TclExprFloatError \ (tclIntStubsPtr->tclExprFloatError) /* 16 */ - #endif - #ifndef TclFileAttrsCmd - #define TclFileAttrsCmd \ - (tclIntStubsPtr->tclFileAttrsCmd) /* 17 */ - #endif - #ifndef TclFileCopyCmd - #define TclFileCopyCmd \ - (tclIntStubsPtr->tclFileCopyCmd) /* 18 */ #endif ! #ifndef TclFileDeleteCmd ! #define TclFileDeleteCmd \ ! (tclIntStubsPtr->tclFileDeleteCmd) /* 19 */ ! #endif ! #ifndef TclFileMakeDirsCmd ! #define TclFileMakeDirsCmd \ ! (tclIntStubsPtr->tclFileMakeDirsCmd) /* 20 */ ! #endif ! #ifndef TclFileRenameCmd ! #define TclFileRenameCmd \ ! (tclIntStubsPtr->tclFileRenameCmd) /* 21 */ ! #endif #ifndef TclFindElement #define TclFindElement \ (tclIntStubsPtr->tclFindElement) /* 22 */ --- 951,962 ---- #ifndef TclExprFloatError #define TclExprFloatError \ (tclIntStubsPtr->tclExprFloatError) /* 16 */ #endif ! /* Slot 17 is reserved */ ! /* Slot 18 is reserved */ ! /* Slot 19 is reserved */ ! /* Slot 20 is reserved */ ! /* Slot 21 is reserved */ #ifndef TclFindElement #define TclFindElement \ (tclIntStubsPtr->tclFindElement) /* 22 */ *************** *** 980,989 **** #define TclLookupVar \ (tclIntStubsPtr->tclLookupVar) /* 58 */ #endif ! #ifndef TclpMatchFiles ! #define TclpMatchFiles \ ! (tclIntStubsPtr->tclpMatchFiles) /* 59 */ ! #endif #ifndef TclNeedSpace #define TclNeedSpace \ (tclIntStubsPtr->tclNeedSpace) /* 60 */ --- 1093,1099 ---- #define TclLookupVar \ (tclIntStubsPtr->tclLookupVar) /* 58 */ #endif ! /* Slot 59 is reserved */ #ifndef TclNeedSpace #define TclNeedSpace \ (tclIntStubsPtr->tclNeedSpace) /* 60 */ *************** *** 1023,1045 **** #ifndef TclpAlloc #define TclpAlloc \ (tclIntStubsPtr->tclpAlloc) /* 69 */ - #endif - #ifndef TclpCopyFile - #define TclpCopyFile \ - (tclIntStubsPtr->tclpCopyFile) /* 70 */ - #endif - #ifndef TclpCopyDirectory - #define TclpCopyDirectory \ - (tclIntStubsPtr->tclpCopyDirectory) /* 71 */ - #endif - #ifndef TclpCreateDirectory - #define TclpCreateDirectory \ - (tclIntStubsPtr->tclpCreateDirectory) /* 72 */ - #endif - #ifndef TclpDeleteFile - #define TclpDeleteFile \ - (tclIntStubsPtr->tclpDeleteFile) /* 73 */ #endif #ifndef TclpFree #define TclpFree \ (tclIntStubsPtr->tclpFree) /* 74 */ --- 1133,1143 ---- #ifndef TclpAlloc #define TclpAlloc \ (tclIntStubsPtr->tclpAlloc) /* 69 */ #endif + /* Slot 70 is reserved */ + /* Slot 71 is reserved */ + /* Slot 72 is reserved */ + /* Slot 73 is reserved */ #ifndef TclpFree #define TclpFree \ (tclIntStubsPtr->tclpFree) /* 74 */ *************** *** 1072,1085 **** #define TclpRealloc \ (tclIntStubsPtr->tclpRealloc) /* 81 */ #endif ! #ifndef TclpRemoveDirectory ! #define TclpRemoveDirectory \ ! (tclIntStubsPtr->tclpRemoveDirectory) /* 82 */ ! #endif ! #ifndef TclpRenameFile ! #define TclpRenameFile \ ! (tclIntStubsPtr->tclpRenameFile) /* 83 */ ! #endif /* Slot 84 is reserved */ /* Slot 85 is reserved */ /* Slot 86 is reserved */ --- 1170,1177 ---- #define TclpRealloc \ (tclIntStubsPtr->tclpRealloc) /* 81 */ #endif ! /* Slot 82 is reserved */ ! /* Slot 83 is reserved */ /* Slot 84 is reserved */ /* Slot 85 is reserved */ /* Slot 86 is reserved */ *************** *** 1287,1296 **** (tclIntStubsPtr->tclpCheckStackSpace) /* 135 */ #endif /* Slot 136 is reserved */ ! #ifndef TclpChdir ! #define TclpChdir \ ! (tclIntStubsPtr->tclpChdir) /* 137 */ ! #endif #ifndef TclGetEnv #define TclGetEnv \ (tclIntStubsPtr->tclGetEnv) /* 138 */ --- 1379,1385 ---- (tclIntStubsPtr->tclpCheckStackSpace) /* 135 */ #endif /* Slot 136 is reserved */ ! /* Slot 137 is reserved */ #ifndef TclGetEnv #define TclGetEnv \ (tclIntStubsPtr->tclGetEnv) /* 138 */ *************** *** 1303,1312 **** #define TclLooksLikeInt \ (tclIntStubsPtr->tclLooksLikeInt) /* 140 */ #endif ! #ifndef TclpGetCwd ! #define TclpGetCwd \ ! (tclIntStubsPtr->tclpGetCwd) /* 141 */ ! #endif #ifndef TclSetByteCodeFromAny #define TclSetByteCodeFromAny \ (tclIntStubsPtr->tclSetByteCodeFromAny) /* 142 */ --- 1392,1398 ---- #define TclLooksLikeInt \ (tclIntStubsPtr->tclLooksLikeInt) /* 140 */ #endif ! /* Slot 141 is reserved */ #ifndef TclSetByteCodeFromAny #define TclSetByteCodeFromAny \ (tclIntStubsPtr->tclSetByteCodeFromAny) /* 142 */ *************** *** 1372,1382 **** #ifndef TclGetStartupScriptFileName #define TclGetStartupScriptFileName \ (tclIntStubsPtr->tclGetStartupScriptFileName) /* 159 */ - #endif - #ifndef TclpMatchFilesTypes - #define TclpMatchFilesTypes \ - (tclIntStubsPtr->tclpMatchFilesTypes) /* 160 */ #endif #ifndef TclChannelTransform #define TclChannelTransform \ (tclIntStubsPtr->tclChannelTransform) /* 161 */ --- 1458,1465 ---- #ifndef TclGetStartupScriptFileName #define TclGetStartupScriptFileName \ (tclIntStubsPtr->tclGetStartupScriptFileName) /* 159 */ #endif + /* Slot 160 is reserved */ #ifndef TclChannelTransform #define TclChannelTransform \ (tclIntStubsPtr->tclChannelTransform) /* 161 */ *************** *** 1384,1389 **** --- 1467,1628 ---- #ifndef TclChannelEventScriptInvoker #define TclChannelEventScriptInvoker \ (tclIntStubsPtr->tclChannelEventScriptInvoker) /* 162 */ + #endif + #ifndef TclpVerifyInitialEncodings + #define TclpVerifyInitialEncodings \ + (tclIntStubsPtr->tclpVerifyInitialEncodings) /* 163 */ + #endif + #ifndef Tcl_FSCopyFile + #define Tcl_FSCopyFile \ + (tclIntStubsPtr->tcl_FSCopyFile) /* 164 */ + #endif + #ifndef Tcl_FSCopyDirectory + #define Tcl_FSCopyDirectory \ + (tclIntStubsPtr->tcl_FSCopyDirectory) /* 165 */ + #endif + #ifndef Tcl_FSCreateDirectory + #define Tcl_FSCreateDirectory \ + (tclIntStubsPtr->tcl_FSCreateDirectory) /* 166 */ + #endif + #ifndef Tcl_FSDeleteFile + #define Tcl_FSDeleteFile \ + (tclIntStubsPtr->tcl_FSDeleteFile) /* 167 */ + #endif + #ifndef Tcl_FSListVolumes + #define Tcl_FSListVolumes \ + (tclIntStubsPtr->tcl_FSListVolumes) /* 168 */ + #endif + #ifndef Tcl_FSLoadFile + #define Tcl_FSLoadFile \ + (tclIntStubsPtr->tcl_FSLoadFile) /* 169 */ + #endif + #ifndef Tcl_FSMatchInDirectory + #define Tcl_FSMatchInDirectory \ + (tclIntStubsPtr->tcl_FSMatchInDirectory) /* 170 */ + #endif + #ifndef Tcl_FSReadlink + #define Tcl_FSReadlink \ + (tclIntStubsPtr->tcl_FSReadlink) /* 171 */ + #endif + #ifndef Tcl_FSRemoveDirectory + #define Tcl_FSRemoveDirectory \ + (tclIntStubsPtr->tcl_FSRemoveDirectory) /* 172 */ + #endif + #ifndef Tcl_FSRenameFile + #define Tcl_FSRenameFile \ + (tclIntStubsPtr->tcl_FSRenameFile) /* 173 */ + #endif + #ifndef Tcl_FSLstat + #define Tcl_FSLstat \ + (tclIntStubsPtr->tcl_FSLstat) /* 174 */ + #endif + #ifndef Tcl_FSUtime + #define Tcl_FSUtime \ + (tclIntStubsPtr->tcl_FSUtime) /* 175 */ + #endif + #ifndef Tcl_FSFileAttrsGet + #define Tcl_FSFileAttrsGet \ + (tclIntStubsPtr->tcl_FSFileAttrsGet) /* 176 */ + #endif + #ifndef Tcl_FSFileAttrsSet + #define Tcl_FSFileAttrsSet \ + (tclIntStubsPtr->tcl_FSFileAttrsSet) /* 177 */ + #endif + #ifndef Tcl_FSFileAttrStrings + #define Tcl_FSFileAttrStrings \ + (tclIntStubsPtr->tcl_FSFileAttrStrings) /* 178 */ + #endif + #ifndef Tcl_FSStat + #define Tcl_FSStat \ + (tclIntStubsPtr->tcl_FSStat) /* 179 */ + #endif + #ifndef Tcl_FSAccess + #define Tcl_FSAccess \ + (tclIntStubsPtr->tcl_FSAccess) /* 180 */ + #endif + #ifndef Tcl_FSOpenFileChannel + #define Tcl_FSOpenFileChannel \ + (tclIntStubsPtr->tcl_FSOpenFileChannel) /* 181 */ + #endif + #ifndef Tcl_FSGetCwd + #define Tcl_FSGetCwd \ + (tclIntStubsPtr->tcl_FSGetCwd) /* 182 */ + #endif + #ifndef Tcl_FSChdir + #define Tcl_FSChdir \ + (tclIntStubsPtr->tcl_FSChdir) /* 183 */ + #endif + #ifndef Tcl_FSConvertToPathType + #define Tcl_FSConvertToPathType \ + (tclIntStubsPtr->tcl_FSConvertToPathType) /* 184 */ + #endif + #ifndef TclFileCopyCmd + #define TclFileCopyCmd \ + (tclIntStubsPtr->tclFileCopyCmd) /* 185 */ + #endif + #ifndef TclFileRenameCmd + #define TclFileRenameCmd \ + (tclIntStubsPtr->tclFileRenameCmd) /* 186 */ + #endif + #ifndef Tcl_FSJoinPath + #define Tcl_FSJoinPath \ + (tclIntStubsPtr->tcl_FSJoinPath) /* 187 */ + #endif + #ifndef TclFileDeleteCmd + #define TclFileDeleteCmd \ + (tclIntStubsPtr->tclFileDeleteCmd) /* 188 */ + #endif + #ifndef TclFileMakeDirsCmd + #define TclFileMakeDirsCmd \ + (tclIntStubsPtr->tclFileMakeDirsCmd) /* 189 */ + #endif + #ifndef TclFileAttrsCmd + #define TclFileAttrsCmd \ + (tclIntStubsPtr->tclFileAttrsCmd) /* 190 */ + #endif + #ifndef Tcl_FSSplitPath + #define Tcl_FSSplitPath \ + (tclIntStubsPtr->tcl_FSSplitPath) /* 191 */ + #endif + #ifndef Tcl_FSEqualPaths + #define Tcl_FSEqualPaths \ + (tclIntStubsPtr->tcl_FSEqualPaths) /* 192 */ + #endif + #ifndef Tcl_FSGetNormalizedPath + #define Tcl_FSGetNormalizedPath \ + (tclIntStubsPtr->tcl_FSGetNormalizedPath) /* 193 */ + #endif + #ifndef Tcl_FSJoinToPath + #define Tcl_FSJoinToPath \ + (tclIntStubsPtr->tcl_FSJoinToPath) /* 194 */ + #endif + #ifndef Tcl_FSGetInternalRep + #define Tcl_FSGetInternalRep \ + (tclIntStubsPtr->tcl_FSGetInternalRep) /* 195 */ + #endif + #ifndef Tcl_FSGetTranslatedPath + #define Tcl_FSGetTranslatedPath \ + (tclIntStubsPtr->tcl_FSGetTranslatedPath) /* 196 */ + #endif + #ifndef Tcl_FSEvalFile + #define Tcl_FSEvalFile \ + (tclIntStubsPtr->tcl_FSEvalFile) /* 197 */ + #endif + #ifndef Tcl_FSNewNativePath + #define Tcl_FSNewNativePath \ + (tclIntStubsPtr->tcl_FSNewNativePath) /* 198 */ + #endif + #ifndef Tcl_FSGetNativePath + #define Tcl_FSGetNativePath \ + (tclIntStubsPtr->tcl_FSGetNativePath) /* 199 */ + #endif + #ifndef Tcl_FSFileSystemInfo + #define Tcl_FSFileSystemInfo \ + (tclIntStubsPtr->tcl_FSFileSystemInfo) /* 200 */ + #endif + #ifndef Tcl_FSPathSeparator + #define Tcl_FSPathSeparator \ + (tclIntStubsPtr->tcl_FSPathSeparator) /* 201 */ #endif #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */ Index: generic/tclLoad.c =================================================================== RCS file: /cvsroot/tcl/tcl/generic/tclLoad.c,v retrieving revision 1.4 diff -c -r1.4 tclLoad.c *** generic/tclLoad.c 1999/12/01 00:08:28 1.4 --- generic/tclLoad.c 2001/03/16 17:08:11 *************** *** 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. */ + TclfsUnloadFileProc_ *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 *************** *** 113,124 **** { Tcl_Interp *target; LoadedPackage *pkgPtr, *defaultPtr; ! Tcl_DString pkgName, tmp, initName, safeInitName, fileName; Tcl_PackageInitProc *initProc, *safeInitProc; InterpPackage *ipFirstPtr, *ipPtr; int code, namesMatch, filesMatch; ! char *p, *tempString, *fullFileName, *packageName; ClientData clientData; Tcl_UniChar ch; int offset; --- 119,131 ---- { Tcl_Interp *target; LoadedPackage *pkgPtr, *defaultPtr; ! Tcl_DString pkgName, tmp, initName, safeInitName; Tcl_PackageInitProc *initProc, *safeInitProc; InterpPackage *ipFirstPtr, *ipPtr; int code, namesMatch, filesMatch; ! char *p, *fullFileName, *packageName; ClientData clientData; + TclfsUnloadFileProc_ *unLoadProcPtr = NULL; Tcl_UniChar ch; int offset; *************** *** 126,136 **** Tcl_WrongNumArgs(interp, 1, objv, "fileName ?packageName? ?interp?"); return TCL_ERROR; } ! tempString = Tcl_GetString(objv[1]); ! fullFileName = Tcl_TranslateFileName(interp, tempString, &fileName); ! if (fullFileName == NULL) { return TCL_ERROR; } Tcl_DStringInit(&pkgName); Tcl_DStringInit(&initName); Tcl_DStringInit(&safeInitName); --- 133,143 ---- Tcl_WrongNumArgs(interp, 1, objv, "fileName ?packageName? ?interp?"); return TCL_ERROR; } ! if (Tcl_FSConvertToPathType(interp, objv[1]) != TCL_OK) { return TCL_ERROR; } + fullFileName = Tcl_GetString(objv[1]); + Tcl_DStringInit(&pkgName); Tcl_DStringInit(&initName); Tcl_DStringInit(&safeInitName); *************** *** 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 = Tcl_FSLoadFile(interp, objv[1], 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); *************** *** 410,416 **** Tcl_DStringFree(&pkgName); Tcl_DStringFree(&initName); Tcl_DStringFree(&safeInitName); - Tcl_DStringFree(&fileName); Tcl_DStringFree(&tmp); return code; } --- 420,425 ---- *************** *** 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); --- 662,671 ---- * call a function in the dll after it's been unloaded. */ if (pkgPtr->fileName[0] != '\0') { ! TclfsUnloadFileProc_ *unLoadProcPtr = pkgPtr->unLoadProcPtr; ! if (unLoadProcPtr != NULL) { ! (*unLoadProcPtr)(pkgPtr->clientData); ! } } #endif ckfree(pkgPtr->fileName); Index: generic/tclLoadNone.c =================================================================== RCS file: /cvsroot/tcl/tcl/generic/tclLoadNone.c,v retrieving revision 1.4 diff -c -r1.4 tclLoadNone.c *** generic/tclLoadNone.c 1999/05/07 20:07:40 1.4 --- generic/tclLoadNone.c 2001/03/16 17:08:11 *************** *** 109,112 **** --- 109,113 ---- * a token that represents the loaded * file. */ { + return TCL_OK; } Index: generic/tclStubInit.c =================================================================== RCS file: /cvsroot/tcl/tcl/generic/tclStubInit.c,v retrieving revision 1.46 diff -c -r1.46 tclStubInit.c *** generic/tclStubInit.c 2000/11/03 18:46:12 1.46 --- generic/tclStubInit.c 2001/03/16 17:08:11 *************** *** 80,90 **** TclDumpMemoryInfo, /* 14 */ NULL, /* 15 */ TclExprFloatError, /* 16 */ ! TclFileAttrsCmd, /* 17 */ ! TclFileCopyCmd, /* 18 */ ! TclFileDeleteCmd, /* 19 */ ! TclFileMakeDirsCmd, /* 20 */ ! TclFileRenameCmd, /* 21 */ TclFindElement, /* 22 */ TclFindProc, /* 23 */ TclFormatInt, /* 24 */ --- 80,90 ---- TclDumpMemoryInfo, /* 14 */ NULL, /* 15 */ TclExprFloatError, /* 16 */ ! NULL, /* 17 */ ! NULL, /* 18 */ ! NULL, /* 19 */ ! NULL, /* 20 */ ! NULL, /* 21 */ TclFindElement, /* 22 */ TclFindProc, /* 23 */ TclFormatInt, /* 24 */ *************** *** 122,128 **** NULL, /* 56 */ NULL, /* 57 */ TclLookupVar, /* 58 */ ! TclpMatchFiles, /* 59 */ TclNeedSpace, /* 60 */ TclNewProcBodyObj, /* 61 */ TclObjCommandComplete, /* 62 */ --- 122,128 ---- NULL, /* 56 */ NULL, /* 57 */ TclLookupVar, /* 58 */ ! NULL, /* 59 */ TclNeedSpace, /* 60 */ TclNewProcBodyObj, /* 61 */ TclObjCommandComplete, /* 62 */ *************** *** 133,142 **** TclOpenFileChannelInsertProc, /* 67 */ TclpAccess, /* 68 */ TclpAlloc, /* 69 */ ! TclpCopyFile, /* 70 */ ! TclpCopyDirectory, /* 71 */ ! TclpCreateDirectory, /* 72 */ ! TclpDeleteFile, /* 73 */ TclpFree, /* 74 */ TclpGetClicks, /* 75 */ TclpGetSeconds, /* 76 */ --- 133,142 ---- TclOpenFileChannelInsertProc, /* 67 */ TclpAccess, /* 68 */ TclpAlloc, /* 69 */ ! NULL, /* 70 */ ! NULL, /* 71 */ ! NULL, /* 72 */ ! NULL, /* 73 */ TclpFree, /* 74 */ TclpGetClicks, /* 75 */ TclpGetSeconds, /* 76 */ *************** *** 145,152 **** TclpListVolumes, /* 79 */ TclpOpenFileChannel, /* 80 */ TclpRealloc, /* 81 */ ! TclpRemoveDirectory, /* 82 */ ! TclpRenameFile, /* 83 */ NULL, /* 84 */ NULL, /* 85 */ NULL, /* 86 */ --- 145,152 ---- TclpListVolumes, /* 79 */ TclpOpenFileChannel, /* 80 */ TclpRealloc, /* 81 */ ! NULL, /* 82 */ ! NULL, /* 83 */ NULL, /* 84 */ NULL, /* 85 */ NULL, /* 86 */ *************** *** 216,226 **** TclpStrftime, /* 134 */ TclpCheckStackSpace, /* 135 */ NULL, /* 136 */ ! TclpChdir, /* 137 */ TclGetEnv, /* 138 */ TclpLoadFile, /* 139 */ TclLooksLikeInt, /* 140 */ ! TclpGetCwd, /* 141 */ TclSetByteCodeFromAny, /* 142 */ TclAddLiteralObj, /* 143 */ TclHideLiteral, /* 144 */ --- 216,226 ---- TclpStrftime, /* 134 */ TclpCheckStackSpace, /* 135 */ NULL, /* 136 */ ! NULL, /* 137 */ TclGetEnv, /* 138 */ TclpLoadFile, /* 139 */ TclLooksLikeInt, /* 140 */ ! NULL, /* 141 */ TclSetByteCodeFromAny, /* 142 */ TclAddLiteralObj, /* 143 */ TclHideLiteral, /* 144 */ *************** *** 239,247 **** TclVarTraceExists, /* 157 */ TclSetStartupScriptFileName, /* 158 */ TclGetStartupScriptFileName, /* 159 */ ! TclpMatchFilesTypes, /* 160 */ TclChannelTransform, /* 161 */ TclChannelEventScriptInvoker, /* 162 */ }; TclIntPlatStubs tclIntPlatStubs = { --- 239,286 ---- TclVarTraceExists, /* 157 */ TclSetStartupScriptFileName, /* 158 */ TclGetStartupScriptFileName, /* 159 */ ! NULL, /* 160 */ TclChannelTransform, /* 161 */ TclChannelEventScriptInvoker, /* 162 */ + TclpVerifyInitialEncodings, /* 163 */ + Tcl_FSCopyFile, /* 164 */ + Tcl_FSCopyDirectory, /* 165 */ + Tcl_FSCreateDirectory, /* 166 */ + Tcl_FSDeleteFile, /* 167 */ + Tcl_FSListVolumes, /* 168 */ + Tcl_FSLoadFile, /* 169 */ + Tcl_FSMatchInDirectory, /* 170 */ + Tcl_FSReadlink, /* 171 */ + Tcl_FSRemoveDirectory, /* 172 */ + Tcl_FSRenameFile, /* 173 */ + Tcl_FSLstat, /* 174 */ + Tcl_FSUtime, /* 175 */ + Tcl_FSFileAttrsGet, /* 176 */ + Tcl_FSFileAttrsSet, /* 177 */ + Tcl_FSFileAttrStrings, /* 178 */ + Tcl_FSStat, /* 179 */ + Tcl_FSAccess, /* 180 */ + Tcl_FSOpenFileChannel, /* 181 */ + Tcl_FSGetCwd, /* 182 */ + Tcl_FSChdir, /* 183 */ + Tcl_FSConvertToPathType, /* 184 */ + TclFileCopyCmd, /* 185 */ + TclFileRenameCmd, /* 186 */ + Tcl_FSJoinPath, /* 187 */ + TclFileDeleteCmd, /* 188 */ + TclFileMakeDirsCmd, /* 189 */ + TclFileAttrsCmd, /* 190 */ + Tcl_FSSplitPath, /* 191 */ + Tcl_FSEqualPaths, /* 192 */ + Tcl_FSGetNormalizedPath, /* 193 */ + Tcl_FSJoinToPath, /* 194 */ + Tcl_FSGetInternalRep, /* 195 */ + Tcl_FSGetTranslatedPath, /* 196 */ + Tcl_FSEvalFile, /* 197 */ + Tcl_FSNewNativePath, /* 198 */ + Tcl_FSGetNativePath, /* 199 */ + Tcl_FSFileSystemInfo, /* 200 */ + Tcl_FSPathSeparator, /* 201 */ }; TclIntPlatStubs tclIntPlatStubs = { *************** *** 836,841 **** --- 875,882 ---- Tcl_AttemptRealloc, /* 430 */ Tcl_AttemptDbCkrealloc, /* 431 */ Tcl_AttemptSetObjLength, /* 432 */ + Tcl_DetachChannel, /* 433 */ + Tcl_IsStandardChannel, /* 434 */ }; /* !END!: Do not edit above this line. */ Index: generic/tclTest.c =================================================================== RCS file: /cvsroot/tcl/tcl/generic/tclTest.c,v retrieving revision 1.22 diff -c -r1.22 tclTest.c *** generic/tclTest.c 2000/11/24 11:27:37 1.22 --- generic/tclTest.c 2001/03/16 17:08:11 *************** *** 299,305 **** --- 299,369 ---- 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 TclfsStatProc_ TestReportStat; + static TclfsAccessProc_ TestReportAccess; + static TclfsOpenFileChannelProc_ TestReportOpenFileChannel; + static TclfsMatchInDirectoryProc_ TestReportMatchInDirectory; + static TclfsGetCwdProc_ TestReportGetCwd; + static TclfsChdirProc_ TestReportChdir; + static TclfsLstatProc_ TestReportLstat; + static TclfsCopyFileProc_ TestReportCopyFile; + static TclfsDeleteFileProc_ TestReportDeleteFile; + static TclfsRenameFileProc_ TestReportRenameFile; + static TclfsCreateDirectoryProc_ TestReportCreateDirectory; + static TclfsCopyDirectoryProc_ TestReportCopyDirectory; + static TclfsRemoveDirectoryProc_ TestReportRemoveDirectory; + static TclfsLoadFileProc_ TestReportLoadFile; + static TclfsUnloadFileProc_ TestReportUnloadFile; + static TclfsReadlinkProc_ TestReportReadlink; + static TclfsListVolumesProc_ TestReportListVolumes; + static TclfsFileAttrStringsProc_ TestReportFileAttrStrings; + static TclfsFileAttrsGetProc_ TestReportFileAttrsGet; + static TclfsFileAttrsSetProc_ TestReportFileAttrsSet; + static TclfsUtimeProc_ TestReportUtime; + static TclfsNormalizePathProc_ TestReportNormalizePath; + + static Tcl_Filesystem testReportingFilesystem = { + "reporting", + sizeof(Tcl_Filesystem), + TCL_FILESYSTEM_VERSION_1, + NULL, + NULL, + NULL, + NULL, + NULL, + NULL, + NULL, + &TestReportStat, + &TestReportAccess, + &TestReportOpenFileChannel, + &TestReportMatchInDirectory, + &TestReportGetCwd, + &TestReportChdir, + &TestReportLstat, + &TestReportCopyFile, + &TestReportDeleteFile, + &TestReportRenameFile, + &TestReportCreateDirectory, + &TestReportCopyDirectory, + &TestReportRemoveDirectory, + &TestReportLoadFile, + &TestReportUnloadFile, + &TestReportReadlink, + &TestReportListVolumes, + &TestReportFileAttrStrings, + &TestReportFileAttrsGet, + &TestReportFileAttrsSet, + &TestReportUtime, + &TestReportNormalizePath + }; + + /* * External (platform specific) initialization routine, these declarations * explicitly don't use EXTERN since this code does not get compiled *************** *** 350,355 **** --- 414,421 ---- (Tcl_CmdDeleteProc *) NULL); Tcl_CreateObjCommand(interp, "testwrongnumargs", TestWrongNumArgsObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateObjCommand(interp, "testfilesystem", TestFilesystemObjCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateObjCommand(interp, "testgetindexfromobjstruct", TestGetIndexFromObjStructObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); *************** *** 4497,4502 **** --- 4563,4579 ---- return TCL_OK; } + if ((cmdName[0] == 'i') && (strncmp(cmdName, "isstandard", len) == 0)) { + if (argc != 3) { + Tcl_AppendResult(interp, "channel name required", (char *) NULL); + return TCL_ERROR; + } + + TclFormatInt(buf, Tcl_IsStandardChannel(chan)); + Tcl_AppendResult(interp, buf, (char *) NULL); + return TCL_OK; + } + if ((cmdName[0] == 'm') && (strncmp(cmdName, "mode", len) == 0)) { if (argc != 3) { Tcl_AppendResult(interp, "channel name required", *************** *** 5002,5005 **** --- 5079,5373 ---- } Tcl_WrongNumArgs(interp, 3, objv, NULL); 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, Tcl_Obj* arg1, Tcl_Obj* arg2) { + Tcl_Interp* interp = (Tcl_Interp*) TclFilesystemData(&testReportingFilesystem); + if (interp == NULL) { + /* This is bad, but not much we can do about it */ + } else { + Tcl_SavedResult savedResult; + Tcl_DString ds; + Tcl_DStringInit(&ds); + Tcl_DStringAppend(&ds, "puts stderr ",-1); + Tcl_DStringStartSublist(&ds); + Tcl_DStringAppendElement(&ds, cmd); + if (arg1 != NULL) { + Tcl_DStringAppendElement(&ds, Tcl_GetString(arg1)); + } + if (arg2 != NULL) { + Tcl_DStringAppendElement(&ds, Tcl_GetString(arg2)); + } + Tcl_DStringEndSublist(&ds); + Tcl_SaveResult(interp, &savedResult); + Tcl_Eval(interp, Tcl_DStringValue(&ds)); + Tcl_DStringFree(&ds); + Tcl_RestoreResult(interp, &savedResult); + } + } + int + TestReportStat(path, buf) + Tcl_Obj *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) + Tcl_Obj *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) + Tcl_Obj *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. */ + Tcl_Obj *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, NULL); + return NULL; + } + + int + TestReportMatchInDirectory( + Tcl_Interp *interp, /* Interpreter to receive results. */ + Tcl_Obj *resultPtr, /* Directory separators to pass to TclDoGlob. */ + Tcl_Obj *dirPtr, /* Contains path to directory to search. */ + char *pattern, /* Pattern to match against. */ + int patLen, /* 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("matchindirectory",dirPtr, NULL); + return -1; + } + Tcl_Obj * + TestReportGetCwd(interp) + Tcl_Interp *interp; + { + TestReport("cwd",NULL,NULL); + return NULL; + } + int + TestReportChdir(dirName) + Tcl_Obj *dirName; + { + TestReport("chdir",dirName,NULL); + return -1; + } + int + TestReportLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr, clientDataPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + Tcl_Obj *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); + } + Tcl_Obj * + TestReportReadlink(path) + Tcl_Obj *path; /* Path of file to readlink (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( + Tcl_Obj *src, /* Pathname of file or dir to be renamed + * (UTF-8). */ + Tcl_Obj *dst) /* New pathname of file or directory + * (UTF-8). */ + { + TestReport("renamefile",src,dst); + return -1; + } + int + TestReportCopyFile( + Tcl_Obj *src, /* Pathname of file to be copied (UTF-8). */ + Tcl_Obj *dst) /* Pathname of file to copy to (UTF-8). */ + { + TestReport("copyfile",src,dst); + return -1; + } + int + TestReportDeleteFile( + Tcl_Obj *path) /* Pathname of file to be removed (UTF-8). */ + { + TestReport("deletefile",path,NULL); + return -1; + } + int + TestReportCreateDirectory( + Tcl_Obj *path) /* Pathname of directory to create (UTF-8). */ + { + TestReport("createdirectory",path,NULL); + return -1; + } + int + TestReportCopyDirectory( + Tcl_Obj *src, /* Pathname of directory to be copied + * (UTF-8). */ + Tcl_Obj *dst, /* Pathname of target directory (UTF-8). */ + Tcl_Obj **errorPtr) /* If non-NULL, uninitialized or free + * DString filled with UTF-8 name of file + * causing error. */ + { + TestReport("copydirectory",src,dst); + return -1; + } + int + TestReportRemoveDirectory( + Tcl_Obj *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_Obj **errorPtr) /* If non-NULL, uninitialized or free + * DString filled with UTF-8 name of file + * causing error. */ + { + TestReport("removedirectory",path,NULL); + return -1; + } + char** + TestReportFileAttrStrings(fileName, objPtrRef) + Tcl_Obj* fileName; + Tcl_Obj** objPtrRef; + { + TestReport("fileattributestrings",fileName,NULL); + return NULL; + } + int + TestReportFileAttrsGet(interp, index, fileName, objPtrRef) + Tcl_Interp *interp; /* The interpreter for error reporting. */ + int index; /* index of the attribute command. */ + Tcl_Obj *fileName; /* filename we are operating on. */ + Tcl_Obj **objPtrRef; /* for output. */ + { + TestReport("fileattributesget",fileName,NULL); + return -1; + } + int + TestReportFileAttrsSet(interp, index, fileName, objPtr) + Tcl_Interp *interp; /* The interpreter for error reporting. */ + int index; /* index of the attribute command. */ + Tcl_Obj *fileName; /* filename we are operating on. */ + Tcl_Obj *objPtr; /* for input. */ + { + TestReport("fileattributesset",fileName,objPtr); + return -1; + } + int + TestReportUtime (fileName, tval) + Tcl_Obj* fileName; + struct utimbuf *tval; + { + TestReport("utime",fileName,NULL); + return -1; + } + int + TestReportNormalizePath(interp, pathPtr, nextCheckpoint) + Tcl_Interp *interp; + Tcl_Obj *pathPtr; + int nextCheckpoint; + { + TestReport("normalizepath",pathPtr,NULL); + return nextCheckpoint; } Index: generic/tclUtil.c =================================================================== RCS file: /cvsroot/tcl/tcl/generic/tclUtil.c,v retrieving revision 1.18 diff -c -r1.18 tclUtil.c *** generic/tclUtil.c 2000/05/08 21:59:59 1.18 --- generic/tclUtil.c 2001/03/16 17:08:12 *************** *** 2272,2374 **** { return (tclExecutableName); } - - /* - *---------------------------------------------------------------------- - * - * 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(). - * - * Results: - * See access() documentation. - * - * Side effects: - * See access() documentation. - * - *---------------------------------------------------------------------- - */ - - int - Tcl_Access(path, mode) - CONST char *path; /* Path of file to access (UTF-8). */ - int mode; /* Permission setting. */ - { - return TclAccess(path, mode); - } - - /* - *---------------------------------------------------------------------- - * - * Tcl_Stat -- - * - * This function replaces the library version of stat(). - * - * Results: - * See stat() documentation. - * - * Side effects: - * See stat() documentation. - * - *---------------------------------------------------------------------- - */ - - int - Tcl_Stat(path, bufPtr) - CONST char *path; /* Path of file to stat (in UTF-8). */ - struct stat *bufPtr; /* Filled with results of stat call. */ - { - return TclStat(path, bufPtr); - } --- 2272,2274 ---- Index: library/init.tcl =================================================================== RCS file: /cvsroot/tcl/tcl/library/init.tcl,v retrieving revision 1.44 diff -c -r1.44 init.tcl *** library/init.tcl 2000/12/11 04:17:38 1.44 --- library/init.tcl 2001/03/16 17:08:14 *************** *** 591,593 **** --- 591,664 ---- } } + + namespace eval tcl {} + + # ::tcl::copyDirectory -- + # + # This procedure is called by Tcl's core when attempts to call the + # filesystem's copydirectory function fail. The semantics of the call + # are that 'dest' does not yet exist, i.e. dest should become the exact + # image of src. If dest does exist, we throw an error. + # + # Note that making changes to this procedure can change the results + # of running Tcl's tests. + # + # Arguments: + # action - "renaming" or "copying" + # src - source directory + # dest - destination directory + proc ::tcl::copyDirectory {action src dest} { + set nsrc [file normalize $src] + set ndest [file normalize $dest] + if {[string equal $action "renaming"]} { + # Can't rename volumes + if {[lsearch -exact [file volumes] $nsrc] != -1} { + return -code error "error $action \"$src\" to\ + \"$dest\": trying to rename a volume or move a directory\ + into itself" + } + } + if {[file exists $dest]} { + if {$nsrc == $ndest} { + return -code error "error $action \"$src\" to\ + \"$dest\": trying to rename a volume or move a directory\ + into itself" + } + if {[string equal $action "copying"]} { + return -code error "error $action \"$src\" to\ + \"$dest\": file already exists" + } else { + # The '2' is for '.' and '..' + if {[llength [glob -nocomplain -directory $dest * .*]] > 2} { + return -code error "error $action \"$src\" to\ + \"$dest\": file already exists" + } + } + } else { + if {[string first $nsrc $ndest] != -1} { + set srclen [expr {[llength [file split $nsrc]] -1}] + set ndest [lindex [file split $ndest] $srclen] + if {$ndest == [file tail $nsrc]} { + return -code error "error $action \"$src\" to\ + \"$dest\": trying to rename a volume or move a directory\ + into itself" + } + } + file mkdir $dest + } + # Have to be careful to capture both visible and hidden files + foreach s [glob -nocomplain -directory $src *] { + if {([file tail $s] != ".") && ([file tail $s] != "..")} { + file copy $s [file join $dest [file tail $s]] + } + } + # This will pick up things beginning with '.' on Unix and on + # Windows/MacOS those files which the OS considers invisible. + foreach s [glob -nocomplain -directory $src -types hidden *] { + if {([file tail $s] != ".") && ([file tail $s] != "..")} { + file copy $s [file join $dest [file tail $s]] + } + } + return + } Index: mac/tclMacFCmd.c =================================================================== RCS file: /cvsroot/tcl/tcl/mac/tclMacFCmd.c,v retrieving revision 1.7 diff -c -r1.7 tclMacFCmd.c *** mac/tclMacFCmd.c 1999/10/15 04:47:03 1.7 --- mac/tclMacFCmd.c 2001/03/16 17:08:14 *************** *** 97,102 **** --- 97,155 ---- static int Pstrequal _ANSI_ARGS_((ConstStr255Param stringA, ConstStr255Param stringB)); + int + TclpObjCreateDirectory(Tcl_Obj *pathPtr) { + return TclpCreateDirectory(Tcl_FSGetTranslatedPath(NULL, pathPtr)); + } + + int + TclpObjDeleteFile(Tcl_Obj *pathPtr) { + return TclpDeleteFile(Tcl_FSGetTranslatedPath(NULL, pathPtr)); + } + + int + TclpObjCopyDirectory(Tcl_Obj *srcPathPtr, + Tcl_Obj *destPathPtr, Tcl_Obj **errorPtr) { + Tcl_DString ds; + int ret; + ret = TclpCopyDirectory(Tcl_FSGetTranslatedPath(NULL,srcPathPtr), + Tcl_FSGetTranslatedPath(NULL,destPathPtr), &ds); + if (ret != TCL_OK) { + *errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1); + Tcl_DStringFree(&ds); + Tcl_IncrRefCount(*errorPtr); + } + return ret; + } + + int + TclpObjCopyFile(Tcl_Obj *srcPathPtr, + Tcl_Obj *destPathPtr) { + return TclpCopyFile(Tcl_FSGetTranslatedPath(NULL,srcPathPtr), + Tcl_FSGetTranslatedPath(NULL,destPathPtr)); + } + + int + TclpObjRemoveDirectory(Tcl_Obj *pathPtr, + int recursive, Tcl_Obj **errorPtr) { + Tcl_DString ds; + int ret; + ret = TclpRemoveDirectory(Tcl_FSGetTranslatedPath(NULL, pathPtr),recursive, &ds); + if (ret != TCL_OK) { + *errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1); + Tcl_DStringFree(&ds); + Tcl_IncrRefCount(*errorPtr); + } + return ret; + } + + int + TclpObjRenameFile(Tcl_Obj *srcPathPtr, + Tcl_Obj *destPathPtr) { + return TclpRenameFile(Tcl_FSGetTranslatedPath(NULL,srcPathPtr), + Tcl_FSGetTranslatedPath(NULL,destPathPtr)); + } + /* *--------------------------------------------------------------------------- * *************** *** 1547,1551 **** --- 1600,1655 ---- Tcl_SetObjResult(interp, resultPtr); return TCL_OK; + } + + /* + *--------------------------------------------------------------------------- + * + * TclpObjNormalizePath -- + * + * This function scans through a path specification and replaces + * it, in place, with a normalized version. On MacOS, this simply + * ascertains where the valid path ends, and makes no change in + * place. It should convert the current path to a normalized, + * case-sensitive path. + * + * Results: + * The new 'nextCheckpoint' value, giving as far as we could + * understand in the path. + * + * Side effects: + * The pathPtr string, which must contain a valid path, is + * not modified, but should be. See the Windows implementation + * for more detail. + * + *--------------------------------------------------------------------------- + */ + + int + TclpObjNormalizePath(interp, pathPtr, nextCheckpoint) + Tcl_Interp *interp; + Tcl_Obj *pathPtr; + int nextCheckpoint; + { + char *path = Tcl_GetString(pathPtr); + + while (1) { + char cur = path[nextCheckpoint]; + if (cur == 0) { + break; + } + if (cur == '/') { + int access; + path[nextCheckpoint] = 0; + access = TclpAccess(path, F_OK); + path[nextCheckpoint] = '/'; + if (access != 0) { + /* File doesn't exist */ + break; + } + } + nextCheckpoint++; + } + return nextCheckpoint; } Index: mac/tclMacFile.c =================================================================== RCS file: /cvsroot/tcl/tcl/mac/tclMacFile.c,v retrieving revision 1.9 diff -c -r1.9 tclMacFile.c *** mac/tclMacFile.c 1999/12/12 22:46:45 1.9 --- mac/tclMacFile.c 2001/03/16 17:08:14 *************** *** 38,43 **** --- 38,49 ---- static long gmt_offset; TCL_DECLARE_MUTEX(gmtMutex) + OSErr + FspLocationFromFsPath(Tcl_Obj *pathPtr, FSSpec* specPtr) { + char *native = Tcl_FSGetNativePath(pathPtr); + return FSpLocationFromPath(strlen(native), native, &dirSpec); + } + /* *---------------------------------------------------------------------- *************** *** 102,118 **** /* *---------------------------------------------------------------------- * ! * TclpMatchFilesTypes -- * * This routine is used by the globbing code to search a * directory for all files which match a given pattern. * * 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. --- 108,127 ---- /* *---------------------------------------------------------------------- * ! * TclpMatchInDirectory -- * * This routine is used by the globbing code to search a * directory for all files which match a given pattern. * * Results: ! * If dirOnly is set, we are simply to find matching directories ! * and ignore all other information -- this is used by TclDoGlob ! * to handle recursion, in which 'pattern' is just a piece of ! * the pattern. ! * ! * The return value is a standard Tcl result indicating whether an ! * error occurred in globbing. Errors are left in interp, good ! * results are lappended to resultPtr (which must be a valid object) * * Side effects: * None. *************** *** 120,140 **** *---------------------------------------------------------------------- */ int ! TclpMatchFilesTypes( ! 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. */ { ! char *fname, *patternEnd = tail; ! char savedChar; int fnameLen, result = TCL_OK; ! int baseLength = Tcl_DStringLength(dirPtr); CInfoPBRec pb; OSErr err; FSSpec dirSpec; --- 129,146 ---- *---------------------------------------------------------------------- */ int ! TclpMatchInDirectory(interp, resultPtr, pathPtr, pattern, dirOnly, types) ! Tcl_Interp *interp; /* Interpreter to receive errors. */ ! Tcl_Obj *resultPtr; /* List object to lappend results. */ ! Tcl_Obj *pathPtr; /* Contains path to directory to search. */ ! char *pattern; /* Pattern to match against. */ ! int dirOnly; /* 1 if we want dirs, and ignore types */ ! GlobTypeData *types; /* Object containing list of acceptable types. * May be NULL. */ { ! char *fname; int fnameLen, result = TCL_OK; ! int baseLength; CInfoPBRec pb; OSErr err; FSSpec dirSpec; *************** *** 143,168 **** short itemIndex; Str255 fileName; Tcl_DString fileString; - Tcl_Obj *resultPtr; OSType okType = 0; OSType okCreator = 0; /* * Make sure that the directory part of the name really is a * directory. */ ! Tcl_UtfToExternalDString(NULL, Tcl_DStringValue(dirPtr), ! Tcl_DStringLength(dirPtr), &fileString); FSpLocationFromPath(fileString.length, fileString.string, &dirSpec); Tcl_DStringFree(&fileString); err = FSpGetDirectoryID(&dirSpec, &dirID, &isDirectory); if ((err != noErr) || !isDirectory) { return TCL_OK; } /* * Now open the directory for reading and iterate over the contents. */ --- 149,190 ---- short itemIndex; Str255 fileName; Tcl_DString fileString; OSType okType = 0; OSType okCreator = 0; + Tcl_DString dsOrig; + char *fileName; + fileName = Tcl_FSGetTranslatedPath(interp, pathPtr); + if (fileName == NULL) { + return TCL_ERROR; + } + Tcl_DStringInit(&dsOrig); + Tcl_DStringAppend(&dsOrig, fileName, -1); + baseLength = Tcl_DStringLength(&dsOrig); + /* * Make sure that the directory part of the name really is a * directory. */ ! Tcl_UtfToExternalDString(NULL, Tcl_DStringValue(&dsOrig), ! Tcl_DStringLength(&dsOrig), &fileString); FSpLocationFromPath(fileString.length, fileString.string, &dirSpec); Tcl_DStringFree(&fileString); err = FSpGetDirectoryID(&dirSpec, &dirID, &isDirectory); if ((err != noErr) || !isDirectory) { + Tcl_DStringFree(&dsOrig); return TCL_OK; } + /* Make sure we have a trailing directory delimiter */ + if (Tcl_DStringValue(&dsOrig)[baseLength-1] != ':') { + Tcl_DStringAppend(&dsOrig, ":", 1); + baseLength++; + } + /* * Now open the directory for reading and iterate over the contents. */ *************** *** 171,202 **** pb.hFileInfo.ioDirID = dirID; pb.hFileInfo.ioNamePtr = (StringPtr) fileName; pb.hFileInfo.ioFDirIndex = itemIndex = 1; - - /* - * Clean up the end of the pattern and the tail pointer. Leave - * the tail pointing to the first character after the path separator - * following the pattern, or NULL. Also, ensure that the pattern - * is null-terminated. - */ ! if (*tail == '\\') { ! tail++; ! } ! if (*tail == '\0') { ! tail = NULL; ! } else { ! tail++; ! } ! savedChar = *patternEnd; ! *patternEnd = '\0'; ! ! resultPtr = Tcl_GetObjResult(interp); ! if (types != NULL) { ! if (types->macType != NULL) { ! Tcl_GetOSTypeFromObj(NULL, types->macType, &okType); ! } ! if (types->macCreator != NULL) { ! Tcl_GetOSTypeFromObj(NULL, types->macCreator, &okCreator); } } --- 193,207 ---- pb.hFileInfo.ioDirID = dirID; pb.hFileInfo.ioNamePtr = (StringPtr) fileName; pb.hFileInfo.ioFDirIndex = itemIndex = 1; ! if (!dirOnly) { ! if (types != NULL) { ! if (types->macType != NULL) { ! Tcl_GetOSTypeFromObj(NULL, types->macType, &okType); ! } ! if (types->macCreator != NULL) { ! Tcl_GetOSTypeFromObj(NULL, types->macCreator, &okCreator); ! } } } *************** *** 209,237 **** } /* ! * Now check to see if the file matches. If there are more ! * characters to be processed, then ensure matching files are ! * directories before calling TclDoGlob. Otherwise, just add ! * the file to the result. */ Tcl_ExternalToUtfDString(NULL, (char *) fileName + 1, fileName[0], &fileString); if (Tcl_StringMatch(Tcl_DStringValue(&fileString), pattern)) { ! Tcl_DStringSetLength(dirPtr, baseLength); ! Tcl_DStringAppend(dirPtr, Tcl_DStringValue(&fileString), -1); ! fname = Tcl_DStringValue(dirPtr); ! fnameLen = Tcl_DStringLength(dirPtr); ! if (tail == NULL) { int typeOk = 1; ! if (types != NULL) { ! if (types->perm != 0) { if ( ((types->perm & TCL_GLOB_PERM_RONLY) && !(pb.hFileInfo.ioFlAttrib & 1)) || - ((types->perm & TCL_GLOB_PERM_HIDDEN) && - !(pb.hFileInfo.ioFlFndrInfo.fdFlags & - kIsInvisible)) || ((types->perm & TCL_GLOB_PERM_R) && (TclpAccess(fname, R_OK) != 0)) || ((types->perm & TCL_GLOB_PERM_W) && --- 214,253 ---- } /* ! * Now check to see if the file matches. */ Tcl_ExternalToUtfDString(NULL, (char *) fileName + 1, fileName[0], &fileString); if (Tcl_StringMatch(Tcl_DStringValue(&fileString), pattern)) { ! Tcl_DStringSetLength(&dsOrig, baseLength); ! Tcl_DStringAppend(&dsOrig, Tcl_DStringValue(&fileString), -1); ! fname = Tcl_DStringValue(&dsOrig); ! fnameLen = Tcl_DStringLength(&dsOrig); ! if (!dirOnly) { int typeOk = 1; ! if (types == NULL) { ! /* If invisible, don't return the file */ ! if (pb.hFileInfo.ioFlFndrInfo.fdFlags & kIsInvisible) { ! typeOk = 0; ! } ! } else { ! if (pb.hFileInfo.ioFlFndrInfo.fdFlags & kIsInvisible) { ! /* If invisible */ ! if ((types->perm == 0) || ! !(types->perm & TCL_GLOB_PERM_HIDDEN)) { ! typeOk = 0; ! } ! } else { ! /* Visible */ ! if (types->perm & TCL_GLOB_PERM_HIDDEN) { ! typeOk = 0; ! } ! } ! if (typeOk == 1 && types->perm != 0) { if ( ((types->perm & TCL_GLOB_PERM_RONLY) && !(pb.hFileInfo.ioFlAttrib & 1)) || ((types->perm & TCL_GLOB_PERM_R) && (TclpAccess(fname, R_OK) != 0)) || ((types->perm & TCL_GLOB_PERM_W) && *************** *** 296,336 **** } } } else if ((pb.hFileInfo.ioFlAttrib & ioDirMask) != 0) { ! Tcl_DStringAppend(dirPtr, ":", 1); ! result = TclDoGlob(interp, separators, dirPtr, tail, types); ! if (result != TCL_OK) { ! Tcl_DStringFree(&fileString); ! break; ! } } } Tcl_DStringFree(&fileString); itemIndex++; } - *patternEnd = savedChar; 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,329 ---- } } } else if ((pb.hFileInfo.ioFlAttrib & ioDirMask) != 0) { ! Tcl_ListObjAppendElement(interp, resultPtr, ! Tcl_NewStringObj(fname, Tcl_DStringLength(&dsOrig))); } } Tcl_DStringFree(&fileString); itemIndex++; } + Tcl_DStringFree(&dsOrig); return result; } /* *---------------------------------------------------------------------- * *************** *** 352,433 **** CONST char *path, /* Path of file to access (UTF-8). */ int mode) /* Permission setting. */ { ! HFileInfo fpb; ! HVolumeParam vpb; ! OSErr err; ! FSSpec fileSpec; ! Boolean isDirectory; ! long dirID; ! Tcl_DString ds; ! char *native; ! int full_mode = 0; ! ! native = Tcl_UtfToExternalDString(NULL, path, -1, &ds); ! err = FSpLocationFromPath(Tcl_DStringLength(&ds), native, &fileSpec); ! Tcl_DStringFree(&ds); ! ! if (err != noErr) { ! errno = TclMacOSErrorToPosixError(err); ! return -1; ! } ! ! /* ! * Fill the fpb & vpb struct up with info about file or directory. ! */ ! FSpGetDirectoryID(&fileSpec, &dirID, &isDirectory); ! vpb.ioVRefNum = fpb.ioVRefNum = fileSpec.vRefNum; ! vpb.ioNamePtr = fpb.ioNamePtr = fileSpec.name; ! if (isDirectory) { ! fpb.ioDirID = fileSpec.parID; ! } else { ! fpb.ioDirID = dirID; ! } ! ! fpb.ioFDirIndex = 0; ! err = PBGetCatInfoSync((CInfoPBPtr)&fpb); ! if (err == noErr) { ! vpb.ioVolIndex = 0; ! err = PBHGetVInfoSync((HParmBlkPtr)&vpb); ! if (err == noErr) { ! /* ! * Use the Volume Info & File Info to determine ! * access information. If we have got this far ! * we know the directory is searchable or the file ! * exists. (We have F_OK) ! */ ! ! /* ! * Check to see if the volume is hardware or ! * software locked. If so we arn't W_OK. ! */ ! if (mode & W_OK) { ! if ((vpb.ioVAtrb & 0x0080) || (vpb.ioVAtrb & 0x8000)) { ! errno = EROFS; ! return -1; ! } ! if (fpb.ioFlAttrib & 0x01) { ! errno = EACCES; ! return -1; ! } ! } ! ! /* ! * Directories are always searchable and executable. But only ! * files of type 'APPL' are executable. ! */ ! if (!(fpb.ioFlAttrib & 0x10) && (mode & X_OK) ! && (fpb.ioFlFndrInfo.fdType != 'APPL')) { ! return -1; ! } ! } ! } ! ! if (err != noErr) { ! errno = TclMacOSErrorToPosixError(err); ! return -1; ! } ! ! return 0; } /* --- 345,356 ---- CONST char *path, /* Path of file to access (UTF-8). */ int mode) /* Permission setting. */ { ! int ret; ! Tcl_Obj *obj = Tcl_NewStringObj(path,-1); ! Tcl_IncrRefCount(obj); ! ret = TclpObjAccess(obj,mode); ! Tcl_DecrRefCount(obj); ! return ret; } /* *************** *** 451,496 **** TclpChdir( CONST char *dirName) /* Path to new working directory (UTF-8). */ { ! FSSpec spec; ! OSErr err; ! Boolean isFolder; ! long dirID; ! Tcl_DString ds; ! char *native; ! ! native = Tcl_UtfToExternalDString(NULL, dirName, -1, &ds); ! err = FSpLocationFromPath(Tcl_DStringLength(&ds), native, &spec); ! Tcl_DStringFree(&ds); ! ! if (err != noErr) { ! errno = ENOENT; ! return -1; ! } ! ! err = FSpGetDirectoryID(&spec, &dirID, &isFolder); ! if (err != noErr) { ! errno = ENOENT; ! return -1; ! } ! ! if (isFolder != true) { ! errno = ENOTDIR; ! return -1; ! } ! ! err = FSpSetDefaultDir(&spec); ! if (err != noErr) { ! switch (err) { ! case afpAccessDenied: ! errno = EACCES; ! break; ! default: ! errno = ENOENT; ! } ! return -1; ! } ! ! return 0; } /* --- 374,385 ---- TclpChdir( CONST char *dirName) /* Path to new working directory (UTF-8). */ { ! int ret; ! Tcl_Obj *obj = Tcl_NewStringObj(dirName,-1); ! Tcl_IncrRefCount(obj); ! ret = TclpObjChdir(obj,mode); ! Tcl_DecrRefCount(obj); ! return ret; } /* *************** *** 728,843 **** CONST char *path, /* Path of file to stat (in UTF-8). */ struct stat *bufPtr) /* Filled with results of stat call. */ { ! HFileInfo fpb; ! HVolumeParam vpb; ! OSErr err; ! FSSpec fileSpec; ! Boolean isDirectory; ! long dirID; ! Tcl_DString ds; ! ! path = Tcl_UtfToExternalDString(NULL, path, -1, &ds); ! err = FSpLocationFromPath(Tcl_DStringLength(&ds), path, &fileSpec); ! Tcl_DStringFree(&ds); ! ! if (err != noErr) { ! errno = TclMacOSErrorToPosixError(err); ! return -1; ! } ! ! /* ! * Fill the fpb & vpb struct up with info about file or directory. ! */ ! ! FSpGetDirectoryID(&fileSpec, &dirID, &isDirectory); ! vpb.ioVRefNum = fpb.ioVRefNum = fileSpec.vRefNum; ! vpb.ioNamePtr = fpb.ioNamePtr = fileSpec.name; ! if (isDirectory) { ! fpb.ioDirID = fileSpec.parID; ! } else { ! fpb.ioDirID = dirID; ! } ! ! fpb.ioFDirIndex = 0; ! err = PBGetCatInfoSync((CInfoPBPtr)&fpb); ! if (err == noErr) { ! vpb.ioVolIndex = 0; ! err = PBHGetVInfoSync((HParmBlkPtr)&vpb); ! if (err == noErr && bufPtr != NULL) { ! /* ! * Files are always readable by everyone. ! */ ! ! bufPtr->st_mode = S_IRUSR | S_IRGRP | S_IROTH; ! ! /* ! * Use the Volume Info & File Info to fill out stat buf. ! */ ! if (fpb.ioFlAttrib & 0x10) { ! bufPtr->st_mode |= S_IFDIR; ! bufPtr->st_nlink = 2; ! } else { ! bufPtr->st_nlink = 1; ! if (fpb.ioFlFndrInfo.fdFlags & 0x8000) { ! bufPtr->st_mode |= S_IFLNK; ! } else { ! bufPtr->st_mode |= S_IFREG; ! } ! } ! if ((fpb.ioFlAttrib & 0x10) || (fpb.ioFlFndrInfo.fdType == 'APPL')) { ! /* ! * Directories and applications are executable by everyone. ! */ ! ! bufPtr->st_mode |= S_IXUSR | S_IXGRP | S_IXOTH; ! } ! if ((fpb.ioFlAttrib & 0x01) == 0){ ! /* ! * If not locked, then everyone has write acces. ! */ ! ! bufPtr->st_mode |= S_IWUSR | S_IWGRP | S_IWOTH; ! } ! bufPtr->st_ino = fpb.ioDirID; ! bufPtr->st_dev = fpb.ioVRefNum; ! bufPtr->st_uid = -1; ! bufPtr->st_gid = -1; ! bufPtr->st_rdev = 0; ! bufPtr->st_size = fpb.ioFlLgLen; ! bufPtr->st_blksize = vpb.ioVAlBlkSiz; ! bufPtr->st_blocks = (bufPtr->st_size + bufPtr->st_blksize - 1) ! / bufPtr->st_blksize; ! ! /* ! * The times returned by the Mac file system are in the ! * local time zone. We convert them to GMT so that the ! * epoch starts from GMT. This is also consistant with ! * what is returned from "clock seconds". ! */ ! ! Tcl_MutexLock(&gmtMutex); ! if (initialized == false) { ! MachineLocation loc; ! ! ReadLocation(&loc); ! gmt_offset = loc.u.gmtDelta & 0x00ffffff; ! if (gmt_offset & 0x00800000) { ! gmt_offset = gmt_offset | 0xff000000; ! } ! initialized = true; ! } ! Tcl_MutexUnlock(&gmtMutex); ! ! bufPtr->st_atime = bufPtr->st_mtime = fpb.ioFlMdDat - gmt_offset; ! bufPtr->st_ctime = fpb.ioFlCrDat - gmt_offset; ! } ! } ! ! if (err != noErr) { ! errno = TclMacOSErrorToPosixError(err); ! } ! ! return (err == noErr ? 0 : -1); } /* --- 617,628 ---- CONST char *path, /* Path of file to stat (in UTF-8). */ struct stat *bufPtr) /* Filled with results of stat call. */ { ! int ret; ! Tcl_Obj *obj = Tcl_NewStringObj(path,-1); ! Tcl_IncrRefCount(obj); ! ret = TclpObjStat(obj,bufPtr); ! Tcl_DecrRefCount(obj); ! return ret; } /* *************** *** 994,999 **** --- 779,785 ---- return EINVAL; } } + int TclMacChmod( char *path, *************** *** 1021,1023 **** --- 807,1070 ---- return 0; } + + int + TclpObjStat(Tcl_Obj *pathPtr, struct stat *buf) { + HFileInfo fpb; + HVolumeParam vpb; + OSErr err; + FSSpec fileSpec; + Boolean isDirectory; + long dirID; + + err = FspLocationFromFsPath(pathPtr, &fileSpec); + + if (err != noErr) { + errno = TclMacOSErrorToPosixError(err); + return -1; + } + + /* + * Fill the fpb & vpb struct up with info about file or directory. + */ + + FSpGetDirectoryID(&fileSpec, &dirID, &isDirectory); + vpb.ioVRefNum = fpb.ioVRefNum = fileSpec.vRefNum; + vpb.ioNamePtr = fpb.ioNamePtr = fileSpec.name; + if (isDirectory) { + fpb.ioDirID = fileSpec.parID; + } else { + fpb.ioDirID = dirID; + } + + fpb.ioFDirIndex = 0; + err = PBGetCatInfoSync((CInfoPBPtr)&fpb); + if (err == noErr) { + vpb.ioVolIndex = 0; + err = PBHGetVInfoSync((HParmBlkPtr)&vpb); + if (err == noErr && bufPtr != NULL) { + /* + * Files are always readable by everyone. + */ + + bufPtr->st_mode = S_IRUSR | S_IRGRP | S_IROTH; + + /* + * Use the Volume Info & File Info to fill out stat buf. + */ + if (fpb.ioFlAttrib & 0x10) { + bufPtr->st_mode |= S_IFDIR; + bufPtr->st_nlink = 2; + } else { + bufPtr->st_nlink = 1; + if (fpb.ioFlFndrInfo.fdFlags & 0x8000) { + bufPtr->st_mode |= S_IFLNK; + } else { + bufPtr->st_mode |= S_IFREG; + } + } + if ((fpb.ioFlAttrib & 0x10) || (fpb.ioFlFndrInfo.fdType == 'APPL')) { + /* + * Directories and applications are executable by everyone. + */ + + bufPtr->st_mode |= S_IXUSR | S_IXGRP | S_IXOTH; + } + if ((fpb.ioFlAttrib & 0x01) == 0){ + /* + * If not locked, then everyone has write acces. + */ + + bufPtr->st_mode |= S_IWUSR | S_IWGRP | S_IWOTH; + } + bufPtr->st_ino = fpb.ioDirID; + bufPtr->st_dev = fpb.ioVRefNum; + bufPtr->st_uid = -1; + bufPtr->st_gid = -1; + bufPtr->st_rdev = 0; + bufPtr->st_size = fpb.ioFlLgLen; + bufPtr->st_blksize = vpb.ioVAlBlkSiz; + bufPtr->st_blocks = (bufPtr->st_size + bufPtr->st_blksize - 1) + / bufPtr->st_blksize; + + /* + * The times returned by the Mac file system are in the + * local time zone. We convert them to GMT so that the + * epoch starts from GMT. This is also consistant with + * what is returned from "clock seconds". + */ + + Tcl_MutexLock(&gmtMutex); + if (initialized == false) { + MachineLocation loc; + + ReadLocation(&loc); + gmt_offset = loc.u.gmtDelta & 0x00ffffff; + if (gmt_offset & 0x00800000) { + gmt_offset = gmt_offset | 0xff000000; + } + initialized = true; + } + Tcl_MutexUnlock(&gmtMutex); + + bufPtr->st_atime = bufPtr->st_mtime = fpb.ioFlMdDat - gmt_offset; + bufPtr->st_ctime = fpb.ioFlCrDat - gmt_offset; + } + } + + if (err != noErr) { + errno = TclMacOSErrorToPosixError(err); + } + + return (err == noErr ? 0 : -1); + } + + Tcl_Obj* + TclpObjGetCwd(Tcl_Interp *interp) { + Tcl_DString ds; + if (TclpGetCwd(interp, &ds) != NULL) { + Tcl_Obj *cwdPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1); + Tcl_IncrRefCount(cwdPtr); + Tcl_DStringFree(&ds); + return cwdPtr; + } else { + return NULL; + } + } + + int + TclpObjChdir(Tcl_Obj *pathPtr) { + FSSpec spec; + OSErr err; + Boolean isFolder; + long dirID; + + err = FspLocationFromFsPath(pathPtr, &spec); + + if (err != noErr) { + errno = ENOENT; + return -1; + } + + err = FSpGetDirectoryID(&spec, &dirID, &isFolder); + if (err != noErr) { + errno = ENOENT; + return -1; + } + + if (isFolder != true) { + errno = ENOTDIR; + return -1; + } + + err = FSpSetDefaultDir(&spec); + if (err != noErr) { + switch (err) { + case afpAccessDenied: + errno = EACCES; + break; + default: + errno = ENOENT; + } + return -1; + } + + return 0; + } + + int + TclpObjAccess(Tcl_Obj *pathPtr, int mode) { + HFileInfo fpb; + HVolumeParam vpb; + OSErr err; + FSSpec fileSpec; + Boolean isDirectory; + long dirID; + int full_mode = 0; + + err = FspLocationFromFsPath(pathPtr, &fileSpec); + + if (err != noErr) { + errno = TclMacOSErrorToPosixError(err); + return -1; + } + + /* + * Fill the fpb & vpb struct up with info about file or directory. + */ + FSpGetDirectoryID(&fileSpec, &dirID, &isDirectory); + vpb.ioVRefNum = fpb.ioVRefNum = fileSpec.vRefNum; + vpb.ioNamePtr = fpb.ioNamePtr = fileSpec.name; + if (isDirectory) { + fpb.ioDirID = fileSpec.parID; + } else { + fpb.ioDirID = dirID; + } + + fpb.ioFDirIndex = 0; + err = PBGetCatInfoSync((CInfoPBPtr)&fpb); + if (err == noErr) { + vpb.ioVolIndex = 0; + err = PBHGetVInfoSync((HParmBlkPtr)&vpb); + if (err == noErr) { + /* + * Use the Volume Info & File Info to determine + * access information. If we have got this far + * we know the directory is searchable or the file + * exists. (We have F_OK) + */ + + /* + * Check to see if the volume is hardware or + * software locked. If so we arn't W_OK. + */ + if (mode & W_OK) { + if ((vpb.ioVAtrb & 0x0080) || (vpb.ioVAtrb & 0x8000)) { + errno = EROFS; + return -1; + } + if (fpb.ioFlAttrib & 0x01) { + errno = EACCES; + return -1; + } + } + + /* + * Directories are always searchable and executable. But only + * files of type 'APPL' are executable. + */ + if (!(fpb.ioFlAttrib & 0x10) && (mode & X_OK) + && (fpb.ioFlFndrInfo.fdType != 'APPL')) { + return -1; + } + } + } + + if (err != noErr) { + errno = TclMacOSErrorToPosixError(err); + return -1; + } + + return 0; + } + + int + TclpObjLstat(Tcl_Obj *pathPtr, struct stat *buf) { + return TclpObjStat(pathPtr, buf); + } + + #ifdef S_IFLNK + + Tcl_Obj* + TclpObjReadlink(Tcl_Obj *pathPtr) { + Tcl_DString ds; + Tcl_Obj* link = NULL; + if (TclpReadlink(Tcl_FSGetTranslatedPath(NULL, pathPtr), &ds) != NULL) { + link = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1); + Tcl_IncrRefCount(link); + Tcl_DStringFree(&ds); + } + return link; + } + + #endif Index: mac/tclMacInit.c =================================================================== RCS file: /cvsroot/tcl/tcl/mac/tclMacInit.c,v retrieving revision 1.4 diff -c -r1.4 tclMacInit.c *** mac/tclMacInit.c 1999/05/11 07:12:16 1.4 --- mac/tclMacInit.c 2001/03/16 17:08:15 *************** *** 132,137 **** --- 132,140 ---- static int GetFinderFont(int *finderID); + /* Used to store the encoding used for binary files */ + static Tcl_Encoding binaryEncoding = NULL; + /* *---------------------------------------------------------------------- *************** *** 467,474 **** * gets on a binary channel. */ ! Tcl_GetEncoding(NULL, "iso8859-1"); } /* *--------------------------------------------------------------------------- --- 470,519 ---- * gets on a binary channel. */ ! binaryEncoding = Tcl_GetEncoding(NULL, "iso8859-1"); } + + /* + *--------------------------------------------------------------------------- + * + * TclpVerifyInitialEncodings -- + * + * Part way through startup, we verify that the initial encodings + * were correctly setup. Depending on Tcl's environment, there + * may not have been enough information first time through (above). + * + * Called at process initialization time. + * + * Results: + * None. + * + * Side effects: + * Encodings may change. + * + *--------------------------------------------------------------------------- + */ + void TclpVerifyInitialEncodings() + { + CONST char *encoding; + Tcl_Obj *pathPtr; + int fontId; + + fontId = 0; + GetFinderFont(&fontId); + encoding = TclMacGetFontEncoding(fontId); + if (encoding == NULL) { + encoding = "macRoman"; + } + + /* We just reload the system encoding */ + Tcl_SetSystemEncoding(NULL, encoding); + + /* This is only ever called from the startup thread */ + if (binaryEncoding == NULL) { + encoding = "iso8859-1"; + binaryEncoding = Tcl_GetEncoding(NULL, encoding); + } + } /* *--------------------------------------------------------------------------- Index: mac/tclMacResource.c =================================================================== RCS file: /cvsroot/tcl/tcl/mac/tclMacResource.c,v retrieving revision 1.7 diff -c -r1.7 tclMacResource.c *** mac/tclMacResource.c 1999/08/15 04:54:03 1.7 --- mac/tclMacResource.c 2001/03/16 17:08:15 *************** *** 954,961 **** } if (objc == 2) { ! string = Tcl_GetStringFromObj(objv[1], &length); ! return Tcl_EvalFile(interp, string); } /* --- 954,960 ---- } if (objc == 2) { ! return Tcl_FSEvalFile(interp, objv[1]); } /* Index: tests/cmdAH.test =================================================================== RCS file: /cvsroot/tcl/tcl/tests/cmdAH.test,v retrieving revision 1.12 diff -c -r1.12 cmdAH.test *** tests/cmdAH.test 2000/10/06 21:10:51 1.12 --- tests/cmdAH.test 2001/03/16 17:08:15 *************** *** 17,22 **** --- 17,24 ---- namespace import -force ::tcltest::* } + tcltest::testConstraint testchmod [string equal testchmod [info commands testchmod]] + global env set cmdAHwd [pwd] catch {set platform [testgetplatform]} *************** *** 166,172 **** } {1 {wrong # args: should be "file option ?arg ...?"}} test cmdAH-5.2 {Tcl_FileObjCmd} { list [catch {file x} msg] $msg ! } {1 {bad option "x": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, owned, pathtype, readable, readlink, rename, rootname, size, split, stat, tail, type, volumes, or writable}} test cmdAH-5.3 {Tcl_FileObjCmd} { list [catch {file exists} msg] $msg } {1 {wrong # args: should be "file exists name"}} --- 168,174 ---- } {1 {wrong # args: should be "file option ?arg ...?"}} test cmdAH-5.2 {Tcl_FileObjCmd} { list [catch {file x} msg] $msg ! } {1 {bad option "x": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}} test cmdAH-5.3 {Tcl_FileObjCmd} { list [catch {file exists} msg] $msg } {1 {wrong # args: should be "file exists name"}} *************** *** 1000,1035 **** # readable - if {[info commands testchmod] == {}} { - puts "This application hasn't been compiled with the \"testchmod\"" - puts "command, so I can't test Tcl_FileObjCmd etc." - } else { makeFile abcde gorp.file makeDirectory dir.file ! test cmdAH-16.1 {Tcl_FileObjCmd: readable} { list [catch {file readable a b} msg] $msg } {1 {wrong # args: should be "file readable name"}} testchmod 444 gorp.file ! test cmdAH-16.2 {Tcl_FileObjCmd: readable} { file readable gorp.file } 1 testchmod 333 gorp.file ! test cmdAH-16.3 {Tcl_FileObjCmd: readable} {unixOnly notRoot} { file reada gorp.file } 0 # writable ! test cmdAH-17.1 {Tcl_FileObjCmd: writable} { list [catch {file writable a b} msg] $msg } {1 {wrong # args: should be "file writable name"}} testchmod 555 gorp.file ! test cmdAH-17.2 {Tcl_FileObjCmd: writable} {notRoot} { file writable gorp.file } 0 testchmod 222 gorp.file ! test cmdAH-17.3 {Tcl_FileObjCmd: writable} { file writable gorp.file } 1 --- 1002,1033 ---- # readable makeFile abcde gorp.file makeDirectory dir.file ! test cmdAH-16.1 {Tcl_FileObjCmd: readable} {testchmod} { list [catch {file readable a b} msg] $msg } {1 {wrong # args: should be "file readable name"}} testchmod 444 gorp.file ! test cmdAH-16.2 {Tcl_FileObjCmd: readable} {testchmod} { file readable gorp.file } 1 testchmod 333 gorp.file ! test cmdAH-16.3 {Tcl_FileObjCmd: readable} {unixOnly notRoot testchmod} { file reada gorp.file } 0 # writable ! test cmdAH-17.1 {Tcl_FileObjCmd: writable} {testchmod} { list [catch {file writable a b} msg] $msg } {1 {wrong # args: should be "file writable name"}} testchmod 555 gorp.file ! test cmdAH-17.2 {Tcl_FileObjCmd: writable} {notRoot testchmod} { file writable gorp.file } 0 testchmod 222 gorp.file ! test cmdAH-17.3 {Tcl_FileObjCmd: writable} {testchmod} { file writable gorp.file } 1 *************** *** 1039,1051 **** file mkdir dir.file makeFile abcde gorp.file ! test cmdAH-18.1 {Tcl_FileObjCmd: executable} { list [catch {file executable a b} msg] $msg } {1 {wrong # args: should be "file executable name"}} ! test cmdAH-18.2 {Tcl_FileObjCmd: executable} { file executable gorp.file } 0 ! test cmdAH-18.3 {Tcl_FileObjCmd: executable} {unixOnly} { # Only on unix will setting the execute bit on a regular file # cause that file to be executable. --- 1037,1049 ---- file mkdir dir.file makeFile abcde gorp.file ! test cmdAH-18.1 {Tcl_FileObjCmd: executable} {testchmod} { list [catch {file executable a b} msg] $msg } {1 {wrong # args: should be "file executable name"}} ! test cmdAH-18.2 {Tcl_FileObjCmd: executable} {testchmod} { file executable gorp.file } 0 ! test cmdAH-18.3 {Tcl_FileObjCmd: executable} {unixOnly testchmod} { # Only on unix will setting the execute bit on a regular file # cause that file to be executable. *************** *** 1053,1066 **** file exe gorp.file } 1 ! test cmdAH-18.4 {Tcl_FileObjCmd: executable} {macOnly} { # On mac, the only executable files are of type APPL. set x [file exe gorp.file] file attrib gorp.file -type APPL lappend x [file exe gorp.file] } {0 1} ! test cmdAH-18.5 {Tcl_FileObjCmd: executable} {pcOnly} { # On pc, must be a .exe, .com, etc. set x [file exe gorp.file] --- 1051,1064 ---- file exe gorp.file } 1 ! test cmdAH-18.4 {Tcl_FileObjCmd: executable} {macOnly testchmod} { # On mac, the only executable files are of type APPL. set x [file exe gorp.file] file attrib gorp.file -type APPL lappend x [file exe gorp.file] } {0 1} ! test cmdAH-18.5 {Tcl_FileObjCmd: executable} {pcOnly testchmod} { # On pc, must be a .exe, .com, etc. set x [file exe gorp.file] *************** *** 1069,1075 **** file delete gorp.exe set x } {0 1} ! test cmdAH-18.6 {Tcl_FileObjCmd: executable} { # Directories are always executable. file exe dir.file --- 1067,1073 ---- file delete gorp.exe set x } {0 1} ! test cmdAH-18.6 {Tcl_FileObjCmd: executable} {testchmod} { # Directories are always executable. file exe dir.file *************** *** 1078,1084 **** file delete -force dir.file file delete gorp.file file delete link.file - } # exists --- 1076,1081 ---- *************** *** 1243,1248 **** --- 1240,1278 ---- } {1 {can't set "x(dev)": variable isn't array} NONE} catch {unset stat} + # mkdir + + test cmdAH-23.7 {Tcl_FileObjCmd: mkdir} { + catch {file delete -force a} + file mkdir a + set res [file isdirectory a] + file delete a + set res + } {1} + test cmdAH-23.8 {Tcl_FileObjCmd: mkdir} { + catch {file delete -force a} + file mkdir a/b + set res [file isdirectory a/b] + file delete -force a + set res + } {1} + test cmdAH-23.9 {Tcl_FileObjCmd: mkdir} { + catch {file delete -force a} + file mkdir a/b/c + set res [file isdirectory a/b/c] + file delete -force a + set res + } {1} + test cmdAH-23.10 {Tcl_FileObjCmd: mkdir} { + catch {file delete -force a} + catch {file delete -force b} + file mkdir a/b b/a/c + set res [list [file isdirectory a/b] [file isdirectory b/a/c]] + file delete -force a + file delete -force b + set res + } {1 1} + # mtime set file [makeFile "data" touch.me] *************** *** 1467,1491 **** test cmdAH-30.1 {Tcl_FileObjCmd: error conditions} { list [catch {file gorp x} msg] $msg ! } {1 {bad option "gorp": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, owned, pathtype, readable, readlink, rename, rootname, size, split, stat, tail, type, volumes, or writable}} test cmdAH-30.2 {Tcl_FileObjCmd: error conditions} { list [catch {file ex x} msg] $msg ! } {1 {ambiguous option "ex": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, owned, pathtype, readable, readlink, rename, rootname, size, split, stat, tail, type, volumes, or writable}} test cmdAH-30.3 {Tcl_FileObjCmd: error conditions} { list [catch {file is x} msg] $msg ! } {1 {ambiguous option "is": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, owned, pathtype, readable, readlink, rename, rootname, size, split, stat, tail, type, volumes, or writable}} test cmdAH-30.4 {Tcl_FileObjCmd: error conditions} { list [catch {file z x} msg] $msg ! } {1 {bad option "z": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, owned, pathtype, readable, readlink, rename, rootname, size, split, stat, tail, type, volumes, or writable}} test cmdAH-30.5 {Tcl_FileObjCmd: error conditions} { list [catch {file read x} msg] $msg ! } {1 {ambiguous option "read": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, owned, pathtype, readable, readlink, rename, rootname, size, split, stat, tail, type, volumes, or writable}} test cmdAH-30.6 {Tcl_FileObjCmd: error conditions} { list [catch {file s x} msg] $msg ! } {1 {ambiguous option "s": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, owned, pathtype, readable, readlink, rename, rootname, size, split, stat, tail, type, volumes, or writable}} test cmdAH-30.7 {Tcl_FileObjCmd: error conditions} { list [catch {file t x} msg] $msg ! } {1 {ambiguous option "t": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, owned, pathtype, readable, readlink, rename, rootname, size, split, stat, tail, type, volumes, or writable}} test cmdAH-30.8 {Tcl_FileObjCmd: error conditions} { list [catch {file dirname ~woohgy} msg] $msg } {1 {user "woohgy" doesn't exist}} --- 1497,1521 ---- test cmdAH-30.1 {Tcl_FileObjCmd: error conditions} { list [catch {file gorp x} msg] $msg ! } {1 {bad option "gorp": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}} test cmdAH-30.2 {Tcl_FileObjCmd: error conditions} { list [catch {file ex x} msg] $msg ! } {1 {ambiguous option "ex": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}} test cmdAH-30.3 {Tcl_FileObjCmd: error conditions} { list [catch {file is x} msg] $msg ! } {1 {ambiguous option "is": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}} test cmdAH-30.4 {Tcl_FileObjCmd: error conditions} { list [catch {file z x} msg] $msg ! } {1 {bad option "z": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}} test cmdAH-30.5 {Tcl_FileObjCmd: error conditions} { list [catch {file read x} msg] $msg ! } {1 {ambiguous option "read": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}} test cmdAH-30.6 {Tcl_FileObjCmd: error conditions} { list [catch {file s x} msg] $msg ! } {1 {ambiguous option "s": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}} test cmdAH-30.7 {Tcl_FileObjCmd: error conditions} { list [catch {file t x} msg] $msg ! } {1 {ambiguous option "t": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}} test cmdAH-30.8 {Tcl_FileObjCmd: error conditions} { list [catch {file dirname ~woohgy} msg] $msg } {1 {user "woohgy" doesn't exist}} Index: tests/fCmd.test =================================================================== RCS file: /cvsroot/tcl/tcl/tests/fCmd.test,v retrieving revision 1.9 diff -c -r1.9 fCmd.test *** tests/fCmd.test 2000/09/29 01:12:14 1.9 --- tests/fCmd.test 2001/03/16 17:08:15 *************** *** 18,39 **** namespace import -force ::tcltest::* } ! if {[string compare testgetplatform [info commands testgetplatform]] != 0} { ! puts "This application hasn't been compiled with the \"testgetplatform\"" ! puts "command, therefore I am skipping all of these tests." ! ::tcltest::cleanupTests ! return ! } ! ! set platform [testgetplatform] - if {"[info commands testchmod]" != "testchmod"} { - puts "Skipping fCmd tests. This application does not seem to have the" - puts "testchmod command that is needed to run these tests." - ::tcltest::cleanupTests - return - } - # Several tests require need to match results against the unix username set user {} if {$tcl_platform(platform) == "unix"} { --- 18,26 ---- namespace import -force ::tcltest::* } ! tcltest::testConstraint testsetplatform [string equal testsetplatform [info commands testsetplatform]] ! tcltest::testConstraint testchmod [string equal testchmod [info commands testchmod]] # Several tests require need to match results against the unix username set user {} if {$tcl_platform(platform) == "unix"} { *************** *** 74,80 **** testchmod 777 $path if {[file isdirectory $path]} { catch { ! foreach p [glob [file join $path *]] { openup $p } } --- 61,67 ---- testchmod 777 $path if {[file isdirectory $path]} { catch { ! foreach p [glob -directory $path *] { openup $p } } *************** *** 82,91 **** } proc cleanup {args} { ! foreach p ". $args" { set x "" catch { ! set x [glob [file join $p tf*] [file join $p td*]] } foreach file $x { if {[catch {file delete -force -- $file}]} { --- 69,78 ---- } proc cleanup {args} { ! foreach p [concat [list .] $args] { set x "" catch { ! set x [glob -directory $p tf* td*] } foreach file $x { if {[catch {file delete -force -- $file}]} { *************** *** 299,305 **** list $x [file exist td1] } {1 1} test fCmd-4.11 {TclFileMakeDirsCmd: doesn't exist: errno != ENOENT} \ ! {unixOnly notRoot} { cleanup file mkdir td1/td2/td3 testchmod 000 td1/td2 --- 286,292 ---- list $x [file exist td1] } {1 1} test fCmd-4.11 {TclFileMakeDirsCmd: doesn't exist: errno != ENOENT} \ ! {unixOnly notRoot testchmod} { cleanup file mkdir td1/td2/td3 testchmod 000 td1/td2 *************** *** 309,316 **** } {1 {can't create directory "td1/td2/td3": permission denied}} test fCmd-4.12 {TclFileMakeDirsCmd: doesn't exist: errno != ENOENT} {macOnly} { cleanup ! list [catch {file mkdir nonexistantvolume:} msg] $msg ! } {1 {can't create directory "nonexistantvolume:": invalid argument}} test fCmd-4.13 {TclFileMakeDirsCmd: doesn't exist: errno == ENOENT} {notRoot} { cleanup set x [file exist td1] --- 296,303 ---- } {1 {can't create directory "td1/td2/td3": permission denied}} test fCmd-4.12 {TclFileMakeDirsCmd: doesn't exist: errno != ENOENT} {macOnly} { cleanup ! list [catch {file mkdir nonexistentvolume:} msg] $msg ! } {1 {can't create directory "nonexistentvolume:": invalid argument}} test fCmd-4.13 {TclFileMakeDirsCmd: doesn't exist: errno == ENOENT} {notRoot} { cleanup set x [file exist td1] *************** *** 415,421 **** file rename tf1 tf2 glob tf* } {tf2} ! test fCmd-6.6 {CopyRenameOneFile: errno != ENOENT} {unixOnly notRoot} { cleanup file mkdir td1 testchmod 000 td1 --- 402,408 ---- file rename tf1 tf2 glob tf* } {tf2} ! test fCmd-6.6 {CopyRenameOneFile: errno != ENOENT} {unixOnly notRoot testchmod} { cleanup file mkdir td1 testchmod 000 td1 *************** *** 676,682 **** cleanup list [catch {file rename tf1 tf2} msg] $msg } {1 {error renaming "tf1": no such file or directory}} ! test fCmd-9.3 {file rename: comprehensive: file to new name} {notRoot} { cleanup createfile tf1 createfile tf2 --- 663,669 ---- cleanup list [catch {file rename tf1 tf2} msg] $msg } {1 {error renaming "tf1": no such file or directory}} ! test fCmd-9.3 {file rename: comprehensive: file to new name} {notRoot testchmod} { cleanup createfile tf1 createfile tf2 *************** *** 685,691 **** file rename tf2 tf4 list [lsort [glob tf*]] [file writable tf3] [file writable tf4] } {{tf3 tf4} 1 0} ! test fCmd-9.4 {file rename: comprehensive: dir to new name} {unixOrPc notRoot} { cleanup file mkdir td1 td2 testchmod 555 td2 --- 672,678 ---- file rename tf2 tf4 list [lsort [glob tf*]] [file writable tf3] [file writable tf4] } {{tf3 tf4} 1 0} ! test fCmd-9.4 {file rename: comprehensive: dir to new name} {unixOrPc notRoot testchmod} { cleanup file mkdir td1 td2 testchmod 555 td2 *************** *** 693,699 **** file rename td2 td4 list [lsort [glob td*]] [file writable td3] [file writable td4] } {{td3 td4} 1 0} ! test fCmd-9.5 {file rename: comprehensive: file to self} {notRoot} { cleanup createfile tf1 tf1 createfile tf2 tf2 --- 680,686 ---- file rename td2 td4 list [lsort [glob td*]] [file writable td3] [file writable td4] } {{td3 td4} 1 0} ! test fCmd-9.5 {file rename: comprehensive: file to self} {notRoot testchmod} { cleanup createfile tf1 tf1 createfile tf2 tf2 *************** *** 702,708 **** file rename -force tf2 tf2 list [contents tf1] [contents tf2] [file writable tf1] [file writable tf2] } {tf1 tf2 1 0} ! test fCmd-9.6 {file rename: comprehensive: dir to self} {notRoot unixOrPc} { cleanup file mkdir td1 file mkdir td2 --- 689,695 ---- file rename -force tf2 tf2 list [contents tf1] [contents tf2] [file writable tf1] [file writable tf2] } {tf1 tf2 1 0} ! test fCmd-9.6 {file rename: comprehensive: dir to self} {notRoot unixOrPc testchmod} { cleanup file mkdir td1 file mkdir td2 *************** *** 711,717 **** file rename -force td2 . list [lsort [glob td*]] [file writable td1] [file writable td2] } {{td1 td2} 1 0} ! test fCmd-9.7 {file rename: comprehensive: file to existing file} {notRoot} { cleanup createfile tf1 createfile tf2 --- 698,704 ---- file rename -force td2 . list [lsort [glob td*]] [file writable td1] [file writable td2] } {{td1 td2} 1 0} ! test fCmd-9.7 {file rename: comprehensive: file to existing file} {notRoot testchmod} { cleanup createfile tf1 createfile tf2 *************** *** 734,740 **** file rename -force tfs4 tfd4 list [lsort [glob tf*]] $msg [file writable tfd1] [file writable tfd2] [file writable tfd3] [file writable tfd4] } {{tf1 tf2 tfd1 tfd2 tfd3 tfd4} {1 {error renaming "tf1" to "tf2": file already exists}} 1 1 0 0} ! test fCmd-9.8 {file rename: comprehensive: dir to empty dir} {notRoot} { # Under unix, you can rename a read-only directory, but you can't # move it into another directory. --- 721,727 ---- file rename -force tfs4 tfd4 list [lsort [glob tf*]] $msg [file writable tfd1] [file writable tfd2] [file writable tfd3] [file writable tfd4] } {{tf1 tf2 tfd1 tfd2 tfd3 tfd4} {1 {error renaming "tf1" to "tf2": file already exists}} 1 1 0 0} ! test fCmd-9.8 {file rename: comprehensive: dir to empty dir} {notRoot testchmod} { # Under unix, you can rename a read-only directory, but you can't # move it into another directory. *************** *** 772,778 **** list [lsort [glob td*]] $msg [file writable [file join tdd1 tds1]] \ [file writable [file join tdd2 tds2]] $w3 $w4 } [subst {{td1 td2 tdd1 tdd2 tdd3 tdd4} {1 {error renaming "td1" to "[file join td2 td1]": file already exists}} 1 1 0 0}] ! test fCmd-9.9 {file rename: comprehensive: dir to non-empty dir} {notRoot} { cleanup file mkdir tds1 file mkdir tds2 --- 759,765 ---- list [lsort [glob td*]] $msg [file writable [file join tdd1 tds1]] \ [file writable [file join tdd2 tds2]] $w3 $w4 } [subst {{td1 td2 tdd1 tdd2 tdd3 tdd4} {1 {error renaming "td1" to "[file join td2 td1]": file already exists}} 1 1 0 0}] ! test fCmd-9.9 {file rename: comprehensive: dir to non-empty dir} {notRoot testchmod} { cleanup file mkdir tds1 file mkdir tds2 *************** *** 790,796 **** } list [lsort [glob td*]] $a1 $a2 [file writable tds1] $w2 } [subst {{tdd1 tdd2 tds1 tds2} {1 {error renaming "tds1" to "[file join tdd1 tds1]": file already exists}} {1 {error renaming "tds2" to "[file join tdd2 tds2]": file already exists}} 1 0}] ! test fCmd-9.10 {file rename: comprehensive: file to new name and dir} {notRoot} { cleanup createfile tf1 createfile tf2 --- 777,783 ---- } list [lsort [glob td*]] $a1 $a2 [file writable tds1] $w2 } [subst {{tdd1 tdd2 tds1 tds2} {1 {error renaming "tds1" to "[file join tdd1 tds1]": file already exists}} {1 {error renaming "tds2" to "[file join tdd2 tds2]": file already exists}} 1 0}] ! test fCmd-9.10 {file rename: comprehensive: file to new name and dir} {notRoot testchmod} { cleanup createfile tf1 createfile tf2 *************** *** 798,807 **** testchmod 444 tf2 file rename tf1 [file join td1 tf3] file rename tf2 [file join td1 tf4] ! list [catch {glob tf*}] [lsort [glob [file join td1 t*]]] \ [file writable [file join td1 tf3]] [file writable [file join td1 tf4]] } [subst {1 {[file join td1 tf3] [file join td1 tf4]} 1 0}] ! test fCmd-9.11 {file rename: comprehensive: dir to new name and dir} {notRoot} { cleanup file mkdir td1 file mkdir td2 --- 785,794 ---- testchmod 444 tf2 file rename tf1 [file join td1 tf3] file rename tf2 [file join td1 tf4] ! list [catch {glob tf*}] [lsort [glob -directory td1 t*]] \ [file writable [file join td1 tf3]] [file writable [file join td1 tf4]] } [subst {1 {[file join td1 tf3] [file join td1 tf4]} 1 0}] ! test fCmd-9.11 {file rename: comprehensive: dir to new name and dir} {notRoot testchmod} { cleanup file mkdir td1 file mkdir td2 *************** *** 816,825 **** } else { set w4 0 } ! list [lsort [glob td*]] [lsort [glob [file join td3 t*]]] \ [file writable [file join td3 td3]] $w4 } [subst {td3 {[file join td3 td3] [file join td3 td4]} 1 0}] ! test fCmd-9.12 {file rename: comprehensive: target exists} {notRoot} { cleanup file mkdir [file join td1 td2] [file join td2 td1] if {$tcl_platform(platform) != "macintosh"} { --- 803,812 ---- } else { set w4 0 } ! list [lsort [glob td*]] [lsort [glob -directory td3 t*]] \ [file writable [file join td3 td3]] $w4 } [subst {td3 {[file join td3 td3] [file join td3 td4]} 1 0}] ! test fCmd-9.12 {file rename: comprehensive: target exists} {notRoot testchmod} { cleanup file mkdir [file join td1 td2] [file join td2 td1] if {$tcl_platform(platform) != "macintosh"} { *************** *** 863,869 **** cleanup list [catch {file copy tf1 tf2} msg] $msg } {1 {error copying "tf1": no such file or directory}} ! test fCmd-10.2 {file copy: comprehensive: file to new name} {notRoot} { cleanup createfile tf1 tf1 createfile tf2 tf2 --- 850,856 ---- cleanup list [catch {file copy tf1 tf2} msg] $msg } {1 {error copying "tf1": no such file or directory}} ! test fCmd-10.2 {file copy: comprehensive: file to new name} {notRoot testchmod} { cleanup createfile tf1 tf1 createfile tf2 tf2 *************** *** 872,893 **** file copy tf2 tf4 list [lsort [glob tf*]] [contents tf3] [contents tf4] [file writable tf3] [file writable tf4] } {{tf1 tf2 tf3 tf4} tf1 tf2 1 0} ! test fCmd-10.3 {file copy: comprehensive: dir to new name} {notRoot unixOrPc} { cleanup file mkdir [file join td1 tdx] file mkdir [file join td2 tdy] testchmod 555 td2 file copy td1 td3 file copy td2 td4 ! set msg [list [lsort [glob td*]] [glob [file join td3 t*]] \ ! [glob [file join td4 t*]] [file writable td3] [file writable td4]] if {$tcl_platform(platform) != "macintosh"} { testchmod 755 td2 testchmod 755 td4 } set msg } [subst {{td1 td2 td3 td4} [file join td3 tdx] [file join td4 tdy] 1 0}] ! test fCmd-10.4 {file copy: comprehensive: file to existing file} {notRoot} { cleanup createfile tf1 createfile tf2 --- 859,880 ---- file copy tf2 tf4 list [lsort [glob tf*]] [contents tf3] [contents tf4] [file writable tf3] [file writable tf4] } {{tf1 tf2 tf3 tf4} tf1 tf2 1 0} ! test fCmd-10.3 {file copy: comprehensive: dir to new name} {notRoot unixOrPc testchmod} { cleanup file mkdir [file join td1 tdx] file mkdir [file join td2 tdy] testchmod 555 td2 file copy td1 td3 file copy td2 td4 ! set msg [list [lsort [glob td*]] [glob -directory td3 t*] \ ! [glob -directory td4 t*] [file writable td3] [file writable td4]] if {$tcl_platform(platform) != "macintosh"} { testchmod 755 td2 testchmod 755 td4 } set msg } [subst {{td1 td2 td3 td4} [file join td3 tdx] [file join td4 tdy] 1 0}] ! test fCmd-10.4 {file copy: comprehensive: file to existing file} {notRoot testchmod} { cleanup createfile tf1 createfile tf2 *************** *** 910,916 **** file copy -force tfs4 tfd4 list [lsort [glob tf*]] $msg [file writable tfd1] [file writable tfd2] [file writable tfd3] [file writable tfd4] } {{tf1 tf2 tfd1 tfd2 tfd3 tfd4 tfs1 tfs2 tfs3 tfs4} {1 {error copying "tf1" to "tf2": file already exists}} 1 1 0 0} ! test fCmd-10.5 {file copy: comprehensive: dir to empty dir} {notRoot} { cleanup file mkdir td1 file mkdir [file join td2 td1] --- 897,903 ---- file copy -force tfs4 tfd4 list [lsort [glob tf*]] $msg [file writable tfd1] [file writable tfd2] [file writable tfd3] [file writable tfd4] } {{tf1 tf2 tfd1 tfd2 tfd3 tfd4 tfs1 tfs2 tfs3 tfs4} {1 {error copying "tf1" to "tf2": file already exists}} 1 1 0 0} ! test fCmd-10.5 {file copy: comprehensive: dir to empty dir} {notRoot testchmod} { cleanup file mkdir td1 file mkdir [file join td2 td1] *************** *** 936,942 **** list [lsort [glob td*]] $a1 $a2 $a3 $a4 $a5 } [subst {{td1 td2 tdd1 tdd2 tdd3 tdd4 tds1 tds2 tds3 tds4} {1 {error copying "td1" to "[file join td2 td1]": file already exists}} {1 {error copying "tds1" to "[file join tdd1 tds1]": file already exists}} 1 1 1}] test fCmd-10.6 {file copy: comprehensive: dir to non-empty dir} \ ! {notRoot unixOrPc} { cleanup file mkdir tds1 file mkdir tds2 --- 923,929 ---- list [lsort [glob td*]] $a1 $a2 $a3 $a4 $a5 } [subst {{td1 td2 tdd1 tdd2 tdd3 tdd4 tds1 tds2 tds3 tds4} {1 {error copying "td1" to "[file join td2 td1]": file already exists}} {1 {error copying "tds1" to "[file join tdd1 tds1]": file already exists}} 1 1 1}] test fCmd-10.6 {file copy: comprehensive: dir to non-empty dir} \ ! {notRoot unixOrPc testchmod} { cleanup file mkdir tds1 file mkdir tds2 *************** *** 947,953 **** set a2 [list [catch {file copy -force tds2 tdd2} msg] $msg] list [lsort [glob td*]] $a1 $a2 [file writable tds1] [file writable tds2] } [subst {{tdd1 tdd2 tds1 tds2} {1 {error copying "tds1" to "[file join tdd1 tds1]": file already exists}} {1 {error copying "tds2" to "[file join tdd2 tds2]": file already exists}} 1 0}] ! test fCmd-10.7 {file rename: comprehensive: file to new name and dir} {notRoot} { cleanup createfile tf1 createfile tf2 --- 934,940 ---- set a2 [list [catch {file copy -force tds2 tdd2} msg] $msg] list [lsort [glob td*]] $a1 $a2 [file writable tds1] [file writable tds2] } [subst {{tdd1 tdd2 tds1 tds2} {1 {error copying "tds1" to "[file join tdd1 tds1]": file already exists}} {1 {error copying "tds2" to "[file join tdd2 tds2]": file already exists}} 1 0}] ! test fCmd-10.7 {file rename: comprehensive: file to new name and dir} {notRoot testchmod} { cleanup createfile tf1 createfile tf2 *************** *** 955,965 **** testchmod 444 tf2 file copy tf1 [file join td1 tf3] file copy tf2 [file join td1 tf4] ! list [lsort [glob tf*]] [lsort [glob [file join td1 t*]]] \ [file writable [file join td1 tf3]] [file writable [file join td1 tf4]] } [subst {{tf1 tf2} {[file join td1 tf3] [file join td1 tf4]} 1 0}] test fCmd-10.8 {file rename: comprehensive: dir to new name and dir} \ ! {notRoot unixOrPc} { cleanup file mkdir td1 file mkdir td2 --- 942,952 ---- testchmod 444 tf2 file copy tf1 [file join td1 tf3] file copy tf2 [file join td1 tf4] ! list [lsort [glob tf*]] [lsort [glob -directory td1 t*]] \ [file writable [file join td1 tf3]] [file writable [file join td1 tf4]] } [subst {{tf1 tf2} {[file join td1 tf3] [file join td1 tf4]} 1 0}] test fCmd-10.8 {file rename: comprehensive: dir to new name and dir} \ ! {notRoot unixOrPc testchmod} { cleanup file mkdir td1 file mkdir td2 *************** *** 967,973 **** testchmod 555 td2 file copy td1 [file join td3 td3] file copy td2 [file join td3 td4] ! list [lsort [glob td*]] [lsort [glob [file join td3 t*]]] \ [file writable [file join td3 td3]] [file writable [file join td3 td4]] } [subst {{td1 td2 td3} {[file join td3 td3] [file join td3 td4]} 1 0}] test fCmd-10.9 {file copy: comprehensive: source and target incompatible} \ --- 954,960 ---- testchmod 555 td2 file copy td1 [file join td3 td3] file copy td2 [file join td3 td4] ! list [lsort [glob td*]] [lsort [glob -directory td3 t*]] \ [file writable [file join td3 td3]] [file writable [file join td3 td4]] } [subst {{td1 td2 td3} {[file join td3 td3] [file join td3 td4]} 1 0}] test fCmd-10.9 {file copy: comprehensive: source and target incompatible} \ *************** *** 2111,2117 **** set result } {1} ! test fCmd-27.2 {TclFileAttrsCmd - Tcl_TranslateFileName fails} { testsetplatform unix list [catch {file attributes ~_totally_bogus_user} msg] $msg [testsetplatform $platform] } {1 {user "_totally_bogus_user" doesn't exist} {}} --- 2098,2105 ---- set result } {1} ! test fCmd-27.2 {TclFileAttrsCmd - Tcl_TranslateFileName fails} {testsetplatform} { ! set platform [testgetplatform] testsetplatform unix list [catch {file attributes ~_totally_bogus_user} msg] $msg [testsetplatform $platform] } {1 {user "_totally_bogus_user" doesn't exist} {}} Index: tests/fileName.test =================================================================== RCS file: /cvsroot/tcl/tcl/tests/fileName.test,v retrieving revision 1.9 diff -c -r1.9 fileName.test *** tests/fileName.test 2000/09/29 01:12:15 1.9 --- tests/fileName.test 2001/03/16 17:08:15 *************** *** 17,894 **** namespace import -force ::tcltest::* } ! if {[info commands testsetplatform] == {}} { ! puts "This application hasn't been compiled with the \"testsetplatform\"" ! puts "command, so I can't test the filename conversion procedures." ! ::tcltest::cleanupTests ! return ! } global env ! set platform [testgetplatform] ! test filename-1.1 {Tcl_GetPathType: unix} { testsetplatform unix file pathtype / } absolute ! test filename-1.2 {Tcl_GetPathType: unix} { testsetplatform unix file pathtype /foo } absolute ! test filename-1.3 {Tcl_GetPathType: unix} { testsetplatform unix file pathtype foo } relative ! test filename-1.4 {Tcl_GetPathType: unix} { testsetplatform unix file pathtype c:/foo } relative ! test filename-1.5 {Tcl_GetPathType: unix} { testsetplatform unix file pathtype ~ } absolute ! test filename-1.6 {Tcl_GetPathType: unix} { testsetplatform unix file pathtype ~/foo } absolute ! test filename-1.7 {Tcl_GetPathType: unix} { testsetplatform unix file pathtype ~foo } absolute ! test filename-1.8 {Tcl_GetPathType: unix} { testsetplatform unix file pathtype ./~foo } relative ! test filename-2.1 {Tcl_GetPathType: mac, denerate names} { testsetplatform mac file pathtype / } relative ! test filename-2.2 {Tcl_GetPathType: mac, denerate names} { testsetplatform mac file pathtype /. } relative ! test filename-2.3 {Tcl_GetPathType: mac, denerate names} { testsetplatform mac file pathtype /.. } relative ! test filename-2.4 {Tcl_GetPathType: mac, denerate names} { testsetplatform mac file pathtype //.// } relative ! test filename-2.5 {Tcl_GetPathType: mac, denerate names} { testsetplatform mac file pathtype //.//../. } relative ! test filename-2.6 {Tcl_GetPathType: mac, tilde names} { testsetplatform mac file pathtype ~ } absolute ! test filename-2.7 {Tcl_GetPathType: mac, tilde names} { testsetplatform mac file pathtype ~: } absolute ! test filename-2.8 {Tcl_GetPathType: mac, tilde names} { testsetplatform mac file pathtype ~:foo } absolute ! test filename-2.9 {Tcl_GetPathType: mac, tilde names} { testsetplatform mac file pathtype ~/ } absolute ! test filename-2.10 {Tcl_GetPathType: mac, tilde names} { testsetplatform mac file pathtype ~/foo } absolute ! test filename-2.11 {Tcl_GetPathType: mac, unix-style names} { testsetplatform mac file pathtype /foo } absolute ! test filename-2.12 {Tcl_GetPathType: mac, unix-style names} { testsetplatform mac file pathtype /./foo } absolute ! test filename-2.13 {Tcl_GetPathType: mac, unix-style names} { testsetplatform mac file pathtype /..//./foo } absolute ! test filename-2.14 {Tcl_GetPathType: mac, unix-style names} { testsetplatform mac file pathtype /foo/bar } absolute ! test filename-2.15 {Tcl_GetPathType: mac, unix-style names} { testsetplatform mac file pathtype foo/bar } relative ! test filename-2.16 {Tcl_GetPathType: mac, mac-style names} { testsetplatform mac file pathtype : } relative ! test filename-2.17 {Tcl_GetPathType: mac, mac-style names} { testsetplatform mac file pathtype :foo } relative ! test filename-2.18 {Tcl_GetPathType: mac, mac-style names} { testsetplatform mac file pathtype foo: } absolute ! test filename-2.19 {Tcl_GetPathType: mac, mac-style names} { testsetplatform mac file pathtype foo:bar } absolute ! test filename-2.20 {Tcl_GetPathType: mac, mac-style names} { testsetplatform mac file pathtype :foo:bar } relative ! test filename-2.21 {Tcl_GetPathType: mac, mac-style names} { testsetplatform mac file pathtype ::foo:bar } relative ! test filename-2.22 {Tcl_GetPathType: mac, mac-style names} { testsetplatform mac file pathtype ~foo } absolute ! test filename-2.23 {Tcl_GetPathType: mac, mac-style names} { testsetplatform mac file pathtype :~foo } relative ! test filename-2.24 {Tcl_GetPathType: mac, mac-style names} { testsetplatform mac file pathtype ~foo: } absolute ! test filename-2.25 {Tcl_GetPathType: mac, mac-style names} { testsetplatform mac file pathtype foo/bar: } absolute ! test filename-2.26 {Tcl_GetPathType: mac, mac-style names} { testsetplatform mac file pathtype /foo: } absolute ! test filename-2.27 {Tcl_GetPathType: mac, mac-style names} { testsetplatform mac file pathtype foo } relative ! test filename-3.1 {Tcl_GetPathType: windows} { testsetplatform windows file pathtype / } volumerelative ! test filename-3.2 {Tcl_GetPathType: windows} { testsetplatform windows file pathtype \\ } volumerelative ! test filename-3.3 {Tcl_GetPathType: windows} { testsetplatform windows file pathtype /foo } volumerelative ! test filename-3.4 {Tcl_GetPathType: windows} { testsetplatform windows file pathtype \\foo } volumerelative ! test filename-3.5 {Tcl_GetPathType: windows} { testsetplatform windows file pathtype c:/ } absolute ! test filename-3.6 {Tcl_GetPathType: windows} { testsetplatform windows file pathtype c:\\ } absolute ! test filename-3.7 {Tcl_GetPathType: windows} { testsetplatform windows file pathtype c:/foo } absolute ! test filename-3.8 {Tcl_GetPathType: windows} { testsetplatform windows file pathtype c:\\foo } absolute ! test filename-3.9 {Tcl_GetPathType: windows} { testsetplatform windows file pathtype c: } volumerelative ! test filename-3.10 {Tcl_GetPathType: windows} { testsetplatform windows file pathtype c:foo } volumerelative ! test filename-3.11 {Tcl_GetPathType: windows} { testsetplatform windows file pathtype foo } relative ! test filename-3.12 {Tcl_GetPathType: windows} { testsetplatform windows file pathtype //foo/bar } absolute ! test filename-3.13 {Tcl_GetPathType: windows} { testsetplatform windows file pathtype ~foo } absolute ! test filename-3.14 {Tcl_GetPathType: windows} { testsetplatform windows file pathtype ~ } absolute ! test filename-3.15 {Tcl_GetPathType: windows} { testsetplatform windows file pathtype ~/foo } absolute ! test filename-3.16 {Tcl_GetPathType: windows} { testsetplatform windows file pathtype ./~foo } relative ! test filename-4.1 {Tcl_SplitPath: unix} { testsetplatform unix file split / } {/} ! test filename-4.2 {Tcl_SplitPath: unix} { testsetplatform unix file split /foo } {/ foo} ! test filename-4.3 {Tcl_SplitPath: unix} { testsetplatform unix file split /foo/bar } {/ foo bar} ! test filename-4.4 {Tcl_SplitPath: unix} { testsetplatform unix file split /foo/bar/baz } {/ foo bar baz} ! test filename-4.5 {Tcl_SplitPath: unix} { testsetplatform unix file split foo/bar } {foo bar} ! test filename-4.6 {Tcl_SplitPath: unix} { testsetplatform unix file split ./foo/bar } {. foo bar} ! test filename-4.7 {Tcl_SplitPath: unix} { testsetplatform unix file split /foo/../././foo/bar } {/ foo .. . . foo bar} ! test filename-4.8 {Tcl_SplitPath: unix} { testsetplatform unix file split ../foo/bar } {.. foo bar} ! test filename-4.9 {Tcl_SplitPath: unix} { testsetplatform unix file split {} } {} ! test filename-4.10 {Tcl_SplitPath: unix} { testsetplatform unix file split . } {.} ! test filename-4.11 {Tcl_SplitPath: unix} { testsetplatform unix file split ../ } {..} ! test filename-4.12 {Tcl_SplitPath: unix} { testsetplatform unix file split ../.. } {.. ..} ! test filename-4.13 {Tcl_SplitPath: unix} { testsetplatform unix file split //foo } {/ foo} ! test filename-4.14 {Tcl_SplitPath: unix} { testsetplatform unix file split foo//bar } {foo bar} ! test filename-4.15 {Tcl_SplitPath: unix} { testsetplatform unix file split ~foo } {~foo} ! test filename-4.16 {Tcl_SplitPath: unix} { testsetplatform unix file split ~foo/~bar } {~foo ./~bar} ! test filename-4.17 {Tcl_SplitPath: unix} { testsetplatform unix file split ~foo/~bar/~baz } {~foo ./~bar ./~baz} ! test filename-4.18 {Tcl_SplitPath: unix} { testsetplatform unix file split foo/bar~/baz } {foo bar~ baz} ! test filename-5.1 {Tcl_SplitPath: mac} { testsetplatform mac file split a:b } {a: b} ! test filename-5.2 {Tcl_SplitPath: mac} { testsetplatform mac file split a:b:c } {a: b c} ! test filename-5.3 {Tcl_SplitPath: mac} { testsetplatform mac file split a:b:c: } {a: b c} ! test filename-5.4 {Tcl_SplitPath: mac} { testsetplatform mac file split a: } {a:} ! test filename-5.5 {Tcl_SplitPath: mac} { testsetplatform mac file split a:: } {a: ::} ! test filename-5.6 {Tcl_SplitPath: mac} { testsetplatform mac file split a::: } {a: :: ::} ! test filename-5.7 {Tcl_SplitPath: mac} { testsetplatform mac file split :a } {a} ! test filename-5.8 {Tcl_SplitPath: mac} { testsetplatform mac file split :a:: } {a ::} ! test filename-5.9 {Tcl_SplitPath: mac} { testsetplatform mac file split : } {:} ! test filename-5.10 {Tcl_SplitPath: mac} { testsetplatform mac file split :: } {::} ! test filename-5.11 {Tcl_SplitPath: mac} { testsetplatform mac file split ::: } {:: ::} ! test filename-5.12 {Tcl_SplitPath: mac} { testsetplatform mac file split a:::b } {a: :: :: b} ! test filename-5.13 {Tcl_SplitPath: mac} { testsetplatform mac file split /a:b } {/a: b} ! test filename-5.14 {Tcl_SplitPath: mac} { testsetplatform mac file split ~: } {~:} ! test filename-5.15 {Tcl_SplitPath: mac} { testsetplatform mac file split ~/: } {~/:} ! test filename-5.16 {Tcl_SplitPath: mac} { testsetplatform mac file split ~:foo } {~: foo} ! test filename-5.17 {Tcl_SplitPath: mac} { testsetplatform mac file split ~/foo } {~: foo} ! test filename-5.18 {Tcl_SplitPath: mac} { testsetplatform mac file split ~foo: } {~foo:} ! test filename-5.19 {Tcl_SplitPath: mac} { testsetplatform mac file split a:~foo } {a: :~foo} ! test filename-5.20 {Tcl_SplitPath: mac} { testsetplatform mac file split / } {:/} ! test filename-5.21 {Tcl_SplitPath: mac} { testsetplatform mac file split a:b/c } {a: :b/c} ! test filename-5.22 {Tcl_SplitPath: mac} { testsetplatform mac file split /foo } {foo:} ! test filename-5.23 {Tcl_SplitPath: mac} { testsetplatform mac file split /a/b } {a: b} ! test filename-5.24 {Tcl_SplitPath: mac} { testsetplatform mac file split /a/b/foo } {a: b foo} ! test filename-5.25 {Tcl_SplitPath: mac} { testsetplatform mac file split a/b } {a b} ! test filename-5.26 {Tcl_SplitPath: mac} { testsetplatform mac file split ./foo/bar } {: foo bar} ! test filename-5.27 {Tcl_SplitPath: mac} { testsetplatform mac file split ../foo/bar } {:: foo bar} ! test filename-5.28 {Tcl_SplitPath: mac} { testsetplatform mac file split {} } {} ! test filename-5.29 {Tcl_SplitPath: mac} { testsetplatform mac file split . } {:} ! test filename-5.30 {Tcl_SplitPath: mac} { testsetplatform mac file split ././ } {: :} ! test filename-5.31 {Tcl_SplitPath: mac} { testsetplatform mac file split ././. } {: : :} ! test filename-5.32 {Tcl_SplitPath: mac} { testsetplatform mac file split ../ } {::} ! test filename-5.33 {Tcl_SplitPath: mac} { testsetplatform mac file split .. } {::} ! test filename-5.34 {Tcl_SplitPath: mac} { testsetplatform mac file split ../.. } {:: ::} ! test filename-5.35 {Tcl_SplitPath: mac} { testsetplatform mac file split //foo } {foo:} ! test filename-5.36 {Tcl_SplitPath: mac} { testsetplatform mac file split foo//bar } {foo bar} ! test filename-5.37 {Tcl_SplitPath: mac} { testsetplatform mac file split ~foo } {~foo:} ! test filename-5.38 {Tcl_SplitPath: mac} { testsetplatform mac file split ~ } {~:} ! test filename-5.39 {Tcl_SplitPath: mac} { testsetplatform mac file split foo } {foo} ! test filename-5.40 {Tcl_SplitPath: mac} { testsetplatform mac file split ~/ } {~:} ! test filename-5.41 {Tcl_SplitPath: mac} { testsetplatform mac file split ~foo/~bar } {~foo: :~bar} ! test filename-5.42 {Tcl_SplitPath: mac} { testsetplatform mac file split ~foo/~bar/~baz } {~foo: :~bar :~baz} ! test filename-5.43 {Tcl_SplitPath: mac} { testsetplatform mac file split foo/bar~/baz } {foo bar~ baz} ! test filename-5.44 {Tcl_SplitPath: mac} { testsetplatform mac file split a/../b } {a :: b} ! test filename-5.45 {Tcl_SplitPath: mac} { testsetplatform mac file split a/../../b } {a :: :: b} ! test filename-5.46 {Tcl_SplitPath: mac} { testsetplatform mac file split a/.././../b } {a :: : :: b} ! test filename-5.47 {Tcl_SplitPath: mac} { testsetplatform mac file split /../bar } {bar:} ! test filename-5.48 {Tcl_SplitPath: mac} { testsetplatform mac file split /./bar } {bar:} ! test filename-5.49 {Tcl_SplitPath: mac} { testsetplatform mac file split //.//.././bar } {bar:} ! test filename-5.50 {Tcl_SplitPath: mac} { testsetplatform mac file split /.. } {:/..} ! test filename-5.51 {Tcl_SplitPath: mac} { testsetplatform mac file split //.//.././ } {://.//.././} ! test filename-6.1 {Tcl_SplitPath: win} { testsetplatform win file split / } {/} ! test filename-6.2 {Tcl_SplitPath: win} { testsetplatform win file split /foo } {/ foo} ! test filename-6.3 {Tcl_SplitPath: win} { testsetplatform win file split /foo/bar } {/ foo bar} ! test filename-6.4 {Tcl_SplitPath: win} { testsetplatform win file split /foo/bar/baz } {/ foo bar baz} ! test filename-6.5 {Tcl_SplitPath: win} { testsetplatform win file split foo/bar } {foo bar} ! test filename-6.6 {Tcl_SplitPath: win} { testsetplatform win file split ./foo/bar } {. foo bar} ! test filename-6.7 {Tcl_SplitPath: win} { testsetplatform win file split /foo/../././foo/bar } {/ foo .. . . foo bar} ! test filename-6.8 {Tcl_SplitPath: win} { testsetplatform win file split ../foo/bar } {.. foo bar} ! test filename-6.9 {Tcl_SplitPath: win} { testsetplatform win file split {} } {} ! test filename-6.10 {Tcl_SplitPath: win} { testsetplatform win file split . } {.} ! test filename-6.11 {Tcl_SplitPath: win} { testsetplatform win file split ../ } {..} ! test filename-6.12 {Tcl_SplitPath: win} { testsetplatform win file split ../.. } {.. ..} ! test filename-6.13 {Tcl_SplitPath: win} { testsetplatform win file split //foo } {/ foo} ! test filename-6.14 {Tcl_SplitPath: win} { testsetplatform win file split foo//bar } {foo bar} ! test filename-6.15 {Tcl_SplitPath: win} { testsetplatform win file split /\\/foo//bar } {//foo/bar} ! test filename-6.16 {Tcl_SplitPath: win} { testsetplatform win file split /\\/foo//bar } {//foo/bar} ! test filename-6.17 {Tcl_SplitPath: win} { testsetplatform win file split /\\/foo//bar } {//foo/bar} ! test filename-6.18 {Tcl_SplitPath: win} { testsetplatform win file split \\\\foo\\bar } {//foo/bar} ! test filename-6.19 {Tcl_SplitPath: win} { testsetplatform win file split \\\\foo\\bar/baz } {//foo/bar baz} ! test filename-6.20 {Tcl_SplitPath: win} { testsetplatform win file split c:/foo } {c:/ foo} ! test filename-6.21 {Tcl_SplitPath: win} { testsetplatform win file split c:foo } {c: foo} ! test filename-6.22 {Tcl_SplitPath: win} { testsetplatform win file split c: } {c:} ! test filename-6.23 {Tcl_SplitPath: win} { testsetplatform win file split c:\\ } {c:/} ! test filename-6.24 {Tcl_SplitPath: win} { testsetplatform win file split c:/ } {c:/} ! test filename-6.25 {Tcl_SplitPath: win} { testsetplatform win file split c:/./.. } {c:/ . ..} ! test filename-6.26 {Tcl_SplitPath: win} { testsetplatform win file split ~foo } {~foo} ! test filename-6.27 {Tcl_SplitPath: win} { testsetplatform win file split ~foo/~bar } {~foo ./~bar} ! test filename-6.28 {Tcl_SplitPath: win} { testsetplatform win file split ~foo/~bar/~baz } {~foo ./~bar ./~baz} ! test filename-6.29 {Tcl_SplitPath: win} { testsetplatform win file split foo/bar~/baz } {foo bar~ baz} ! test filename-6.30 {Tcl_SplitPath: win} { testsetplatform win file split c:~foo } {c: ./~foo} ! test filename-7.1 {Tcl_JoinPath: unix} { testsetplatform unix file join / a } {/a} ! test filename-7.2 {Tcl_JoinPath: unix} { testsetplatform unix file join a b } {a/b} ! test filename-7.3 {Tcl_JoinPath: unix} { testsetplatform unix file join /a c /b d } {/b/d} ! test filename-7.4 {Tcl_JoinPath: unix} { testsetplatform unix file join / } {/} ! test filename-7.5 {Tcl_JoinPath: unix} { testsetplatform unix file join a } {a} ! test filename-7.6 {Tcl_JoinPath: unix} { testsetplatform unix file join {} } {} ! test filename-7.7 {Tcl_JoinPath: unix} { testsetplatform unix file join /a/ b } {/a/b} ! test filename-7.8 {Tcl_JoinPath: unix} { testsetplatform unix file join /a// b } {/a/b} ! test filename-7.9 {Tcl_JoinPath: unix} { testsetplatform unix file join /a/./../. b } {/a/./.././b} ! test filename-7.10 {Tcl_JoinPath: unix} { testsetplatform unix file join ~ a } {~/a} ! test filename-7.11 {Tcl_JoinPath: unix} { testsetplatform unix file join ~a ~b } {~b} ! test filename-7.12 {Tcl_JoinPath: unix} { testsetplatform unix file join ./~a b } {./~a/b} ! test filename-7.13 {Tcl_JoinPath: unix} { testsetplatform unix file join ./~a ~b } {~b} ! test filename-7.14 {Tcl_JoinPath: unix} { testsetplatform unix file join ./~a ./~b } {./~a/~b} ! test filename-7.15 {Tcl_JoinPath: unix} { testsetplatform unix file join a . b } {a/./b} ! test filename-7.16 {Tcl_JoinPath: unix} { testsetplatform unix file join a . ./~b } {a/./~b} ! test filename-7.17 {Tcl_JoinPath: unix} { testsetplatform unix file join //a b } {/a/b} ! test filename-7.18 {Tcl_JoinPath: unix} { testsetplatform unix file join /// a b } {/a/b} ! test filename-8.1 {Tcl_JoinPath: mac} { testsetplatform mac file join a b } {:a:b} ! test filename-8.2 {Tcl_JoinPath: mac} { testsetplatform mac file join :a b } {:a:b} ! test filename-8.3 {Tcl_JoinPath: mac} { testsetplatform mac file join a b: } {b:} ! test filename-8.4 {Tcl_JoinPath: mac} { testsetplatform mac file join a: :b } {a:b} ! test filename-8.5 {Tcl_JoinPath: mac} { testsetplatform mac file join a: :b: } {a:b} ! test filename-8.6 {Tcl_JoinPath: mac} { testsetplatform mac file join a :: b } {:a::b} ! test filename-8.7 {Tcl_JoinPath: mac} { testsetplatform mac file join a :: :: b } {:a:::b} ! test filename-8.8 {Tcl_JoinPath: mac} { testsetplatform mac file join a ::: b } {:a:::b} ! test filename-8.9 {Tcl_JoinPath: mac} { testsetplatform mac file join a: b: } {b:} ! test filename-8.10 {Tcl_JoinPath: mac} { testsetplatform mac file join /a/b } {a:b} ! test filename-8.11 {Tcl_JoinPath: mac} { testsetplatform mac file join /a/b c/d } {a:b:c:d} ! test filename-8.12 {Tcl_JoinPath: mac} { testsetplatform mac file join /a/b :c:d } {a:b:c:d} ! test filename-8.13 {Tcl_JoinPath: mac} { testsetplatform mac file join ~ foo } {~:foo} ! test filename-8.14 {Tcl_JoinPath: mac} { testsetplatform mac file join :: :: } {:::} ! test filename-8.15 {Tcl_JoinPath: mac} { testsetplatform mac file join a: :: } {a::} ! test filename-8.16 {Tcl_JoinPath: mac} { testsetplatform mac file join a {} b } {:a:b} ! test filename-8.17 {Tcl_JoinPath: mac} { testsetplatform mac file join a::: b } {a:::b} ! test filename-8.18 {Tcl_JoinPath: mac} { testsetplatform mac file join a : : : } {:a} ! test filename-8.19 {Tcl_JoinPath: mac} { testsetplatform mac file join : } {:} ! test filename-8.20 {Tcl_JoinPath: mac} { testsetplatform mac file join : a } {:a} ! test filename-8.21 {Tcl_JoinPath: mac} { testsetplatform mac file join a: :b/c } {a:b/c} ! test filename-8.22 {Tcl_JoinPath: mac} { testsetplatform mac file join :a :b/c } {:a:b/c} ! test filename-9.1 {Tcl_JoinPath: win} { testsetplatform win file join a b } {a/b} ! test filename-9.2 {Tcl_JoinPath: win} { testsetplatform win file join /a b } {/a/b} ! test filename-9.3 {Tcl_JoinPath: win} { testsetplatform win file join /a /b } {/b} ! test filename-9.4 {Tcl_JoinPath: win} { testsetplatform win file join c: foo } {c:foo} ! test filename-9.5 {Tcl_JoinPath: win} { testsetplatform win file join c:/ foo } {c:/foo} ! test filename-9.6 {Tcl_JoinPath: win} { testsetplatform win file join c:\\bar foo } {c:/bar/foo} ! test filename-9.7 {Tcl_JoinPath: win} { testsetplatform win file join /foo c:bar } {c:bar} ! test filename-9.8 {Tcl_JoinPath: win} { testsetplatform win file join ///host//share dir } {//host/share/dir} ! test filename-9.9 {Tcl_JoinPath: win} { testsetplatform win file join ~ foo } {~/foo} ! test filename-9.10 {Tcl_JoinPath: win} { testsetplatform win file join ~/~foo } {~/~foo} ! test filename-9.11 {Tcl_JoinPath: win} { testsetplatform win file join ~ ./~foo } {~/~foo} ! test filename-9.12 {Tcl_JoinPath: win} { testsetplatform win file join / ~foo } {~foo} ! test filename-9.13 {Tcl_JoinPath: win} { testsetplatform win file join ./a/ b c } {./a/b/c} ! test filename-9.14 {Tcl_JoinPath: win} { testsetplatform win file join ./~a/ b c } {./~a/b/c} ! test filename-9.15 {Tcl_JoinPath: win} { testsetplatform win file join // host share path } {/host/share/path} ! test filename-9.16 {Tcl_JoinPath: win} { testsetplatform win file join foo . bar } {foo/./bar} ! test filename-9.17 {Tcl_JoinPath: win} { testsetplatform win file join foo .. bar } {foo/../bar} ! test filename-9.18 {Tcl_JoinPath: win} { testsetplatform win file join foo/./bar } {foo/./bar} ! test filename-10.1 {Tcl_TranslateFileName} { testsetplatform unix list [catch {testtranslatefilename foo} msg] $msg } {0 foo} ! test filename-10.2 {Tcl_TranslateFileName} { testsetplatform windows list [catch {testtranslatefilename {c:/foo}} msg] $msg } {0 {c:\foo}} ! test filename-10.3 {Tcl_TranslateFileName} { testsetplatform windows list [catch {testtranslatefilename {c:/\\foo/}} msg] $msg } {0 {c:\foo}} ! test filename-10.4 {Tcl_TranslateFileName} { testsetplatform mac list [catch {testtranslatefilename foo} msg] $msg } {0 :foo} ! test filename-10.5 {Tcl_TranslateFileName} { testsetplatform mac list [catch {testtranslatefilename :~foo} msg] $msg } {0 :~foo} ! test filename-10.6 {Tcl_TranslateFileName} { global env set temp $env(HOME) set env(HOME) "/home/test" --- 17,892 ---- namespace import -force ::tcltest::* } ! tcltest::testConstraint testsetplatform [string equal testsetplatform [info commands testsetplatform]] ! tcltest::testConstraint testtranslatefilename [string equal testtranslatefilename [info commands testtranslatefilename]] global env ! if {[tcltest::testConstraint testsetplatform]} { ! set platform [testgetplatform] ! } ! test filename-1.1 {Tcl_GetPathType: unix} {testsetplatform} { testsetplatform unix file pathtype / } absolute ! test filename-1.2 {Tcl_GetPathType: unix} {testsetplatform} { testsetplatform unix file pathtype /foo } absolute ! test filename-1.3 {Tcl_GetPathType: unix} {testsetplatform} { testsetplatform unix file pathtype foo } relative ! test filename-1.4 {Tcl_GetPathType: unix} {testsetplatform} { testsetplatform unix file pathtype c:/foo } relative ! test filename-1.5 {Tcl_GetPathType: unix} {testsetplatform} { testsetplatform unix file pathtype ~ } absolute ! test filename-1.6 {Tcl_GetPathType: unix} {testsetplatform} { testsetplatform unix file pathtype ~/foo } absolute ! test filename-1.7 {Tcl_GetPathType: unix} {testsetplatform} { testsetplatform unix file pathtype ~foo } absolute ! test filename-1.8 {Tcl_GetPathType: unix} {testsetplatform} { testsetplatform unix file pathtype ./~foo } relative ! test filename-2.1 {Tcl_GetPathType: mac, denerate names} {testsetplatform} { testsetplatform mac file pathtype / } relative ! test filename-2.2 {Tcl_GetPathType: mac, denerate names} {testsetplatform} { testsetplatform mac file pathtype /. } relative ! test filename-2.3 {Tcl_GetPathType: mac, denerate names} {testsetplatform} { testsetplatform mac file pathtype /.. } relative ! test filename-2.4 {Tcl_GetPathType: mac, denerate names} {testsetplatform} { testsetplatform mac file pathtype //.// } relative ! test filename-2.5 {Tcl_GetPathType: mac, denerate names} {testsetplatform} { testsetplatform mac file pathtype //.//../. } relative ! test filename-2.6 {Tcl_GetPathType: mac, tilde names} {testsetplatform} { testsetplatform mac file pathtype ~ } absolute ! test filename-2.7 {Tcl_GetPathType: mac, tilde names} {testsetplatform} { testsetplatform mac file pathtype ~: } absolute ! test filename-2.8 {Tcl_GetPathType: mac, tilde names} {testsetplatform} { testsetplatform mac file pathtype ~:foo } absolute ! test filename-2.9 {Tcl_GetPathType: mac, tilde names} {testsetplatform} { testsetplatform mac file pathtype ~/ } absolute ! test filename-2.10 {Tcl_GetPathType: mac, tilde names} {testsetplatform} { testsetplatform mac file pathtype ~/foo } absolute ! test filename-2.11 {Tcl_GetPathType: mac, unix-style names} {testsetplatform} { testsetplatform mac file pathtype /foo } absolute ! test filename-2.12 {Tcl_GetPathType: mac, unix-style names} {testsetplatform} { testsetplatform mac file pathtype /./foo } absolute ! test filename-2.13 {Tcl_GetPathType: mac, unix-style names} {testsetplatform} { testsetplatform mac file pathtype /..//./foo } absolute ! test filename-2.14 {Tcl_GetPathType: mac, unix-style names} {testsetplatform} { testsetplatform mac file pathtype /foo/bar } absolute ! test filename-2.15 {Tcl_GetPathType: mac, unix-style names} {testsetplatform} { testsetplatform mac file pathtype foo/bar } relative ! test filename-2.16 {Tcl_GetPathType: mac, mac-style names} {testsetplatform} { testsetplatform mac file pathtype : } relative ! test filename-2.17 {Tcl_GetPathType: mac, mac-style names} {testsetplatform} { testsetplatform mac file pathtype :foo } relative ! test filename-2.18 {Tcl_GetPathType: mac, mac-style names} {testsetplatform} { testsetplatform mac file pathtype foo: } absolute ! test filename-2.19 {Tcl_GetPathType: mac, mac-style names} {testsetplatform} { testsetplatform mac file pathtype foo:bar } absolute ! test filename-2.20 {Tcl_GetPathType: mac, mac-style names} {testsetplatform} { testsetplatform mac file pathtype :foo:bar } relative ! test filename-2.21 {Tcl_GetPathType: mac, mac-style names} {testsetplatform} { testsetplatform mac file pathtype ::foo:bar } relative ! test filename-2.22 {Tcl_GetPathType: mac, mac-style names} {testsetplatform} { testsetplatform mac file pathtype ~foo } absolute ! test filename-2.23 {Tcl_GetPathType: mac, mac-style names} {testsetplatform} { testsetplatform mac file pathtype :~foo } relative ! test filename-2.24 {Tcl_GetPathType: mac, mac-style names} {testsetplatform} { testsetplatform mac file pathtype ~foo: } absolute ! test filename-2.25 {Tcl_GetPathType: mac, mac-style names} {testsetplatform} { testsetplatform mac file pathtype foo/bar: } absolute ! test filename-2.26 {Tcl_GetPathType: mac, mac-style names} {testsetplatform} { testsetplatform mac file pathtype /foo: } absolute ! test filename-2.27 {Tcl_GetPathType: mac, mac-style names} {testsetplatform} { testsetplatform mac file pathtype foo } relative ! test filename-3.1 {Tcl_GetPathType: windows} {testsetplatform} { testsetplatform windows file pathtype / } volumerelative ! test filename-3.2 {Tcl_GetPathType: windows} {testsetplatform} { testsetplatform windows file pathtype \\ } volumerelative ! test filename-3.3 {Tcl_GetPathType: windows} {testsetplatform} { testsetplatform windows file pathtype /foo } volumerelative ! test filename-3.4 {Tcl_GetPathType: windows} {testsetplatform} { testsetplatform windows file pathtype \\foo } volumerelative ! test filename-3.5 {Tcl_GetPathType: windows} {testsetplatform} { testsetplatform windows file pathtype c:/ } absolute ! test filename-3.6 {Tcl_GetPathType: windows} {testsetplatform} { testsetplatform windows file pathtype c:\\ } absolute ! test filename-3.7 {Tcl_GetPathType: windows} {testsetplatform} { testsetplatform windows file pathtype c:/foo } absolute ! test filename-3.8 {Tcl_GetPathType: windows} {testsetplatform} { testsetplatform windows file pathtype c:\\foo } absolute ! test filename-3.9 {Tcl_GetPathType: windows} {testsetplatform} { testsetplatform windows file pathtype c: } volumerelative ! test filename-3.10 {Tcl_GetPathType: windows} {testsetplatform} { testsetplatform windows file pathtype c:foo } volumerelative ! test filename-3.11 {Tcl_GetPathType: windows} {testsetplatform} { testsetplatform windows file pathtype foo } relative ! test filename-3.12 {Tcl_GetPathType: windows} {testsetplatform} { testsetplatform windows file pathtype //foo/bar } absolute ! test filename-3.13 {Tcl_GetPathType: windows} {testsetplatform} { testsetplatform windows file pathtype ~foo } absolute ! test filename-3.14 {Tcl_GetPathType: windows} {testsetplatform} { testsetplatform windows file pathtype ~ } absolute ! test filename-3.15 {Tcl_GetPathType: windows} {testsetplatform} { testsetplatform windows file pathtype ~/foo } absolute ! test filename-3.16 {Tcl_GetPathType: windows} {testsetplatform} { testsetplatform windows file pathtype ./~foo } relative ! test filename-4.1 {Tcl_SplitPath: unix} {testsetplatform} { testsetplatform unix file split / } {/} ! test filename-4.2 {Tcl_SplitPath: unix} {testsetplatform} { testsetplatform unix file split /foo } {/ foo} ! test filename-4.3 {Tcl_SplitPath: unix} {testsetplatform} { testsetplatform unix file split /foo/bar } {/ foo bar} ! test filename-4.4 {Tcl_SplitPath: unix} {testsetplatform} { testsetplatform unix file split /foo/bar/baz } {/ foo bar baz} ! test filename-4.5 {Tcl_SplitPath: unix} {testsetplatform} { testsetplatform unix file split foo/bar } {foo bar} ! test filename-4.6 {Tcl_SplitPath: unix} {testsetplatform} { testsetplatform unix file split ./foo/bar } {. foo bar} ! test filename-4.7 {Tcl_SplitPath: unix} {testsetplatform} { testsetplatform unix file split /foo/../././foo/bar } {/ foo .. . . foo bar} ! test filename-4.8 {Tcl_SplitPath: unix} {testsetplatform} { testsetplatform unix file split ../foo/bar } {.. foo bar} ! test filename-4.9 {Tcl_SplitPath: unix} {testsetplatform} { testsetplatform unix file split {} } {} ! test filename-4.10 {Tcl_SplitPath: unix} {testsetplatform} { testsetplatform unix file split . } {.} ! test filename-4.11 {Tcl_SplitPath: unix} {testsetplatform} { testsetplatform unix file split ../ } {..} ! test filename-4.12 {Tcl_SplitPath: unix} {testsetplatform} { testsetplatform unix file split ../.. } {.. ..} ! test filename-4.13 {Tcl_SplitPath: unix} {testsetplatform} { testsetplatform unix file split //foo } {/ foo} ! test filename-4.14 {Tcl_SplitPath: unix} {testsetplatform} { testsetplatform unix file split foo//bar } {foo bar} ! test filename-4.15 {Tcl_SplitPath: unix} {testsetplatform} { testsetplatform unix file split ~foo } {~foo} ! test filename-4.16 {Tcl_SplitPath: unix} {testsetplatform} { testsetplatform unix file split ~foo/~bar } {~foo ./~bar} ! test filename-4.17 {Tcl_SplitPath: unix} {testsetplatform} { testsetplatform unix file split ~foo/~bar/~baz } {~foo ./~bar ./~baz} ! test filename-4.18 {Tcl_SplitPath: unix} {testsetplatform} { testsetplatform unix file split foo/bar~/baz } {foo bar~ baz} ! test filename-5.1 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split a:b } {a: b} ! test filename-5.2 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split a:b:c } {a: b c} ! test filename-5.3 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split a:b:c: } {a: b c} ! test filename-5.4 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split a: } {a:} ! test filename-5.5 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split a:: } {a: ::} ! test filename-5.6 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split a::: } {a: :: ::} ! test filename-5.7 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split :a } {a} ! test filename-5.8 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split :a:: } {a ::} ! test filename-5.9 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split : } {:} ! test filename-5.10 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split :: } {::} ! test filename-5.11 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split ::: } {:: ::} ! test filename-5.12 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split a:::b } {a: :: :: b} ! test filename-5.13 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split /a:b } {/a: b} ! test filename-5.14 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split ~: } {~:} ! test filename-5.15 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split ~/: } {~/:} ! test filename-5.16 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split ~:foo } {~: foo} ! test filename-5.17 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split ~/foo } {~: foo} ! test filename-5.18 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split ~foo: } {~foo:} ! test filename-5.19 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split a:~foo } {a: :~foo} ! test filename-5.20 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split / } {:/} ! test filename-5.21 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split a:b/c } {a: :b/c} ! test filename-5.22 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split /foo } {foo:} ! test filename-5.23 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split /a/b } {a: b} ! test filename-5.24 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split /a/b/foo } {a: b foo} ! test filename-5.25 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split a/b } {a b} ! test filename-5.26 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split ./foo/bar } {: foo bar} ! test filename-5.27 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split ../foo/bar } {:: foo bar} ! test filename-5.28 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split {} } {} ! test filename-5.29 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split . } {:} ! test filename-5.30 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split ././ } {: :} ! test filename-5.31 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split ././. } {: : :} ! test filename-5.32 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split ../ } {::} ! test filename-5.33 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split .. } {::} ! test filename-5.34 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split ../.. } {:: ::} ! test filename-5.35 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split //foo } {foo:} ! test filename-5.36 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split foo//bar } {foo bar} ! test filename-5.37 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split ~foo } {~foo:} ! test filename-5.38 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split ~ } {~:} ! test filename-5.39 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split foo } {foo} ! test filename-5.40 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split ~/ } {~:} ! test filename-5.41 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split ~foo/~bar } {~foo: :~bar} ! test filename-5.42 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split ~foo/~bar/~baz } {~foo: :~bar :~baz} ! test filename-5.43 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split foo/bar~/baz } {foo bar~ baz} ! test filename-5.44 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split a/../b } {a :: b} ! test filename-5.45 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split a/../../b } {a :: :: b} ! test filename-5.46 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split a/.././../b } {a :: : :: b} ! test filename-5.47 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split /../bar } {bar:} ! test filename-5.48 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split /./bar } {bar:} ! test filename-5.49 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split //.//.././bar } {bar:} ! test filename-5.50 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split /.. } {:/..} ! test filename-5.51 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split //.//.././ } {://.//.././} ! test filename-6.1 {Tcl_SplitPath: win} {testsetplatform} { testsetplatform win file split / } {/} ! test filename-6.2 {Tcl_SplitPath: win} {testsetplatform} { testsetplatform win file split /foo } {/ foo} ! test filename-6.3 {Tcl_SplitPath: win} {testsetplatform} { testsetplatform win file split /foo/bar } {/ foo bar} ! test filename-6.4 {Tcl_SplitPath: win} {testsetplatform} { testsetplatform win file split /foo/bar/baz } {/ foo bar baz} ! test filename-6.5 {Tcl_SplitPath: win} {testsetplatform} { testsetplatform win file split foo/bar } {foo bar} ! test filename-6.6 {Tcl_SplitPath: win} {testsetplatform} { testsetplatform win file split ./foo/bar } {. foo bar} ! test filename-6.7 {Tcl_SplitPath: win} {testsetplatform} { testsetplatform win file split /foo/../././foo/bar } {/ foo .. . . foo bar} ! test filename-6.8 {Tcl_SplitPath: win} {testsetplatform} { testsetplatform win file split ../foo/bar } {.. foo bar} ! test filename-6.9 {Tcl_SplitPath: win} {testsetplatform} { testsetplatform win file split {} } {} ! test filename-6.10 {Tcl_SplitPath: win} {testsetplatform} { testsetplatform win file split . } {.} ! test filename-6.11 {Tcl_SplitPath: win} {testsetplatform} { testsetplatform win file split ../ } {..} ! test filename-6.12 {Tcl_SplitPath: win} {testsetplatform} { testsetplatform win file split ../.. } {.. ..} ! test filename-6.13 {Tcl_SplitPath: win} {testsetplatform} { testsetplatform win file split //foo } {/ foo} ! test filename-6.14 {Tcl_SplitPath: win} {testsetplatform} { testsetplatform win file split foo//bar } {foo bar} ! test filename-6.15 {Tcl_SplitPath: win} {testsetplatform} { testsetplatform win file split /\\/foo//bar } {//foo/bar} ! test filename-6.16 {Tcl_SplitPath: win} {testsetplatform} { testsetplatform win file split /\\/foo//bar } {//foo/bar} ! test filename-6.17 {Tcl_SplitPath: win} {testsetplatform} { testsetplatform win file split /\\/foo//bar } {//foo/bar} ! test filename-6.18 {Tcl_SplitPath: win} {testsetplatform} { testsetplatform win file split \\\\foo\\bar } {//foo/bar} ! test filename-6.19 {Tcl_SplitPath: win} {testsetplatform} { testsetplatform win file split \\\\foo\\bar/baz } {//foo/bar baz} ! test filename-6.20 {Tcl_SplitPath: win} {testsetplatform} { testsetplatform win file split c:/foo } {c:/ foo} ! test filename-6.21 {Tcl_SplitPath: win} {testsetplatform} { testsetplatform win file split c:foo } {c: foo} ! test filename-6.22 {Tcl_SplitPath: win} {testsetplatform} { testsetplatform win file split c: } {c:} ! test filename-6.23 {Tcl_SplitPath: win} {testsetplatform} { testsetplatform win file split c:\\ } {c:/} ! test filename-6.24 {Tcl_SplitPath: win} {testsetplatform} { testsetplatform win file split c:/ } {c:/} ! test filename-6.25 {Tcl_SplitPath: win} {testsetplatform} { testsetplatform win file split c:/./.. } {c:/ . ..} ! test filename-6.26 {Tcl_SplitPath: win} {testsetplatform} { testsetplatform win file split ~foo } {~foo} ! test filename-6.27 {Tcl_SplitPath: win} {testsetplatform} { testsetplatform win file split ~foo/~bar } {~foo ./~bar} ! test filename-6.28 {Tcl_SplitPath: win} {testsetplatform} { testsetplatform win file split ~foo/~bar/~baz } {~foo ./~bar ./~baz} ! test filename-6.29 {Tcl_SplitPath: win} {testsetplatform} { testsetplatform win file split foo/bar~/baz } {foo bar~ baz} ! test filename-6.30 {Tcl_SplitPath: win} {testsetplatform} { testsetplatform win file split c:~foo } {c: ./~foo} ! test filename-7.1 {Tcl_JoinPath: unix} {testsetplatform} { testsetplatform unix file join / a } {/a} ! test filename-7.2 {Tcl_JoinPath: unix} {testsetplatform} { testsetplatform unix file join a b } {a/b} ! test filename-7.3 {Tcl_JoinPath: unix} {testsetplatform} { testsetplatform unix file join /a c /b d } {/b/d} ! test filename-7.4 {Tcl_JoinPath: unix} {testsetplatform} { testsetplatform unix file join / } {/} ! test filename-7.5 {Tcl_JoinPath: unix} {testsetplatform} { testsetplatform unix file join a } {a} ! test filename-7.6 {Tcl_JoinPath: unix} {testsetplatform} { testsetplatform unix file join {} } {} ! test filename-7.7 {Tcl_JoinPath: unix} {testsetplatform} { testsetplatform unix file join /a/ b } {/a/b} ! test filename-7.8 {Tcl_JoinPath: unix} {testsetplatform} { testsetplatform unix file join /a// b } {/a/b} ! test filename-7.9 {Tcl_JoinPath: unix} {testsetplatform} { testsetplatform unix file join /a/./../. b } {/a/./.././b} ! test filename-7.10 {Tcl_JoinPath: unix} {testsetplatform} { testsetplatform unix file join ~ a } {~/a} ! test filename-7.11 {Tcl_JoinPath: unix} {testsetplatform} { testsetplatform unix file join ~a ~b } {~b} ! test filename-7.12 {Tcl_JoinPath: unix} {testsetplatform} { testsetplatform unix file join ./~a b } {./~a/b} ! test filename-7.13 {Tcl_JoinPath: unix} {testsetplatform} { testsetplatform unix file join ./~a ~b } {~b} ! test filename-7.14 {Tcl_JoinPath: unix} {testsetplatform} { testsetplatform unix file join ./~a ./~b } {./~a/~b} ! test filename-7.15 {Tcl_JoinPath: unix} {testsetplatform} { testsetplatform unix file join a . b } {a/./b} ! test filename-7.16 {Tcl_JoinPath: unix} {testsetplatform} { testsetplatform unix file join a . ./~b } {a/./~b} ! test filename-7.17 {Tcl_JoinPath: unix} {testsetplatform} { testsetplatform unix file join //a b } {/a/b} ! test filename-7.18 {Tcl_JoinPath: unix} {testsetplatform} { testsetplatform unix file join /// a b } {/a/b} ! test filename-8.1 {Tcl_JoinPath: mac} {testsetplatform} { testsetplatform mac file join a b } {:a:b} ! test filename-8.2 {Tcl_JoinPath: mac} {testsetplatform} { testsetplatform mac file join :a b } {:a:b} ! test filename-8.3 {Tcl_JoinPath: mac} {testsetplatform} { testsetplatform mac file join a b: } {b:} ! test filename-8.4 {Tcl_JoinPath: mac} {testsetplatform} { testsetplatform mac file join a: :b } {a:b} ! test filename-8.5 {Tcl_JoinPath: mac} {testsetplatform} { testsetplatform mac file join a: :b: } {a:b} ! test filename-8.6 {Tcl_JoinPath: mac} {testsetplatform} { testsetplatform mac file join a :: b } {:a::b} ! test filename-8.7 {Tcl_JoinPath: mac} {testsetplatform} { testsetplatform mac file join a :: :: b } {:a:::b} ! test filename-8.8 {Tcl_JoinPath: mac} {testsetplatform} { testsetplatform mac file join a ::: b } {:a:::b} ! test filename-8.9 {Tcl_JoinPath: mac} {testsetplatform} { testsetplatform mac file join a: b: } {b:} ! test filename-8.10 {Tcl_JoinPath: mac} {testsetplatform} { testsetplatform mac file join /a/b } {a:b} ! test filename-8.11 {Tcl_JoinPath: mac} {testsetplatform} { testsetplatform mac file join /a/b c/d } {a:b:c:d} ! test filename-8.12 {Tcl_JoinPath: mac} {testsetplatform} { testsetplatform mac file join /a/b :c:d } {a:b:c:d} ! test filename-8.13 {Tcl_JoinPath: mac} {testsetplatform} { testsetplatform mac file join ~ foo } {~:foo} ! test filename-8.14 {Tcl_JoinPath: mac} {testsetplatform} { testsetplatform mac file join :: :: } {:::} ! test filename-8.15 {Tcl_JoinPath: mac} {testsetplatform} { testsetplatform mac file join a: :: } {a::} ! test filename-8.16 {Tcl_JoinPath: mac} {testsetplatform} { testsetplatform mac file join a {} b } {:a:b} ! test filename-8.17 {Tcl_JoinPath: mac} {testsetplatform} { testsetplatform mac file join a::: b } {a:::b} ! test filename-8.18 {Tcl_JoinPath: mac} {testsetplatform} { testsetplatform mac file join a : : : } {:a} ! test filename-8.19 {Tcl_JoinPath: mac} {testsetplatform} { testsetplatform mac file join : } {:} ! test filename-8.20 {Tcl_JoinPath: mac} {testsetplatform} { testsetplatform mac file join : a } {:a} ! test filename-8.21 {Tcl_JoinPath: mac} {testsetplatform} { testsetplatform mac file join a: :b/c } {a:b/c} ! test filename-8.22 {Tcl_JoinPath: mac} {testsetplatform} { testsetplatform mac file join :a :b/c } {:a:b/c} ! test filename-9.1 {Tcl_JoinPath: win} {testsetplatform} { testsetplatform win file join a b } {a/b} ! test filename-9.2 {Tcl_JoinPath: win} {testsetplatform} { testsetplatform win file join /a b } {/a/b} ! test filename-9.3 {Tcl_JoinPath: win} {testsetplatform} { testsetplatform win file join /a /b } {/b} ! test filename-9.4 {Tcl_JoinPath: win} {testsetplatform} { testsetplatform win file join c: foo } {c:foo} ! test filename-9.5 {Tcl_JoinPath: win} {testsetplatform} { testsetplatform win file join c:/ foo } {c:/foo} ! test filename-9.6 {Tcl_JoinPath: win} {testsetplatform} { testsetplatform win file join c:\\bar foo } {c:/bar/foo} ! test filename-9.7 {Tcl_JoinPath: win} {testsetplatform} { testsetplatform win file join /foo c:bar } {c:bar} ! test filename-9.8 {Tcl_JoinPath: win} {testsetplatform} { testsetplatform win file join ///host//share dir } {//host/share/dir} ! test filename-9.9 {Tcl_JoinPath: win} {testsetplatform} { testsetplatform win file join ~ foo } {~/foo} ! test filename-9.10 {Tcl_JoinPath: win} {testsetplatform} { testsetplatform win file join ~/~foo } {~/~foo} ! test filename-9.11 {Tcl_JoinPath: win} {testsetplatform} { testsetplatform win file join ~ ./~foo } {~/~foo} ! test filename-9.12 {Tcl_JoinPath: win} {testsetplatform} { testsetplatform win file join / ~foo } {~foo} ! test filename-9.13 {Tcl_JoinPath: win} {testsetplatform} { testsetplatform win file join ./a/ b c } {./a/b/c} ! test filename-9.14 {Tcl_JoinPath: win} {testsetplatform} { testsetplatform win file join ./~a/ b c } {./~a/b/c} ! test filename-9.15 {Tcl_JoinPath: win} {testsetplatform} { testsetplatform win file join // host share path } {/host/share/path} ! test filename-9.16 {Tcl_JoinPath: win} {testsetplatform} { testsetplatform win file join foo . bar } {foo/./bar} ! test filename-9.17 {Tcl_JoinPath: win} {testsetplatform} { testsetplatform win file join foo .. bar } {foo/../bar} ! test filename-9.18 {Tcl_JoinPath: win} {testsetplatform} { testsetplatform win file join foo/./bar } {foo/./bar} ! test filename-10.1 {Tcl_TranslateFileName} {testsetplatform} { testsetplatform unix list [catch {testtranslatefilename foo} msg] $msg } {0 foo} ! test filename-10.2 {Tcl_TranslateFileName} {testsetplatform} { testsetplatform windows list [catch {testtranslatefilename {c:/foo}} msg] $msg } {0 {c:\foo}} ! test filename-10.3 {Tcl_TranslateFileName} {testsetplatform} { testsetplatform windows list [catch {testtranslatefilename {c:/\\foo/}} msg] $msg } {0 {c:\foo}} ! test filename-10.4 {Tcl_TranslateFileName} {testsetplatform} { testsetplatform mac list [catch {testtranslatefilename foo} msg] $msg } {0 :foo} ! test filename-10.5 {Tcl_TranslateFileName} {testsetplatform} { testsetplatform mac list [catch {testtranslatefilename :~foo} msg] $msg } {0 :~foo} ! test filename-10.6 {Tcl_TranslateFileName} {testsetplatform} { global env set temp $env(HOME) set env(HOME) "/home/test" *************** *** 897,903 **** set env(HOME) $temp set result } {0 /home/test/foo} ! test filename-10.7 {Tcl_TranslateFileName} { global env set temp $env(HOME) unset env(HOME) --- 895,901 ---- set env(HOME) $temp set result } {0 /home/test/foo} ! test filename-10.7 {Tcl_TranslateFileName} {testsetplatform} { global env set temp $env(HOME) unset env(HOME) *************** *** 906,912 **** set env(HOME) $temp set result } {1 {couldn't find HOME environment variable to expand path}} ! test filename-10.8 {Tcl_TranslateFileName} { global env set temp $env(HOME) set env(HOME) "/home/test" --- 904,910 ---- set env(HOME) $temp set result } {1 {couldn't find HOME environment variable to expand path}} ! test filename-10.8 {Tcl_TranslateFileName} {testsetplatform} { global env set temp $env(HOME) set env(HOME) "/home/test" *************** *** 915,921 **** set env(HOME) $temp set result } {0 /home/test} ! test filename-10.9 {Tcl_TranslateFileName} { global env set temp $env(HOME) set env(HOME) "/home/test/" --- 913,919 ---- set env(HOME) $temp set result } {0 /home/test} ! test filename-10.9 {Tcl_TranslateFileName} {testsetplatform} { global env set temp $env(HOME) set env(HOME) "/home/test/" *************** *** 924,930 **** set env(HOME) $temp set result } {0 /home/test} ! test filename-10.10 {Tcl_TranslateFileName} { global env set temp $env(HOME) set env(HOME) "/home/test/" --- 922,928 ---- set env(HOME) $temp set result } {0 /home/test} ! test filename-10.10 {Tcl_TranslateFileName} {testsetplatform} { global env set temp $env(HOME) set env(HOME) "/home/test/" *************** *** 933,939 **** set env(HOME) $temp set result } {0 /home/test/foo} ! test filename-10.11 {Tcl_TranslateFileName} { global env set temp $env(HOME) set env(HOME) "Root:" --- 931,937 ---- set env(HOME) $temp set result } {0 /home/test/foo} ! test filename-10.11 {Tcl_TranslateFileName} {testsetplatform} { global env set temp $env(HOME) set env(HOME) "Root:" *************** *** 942,948 **** set env(HOME) $temp set result } {0 Root:foo} ! test filename-10.12 {Tcl_TranslateFileName} { global env set temp $env(HOME) set env(HOME) "Root:home" --- 940,946 ---- set env(HOME) $temp set result } {0 Root:foo} ! test filename-10.12 {Tcl_TranslateFileName} {testsetplatform} { global env set temp $env(HOME) set env(HOME) "Root:home" *************** *** 951,957 **** set env(HOME) $temp set result } {0 Root:home:foo} ! test filename-10.13 {Tcl_TranslateFileName} { global env set temp $env(HOME) set env(HOME) "Root:home" --- 949,955 ---- set env(HOME) $temp set result } {0 Root:home:foo} ! test filename-10.13 {Tcl_TranslateFileName} {testsetplatform} { global env set temp $env(HOME) set env(HOME) "Root:home" *************** *** 960,966 **** set env(HOME) $temp set result } {0 Root:home::foo} ! test filename-10.14 {Tcl_TranslateFileName} { global env set temp $env(HOME) set env(HOME) "Root:home" --- 958,964 ---- set env(HOME) $temp set result } {0 Root:home::foo} ! test filename-10.14 {Tcl_TranslateFileName} {testsetplatform} { global env set temp $env(HOME) set env(HOME) "Root:home" *************** *** 969,975 **** set env(HOME) $temp set result } {0 Root:home} ! test filename-10.15 {Tcl_TranslateFileName} { global env set temp $env(HOME) set env(HOME) "Root:home:" --- 967,973 ---- set env(HOME) $temp set result } {0 Root:home} ! test filename-10.15 {Tcl_TranslateFileName} {testsetplatform} { global env set temp $env(HOME) set env(HOME) "Root:home:" *************** *** 978,984 **** set env(HOME) $temp set result } {0 Root:home::foo} ! test filename-10.16 {Tcl_TranslateFileName} { global env set temp $env(HOME) set env(HOME) "Root:home::" --- 976,982 ---- set env(HOME) $temp set result } {0 Root:home::foo} ! test filename-10.16 {Tcl_TranslateFileName} {testsetplatform} { global env set temp $env(HOME) set env(HOME) "Root:home::" *************** *** 987,993 **** set env(HOME) $temp set result } {0 Root:home:::foo} ! test filename-10.17 {Tcl_TranslateFileName} { global env set temp $env(HOME) set env(HOME) "\\home\\" --- 985,991 ---- set env(HOME) $temp set result } {0 Root:home:::foo} ! test filename-10.17 {Tcl_TranslateFileName} {testsetplatform} { global env set temp $env(HOME) set env(HOME) "\\home\\" *************** *** 996,1002 **** set env(HOME) $temp set result } {0 {\home\foo}} ! test filename-10.18 {Tcl_TranslateFileName} { global env set temp $env(HOME) set env(HOME) "\\home\\" --- 994,1000 ---- set env(HOME) $temp set result } {0 {\home\foo}} ! test filename-10.18 {Tcl_TranslateFileName} {testsetplatform} { global env set temp $env(HOME) set env(HOME) "\\home\\" *************** *** 1005,1011 **** set env(HOME) $temp set result } {0 {\home\foo\bar}} ! test filename-10.19 {Tcl_TranslateFileName} { global env set temp $env(HOME) set env(HOME) "c:" --- 1003,1009 ---- set env(HOME) $temp set result } {0 {\home\foo\bar}} ! test filename-10.19 {Tcl_TranslateFileName} {testsetplatform} { global env set temp $env(HOME) set env(HOME) "c:" *************** *** 1014,1023 **** set env(HOME) $temp set result } {0 c:foo} ! test filename-10.20 {Tcl_TranslateFileName} { list [catch {testtranslatefilename ~blorp/foo} msg] $msg } {1 {user "blorp" doesn't exist}} ! test filename-10.21 {Tcl_TranslateFileName} { global env set temp $env(HOME) set env(HOME) "c:\\" --- 1012,1021 ---- set env(HOME) $temp set result } {0 c:foo} ! test filename-10.20 {Tcl_TranslateFileName} {testtranslatefilename} { list [catch {testtranslatefilename ~blorp/foo} msg] $msg } {1 {user "blorp" doesn't exist}} ! test filename-10.21 {Tcl_TranslateFileName} {testsetplatform} { global env set temp $env(HOME) set env(HOME) "c:\\" *************** *** 1026,1037 **** set env(HOME) $temp set result } {0 {c:\foo}} ! test filename-10.22 {Tcl_TranslateFileName} { testsetplatform windows list [catch {testtranslatefilename foo//bar} msg] $msg } {0 {foo\bar}} ! testsetplatform $platform test filename-10.23 {Tcl_TranslateFileName} {unixOnly nonPortable} { # this test fails if ~ouster is not /home/ouster --- 1024,1037 ---- set env(HOME) $temp set result } {0 {c:\foo}} ! test filename-10.22 {Tcl_TranslateFileName} {testsetplatform} { testsetplatform windows list [catch {testtranslatefilename foo//bar} msg] $msg } {0 {foo\bar}} ! if {[tcltest::testConstraint testsetplatform]} { ! testsetplatform $platform ! } test filename-10.23 {Tcl_TranslateFileName} {unixOnly nonPortable} { # this test fails if ~ouster is not /home/ouster *************** *** 1048,1054 **** } {1 {wrong # args: should be "glob ?switches? name ?name ...?"}} test filename-11.2 {Tcl_GlobCmd} { list [catch {glob -gorp} msg] $msg ! } {1 {bad option "-gorp": must be -directory, -join, -nocomplain, -path, -types, or --}} test filename-11.3 {Tcl_GlobCmd} { list [catch {glob -nocomplai} msg] $msg } {1 {wrong # args: should be "glob ?switches? name ?name ...?"}} --- 1048,1054 ---- } {1 {wrong # args: should be "glob ?switches? name ?name ...?"}} test filename-11.2 {Tcl_GlobCmd} { list [catch {glob -gorp} msg] $msg ! } {1 {bad option "-gorp": must be -directory, -join, -nocomplain, -path, -tails, -types, or --}} test filename-11.3 {Tcl_GlobCmd} { list [catch {glob -nocomplai} msg] $msg } {1 {wrong # args: should be "glob ?switches? name ?name ...?"}} *************** *** 1067,1085 **** test filename-11.8 {Tcl_GlobCmd} { list [catch {glob -nocomplain -- -nocomplain} msg] $msg } {0 {}} ! test filename-11.9 {Tcl_GlobCmd} { testsetplatform unix list [catch {glob ~\\xyqrszzz/bar} msg] $msg } {1 {user "\xyqrszzz" doesn't exist}} ! test filename-11.10 {Tcl_GlobCmd} { testsetplatform unix list [catch {glob -nocomplain ~\\xyqrszzz/bar} msg] $msg } {0 {}} ! test filename-11.11 {Tcl_GlobCmd} { testsetplatform unix list [catch {glob ~xyqrszzz\\/\\bar} msg] $msg } {1 {user "xyqrszzz" doesn't exist}} ! test filename-11.12 {Tcl_GlobCmd} { testsetplatform unix set home $env(HOME) unset env(HOME) --- 1067,1085 ---- test filename-11.8 {Tcl_GlobCmd} { list [catch {glob -nocomplain -- -nocomplain} msg] $msg } {0 {}} ! test filename-11.9 {Tcl_GlobCmd} {testsetplatform} { testsetplatform unix list [catch {glob ~\\xyqrszzz/bar} msg] $msg } {1 {user "\xyqrszzz" doesn't exist}} ! test filename-11.10 {Tcl_GlobCmd} {testsetplatform} { testsetplatform unix list [catch {glob -nocomplain ~\\xyqrszzz/bar} msg] $msg } {0 {}} ! test filename-11.11 {Tcl_GlobCmd} {testsetplatform} { testsetplatform unix list [catch {glob ~xyqrszzz\\/\\bar} msg] $msg } {1 {user "xyqrszzz" doesn't exist}} ! test filename-11.12 {Tcl_GlobCmd} {testsetplatform} { testsetplatform unix set home $env(HOME) unset env(HOME) *************** *** 1088,1094 **** set x } {1 {couldn't find HOME environment variable to expand path}} ! testsetplatform $platform test filename-11.13 {Tcl_GlobCmd} { list [catch {file join [lindex [glob ~] 0]} msg] $msg --- 1088,1096 ---- set x } {1 {couldn't find HOME environment variable to expand path}} ! if {[tcltest::testConstraint testsetplatform]} { ! testsetplatform $platform ! } test filename-11.13 {Tcl_GlobCmd} { list [catch {file join [lindex [glob ~] 0]} msg] $msg *************** *** 1124,1149 **** set globname "globTest" set horribleglobname "glob\[\{Test" ! test filename-11.17 {Tcl_GlobCmd} { list [catch {lsort [glob -directory $globname *]} msg] $msg } [list 0 [lsort [list [file join $globname a1] [file join $globname a2]\ [file join $globname a3]\ [file join $globname "weird name.c"]\ [file join $globname x,z1.c]\ [file join $globname x1.c]\ [file join $globname y1.c] [file join $globname z1.c]]]] ! test filename-11.18 {Tcl_GlobCmd} { list [catch {lsort [glob -path $globname/ *]} msg] $msg } [list 0 [lsort [list [file join $globname a1] [file join $globname a2]\ [file join $globname a3]\ [file join $globname "weird name.c"]\ [file join $globname x,z1.c]\ [file join $globname x1.c]\ [file join $globname y1.c] [file join $globname z1.c]]]] ! test filename-11.19 {Tcl_GlobCmd} { list [catch {lsort [glob -join -path \ [string range $globname 0 5] * *]} msg] $msg } [list 0 [lsort [list [file join $globname a1] [file join $globname a2]\ [file join $globname a3]\ [file join $globname "weird name.c"]\ [file join $globname x,z1.c]\ --- 1126,1179 ---- set globname "globTest" set horribleglobname "glob\[\{Test" ! test filename-11.17 {Tcl_GlobCmd} {unixOnly} { ! list [catch {lsort [glob -directory $globname *]} msg] $msg ! } [list 0 [lsort [list [file join $globname a1] [file join $globname a2]\ ! [file join $globname a3]\ ! [file join $globname "weird name.c"]\ ! [file join $globname x,z1.c]\ ! [file join $globname x1.c]\ ! [file join $globname y1.c] [file join $globname z1.c]]]] ! test filename-11.17.1 {Tcl_GlobCmd} {pcOnly macOnly} { list [catch {lsort [glob -directory $globname *]} msg] $msg } [list 0 [lsort [list [file join $globname a1] [file join $globname a2]\ + [file join $globname .1]\ + [file join $globname a3]\ + [file join $globname "weird name.c"]\ + [file join $globname x,z1.c]\ + [file join $globname x1.c]\ + [file join $globname y1.c] [file join $globname z1.c]]]] + test filename-11.18 {Tcl_GlobCmd} {unixOnly} { + list [catch {lsort [glob -path $globname/ *]} msg] $msg + } [list 0 [lsort [list [file join $globname a1] [file join $globname a2]\ [file join $globname a3]\ [file join $globname "weird name.c"]\ [file join $globname x,z1.c]\ [file join $globname x1.c]\ [file join $globname y1.c] [file join $globname z1.c]]]] ! test filename-11.18.1 {Tcl_GlobCmd} {pcOnly macOnly} { list [catch {lsort [glob -path $globname/ *]} msg] $msg } [list 0 [lsort [list [file join $globname a1] [file join $globname a2]\ + [file join $globname .1]\ + [file join $globname a3]\ + [file join $globname "weird name.c"]\ + [file join $globname x,z1.c]\ + [file join $globname x1.c]\ + [file join $globname y1.c] [file join $globname z1.c]]]] + test filename-11.19 {Tcl_GlobCmd} {unixOnly} { + list [catch {lsort [glob -join -path \ + [string range $globname 0 5] * *]} msg] $msg + } [list 0 [lsort [list [file join $globname a1] [file join $globname a2]\ [file join $globname a3]\ [file join $globname "weird name.c"]\ [file join $globname x,z1.c]\ [file join $globname x1.c]\ [file join $globname y1.c] [file join $globname z1.c]]]] ! test filename-11.19.1 {Tcl_GlobCmd} {pcOnly macOnly} { list [catch {lsort [glob -join -path \ [string range $globname 0 5] * *]} msg] $msg } [list 0 [lsort [list [file join $globname a1] [file join $globname a2]\ + [file join $globname .1]\ [file join $globname a3]\ [file join $globname "weird name.c"]\ [file join $globname x,z1.c]\ *************** *** 1161,1167 **** file rename globTest $horribleglobname set globname $horribleglobname ! test filename-11.22 {Tcl_GlobCmd} { list [catch {lsort [glob -dir $globname *]} msg] $msg } [list 0 [lsort [list [file join $globname a1] [file join $globname a2]\ [file join $globname a3]\ --- 1191,1197 ---- file rename globTest $horribleglobname set globname $horribleglobname ! test filename-11.22 {Tcl_GlobCmd} {unixOnly} { list [catch {lsort [glob -dir $globname *]} msg] $msg } [list 0 [lsort [list [file join $globname a1] [file join $globname a2]\ [file join $globname a3]\ *************** *** 1169,1183 **** [file join $globname x,z1.c]\ [file join $globname x1.c]\ [file join $globname y1.c] [file join $globname z1.c]]]] ! test filename-11.23 {Tcl_GlobCmd} { list [catch {lsort [glob -path $globname/ *]} msg] $msg } [list 0 [lsort [list [file join $globname a1] [file join $globname a2]\ [file join $globname a3]\ [file join $globname "weird name.c"]\ [file join $globname x,z1.c]\ [file join $globname x1.c]\ [file join $globname y1.c] [file join $globname z1.c]]]] ! test filename-11.24 {Tcl_GlobCmd} { list [catch {lsort [glob -join -path \ [string range $globname 0 5] * *]} msg] $msg } [list 0 [lsort [list [file join $globname a1] [file join $globname a2]\ --- 1199,1231 ---- [file join $globname x,z1.c]\ [file join $globname x1.c]\ [file join $globname y1.c] [file join $globname z1.c]]]] ! test filename-11.22.1 {Tcl_GlobCmd} {pcOnly macOnly} { ! list [catch {lsort [glob -dir $globname *]} msg] $msg ! } [list 0 [lsort [list [file join $globname a1] [file join $globname a2]\ ! [file join $globname .1]\ ! [file join $globname a3]\ ! [file join $globname "weird name.c"]\ ! [file join $globname x,z1.c]\ ! [file join $globname x1.c]\ ! [file join $globname y1.c] [file join $globname z1.c]]]] ! test filename-11.23 {Tcl_GlobCmd} {unixOnly} { ! list [catch {lsort [glob -path $globname/ *]} msg] $msg ! } [list 0 [lsort [list [file join $globname a1] [file join $globname a2]\ ! [file join $globname a3]\ ! [file join $globname "weird name.c"]\ ! [file join $globname x,z1.c]\ ! [file join $globname x1.c]\ ! [file join $globname y1.c] [file join $globname z1.c]]]] ! test filename-11.23.1 {Tcl_GlobCmd} {pcOnly macOnly} { list [catch {lsort [glob -path $globname/ *]} msg] $msg } [list 0 [lsort [list [file join $globname a1] [file join $globname a2]\ + [file join $globname .1]\ [file join $globname a3]\ [file join $globname "weird name.c"]\ [file join $globname x,z1.c]\ [file join $globname x1.c]\ [file join $globname y1.c] [file join $globname z1.c]]]] ! test filename-11.24 {Tcl_GlobCmd} {unixOnly} { list [catch {lsort [glob -join -path \ [string range $globname 0 5] * *]} msg] $msg } [list 0 [lsort [list [file join $globname a1] [file join $globname a2]\ *************** *** 1186,1191 **** --- 1234,1249 ---- [file join $globname x,z1.c]\ [file join $globname x1.c]\ [file join $globname y1.c] [file join $globname z1.c]]]] + test filename-11.24.1 {Tcl_GlobCmd} {pcOnly macOnly} { + list [catch {lsort [glob -join -path \ + [string range $globname 0 5] * *]} msg] $msg + } [list 0 [lsort [list [file join $globname a1] [file join $globname a2]\ + [file join $globname .1]\ + [file join $globname a3]\ + [file join $globname "weird name.c"]\ + [file join $globname x,z1.c]\ + [file join $globname x1.c]\ + [file join $globname y1.c] [file join $globname z1.c]]]] test filename-11.25 {Tcl_GlobCmd} { list [catch {lsort [glob -type d -dir $globname *]} msg] $msg } [list 0 [lsort [list [file join $globname a1]\ *************** *** 1221,1227 **** } {1 {missing argument to "-directory"}} test filename-11.35 {Tcl_GlobCmd} { list [catch {glob -paths *} msg] $msg ! } {1 {bad option "-paths": must be -directory, -join, -nocomplain, -path, -types, or --}} file rename $horribleglobname globTest set globname globTest --- 1279,1285 ---- } {1 {missing argument to "-directory"}} test filename-11.35 {Tcl_GlobCmd} { list [catch {glob -paths *} msg] $msg ! } {1 {bad option "-paths": must be -directory, -join, -nocomplain, -path, -tails, -types, or --}} file rename $horribleglobname globTest set globname globTest *************** *** 1339,1347 **** test filename-14.6 {asterisks, question marks, and brackets} {macOnly} { lsort [glob */*/*/*.c] } {:globTest:a1:b1:x2.c :globTest:a1:b2:y2.c} ! test filename-14.7 {asterisks, question marks, and brackets} {unixOrPc} { lsort [glob globTest/*] } {globTest/a1 globTest/a2 globTest/a3 {globTest/weird name.c} globTest/x,z1.c globTest/x1.c globTest/y1.c globTest/z1.c} test filename-14.8 {asterisks, question marks, and brackets} {macOnly} { lsort [glob globTest/*] } {:globTest:.1 :globTest:a1 :globTest:a2 :globTest:a3 {:globTest:weird name.c} :globTest:x,z1.c :globTest:x1.c :globTest:y1.c :globTest:z1.c} --- 1397,1408 ---- test filename-14.6 {asterisks, question marks, and brackets} {macOnly} { lsort [glob */*/*/*.c] } {:globTest:a1:b1:x2.c :globTest:a1:b2:y2.c} ! test filename-14.7 {asterisks, question marks, and brackets} {unixOnly} { lsort [glob globTest/*] } {globTest/a1 globTest/a2 globTest/a3 {globTest/weird name.c} globTest/x,z1.c globTest/x1.c globTest/y1.c globTest/z1.c} + test filename-14.7.1 {asterisks, question marks, and brackets} {pcOnly} { + lsort [glob globTest/*] + } {globTest/.1 globTest/a1 globTest/a2 globTest/a3 {globTest/weird name.c} globTest/x,z1.c globTest/x1.c globTest/y1.c globTest/z1.c} test filename-14.8 {asterisks, question marks, and brackets} {macOnly} { lsort [glob globTest/*] } {:globTest:.1 :globTest:a1 :globTest:a2 :globTest:a3 {:globTest:weird name.c} :globTest:x,z1.c :globTest:x1.c :globTest:y1.c :globTest:z1.c} *************** *** 1398,1410 **** test filename-14.24 {slash globbing} {pcOnly} { glob {\\} } / ! test filename-14.25 {type specific globbing} { list [catch {lsort [glob -dir globTest -types f *]} msg] $msg } [list 0 [lsort [list \ [file join $globname "weird name.c"]\ [file join $globname x,z1.c]\ [file join $globname x1.c]\ [file join $globname y1.c] [file join $globname z1.c]]]] test filename-14.26 {type specific globbing} { list [catch {glob -nocomplain -dir globTest -types {readonly} *} msg] $msg } [list 0 {}] --- 1459,1479 ---- test filename-14.24 {slash globbing} {pcOnly} { glob {\\} } / ! test filename-14.25 {type specific globbing} {unixOnly} { list [catch {lsort [glob -dir globTest -types f *]} msg] $msg } [list 0 [lsort [list \ [file join $globname "weird name.c"]\ [file join $globname x,z1.c]\ [file join $globname x1.c]\ [file join $globname y1.c] [file join $globname z1.c]]]] + test filename-14.25.1 {type specific globbing} {pcOnly macOnly} { + list [catch {lsort [glob -dir globTest -types f *]} msg] $msg + } [list 0 [lsort [list \ + [file join $globname .1]\ + [file join $globname "weird name.c"]\ + [file join $globname x,z1.c]\ + [file join $globname x1.c]\ + [file join $globname y1.c] [file join $globname z1.c]]]] test filename-14.26 {type specific globbing} { list [catch {glob -nocomplain -dir globTest -types {readonly} *} msg] $msg } [list 0 {}] *************** *** 1518,1524 **** cd $oldDir file delete -force globTest set env(HOME) $oldhome ! testsetplatform $platform ! catch {unset oldhome platform temp result} ::tcltest::cleanupTests return --- 1587,1596 ---- cd $oldDir file delete -force globTest set env(HOME) $oldhome ! if {[tcltest::testConstraint testsetplatform]} { ! testsetplatform $platform ! catch {unset platform} ! } ! catch {unset oldhome temp result} ::tcltest::cleanupTests return Index: tests/io.test =================================================================== RCS file: /cvsroot/tcl/tcl/tests/io.test,v retrieving revision 1.14 diff -c -r1.14 io.test *** tests/io.test 2000/04/10 17:19:00 1.14 --- tests/io.test 2001/03/16 17:08:16 *************** *** 19,29 **** namespace import -force ::tcltest::* } ! if {"[info commands testchannel]" != "testchannel"} { ! puts "Skipping io tests. This application does not seem to have the" ! puts "testchannel command that is needed to run these tests." ! return ! } ::tcltest::saveState --- 19,25 ---- namespace import -force ::tcltest::* } ! tcltest::testConstraint testchannel [string equal testchannel [info commands testchannel]] ::tcltest::saveState *************** *** 630,636 **** close $f set x } [list 14 "abcd\nefgh\rijkl" 4 "mnop" -1 ""] ! test io-6.30 {Tcl_GetsObj: crlf mode: buffer exhausted} { # if (eol >= dstEnd) set f [open test1 w] --- 626,632 ---- close $f set x } [list 14 "abcd\nefgh\rijkl" 4 "mnop" -1 ""] ! test io-6.30 {Tcl_GetsObj: crlf mode: buffer exhausted} {testchannel} { # if (eol >= dstEnd) set f [open test1 w] *************** *** 643,649 **** close $f set x } [list 15 "123456789012345" 15] ! test io-6.31 {Tcl_GetsObj: crlf mode: buffer exhausted, blocked} {stdio} { # (FilterInputBytes() != 0) set f [open "|[list $::tcltest::tcltest cat]" w+] --- 639,645 ---- close $f set x } [list 15 "123456789012345" 15] ! test io-6.31 {Tcl_GetsObj: crlf mode: buffer exhausted, blocked} {stdio testchannel} { # (FilterInputBytes() != 0) set f [open "|[list $::tcltest::tcltest cat]" w+] *************** *** 656,662 **** close $f set x } [list "bbbbbbbbbbbbbb" -1 "" 1 16] ! test io-6.32 {Tcl_GetsObj: crlf mode: buffer exhausted, more data} { # not (FilterInputBytes() != 0) set f [open test1 w] --- 652,658 ---- close $f set x } [list "bbbbbbbbbbbbbb" -1 "" 1 16] ! test io-6.32 {Tcl_GetsObj: crlf mode: buffer exhausted, more data} {testchannel} { # not (FilterInputBytes() != 0) set f [open test1 w] *************** *** 782,788 **** close $f set x } [list 4 "abcd" 4 "efgh" 4 "ijkl" 4 "mnop" -1 ""] ! test io-6.43 {Tcl_GetsObj: input saw cr} {stdio} { # if (chanPtr->flags & INPUT_SAW_CR) set f [open "|[list $::tcltest::tcltest cat]" w+] --- 778,784 ---- close $f set x } [list 4 "abcd" 4 "efgh" 4 "ijkl" 4 "mnop" -1 ""] ! test io-6.43 {Tcl_GetsObj: input saw cr} {stdio testchannel} { # if (chanPtr->flags & INPUT_SAW_CR) set f [open "|[list $::tcltest::tcltest cat]" w+] *************** *** 799,805 **** close $f set x } [list "bbbbbbbbbbbbbbb" 15 "123456789abcdef" 1 4 "abcd" 0 3 "efg"] ! test io-6.44 {Tcl_GetsObj: input saw cr, not followed by cr} {stdio} { # not (*eol == '\n') set f [open "|[list $::tcltest::tcltest cat]" w+] --- 795,801 ---- close $f set x } [list "bbbbbbbbbbbbbbb" 15 "123456789abcdef" 1 4 "abcd" 0 3 "efg"] ! test io-6.44 {Tcl_GetsObj: input saw cr, not followed by cr} {stdio testchannel} { # not (*eol == '\n') set f [open "|[list $::tcltest::tcltest cat]" w+] *************** *** 816,822 **** close $f set x } [list "bbbbbbbbbbbbbbb" 15 "123456789abcdef" 1 4 "abcd" 0 3 "efg"] ! test io-6.45 {Tcl_GetsObj: input saw cr, skip right number of bytes} {stdio} { # Tcl_ExternalToUtf() set f [open "|[list $::tcltest::tcltest cat]" w+] --- 812,818 ---- close $f set x } [list "bbbbbbbbbbbbbbb" 15 "123456789abcdef" 1 4 "abcd" 0 3 "efg"] ! test io-6.45 {Tcl_GetsObj: input saw cr, skip right number of bytes} {stdio testchannel} { # Tcl_ExternalToUtf() set f [open "|[list $::tcltest::tcltest cat]" w+] *************** *** 833,839 **** close $f set x } [list 15 "123456789abcdef" 1 4 "abcd" 0] ! test io-6.46 {Tcl_GetsObj: input saw cr, followed by just \n should give eof} {stdio} { # memmove() set f [open "|[list $::tcltest::tcltest cat]" w+] --- 829,835 ---- close $f set x } [list 15 "123456789abcdef" 1 4 "abcd" 0] ! test io-6.46 {Tcl_GetsObj: input saw cr, followed by just \n should give eof} {stdio testchannel} { # memmove() set f [open "|[list $::tcltest::tcltest cat]" w+] *************** *** 849,855 **** close $f set x } [list 15 "123456789abcdef" 1 -1 "" 0] ! test io-6.47 {Tcl_GetsObj: auto mode: \r at end of buffer, peek for \n} { # (eol == dstEnd) set f [open test1 w] --- 845,851 ---- close $f set x } [list 15 "123456789abcdef" 1 -1 "" 0] ! test io-6.47 {Tcl_GetsObj: auto mode: \r at end of buffer, peek for \n} {testchannel} { # (eol == dstEnd) set f [open test1 w] *************** *** 862,868 **** close $f set x } [list "123456789012345" 15] ! test io-6.48 {Tcl_GetsObj: auto mode: \r at end of buffer, no more avail} { # PeekAhead() did not get any, so (eol >= dstEnd) set f [open test1 w] --- 858,864 ---- close $f set x } [list "123456789012345" 15] ! test io-6.48 {Tcl_GetsObj: auto mode: \r at end of buffer, no more avail} {testchannel} { # PeekAhead() did not get any, so (eol >= dstEnd) set f [open test1 w] *************** *** 875,881 **** close $f set x } [list "123456789012345" 1] ! test io-6.49 {Tcl_GetsObj: auto mode: \r followed by \n} { # if (*eol == '\n') {skip++} set f [open test1 w] --- 871,877 ---- close $f set x } [list "123456789012345" 1] ! test io-6.49 {Tcl_GetsObj: auto mode: \r followed by \n} {testchannel} { # if (*eol == '\n') {skip++} set f [open test1 w] *************** *** 887,893 **** close $f set x } [list "123456" 0 8 "78901"] ! test io-6.50 {Tcl_GetsObj: auto mode: \r not followed by \n} { # not (*eol == '\n') set f [open test1 w] --- 883,889 ---- close $f set x } [list "123456" 0 8 "78901"] ! test io-6.50 {Tcl_GetsObj: auto mode: \r not followed by \n} {testchannel} { # not (*eol == '\n') set f [open test1 w] *************** *** 911,917 **** close $f set x } [list "123456" 7 "78901"] ! test io-6.52 {Tcl_GetsObj: saw EOF character} { # if (eof != NULL) set f [open test1 w] --- 907,913 ---- close $f set x } [list "123456" 7 "78901"] ! test io-6.52 {Tcl_GetsObj: saw EOF character} {testchannel} { # if (eof != NULL) set f [open test1 w] *************** *** 1005,1011 **** close $f set x } [list 10 "1234567890" 0] ! test io-7.3 {FilterInputBytes: split up character at EOF} { set f [open test1 w] fconfigure $f -encoding binary puts -nonewline $f "1234567890123\x82\x4f\x82\x50\x82" --- 1001,1007 ---- close $f set x } [list 10 "1234567890" 0] ! test io-7.3 {FilterInputBytes: split up character at EOF} {testchannel} { set f [open test1 w] fconfigure $f -encoding binary puts -nonewline $f "1234567890123\x82\x4f\x82\x50\x82" *************** *** 1037,1043 **** set x } [list -1 "" 1 17 "1234567890123\uff10\uff11\uff12\uff13" 0] ! test io-8.1 {PeekAhead: only go to device if no more cached data} { # (bufPtr->nextPtr == NULL) set f [open "test1" w] --- 1033,1039 ---- set x } [list -1 "" 1 17 "1234567890123\uff10\uff11\uff12\uff13" 0] ! test io-8.1 {PeekAhead: only go to device if no more cached data} {testchannel} { # (bufPtr->nextPtr == NULL) set f [open "test1" w] *************** *** 1052,1058 **** close $f set x } "7" ! test io-8.2 {PeekAhead: only go to device if no more cached data} {stdio} { # not (bufPtr->nextPtr == NULL) set f [open "|[list $::tcltest::tcltest cat]" w+] --- 1048,1054 ---- close $f set x } "7" ! test io-8.2 {PeekAhead: only go to device if no more cached data} {stdio testchannel} { # not (bufPtr->nextPtr == NULL) set f [open "|[list $::tcltest::tcltest cat]" w+] *************** *** 1071,1077 **** close $f set x } [list -1 "" 42 15 "123456789012345" 25] ! test io-8.3 {PeekAhead: no cached data available} {stdio} { # (bytesLeft == 0) set f [open "|[list $::tcltest::tcltest cat]" w+] --- 1067,1073 ---- close $f set x } [list -1 "" 42 15 "123456789012345" 25] ! test io-8.3 {PeekAhead: no cached data available} {stdio testchannel} { # (bytesLeft == 0) set f [open "|[list $::tcltest::tcltest cat]" w+] *************** *** 1104,1110 **** set x } $a unset a ! test io-8.5 {PeekAhead: don't peek if last read was short} {stdio} { # (bufPtr->nextAdded < bufPtr->length) set f [open "|[list $::tcltest::tcltest cat]" w+] --- 1100,1106 ---- set x } $a unset a ! test io-8.5 {PeekAhead: don't peek if last read was short} {stdio testchannel} { # (bufPtr->nextAdded < bufPtr->length) set f [open "|[list $::tcltest::tcltest cat]" w+] *************** *** 1116,1122 **** close $f set x } {15 abcdefghijklmno 1} ! test io-8.6 {PeekAhead: change to non-blocking mode} {stdio} { # ((chanPtr->flags & CHANNEL_NONBLOCKING) == 0) set f [open "|[list $::tcltest::tcltest cat]" w+] --- 1112,1118 ---- close $f set x } {15 abcdefghijklmno 1} ! test io-8.6 {PeekAhead: change to non-blocking mode} {stdio testchannel} { # ((chanPtr->flags & CHANNEL_NONBLOCKING) == 0) set f [open "|[list $::tcltest::tcltest cat]" w+] *************** *** 1128,1134 **** close $f set x } {15 abcdefghijklmno 1} ! test io-8.7 {PeekAhead: cleanup} {stdio} { # Make sure bytes are removed from buffer. set f [open "|[list $::tcltest::tcltest cat]" w+] --- 1124,1130 ---- close $f set x } {15 abcdefghijklmno 1} ! test io-8.7 {PeekAhead: cleanup} {stdio testchannel} { # Make sure bytes are removed from buffer. set f [open "|[list $::tcltest::tcltest cat]" w+] *************** *** 1294,1300 **** close $f set x } {abcdefghijklmnopqrstuvwxyz} ! test io-12.4 {ReadChars: split-up char} {stdio} { # (srcRead == 0) set f [open "|[list $::tcltest::tcltest cat]" w+] --- 1290,1296 ---- close $f set x } {abcdefghijklmnopqrstuvwxyz} ! test io-12.4 {ReadChars: split-up char} {stdio testchannel} { # (srcRead == 0) set f [open "|[list $::tcltest::tcltest cat]" w+] *************** *** 1413,1419 **** close $f set x } "abcd\ndef\nfgh" ! test io-13.6 {TranslateInputEOL: auto mode: saw cr in last segment} {stdio} { # (chanPtr->flags & INPUT_SAW_CR) # This test may fail on slower machines. --- 1409,1415 ---- close $f set x } "abcd\ndef\nfgh" ! test io-13.6 {TranslateInputEOL: auto mode: saw cr in last segment} {stdio testchannel} { # (chanPtr->flags & INPUT_SAW_CR) # This test may fail on slower machines. *************** *** 1437,1443 **** close $f set x } [list "abcdefghj\n" 1 "01234" 0] ! test io-13.7 {TranslateInputEOL: auto mode: naked \r} { # (src >= srcMax) set f [open test1 w] --- 1433,1439 ---- close $f set x } [list "abcdefghj\n" 1 "01234" 0] ! test io-13.7 {TranslateInputEOL: auto mode: naked \r} {testchannel} { # (src >= srcMax) set f [open test1 w] *************** *** 1518,1529 **** # Tcl_SetStdChannel and Tcl_GetStdChannel. Incidentally we are # also testing channel table management. ! if {$tcl_platform(platform) == "macintosh"} { ! set consoleFileNames [list console0 console1 console2] } else { ! set consoleFileNames [lsort [testchannel open]] } ! test io-14.1 {Tcl_SetStdChannel and Tcl_GetStdChannel} { set l "" lappend l [fconfigure stdin -buffering] lappend l [fconfigure stdout -buffering] --- 1514,1531 ---- # Tcl_SetStdChannel and Tcl_GetStdChannel. Incidentally we are # also testing channel table management. ! if {[info commands testchannel] != ""} { ! if {$tcl_platform(platform) == "macintosh"} { ! set consoleFileNames [list console0 console1 console2] ! } else { ! set consoleFileNames [lsort [testchannel open]] ! } } else { ! # just to avoid an error ! set consoleFileNames [list] } ! ! test io-14.1 {Tcl_SetStdChannel and Tcl_GetStdChannel} {testchannel} { set l "" lappend l [fconfigure stdin -buffering] lappend l [fconfigure stdout -buffering] *************** *** 1677,1683 **** # These functions use "eof stdin" to ensure that the standard # channels are added to the channel table of the interpreter. ! test io-17.1 {GetChannelTable, DeleteChannelTable on std handles} { set l1 [testchannel refcount stdin] eof stdin interp create x --- 1679,1685 ---- # These functions use "eof stdin" to ensure that the standard # channels are added to the channel table of the interpreter. ! test io-17.1 {GetChannelTable, DeleteChannelTable on std handles} {testchannel} { set l1 [testchannel refcount stdin] eof stdin interp create x *************** *** 1689,1695 **** lappend l [expr [testchannel refcount stdin] - $l1] set l } {0 1 0} ! test io-17.2 {GetChannelTable, DeleteChannelTable on std handles} { set l1 [testchannel refcount stdout] eof stdin interp create x --- 1691,1697 ---- lappend l [expr [testchannel refcount stdin] - $l1] set l } {0 1 0} ! test io-17.2 {GetChannelTable, DeleteChannelTable on std handles} {testchannel} { set l1 [testchannel refcount stdout] eof stdin interp create x *************** *** 1701,1707 **** lappend l [expr [testchannel refcount stdout] - $l1] set l } {0 1 0} ! test io-17.3 {GetChannelTable, DeleteChannelTable on std handles} { set l1 [testchannel refcount stderr] eof stdin interp create x --- 1703,1709 ---- lappend l [expr [testchannel refcount stdout] - $l1] set l } {0 1 0} ! test io-17.3 {GetChannelTable, DeleteChannelTable on std handles} {testchannel} { set l1 [testchannel refcount stderr] eof stdin interp create x *************** *** 1714,1720 **** set l } {0 1 0} ! test io-18.1 {Tcl_RegisterChannel, Tcl_UnregisterChannel} { removeFile test1 set l "" set f [open test1 w] --- 1716,1722 ---- set l } {0 1 0} ! test io-18.1 {Tcl_RegisterChannel, Tcl_UnregisterChannel} {testchannel} { removeFile test1 set l "" set f [open test1 w] *************** *** 1728,1734 **** string compare [string tolower $l] \ [list 1 [format "can not find channel named \"%s\"" $f]] } 0 ! test io-18.2 {Tcl_RegisterChannel, Tcl_UnregisterChannel} { removeFile test1 set l "" set f [open test1 w] --- 1730,1736 ---- string compare [string tolower $l] \ [list 1 [format "can not find channel named \"%s\"" $f]] } 0 ! test io-18.2 {Tcl_RegisterChannel, Tcl_UnregisterChannel} {testchannel} { removeFile test1 set l "" set f [open test1 w] *************** *** 1749,1755 **** string compare [string tolower $l] \ [list 1 2 1 1 [format "can not find channel named \"%s\"" $f]] } 0 ! test io-18.3 {Tcl_RegisterChannel, Tcl_UnregisterChannel} { removeFile test1 set l "" set f [open test1 w] --- 1751,1757 ---- string compare [string tolower $l] \ [list 1 2 1 1 [format "can not find channel named \"%s\"" $f]] } 0 ! test io-18.3 {Tcl_RegisterChannel, Tcl_UnregisterChannel} {testchannel} { removeFile test1 set l "" set f [open test1 w] *************** *** 1782,1788 **** test io-19.3 {Tcl_GetChannel, channel not found} { list [catch {eof file34} msg] $msg } {1 {can not find channel named "file34"}} ! test io-19.4 {Tcl_CreateChannel, insertion into channel table} { removeFile test1 set f [open test1 w] set l "" --- 1784,1790 ---- test io-19.3 {Tcl_GetChannel, channel not found} { list [catch {eof file34} msg] $msg } {1 {can not find channel named "file34"}} ! test io-19.4 {Tcl_CreateChannel, insertion into channel table} {testchannel} { removeFile test1 set f [open test1 w] set l "" *************** *** 1853,1859 **** # Not used anywhere in Tcl. } {} ! test io-23.1 {Tcl_GetChannelName} { removeFile test1 set f [open test1 w] set n [testchannel name $f] --- 1855,1861 ---- # Not used anywhere in Tcl. } {} ! test io-23.1 {Tcl_GetChannelName} {testchannel} { removeFile test1 set f [open test1 w] set n [testchannel name $f] *************** *** 1861,1867 **** string compare $n $f } 0 ! test io-24.1 {Tcl_GetChannelType} { removeFile test1 set f [open test1 w] set t [testchannel type $f] --- 1863,1869 ---- string compare $n $f } 0 ! test io-24.1 {Tcl_GetChannelType} {testchannel} { removeFile test1 set f [open test1 w] set t [testchannel type $f] *************** *** 1869,1875 **** string compare $t file } 0 ! test io-25.1 {Tcl_GetChannelHandle, input} { set f [open test1 w] fconfigure $f -translation lf -eofchar {} puts $f "1234567890\n098765432" --- 1871,1877 ---- string compare $t file } 0 ! test io-25.1 {Tcl_GetChannelHandle, input} {testchannel} { set f [open test1 w] fconfigure $f -translation lf -eofchar {} puts $f "1234567890\n098765432" *************** *** 1882,1888 **** close $f set l } {10 11} ! test io-25.2 {Tcl_GetChannelHandle, output} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf --- 1884,1890 ---- close $f set l } {10 11} ! test io-25.2 {Tcl_GetChannelHandle, output} {testchannel} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf *************** *** 2012,2018 **** # Tests closing a channel. The functions tested are CloseChannel and Tcl_Close. ! test io-28.1 {CloseChannel called when all references are dropped} { removeFile test1 set f [open test1 w] interp create x --- 2014,2020 ---- # Tests closing a channel. The functions tested are CloseChannel and Tcl_Close. ! test io-28.1 {CloseChannel called when all references are dropped} {testchannel} { removeFile test1 set f [open test1 w] interp create x *************** *** 2086,2092 **** set result ok } } ok ! test io-28.4 {Tcl_Close} { removeFile test1 set l "" lappend l [lsort [testchannel open]] --- 2088,2094 ---- set result ok } } ok ! test io-28.4 {Tcl_Close} {testchannel} { removeFile test1 set l "" lappend l [lsort [testchannel open]] *************** *** 2099,2105 **** $consoleFileNames] string compare $l $x } 0 ! test io-28.5 {Tcl_Close vs standard handles} {stdio unixOnly} { removeFile script set f [open script w] puts $f { --- 2101,2107 ---- $consoleFileNames] string compare $l $x } 0 ! test io-28.5 {Tcl_Close vs standard handles} {stdio unixOnly testchannel} { removeFile script set f [open script w] puts $f { *************** *** 2132,2138 **** close $f file size test1 } 5 ! test io-29.4 {Tcl_WriteChars, buffering in full buffering mode} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf -buffering full -eofchar {} --- 2134,2140 ---- close $f file size test1 } 5 ! test io-29.4 {Tcl_WriteChars, buffering in full buffering mode} {testchannel} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf -buffering full -eofchar {} *************** *** 2146,2152 **** close $f set l } {6 0 0 6} ! test io-29.5 {Tcl_WriteChars, buffering in line buffering mode} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf -buffering line -eofchar {} --- 2148,2154 ---- close $f set l } {6 0 0 6} ! test io-29.5 {Tcl_WriteChars, buffering in line buffering mode} {testchannel} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf -buffering line -eofchar {} *************** *** 2160,2166 **** close $f set l } {5 0 0 11} ! test io-29.6 {Tcl_WriteChars, buffering in no buffering mode} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf -buffering none -eofchar {} --- 2162,2168 ---- close $f set l } {5 0 0 11} ! test io-29.6 {Tcl_WriteChars, buffering in no buffering mode} {testchannel} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf -buffering none -eofchar {} *************** *** 2175,2181 **** set l } {0 5 0 11} ! test io-29.7 {Tcl_Flush, full buffering} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf -buffering full -eofchar {} --- 2177,2183 ---- set l } {0 5 0 11} ! test io-29.7 {Tcl_Flush, full buffering} {testchannel} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf -buffering full -eofchar {} *************** *** 2192,2198 **** close $f set l } {5 0 11 0 0 11} ! test io-29.8 {Tcl_Flush, full buffering} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf -buffering line --- 2194,2200 ---- close $f set l } {5 0 11 0 0 11} ! test io-29.8 {Tcl_Flush, full buffering} {testchannel} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf -buffering line *************** *** 4671,4677 **** # Test Tcl_InputBuffered ! test io-37.1 {Tcl_InputBuffered} { set f [open longfile r] fconfigure $f -buffersize 4096 read $f 3 --- 4673,4679 ---- # Test Tcl_InputBuffered ! test io-37.1 {Tcl_InputBuffered} {testchannel} { set f [open longfile r] fconfigure $f -buffersize 4096 read $f 3 *************** *** 4681,4687 **** close $f set l } {4093 3} ! test io-37.2 {Tcl_InputBuffered, test input flushing on seek} { set f [open longfile r] fconfigure $f -buffersize 4096 read $f 3 --- 4683,4689 ---- close $f set l } {4093 3} ! test io-37.2 {Tcl_InputBuffered, test input flushing on seek} {testchannel} { set f [open longfile r] fconfigure $f -buffersize 4096 read $f 3 *************** *** 6043,6049 **** set l } [list 7 a\rb\rc 7 {} 7 1] ! test io-50.1 {testing handler deletion} {} { removeFile test1 set f [open test1 w] close $f --- 6045,6051 ---- set l } [list 7 a\rb\rc 7 {} 7 1] ! test io-50.1 {testing handler deletion} {testchannel} { removeFile test1 set f [open test1 w] close $f *************** *** 6059,6065 **** close $f set z } called ! test io-50.2 {testing handler deletion with multiple handlers} {} { removeFile test1 set f [open test1 w] close $f --- 6061,6067 ---- close $f set z } called ! test io-50.2 {testing handler deletion with multiple handlers} {testchannel} { removeFile test1 set f [open test1 w] close $f *************** *** 6077,6083 **** string compare [string tolower $z] \ [list [list called delhandler $f 0] [list called delhandler $f 1]] } 0 ! test io-50.3 {testing handler deletion with multiple handlers} {} { removeFile test1 set f [open test1 w] close $f --- 6079,6085 ---- string compare [string tolower $z] \ [list [list called delhandler $f 0] [list called delhandler $f 1]] } 0 ! test io-50.3 {testing handler deletion with multiple handlers} {testchannel} { removeFile test1 set f [open test1 w] close $f *************** *** 6103,6109 **** [list [list delhandler $f 0 called] \ [list delhandler $f 0 deleted myself]] } 0 ! test io-50.4 {testing handler deletion vs reentrant calls} {} { removeFile test1 set f [open test1 w] close $f --- 6105,6111 ---- [list [list delhandler $f 0 called] \ [list delhandler $f 0 deleted myself]] } 0 ! test io-50.4 {testing handler deletion vs reentrant calls} {testchannel} { removeFile test1 set f [open test1 w] close $f *************** *** 6127,6133 **** string compare [string tolower $z] \ {{delrecursive calling recursive} {delrecursive deleting recursive}} } 0 ! test io-50.5 {testing handler deletion vs reentrant calls} {} { removeFile test1 set f [open test1 w] close $f --- 6129,6135 ---- string compare [string tolower $z] \ {{delrecursive calling recursive} {delrecursive deleting recursive}} } 0 ! test io-50.5 {testing handler deletion vs reentrant calls} {testchannel} { removeFile test1 set f [open test1 w] close $f *************** *** 6160,6166 **** [list {del calling recursive} {del deleted notcalled} \ {del deleted myself} {del after update}] } 0 ! test io-50.6 {testing handler deletion vs reentrant calls} {} { removeFile test1 set f [open test1 w] close $f --- 6162,6168 ---- [list {del calling recursive} {del deleted notcalled} \ {del deleted myself} {del after update}] } 0 ! test io-50.6 {testing handler deletion vs reentrant calls} {testchannel} { removeFile test1 set f [open test1 w] close $f *************** *** 6633,6639 **** set x } {got_error} ! test io-56.1 {ChannelTimerProc} { set f [open fooBar w] puts $f "this is a test" close $f --- 6635,6641 ---- set x } {got_error} ! test io-56.1 {ChannelTimerProc} {testchannel} { set f [open fooBar w] puts $f "this is a test" close $f Index: tests/registry.test =================================================================== RCS file: /cvsroot/tcl/tcl/tests/registry.test,v retrieving revision 1.10 diff -c -r1.10 registry.test *** tests/registry.test 2000/04/10 17:19:03 1.10 --- tests/registry.test 2001/03/16 17:08:16 *************** *** 19,26 **** if {$tcl_platform(platform) == "windows"} { if [catch { ! set lib [lindex [glob [file join [pwd] [file dirname \ ! [info nameofexecutable]] tclreg*.dll]] 0] load $lib registry }] { puts "Unable to find the registry package. Skipping registry tests." --- 19,26 ---- if {$tcl_platform(platform) == "windows"} { if [catch { ! set lib [lindex [glob -directory [file join [pwd] [file dirname \ ! [info nameofexecutable]]] tclreg*.dll] 0] load $lib registry }] { puts "Unable to find the registry package. Skipping registry tests." Index: tests/unixFCmd.test =================================================================== RCS file: /cvsroot/tcl/tcl/tests/unixFCmd.test,v retrieving revision 1.11 diff -c -r1.11 unixFCmd.test *** tests/unixFCmd.test 2000/04/10 17:19:05 1.11 --- tests/unixFCmd.test 2001/03/16 17:08:16 *************** *** 32,38 **** testchmod 777 $path if {[file isdirectory $path]} { catch { ! foreach p [glob [file join $path *]] { openup $p } } --- 32,38 ---- testchmod 777 $path if {[file isdirectory $path]} { catch { ! foreach p [glob -directory $path *] { openup $p } } *************** *** 43,49 **** foreach p ". $args" { set x "" catch { ! set x [glob [file join $p tf*] [file join $p td*]] } foreach file $x { if {[catch {file delete -force -- $file}]} { --- 43,49 ---- foreach p ". $args" { set x "" catch { ! set x [glob -directory $p tf* td*] } foreach file $x { if {[catch {file delete -force -- $file}]} { Index: tests/winDde.test =================================================================== RCS file: /cvsroot/tcl/tcl/tests/winDde.test,v retrieving revision 1.8 diff -c -r1.8 winDde.test *** tests/winDde.test 2000/04/10 17:19:06 1.8 --- tests/winDde.test 2001/03/16 17:08:16 *************** *** 18,25 **** if {$tcl_platform(platform) == "windows"} { if [catch { ! set lib [lindex [glob [file join [pwd] [file dirname \ ! [info nameofexecutable]] tcldde*.dll]] 0] load $lib dde }] { puts "Unable to find the dde package. Skipping registry tests." --- 18,25 ---- if {$tcl_platform(platform) == "windows"} { if [catch { ! set lib [lindex [glob -directory [file join [pwd] [file dirname \ ! [info nameofexecutable]]] tcldde*.dll] 0] load $lib dde }] { puts "Unable to find the dde package. Skipping registry tests." *************** *** 38,45 **** set f [open $::scriptName w+] puts $f { if [catch { ! set lib [lindex [glob [file join [pwd] [file dirname \ ! [info nameofexecutable]] tcldde*.dll]] 0] load $lib dde }] { puts "Unable to find the dde package. Skipping registry tests." --- 38,45 ---- set f [open $::scriptName w+] puts $f { if [catch { ! set lib [lindex [glob -directory [file join [pwd] [file dirname \ ! [info nameofexecutable]]] tcldde*.dll] 0] load $lib dde }] { puts "Unable to find the dde package. Skipping registry tests." Index: tests/winFCmd.test =================================================================== RCS file: /cvsroot/tcl/tcl/tests/winFCmd.test,v retrieving revision 1.9 diff -c -r1.9 winFCmd.test *** tests/winFCmd.test 2000/04/10 17:19:06 1.9 --- tests/winFCmd.test 2001/03/16 17:08:16 *************** *** 36,42 **** foreach p ". $args" { set x "" catch { ! set x [glob [file join $p tf*] [file join $p td*]] } if {$x != ""} { catch {eval file delete -force -- $x} --- 36,42 ---- foreach p ". $args" { set x "" catch { ! set x [glob -directory $p tf* td*] } if {$x != ""} { catch {eval file delete -force -- $x} Index: unix/tclUnixFCmd.c =================================================================== RCS file: /cvsroot/tcl/tcl/unix/tclUnixFCmd.c,v retrieving revision 1.6 diff -c -r1.6 tclUnixFCmd.c *** unix/tclUnixFCmd.c 2000/04/04 08:05:57 1.6 --- unix/tclUnixFCmd.c 2001/03/16 17:08:16 *************** *** 150,155 **** --- 150,208 ---- Tcl_DString *sourcePtr, Tcl_DString *destPtr, Tcl_DString *errorPtr)); + int + TclpObjCreateDirectory(Tcl_Obj *pathPtr) { + return TclpCreateDirectory(Tcl_FSGetTranslatedPath(NULL, pathPtr)); + } + + int + TclpObjDeleteFile(Tcl_Obj *pathPtr) { + return TclpDeleteFile(Tcl_FSGetTranslatedPath(NULL, pathPtr)); + } + + int + TclpObjCopyDirectory(Tcl_Obj *srcPathPtr, + Tcl_Obj *destPathPtr, Tcl_Obj **errorPtr) { + Tcl_DString ds; + int ret; + ret = TclpCopyDirectory(Tcl_FSGetTranslatedPath(NULL,srcPathPtr), + Tcl_FSGetTranslatedPath(NULL,destPathPtr), &ds); + if (ret != TCL_OK) { + *errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1); + Tcl_DStringFree(&ds); + Tcl_IncrRefCount(*errorPtr); + } + return ret; + } + + int + TclpObjCopyFile(Tcl_Obj *srcPathPtr, + Tcl_Obj *destPathPtr) { + return TclpCopyFile(Tcl_FSGetTranslatedPath(NULL,srcPathPtr), + Tcl_FSGetTranslatedPath(NULL,destPathPtr)); + } + + int + TclpObjRemoveDirectory(Tcl_Obj *pathPtr, + int recursive, Tcl_Obj **errorPtr) { + Tcl_DString ds; + int ret; + ret = TclpRemoveDirectory(Tcl_FSGetTranslatedPath(NULL, pathPtr),recursive, &ds); + if (ret != TCL_OK) { + *errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1); + Tcl_DStringFree(&ds); + Tcl_IncrRefCount(*errorPtr); + } + return ret; + } + + int + TclpObjRenameFile(Tcl_Obj *srcPathPtr, + Tcl_Obj *destPathPtr) { + return TclpRenameFile(Tcl_FSGetTranslatedPath(NULL,srcPathPtr), + Tcl_FSGetTranslatedPath(NULL,destPathPtr)); + } + /* *--------------------------------------------------------------------------- * *************** *** 1608,1611 **** --- 1661,1713 ---- } } return TCL_OK; + } + + /* + *--------------------------------------------------------------------------- + * + * TclpObjNormalizePath -- + * + * This function scans through a path specification and replaces + * it, in place, with a normalized version. On unix, this simply + * ascertains where the valid path ends, and makes no change in + * place. + * + * Results: + * The new 'nextCheckpoint' value, giving as far as we could + * understand in the path. + * + * Side effects: + * The pathPtr string, which must contain a valid path, is + * not modified (unlike Windows, MacOS versions). + * + *--------------------------------------------------------------------------- + */ + + int + TclpObjNormalizePath(interp, pathPtr, nextCheckpoint) + Tcl_Interp *interp; + Tcl_Obj *pathPtr; + int nextCheckpoint; + { + char *path = Tcl_GetString(pathPtr); + + while (1) { + char cur = path[nextCheckpoint]; + if (cur == 0) { + break; + } + if (cur == '/') { + int access; + path[nextCheckpoint] = 0; + access = TclpAccess(path, F_OK); + path[nextCheckpoint] = '/'; + if (access != 0) { + /* File doesn't exist */ + break; + } + } + nextCheckpoint++; + } + return nextCheckpoint; } Index: unix/tclUnixFile.c =================================================================== RCS file: /cvsroot/tcl/tcl/unix/tclUnixFile.c,v retrieving revision 1.9 diff -c -r1.9 tclUnixFile.c *** unix/tclUnixFile.c 2000/01/11 22:09:19 1.9 --- unix/tclUnixFile.c 2001/03/16 17:08:16 *************** *** 15,20 **** --- 15,22 ---- #include "tclInt.h" #include "tclPort.h" + char * TclpGetCwd _ANSI_ARGS_((Tcl_Interp *interp, Tcl_DString *bufferPtr)); + /* *--------------------------------------------------------------------------- *************** *** 176,221 **** /* *---------------------------------------------------------------------- * ! * TclpMatchFilesTypes -- * * This routine is used by the globbing code to search a * directory for all files which match a given pattern. * * 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 ! TclpMatchFilesTypes(interp, separators, dirPtr, pattern, tail, types) ! 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. */ { ! char *native, *fname, *dirName, *patternEnd = tail; ! char savedChar = 0; /* lint. */ DIR *d; Tcl_DString ds; struct stat statBuf; int matchHidden; int result = TCL_OK; ! int baseLength = Tcl_DStringLength(dirPtr); ! Tcl_Obj *resultPtr; /* * Make sure that the directory part of the name really is a * directory. If the directory name is "", use the name "." --- 178,231 ---- /* *---------------------------------------------------------------------- * ! * TclpMatchInDirectory -- * * This routine is used by the globbing code to search a * directory for all files which match a given pattern. * * Results: ! * If dirOnly is set, we are simply to find matching directories ! * and ignore all other information -- this is used by TclDoGlob ! * to handle recursion, in which 'pattern' is just a piece of ! * the pattern. ! * ! * The return value is a standard Tcl result indicating whether an ! * error occurred in globbing. Errors are left in interp, good ! * results are lappended to resultPtr (which must be a valid object) * * Side effects: * None. * ! *---------------------------------------------------------------------- */ int ! TclpMatchInDirectory(interp, resultPtr, pathPtr, pattern, dirOnly, types) ! Tcl_Interp *interp; /* Interpreter to receive errors. */ ! Tcl_Obj *resultPtr; /* List object to lappend results. */ ! Tcl_Obj *pathPtr; /* Contains path to directory to search. */ char *pattern; /* Pattern to match against. */ ! int dirOnly; /* 1 if we want dirs, and ignore types */ GlobTypeData *types; /* Object containing list of acceptable types. * May be NULL. */ { ! char *native, *fname, *dirName; DIR *d; Tcl_DString ds; struct stat statBuf; int matchHidden; int result = TCL_OK; ! Tcl_DString dsOrig; ! char *fileName; ! int baseLength; + fileName = Tcl_FSGetTranslatedPath(interp, pathPtr); + if (fileName == NULL) { + return TCL_ERROR; + } + Tcl_DStringInit(&dsOrig); + Tcl_DStringAppend(&dsOrig, fileName, -1); + baseLength = Tcl_DStringLength(&dsOrig); + /* * Make sure that the directory part of the name really is a * directory. If the directory name is "", use the name "." *************** *** 224,237 **** * otherwise "glob foo.c" would return "./foo.c". */ ! if (Tcl_DStringLength(dirPtr) == 0) { dirName = "."; } else { ! dirName = Tcl_DStringValue(dirPtr); } if ((TclpStat(dirName, &statBuf) != 0) /* INTL: UTF-8. */ || !S_ISDIR(statBuf.st_mode)) { return TCL_OK; } --- 234,254 ---- * otherwise "glob foo.c" would return "./foo.c". */ ! if (baseLength == 0) { dirName = "."; } else { ! dirName = Tcl_DStringValue(&dsOrig); ! /* Make sure we have a trailing directory delimiter */ ! if (dirName[baseLength-1] != '/') { ! Tcl_DStringAppend(&dsOrig, "/", 1); ! dirName = Tcl_DStringValue(&dsOrig); ! baseLength++; ! } } if ((TclpStat(dirName, &statBuf) != 0) /* INTL: UTF-8. */ || !S_ISDIR(statBuf.st_mode)) { + Tcl_DStringFree(&dsOrig); return TCL_OK; } *************** *** 254,259 **** --- 271,277 ---- d = opendir(native); /* INTL: Native. */ Tcl_DStringFree(&ds); if (d == NULL) { + char savedChar = '\0'; Tcl_ResetResult(interp); /* *************** *** 261,299 **** */ if (baseLength > 0) { ! savedChar = (Tcl_DStringValue(dirPtr))[baseLength-1]; if (savedChar == '/') { ! (Tcl_DStringValue(dirPtr))[baseLength-1] = '\0'; } } Tcl_AppendResult(interp, "couldn't read directory \"", ! Tcl_DStringValue(dirPtr), "\": ", Tcl_PosixError(interp), (char *) NULL); if (baseLength > 0) { ! (Tcl_DStringValue(dirPtr))[baseLength-1] = savedChar; } return TCL_ERROR; } - /* - * Clean up the end of the pattern and the tail pointer. Leave - * the tail pointing to the first character after the path separator - * following the pattern, or NULL. Also, ensure that the pattern - * is null-terminated. - */ - - if (*tail == '\\') { - tail++; - } - if (*tail == '\0') { - tail = NULL; - } else { - tail++; - } - savedChar = *patternEnd; - *patternEnd = '\0'; - - resultPtr = Tcl_GetObjResult(interp); while (1) { char *utf; struct dirent *entryPtr; --- 279,299 ---- */ if (baseLength > 0) { ! savedChar = (Tcl_DStringValue(&dsOrig))[baseLength-1]; if (savedChar == '/') { ! (Tcl_DStringValue(&dsOrig))[baseLength-1] = '\0'; } } Tcl_AppendResult(interp, "couldn't read directory \"", ! Tcl_DStringValue(&dsOrig), "\": ", Tcl_PosixError(interp), (char *) NULL); if (baseLength > 0) { ! (Tcl_DStringValue(&dsOrig))[baseLength-1] = savedChar; } + Tcl_DStringFree(&dsOrig); return TCL_ERROR; } while (1) { char *utf; struct dirent *entryPtr; *************** *** 328,337 **** utf = Tcl_ExternalToUtfDString(NULL, entryPtr->d_name, -1, &ds); if (Tcl_StringMatch(utf, pattern) != 0) { ! Tcl_DStringSetLength(dirPtr, baseLength); ! Tcl_DStringAppend(dirPtr, utf, -1); ! fname = Tcl_DStringValue(dirPtr); ! if (tail == NULL) { int typeOk = 1; if (types != NULL) { if (types->perm != 0) { --- 328,337 ---- utf = Tcl_ExternalToUtfDString(NULL, entryPtr->d_name, -1, &ds); if (Tcl_StringMatch(utf, pattern) != 0) { ! Tcl_DStringSetLength(&dsOrig, baseLength); ! Tcl_DStringAppend(&dsOrig, utf, -1); ! fname = Tcl_DStringValue(&dsOrig); ! if (!dirOnly) { int typeOk = 1; if (types != NULL) { if (types->perm != 0) { *************** *** 396,441 **** } if (typeOk) { Tcl_ListObjAppendElement(interp, resultPtr, ! Tcl_NewStringObj(fname, ! Tcl_DStringLength(dirPtr))); } } else if ((TclpStat(fname, &statBuf) == 0) && S_ISDIR(statBuf.st_mode)) { ! Tcl_DStringAppend(dirPtr, "/", 1); ! result = TclDoGlob(interp, separators, dirPtr, tail, types); ! if (result != TCL_OK) { ! Tcl_DStringFree(&ds); ! break; ! } } } Tcl_DStringFree(&ds); } - *patternEnd = savedChar; closedir(d); 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); - } - /* *--------------------------------------------------------------------------- * --- 396,417 ---- } if (typeOk) { Tcl_ListObjAppendElement(interp, resultPtr, ! Tcl_NewStringObj(fname, Tcl_DStringLength(&dsOrig))); } } else if ((TclpStat(fname, &statBuf) == 0) && S_ISDIR(statBuf.st_mode)) { ! Tcl_ListObjAppendElement(interp, resultPtr, ! Tcl_NewStringObj(fname, Tcl_DStringLength(&dsOrig))); } } Tcl_DStringFree(&ds); } closedir(d); + Tcl_DStringFree(&dsOrig); return result; } /* *--------------------------------------------------------------------------- * *************** *** 693,696 **** --- 669,732 ---- return result; } + + int + TclpObjLstat(Tcl_Obj *pathPtr, struct stat *buf) { + return lstat(Tcl_FSGetNativePath(pathPtr), buf); + } + + int + TclpObjStat(Tcl_Obj *pathPtr, struct stat *buf) { + return stat(Tcl_FSGetNativePath(pathPtr), buf); + } + + Tcl_Obj* + TclpObjGetCwd(Tcl_Interp *interp) { + Tcl_DString ds; + if (TclpGetCwd(interp, &ds) != NULL) { + Tcl_Obj *cwdPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1); + Tcl_IncrRefCount(cwdPtr); + Tcl_DStringFree(&ds); + return cwdPtr; + } else { + return NULL; + } + } + + int + TclpObjChdir(Tcl_Obj *pathPtr) { + return chdir(Tcl_FSGetNativePath(pathPtr)); + } + + int + TclpObjAccess(Tcl_Obj *pathPtr, int mode) { + return access(Tcl_FSGetNativePath(pathPtr), mode); + } + + #ifdef S_IFLNK + + Tcl_Obj* TclpObjReadlink(Tcl_Obj *pathPtr) { + char link[MAXPATHLEN]; + int length; + char *native; + Tcl_Obj* linkPtr; + + if (Tcl_FSGetTranslatedPath(NULL, pathPtr) == NULL) { + return NULL; + } + length = readlink(Tcl_FSGetNativePath(pathPtr), link, sizeof(link)); + if (length < 0) { + return NULL; + } + + native = (char*)ckalloc((unsigned)(1+length)); + strcpy(native, link); + linkPtr = Tcl_FSNewNativePath(pathPtr, native); + Tcl_IncrRefCount(linkPtr); + return linkPtr; + } + + #endif + + Index: unix/tclUnixInit.c =================================================================== RCS file: /cvsroot/tcl/tcl/unix/tclUnixInit.c,v retrieving revision 1.20 diff -c -r1.20 tclUnixInit.c *** unix/tclUnixInit.c 2000/10/31 00:48:53 1.20 --- unix/tclUnixInit.c 2001/03/16 17:08:17 *************** *** 29,34 **** --- 29,36 ---- */ #include "tclInitScript.h" + /* Used to store the encoding used for binary files */ + static Tcl_Encoding binaryEncoding = NULL; /* * Default directory in which to look for Tcl library scripts. The *************** *** 500,506 **** * gets on a binary channel. */ ! Tcl_GetEncoding(NULL, "iso8859-1"); } /* --- 502,540 ---- * gets on a binary channel. */ ! binaryEncoding = Tcl_GetEncoding(NULL, "iso8859-1"); ! } ! ! /* ! *--------------------------------------------------------------------------- ! * ! * TclpVerifyInitialEncodings -- ! * ! * Part way through startup, we verify that the initial encodings ! * were correctly setup. Depending on Tcl's environment, there ! * may not have been enough information first time through (above). ! * ! * Called at process initialization time. ! * ! * Results: ! * None. ! * ! * Side effects: ! * Encodings may change. ! * ! *--------------------------------------------------------------------------- ! */ ! void TclpVerifyInitialEncodings() ! { ! CONST char *encoding; ! ! /* We should perhaps reload the system encoding */ ! ! /* This is only ever called from the startup thread */ ! if (binaryEncoding == NULL) { ! encoding = "iso8859-1"; ! binaryEncoding = Tcl_GetEncoding(NULL, encoding); ! } } /* Index: win/makefile.vc =================================================================== RCS file: /cvsroot/tcl/tcl/win/makefile.vc,v retrieving revision 1.59 diff -c -r1.59 makefile.vc *** win/makefile.vc 2000/11/03 21:23:28 1.59 --- win/makefile.vc 2001/03/16 17:08:17 *************** *** 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/tclWinFCmd.c =================================================================== RCS file: /cvsroot/tcl/tcl/win/tclWinFCmd.c,v retrieving revision 1.8 diff -c -r1.8 tclWinFCmd.c *** win/tclWinFCmd.c 2000/05/22 23:55:09 1.8 --- win/tclWinFCmd.c 2001/03/16 17:08:17 *************** *** 103,108 **** --- 103,161 ---- Tcl_DString *errorPtr); + int + TclpObjCreateDirectory(Tcl_Obj *pathPtr) { + return TclpCreateDirectory(Tcl_FSGetTranslatedPath(NULL, pathPtr)); + } + + int + TclpObjDeleteFile(Tcl_Obj *pathPtr) { + return TclpDeleteFile(Tcl_FSGetTranslatedPath(NULL, pathPtr)); + } + + int + TclpObjCopyDirectory(Tcl_Obj *srcPathPtr, + Tcl_Obj *destPathPtr, Tcl_Obj **errorPtr) { + Tcl_DString ds; + int ret; + ret = TclpCopyDirectory(Tcl_FSGetTranslatedPath(NULL,srcPathPtr), + Tcl_FSGetTranslatedPath(NULL,destPathPtr), &ds); + if (ret != TCL_OK) { + *errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1); + Tcl_DStringFree(&ds); + Tcl_IncrRefCount(*errorPtr); + } + return ret; + } + + int + TclpObjCopyFile(Tcl_Obj *srcPathPtr, + Tcl_Obj *destPathPtr) { + return TclpCopyFile(Tcl_FSGetTranslatedPath(NULL,srcPathPtr), + Tcl_FSGetTranslatedPath(NULL,destPathPtr)); + } + + int + TclpObjRemoveDirectory(Tcl_Obj *pathPtr, + int recursive, Tcl_Obj **errorPtr) { + Tcl_DString ds; + int ret; + ret = TclpRemoveDirectory(Tcl_FSGetTranslatedPath(NULL, pathPtr),recursive, &ds); + if (ret != TCL_OK) { + *errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1); + Tcl_DStringFree(&ds); + Tcl_IncrRefCount(*errorPtr); + } + return ret; + } + + int + TclpObjRenameFile(Tcl_Obj *srcPathPtr, + Tcl_Obj *destPathPtr) { + return TclpRenameFile(Tcl_FSGetTranslatedPath(NULL,srcPathPtr), + Tcl_FSGetTranslatedPath(NULL,destPathPtr)); + } + /* *--------------------------------------------------------------------------- * *************** *** 1289,1294 **** --- 1342,1447 ---- } /* + *--------------------------------------------------------------------------- + * + * TclpNormalizePath -- + * + * This function scans through a path specification and replaces + * it, in place, with a normalized version. On windows this + * means using the 'longname'. + * + * Results: + * The new 'nextCheckpoint' value, giving as far as we could + * understand in the path. + * + * Side effects: + * The pathPtr string, which must contain a valid path, is + * possibly modified in place. + * + *--------------------------------------------------------------------------- + */ + + int + TclpNormalizePath(interp, pathPtr, nextCheckpoint) + Tcl_Interp *interp; + Tcl_DString *pathPtr; + int nextCheckpoint; + { + char *currentPathEndPosition; + char *lastValidPathEnd = NULL; + char *path = Tcl_DStringValue(pathPtr); + + currentPathEndPosition = path + nextCheckpoint; + + while (1) { + char cur = *currentPathEndPosition; + if (cur == '/' || cur == 0) { + /* Reached directory separator, or end of string */ + Tcl_DString ds; + DWORD attr; + char * nativePath; + nativePath = Tcl_WinUtfToTChar(path, currentPathEndPosition - path, &ds); + attr = (*tclWinProcs->getFileAttributesProc)(nativePath); + Tcl_DStringFree(&ds); + + if (attr == 0xffffffff) { + /* File doesn't exist */ + break; + } + lastValidPathEnd = currentPathEndPosition; + /* File does exist */ + if (cur == 0) { + break; + } + } + currentPathEndPosition++; + } + nextCheckpoint = currentPathEndPosition - path; + if (lastValidPathEnd != NULL) { + /* + * The leading end of the path description was acceptable to + * us. We therefore convert it to its long form, and return + * that. + */ + Tcl_Obj* objPtr = NULL; + int endOfString; + int useLength = lastValidPathEnd - path; + if (*lastValidPathEnd == 0) { + endOfString = 1; + } else { + endOfString = 0; + path[useLength] = 0; + } + /* + * If this returns an error, we have a strange situation; the + * file exists, but we can't get its long name. We will have + * to assume the name we have is ok. + */ + if (ConvertFileNameFormat(interp, 0, path, 1, &objPtr) == TCL_OK) { + /* objPtr now has a refCount of 0 */ + int len; + (void) Tcl_GetStringFromObj(objPtr,&len); + if (!endOfString) { + /* Be nice and fix the string before we clear it */ + path[useLength] = '/'; + Tcl_AppendToObj(objPtr, lastValidPathEnd, -1); + } + nextCheckpoint += (len - useLength); + Tcl_DStringSetLength(pathPtr,0); + path = Tcl_GetStringFromObj(objPtr,&len); + Tcl_DStringAppend(pathPtr,path,len); + /* Free up the objPtr */ + Tcl_DecrRefCount(objPtr); + } else { + if (!endOfString) { + path[useLength] = '/'; + } + } + } + return nextCheckpoint; + } + + /* *---------------------------------------------------------------------- * * ConvertFileNameFormat -- *************** *** 1449,1455 **** * * GetWinFileLongName -- * ! * Returns a Tcl_Obj containing the short version of the file * name. * * Results: --- 1602,1608 ---- * * GetWinFileLongName -- * ! * Returns a Tcl_Obj containing the long version of the file * name. * * Results: *************** *** 1661,1664 **** --- 1814,1914 ---- } } return TCL_OK; + } + + /* + *--------------------------------------------------------------------------- + * + * TclpObjNormalizePath -- + * + * This function scans through a path specification and replaces + * it, in place, with a normalized version. On windows this + * means using the 'longname'. + * + * Results: + * The new 'nextCheckpoint' value, giving as far as we could + * understand in the path. + * + * Side effects: + * The pathPtr string, which must contain a valid path, is + * possibly modified in place. + * + *--------------------------------------------------------------------------- + */ + + int + TclpObjNormalizePath(interp, pathPtr, nextCheckpoint) + Tcl_Interp *interp; + Tcl_Obj *pathPtr; + int nextCheckpoint; + { + char *currentPathEndPosition; + char *lastValidPathEnd = NULL; + char *path = Tcl_GetString(pathPtr); + + currentPathEndPosition = path + nextCheckpoint; + + while (1) { + char cur = *currentPathEndPosition; + if (cur == '/' || cur == 0) { + /* Reached directory separator, or end of string */ + Tcl_DString ds; + DWORD attr; + char * nativePath; + nativePath = Tcl_WinUtfToTChar(path, currentPathEndPosition - path, &ds); + attr = (*tclWinProcs->getFileAttributesProc)(nativePath); + Tcl_DStringFree(&ds); + + if (attr == 0xffffffff) { + /* File doesn't exist */ + break; + } + lastValidPathEnd = currentPathEndPosition; + /* File does exist */ + if (cur == 0) { + break; + } + } + currentPathEndPosition++; + } + nextCheckpoint = currentPathEndPosition - path; + if (lastValidPathEnd != NULL) { + /* + * The leading end of the path description was acceptable to + * us. We therefore convert it to its long form, and return + * that. + */ + Tcl_Obj* objPtr = NULL; + int endOfString; + int useLength = lastValidPathEnd - path; + if (*lastValidPathEnd == 0) { + endOfString = 1; + } else { + endOfString = 0; + path[useLength] = 0; + } + /* + * If this returns an error, we have a strange situation; the + * file exists, but we can't get its long name. We will have + * to assume the name we have is ok. + */ + if (ConvertFileNameFormat(interp, 0, path, 1, &objPtr) == TCL_OK) { + int len; + (void) Tcl_GetStringFromObj(objPtr,&len); + if (!endOfString) { + /* Be nice and fix the string before we clear it */ + path[useLength] = '/'; + Tcl_AppendToObj(objPtr, lastValidPathEnd, -1); + } + nextCheckpoint += (len - useLength); + path = Tcl_GetStringFromObj(objPtr,&len); + Tcl_SetStringObj(pathPtr,path, len); + Tcl_DecrRefCount(objPtr); + } else { + if (!endOfString) { + path[useLength] = '/'; + } + } + } + return nextCheckpoint; } Index: win/tclWinFile.c =================================================================== RCS file: /cvsroot/tcl/tcl/win/tclWinFile.c,v retrieving revision 1.9 diff -c -r1.9 tclWinFile.c *** win/tclWinFile.c 2000/10/27 01:58:00 1.9 --- win/tclWinFile.c 2001/03/16 17:08:17 *************** *** 89,105 **** /* *---------------------------------------------------------------------- * ! * TclpMatchFilesTypes -- * * This routine is used by the globbing code to search a * directory for all files which match a given pattern. * * 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. --- 89,108 ---- /* *---------------------------------------------------------------------- * ! * TclpMatchInDirectory -- * * This routine is used by the globbing code to search a * directory for all files which match a given pattern. * * Results: ! * If dirOnly is set, we are simply to find matching directories ! * and ignore all other information -- this is used by TclDoGlob ! * to handle recursion, in which 'pattern' is just a piece of ! * the pattern. ! * ! * The return value is a standard Tcl result indicating whether an ! * error occurred in globbing. Errors are left in interp, good ! * results are lappended to resultPtr (which must be a valid object) * * Side effects: * None. *************** *** 107,160 **** *---------------------------------------------------------------------- */ int ! TclpMatchFilesTypes( ! 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. */ { char drivePat[] = "?:\\"; const char *message; ! char *dir, *newPattern, *root; ! int matchDotFiles; ! int dirLength, result = TCL_OK; ! Tcl_DString dirString, patternString; DWORD attr, volFlags; HANDLE handle; WIN32_FIND_DATAT data; BOOL found; Tcl_DString ds; TCHAR *nativeName; ! Tcl_Obj *resultPtr; ! /* * Convert the path to normalized form since some interfaces only * accept backslashes. Also, ensure that the directory ends with a * separator character. */ ! dirLength = Tcl_DStringLength(dirPtr); Tcl_DStringInit(&dirString); if (dirLength == 0) { Tcl_DStringAppend(&dirString, ".\\", 2); } else { char *p; ! Tcl_DStringAppend(&dirString, Tcl_DStringValue(dirPtr), ! Tcl_DStringLength(dirPtr)); for (p = Tcl_DStringValue(&dirString); *p != '\0'; p++) { if (*p == '/') { *p = '\\'; } } p--; if ((*p != '\\') && (*p != ':')) { Tcl_DStringAppend(&dirString, "\\", 1); } } dir = Tcl_DStringValue(&dirString); --- 110,172 ---- *---------------------------------------------------------------------- */ int ! TclpMatchInDirectory(interp, resultPtr, pathPtr, pattern, dirOnly, types) ! Tcl_Interp *interp; /* Interpreter to receive errors. */ ! Tcl_Obj *resultPtr; /* List object to lappend results. */ ! Tcl_Obj *pathPtr; /* Contains path to directory to search. */ ! char *pattern; /* Pattern to match against. */ ! int dirOnly; /* 1 if we want dirs, and ignore types */ ! GlobTypeData *types; /* Object containing list of acceptable types. * May be NULL. */ { char drivePat[] = "?:\\"; const char *message; ! char *dir, *root; ! int dirLength; ! Tcl_DString dirString; DWORD attr, volFlags; HANDLE handle; WIN32_FIND_DATAT data; BOOL found; Tcl_DString ds; + Tcl_DString dsOrig; + char *fileName; TCHAR *nativeName; ! int matchSpecialDots; ! /* * Convert the path to normalized form since some interfaces only * accept backslashes. Also, ensure that the directory ends with a * separator character. */ ! fileName = Tcl_FSGetTranslatedPath(interp, pathPtr); ! if (fileName == NULL) { ! return TCL_ERROR; ! } ! Tcl_DStringInit(&dsOrig); ! Tcl_DStringAppend(&dsOrig, fileName, -1); ! ! dirLength = Tcl_DStringLength(&dsOrig); Tcl_DStringInit(&dirString); if (dirLength == 0) { Tcl_DStringAppend(&dirString, ".\\", 2); } else { char *p; ! Tcl_DStringAppend(&dirString, Tcl_DStringValue(&dsOrig), ! Tcl_DStringLength(&dsOrig)); for (p = Tcl_DStringValue(&dirString); *p != '\0'; p++) { if (*p == '/') { *p = '\\'; } } p--; + /* Make sure we have a trailing directory delimiter */ if ((*p != '\\') && (*p != ':')) { Tcl_DStringAppend(&dirString, "\\", 1); + Tcl_DStringAppend(&dsOrig, "/", 1); + dirLength++; } } dir = Tcl_DStringValue(&dirString); *************** *** 220,233 **** } /* ! * In Windows, although some volumes may support case sensitivity, Windows ! * doesn't honor case. So in globbing we need to ignore the case ! * of file names. */ ! Tcl_DStringInit(&patternString); ! newPattern = Tcl_DStringAppend(&patternString, pattern, tail - pattern); ! Tcl_UtfToLower(newPattern); /* * We need to check all files in the directory, so append a *.* --- 232,251 ---- } /* ! * Check to see if the pattern should match the special ! * . and .. names, referring to the current directory, ! * or the directory above. We need a special check for ! * this because paths beginning with a dot are not considered ! * hidden on Windows, and so otherwise a relative glob like ! * 'glob -join * *' will actually return './. ../..' etc. */ ! if ((pattern[0] == '.') ! || ((pattern[0] == '\\') && (pattern[1] == '.'))) { ! matchSpecialDots = 1; ! } else { ! matchSpecialDots = 0; ! } /* * We need to check all files in the directory, so append a *.* *************** *** 245,279 **** } /* - * Clean up the tail pointer. Leave the tail pointing to the - * first character after the path separator or NULL. - */ - - if (*tail == '\\') { - tail++; - } - if (*tail == '\0') { - tail = NULL; - } else { - tail++; - } - - /* - * Check to see if the pattern needs to compare with dot files. - */ - - if ((newPattern[0] == '.') - || ((pattern[0] == '\\') && (pattern[1] == '.'))) { - matchDotFiles = 1; - } else { - matchDotFiles = 0; - } - - /* * Now iterate over all of the files in the directory. */ - resultPtr = Tcl_GetObjResult(interp); for (found = 1; found != 0; found = (*tclWinProcs->findNextFileProc)(handle, &data)) { TCHAR *nativeMatchResult; --- 263,271 ---- *************** *** 286,294 **** } name = Tcl_WinTCharToUtf(nativeName, -1, &ds); /* ! * Check to see if the file matches the pattern. We need to convert ! * the file name to lower case for comparison purposes. Note that we * are ignoring the case sensitivity flag because Windows doesn't honor * case even if the volume is case sensitive. If the volume also * doesn't preserve case, then we previously returned the lower case --- 278,294 ---- } name = Tcl_WinTCharToUtf(nativeName, -1, &ds); + if (!matchSpecialDots) { + /* If it is exactly '.' or '..' then we ignore it */ + if (name[0] == '.') { + if (name[1] == '\0' || (name[1] == '.' && name[2] == '\0')) { + continue; + } + } + } + /* ! * Check to see if the file matches the pattern. Note that we * are ignoring the case sensitivity flag because Windows doesn't honor * case even if the volume is case sensitive. If the volume also * doesn't preserve case, then we previously returned the lower case *************** *** 297,310 **** * we are returning exactly what we get from the system. */ - Tcl_UtfToLower(name); nativeMatchResult = NULL; ! if ((matchDotFiles == 0) && (name[0] == '.')) { ! /* ! * Ignore hidden files. ! */ ! } else if (Tcl_StringMatch(name, newPattern) != 0) { nativeMatchResult = nativeName; } Tcl_DStringFree(&ds); --- 297,305 ---- * we are returning exactly what we get from the system. */ nativeMatchResult = NULL; ! if (Tcl_StringCaseMatch(name, pattern, 1) != 0) { nativeMatchResult = nativeName; } Tcl_DStringFree(&ds); *************** *** 315,331 **** /* * If the file matches, then we need to process the remainder of the ! * path. If there are more characters to process, then ensure matching ! * files are directories and call TclDoGlob. Otherwise, just add the ! * file to the result. */ name = Tcl_WinTCharToUtf(nativeMatchResult, -1, &ds); ! Tcl_DStringAppend(dirPtr, name, -1); Tcl_DStringFree(&ds); ! fname = Tcl_DStringValue(dirPtr); ! nativeName = Tcl_WinUtfToTChar(fname, Tcl_DStringLength(dirPtr), &ds); /* * 'attr' represents the attributes of the file, but we only --- 310,324 ---- /* * If the file matches, then we need to process the remainder of the ! * path. */ name = Tcl_WinTCharToUtf(nativeMatchResult, -1, &ds); ! Tcl_DStringAppend(&dsOrig, name, -1); Tcl_DStringFree(&ds); ! fname = Tcl_DStringValue(&dsOrig); ! nativeName = Tcl_WinUtfToTChar(fname, Tcl_DStringLength(&dsOrig), &ds); /* * 'attr' represents the attributes of the file, but we only *************** *** 335,350 **** attr = 0; ! if (tail == NULL) { int typeOk = 1; ! if (types != NULL) { ! if (types->perm != 0) { ! attr = (*tclWinProcs->getFileAttributesProc)(nativeName); if ( ((types->perm & TCL_GLOB_PERM_RONLY) && !(attr & FILE_ATTRIBUTE_READONLY)) || - ((types->perm & TCL_GLOB_PERM_HIDDEN) && - !(attr & FILE_ATTRIBUTE_HIDDEN)) || ((types->perm & TCL_GLOB_PERM_R) && (TclpAccess(fname, R_OK) != 0)) || ((types->perm & TCL_GLOB_PERM_W) && --- 328,358 ---- attr = 0; ! if (!dirOnly) { int typeOk = 1; ! attr = (*tclWinProcs->getFileAttributesProc)(nativeName); ! if (types == NULL) { ! /* If invisible, don't return the file */ ! if (attr & FILE_ATTRIBUTE_HIDDEN) { ! typeOk = 0; ! } ! } else { ! if (attr & FILE_ATTRIBUTE_HIDDEN) { ! /* If invisible */ ! if ((types->perm == 0) || ! !(types->perm & TCL_GLOB_PERM_HIDDEN)) { ! typeOk = 0; ! } ! } else { ! /* Visible */ ! if (types->perm & TCL_GLOB_PERM_HIDDEN) { ! typeOk = 0; ! } ! } ! if (typeOk == 1 && types->perm != 0) { if ( ((types->perm & TCL_GLOB_PERM_RONLY) && !(attr & FILE_ATTRIBUTE_READONLY)) || ((types->perm & TCL_GLOB_PERM_R) && (TclpAccess(fname, R_OK) != 0)) || ((types->perm & TCL_GLOB_PERM_W) && *************** *** 394,409 **** } if (typeOk) { Tcl_ListObjAppendElement(interp, resultPtr, ! Tcl_NewStringObj(fname, Tcl_DStringLength(dirPtr))); } } else { attr = (*tclWinProcs->getFileAttributesProc)(nativeName); if (attr & FILE_ATTRIBUTE_DIRECTORY) { ! Tcl_DStringAppend(dirPtr, "/", 1); ! result = TclDoGlob(interp, separators, dirPtr, tail, types); ! if (result != TCL_OK) { ! break; ! } } } /* --- 402,414 ---- } if (typeOk) { Tcl_ListObjAppendElement(interp, resultPtr, ! Tcl_NewStringObj(fname, Tcl_DStringLength(&dsOrig))); } } else { attr = (*tclWinProcs->getFileAttributesProc)(nativeName); if (attr & FILE_ATTRIBUTE_DIRECTORY) { ! Tcl_ListObjAppendElement(interp, resultPtr, ! Tcl_NewStringObj(fname, Tcl_DStringLength(&dsOrig))); } } /* *************** *** 412,454 **** Tcl_DStringFree(&ds); ! Tcl_DStringSetLength(dirPtr, dirLength); } FindClose(handle); Tcl_DStringFree(&dirString); ! Tcl_DStringFree(&patternString); ! return result; error: Tcl_DStringFree(&dirString); TclWinConvertError(GetLastError()); Tcl_ResetResult(interp); ! Tcl_AppendResult(interp, message, Tcl_DStringValue(dirPtr), "\": ", Tcl_PosixError(interp), (char *) NULL); 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); - } - /* *---------------------------------------------------------------------- * --- 417,441 ---- Tcl_DStringFree(&ds); ! Tcl_DStringSetLength(&dsOrig, dirLength); } FindClose(handle); Tcl_DStringFree(&dirString); ! Tcl_DStringFree(&dsOrig); ! return TCL_OK; error: Tcl_DStringFree(&dirString); TclWinConvertError(GetLastError()); Tcl_ResetResult(interp); ! Tcl_AppendResult(interp, message, Tcl_DStringValue(&dsOrig), "\": ", Tcl_PosixError(interp), (char *) NULL); + Tcl_DStringFree(&dsOrig); return TCL_ERROR; } /* *---------------------------------------------------------------------- * *************** *** 573,578 **** --- 560,566 ---- return result; } + /* *--------------------------------------------------------------------------- *************** *** 768,774 **** /* *---------------------------------------------------------------------- * ! * TclpStat -- * * This function replaces the library version of stat(), fixing * the following bugs: --- 756,762 ---- /* *---------------------------------------------------------------------- * ! * TclpObjStat -- * * This function replaces the library version of stat(), fixing * the following bugs: *************** *** 788,797 **** *---------------------------------------------------------------------- */ ! int ! TclpStat(path, statPtr) ! CONST char *path; /* Path of file to stat (UTF-8). */ ! struct stat *statPtr; /* Filled with results of stat call. */ { Tcl_DString ds; TCHAR *nativePath; --- 776,785 ---- *---------------------------------------------------------------------- */ ! int ! TclpObjStat(pathPtr, statPtr) ! Tcl_Obj *pathPtr; /* Path of file to stat */ ! struct stat *statPtr; /* Filled with results of stat call. */ { Tcl_DString ds; TCHAR *nativePath; *************** *** 808,819 **** * call to FindFirstFile() will expand them, matching some other file. */ ! if (strpbrk(path, "?*") != NULL) { Tcl_SetErrno(ENOENT); return -1; } ! nativePath = Tcl_WinUtfToTChar(path, -1, &ds); handle = (*tclWinProcs->findFirstFileProc)(nativePath, &data); if (handle == INVALID_HANDLE_VALUE) { /* --- 796,807 ---- * call to FindFirstFile() will expand them, matching some other file. */ ! if (strpbrk(Tcl_FSGetTranslatedPath(NULL, pathPtr), "?*") != NULL) { Tcl_SetErrno(ENOENT); return -1; } ! nativePath = (TCHAR *) Tcl_FSGetNativePath(pathPtr); handle = (*tclWinProcs->findFirstFileProc)(nativePath, &data); if (handle == INVALID_HANDLE_VALUE) { /* *************** *** 823,829 **** attr = (*tclWinProcs->getFileAttributesProc)(nativePath); if (attr == 0xffffffff) { - Tcl_DStringFree(&ds); Tcl_SetErrno(ENOENT); return -1; } --- 811,816 ---- *************** *** 842,848 **** (*tclWinProcs->getFullPathNameProc)(nativePath, MAX_PATH, nativeFullPath, &nativePart); - Tcl_DStringFree(&ds); fullPath = Tcl_WinTCharToUtf((TCHAR *) nativeFullPath, -1, &ds); dev = -1; --- 829,834 ---- *************** *** 887,893 **** attr = data.a.dwFileAttributes; mode = (attr & FILE_ATTRIBUTE_DIRECTORY) ? S_IFDIR | S_IEXEC : S_IFREG; mode |= (attr & FILE_ATTRIBUTE_READONLY) ? S_IREAD : S_IREAD | S_IWRITE; ! p = strrchr(path, '.'); if (p != NULL) { if ((lstrcmpiA(p, ".exe") == 0) || (lstrcmpiA(p, ".com") == 0) --- 873,879 ---- attr = data.a.dwFileAttributes; mode = (attr & FILE_ATTRIBUTE_DIRECTORY) ? S_IFDIR | S_IEXEC : S_IFREG; mode |= (attr & FILE_ATTRIBUTE_READONLY) ? S_IREAD : S_IREAD | S_IWRITE; ! p = strrchr(Tcl_FSGetTranslatedPath(NULL, pathPtr), '.'); if (p != NULL) { if ((lstrcmpiA(p, ".exe") == 0) || (lstrcmpiA(p, ".com") == 0) *************** *** 1048,1050 **** --- 1034,1155 ---- return 0; } #endif + + Tcl_Obj* + TclpObjGetCwd(Tcl_Interp *interp) { + Tcl_DString ds; + if (TclpGetCwd(interp, &ds) != NULL) { + Tcl_Obj *cwdPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1); + Tcl_IncrRefCount(cwdPtr); + Tcl_DStringFree(&ds); + return cwdPtr; + } else { + return NULL; + } + } + + int + TclpObjChdir(Tcl_Obj *pathPtr) { + int result; + TCHAR *nativePath; + + nativePath = (TCHAR *) Tcl_FSGetNativePath(pathPtr); + result = (*tclWinProcs->setCurrentDirectoryProc)(nativePath); + + if (result == 0) { + TclWinConvertError(GetLastError()); + return -1; + } + return 0; + } + + int + TclpObjAccess(Tcl_Obj *pathPtr, int mode) { + TCHAR *nativePath; + DWORD attr; + + nativePath = (TCHAR *) Tcl_FSGetNativePath(pathPtr); + attr = (*tclWinProcs->getFileAttributesProc)(nativePath); + + if (attr == 0xffffffff) { + /* + * File doesn't exist. + */ + + TclWinConvertError(GetLastError()); + return -1; + } + + if ((mode & W_OK) && (attr & FILE_ATTRIBUTE_READONLY)) { + /* + * File is not writable. + */ + + Tcl_SetErrno(EACCES); + return -1; + } + + if (mode & X_OK) { + CONST char *p; + + if (attr & FILE_ATTRIBUTE_DIRECTORY) { + /* + * Directories are always executable. + */ + + return 0; + } + p = strrchr(Tcl_FSGetTranslatedPath(NULL, pathPtr), '.'); + if (p != NULL) { + p++; + if ((stricmp(p, "exe") == 0) + || (stricmp(p, "com") == 0) + || (stricmp(p, "bat") == 0)) { + /* + * File that ends with .exe, .com, or .bat is executable. + */ + + return 0; + } + } + Tcl_SetErrno(EACCES); + return -1; + } + + return 0; + } + + int + TclpObjLstat(Tcl_Obj *pathPtr, struct stat *buf) { + return TclpObjStat(pathPtr,buf); + } + + #ifdef S_IFLNK + + Tcl_Obj* + TclpObjReadlink(Tcl_Obj *pathPtr) { + Tcl_DString ds; + Tcl_Obj* link = NULL; + if (TclpReadlink(Tcl_FSGetTranslatedPath(NULL, pathPtr), &ds) != NULL) { + link = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1); + Tcl_IncrRefCount(link); + Tcl_DStringFree(&ds); + } + return link; + } + + #endif + + /* Obsolete, only called from test suite */ + int + TclpStat(path, statPtr) + CONST char *path; /* Path of file to stat (UTF-8). */ + struct stat *statPtr; /* Filled with results of stat call. */ + { + int retVal; + Tcl_Obj *pathPtr = Tcl_NewStringObj(path,-1); + Tcl_IncrRefCount(pathPtr); + retVal = TclpObjStat(pathPtr, statPtr); + Tcl_DecrRefCount(pathPtr); + return retVal; + } Index: win/tclWinInit.c =================================================================== RCS file: /cvsroot/tcl/tcl/win/tclWinInit.c,v retrieving revision 1.24 diff -c -r1.24 tclWinInit.c *** win/tclWinInit.c 2000/07/26 01:27:58 1.24 --- win/tclWinInit.c 2001/03/16 17:08:17 *************** *** 72,77 **** --- 72,80 ---- "intel", "mips", "alpha", "ppc" }; + /* Used to store the encoding used for binary files */ + static Tcl_Encoding binaryEncoding = NULL; + /* * The Init script (common to Windows and Unix platforms) is * defined in tkInitScript.h *************** *** 499,505 **** */ encoding = "iso8859-1"; ! Tcl_GetEncoding(NULL, encoding); } /* --- 502,543 ---- */ encoding = "iso8859-1"; ! binaryEncoding = Tcl_GetEncoding(NULL, encoding); ! } ! ! /* ! *--------------------------------------------------------------------------- ! * ! * TclpVerifyInitialEncodings -- ! * ! * Part way through startup, we verify that the initial encodings ! * were correctly setup. Depending on Tcl's environment, there ! * may not have been enough information first time through (above). ! * ! * Called at process initialization time. ! * ! * Results: ! * None. ! * ! * Side effects: ! * Encodings may change. ! * ! *--------------------------------------------------------------------------- ! */ ! void TclpVerifyInitialEncodings() ! { ! CONST char *encoding; ! char buf[4 + TCL_INTEGER_SPACE]; ! ! /* We just reload the system encoding */ ! wsprintfA(buf, "cp%d", GetACP()); ! Tcl_SetSystemEncoding(NULL, buf); ! ! /* This is only ever called from the startup thread */ ! if (binaryEncoding == NULL) { ! encoding = "iso8859-1"; ! binaryEncoding = Tcl_GetEncoding(NULL, encoding); ! } } /*