diff options
53 files changed, 8636 insertions, 2364 deletions
@@ -1,3 +1,61 @@ +2001-07-31 Vince Darley <vincentdarley@users.sourceforge.net> + + Changes from TIP#17 "Redo Tcl's filesystem" + The following files were impacted: + * doc/Access.3: + * doc/FileSystem.3: + * doc/OpenFileChnl.3: + * doc/file.n: + * doc/glob.n: + * generic/tcl.decls: + * generic/tcl.h: + * generic/tclCmdAH.c: + * generic/tclCmdIL.c: + * generic/tclCmdMZ.c: + * generic/tclDate.c: + * generic/tclDecls.h: + * generic/tclEncoding.c: + * generic/tclFCmd.c: + * generic/tclFileName.c: + * generic/tclGetDate.y: + * generic/tclIO.c: + * generic/tclIOCmd.c: + * generic/tclIOUtil.c: + * generic/tclInt.decls: + * generic/tclInt.h: + * generic/tclIntDecls.h: + * generic/tclLoad.c: + * generic/tclStubInit.c: + * generic/tclTest.c: + * generic/tclUtil.c: + * library/init.tcl: + * mac/tclMacFCmd.c: + * mac/tclMacFile.c: + * mac/tclMacInit.c: + * mac/tclMacPort.h: + * mac/tclMacResource.c: + * mac/tclMacTime.c: + * tests/cmdAH.test: + * tests/event.test: + * tests/fCmd.test: + * tests/fileName.test: + * tests/io.test: + * tests/ioCmd.test: + * tests/proc-old.test: + * tests/registry.test: + * tests/unixFCmd.test: + * tests/winDde.test: + * tests/winFCmd.test: + * unix/mkLinks: + * unix/tclUnixFCmd.c: + * unix/tclUnixFile.c: + * unix/tclUnixInit.c: + * unix/tclUnixPipe.c: + * win/tclWinFCmd.c: + * win/tclWinFile.c: + * win/tclWinInit.c: + * win/tclWinPipe.c + 2001-07-24 Mo DeJong <mdejong@redhat.com> * win/tclWinThrd.c (Tcl_CreateThread): Close Windows diff --git a/doc/Access.3 b/doc/Access.3 index c81cf10..daa4f53 100644 --- a/doc/Access.3 +++ b/doc/Access.3 @@ -4,7 +4,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: Access.3,v 1.3 1999/05/06 19:14:39 stanton Exp $ +'\" RCS: @(#) $Id: Access.3,v 1.4 2001/07/31 19:12:05 vincentdarley Exp $ '\" .so man.macros .TH Tcl_Access 3 8.1 Tcl "Tcl Library Procedures" @@ -35,6 +35,10 @@ The structure that contains the result. .SH DESCRIPTION .PP +As of Tcl 8.4, the object-based APIs \fBTcl_FSAccess\fR and +\fBTcl_FSStat\fR should be used in preference to \fBTcl_Access\fR and +\fBTcl_Stat\fR, wherever possible. +.PP There are two reasons for calling \fBTcl_Access\fR and \fBTcl_Stat\fR rather than calling system level functions \fBaccess\fR and \fBstat\fR directly. First, the Windows implementation of both functions fixes diff --git a/doc/OpenFileChnl.3 b/doc/OpenFileChnl.3 index 45d1410..eeafd08 100644 --- a/doc/OpenFileChnl.3 +++ b/doc/OpenFileChnl.3 @@ -4,13 +4,13 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: OpenFileChnl.3,v 1.9 2000/04/25 00:54:53 ericm Exp $ +'\" RCS: @(#) $Id: OpenFileChnl.3,v 1.10 2001/07/31 19:12:05 vincentdarley Exp $ .so man.macros .TH Tcl_OpenFileChannel 3 8.3 Tcl "Tcl Library Procedures" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME -Tcl_OpenFileChannel, Tcl_OpenCommandChannel, Tcl_MakeFileChannel, Tcl_GetChannel, Tcl_GetChannelNames, Tcl_GetChannelNamesEx, Tcl_RegisterChannel, Tcl_UnregisterChannel, Tcl_Close, Tcl_ReadChars, Tcl_Read, Tcl_GetsObj, Tcl_Gets, Tcl_WriteObj, Tcl_WriteChars, Tcl_Write, Tcl_Flush, Tcl_Seek, Tcl_Tell, Tcl_GetChannelOption, Tcl_SetChannelOption, Tcl_Eof, Tcl_InputBlocked, Tcl_InputBuffered, Tcl_Ungets \- buffered I/O facilities using channels +Tcl_OpenFileChannel, Tcl_OpenCommandChannel, Tcl_MakeFileChannel, Tcl_GetChannel, Tcl_GetChannelNames, Tcl_GetChannelNamesEx, Tcl_RegisterChannel, Tcl_UnregisterChannel, Tcl_DetachChannel, Tcl_IsStandardChannel, Tcl_Close, Tcl_ReadChars, Tcl_Read, Tcl_GetsObj, Tcl_Gets, Tcl_WriteObj, Tcl_WriteChars, Tcl_Write, Tcl_Flush, Tcl_Seek, Tcl_Tell, Tcl_GetChannelOption, Tcl_SetChannelOption, Tcl_Eof, Tcl_InputBlocked, Tcl_InputBuffered, Tcl_Ungets \- buffered I/O facilities using channels .SH SYNOPSIS .nf \fB#include <tcl.h>\fR @@ -46,6 +46,12 @@ int \fBTcl_UnregisterChannel\fR(\fIinterp, channel\fR) .sp int +\fBTcl_DetachChannel\fR(\fIinterp, channel\fR) +.sp +int +\fBTcl_IsStandardChannel\fR(\fIchannel\fR) +.sp +int \fBTcl_Close\fR(\fIinterp, channel\fR) .sp .VS 8.1 @@ -236,7 +242,11 @@ If an error occurs while opening the channel, \fBTcl_OpenFileChannel\fR returns NULL and records a POSIX error code that can be retrieved with \fBTcl_GetErrno\fR. In addition, if \fIinterp\fR is non-NULL, \fBTcl_OpenFileChannel\fR -leaves an error message in \fIinterp\fR's result after any error. +leaves an error message in \fIinterp\fR's result after any error. +As of Tcl 8.4, the object-based API \fBTcl_FSOpenFileChannel\fR should +be used in preference to \fBTcl_OpenFileChannel\fR wherever possible. +.PP + .PP The newly created channel is not registered in the supplied interpreter; to register it, use \fBTcl_RegisterChannel\fR, described below. @@ -339,7 +349,33 @@ interpreter, the channel is also closed and destroyed. Code not associated with a Tcl interpreter can call \fBTcl_UnregisterChannel\fR with \fIinterp\fR as NULL, to indicate to Tcl that it no longer holds a reference to that channel. If this is the last -reference to the channel, it will now be closed. +reference to the channel, it will now be closed. \fBTcl_UnregisterChannel\fR +is very similar to \fBTcl_DetachChannel\fR except that it will also +close the channel if no further references to it exist. + +.SH TCL_DETACHCHANNEL +.PP +\fBTcl_DetachChannel\fR removes a channel from the set of channels +accessible in \fIinterp\fR. After this call, Tcl programs will no longer be +able to use the channel's name to refer to the channel in that interpreter. +Beyond that, this command has no further effect. It cannot be used on +the standard channels (stdout, stderr, stdin), and will return +TCL_ERROR if passed one of those channels. +.PP +Code not associated with a Tcl interpreter can call +\fBTcl_DetachChannel\fR with \fIinterp\fR as NULL, to indicate to Tcl +that it no longer holds a reference to that channel. If this is the last +reference to the channel, unlike \fBTcl_UnregisterChannel\fR, +it will not be closed. + +.SH TCL_ISSTANDARDCHANNEL +.PP +\fBTcl_IsStandardChannel\fR tests whether a channel is one of the +three standard channels, stdin, stdout or stderr. If so, it returns +1, otherwise 0. +.PP +No attempt is made to check whether the given channel or the standard +channels are initialized or otherwise valid. .SH TCL_CLOSE .PP @@ -5,7 +5,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: file.n,v 1.6 2000/09/07 14:27:47 poenitz Exp $ +'\" RCS: @(#) $Id: file.n,v 1.7 2001/07/31 19:12:06 vincentdarley Exp $ '\" .so man.macros .TH file n 8.3 Tcl "Tcl Built-In Commands" @@ -216,6 +216,16 @@ Returns the platform-specific name of the file. This is useful if the 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,6 +277,14 @@ Returns all of the characters in \fIname\fR up to but not including the 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 @@ -303,6 +321,19 @@ 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. If a filesystem only supports one type of +file, the second element may be null. 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 generic virtual file system might return +the list 'vfs ftp' to represent a file on a remote ftp site mounted as +a virtual filesystem through an extension called 'vfs'. If the file +does not belong to any filesystem, an error is generated. +.TP \fBfile tail \fIname\fR . Returns all of the characters in \fIname\fR after the last directory @@ -5,7 +5,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: glob.n,v 1.8 2000/09/07 14:27:48 poenitz Exp $ +'\" RCS: @(#) $Id: glob.n,v 1.9 2001/07/31 19:12:06 vincentdarley Exp $ '\" .so man.macros .TH glob n 8.3 Tcl "Tcl Built-In Commands" @@ -52,6 +52,15 @@ similar to a given file even when the names contain glob-sensitive 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 @@ -114,8 +123,14 @@ Matches the character \fIx\fR. \fB{\fIa\fB,\fIb\fB,\fI...\fR} Matches any of the strings \fIa\fR, \fIb\fR, etc. .LP -As with csh, a ``.'' at the beginning of a file's name or just -after a ``/'' must be matched explicitly or with a {} construct. +On Unix, as with csh, a ``.'' at the beginning of a file's name or just +after a ``/'' must be matched explicitly or with a {} construct, +unless the ``-types hidden'' flag is given (since ``.'' at the beginning +of a file's name indicates that it is hidden). On other platforms, +files beginning with a ``.'' are handled no differently to any others, +except the special directories ``.'' and ``..'' which must be matched +explicitly (this is to avoid a recursive pattern like ``glob -join * * +* *'' from recursing up the directory hierarchy as well as down). In addition, all ``/'' characters must be matched explicitly. .LP If the first character in a \fIpattern\fR is ``~'' then it refers diff --git a/generic/tcl.decls b/generic/tcl.decls index 679cff8..482d5fa 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: tcl.decls,v 1.50 2001/07/12 13:15:09 dkf Exp $ +# RCS: @(#) $Id: tcl.decls,v 1.51 2001/07/31 19:12:06 vincentdarley Exp $ library tcl @@ -1514,7 +1514,6 @@ declare 432 generic { declare 433 generic { Tcl_ThreadId Tcl_GetChannelThread(Tcl_Channel channel) } - # introduced in 8.4a3 declare 434 generic { Tcl_UniChar * Tcl_GetUnicodeFromObj (Tcl_Obj *objPtr, int *lengthPtr) @@ -1530,6 +1529,134 @@ declare 436 generic { declare 437 generic { Tcl_Obj * Tcl_SubstObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags) } +declare 438 generic { + int Tcl_DetachChannel(Tcl_Interp* interp, Tcl_Channel channel) +} +declare 439 generic { + int Tcl_IsStandardChannel(Tcl_Channel channel) +} +declare 440 generic { + int Tcl_FSCopyFile(Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr) +} +declare 441 generic { + int Tcl_FSCopyDirectory(Tcl_Obj *srcPathPtr, \ + Tcl_Obj *destPathPtr, Tcl_Obj **errorPtr) +} +declare 442 generic { + int Tcl_FSCreateDirectory(Tcl_Obj *pathPtr) +} +declare 443 generic { + int Tcl_FSDeleteFile(Tcl_Obj *pathPtr) +} +declare 444 generic { + int Tcl_FSLoadFile(Tcl_Interp * interp, \ + Tcl_Obj *pathPtr, char * sym1, char * sym2, \ + Tcl_PackageInitProc ** proc1Ptr, \ + Tcl_PackageInitProc ** proc2Ptr, \ + ClientData * clientDataPtr, \ + Tcl_FSUnloadFileProc **unloadProcPtr) +} +declare 445 generic { + int Tcl_FSMatchInDirectory(Tcl_Interp *interp, Tcl_Obj * result, \ + Tcl_Obj *pathPtr, \ + char * pattern, Tcl_GlobTypeData * types) +} +declare 446 generic { + Tcl_Obj* Tcl_FSReadlink(Tcl_Obj *pathPtr) +} +declare 447 generic { + int Tcl_FSRemoveDirectory(Tcl_Obj *pathPtr, \ + int recursive, Tcl_Obj **errorPtr) +} +declare 448 generic { + int Tcl_FSRenameFile(Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr) +} +declare 449 generic { + int Tcl_FSLstat(Tcl_Obj *pathPtr, struct stat *buf) +} +declare 450 generic { + int Tcl_FSUtime(Tcl_Obj *pathPtr, struct utimbuf *tval) +} +declare 451 generic { + int Tcl_FSFileAttrsGet(Tcl_Interp *interp, \ + int index, Tcl_Obj *pathPtr, \ + Tcl_Obj **objPtrRef) +} +declare 452 generic { + int Tcl_FSFileAttrsSet(Tcl_Interp *interp, \ + int index, Tcl_Obj *pathPtr, \ + Tcl_Obj *objPtr) +} +declare 453 generic { + char** Tcl_FSFileAttrStrings(Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef) +} +declare 454 generic { + int Tcl_FSStat(Tcl_Obj *pathPtr, struct stat *buf) +} +declare 455 generic { + int Tcl_FSAccess(Tcl_Obj *pathPtr, int mode) +} +declare 456 generic { + Tcl_Channel Tcl_FSOpenFileChannel(Tcl_Interp *interp, Tcl_Obj *pathPtr, \ + char *modeString, int permissions) +} +declare 457 generic { + Tcl_Obj* Tcl_FSGetCwd(Tcl_Interp *interp) +} +declare 458 generic { + int Tcl_FSChdir(Tcl_Obj *pathPtr) +} +declare 459 generic { + int Tcl_FSConvertToPathType(Tcl_Interp *interp, Tcl_Obj *pathPtr) +} +declare 460 generic { + Tcl_Obj* Tcl_FSJoinPath(Tcl_Obj *listObj, int elements) +} +declare 461 generic { + Tcl_Obj* Tcl_FSSplitPath(Tcl_Obj* pathPtr, int *lenPtr) +} +declare 462 generic { + int Tcl_FSEqualPaths(Tcl_Obj* firstPtr, Tcl_Obj* secondPtr) +} +declare 463 generic { + Tcl_Obj* Tcl_FSGetNormalizedPath(Tcl_Interp *interp, Tcl_Obj* pathObjPtr) +} +declare 464 generic { + Tcl_Obj* Tcl_FSJoinToPath(Tcl_Obj *basePtr, int objc, Tcl_Obj *CONST objv[]) +} +declare 465 generic { + ClientData Tcl_FSGetInternalRep(Tcl_Obj* pathObjPtr, Tcl_Filesystem *fsPtr) +} +declare 466 generic { + char* Tcl_FSGetTranslatedPath(Tcl_Interp *interp, Tcl_Obj* pathPtr) +} +declare 467 generic { + int Tcl_FSEvalFile(Tcl_Interp *interp, Tcl_Obj *fileName) +} +declare 468 generic { + Tcl_Obj* Tcl_FSNewNativePath(Tcl_Obj* fromFilesystem, ClientData clientData) +} +declare 469 generic { + char* Tcl_FSGetNativePath(Tcl_Obj* pathObjPtr) +} +declare 470 generic { + Tcl_Obj* Tcl_FSFileSystemInfo(Tcl_Obj* pathObjPtr) +} +declare 471 generic { + Tcl_Obj* Tcl_FSPathSeparator(Tcl_Obj* pathObjPtr) +} +declare 472 generic { + int Tcl_FSListVolumes(Tcl_Interp *interp) +} +declare 473 generic { + int Tcl_FSRegister(ClientData clientData, Tcl_Filesystem *fsPtr) +} +declare 474 generic { + int Tcl_FSUnregister(Tcl_Filesystem *fsPtr) +} +declare 475 generic { + ClientData Tcl_FSData(Tcl_Filesystem *fsPtr) +} ############################################################################## diff --git a/generic/tcl.h b/generic/tcl.h index 08ae9c3..6e3ab91 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tcl.h,v 1.93 2001/07/17 02:01:23 mdejong Exp $ + * RCS: @(#) $Id: tcl.h,v 1.94 2001/07/31 19:12:06 vincentdarley Exp $ */ #ifndef _TCL @@ -1474,6 +1474,304 @@ typedef enum Tcl_PathType { TCL_PATH_VOLUME_RELATIVE } Tcl_PathType; +/* + * The following structure is used to pass glob type data amongst + * the various glob routines and Tcl_FSMatchInDirectory. + */ +typedef struct Tcl_GlobTypeData { + /* Corresponds to bcdpfls as in 'find -t' */ + int type; + /* Corresponds to file permissions */ + int perm; + /* Acceptable mac type */ + Tcl_Obj* macType; + /* Acceptable mac creator */ + Tcl_Obj* macCreator; +} Tcl_GlobTypeData; + +/* + * type and permission definitions for glob command + */ +#define TCL_GLOB_TYPE_BLOCK (1<<0) +#define TCL_GLOB_TYPE_CHAR (1<<1) +#define TCL_GLOB_TYPE_DIR (1<<2) +#define TCL_GLOB_TYPE_PIPE (1<<3) +#define TCL_GLOB_TYPE_FILE (1<<4) +#define TCL_GLOB_TYPE_LINK (1<<5) +#define TCL_GLOB_TYPE_SOCK (1<<6) + +#define TCL_GLOB_PERM_RONLY (1<<0) +#define TCL_GLOB_PERM_HIDDEN (1<<1) +#define TCL_GLOB_PERM_R (1<<2) +#define TCL_GLOB_PERM_W (1<<3) +#define TCL_GLOB_PERM_X (1<<4) + +/* + * Typedefs for the various filesystem operations: + */ + +typedef int (Tcl_FSStatProc) _ANSI_ARGS_((Tcl_Obj *pathPtr, struct stat *buf)); +typedef int (Tcl_FSAccessProc) _ANSI_ARGS_((Tcl_Obj *pathPtr, int mode)); +typedef Tcl_Channel (Tcl_FSOpenFileChannelProc) + _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *pathPtr, + char *modeString, int permissions)); +typedef int (Tcl_FSMatchInDirectoryProc) _ANSI_ARGS_((Tcl_Interp* interp, + Tcl_Obj *result, Tcl_Obj *pathPtr, char *pattern, + Tcl_GlobTypeData * types)); +typedef Tcl_Obj* (Tcl_FSGetCwdProc) _ANSI_ARGS_((Tcl_Interp *interp)); +typedef int (Tcl_FSChdirProc) _ANSI_ARGS_((Tcl_Obj *pathPtr)); +typedef int (Tcl_FSLstatProc) _ANSI_ARGS_((Tcl_Obj *pathPtr, + struct stat *buf)); +typedef int (Tcl_FSCreateDirectoryProc) _ANSI_ARGS_((Tcl_Obj *pathPtr)); +typedef int (Tcl_FSDeleteFileProc) _ANSI_ARGS_((Tcl_Obj *pathPtr)); +typedef int (Tcl_FSCopyDirectoryProc) _ANSI_ARGS_((Tcl_Obj *srcPathPtr, + Tcl_Obj *destPathPtr, Tcl_Obj **errorPtr)); +typedef int (Tcl_FSCopyFileProc) _ANSI_ARGS_((Tcl_Obj *srcPathPtr, + Tcl_Obj *destPathPtr)); +typedef int (Tcl_FSRemoveDirectoryProc) _ANSI_ARGS_((Tcl_Obj *pathPtr, + int recursive, Tcl_Obj **errorPtr)); +typedef int (Tcl_FSRenameFileProc) _ANSI_ARGS_((Tcl_Obj *srcPathPtr, + Tcl_Obj *destPathPtr)); +typedef void (Tcl_FSUnloadFileProc) _ANSI_ARGS_((ClientData clientData)); +typedef int (Tcl_FSListVolumesProc) _ANSI_ARGS_((Tcl_Interp *interp)); +/* We have to declare the utime structure here. */ +struct utimbuf; +typedef int (Tcl_FSUtimeProc) _ANSI_ARGS_((Tcl_Obj *pathPtr, + struct utimbuf *tval)); +typedef int (Tcl_FSNormalizePathProc) _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *pathPtr, int nextCheckpoint)); +typedef int (Tcl_FSFileAttrsGetProc) _ANSI_ARGS_((Tcl_Interp *interp, + int index, Tcl_Obj *pathPtr, + Tcl_Obj **objPtrRef)); +typedef char** (Tcl_FSFileAttrStringsProc) _ANSI_ARGS_((Tcl_Obj *pathPtr, + Tcl_Obj** objPtrRef)); +typedef int (Tcl_FSFileAttrsSetProc) _ANSI_ARGS_((Tcl_Interp *interp, + int index, Tcl_Obj *pathPtr, + Tcl_Obj *objPtr)); +typedef Tcl_Obj* (Tcl_FSReadlinkProc) _ANSI_ARGS_((Tcl_Obj *pathPtr)); +typedef int (Tcl_FSLoadFileProc) _ANSI_ARGS_((Tcl_Interp * interp, + Tcl_Obj *pathPtr, char * sym1, char * sym2, + Tcl_PackageInitProc ** proc1Ptr, + Tcl_PackageInitProc ** proc2Ptr, + ClientData * clientDataPtr)); +typedef int (Tcl_FSPathInFilesystemProc) _ANSI_ARGS_((Tcl_Obj *pathPtr, + ClientData *clientDataPtr)); +typedef Tcl_Obj* (Tcl_FSFilesystemPathTypeProc) + _ANSI_ARGS_((Tcl_Obj *pathPtr)); +typedef Tcl_Obj* (Tcl_FSFilesystemSeparatorProc) + _ANSI_ARGS_((Tcl_Obj *pathPtr)); +typedef void (Tcl_FSFreeInternalRepProc) _ANSI_ARGS_((ClientData clientData)); +typedef ClientData (Tcl_FSDupInternalRepProc) + _ANSI_ARGS_((ClientData clientData)); +typedef Tcl_Obj* (Tcl_FSInternalToNormalizedProc) + _ANSI_ARGS_((ClientData clientData)); +typedef ClientData (Tcl_FSCreateInternalRepProc) _ANSI_ARGS_((Tcl_Obj *pathPtr)); + +typedef struct Tcl_FSVersion_ *Tcl_FSVersion; + +/* + *---------------------------------------------------------------- + * Data structures related to hooking into the filesystem + *---------------------------------------------------------------- + */ + +/* + * Filesystem version tag. This was introduced in 8.4. + */ + +#define TCL_FILESYSTEM_VERSION_1 ((Tcl_FSVersion) 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. The explanations in the structure show + * the importance of each function. + */ + +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_FSVersion version; + /* Version of the filesystem type. */ + Tcl_FSPathInFilesystemProc *pathInFilesystemProc; + /* Function to check whether a path is in + * this filesystem. This is the most + * important filesystem procedure. */ + Tcl_FSDupInternalRepProc *dupInternalRepProc; + /* Function to duplicate internal fs rep. May + * be NULL (but then fs is less efficient). */ + Tcl_FSFreeInternalRepProc *freeInternalRepProc; + /* Function to free internal fs rep. Must + * be implemented, if internal representations + * need freeing, otherwise it can be NULL. */ + Tcl_FSInternalToNormalizedProc *internalToNormalizedProc; + /* Function to convert internal representation + * to a normalized path. Only required if + * the fs creates pure path objects with no + * string/path representation. */ + Tcl_FSCreateInternalRepProc *createInternalRepProc; + /* Function to create a filesystem-specific + * internal representation. May be NULL + * if paths have no internal representation, + * or if the Tcl_FSPathInFilesystemProc + * for this filesystem always immediately + * creates an internal representation for + * paths it accepts. */ + Tcl_FSNormalizePathProc *normalizePathProc; + /* Function to normalize a path. Should + * be implemented for all filesystems + * which can have multiple string + * representations for the same path + * object. */ + Tcl_FSFilesystemPathTypeProc *filesystemPathTypeProc; + /* Function to determine the type of a + * path in this filesystem. May be NULL. */ + Tcl_FSFilesystemSeparatorProc *filesystemSeparatorProc; + /* Function to return the separator + * character(s) for this filesystem. Must + * be implemented. */ + Tcl_FSStatProc *statProc; + /* + * Function to process a 'Tcl_FSStat()' + * call. Must be implemented for any + * reasonable filesystem. + */ + Tcl_FSAccessProc *accessProc; + /* + * Function to process a 'Tcl_FSAccess()' + * call. Must be implemented for any + * reasonable filesystem. + */ + Tcl_FSOpenFileChannelProc *openFileChannelProc; + /* + * Function to process a + * 'Tcl_FSOpenFileChannel()' call. Must be + * implemented for any reasonable + * filesystem. + */ + Tcl_FSMatchInDirectoryProc *matchInDirectoryProc; + /* Function to process a + * 'Tcl_FSMatchInDirectory()'. If not + * implemented, then glob and recursive + * copy functionality will be lacking in + * the filesystem. */ + Tcl_FSUtimeProc *utimeProc; + /* Function to process a + * 'Tcl_FSUtime()' call. Required to + * allow setting (not reading) of times + * with 'file mtime', 'file atime' and + * the open-r/open-w/fcopy implementation + * of 'file copy'. */ + Tcl_FSReadlinkProc *readlinkProc; + /* Function to process a + * 'Tcl_FSReadlink()' call. Should be + * implemented only if the filesystem supports + * links. */ + Tcl_FSListVolumesProc *listVolumesProc; + /* Function to list any filesystem volumes + * added by this filesystem. Should be + * implemented only if the filesystem adds + * volumes at the head of the filesystem. */ + Tcl_FSFileAttrStringsProc *fileAttrStringsProc; + /* Function to list all attributes strings + * which are valid for this filesystem. + * If not implemented the filesystem will + * not support the 'file attributes' command. + * This allows arbitrary additional information + * to be attached to files in the filesystem. */ + Tcl_FSFileAttrsGetProc *fileAttrsGetProc; + /* Function to process a + * 'Tcl_FSFileAttrsGet()' call, used by + * 'file attributes'. */ + Tcl_FSFileAttrsSetProc *fileAttrsSetProc; + /* Function to process a + * 'Tcl_FSFileAttrsSet()' call, used by + * 'file attributes'. */ + Tcl_FSCreateDirectoryProc *createDirectoryProc; + /* Function to process a + * 'Tcl_FSCreateDirectory()' call. Should + * be implemented unless the FS is + * read-only. */ + Tcl_FSRemoveDirectoryProc *removeDirectoryProc; + /* Function to process a + * 'Tcl_FSRemoveDirectory()' call. Should + * be implemented unless the FS is + * read-only. */ + Tcl_FSDeleteFileProc *deleteFileProc; + /* Function to process a + * 'Tcl_FSDeleteFile()' call. Should + * be implemented unless the FS is + * read-only. */ + Tcl_FSLstatProc *lstatProc; + /* Function to process a + * 'Tcl_FSLstat()' call. If not implemented, + * Tcl will attempt to use the 'statProc' + * defined above instead. */ + Tcl_FSCopyFileProc *copyFileProc; + /* Function to process a + * 'Tcl_FSCopyFile()' call. If not + * implemented Tcl will fall back + * on open-r, open-w and fcopy as + * a copying mechanism. */ + Tcl_FSRenameFileProc *renameFileProc; + /* Function to process a + * 'Tcl_FSRenameFile()' call. If not + * implemented, Tcl will fall back on + * a copy and delete mechanism. */ + Tcl_FSCopyDirectoryProc *copyDirectoryProc; + /* Function to process a + * 'Tcl_FSCopyDirectory()' call. If + * not implemented, Tcl will fall back + * on a recursive create-dir, file copy + * mechanism. */ + Tcl_FSLoadFileProc *loadFileProc; + /* Function to process a + * 'Tcl_FSLoadFile()' call. If not + * implemented, Tcl will fall back on + * a copy to native-temp followed by a + * Tcl_FSLoadFile on that temporary copy. */ + Tcl_FSUnloadFileProc *unloadFileProc; + /* Function to unload a previously + * successfully loaded file. If load was + * implemented, then this should also be + * implemented, if there is any cleanup + * action required. */ + Tcl_FSGetCwdProc *getCwdProc; + /* + * Function to process a 'Tcl_FSGetCwd()' + * call. Most filesystems need not + * implement this. It will usually only be + * called once, if 'getcwd' is called + * before 'chdir'. May be NULL. + */ + Tcl_FSChdirProc *chdirProc; + /* + * Function to process a 'Tcl_FSChdir()' + * call. If filesystems do not implement + * this, it will be emulated by a series of + * directory access checks. Otherwise, + * virtual filesystems which do implement + * it need only respond 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 (i.e. call + * the correct system 'chdir' api). If not + * implemented, then 'cd' and 'pwd' will + * fail inside the filesystem. + */ +} Tcl_Filesystem; + /* * The following structure represents the Notifier functions that * you can override with the Tcl_SetNotifier call. diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index c928224..5866ac4 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -11,15 +11,13 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCmdAH.c,v 1.12 2000/01/21 02:25:26 hobbs Exp $ + * RCS: @(#) $Id: tclCmdAH.c,v 1.13 2001/07/31 19:12:06 vincentdarley Exp $ */ #include "tclInt.h" #include "tclPort.h" #include <locale.h> -typedef int (StatProc)_ANSI_ARGS_((CONST char *path, struct stat *buf)); - /* * Prototypes for local procedures defined in this file: */ @@ -27,15 +25,13 @@ typedef int (StatProc)_ANSI_ARGS_((CONST char *path, struct stat *buf)); 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, + Tcl_Obj *objPtr, Tcl_FSStatProc *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[])); /* *---------------------------------------------------------------------- @@ -307,8 +303,7 @@ Tcl_CdObjCmd(dummy, interp, objc, objv) int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { - char *dirName; - Tcl_DString ds; + Tcl_Obj *dir; int result; if (objc > 2) { @@ -317,23 +312,25 @@ Tcl_CdObjCmd(dummy, interp, objc, objv) } if (objc == 2) { - dirName = Tcl_GetString(objv[1]); + dir = objv[1]; } else { - dirName = "~"; + dir = Tcl_NewStringObj("~",1); + Tcl_IncrRefCount(dir); } - if (Tcl_TranslateFileName(interp, dirName, &ds) == NULL) { - return TCL_ERROR; + 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; + } } - - 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; + if (objc != 2) { + Tcl_DecrRefCount(dir); } - return TCL_OK; + return result; } /* @@ -765,7 +762,9 @@ Tcl_ExprObjCmd(dummy, interp, objc, objv) * 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,9 +794,11 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) "delete", "dirname", "executable", "exists", "extension", "isdirectory", "isfile", "join", "lstat", - "mtime", "mkdir", "nativename", "owned", + "mtime", "mkdir", "nativename", + "normalize", "owned", "pathtype", "readable", "readlink", "rename", - "rootname", "size", "split", "stat", + "rootname", "separator", "size", "split", + "stat", "system", "tail", "type", "volumes", "writable", (char *) NULL }; @@ -806,9 +807,11 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) 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_MTIME, FILE_MKDIR, FILE_NATIVENAME, + FILE_NORMALIZE, FILE_OWNED, FILE_PATHTYPE, FILE_READABLE, FILE_READLINK, FILE_RENAME, - FILE_ROOTNAME, FILE_SIZE, FILE_SPLIT, FILE_STAT, + FILE_ROOTNAME, FILE_SEPARATOR, FILE_SIZE, FILE_SPLIT, + FILE_STAT, FILE_SYSTEM, FILE_TAIL, FILE_TYPE, FILE_VOLUMES, FILE_WRITABLE }; @@ -825,14 +828,13 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) 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) { + if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) { return TCL_ERROR; } if (objc == 4) { @@ -842,11 +844,10 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) } tval.actime = buf.st_atime; tval.modtime = buf.st_mtime; - fileName = Tcl_GetString(objv[2]); - if (utime(fileName, &tval) != 0) { + if (Tcl_FSUtime(objv[2], &tval) != 0) { Tcl_AppendStringsToObj(resultPtr, "could not set access time for file \"", - fileName, "\": ", + Tcl_GetString(objv[2]), "\": ", Tcl_PosixError(interp), (char *) NULL); return TCL_ERROR; } @@ -856,7 +857,7 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) * 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) { + if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) { return TCL_ERROR; } } @@ -875,26 +876,14 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) ((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; + return TclFileCopyCmd(interp, objc, objv); } case FILE_DELETE: { - int result; - char **argv; - - argv = StringifyObjects(objc, objv); - result = TclFileDeleteCmd(interp, objc, argv); - ckfree((char *) argv); - return result; + return TclFileDeleteCmd(interp, objc, objv); } case FILE_DIRNAME: { int argc; - char **argv; + char ** argv; if (objc != 3) { goto only3Args; @@ -959,7 +948,7 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) goto only3Args; } value = 0; - if (GetStatBuf(NULL, objv[2], TclStat, &buf) == TCL_OK) { + if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) { value = S_ISDIR(buf.st_mode); } Tcl_SetBooleanObj(resultPtr, value); @@ -973,27 +962,21 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) goto only3Args; } value = 0; - if (GetStatBuf(NULL, objv[2], TclStat, &buf) == TCL_OK) { + 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: { - char **argv; - Tcl_DString ds; + Tcl_Obj *resObj; 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); + resObj = Tcl_FSJoinToPath(NULL, objc - 2, objv + 2); + Tcl_SetObjResult(interp, resObj); return TCL_OK; } case FILE_LSTAT: { @@ -1004,7 +987,7 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) Tcl_WrongNumArgs(interp, 2, objv, "name varName"); return TCL_ERROR; } - if (GetStatBuf(interp, objv[2], TclpLstat, &buf) != TCL_OK) { + if (GetStatBuf(interp, objv[2], Tcl_FSLstat, &buf) != TCL_OK) { return TCL_ERROR; } varName = Tcl_GetString(objv[3]); @@ -1012,14 +995,13 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) } 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) { + if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) { return TCL_ERROR; } if (objc == 4) { @@ -1029,11 +1011,10 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) } tval.actime = buf.st_atime; tval.modtime = buf.st_mtime; - fileName = Tcl_GetString(objv[2]); - if (utime(fileName, &tval) != 0) { + if (Tcl_FSUtime(objv[2], &tval) != 0) { Tcl_AppendStringsToObj(resultPtr, "could not set modification time for file \"", - fileName, "\": ", + Tcl_GetString(objv[2]), "\": ", Tcl_PosixError(interp), (char *) NULL); return TCL_ERROR; } @@ -1043,7 +1024,7 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) * 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) { + if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) { return TCL_ERROR; } } @@ -1051,17 +1032,11 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) 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; + return TclFileMakeDirsCmd(interp, objc, objv); } case FILE_NATIVENAME: { char *fileName; @@ -1079,6 +1054,18 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) 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,7 +1074,7 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) goto only3Args; } value = 0; - if (GetStatBuf(NULL, objv[2], TclStat, &buf) == TCL_OK) { + 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,52 +1116,30 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) return CheckAccess(interp, objv[2], R_OK); } case FILE_READLINK: { - char *fileName, *contents; - Tcl_DString name, link; + Tcl_Obj *contents; if (objc != 3) { goto only3Args; } - fileName = Tcl_GetString(objv[2]); - fileName = Tcl_TranslateFileName(interp, fileName, &name); - if (fileName == NULL) { + if (Tcl_FSConvertToPathType(interp, objv[2]) != TCL_OK) { 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 */ + contents = Tcl_FSReadlink(objv[2]); - 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); + Tcl_SetObjResult(interp, contents); + Tcl_DecrRefCount(contents); return TCL_OK; } case FILE_RENAME: { - int result; - char **argv; - - argv = StringifyObjects(objc, objv); - result = TclFileRenameCmd(interp, objc, argv); - ckfree((char *) argv); - return result; + return TclFileRenameCmd(interp, objc, objv); } case FILE_ROOTNAME: { int length; @@ -1193,34 +1158,54 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) } 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], TclStat, &buf) != TCL_OK) { + 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: { - 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); + Tcl_SetObjResult(interp, Tcl_FSSplitPath(objv[2], NULL)); return TCL_OK; } case FILE_STAT: { @@ -1231,12 +1216,27 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) Tcl_WrongNumArgs(interp, 1, objv, "stat name varName"); return TCL_ERROR; } - if (GetStatBuf(interp, objv[2], TclStat, &buf) != TCL_OK) { + 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,7 +1268,7 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) if (objc != 3) { goto only3Args; } - if (GetStatBuf(interp, objv[2], TclpLstat, &buf) != TCL_OK) { + if (GetStatBuf(interp, objv[2], Tcl_FSLstat, &buf) != TCL_OK) { return TCL_ERROR; } Tcl_SetStringObj(resultPtr, @@ -1280,7 +1280,7 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; } - return TclpListVolumes(interp); + return Tcl_FSListVolumes(interp); } case FILE_WRITABLE: { if (objc != 3) { @@ -1379,16 +1379,11 @@ CheckAccess(interp, objPtr, mode) * access(). */ { int value; - char *fileName; - Tcl_DString ds; - fileName = Tcl_GetString(objPtr); - fileName = Tcl_TranslateFileName(interp, fileName, &ds); - if (fileName == NULL) { + if (Tcl_FSConvertToPathType(interp, objPtr) != TCL_OK) { value = 0; } else { - value = (TclAccess(fileName, mode) == 0); - Tcl_DStringFree(&ds); + value = (Tcl_FSAccess(objPtr, mode) == 0); } Tcl_SetBooleanObj(Tcl_GetObjResult(interp), value); @@ -1419,23 +1414,18 @@ static int 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 + Tcl_FSStatProc *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) { + if (Tcl_FSConvertToPathType(interp, objPtr) != TCL_OK) { return TCL_ERROR; } - status = (*statProc)(Tcl_DStringValue(&ds), statPtr); - Tcl_DStringFree(&ds); + status = (*statProc)(objPtr, statPtr); if (status < 0) { if (interp != NULL) { @@ -2345,43 +2335,3 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) 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; -} diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 3ba2a34..9cea6a7 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -14,7 +14,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCmdIL.c,v 1.32 2001/06/28 00:42:55 hobbs Exp $ + * RCS: @(#) $Id: tclCmdIL.c,v 1.33 2001/07/31 19:12:06 vincentdarley Exp $ */ #include "tclInt.h" @@ -1663,17 +1663,14 @@ InfoScriptCmd(dummy, interp, objc, objv) } if (objc == 3) { - int length; - char *filename = Tcl_GetStringFromObj(objv[2], &length); - if (iPtr->scriptFile != NULL) { - ckfree(iPtr->scriptFile); + Tcl_DecrRefCount(iPtr->scriptFile); } - iPtr->scriptFile = ckalloc((unsigned) (length + 1)); - strcpy(iPtr->scriptFile, filename); + iPtr->scriptFile = objv[2]; + Tcl_IncrRefCount(iPtr->scriptFile); } if (iPtr->scriptFile != NULL) { - Tcl_SetStringObj(Tcl_GetObjResult(interp), iPtr->scriptFile, -1); + Tcl_SetObjResult(interp, iPtr->scriptFile); } return TCL_OK; } diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 49708d7..b70c7d8 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -13,7 +13,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCmdMZ.c,v 1.41 2001/07/16 18:35:50 hobbs Exp $ + * RCS: @(#) $Id: tclCmdMZ.c,v 1.42 2001/07/31 19:12:06 vincentdarley Exp $ */ #include "tclInt.h" @@ -102,17 +102,19 @@ Tcl_PwdObjCmd(dummy, interp, objc, objv) int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { - Tcl_DString ds; + Tcl_Obj *retVal; if (objc != 1) { Tcl_WrongNumArgs(interp, 1, objv, NULL); return TCL_ERROR; } - if (Tcl_GetCwd(interp, &ds) == NULL) { + retVal = Tcl_FSGetCwd(interp); + if (retVal == NULL) { return TCL_ERROR; } - Tcl_DStringResult(interp, &ds); + Tcl_SetObjResult(interp, retVal); + Tcl_DecrRefCount(retVal); return TCL_OK; } @@ -863,17 +865,12 @@ Tcl_SourceObjCmd(dummy, interp, objc, objv) 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; + return Tcl_FSEvalFile(interp, objv[1]); } /* diff --git a/generic/tclDate.c b/generic/tclDate.c index 9874075..29f9037 100644 --- a/generic/tclDate.c +++ b/generic/tclDate.c @@ -10,13 +10,13 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclDate.c,v 1.18 2000/05/18 22:29:56 ericm Exp $ + * RCS: @(#) $Id: tclDate.c,v 1.19 2001/07/31 19:12:06 vincentdarley Exp $ */ #include "tclInt.h" #include "tclPort.h" -#ifdef MAC_TCL +#if defined(MAC_TCL) && !defined(TCL_MAC_USE_MSL_EPOCH) # define EPOCH 1904 # define START_OF_TIME 1904 # define END_OF_TIME 2039 diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 2e94d6a..2a0da68 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclDecls.h,v 1.52 2001/07/12 13:15:09 dkf Exp $ + * RCS: @(#) $Id: tclDecls.h,v 1.53 2001/07/31 19:12:06 vincentdarley Exp $ */ #ifndef _TCLDECLS @@ -1371,6 +1371,121 @@ EXTERN Tcl_Obj * Tcl_ListMathFuncs _ANSI_ARGS_((Tcl_Interp * interp, /* 437 */ EXTERN Tcl_Obj * Tcl_SubstObj _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, int flags)); +/* 438 */ +EXTERN int Tcl_DetachChannel _ANSI_ARGS_((Tcl_Interp* interp, + Tcl_Channel channel)); +/* 439 */ +EXTERN int Tcl_IsStandardChannel _ANSI_ARGS_(( + Tcl_Channel channel)); +/* 440 */ +EXTERN int Tcl_FSCopyFile _ANSI_ARGS_((Tcl_Obj * srcPathPtr, + Tcl_Obj * destPathPtr)); +/* 441 */ +EXTERN int Tcl_FSCopyDirectory _ANSI_ARGS_(( + Tcl_Obj * srcPathPtr, Tcl_Obj * destPathPtr, + Tcl_Obj ** errorPtr)); +/* 442 */ +EXTERN int Tcl_FSCreateDirectory _ANSI_ARGS_((Tcl_Obj * pathPtr)); +/* 443 */ +EXTERN int Tcl_FSDeleteFile _ANSI_ARGS_((Tcl_Obj * pathPtr)); +/* 444 */ +EXTERN int Tcl_FSLoadFile _ANSI_ARGS_((Tcl_Interp * interp, + Tcl_Obj * pathPtr, char * sym1, char * sym2, + Tcl_PackageInitProc ** proc1Ptr, + Tcl_PackageInitProc ** proc2Ptr, + ClientData * clientDataPtr, + Tcl_FSUnloadFileProc ** unloadProcPtr)); +/* 445 */ +EXTERN int Tcl_FSMatchInDirectory _ANSI_ARGS_(( + Tcl_Interp * interp, Tcl_Obj * result, + Tcl_Obj * pathPtr, char * pattern, + Tcl_GlobTypeData * types)); +/* 446 */ +EXTERN Tcl_Obj* Tcl_FSReadlink _ANSI_ARGS_((Tcl_Obj * pathPtr)); +/* 447 */ +EXTERN int Tcl_FSRemoveDirectory _ANSI_ARGS_((Tcl_Obj * pathPtr, + int recursive, Tcl_Obj ** errorPtr)); +/* 448 */ +EXTERN int Tcl_FSRenameFile _ANSI_ARGS_((Tcl_Obj * srcPathPtr, + Tcl_Obj * destPathPtr)); +/* 449 */ +EXTERN int Tcl_FSLstat _ANSI_ARGS_((Tcl_Obj * pathPtr, + struct stat * buf)); +/* 450 */ +EXTERN int Tcl_FSUtime _ANSI_ARGS_((Tcl_Obj * pathPtr, + struct utimbuf * tval)); +/* 451 */ +EXTERN int Tcl_FSFileAttrsGet _ANSI_ARGS_((Tcl_Interp * interp, + int index, Tcl_Obj * pathPtr, + Tcl_Obj ** objPtrRef)); +/* 452 */ +EXTERN int Tcl_FSFileAttrsSet _ANSI_ARGS_((Tcl_Interp * interp, + int index, Tcl_Obj * pathPtr, + Tcl_Obj * objPtr)); +/* 453 */ +EXTERN char** Tcl_FSFileAttrStrings _ANSI_ARGS_((Tcl_Obj * pathPtr, + Tcl_Obj ** objPtrRef)); +/* 454 */ +EXTERN int Tcl_FSStat _ANSI_ARGS_((Tcl_Obj * pathPtr, + struct stat * buf)); +/* 455 */ +EXTERN int Tcl_FSAccess _ANSI_ARGS_((Tcl_Obj * pathPtr, + int mode)); +/* 456 */ +EXTERN Tcl_Channel Tcl_FSOpenFileChannel _ANSI_ARGS_(( + Tcl_Interp * interp, Tcl_Obj * pathPtr, + char * modeString, int permissions)); +/* 457 */ +EXTERN Tcl_Obj* Tcl_FSGetCwd _ANSI_ARGS_((Tcl_Interp * interp)); +/* 458 */ +EXTERN int Tcl_FSChdir _ANSI_ARGS_((Tcl_Obj * pathPtr)); +/* 459 */ +EXTERN int Tcl_FSConvertToPathType _ANSI_ARGS_(( + Tcl_Interp * interp, Tcl_Obj * pathPtr)); +/* 460 */ +EXTERN Tcl_Obj* Tcl_FSJoinPath _ANSI_ARGS_((Tcl_Obj * listObj, + int elements)); +/* 461 */ +EXTERN Tcl_Obj* Tcl_FSSplitPath _ANSI_ARGS_((Tcl_Obj* pathPtr, + int * lenPtr)); +/* 462 */ +EXTERN int Tcl_FSEqualPaths _ANSI_ARGS_((Tcl_Obj* firstPtr, + Tcl_Obj* secondPtr)); +/* 463 */ +EXTERN Tcl_Obj* Tcl_FSGetNormalizedPath _ANSI_ARGS_(( + Tcl_Interp * interp, Tcl_Obj* pathObjPtr)); +/* 464 */ +EXTERN Tcl_Obj* Tcl_FSJoinToPath _ANSI_ARGS_((Tcl_Obj * basePtr, + int objc, Tcl_Obj *CONST objv[])); +/* 465 */ +EXTERN ClientData Tcl_FSGetInternalRep _ANSI_ARGS_(( + Tcl_Obj* pathObjPtr, Tcl_Filesystem * fsPtr)); +/* 466 */ +EXTERN char* Tcl_FSGetTranslatedPath _ANSI_ARGS_(( + Tcl_Interp * interp, Tcl_Obj* pathPtr)); +/* 467 */ +EXTERN int Tcl_FSEvalFile _ANSI_ARGS_((Tcl_Interp * interp, + Tcl_Obj * fileName)); +/* 468 */ +EXTERN Tcl_Obj* Tcl_FSNewNativePath _ANSI_ARGS_(( + Tcl_Obj* fromFilesystem, + ClientData clientData)); +/* 469 */ +EXTERN char* Tcl_FSGetNativePath _ANSI_ARGS_((Tcl_Obj* pathObjPtr)); +/* 470 */ +EXTERN Tcl_Obj* Tcl_FSFileSystemInfo _ANSI_ARGS_(( + Tcl_Obj* pathObjPtr)); +/* 471 */ +EXTERN Tcl_Obj* Tcl_FSPathSeparator _ANSI_ARGS_((Tcl_Obj* pathObjPtr)); +/* 472 */ +EXTERN int Tcl_FSListVolumes _ANSI_ARGS_((Tcl_Interp * interp)); +/* 473 */ +EXTERN int Tcl_FSRegister _ANSI_ARGS_((ClientData clientData, + Tcl_Filesystem * fsPtr)); +/* 474 */ +EXTERN int Tcl_FSUnregister _ANSI_ARGS_((Tcl_Filesystem * fsPtr)); +/* 475 */ +EXTERN ClientData Tcl_FSData _ANSI_ARGS_((Tcl_Filesystem * fsPtr)); typedef struct TclStubHooks { struct TclPlatStubs *tclPlatStubs; @@ -1868,6 +1983,44 @@ typedef struct TclStubs { int (*tcl_GetMathFuncInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, int * numArgsPtr, Tcl_ValueType ** argTypesPtr, Tcl_MathProc ** procPtr, ClientData * clientDataPtr)); /* 435 */ Tcl_Obj * (*tcl_ListMathFuncs) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * pattern)); /* 436 */ Tcl_Obj * (*tcl_SubstObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, int flags)); /* 437 */ + int (*tcl_DetachChannel) _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Channel channel)); /* 438 */ + int (*tcl_IsStandardChannel) _ANSI_ARGS_((Tcl_Channel channel)); /* 439 */ + int (*tcl_FSCopyFile) _ANSI_ARGS_((Tcl_Obj * srcPathPtr, Tcl_Obj * destPathPtr)); /* 440 */ + int (*tcl_FSCopyDirectory) _ANSI_ARGS_((Tcl_Obj * srcPathPtr, Tcl_Obj * destPathPtr, Tcl_Obj ** errorPtr)); /* 441 */ + int (*tcl_FSCreateDirectory) _ANSI_ARGS_((Tcl_Obj * pathPtr)); /* 442 */ + int (*tcl_FSDeleteFile) _ANSI_ARGS_((Tcl_Obj * pathPtr)); /* 443 */ + int (*tcl_FSLoadFile) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * pathPtr, char * sym1, char * sym2, Tcl_PackageInitProc ** proc1Ptr, Tcl_PackageInitProc ** proc2Ptr, ClientData * clientDataPtr, Tcl_FSUnloadFileProc ** unloadProcPtr)); /* 444 */ + int (*tcl_FSMatchInDirectory) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * result, Tcl_Obj * pathPtr, char * pattern, Tcl_GlobTypeData * types)); /* 445 */ + Tcl_Obj* (*tcl_FSReadlink) _ANSI_ARGS_((Tcl_Obj * pathPtr)); /* 446 */ + int (*tcl_FSRemoveDirectory) _ANSI_ARGS_((Tcl_Obj * pathPtr, int recursive, Tcl_Obj ** errorPtr)); /* 447 */ + int (*tcl_FSRenameFile) _ANSI_ARGS_((Tcl_Obj * srcPathPtr, Tcl_Obj * destPathPtr)); /* 448 */ + int (*tcl_FSLstat) _ANSI_ARGS_((Tcl_Obj * pathPtr, struct stat * buf)); /* 449 */ + int (*tcl_FSUtime) _ANSI_ARGS_((Tcl_Obj * pathPtr, struct utimbuf * tval)); /* 450 */ + int (*tcl_FSFileAttrsGet) _ANSI_ARGS_((Tcl_Interp * interp, int index, Tcl_Obj * pathPtr, Tcl_Obj ** objPtrRef)); /* 451 */ + int (*tcl_FSFileAttrsSet) _ANSI_ARGS_((Tcl_Interp * interp, int index, Tcl_Obj * pathPtr, Tcl_Obj * objPtr)); /* 452 */ + char** (*tcl_FSFileAttrStrings) _ANSI_ARGS_((Tcl_Obj * pathPtr, Tcl_Obj ** objPtrRef)); /* 453 */ + int (*tcl_FSStat) _ANSI_ARGS_((Tcl_Obj * pathPtr, struct stat * buf)); /* 454 */ + int (*tcl_FSAccess) _ANSI_ARGS_((Tcl_Obj * pathPtr, int mode)); /* 455 */ + Tcl_Channel (*tcl_FSOpenFileChannel) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * pathPtr, char * modeString, int permissions)); /* 456 */ + Tcl_Obj* (*tcl_FSGetCwd) _ANSI_ARGS_((Tcl_Interp * interp)); /* 457 */ + int (*tcl_FSChdir) _ANSI_ARGS_((Tcl_Obj * pathPtr)); /* 458 */ + int (*tcl_FSConvertToPathType) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * pathPtr)); /* 459 */ + Tcl_Obj* (*tcl_FSJoinPath) _ANSI_ARGS_((Tcl_Obj * listObj, int elements)); /* 460 */ + Tcl_Obj* (*tcl_FSSplitPath) _ANSI_ARGS_((Tcl_Obj* pathPtr, int * lenPtr)); /* 461 */ + int (*tcl_FSEqualPaths) _ANSI_ARGS_((Tcl_Obj* firstPtr, Tcl_Obj* secondPtr)); /* 462 */ + Tcl_Obj* (*tcl_FSGetNormalizedPath) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj* pathObjPtr)); /* 463 */ + Tcl_Obj* (*tcl_FSJoinToPath) _ANSI_ARGS_((Tcl_Obj * basePtr, int objc, Tcl_Obj *CONST objv[])); /* 464 */ + ClientData (*tcl_FSGetInternalRep) _ANSI_ARGS_((Tcl_Obj* pathObjPtr, Tcl_Filesystem * fsPtr)); /* 465 */ + char* (*tcl_FSGetTranslatedPath) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj* pathPtr)); /* 466 */ + int (*tcl_FSEvalFile) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * fileName)); /* 467 */ + Tcl_Obj* (*tcl_FSNewNativePath) _ANSI_ARGS_((Tcl_Obj* fromFilesystem, ClientData clientData)); /* 468 */ + char* (*tcl_FSGetNativePath) _ANSI_ARGS_((Tcl_Obj* pathObjPtr)); /* 469 */ + Tcl_Obj* (*tcl_FSFileSystemInfo) _ANSI_ARGS_((Tcl_Obj* pathObjPtr)); /* 470 */ + Tcl_Obj* (*tcl_FSPathSeparator) _ANSI_ARGS_((Tcl_Obj* pathObjPtr)); /* 471 */ + int (*tcl_FSListVolumes) _ANSI_ARGS_((Tcl_Interp * interp)); /* 472 */ + int (*tcl_FSRegister) _ANSI_ARGS_((ClientData clientData, Tcl_Filesystem * fsPtr)); /* 473 */ + int (*tcl_FSUnregister) _ANSI_ARGS_((Tcl_Filesystem * fsPtr)); /* 474 */ + ClientData (*tcl_FSData) _ANSI_ARGS_((Tcl_Filesystem * fsPtr)); /* 475 */ } TclStubs; #ifdef __cplusplus @@ -3660,6 +3813,158 @@ extern TclStubs *tclStubsPtr; #define Tcl_SubstObj \ (tclStubsPtr->tcl_SubstObj) /* 437 */ #endif +#ifndef Tcl_DetachChannel +#define Tcl_DetachChannel \ + (tclStubsPtr->tcl_DetachChannel) /* 438 */ +#endif +#ifndef Tcl_IsStandardChannel +#define Tcl_IsStandardChannel \ + (tclStubsPtr->tcl_IsStandardChannel) /* 439 */ +#endif +#ifndef Tcl_FSCopyFile +#define Tcl_FSCopyFile \ + (tclStubsPtr->tcl_FSCopyFile) /* 440 */ +#endif +#ifndef Tcl_FSCopyDirectory +#define Tcl_FSCopyDirectory \ + (tclStubsPtr->tcl_FSCopyDirectory) /* 441 */ +#endif +#ifndef Tcl_FSCreateDirectory +#define Tcl_FSCreateDirectory \ + (tclStubsPtr->tcl_FSCreateDirectory) /* 442 */ +#endif +#ifndef Tcl_FSDeleteFile +#define Tcl_FSDeleteFile \ + (tclStubsPtr->tcl_FSDeleteFile) /* 443 */ +#endif +#ifndef Tcl_FSLoadFile +#define Tcl_FSLoadFile \ + (tclStubsPtr->tcl_FSLoadFile) /* 444 */ +#endif +#ifndef Tcl_FSMatchInDirectory +#define Tcl_FSMatchInDirectory \ + (tclStubsPtr->tcl_FSMatchInDirectory) /* 445 */ +#endif +#ifndef Tcl_FSReadlink +#define Tcl_FSReadlink \ + (tclStubsPtr->tcl_FSReadlink) /* 446 */ +#endif +#ifndef Tcl_FSRemoveDirectory +#define Tcl_FSRemoveDirectory \ + (tclStubsPtr->tcl_FSRemoveDirectory) /* 447 */ +#endif +#ifndef Tcl_FSRenameFile +#define Tcl_FSRenameFile \ + (tclStubsPtr->tcl_FSRenameFile) /* 448 */ +#endif +#ifndef Tcl_FSLstat +#define Tcl_FSLstat \ + (tclStubsPtr->tcl_FSLstat) /* 449 */ +#endif +#ifndef Tcl_FSUtime +#define Tcl_FSUtime \ + (tclStubsPtr->tcl_FSUtime) /* 450 */ +#endif +#ifndef Tcl_FSFileAttrsGet +#define Tcl_FSFileAttrsGet \ + (tclStubsPtr->tcl_FSFileAttrsGet) /* 451 */ +#endif +#ifndef Tcl_FSFileAttrsSet +#define Tcl_FSFileAttrsSet \ + (tclStubsPtr->tcl_FSFileAttrsSet) /* 452 */ +#endif +#ifndef Tcl_FSFileAttrStrings +#define Tcl_FSFileAttrStrings \ + (tclStubsPtr->tcl_FSFileAttrStrings) /* 453 */ +#endif +#ifndef Tcl_FSStat +#define Tcl_FSStat \ + (tclStubsPtr->tcl_FSStat) /* 454 */ +#endif +#ifndef Tcl_FSAccess +#define Tcl_FSAccess \ + (tclStubsPtr->tcl_FSAccess) /* 455 */ +#endif +#ifndef Tcl_FSOpenFileChannel +#define Tcl_FSOpenFileChannel \ + (tclStubsPtr->tcl_FSOpenFileChannel) /* 456 */ +#endif +#ifndef Tcl_FSGetCwd +#define Tcl_FSGetCwd \ + (tclStubsPtr->tcl_FSGetCwd) /* 457 */ +#endif +#ifndef Tcl_FSChdir +#define Tcl_FSChdir \ + (tclStubsPtr->tcl_FSChdir) /* 458 */ +#endif +#ifndef Tcl_FSConvertToPathType +#define Tcl_FSConvertToPathType \ + (tclStubsPtr->tcl_FSConvertToPathType) /* 459 */ +#endif +#ifndef Tcl_FSJoinPath +#define Tcl_FSJoinPath \ + (tclStubsPtr->tcl_FSJoinPath) /* 460 */ +#endif +#ifndef Tcl_FSSplitPath +#define Tcl_FSSplitPath \ + (tclStubsPtr->tcl_FSSplitPath) /* 461 */ +#endif +#ifndef Tcl_FSEqualPaths +#define Tcl_FSEqualPaths \ + (tclStubsPtr->tcl_FSEqualPaths) /* 462 */ +#endif +#ifndef Tcl_FSGetNormalizedPath +#define Tcl_FSGetNormalizedPath \ + (tclStubsPtr->tcl_FSGetNormalizedPath) /* 463 */ +#endif +#ifndef Tcl_FSJoinToPath +#define Tcl_FSJoinToPath \ + (tclStubsPtr->tcl_FSJoinToPath) /* 464 */ +#endif +#ifndef Tcl_FSGetInternalRep +#define Tcl_FSGetInternalRep \ + (tclStubsPtr->tcl_FSGetInternalRep) /* 465 */ +#endif +#ifndef Tcl_FSGetTranslatedPath +#define Tcl_FSGetTranslatedPath \ + (tclStubsPtr->tcl_FSGetTranslatedPath) /* 466 */ +#endif +#ifndef Tcl_FSEvalFile +#define Tcl_FSEvalFile \ + (tclStubsPtr->tcl_FSEvalFile) /* 467 */ +#endif +#ifndef Tcl_FSNewNativePath +#define Tcl_FSNewNativePath \ + (tclStubsPtr->tcl_FSNewNativePath) /* 468 */ +#endif +#ifndef Tcl_FSGetNativePath +#define Tcl_FSGetNativePath \ + (tclStubsPtr->tcl_FSGetNativePath) /* 469 */ +#endif +#ifndef Tcl_FSFileSystemInfo +#define Tcl_FSFileSystemInfo \ + (tclStubsPtr->tcl_FSFileSystemInfo) /* 470 */ +#endif +#ifndef Tcl_FSPathSeparator +#define Tcl_FSPathSeparator \ + (tclStubsPtr->tcl_FSPathSeparator) /* 471 */ +#endif +#ifndef Tcl_FSListVolumes +#define Tcl_FSListVolumes \ + (tclStubsPtr->tcl_FSListVolumes) /* 472 */ +#endif +#ifndef Tcl_FSRegister +#define Tcl_FSRegister \ + (tclStubsPtr->tcl_FSRegister) /* 473 */ +#endif +#ifndef Tcl_FSUnregister +#define Tcl_FSUnregister \ + (tclStubsPtr->tcl_FSUnregister) /* 474 */ +#endif +#ifndef Tcl_FSData +#define Tcl_FSData \ + (tclStubsPtr->tcl_FSData) /* 475 */ +#endif #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */ diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index beb36e5..f7bc742 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclEncoding.c,v 1.6 2000/12/08 18:55:58 andreas_kupries Exp $ + * RCS: @(#) $Id: tclEncoding.c,v 1.7 2001/07/31 19:12:06 vincentdarley Exp $ */ #include "tclInt.h" @@ -563,20 +563,22 @@ Tcl_GetEncodingNames(interp) if (pathPtr != NULL) { int i, objc; Tcl_Obj **objv; - Tcl_DString pwdString; char globArgString[10]; - + Tcl_Obj* encodingObj = Tcl_NewStringObj("encoding",-1); + Tcl_IncrRefCount(encodingObj); + 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_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,15 +588,22 @@ Tcl_GetEncodingNames(interp) */ strcpy(globArgString, "*.enc"); - if ((Tcl_Chdir(string) == 0) - && (Tcl_Chdir("encoding") == 0) - && (TclGlob(interp, globArgString, NULL, 0, NULL) == TCL_OK)) { - objc2 = 0; + /* + * 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, + TCL_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,9 +613,9 @@ Tcl_GetEncodingNames(interp) } } } - Tcl_Chdir(Tcl_DStringValue(&pwdString)); + Tcl_DecrRefCount(searchIn); } - Tcl_DStringFree(&pwdString); + Tcl_DecrRefCount(encodingObj); } /* @@ -1275,6 +1284,7 @@ OpenEncodingFile(dir, name) Tcl_DString pathString; char *path; Tcl_Channel chan; + Tcl_Obj *pathPtr; argv[0] = (char *) dir; argv[1] = "encoding"; @@ -1283,7 +1293,12 @@ OpenEncodingFile(dir, name) Tcl_DStringInit(&pathString); Tcl_JoinPath(3, argv, &pathString); path = Tcl_DStringAppend(&pathString, ".enc", -1); - chan = Tcl_OpenFileChannel(NULL, path, "r", 0); + pathPtr = Tcl_NewStringObj(path,-1); + + Tcl_IncrRefCount(pathPtr); + chan = Tcl_FSOpenFileChannel(NULL, pathPtr, "r", 0); + Tcl_DecrRefCount(pathPtr); + Tcl_DStringFree(&pathString); return chan; diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c index d975cc6..c169427 100644 --- a/generic/tclFCmd.c +++ b/generic/tclFCmd.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclFCmd.c,v 1.6 1999/07/01 23:21:07 redman Exp $ + * RCS: @(#) $Id: tclFCmd.c,v 1.7 2001/07/31 19:12:06 vincentdarley Exp $ */ #include "tclInt.h" @@ -20,14 +20,14 @@ */ 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)); + 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 argc, char **argv, int copyFlag)); + int objc, Tcl_Obj *CONST objv[], int copyFlag)); static int FileForceOption _ANSI_ARGS_((Tcl_Interp *interp, - int argc, char **argv, int *forcePtr)); + int objc, Tcl_Obj *CONST objv[], int *forcePtr)); /* *--------------------------------------------------------------------------- @@ -49,12 +49,12 @@ static int FileForceOption _ANSI_ARGS_((Tcl_Interp *interp, */ int -TclFileRenameCmd(interp, argc, argv) +TclFileRenameCmd(interp, objc, objv) Tcl_Interp *interp; /* Interp for error reporting. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings passed to Tcl_FileCmd. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument strings passed to Tcl_FileCmd. */ { - return FileCopyRename(interp, argc, argv, 0); + return FileCopyRename(interp, objc, objv, 0); } /* @@ -77,12 +77,12 @@ TclFileRenameCmd(interp, argc, argv) */ int -TclFileCopyCmd(interp, argc, argv) +TclFileCopyCmd(interp, objc, objv) Tcl_Interp *interp; /* Used for error reporting */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings passed to Tcl_FileCmd. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument strings passed to Tcl_FileCmd. */ { - return FileCopyRename(interp, argc, argv, 1); + return FileCopyRename(interp, objc, objv, 1); } /* @@ -103,26 +103,26 @@ TclFileCopyCmd(interp, argc, argv) */ static int -FileCopyRename(interp, argc, argv, copyFlag) +FileCopyRename(interp, objc, objv, copyFlag) Tcl_Interp *interp; /* Used for error reporting. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings passed to Tcl_FileCmd. */ + 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_DString targetBuffer; - char *target; + Tcl_Obj *target; - i = FileForceOption(interp, argc - 2, argv + 2, &force); + i = FileForceOption(interp, objc - 2, objv + 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\"", + 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,38 +133,38 @@ FileCopyRename(interp, argc, argv, copyFlag) * directory. */ - target = Tcl_TranslateFileName(interp, argv[argc - 1], &targetBuffer); - if (target == NULL) { + target = objv[objc - 1]; + if (Tcl_FSConvertToPathType(interp, target) != TCL_OK) { return TCL_ERROR; } result = TCL_OK; /* - * Call TclStat() so that if target is a symlink that points to a + * 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 ((TclStat(target, &statBuf) != 0) || !S_ISDIR(statBuf.st_mode)) { - if ((argc - i) > 2) { + 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 \"", - argv[argc - 1], "\" is not a directory", (char *) NULL); + Tcl_GetString(target), "\" is not a directory", + (char *) NULL); result = TCL_ERROR; } else { /* - * Even though already have target == translated(argv[i+1]), + * 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, argv[i], argv[i + 1], copyFlag, + result = CopyRenameOneFile(interp, objv[i], objv[i + 1], copyFlag, force); } - Tcl_DStringFree(&targetBuffer); return result; } @@ -173,30 +173,30 @@ FileCopyRename(interp, argc, argv, copyFlag) * 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); + 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] = argv[argc - 1]; + jargv[0] = objv[objc - 1]; jargv[1] = source; - Tcl_DStringInit(&newFileNameBuffer); - newFileName = Tcl_JoinPath(2, jargv, &newFileNameBuffer); - result = CopyRenameOneFile(interp, argv[i], newFileName, copyFlag, + 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_DStringFree(&sourceBuffer); - Tcl_DStringFree(&newFileNameBuffer); - + Tcl_DecrRefCount(newFileName); if (result == TCL_ERROR) { break; } } - Tcl_DStringFree(&targetBuffer); return result; } @@ -219,74 +219,72 @@ FileCopyRename(interp, argc, argv, copyFlag) *---------------------------------------------------------------------- */ int -TclFileMakeDirsCmd(interp, argc, argv) +TclFileMakeDirsCmd(interp, objc, objv) Tcl_Interp *interp; /* Used for error reporting. */ - int argc; /* Number of arguments */ - char **argv; /* Argument strings passed to Tcl_FileCmd. */ + int objc; /* Number of arguments */ + Tcl_Obj *CONST objv[]; /* Argument strings passed to Tcl_FileCmd. */ { - Tcl_DString nameBuffer, targetBuffer; - char *errfile; - int result, i, j, pargc; - char **pargv; + Tcl_Obj *errfile; + int result, i, j, pobjc; + Tcl_Obj *split = NULL; + Tcl_Obj *target = NULL; 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) { + for (i = 2; i < objc; i++) { + if (Tcl_FSConvertToPathType(interp, objv[i]) != TCL_OK) { result = TCL_ERROR; break; } - Tcl_SplitPath(name, &pargc, &pargv); - if (pargc == 0) { + split = Tcl_FSSplitPath(objv[i],&pobjc); + if (pobjc == 0) { errno = ENOENT; - errfile = argv[i]; + errfile = objv[i]; break; } - for (j = 0; j < pargc; j++) { - char *target = Tcl_JoinPath(j + 1, pargv, &targetBuffer); - + for (j = 0; j < pobjc; j++) { + target = Tcl_FSJoinPath(split, j + 1); + Tcl_IncrRefCount(target); /* - * Call TclStat() so that if target is a symlink that points + * Call Tcl_Stat() 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 (Tcl_FSStat(target, &statBuf) == 0) { if (!S_ISDIR(statBuf.st_mode)) { errno = EEXIST; errfile = target; goto done; } } else if ((errno != ENOENT) - || (TclpCreateDirectory(target) != TCL_OK)) { + || (Tcl_FSCreateDirectory(target) != TCL_OK)) { errfile = target; goto done; } - Tcl_DStringFree(&targetBuffer); + /* Forget about this sub-path */ + Tcl_DecrRefCount(target); + target = NULL; } - ckfree((char *) pargv); - pargv = NULL; - Tcl_DStringFree(&nameBuffer); + Tcl_DecrRefCount(split); + split = NULL; } done: if (errfile != NULL) { Tcl_AppendResult(interp, "can't create directory \"", - errfile, "\": ", Tcl_PosixError(interp), (char *) NULL); + Tcl_GetString(errfile), "\": ", Tcl_PosixError(interp), + (char *) NULL); result = TCL_ERROR; } - - Tcl_DStringFree(&nameBuffer); - Tcl_DStringFree(&targetBuffer); - if (pargv != NULL) { - ckfree((char *) pargv); + if (split != NULL) { + Tcl_DecrRefCount(split); + } + if (target != NULL) { + Tcl_DecrRefCount(target); } return result; } @@ -309,39 +307,34 @@ TclFileMakeDirsCmd(interp, argc, argv) */ int -TclFileDeleteCmd(interp, argc, argv) +TclFileDeleteCmd(interp, objc, objv) Tcl_Interp *interp; /* Used for error reporting */ - int argc; /* Number of arguments */ - char **argv; /* Argument strings passed to Tcl_FileCmd. */ + int objc; /* Number of arguments */ + Tcl_Obj *CONST objv[]; /* Argument strings passed to Tcl_FileCmd. */ { - Tcl_DString nameBuffer, errorBuffer; int i, force, result; - char *errfile; + Tcl_Obj *errfile; - i = FileForceOption(interp, argc - 2, argv + 2, &force); + i = FileForceOption(interp, objc - 2, objv + 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); + 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; - Tcl_DStringInit(&errorBuffer); - Tcl_DStringInit(&nameBuffer); - for ( ; i < argc; i++) { + for ( ; i < objc; i++) { struct stat statBuf; - char *name; - errfile = argv[i]; - Tcl_DStringSetLength(&nameBuffer, 0); - name = Tcl_TranslateFileName(interp, argv[i], &nameBuffer); - if (name == NULL) { + errfile = objv[i]; + if (Tcl_FSConvertToPathType(interp, objv[i]) != TCL_OK) { result = TCL_ERROR; goto done; } @@ -350,7 +343,7 @@ TclFileDeleteCmd(interp, argc, argv) * Call lstat() to get info so can delete symbolic link itself. */ - if (TclpLstat(name, &statBuf) != 0) { + 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,10 +353,12 @@ TclFileDeleteCmd(interp, argc, argv) result = TCL_ERROR; } } else if (S_ISDIR(statBuf.st_mode)) { - result = TclpRemoveDirectory(name, force, &errorBuffer); + 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 \"", argv[i], + Tcl_AppendResult(interp, "error deleting \"", + Tcl_GetString(objv[i]), "\": directory not empty", (char *) NULL); Tcl_PosixError(interp); goto done; @@ -373,13 +368,14 @@ TclFileDeleteCmd(interp, argc, argv) * If possible, use the untranslated name for the file. */ - errfile = Tcl_DStringValue(&errorBuffer); - if (strcmp(name, errfile) == 0) { - errfile = argv[i]; + errfile = errorBuffer; + /* FS supposed to check between translated objv and errfile */ + if (Tcl_FSEqualPaths(objv[i], errfile)) { + errfile = objv[i]; } } } else { - result = TclpDeleteFile(name); + result = Tcl_FSDeleteFile(objv[i]); } if (result == TCL_ERROR) { @@ -387,12 +383,20 @@ TclFileDeleteCmd(interp, argc, argv) } } if (result != TCL_OK) { - Tcl_AppendResult(interp, "error deleting \"", errfile, - "\": ", Tcl_PosixError(interp), (char *) NULL); + 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: - Tcl_DStringFree(&errorBuffer); - Tcl_DStringFree(&nameBuffer); return result; } @@ -418,9 +422,9 @@ TclFileDeleteCmd(interp, argc, argv) 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 + Tcl_Obj *source; /* Pathname of file to copy. May need to * be translated. */ - char *target; /* Pathname of file to create/overwrite. + 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,23 +433,19 @@ CopyRenameOneFile(interp, source, target, copyFlag, force) * exists. */ { int result; - Tcl_DString sourcePath, targetPath, errorBuffer; - char *targetName, *sourceName, *errfile; + Tcl_Obj *errfile, *errorBuffer; struct stat sourceStatBuf, targetStatBuf; - sourceName = Tcl_TranslateFileName(interp, source, &sourcePath); - if (sourceName == NULL) { + if (Tcl_FSConvertToPathType(interp, source) != TCL_OK) { return TCL_ERROR; } - targetName = Tcl_TranslateFileName(interp, target, &targetPath); - if (targetName == NULL) { - Tcl_DStringFree(&sourcePath); + if (Tcl_FSConvertToPathType(interp, target) != TCL_OK) { return TCL_ERROR; } errfile = NULL; + errorBuffer = NULL; result = TCL_ERROR; - Tcl_DStringInit(&errorBuffer); /* * We want to copy/rename links and not the files they point to, so we @@ -454,11 +454,11 @@ CopyRenameOneFile(interp, source, target, copyFlag, force) * target. */ - if (TclpLstat(sourceName, &sourceStatBuf) != 0) { + if (Tcl_FSLstat(source, &sourceStatBuf) != 0) { errfile = source; goto done; } - if (TclpLstat(targetName, &targetStatBuf) != 0) { + if (Tcl_FSLstat(target, &targetStatBuf) != 0) { if (errno != ENOENT) { errfile = target; goto done; @@ -495,28 +495,31 @@ CopyRenameOneFile(interp, source, target, copyFlag, force) 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); + 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 \"", target, - "\" with file \"", source, "\"", (char *) NULL); + Tcl_AppendResult(interp, "can't overwrite directory \"", + Tcl_GetString(target), "\" with file \"", + Tcl_GetString(source), "\"", (char *) NULL); goto done; } } if (copyFlag == 0) { - result = TclpRenameFile(sourceName, targetName); + result = Tcl_FSRenameFile(source, target); if (result == TCL_OK) { goto done; } if (errno == EINVAL) { - Tcl_AppendResult(interp, "error renaming \"", source, "\" to \"", - target, "\": trying to rename a volume or ", + 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,44 +536,122 @@ CopyRenameOneFile(interp, source, target, copyFlag, force) } if (S_ISDIR(sourceStatBuf.st_mode)) { - result = TclpCopyDirectory(sourceName, targetName, &errorBuffer); + result = Tcl_FSCopyDirectory(source, target, &errorBuffer); if (result != TCL_OK) { - errfile = Tcl_DStringValue(&errorBuffer); - if (strcmp(errfile, sourceName) == 0) { - errfile = source; - } else if (strcmp(errfile, targetName) == 0) { - errfile = target; + 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 = TclpCopyFile(sourceName, targetName); - if (result != TCL_OK) { + 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. */ - - errfile = target; + 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 = TclpRemoveDirectory(sourceName, 1, &errorBuffer); + result = Tcl_FSRemoveDirectory(source, 1, &errorBuffer); if (result != TCL_OK) { - errfile = Tcl_DStringValue(&errorBuffer); - if (strcmp(errfile, sourceName) == 0) { + if (Tcl_FSEqualPaths(errfile, source) == 0) { errfile = source; } } } else { - result = TclpDeleteFile(sourceName); + result = Tcl_FSDeleteFile(source); if (result != TCL_OK) { errfile = source; } } if (result != TCL_OK) { - Tcl_AppendResult(interp, "can't unlink \"", errfile, "\": ", - Tcl_PosixError(interp), (char *) NULL); + Tcl_AppendResult(interp, "can't unlink \"", + Tcl_GetString(errfile), "\": ", + Tcl_PosixError(interp), (char *) NULL); errfile = NULL; } } @@ -579,19 +660,21 @@ CopyRenameOneFile(interp, source, target, copyFlag, force) if (errfile != NULL) { Tcl_AppendResult(interp, ((copyFlag) ? "error copying \"" : "error renaming \""), - source, (char *) NULL); + Tcl_GetString(source), (char *) NULL); if (errfile != source) { - Tcl_AppendResult(interp, "\" to \"", target, (char *) NULL); + Tcl_AppendResult(interp, "\" to \"", Tcl_GetString(target), + (char *) NULL); if (errfile != target) { - Tcl_AppendResult(interp, "\": \"", errfile, (char *) NULL); + Tcl_AppendResult(interp, "\": \"", Tcl_GetString(errfile), + (char *) NULL); } } Tcl_AppendResult(interp, "\": ", Tcl_PosixError(interp), (char *) NULL); } - Tcl_DStringFree(&errorBuffer); - Tcl_DStringFree(&sourcePath); - Tcl_DStringFree(&targetPath); + if (errorBuffer != NULL) { + Tcl_DecrRefCount(errorBuffer); + } return result; } @@ -616,10 +699,10 @@ CopyRenameOneFile(interp, source, target, copyFlag, force) */ static int -FileForceOption(interp, argc, argv, forcePtr) +FileForceOption(interp, objc, objv, forcePtr) Tcl_Interp *interp; /* Interp, for error return. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. First command line + 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,17 +710,17 @@ FileForceOption(interp, argc, argv, forcePtr) int force, i; force = 0; - for (i = 0; i < argc; i++) { - if (argv[i][0] != '-') { + for (i = 0; i < objc; i++) { + if (Tcl_GetString(objv[i])[0] != '-') { break; } - if (strcmp(argv[i], "-force") == 0) { + if (strcmp(Tcl_GetString(objv[i]), "-force") == 0) { force = 1; - } else if (strcmp(argv[i], "--") == 0) { + } else if (strcmp(Tcl_GetString(objv[i]), "--") == 0) { i++; break; } else { - Tcl_AppendResult(interp, "bad option \"", argv[i], + Tcl_AppendResult(interp, "bad option \"", Tcl_GetString(objv[i]), "\": should be -force or --", (char *)NULL); return -1; } @@ -667,47 +750,51 @@ FileForceOption(interp, argc, argv, forcePtr) *--------------------------------------------------------------------------- */ -static char * -FileBasename(interp, path, bufferPtr) +static Tcl_Obj * +FileBasename(interp, pathPtr) Tcl_Interp *interp; /* Interp, for error return. */ - char *path; /* Path whose basename to extract. */ - Tcl_DString *bufferPtr; /* Initialized DString that receives - * basename. */ + Tcl_Obj *pathPtr; /* Path whose basename to extract. */ { - int argc; - char **argv; + int objc; + Tcl_Obj *split; + Tcl_Obj *resPtr = NULL; - Tcl_SplitPath(path, &argc, &argv); - if (argc == 0) { - Tcl_DStringInit(bufferPtr); - } else { - if ((argc == 1) && (*path == '~')) { - Tcl_DString buffer; + split = Tcl_FSSplitPath(pathPtr, &objc); + + if (objc != 0) { + if ((objc == 1) && (*Tcl_GetString(pathPtr) == '~')) { - ckfree((char *) argv); - path = Tcl_TranslateFileName(interp, path, &buffer); - if (path == NULL) { + if (Tcl_FSConvertToPathType(interp, pathPtr) != TCL_OK) { + Tcl_DecrRefCount(split); return NULL; } - Tcl_SplitPath(path, &argc, &argv); - Tcl_DStringFree(&buffer); + Tcl_DecrRefCount(split); + split = Tcl_FSSplitPath(pathPtr, &objc); } - 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); + 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); + } } } } - ckfree((char *) argv); - return Tcl_DStringValue(bufferPtr); + if (resPtr == NULL) { + resPtr = Tcl_NewStringObj("",0); + } + Tcl_IncrRefCount(resPtr); + Tcl_DecrRefCount(split); + return resPtr; } /* @@ -715,15 +802,15 @@ FileBasename(interp, path, bufferPtr) * * TclFileAttrsCmd -- * - * Sets or gets the platform-specific attributes of a file. The objc-objv - * points to the file name with the rest of the command line following. - * This routine uses platform-specific tables of option strings - * and callbacks. The callback to get the attributes take three - * parameters: + * Sets or gets the platform-specific attributes of a file. The + * objc-objv points to the file name with the rest of the command + * line following. This routine uses platform-specific tables of + * option strings and callbacks. The callback to get the + * attributes take three parameters: * Tcl_Interp *interp; The interp to report errors with. * Since this is an object-based API, - * the object form of the result should be - * used. + * the object form of the result should + * be used. * CONST char *fileName; This is extracted using * Tcl_TranslateFileName. * TclObj **attrObjPtrPtr; A new object to hold the attribute @@ -751,46 +838,67 @@ TclFileAttrsCmd(interp, objc, objv) int objc; /* Number of command line arguments. */ Tcl_Obj *CONST objv[]; /* The command line objects. */ { - char *fileName; int result; - Tcl_DString buffer; - + 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; } - fileName = Tcl_GetString(objv[2]); - fileName = Tcl_TranslateFileName(interp, fileName, &buffer); - if (fileName == NULL) { + 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, *objPtr; + Tcl_Obj *listPtr; listPtr = Tcl_NewListObj(0, NULL); - for (index = 0; tclpFileAttrStrings[index] != NULL; index++) { - objPtr = Tcl_NewStringObj(tclpFileAttrStrings[index], -1); + for (index = 0; attributeStrings[index] != NULL; index++) { + Tcl_Obj *objPtr = Tcl_NewStringObj(attributeStrings[index], -1); Tcl_ListObjAppendElement(interp, listPtr, objPtr); - - if ((*tclpFileAttrProcs[index].getProc)(interp, index, fileName, - &objPtr) != TCL_OK) { + /* 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,13 +906,20 @@ TclFileAttrsCmd(interp, objc, objv) */ int index; - Tcl_Obj *objPtr; - - if (Tcl_GetIndexFromObj(interp, objv[0], tclpFileAttrStrings, + Tcl_Obj *objPtr = NULL; + + if (numObjStrings == 0) { + Tcl_AppendResult(interp, "bad option \"", + Tcl_GetString(objv[0]), "\", there are no file attributes" + " in this filesystem.", (char *) NULL); + goto end; + } + + if (Tcl_GetIndexFromObj(interp, objv[0], attributeStrings, "option", 0, &index) != TCL_OK) { goto end; - } - if ((*tclpFileAttrProcs[index].getProc)(interp, index, fileName, + } + if (Tcl_FSFileAttrsGet(interp, index, filePtr, &objPtr) != TCL_OK) { goto end; } @@ -816,8 +931,15 @@ TclFileAttrsCmd(interp, objc, objv) int i, index; + if (numObjStrings == 0) { + Tcl_AppendResult(interp, "bad option \"", + Tcl_GetString(objv[0]), "\", there are no file attributes" + " in this filesystem.", (char *) NULL); + goto end; + } + for (i = 0; i < objc ; i += 2) { - if (Tcl_GetIndexFromObj(interp, objv[i], tclpFileAttrStrings, + if (Tcl_GetIndexFromObj(interp, objv[i], attributeStrings, "option", 0, &index) != TCL_OK) { goto end; } @@ -827,7 +949,7 @@ TclFileAttrsCmd(interp, objc, objv) (char *) NULL); goto end; } - if ((*tclpFileAttrProcs[index].setProc)(interp, index, fileName, + if (Tcl_FSFileAttrsSet(interp, index, filePtr, objv[i + 1]) != TCL_OK) { goto end; } @@ -836,6 +958,16 @@ TclFileAttrsCmd(interp, objc, objv) result = TCL_OK; end: - Tcl_DStringFree(&buffer); + if (numObjStrings != -1) { + /* Free up the array we allocated */ + ckfree((char*)attributeStrings); + /* + * We don't need this object that was passed to us + * any more. + */ + if (objStrings != NULL) { + Tcl_DecrRefCount(objStrings); + } + } return result; } diff --git a/generic/tclFileName.c b/generic/tclFileName.c index 257f49d..31332ac 100644 --- a/generic/tclFileName.c +++ b/generic/tclFileName.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclFileName.c,v 1.14 2001/05/15 21:24:22 hobbs Exp $ + * RCS: @(#) $Id: tclFileName.c,v 1.15 2001/07/31 19:12:06 vincentdarley Exp $ */ #include "tclInt.h" @@ -53,22 +53,14 @@ static Tcl_ThreadDataKey dataKey; 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: */ static char * DoTildeSubst _ANSI_ARGS_((Tcl_Interp *interp, CONST char *user, Tcl_DString *resultPtr)); static CONST char * ExtractWinRoot _ANSI_ARGS_((CONST char *path, - Tcl_DString *resultPtr, int offset, Tcl_PathType *typePtr)); + Tcl_DString *resultPtr, int offset, + Tcl_PathType *typePtr)); static void FileNameCleanup _ANSI_ARGS_((ClientData clientData)); static void FileNameInit _ANSI_ARGS_((void)); static int SkipToChar _ANSI_ARGS_((char **stringPtr, @@ -314,6 +306,49 @@ Tcl_GetPathType(path) } /* + *--------------------------------------------------------------------------- + * + * 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;i<argc;i++) { + Tcl_ListObjAppendElement(NULL, res, Tcl_NewStringObj(argv[i],-1)); + } + ckfree((char*)argv); + return res; +} + +/* *---------------------------------------------------------------------- * * Tcl_SplitPath -- @@ -739,6 +774,109 @@ SplitMacPath(path, bufPtr) } /* + *--------------------------------------------------------------------------- + * + * Tcl_FSJoinToPath -- + * + * This function takes the given object, which should usually be a + * valid path or NULL, and joins onto it the array of paths + * segments given. + * + * Results: + * Returns object with refCount of zero + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +Tcl_Obj* +Tcl_FSJoinToPath(basePtr, objc, objv) + Tcl_Obj *basePtr; + int objc; + Tcl_Obj *CONST objv[]; +{ + int i; + Tcl_Obj *lobj, *ret; + + if (basePtr == NULL) { + lobj = Tcl_NewListObj(0,NULL); + } else { + lobj = Tcl_NewListObj(1,&basePtr); + } + + for (i = 0; i<objc;i++) { + Tcl_ListObjAppendElement(NULL, lobj, objv[i]); + } + ret = Tcl_FSJoinPath(lobj,-1); + Tcl_DecrRefCount(lobj); + return ret; +} + +/* + *--------------------------------------------------------------------------- + * + * Tcl_FSJoinPath -- + * + * This function takes the given Tcl_Obj, which should be a valid + * list, and returns the path object given by considering the + * first 'elements' elements as valid path segments. If elements < 0, + * we use the entire list. + * + * Note this function currently calls the older Tcl_JoinPath + * routine, which therefore requires more memory allocation and + * deallocation than necessary. We could easily rewrite this for + * greater efficiency. + * + * Results: + * Returns object with refCount of zero. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +Tcl_Obj* +Tcl_FSJoinPath(listObj, elements) + Tcl_Obj *listObj; + int elements; +{ + char ** argv; + int count; + Tcl_DString ds; + Tcl_Obj *res; + if (elements < 0) { + if (Tcl_ListObjLength(NULL, listObj, &elements) != TCL_OK) { + return NULL; + } + } else { + /* Just make sure it is a valid list */ + int listTest; + if (Tcl_ListObjLength(NULL, listObj, &listTest) != TCL_OK) { + return NULL; + } + /* + * It doesn't actually matter if 'elements' is greater + * than the actual number of elements. + */ + } + argv = (char **)ckalloc(elements*sizeof(char*)); + + for (count = 0; count < elements; count++) { + Tcl_Obj* elt; + Tcl_ListObjIndex(NULL, listObj,count,&elt); + argv[count] = Tcl_GetString(elt); + } + Tcl_DStringInit(&ds); + res = Tcl_NewStringObj(Tcl_JoinPath(elements, argv, &ds),-1); + Tcl_DStringFree(&ds); + ckfree((char*)argv); + return res; +} + +/* *---------------------------------------------------------------------- * * Tcl_JoinPath -- @@ -1008,12 +1146,9 @@ Tcl_TranslateFileName(interp, name, bufferPtr) Tcl_DString *bufferPtr; /* Uninitialized or free DString filled * with name after tilde substitution. */ { - register char *p; - /* * Handle tilde substitutions, if needed. */ - if (name[0] == '~') { int argc, length; char **argv; @@ -1039,20 +1174,20 @@ Tcl_TranslateFileName(interp, name, bufferPtr) return NULL; } Tcl_DStringInit(bufferPtr); - Tcl_JoinPath(argc, (char **) argv, bufferPtr); + Tcl_JoinPath(argc, argv, bufferPtr); Tcl_DStringFree(&temp); ckfree((char*)argv); } else { Tcl_DStringInit(bufferPtr); - Tcl_JoinPath(1, (char **) &name, bufferPtr); + Tcl_JoinPath(1, &name, bufferPtr); } /* * Convert forward slashes to backslashes in Windows paths because * some system interfaces don't accept forward slashes. */ - if (tclPlatform == TCL_PLATFORM_WINDOWS) { + register char *p; for (p = Tcl_DStringValue(bufferPtr); *p != '\0'; p++) { if (*p == '/') { *p = '\\'; @@ -1214,23 +1349,25 @@ Tcl_GlobObjCmd(dummy, interp, objc, objv) int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { - int index, i, globFlags, pathlength, length, join, dir, result; - char *string, *pathOrDir, *separators; + int index, i, globFlags, length, join, dir, result; + char *string, *separators; Tcl_Obj *typePtr, *resultPtr, *look; - Tcl_DString prefix, directory; + Tcl_Obj *pathOrDir = NULL; + Tcl_DString prefix; static char *options[] = { - "-directory", "-join", "-nocomplain", "-path", "-types", "--", NULL + "-directory", "-join", "-nocomplain", "-path", "-tails", + "-types", "--", NULL }; enum options { - GLOB_DIR, GLOB_JOIN, GLOB_NOCOMPLAIN, GLOB_PATH, GLOB_TYPE, GLOB_LAST + GLOB_DIR, GLOB_JOIN, GLOB_NOCOMPLAIN, GLOB_PATH, GLOB_TAILS, + GLOB_TYPE, GLOB_LAST }; enum pathDirOptions {PATH_NONE = -1 , PATH_GENERAL = 0, PATH_DIR = 1}; - GlobTypeData *globTypes = NULL; + Tcl_GlobTypeData *globTypes = NULL; globFlags = 0; join = 0; dir = PATH_NONE; - pathOrDir = NULL; typePtr = NULL; resultPtr = Tcl_GetObjResult(interp); for (i = 1; i < objc; i++) { @@ -1254,7 +1391,7 @@ Tcl_GlobObjCmd(dummy, interp, objc, objv) } switch (index) { case GLOB_NOCOMPLAIN: /* -nocomplain */ - globFlags |= GLOBMODE_NO_COMPLAIN; + globFlags |= TCL_GLOBMODE_NO_COMPLAIN; break; case GLOB_DIR: /* -dir */ if (i == (objc-1)) { @@ -1262,34 +1399,37 @@ Tcl_GlobObjCmd(dummy, interp, objc, objv) "missing argument to \"-directory\"", -1); return TCL_ERROR; } - if (dir != -1) { + if (dir != PATH_NONE) { Tcl_AppendToObj(resultPtr, "\"-directory\" cannot be used with \"-path\"", -1); return TCL_ERROR; } dir = PATH_DIR; - globFlags |= GLOBMODE_DIR; - pathOrDir = Tcl_GetStringFromObj(objv[i+1], &pathlength); + globFlags |= TCL_GLOBMODE_DIR; + pathOrDir = objv[i+1]; i++; break; case GLOB_JOIN: /* -join */ join = 1; break; + case GLOB_TAILS: /* -tails */ + globFlags |= TCL_GLOBMODE_TAILS; + break; case GLOB_PATH: /* -path */ if (i == (objc-1)) { Tcl_AppendToObj(resultPtr, "missing argument to \"-path\"", -1); return TCL_ERROR; } - if (dir != -1) { + if (dir != PATH_NONE) { Tcl_AppendToObj(resultPtr, "\"-path\" cannot be used with \"-directory\"", -1); return TCL_ERROR; } dir = PATH_GENERAL; - pathOrDir = Tcl_GetStringFromObj(objv[i+1], &pathlength); + pathOrDir = objv[i+1]; i++; break; case GLOB_TYPE: /* -types */ @@ -1315,7 +1455,13 @@ Tcl_GlobObjCmd(dummy, interp, objc, objv) Tcl_WrongNumArgs(interp, 1, objv, "?switches? name ?name ...?"); return TCL_ERROR; } - + if ((globFlags & TCL_GLOBMODE_TAILS) && (pathOrDir == NULL)) { + Tcl_AppendToObj(resultPtr, + "\"-tails\" must be used with either \"-directory\" or \"-path\"", + -1); + return TCL_ERROR; + } + separators = NULL; /* lint. */ switch (tclPlatform) { case TCL_PLATFORM_UNIX: @@ -1329,34 +1475,34 @@ Tcl_GlobObjCmd(dummy, interp, objc, objv) break; } if (dir == PATH_GENERAL) { + int pathlength; char *last; + char *first = Tcl_GetStringFromObj(pathOrDir,&pathlength); /* * Find the last path separator in the path */ - last = pathOrDir + pathlength; - for (; last != pathOrDir; last--) { + last = first + pathlength; + for (; last != first; last--) { if (strchr(separators, *(last-1)) != NULL) { break; } } - if (last == pathOrDir + pathlength) { + if (last == first + pathlength) { /* It's really a directory */ - dir = 1; + dir = PATH_DIR; } else { Tcl_DString pref; char *search, *find; Tcl_DStringInit(&pref); - Tcl_DStringInit(&directory); - if (last == pathOrDir) { + if (last == first) { /* The whole thing is a prefix */ - Tcl_DStringAppend(&pref, pathOrDir, -1); + Tcl_DStringAppend(&pref, first, -1); pathOrDir = NULL; } else { /* Have to split off the end */ - Tcl_DStringAppend(&pref, last, pathOrDir+pathlength-last); - Tcl_DStringAppend(&directory, pathOrDir, last-pathOrDir-1); - pathOrDir = Tcl_DStringValue(&directory); + Tcl_DStringAppend(&pref, last, first+pathlength-last); + pathOrDir = Tcl_NewStringObj(first, last-first-1); } /* Need to quote 'prefix' */ Tcl_DStringInit(&prefix); @@ -1376,7 +1522,7 @@ Tcl_GlobObjCmd(dummy, interp, objc, objv) Tcl_DStringFree(&pref); } } - + if (typePtr != NULL) { /* * The rest of the possible type arguments (except 'd') are @@ -1384,7 +1530,7 @@ Tcl_GlobObjCmd(dummy, interp, objc, objv) * on an incompatible platform. */ Tcl_ListObjLength(interp, typePtr, &length); - globTypes = (GlobTypeData*) ckalloc(sizeof(GlobTypeData)); + globTypes = (Tcl_GlobTypeData*) ckalloc(sizeof(Tcl_GlobTypeData)); globTypes->type = 0; globTypes->perm = 0; globTypes->macType = NULL; @@ -1476,13 +1622,18 @@ Tcl_GlobObjCmd(dummy, interp, objc, objv) goto endOfGlob; badMacTypesArg: Tcl_AppendToObj(resultPtr, - "only one MacOS type or creator argument to \"-types\" allowed", -1); + "only one MacOS type or creator argument" + " to \"-types\" allowed", -1); result = TCL_ERROR; goto endOfGlob; } } } + if (pathOrDir != NULL) { + Tcl_IncrRefCount(pathOrDir); + } + /* * Now we perform the actual glob below. This may involve joining * together the pattern arguments, dealing with particular file types @@ -1543,7 +1694,7 @@ Tcl_GlobObjCmd(dummy, interp, objc, objv) } } } - if ((globFlags & GLOBMODE_NO_COMPLAIN) == 0) { + if ((globFlags & TCL_GLOBMODE_NO_COMPLAIN) == 0) { if (Tcl_ListObjLength(interp, Tcl_GetObjResult(interp), &length) != TCL_OK) { /* This should never happen. Maybe we should be more dramatic */ @@ -1571,9 +1722,9 @@ Tcl_GlobObjCmd(dummy, interp, objc, objv) endOfGlob: if (join || (dir == PATH_GENERAL)) { Tcl_DStringFree(&prefix); - if (dir == PATH_GENERAL) { - Tcl_DStringFree(&directory); - } + } + if (pathOrDir != NULL) { + Tcl_DecrRefCount(pathOrDir); } if (globTypes != NULL) { if (globTypes->macType != NULL) { @@ -1600,11 +1751,11 @@ Tcl_GlobObjCmd(dummy, interp, objc, objv) * The return value is a standard Tcl result indicating whether * an error occurred in globbing. After a normal return the * result in interp (set by TclDoGlob) holds all of the file names - * given by the dir and rem arguments. After an error the - * result in interp will hold an error message. + * given by the pattern and unquotedPrefix arguments. After an + * error the result in interp will hold an error message. * * Side effects: - * The currentArgString is written to. + * The 'pattern' is written to. * *---------------------------------------------------------------------- */ @@ -1616,16 +1767,16 @@ TclGlob(interp, pattern, unquotedPrefix, globFlags, types) * 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. */ + 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. + Tcl_GlobTypeData *types; /* Struct containing acceptable types. * May be NULL. */ { char *separators; char *head, *tail, *start; char c; - int result; + int result, prefixLen; Tcl_DString buffer; separators = NULL; /* lint. */ @@ -1647,7 +1798,7 @@ TclGlob(interp, pattern, unquotedPrefix, globFlags, types) Tcl_DStringInit(&buffer); if (unquotedPrefix != NULL) { - start = unquotedPrefix; + start = Tcl_GetString(unquotedPrefix); } else { start = pattern; } @@ -1672,35 +1823,15 @@ TclGlob(interp, pattern, unquotedPrefix, globFlags, types) } /* - * Determine the home directory for the specified user. Note that - * we don't allow special characters in the user name. + * Determine the home directory for the specified user. */ 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) { + if (globFlags & TCL_GLOBMODE_NO_COMPLAIN) { /* * We should in fact pass down the nocomplain flag * or save the interp result or use another mechanism @@ -1725,29 +1856,76 @@ TclGlob(interp, pattern, unquotedPrefix, globFlags, types) } else { tail = pattern; if (unquotedPrefix != NULL) { - Tcl_DStringAppend(&buffer,unquotedPrefix,-1); + Tcl_DStringAppend(&buffer,Tcl_GetString(unquotedPrefix),-1); } } + /* - * If the prefix is a directory, make sure it ends in a directory - * separator. + * We want to remember the length of the current prefix, + * in case we are using TCL_GLOBMODE_TAILS. Also if we + * are using TCL_GLOBMODE_DIR, we must make sure the + * prefix 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) { + 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 & TCL_GLOBMODE_DIR) { Tcl_DStringAppend(&buffer,separators,1); } + prefixLen++; } } result = TclDoGlob(interp, separators, &buffer, tail, types); Tcl_DStringFree(&buffer); + if (result != TCL_OK) { - if (globFlags & GLOBMODE_NO_COMPLAIN) { + if (globFlags & TCL_GLOBMODE_NO_COMPLAIN) { 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, Tcl_FSMatchInDirectory, 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 & TCL_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; + if (len == prefixLen) { + if ((pattern[0] == '\0') + || (strchr(separators, pattern[0]) == NULL)) { + str = Tcl_NewStringObj(".",1); + } else { + str = Tcl_NewStringObj("/",1); + } + } else { + str = Tcl_NewStringObj(oldStr + prefixLen, + len - prefixLen); + } + Tcl_ListObjAppendElement(interp, tailResult, str); + } + Tcl_SetObjResult(interp, tailResult); + } } return result; } @@ -1841,8 +2019,8 @@ TclDoGlob(interp, separators, headPtr, tail, types) Tcl_DString *headPtr; /* Completely expanded prefix. */ char *tail; /* The unexpanded remainder of the path. * Must not be a pointer to a static string. */ - GlobTypeData *types; /* List object containing list of acceptable types. - * May be NULL. */ + Tcl_GlobTypeData *types; /* List object containing list of acceptable + * types. May be NULL. */ { int baseLength, quoted, count; int result = TCL_OK; @@ -1999,8 +2177,8 @@ TclDoGlob(interp, separators, headPtr, tail, types) Tcl_DStringSetLength(&newName, baseLength); Tcl_DStringAppend(&newName, element, p-element); Tcl_DStringAppend(&newName, closeBrace+1, -1); - result = TclDoGlob(interp, separators, - headPtr, Tcl_DStringValue(&newName), types); + result = TclDoGlob(interp, separators, headPtr, + Tcl_DStringValue(&newName), types); if (result != TCL_OK) { break; } @@ -2025,24 +2203,70 @@ TclDoGlob(interp, separators, headPtr, tail, types) * if the string is a static. */ - savedChar = *p; - *p = '\0'; - firstSpecialChar = strpbrk(tail, "*[]?\\"); - *p = savedChar; + savedChar = *p; + *p = '\0'; + firstSpecialChar = strpbrk(tail, "*[]?\\"); + *p = savedChar; } else { firstSpecialChar = strpbrk(tail, "*[]?\\"); } if (firstSpecialChar != NULL) { + int ret; + Tcl_Obj *head = Tcl_NewStringObj(Tcl_DStringValue(headPtr),-1); + Tcl_IncrRefCount(head); /* - * 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. + * Look for matching files in the given directory. The + * implementation of this function is platform specific. For + * each file that matches, it will add the match onto the + * resultPtr given. */ + if (*p == '\0') { + ret = Tcl_FSMatchInDirectory(interp, Tcl_GetObjResult(interp), + head, tail, types); + } else { + Tcl_Obj* resultPtr; - return TclpMatchFilesTypes(interp, separators, headPtr, tail, p, types); + /* + * We do the recursion ourselves. This makes implementing + * Tcl_FSMatchInDirectory for each filesystem much easier. + */ + Tcl_GlobTypeData dirOnly = { TCL_GLOB_TYPE_DIR, 0, NULL, NULL }; + char save = *p; + + *p = '\0'; + resultPtr = Tcl_NewListObj(0, NULL); + ret = Tcl_FSMatchInDirectory(interp, resultPtr, + head, tail, &dirOnly); + *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); + if(tclPlatform == TCL_PLATFORM_MAC) { + Tcl_DStringAppend(&ds, ":",1); + } else { + 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') { @@ -2061,7 +2285,7 @@ TclDoGlob(interp, separators, headPtr, tail, types) Tcl_DStringAppend(headPtr, ":", 1); } name = Tcl_DStringValue(headPtr); - if (TclpAccess(name, F_OK) == 0) { + 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)); @@ -2079,6 +2303,9 @@ TclDoGlob(interp, separators, headPtr, tail, types) * 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) { @@ -2096,7 +2323,7 @@ TclDoGlob(interp, separators, headPtr, tail, types) } } name = Tcl_DStringValue(headPtr); - exists = (TclpAccess(name, F_OK) == 0); + exists = (Tcl_Access(name, F_OK) == 0); for (p = name; *p != '\0'; p++) { if (*p == '\\') { @@ -2118,7 +2345,7 @@ TclDoGlob(interp, separators, headPtr, tail, types) } } name = Tcl_DStringValue(headPtr); - if (TclpAccess(name, F_OK) == 0) { + if (Tcl_Access(name, F_OK) == 0) { Tcl_ListObjAppendElement(interp, Tcl_GetObjResult(interp), Tcl_NewStringObj(name,-1)); } diff --git a/generic/tclGetDate.y b/generic/tclGetDate.y index b7da254..dd3310b 100644 --- a/generic/tclGetDate.y +++ b/generic/tclGetDate.y @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclGetDate.y,v 1.16 2000/05/18 22:29:56 ericm Exp $ + * RCS: @(#) $Id: tclGetDate.y,v 1.17 2001/07/31 19:12:06 vincentdarley Exp $ */ %{ @@ -33,7 +33,7 @@ #include "tclInt.h" #include "tclPort.h" -#ifdef MAC_TCL +#if defined(MAC_TCL) && !defined(TCL_MAC_USE_MSL_EPOCH) # define EPOCH 1904 # define START_OF_TIME 1904 # define END_OF_TIME 2039 diff --git a/generic/tclIO.c b/generic/tclIO.c index 7bd0938..8ef6e12 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIO.c,v 1.32 2001/07/18 17:13:25 andreas_kupries Exp $ + * RCS: @(#) $Id: tclIO.c,v 1.33 2001/07/31 19:12:06 vincentdarley Exp $ */ #include "tclInt.h" @@ -104,6 +104,8 @@ static void DeleteChannelTable _ANSI_ARGS_(( 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_(( @@ -687,6 +689,38 @@ CheckForStdChannelsBeingClosed(chan) /* *---------------------------------------------------------------------- * + * 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. @@ -747,13 +781,21 @@ Tcl_RegisterChannel(interp, chan) * * 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. + * 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: - * Deletes the hash entry for a channel associated with an interpreter. + * 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. * *---------------------------------------------------------------------- */ @@ -763,46 +805,14 @@ Tcl_UnregisterChannel(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_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); + if (DetachChannel(interp, chan) != TCL_OK) { + return TCL_OK; } - - statePtr->refCount--; + 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 @@ -829,17 +839,143 @@ Tcl_UnregisterChannel(interp, chan) statePtr->curOutPtr->nextRemoved)) { statePtr->flags |= BUFFER_READY; } - statePtr->flags |= CHANNEL_CLOSED; + Tcl_Preserve((ClientData)statePtr); if (!(statePtr->flags & BG_FLUSH_SCHEDULED)) { - if (Tcl_Close(interp, chan) != TCL_OK) { - return TCL_ERROR; - } + /* 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; + Tcl_Release((ClientData)statePtr); + return TCL_ERROR; + } + } } + statePtr->flags |= CHANNEL_CLOSED; + Tcl_Release((ClientData)statePtr); } 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; +} + + +/* *--------------------------------------------------------------------------- * * Tcl_GetChannel -- diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index e3f0a6e..78ab3cf 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIOCmd.c,v 1.7 1999/09/21 04:20:40 hobbs Exp $ + * RCS: @(#) $Id: tclIOCmd.c,v 1.8 2001/07/31 19:12:06 vincentdarley Exp $ */ #include "tclInt.h" @@ -953,7 +953,7 @@ Tcl_OpenObjCmd(notUsed, interp, objc, objv) */ if (!pipeline) { - chan = Tcl_OpenFileChannel(interp, what, modeString, prot); + chan = Tcl_FSOpenFileChannel(interp, objv[1], modeString, prot); } else { #ifdef MAC_TCL Tcl_AppendResult(interp, diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index f4412e5..ec0e277 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -1,8 +1,12 @@ /* * tclIOUtil.c -- * - * This file contains a collection of utility procedures that - * are shared by the platform specific IO drivers. + * 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. @@ -13,12 +17,187 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIOUtil.c,v 1.11 2000/05/27 23:58:01 hobbs Exp $ + * RCS: @(#) $Id: tclIOUtil.c,v 1.12 2001/07/31 19:12:06 vincentdarley Exp $ */ #include "tclInt.h" #include "tclPort.h" + +/* + * Prototypes for procedures defined later in this file. The last + * of these could perhaps be exported in the future, if extensions + * require it. + */ + +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_Obj* 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, char *separator)); +static Tcl_Filesystem* Tcl_FSGetFileSystemForPath + _ANSI_ARGS_((Tcl_Obj* pathObjPtr)); + +/* + * 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(dirName) + 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(interp, cwdPtr) + 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 users of these APIs are prowrap + * and mktclapp. New code/extensions should not use them, since they + * do not provide as full support as the full filesystem API. + */ +#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,10 +224,10 @@ typedef struct OpenFileChannelProc { } 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. + * 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,26 +235,638 @@ typedef struct OpenFileChannelProc { * This method avoids the need to call any sort of "initialization" * function. * - * All three lists are protected by a global hookMutex. + * All three lists are protected by a global obsoleteFsHookMutex. */ -static StatProc defaultStatProc = { - &TclpStat, NULL -}; -static StatProc *statProcList = &defaultStatProc; +static StatProc *statProcList = NULL; +static AccessProc *accessProcList = NULL; +static OpenFileChannelProc *openFileChannelProcList = NULL; + +TCL_DECLARE_MUTEX(obsoleteFsHookMutex) + +#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 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 FilesystemRecord *nextPtr; + /* The next filesystem registered + * to Tcl, or NULL if no more. */ +} 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 Tcl_FS... set of functions, + * which ensure correct and complete virtual filesystem support. + * + * We cannot make all of these static, since some of them + * are implemented in the platform-specific directories. + */ +static Tcl_FSPathInFilesystemProc NativePathInFilesystem; +static Tcl_FSFilesystemPathTypeProc NativeFilesystemPathType; +static Tcl_FSFilesystemSeparatorProc NativeFilesystemSeparator; +static Tcl_FSFreeInternalRepProc NativeFreeInternalRep; +static Tcl_FSDupInternalRepProc NativeDupInternalRep; +static Tcl_FSCreateInternalRepProc NativeCreateNativeRep; +static Tcl_FSFileAttrStringsProc NativeFileAttrStrings; +static Tcl_FSFileAttrsGetProc NativeFileAttrsGet; +static Tcl_FSFileAttrsSetProc NativeFileAttrsSet; +static Tcl_FSLoadFileProc NativeLoadFile; +static Tcl_FSOpenFileChannelProc NativeOpenFileChannel; +static Tcl_FSUtimeProc NativeUtime; -static AccessProc defaultAccessProc = { - &TclpAccess, NULL +/* + * The only reason these functions are not static is that they + * are either called by code in the native (win/unix/mac) directories + * or they are actually implemented in those directories. They + * should simply not be called by code outside Tcl's native + * filesystem core. i.e. they should be considered 'static' to + * Tcl's filesystem code (if we ever built the native filesystem + * support into a separate code library, this could actually be + * enforced). + */ +Tcl_FSInternalToNormalizedProc TclpNativeToNormalized; +Tcl_FSStatProc TclpObjStat; +Tcl_FSAccessProc TclpObjAccess; +Tcl_FSMatchInDirectoryProc TclpMatchInDirectory; +Tcl_FSGetCwdProc TclpObjGetCwd; +Tcl_FSChdirProc TclpObjChdir; +Tcl_FSLstatProc TclpObjLstat; +Tcl_FSCopyFileProc TclpObjCopyFile; +Tcl_FSDeleteFileProc TclpObjDeleteFile; +Tcl_FSRenameFileProc TclpObjRenameFile; +Tcl_FSCreateDirectoryProc TclpObjCreateDirectory; +Tcl_FSCopyDirectoryProc TclpObjCopyDirectory; +Tcl_FSRemoveDirectoryProc TclpObjRemoveDirectory; +Tcl_FSUnloadFileProc TclpUnloadFile; +Tcl_FSReadlinkProc TclpObjReadlink; +Tcl_FSListVolumesProc TclpListVolumes; + +/* Define the native filesystem dispatch table */ +static Tcl_Filesystem nativeFilesystem = { + "native", + sizeof(Tcl_Filesystem), + TCL_FILESYSTEM_VERSION_1, + &NativePathInFilesystem, + &NativeDupInternalRep, + &NativeFreeInternalRep, + &TclpNativeToNormalized, + &NativeCreateNativeRep, + &TclpObjNormalizePath, + &NativeFilesystemPathType, + &NativeFilesystemSeparator, + &TclpObjStat, + &TclpObjAccess, + &NativeOpenFileChannel, + &TclpMatchInDirectory, + &NativeUtime, +#ifndef S_IFLNK + NULL, +#else + &TclpObjReadlink, +#endif /* S_IFLNK */ + &TclpListVolumes, + &NativeFileAttrStrings, + &NativeFileAttrsGet, + &NativeFileAttrsSet, + &TclpObjCreateDirectory, + &TclpObjRemoveDirectory, + &TclpObjDeleteFile, + &TclpObjLstat, + &TclpObjCopyFile, + &TclpObjRenameFile, + &TclpObjCopyDirectory, + &NativeLoadFile, + &TclpUnloadFile, + &TclpObjGetCwd, + &TclpObjChdir }; -static AccessProc *accessProcList = &defaultAccessProc; -static OpenFileChannelProc defaultOpenFileChannelProc = { - &TclpOpenFileChannel, NULL +/* + * 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 FilesystemRecord nativeFilesystemRecord = { + NULL, + &nativeFilesystem, + 1, + NULL }; -static OpenFileChannelProc *openFileChannelProcList = - &defaultOpenFileChannelProc; -TCL_DECLARE_MUTEX(hookMutex) +/* + * The following few variables are protected by the + * filesystemMutex just below. + */ + +/* + * This is incremented each time we modify the linked list of + * filesystems. Any time it changes, all cached filesystem + * representations are suspect and must be freed. + */ +int filesystemEpoch = 0; +/* Stores the linked list of filesystems.*/ +static FilesystemRecord *filesystemList = &nativeFilesystemRecord; +/* + * The number of loops which are currently iterating over the linked + * list. If this is greater than zero, we can't modify the list. + */ +int filesystemIteratorsInProgress = 0; +/* Someone wants to modify the list of filesystems if this is set. */ +int filesystemWantToModify = 0; + +Tcl_Condition filesystemOkToModify = NULL; + +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 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) + +/* + * Declare fallback support function and + * information for Tcl_FSLoadFile + */ +static Tcl_FSUnloadFileProc FSUnloadTempFile; + +/* + * One of these structures is used each time we successfully load a + * file from a file system by way of making a temporary copy of the + * file on the native filesystem. We need to store both the actual + * unloadProc/clientData combination which was used, and the original + * and modified filenames, so that we can correctly undo the entire + * operation when we want to unload the code. + */ +typedef struct FsDivertLoad { + ClientData clientData; + Tcl_FSUnloadFileProc *unloadProcPtr; + Tcl_Obj *divertedFile; +} FsDivertLoad; + +/* Now move on to the basic filesystem implementation */ + + +static int +FsCwdPointerEquals(objPtr) + Tcl_Obj* objPtr; +{ + Tcl_MutexLock(&cwdMutex); + if (cwdPathPtr == objPtr) { + Tcl_MutexUnlock(&cwdMutex); + return 1; + } else { + Tcl_MutexUnlock(&cwdMutex); + return 0; + } +} + + +static FilesystemRecord* +FsGetIterator(void) { + Tcl_MutexLock(&filesystemMutex); + filesystemIteratorsInProgress++; + Tcl_MutexUnlock(&filesystemMutex); + /* Now we know the list of filesystems cannot be modified */ + return filesystemList; +} + +static void +FsReleaseIterator(void) { + Tcl_MutexLock(&filesystemMutex); + filesystemIteratorsInProgress--; + if (filesystemIteratorsInProgress == 0) { + /* Notify any waiting threads that things are ok now */ + if (filesystemWantToModify > 0) { + Tcl_ConditionNotify(&filesystemOkToModify); + } + } + Tcl_MutexUnlock(&filesystemMutex); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FSRegister -- + * + * 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 +Tcl_FSRegister(clientData, fsPtr) + ClientData clientData; /* Client specific data for this fs */ + Tcl_Filesystem *fsPtr; /* The filesystem record for the new fs. */ +{ + FilesystemRecord *newFilesystemPtr; + + if (fsPtr == NULL) { + return TCL_ERROR; + } + + newFilesystemPtr = (FilesystemRecord *) + ckalloc(sizeof(FilesystemRecord)); + + newFilesystemPtr->clientData = clientData; + newFilesystemPtr->fsPtr = fsPtr; + + /* + * Is this lock and wait strictly speaking necessary? Since any + * iterators out there will have grabbed a copy of the head of + * the list and be iterating away from that, if we add a new + * element to the head of the list, it can't possibly have any + * effect on any of their loops. In fact it could be better not + * to wait, since we are adjusting the filesystem epoch, any + * cached representations calculated by existing iterators are + * going to have to be thrown away anyway. + * + * However, since registering and unregistering filesystems is + * a very rare action, this is not a very important point. + */ + Tcl_MutexLock(&filesystemMutex); + filesystemWantToModify++; + Tcl_ConditionWait(&filesystemOkToModify, &filesystemMutex, NULL); + filesystemWantToModify--; + + newFilesystemPtr->nextPtr = filesystemList; + filesystemList = newFilesystemPtr; + /* + * Increment the filesystem epoch counter, since existing paths + * might conceivably now belong to different filesystems. + */ + filesystemEpoch++; + Tcl_MutexUnlock(&filesystemMutex); + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FSUnregister -- + * + * 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 +Tcl_FSUnregister(fsPtr) + Tcl_Filesystem *fsPtr; /* The filesystem record to remove. */ +{ + int retVal = TCL_ERROR; + FilesystemRecord *tmpFsRecPtr; + FilesystemRecord *prevFsRecPtr = NULL; + + Tcl_MutexLock(&filesystemMutex); + filesystemWantToModify++; + Tcl_ConditionWait(&filesystemOkToModify, &filesystemMutex, NULL); + filesystemWantToModify--; + 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; + } + /* + * Increment the filesystem epoch counter, since existing + * paths might conceivably now belong to different + * filesystems. This should also ensure that paths which + * have cached the filesystem which is about to be deleted + * do not reference that filesystem (which would of course + * lead to memory exceptions). + */ + filesystemEpoch++; + + ckfree((char *)tmpFsRecPtr); + + retVal = TCL_OK; + } else { + prevFsRecPtr = tmpFsRecPtr; + tmpFsRecPtr = tmpFsRecPtr->nextPtr; + } + } + + Tcl_MutexUnlock(&filesystemMutex); + return (retVal); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FSData -- + * + * 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 +Tcl_FSData(fsPtr) + Tcl_Filesystem *fsPtr; /* The filesystem record to query. */ +{ + ClientData retVal = NULL; + FilesystemRecord *tmpFsRecPtr; + + tmpFsRecPtr = FsGetIterator(); + /* + * 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; + } + + FsReleaseIterator(); + return (retVal); +} + +/* + *--------------------------------------------------------------------------- + * + * FSNormalizeAbsolutePath -- + * + * Description: + * Takes an absolute path specification and computes a 'normalized' + * path from 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 that long form's case-dependence (which gives + * us a unique, case-dependent path). + * + * The behaviour of this function if passed a non-absolute path + * is NOT defined. + * + * 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* +FSNormalizeAbsolutePath(interp, path) + Tcl_Interp* interp; /* Interpreter to use */ + char *path; /* Absolute path to normalize (UTF-8) */ +{ + 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, 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; +{ + 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). + */ + + fsRecPtr = FsGetIterator(); + while (fsRecPtr != NULL) { + if (fsRecPtr == &nativeFilesystemRecord) { + Tcl_FSNormalizePathProc *proc = fsRecPtr->fsPtr->normalizePathProc; + if (proc != NULL) { + retVal = (*proc)(interp, pathPtr, retVal); + } + break; + } + fsRecPtr = fsRecPtr->nextPtr; + } + FsReleaseIterator(); + + fsRecPtr = FsGetIterator(); + while (fsRecPtr != NULL) { + /* Skip the native system next time through */ + if (fsRecPtr != &nativeFilesystemRecord) { + Tcl_FSNormalizePathProc *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; + } + FsReleaseIterator(); + + return (retVal); +} /* *--------------------------------------------------------------------------- @@ -255,7 +1046,7 @@ TclGetOpenMode(interp, string, seekFlagPtr) /* *---------------------------------------------------------------------- * - * Tcl_EvalFile -- + * Tcl_FSEvalFile -- * * Read in a file and process the entire file as one gigantic * Tcl command. @@ -265,44 +1056,47 @@ TclGetOpenMode(interp, string, seekFlagPtr) * the file or an error indicating why the file couldn't be read. * * Side effects: - * Depends on the commands in the file. + * 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_EvalFile(interp, fileName) +Tcl_FSEvalFile(interp, fileName) Tcl_Interp *interp; /* Interpreter in which to process file. */ - char *fileName; /* Name of file to process. Tilde-substitution + Tcl_Obj *fileName; /* Name of file to process. Tilde-substitution * will be performed on this name. */ { int result, length; struct stat statBuf; - char *oldScriptFile; + Tcl_Obj *oldScriptFile; Interp *iPtr; - Tcl_DString nameString; - char *name, *string; + char *string; Tcl_Channel chan; Tcl_Obj *objPtr; - name = Tcl_TranslateFileName(interp, fileName, &nameString); - if (name == NULL) { + if (Tcl_FSGetTranslatedPath(interp, fileName) == NULL) { return TCL_ERROR; } result = TCL_ERROR; objPtr = Tcl_NewObj(); - if (TclStat(name, &statBuf) == -1) { + if (Tcl_FSStat(fileName, &statBuf) == -1) { Tcl_SetErrno(errno); - Tcl_AppendResult(interp, "couldn't read file \"", fileName, + Tcl_AppendResult(interp, "couldn't read file \"", + Tcl_GetString(fileName), "\": ", Tcl_PosixError(interp), (char *) NULL); goto end; } - chan = Tcl_OpenFileChannel(interp, name, "r", 0644); + chan = Tcl_FSOpenFileChannel(interp, fileName, "r", 0644); if (chan == (Tcl_Channel) NULL) { Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "couldn't read file \"", fileName, + Tcl_AppendResult(interp, "couldn't read file \"", + Tcl_GetString(fileName), "\": ", Tcl_PosixError(interp), (char *) NULL); goto end; } @@ -314,7 +1108,8 @@ Tcl_EvalFile(interp, fileName) 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_AppendResult(interp, "couldn't read file \"", + Tcl_GetString(fileName), "\": ", Tcl_PosixError(interp), (char *) NULL); goto end; } @@ -324,11 +1119,18 @@ Tcl_EvalFile(interp, fileName) iPtr = (Interp *) interp; oldScriptFile = iPtr->scriptFile; - iPtr->scriptFile = ckalloc((unsigned) (strlen(fileName) + 1)); - strcpy(iPtr->scriptFile, fileName); + iPtr->scriptFile = fileName; + Tcl_IncrRefCount(iPtr->scriptFile); string = Tcl_GetStringFromObj(objPtr, &length); result = Tcl_EvalEx(interp, string, length, 0); - ckfree(iPtr->scriptFile); + /* + * 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,14 +1142,13 @@ Tcl_EvalFile(interp, fileName) * Record information telling where the error occurred. */ - sprintf(msg, "\n (file \"%.150s\" line %d)", fileName, + sprintf(msg, "\n (file \"%.150s\" line %d)", Tcl_GetString(fileName), interp->errorLine); Tcl_AddErrorInfo(interp, msg); } end: Tcl_DecrRefCount(objPtr); - Tcl_DStringFree(&nameString); return result; } @@ -435,12 +1236,12 @@ Tcl_PosixError(interp) /* *---------------------------------------------------------------------- * - * TclStat -- + * Tcl_FSStat -- * * 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. + * + * The appropriate function for the filesystem to which pathPtr + * belongs will be called. * * Results: * See stat documentation. @@ -452,38 +1253,94 @@ Tcl_PosixError(interp) */ int -TclStat(path, buf) - CONST char *path; /* Path of file to stat (in current CP). */ +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; int retVal = -1; +#endif /* USE_OBSOLETE_FS_HOOKS */ + Tcl_Filesystem *fsPtr; + 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(&hookMutex); +#ifdef USE_OBSOLETE_FS_HOOKS + Tcl_MutexLock(&obsoleteFsHookMutex); statProcPtr = statProcList; while ((retVal == -1) && (statProcPtr != NULL)) { retVal = (*statProcPtr->proc)(path, buf); statProcPtr = statProcPtr->nextPtr; } - Tcl_MutexUnlock(&hookMutex); + Tcl_MutexUnlock(&obsoleteFsHookMutex); + if (retVal != -1) { + return retVal; + } +#endif /* USE_OBSOLETE_FS_HOOKS */ + fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); + if (fsPtr != NULL) { + Tcl_FSStatProc *proc = fsPtr->statProc; + if (proc != NULL) { + return (*proc)(pathPtr, buf); + } + } + Tcl_SetErrno(ENOENT); + return -1; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FSLstat -- + * + * This procedure replaces the library version of lstat. + * The appropriate function for the filesystem to which pathPtr + * belongs will be called. If no 'lstat' function is listed, + * but a 'stat' function is, then Tcl will fall back on the + * stat function. + * + * Results: + * See lstat documentation. + * + * Side effects: + * See lstat documentation. + * + *---------------------------------------------------------------------- + */ - return (retVal); +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. */ +{ + Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); + if (fsPtr != NULL) { + Tcl_FSLstatProc *proc = fsPtr->lstatProc; + if (proc != NULL) { + return (*proc)(pathPtr, buf); + } else { + Tcl_FSStatProc *sproc = fsPtr->statProc; + if (sproc != NULL) { + return (*sproc)(pathPtr, buf); + } + } + } + Tcl_SetErrno(ENOENT); + return -1; } /* *---------------------------------------------------------------------- * - * TclAccess -- + * Tcl_FSAccess -- * * 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. + * The appropriate function for the filesystem to which pathPtr + * belongs will be called. * * Results: * See access documentation. @@ -495,38 +1352,53 @@ TclStat(path, buf) */ int -TclAccess(path, mode) - CONST char *path; /* Path of file to access (in current CP). */ +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; int retVal = -1; +#endif /* USE_OBSOLETE_FS_HOOKS */ + Tcl_Filesystem *fsPtr; + 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(&hookMutex); +#ifdef USE_OBSOLETE_FS_HOOKS + Tcl_MutexLock(&obsoleteFsHookMutex); accessProcPtr = accessProcList; while ((retVal == -1) && (accessProcPtr != NULL)) { retVal = (*accessProcPtr->proc)(path, mode); accessProcPtr = accessProcPtr->nextPtr; } - Tcl_MutexUnlock(&hookMutex); + Tcl_MutexUnlock(&obsoleteFsHookMutex); + if (retVal != -1) { + return retVal; + } +#endif /* USE_OBSOLETE_FS_HOOKS */ + fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); + if (fsPtr != NULL) { + Tcl_FSAccessProc *proc = fsPtr->accessProc; + if (proc != NULL) { + return (*proc)(pathPtr, mode); + } + } - return (retVal); + Tcl_SetErrno(ENOENT); + return -1; } /* *---------------------------------------------------------------------- * - * Tcl_OpenFileChannel -- + * Tcl_FSOpenFileChannel -- * - * 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. + * 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. @@ -539,18 +1411,25 @@ TclAccess(path, mode) */ Tcl_Channel -Tcl_OpenFileChannel(interp, fileName, modeString, permissions) +Tcl_FSOpenFileChannel(interp, pathPtr, modeString, permissions) Tcl_Interp *interp; /* Interpreter for error reporting; * can be NULL. */ - char *fileName; /* Name of file to open. */ + 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; Tcl_Channel retVal = NULL; +#endif /* USE_OBSOLETE_FS_HOOKS */ + Tcl_Filesystem *fsPtr; + char *path = Tcl_FSGetTranslatedPath(interp, pathPtr); + if (path == NULL) { + return NULL; + } /* * Call each of the "Tcl_OpenFileChannel" function in succession. @@ -558,21 +1437,2413 @@ Tcl_OpenFileChannel(interp, fileName, modeString, permissions) * succeeded. */ - Tcl_MutexLock(&hookMutex); +#ifdef USE_OBSOLETE_FS_HOOKS + Tcl_MutexLock(&obsoleteFsHookMutex); openFileChannelProcPtr = openFileChannelProcList; while ((retVal == NULL) && (openFileChannelProcPtr != NULL)) { - retVal = (*openFileChannelProcPtr->proc)(interp, fileName, + retVal = (*openFileChannelProcPtr->proc)(interp, path, modeString, permissions); openFileChannelProcPtr = openFileChannelProcPtr->nextPtr; } - Tcl_MutexUnlock(&hookMutex); + Tcl_MutexUnlock(&obsoleteFsHookMutex); + if (retVal != NULL) { + return retVal; + } +#endif /* USE_OBSOLETE_FS_HOOKS */ + fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); + if (fsPtr != NULL) { + Tcl_FSOpenFileChannelProc *proc = fsPtr->openFileChannelProc; + if (proc != NULL) { + return (*proc)(interp, pathPtr, modeString, permissions); + } + } + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * 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. If pathPtr does not belong to any filesystem and if it + * is NULL or the empty string, then we assume the pattern is to + * be matched in the current working directory. To avoid each + * filesystem's Tcl_FSMatchInDirectoryProc having to deal with + * this issue, we create a pathPtr on the fly, and then remove it + * from the results returned. This makes filesystems easy to + * write, since they can assume the pathPtr passed to them + * is an ordinary path. In fact this means we could remove such + * special case handling from Tcl's native filesystems. + * + * 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. + * + * Recursive searches, e.g. + * + * glob -dir $dir -join * pkgIndex.tcl + * + * which must recurse through each directory matching '*' are + * handled internally by Tcl, by passing specific flags in a + * modified 'types' parameter. + * + * Side effects: + * The interpreter may have an error message inserted into it. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_FSMatchInDirectory(interp, result, pathPtr, pattern, types) + Tcl_Interp *interp; /* Interpreter to receive error messages. */ + Tcl_Obj *result; /* List object to receive results. */ + Tcl_Obj *pathPtr; /* Contains path to directory to search. */ + char *pattern; /* Pattern to match against. */ + Tcl_GlobTypeData *types; /* Object containing list of acceptable types. + * May be NULL. In particular the directory + * flag is very important. */ +{ + Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); + if (fsPtr != NULL) { + Tcl_FSMatchInDirectoryProc *proc = fsPtr->matchInDirectoryProc; + if (proc != NULL) { + return (*proc)(interp, result, pathPtr, pattern, types); + } + } else { + Tcl_Obj* cwd; + int ret; + if (pathPtr != NULL) { + int len; + Tcl_GetStringFromObj(pathPtr,&len); + if (len != 0) { + /* + * We have no idea how to match files in a directory + * which belongs to no known filesystem + */ + return -1; + } + } + /* + * We have a null string, this means we must use the 'cwd', and + * then manipulate the result. We must deal with this here, + * since if we don't, every single filesystem's implementation + * of Tcl_FSMatchInDirectory will have to deal with it for us. + */ + cwd = Tcl_FSGetCwd(NULL); + if (cwd == NULL) { + if (interp != NULL) { + Tcl_SetResult(interp, "glob couldn't determine" + "the current working directory", TCL_STATIC); + } + return TCL_ERROR; + } + fsPtr = Tcl_FSGetFileSystemForPath(cwd); + if (fsPtr != NULL) { + Tcl_FSMatchInDirectoryProc *proc = fsPtr->matchInDirectoryProc; + if (proc != NULL) { + int cwdLen; + Tcl_Obj *cwdDir; + Tcl_Obj* tmpResultPtr = Tcl_NewListObj(0, NULL); + /* + * We know the cwd is a normalised object which does + * not end in a directory delimiter. + */ + cwdDir = Tcl_DuplicateObj(cwd); + #ifdef MAC_TCL + Tcl_AppendToObj(cwdDir, ":", 1); + #else + Tcl_AppendToObj(cwdDir, "/", 1); + #endif + Tcl_GetStringFromObj(cwdDir, &cwdLen); + Tcl_IncrRefCount(cwdDir); + ret = (*proc)(interp, tmpResultPtr, cwdDir, pattern, types); + Tcl_DecrRefCount(cwdDir); + if (ret == TCL_OK) { + int resLength; + ret = Tcl_ListObjLength(interp, tmpResultPtr, &resLength); + if (ret == TCL_OK) { + int i; + for (i =0; i< resLength; i++) { + Tcl_Obj *elt, *cutElt; + char *eltStr; + int eltLen; + Tcl_ListObjIndex(interp, tmpResultPtr, i, &elt); + eltStr = Tcl_GetStringFromObj(elt,&eltLen); + cutElt = Tcl_NewStringObj(eltStr + cwdLen, eltLen - cwdLen); + Tcl_ListObjAppendElement(interp, result, cutElt); + } + } + } + Tcl_DecrRefCount(tmpResultPtr); + } + } + Tcl_DecrRefCount(cwd); + return ret; + } + 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; + + if (FsCwdPointerEquals(NULL)) { + FilesystemRecord *fsRecPtr; + Tcl_Obj *retVal = NULL; + + /* + * 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 = FsGetIterator(); + while ((retVal == NULL) && (fsRecPtr != NULL)) { + Tcl_FSGetCwdProc *proc = fsRecPtr->fsPtr->getCwdProc; + if (proc != NULL) { + retVal = (*proc)(interp); + } + fsRecPtr = fsRecPtr->nextPtr; + } + FsReleaseIterator(); + /* + * 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. + */ + if (retVal != NULL) { + Tcl_Obj *norm = 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. + * + * Threading issue: note that multiple threads at system + * startup could in principle call this procedure + * simultaneously. They will therefore each set the + * cwdPathPtr independently. That behaviour is a bit + * peculiar, but should be fine. Once we have a cwd, + * we'll always be in the 'else' branch below which + * is simpler. + */ + Tcl_MutexLock(&cwdMutex); + /* Just in case the pointer has been set by another + * thread between now and the test above */ + if (cwdPathPtr != NULL) { + Tcl_DecrRefCount(cwdPathPtr); + } + cwdPathPtr = norm; + Tcl_MutexUnlock(&cwdMutex); + } + Tcl_DecrRefCount(retVal); + } + } 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. This + * allows an error to be thrown if, say, the permissions on + * that directory have changed. + */ + 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) { + Tcl_FSGetCwdProc *proc = fsPtr->getCwdProc; + if (proc != NULL) { + Tcl_Obj *retVal = (*proc)(interp); + if (retVal != NULL) { + Tcl_Obj *norm = FSNormalizeAbsolutePath(interp, + Tcl_GetString(retVal)); + /* + * Check whether cwd has changed from the value + * previously stored in cwdPathPtr. Really 'norm' + * shouldn't be null, but we are careful. + */ + if (norm == NULL) { + /* Do nothing */ + } else if (Tcl_FSEqualPaths(cwdPathPtr, norm)) { + /* + * If the paths were equal, we can be more + * efficient and retain the old path object + * which will probably already be shared. In + * this case we can simply free the normalized + * path we just calculated. + */ + Tcl_DecrRefCount(norm); + } else { + /* The cwd has in fact changed, so we must + * lock down the cwdMutex to modify. */ + Tcl_MutexLock(&cwdMutex); + Tcl_DecrRefCount(cwdPathPtr); + cwdPathPtr = norm; + Tcl_MutexUnlock(&cwdMutex); + } + Tcl_DecrRefCount(retVal); + } else { + /* The 'cwd' function returned an error, so we + * reset the cwd after locking down the mutex. */ + Tcl_MutexLock(&cwdMutex); + Tcl_DecrRefCount(cwdPathPtr); + cwdPathPtr = NULL; + Tcl_MutexUnlock(&cwdMutex); + } + } + } + } + + /* + * The paths all eventually fall through to here. Note that + * we use a bunch of separate mutex locks throughout this + * code to help prevent deadlocks between threads. Really + * the only weirdness will arise if multiple threads are setting + * and reading the cwd, and that behaviour is always going to be + * a little suspect. + */ + Tcl_MutexLock(&cwdMutex); + 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; /* File to change access/modification times */ + struct utimbuf *tval; /* Structure containing access/modification + * times to use. Should not be modified. */ +{ + Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); + if (fsPtr != NULL) { + Tcl_FSUtimeProc *proc = fsPtr->utimeProc; + if (proc != NULL) { + return (*proc)(pathPtr, tval); + } + } + return -1; +} + +/* + *---------------------------------------------------------------------- + * + * NativeFileAttrStrings -- + * + * 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** +NativeFileAttrStrings(pathPtr, objPtrRef) + Tcl_Obj *pathPtr; + Tcl_Obj** objPtrRef; +{ + return tclpFileAttrStrings; +} + +/* + *---------------------------------------------------------------------- + * + * NativeFileAttrsGet -- + * + * 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 +NativeFileAttrsGet(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); +} + +/* + *---------------------------------------------------------------------- + * + * NativeFileAttrsSet -- + * + * 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 +NativeFileAttrsSet(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) { + Tcl_FSFileAttrStringsProc *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) { + Tcl_FSFileAttrsGetProc *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) { + Tcl_FSFileAttrsSetProc *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) { + Tcl_FSChdirProc *proc = fsPtr->chdirProc; + if (proc != NULL) { + retVal = (*proc)(pathPtr); + } else { + /* Fallback on stat-based implementation */ + struct stat buf; + /* If the file can be stat'ed and is a directory and + * is readable, then we can chdir. */ + if ((Tcl_FSStat(pathPtr, &buf) == 0) + && (S_ISDIR(buf.st_mode)) + && (Tcl_FSAccess(pathPtr, R_OK) == 0)) { + /* We allow the chdir */ + retVal = 0; + } + } + } + + 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) { + /* Get a lock on the cwd while we modify it */ + 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. */ + Tcl_FSUnloadFileProc **unloadProcPtr; + /* Filled with address of Tcl_FSUnloadFileProc + * function which should be used for + * this file. */ +{ + Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); + if (fsPtr != NULL) { + Tcl_FSLoadFileProc *proc = fsPtr->loadFileProc; + if (proc != NULL) { + int retVal = (*proc)(interp, pathPtr, sym1, sym2, + proc1Ptr, proc2Ptr, clientDataPtr); + if (retVal != -1) { + /* + * We handled it. Remember which unload file + * proc to use. + */ + (*unloadProcPtr) = fsPtr->unloadFileProc; + } + return retVal; + } else { + Tcl_Filesystem *copyFsPtr; + /* Get a temporary filename to use, first to + * copy the file into, and then to load. */ + Tcl_Obj *copyToPtr = TclpTempFileName(); + if (copyToPtr == NULL) { + return -1; + } + Tcl_IncrRefCount(copyToPtr); + + copyFsPtr = Tcl_FSGetFileSystemForPath(copyToPtr); + if ((copyFsPtr == NULL) || (copyFsPtr == fsPtr)) { + /* We already know we can't use Tcl_FSLoadFile from + * this filesystem, and we must avoid a possible + * infinite loop. */ + Tcl_DecrRefCount(copyToPtr); + return -1; + } + + if (Tcl_FSCopyFile(pathPtr, copyToPtr) == 0) { + /* + * Do we need to set appropriate permissions + * on the file? This may be required on some + * systems. On Unix we could do loop over + * the file attributes, and set any that are + * called "-permissions" to 0777. Or directly: + * + * Tcl_Obj* perm = Tcl_NewStringObj("0777",-1); + * Tcl_IncrRefCount(perm); + * Tcl_FSFileAttrsSet(NULL, 2, copyToPtr, perm); + * Tcl_DecrRefCount(perm); + * + */ + ClientData newClientData = NULL; + Tcl_FSUnloadFileProc *newUnloadProcPtr = NULL; + FsDivertLoad *tvdlPtr; + int retVal; + + retVal = Tcl_FSLoadFile(interp, copyToPtr, sym1, sym2, proc1Ptr, + proc2Ptr, &newClientData, &newUnloadProcPtr); + if (retVal == -1) { + /* The file didn't load successfully */ + Tcl_FSDeleteFile(copyToPtr); + Tcl_DecrRefCount(copyToPtr); + return -1; + } + /* + * When we unload this file, we need to divert the + * unloading so we can unload and cleanup the + * temporary file correctly. + */ + tvdlPtr = (FsDivertLoad*) ckalloc(sizeof(FsDivertLoad)); + + /* + * Remember three pieces of information. This allows + * us to cleanup the diverted load completely, on + * platforms which allow proper unloading of code. + */ + tvdlPtr->clientData = newClientData; + tvdlPtr->unloadProcPtr = newUnloadProcPtr; + /* copyToPtr is already incremented for this reference */ + tvdlPtr->divertedFile = copyToPtr; + copyToPtr = NULL; + (*clientDataPtr) = (ClientData) tvdlPtr; + (*unloadProcPtr) = &FSUnloadTempFile; + + return retVal; + } + } + } + return -1; +} + +/* + *--------------------------------------------------------------------------- + * + * FSUnloadTempFile -- + * + * This function is called when we loaded a library of code via + * an intermediate temporary file. This function ensures + * the library is correctly unloaded and the temporary file + * is correctly deleted. + * + * Results: + * None. + * + * Side effects: + * The effects of the 'unload' function called, and of course + * the temporary file will be deleted. + * + *--------------------------------------------------------------------------- + */ +static void +FSUnloadTempFile(clientData) + ClientData clientData; /* ClientData returned by a previous call + * to Tcl_FSLoadFile(). The clientData is + * a token that represents the loaded + * file. */ +{ + FsDivertLoad *tvdlPtr = (FsDivertLoad*)clientData; + /* + * This test should never trigger, since we give + * the client data in the function above. + */ + if (tvdlPtr == NULL) { return; } + + /* Call the real 'unloadfile' proc we actually used. */ + if (tvdlPtr->unloadProcPtr != NULL) { + (*tvdlPtr->unloadProcPtr)(tvdlPtr->clientData); + } + + /* Remove the temporary file we created. */ + Tcl_FSDeleteFile(tvdlPtr->divertedFile); + + /* And free up the allocations */ + Tcl_DecrRefCount(tvdlPtr->divertedFile); + ckfree((char*)tvdlPtr); +} + +/* + *--------------------------------------------------------------------------- + * + * 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) { + Tcl_FSReadlinkProc *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(interp) + Tcl_Interp *interp; /* Interpreter for returning volume list. */ +{ + 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. + */ + + fsRecPtr = FsGetIterator(); + while (fsRecPtr != NULL) { + Tcl_FSListVolumesProc *proc = fsRecPtr->fsPtr->listVolumesProc; + if (proc != NULL) { + /* Ignore return value */ + (*proc)(interp); + } + fsRecPtr = fsRecPtr->nextPtr; + } + FsReleaseIterator(); + + 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(srcPathPtr, destPathPtr) + 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) { + Tcl_FSRenameFileProc *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(srcPathPtr, destPathPtr) + 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) { + Tcl_FSCopyFileProc *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(pathPtr) + Tcl_Obj *pathPtr; /* Pathname of file to be removed (UTF-8). */ +{ + Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); + if (fsPtr != NULL) { + Tcl_FSDeleteFileProc *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(pathPtr) + Tcl_Obj *pathPtr; /* Pathname of directory to create (UTF-8). */ +{ + Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); + if (fsPtr != NULL) { + Tcl_FSCreateDirectoryProc *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(srcPathPtr, destPathPtr, errorPtr) + 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) { + Tcl_FSCopyDirectoryProc *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(pathPtr, recursive, errorPtr) + 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) { + Tcl_FSRemoveDirectoryProc *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 "~<user>" (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 { + if (FsCwdPointerEquals(fsPathPtr->cwdPtr)) { + return TCL_OK; + } else { + FreeFsPathInternalRep(objPtr); + objPtr->typePtr = NULL; + return Tcl_ConvertToType(interp, objPtr, &tclFsPathType); + } + } + } else { + return Tcl_ConvertToType(interp, objPtr, &tclFsPathType); + } +} + + +/* + * Helper function for SetFsPathFromAny. Returns position of first + * directory delimiter in the path. + */ +static int +FindSplitPos(path, separator) + char *path; + char *separator; +{ + int count = 0; + switch (tclPlatform) { + case TCL_PLATFORM_UNIX: + case TCL_PLATFORM_MAC: + while (path[count] != 0) { + if (path[count] == *separator) { + return count; + } + count++; + } + break; + + case TCL_PLATFORM_WINDOWS: + while (path[count] != 0) { + if (path[count] == *separator || 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 "~<user>" (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; + char separator='/'; + + if (tclPlatform==TCL_PLATFORM_MAC) { + if (strchr(name, ':') != NULL) separator = ':'; + } + + split = FindSplitPos(name, &separator); + if (split != len) { + /* We have multiple pieces '~user/foo/bar...' */ + name[split] = '\0'; + } + /* Do some tilde substitution */ + if (name[1] == '\0') { + /* We have just '~' */ + char *dir; + Tcl_DString dirString; + if (split != len) { name[split] = separator; } + + 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] = separator; } + return TCL_ERROR; + } + if (split != len) { name[split] = separator; } + } + 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 + */ + char *argv[2]; + argv[0] = expandedUser; + argv[1] = name+split+1; + Tcl_JoinPath(2, argv, &buffer); + } + Tcl_DStringFree(&temp); + } else { + Tcl_DStringInit(&buffer); + Tcl_JoinPath(1, &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(fromFilesystem, clientData) + Tcl_Obj* fromFilesystem; + ClientData clientData; +{ + Tcl_Obj *objPtr; + FsPath *fsPathPtr, *fsFromPtr; + Tcl_FSInternalToNormalizedProc *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)); + Tcl_FSDupInternalRepProc *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(interp, pathPtr) + 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(interp, pathObjPtr) + 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 ((path[0] != '\0') && (Tcl_GetPathType(path) == TCL_PATH_RELATIVE)) { + 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 = 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); + + /* Get a quick, temporary lock on the cwd while we copy it */ + 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 + * 'Tcl_FSCreateInternalRepProc'. + * + * Results: + * NULL or a valid internal representation. + * + * Side effects: + * An attempt may be made to convert the object. + * + *--------------------------------------------------------------------------- + */ + +ClientData +Tcl_FSGetInternalRep(pathObjPtr, fsPtr) + 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) { + Tcl_FSCreateInternalRepProc *proc; + proc = srcFsPathPtr->fsRecPtr->fsPtr->createInternalRepProc; + + if (proc == NULL) { + return NULL; + } + srcFsPathPtr->nativePathPtr = (*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(pathObjPtr) + Tcl_Obj* pathObjPtr; +{ + return (char*)Tcl_FSGetInternalRep(pathObjPtr, &nativeFilesystem); +} + +/* + *--------------------------------------------------------------------------- + * + * NativeCreateNativeRep -- + * + * Create a native representation for the given path. + * + * Results: + * None. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ +ClientData +NativeCreateNativeRep(pathObjPtr) + Tcl_Obj* pathObjPtr; +{ + char *nativePathPtr; + Tcl_DString ds; + Tcl_Obj* normPtr; + int len; + char *str; + + /* Make sure the normalized path is set */ + normPtr = Tcl_FSGetNormalizedPath(NULL, pathObjPtr); + + str = Tcl_GetStringFromObj(normPtr,&len); +#ifdef __WIN32__ + Tcl_WinUtfToTChar(str, len, &ds); + nativePathPtr = ckalloc((unsigned)(2+Tcl_DStringLength(&ds))); + memcpy((VOID*)nativePathPtr, (VOID*)Tcl_DStringValue(&ds), + (size_t) (2+Tcl_DStringLength(&ds))); +#else + Tcl_UtfToExternalDString(NULL, str, len, &ds); + nativePathPtr = ckalloc((unsigned)(1+Tcl_DStringLength(&ds))); + memcpy((VOID*)nativePathPtr, (VOID*)Tcl_DStringValue(&ds), + (size_t) (1+Tcl_DStringLength(&ds))); +#endif + + Tcl_DStringFree(&ds); + return (ClientData)nativePathPtr; +} + +/* + *--------------------------------------------------------------------------- + * + * 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 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; +} + + +/* + *--------------------------------------------------------------------------- + * + * NativeDupInternalRep -- + * + * Duplicate the native representation. + * + * Results: + * The copied native representation, or NULL if it is not possible + * to copy the representation. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ +ClientData +NativeDupInternalRep(clientData) + ClientData clientData; +{ +#ifdef __WIN32__ + /* Copying internal representations is complicated with multi-byte TChars */ + return NULL; +#else + if (clientData == NULL) { + return NULL; + } else { + char *native = (char*)clientData; + char *copy = ckalloc((unsigned)(1+strlen(native))); + strcpy(copy,native); + return (ClientData)copy; + } +#endif +} + +/* + *--------------------------------------------------------------------------- + * + * NativePathInFilesystem -- + * + * 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', -1 to indicate no. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ +int +NativePathInFilesystem(pathPtr, clientDataPtr) + Tcl_Obj *pathPtr; + ClientData *clientDataPtr; +{ + int len; + Tcl_GetStringFromObj(pathPtr,&len); + if (len == 0) { + return -1; + } else { + /* We accept any path as valid */ + return TCL_OK; + } +} + +/* + *--------------------------------------------------------------------------- + * + * NativeFreeInternalRep -- + * + * Free a native internal representation, which will be non-NULL. + * + * Results: + * None. + * + * Side effects: + * Memory is released. + * + *--------------------------------------------------------------------------- + */ +void +NativeFreeInternalRep(clientData) + 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(pathObjPtr) + Tcl_Obj* pathObjPtr; +{ + Tcl_Obj *resPtr; + Tcl_FSFilesystemPathTypeProc *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(pathObjPtr) + Tcl_Obj* pathObjPtr; +{ + Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathObjPtr); + + if (fsPtr == NULL) { + return NULL; + } + if (fsPtr->filesystemSeparatorProc != NULL) { + return (*fsPtr->filesystemSeparatorProc)(pathObjPtr); + } + + return NULL; +} + +/* + *--------------------------------------------------------------------------- + * + * NativeFilesystemSeparator -- + * + * 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* +NativeFilesystemSeparator(pathObjPtr) + 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); +} + +/* + *--------------------------------------------------------------------------- + * + * NativeFilesystemPathType -- + * + * 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* +NativeFilesystemPathType(pathObjPtr) + 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(pathObjPtr) + Tcl_Obj* pathObjPtr; +{ + 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 + * + * While we don't need the fsRecPtr until the while loop + * below, we do want to make sure the filesystemEpoch doesn't + * change between the 'if' and 'while' blocks, getting this + * iterator will ensure that everything is consistent + */ + fsRecPtr = FsGetIterator(); + + /* 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. + */ + + while ((retVal == NULL) && (fsRecPtr != NULL)) { + Tcl_FSPathInFilesystemProc *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; + } + + done: + FsReleaseIterator(); + 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(firstPtr, secondPtr) + 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 +NativeOpenFileChannel(interp, pathPtr, modeString, permissions) + 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 +NativeUtime(pathPtr, tval) + Tcl_Obj *pathPtr; + struct utimbuf *tval; +{ + #ifdef MAC_TCL + long gmt_offset=TclpGetGMTOffset(); + struct utimbuf local_tval; + local_tval.actime=tval->actime+gmt_offset; + local_tval.modtime=tval->modtime+gmt_offset; + return utime(Tcl_GetString(Tcl_FSGetNormalizedPath(NULL,pathPtr)),&local_tval); + #else + return utime(Tcl_GetString(Tcl_FSGetNormalizedPath(NULL,pathPtr)),tval); + #endif +} + +int +NativeLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr, clientDataPtr) + 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 is contained in this obsolete ifdef */ +#ifdef USE_OBSOLETE_FS_HOOKS + +/* + *---------------------------------------------------------------------- + * * TclStatInsertProc -- * * Insert the passed procedure pointer at the head of the list of @@ -605,10 +3876,10 @@ TclStatInsertProc (proc) if (newStatProcPtr != NULL) { newStatProcPtr->proc = proc; - Tcl_MutexLock(&hookMutex); + Tcl_MutexLock(&obsoleteFsHookMutex); newStatProcPtr->nextPtr = statProcList; statProcList = newStatProcPtr; - Tcl_MutexUnlock(&hookMutex); + Tcl_MutexUnlock(&obsoleteFsHookMutex); retVal = TCL_OK; } @@ -644,7 +3915,7 @@ TclStatDeleteProc (proc) StatProc *tmpStatProcPtr; StatProc *prevStatProcPtr = NULL; - Tcl_MutexLock(&hookMutex); + Tcl_MutexLock(&obsoleteFsHookMutex); tmpStatProcPtr = statProcList; /* * Traverse the 'statProcList' looking for the particular node @@ -652,7 +3923,7 @@ TclStatDeleteProc (proc) * the list. Ensure that the "default" node cannot be removed. */ - while ((retVal == TCL_ERROR) && (tmpStatProcPtr != &defaultStatProc)) { + while ((retVal == TCL_ERROR) && (tmpStatProcPtr != NULL)) { if (tmpStatProcPtr->proc == proc) { if (prevStatProcPtr == NULL) { statProcList = tmpStatProcPtr->nextPtr; @@ -660,7 +3931,7 @@ TclStatDeleteProc (proc) prevStatProcPtr->nextPtr = tmpStatProcPtr->nextPtr; } - Tcl_Free((char *)tmpStatProcPtr); + ckfree((char *)tmpStatProcPtr); retVal = TCL_OK; } else { @@ -669,7 +3940,7 @@ TclStatDeleteProc (proc) } } - Tcl_MutexUnlock(&hookMutex); + Tcl_MutexUnlock(&obsoleteFsHookMutex); return (retVal); } @@ -708,10 +3979,10 @@ TclAccessInsertProc(proc) if (newAccessProcPtr != NULL) { newAccessProcPtr->proc = proc; - Tcl_MutexLock(&hookMutex); + Tcl_MutexLock(&obsoleteFsHookMutex); newAccessProcPtr->nextPtr = accessProcList; accessProcList = newAccessProcPtr; - Tcl_MutexUnlock(&hookMutex); + Tcl_MutexUnlock(&obsoleteFsHookMutex); retVal = TCL_OK; } @@ -753,9 +4024,9 @@ TclAccessDeleteProc(proc) * the list. Ensure that the "default" node cannot be removed. */ - Tcl_MutexLock(&hookMutex); + Tcl_MutexLock(&obsoleteFsHookMutex); tmpAccessProcPtr = accessProcList; - while ((retVal == TCL_ERROR) && (tmpAccessProcPtr != &defaultAccessProc)) { + while ((retVal == TCL_ERROR) && (tmpAccessProcPtr != NULL)) { if (tmpAccessProcPtr->proc == proc) { if (prevAccessProcPtr == NULL) { accessProcList = tmpAccessProcPtr->nextPtr; @@ -763,7 +4034,7 @@ TclAccessDeleteProc(proc) prevAccessProcPtr->nextPtr = tmpAccessProcPtr->nextPtr; } - Tcl_Free((char *)tmpAccessProcPtr); + ckfree((char *)tmpAccessProcPtr); retVal = TCL_OK; } else { @@ -771,7 +4042,7 @@ TclAccessDeleteProc(proc) tmpAccessProcPtr = tmpAccessProcPtr->nextPtr; } } - Tcl_MutexUnlock(&hookMutex); + Tcl_MutexUnlock(&obsoleteFsHookMutex); return (retVal); } @@ -813,10 +4084,10 @@ TclOpenFileChannelInsertProc(proc) if (newOpenFileChannelProcPtr != NULL) { newOpenFileChannelProcPtr->proc = proc; - Tcl_MutexLock(&hookMutex); + Tcl_MutexLock(&obsoleteFsHookMutex); newOpenFileChannelProcPtr->nextPtr = openFileChannelProcList; openFileChannelProcList = newOpenFileChannelProcPtr; - Tcl_MutexUnlock(&hookMutex); + Tcl_MutexUnlock(&obsoleteFsHookMutex); retVal = TCL_OK; } @@ -855,13 +4126,13 @@ TclOpenFileChannelDeleteProc(proc) /* * 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. + * the list. */ - Tcl_MutexLock(&hookMutex); + Tcl_MutexLock(&obsoleteFsHookMutex); tmpOpenFileChannelProcPtr = openFileChannelProcList; while ((retVal == TCL_ERROR) && - (tmpOpenFileChannelProcPtr != &defaultOpenFileChannelProc)) { + (tmpOpenFileChannelProcPtr != NULL)) { if (tmpOpenFileChannelProcPtr->proc == proc) { if (prevOpenFileChannelProcPtr == NULL) { openFileChannelProcList = tmpOpenFileChannelProcPtr->nextPtr; @@ -870,7 +4141,7 @@ TclOpenFileChannelDeleteProc(proc) tmpOpenFileChannelProcPtr->nextPtr; } - Tcl_Free((char *)tmpOpenFileChannelProcPtr); + ckfree((char *)tmpOpenFileChannelProcPtr); retVal = TCL_OK; } else { @@ -878,7 +4149,8 @@ TclOpenFileChannelDeleteProc(proc) tmpOpenFileChannelProcPtr = tmpOpenFileChannelProcPtr->nextPtr; } } - Tcl_MutexUnlock(&hookMutex); + Tcl_MutexUnlock(&obsoleteFsHookMutex); return (retVal); } +#endif /* USE_OBSOLETE_FS_HOOKS */ diff --git a/generic/tclInt.decls b/generic/tclInt.decls index 4894d2d..b0b883b 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: tclInt.decls,v 1.28 2001/06/17 03:48:19 dgp Exp $ +# RCS: @(#) $Id: tclInt.decls,v 1.29 2001/07/31 19:12:06 vincentdarley Exp $ library tcl @@ -74,7 +74,7 @@ declare 12 generic { } declare 13 generic { int TclDoGlob(Tcl_Interp *interp, char *separators, \ - Tcl_DString *headPtr, char *tail, GlobTypeData *types) + Tcl_DString *headPtr, char *tail, Tcl_GlobTypeData *types) } declare 14 generic { void TclDumpMemoryInfo(FILE *outFile) @@ -86,21 +86,22 @@ declare 14 generic { 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) -} +# 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, \ @@ -235,10 +236,11 @@ declare 58 generic { 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) -} +# 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) } @@ -272,19 +274,19 @@ declare 68 generic { 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 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) } @@ -310,13 +312,13 @@ declare 80 generic { 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) -} +#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, \ @@ -512,9 +514,9 @@ declare 135 generic { # Added in 8.1: -declare 137 generic { - int TclpChdir(CONST char *dirName) -} +#declare 137 generic { +# int TclpChdir(CONST char *dirName) +#} declare 138 generic { char * TclGetEnv(CONST char *name, Tcl_DString *valuePtr) } @@ -526,9 +528,9 @@ declare 139 generic { declare 140 generic { int TclLooksLikeInt(char *bytes, int length) } -declare 141 generic { - char *TclpGetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr) -} +#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) @@ -601,10 +603,10 @@ declare 158 generic { 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) -} +#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 { @@ -614,6 +616,31 @@ declare 161 generic { 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 { + int TclFileCopyCmd(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) +} +declare 164 generic { + int TclFileRenameCmd(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) +} +declare 165 generic { + int TclFileDeleteCmd(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) +} +declare 166 generic { + int TclFileMakeDirsCmd(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) +} +declare 167 generic { + int TclFileAttrsCmd(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) +} +declare 168 generic { + Tcl_Obj* TclpTempFileName(void) +} +declare 169 generic { + void TclpSetInitialEncodings(void) +} ############################################################################## @@ -870,3 +897,4 @@ declare 8 unix { declare 9 unix { TclFile TclpCreateTempFile(CONST char *contents) } + diff --git a/generic/tclInt.h b/generic/tclInt.h index 2ee93d0..ddb8fd4 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclInt.h,v 1.57 2001/06/28 01:22:21 hobbs Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.58 2001/07/31 19:12:06 vincentdarley Exp $ */ #ifndef _TCLINT @@ -1274,11 +1274,9 @@ typedef struct Interp { * are added/removed by calling * Tcl_AddInterpResolvers and * Tcl_RemoveInterpResolver. */ - char *scriptFile; /* NULL means there is no nested source + Tcl_Obj *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. */ + * 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. */ @@ -1505,9 +1503,24 @@ typedef struct TclFileAttrProcs { typedef struct TclFile_ *TclFile; /* + * Opaque names for platform specific types. + */ + +typedef struct TclpTime_t_ *TclpTime_t; + +/* + * The "globParameters" argument of the function TclGlob is an + * or'ed combination of the following values: + */ + +#define TCL_GLOBMODE_NO_COMPLAIN 1 +#define TCL_GLOBMODE_JOIN 2 +#define TCL_GLOBMODE_DIR 4 +#define TCL_GLOBMODE_TAILS 8 + +/* *---------------------------------------------------------------- - * Data structures related to hooking 'TclStat(...)' and - * 'TclAccess(...)'. + * Data structures related to obsolete filesystem hooks *---------------------------------------------------------------- */ @@ -1517,51 +1530,17 @@ 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. + *---------------------------------------------------------------- + * Data structures related to procedures + *---------------------------------------------------------------- */ -typedef struct TclpTime_t_ *TclpTime_t; - -/* - * 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. - */ -typedef struct GlobTypeData { - /* Corresponds to bcdpfls as in 'find -t' */ - int type; - /* Corresponds to file permissions */ - int perm; - /* Acceptable mac type */ - Tcl_Obj* macType; - /* Acceptable mac creator */ - Tcl_Obj* macCreator; -} GlobTypeData; - -/* - * type and permission definitions for glob command - */ -#define TCL_GLOB_TYPE_BLOCK (1<<0) -#define TCL_GLOB_TYPE_CHAR (1<<1) -#define TCL_GLOB_TYPE_DIR (1<<2) -#define TCL_GLOB_TYPE_PIPE (1<<3) -#define TCL_GLOB_TYPE_FILE (1<<4) -#define TCL_GLOB_TYPE_LINK (1<<5) -#define TCL_GLOB_TYPE_SOCK (1<<6) - -#define TCL_GLOB_PERM_RONLY (1<<0) -#define TCL_GLOB_PERM_HIDDEN (1<<1) -#define TCL_GLOB_PERM_R (1<<2) -#define TCL_GLOB_PERM_W (1<<3) -#define TCL_GLOB_PERM_X (1<<4) +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[])); /* *---------------------------------------------------------------- @@ -1577,8 +1556,6 @@ extern char * tclDefaultEncodingDir; 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. @@ -1634,8 +1611,6 @@ extern char * tclEmptyStringRep; *---------------------------------------------------------------- */ -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)); @@ -1667,7 +1642,7 @@ EXTERN void TclDeleteVars _ANSI_ARGS_((Interp *iPtr, Tcl_HashTable *tablePtr)); EXTERN int TclDoGlob _ANSI_ARGS_((Tcl_Interp *interp, char *separators, Tcl_DString *headPtr, - char *tail, GlobTypeData *types)); + char *tail, Tcl_GlobTypeData *types)); EXTERN void TclDumpMemoryInfo _ANSI_ARGS_((FILE *outFile)); EXTERN void TclExpandTokenArray _ANSI_ARGS_(( Tcl_Parse *parsePtr)); @@ -1676,13 +1651,13 @@ EXTERN void TclExprFloatError _ANSI_ARGS_((Tcl_Interp *interp, 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)) ; + int objc, Tcl_Obj *CONST objv[])) ; EXTERN int TclFileDeleteCmd _ANSI_ARGS_((Tcl_Interp *interp, - int argc, char **argv)); + int objc, Tcl_Obj *CONST objv[])); EXTERN int TclFileMakeDirsCmd _ANSI_ARGS_((Tcl_Interp *interp, - int argc, char **argv)) ; + int objc, Tcl_Obj *CONST objv[])) ; EXTERN int TclFileRenameCmd _ANSI_ARGS_((Tcl_Interp *interp, - int argc, char **argv)) ; + int objc, Tcl_Obj *CONST objv[])) ; EXTERN void TclFinalizeAllocSubsystem _ANSI_ARGS_((void)); EXTERN void TclFinalizeCompExecEnv _ANSI_ARGS_((void)); EXTERN void TclFinalizeCompilation _ANSI_ARGS_((void)); @@ -1730,8 +1705,8 @@ EXTERN int TclGetOpenMode _ANSI_ARGS_((Tcl_Interp *interp, 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)); + char *pattern, Tcl_Obj *unquotedPrefix, + int globFlags, Tcl_GlobTypeData* types)); EXTERN int TclGlobalInvoke _ANSI_ARGS_((Tcl_Interp *interp, int argc, char **argv, int flags)); EXTERN int TclGuessPackageName _ANSI_ARGS_((char *fileName, @@ -1791,8 +1766,10 @@ EXTERN int TclOpenFileChannelDeleteProc _ANSI_ARGS_(( TclOpenFileChannelProc_ *proc)); EXTERN int TclOpenFileChannelInsertProc _ANSI_ARGS_(( TclOpenFileChannelProc_ *proc)); -EXTERN int TclpAccess _ANSI_ARGS_((CONST char *filename, +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, @@ -1816,6 +1793,7 @@ EXTERN int TclpFindVariable _ANSI_ARGS_((CONST char *name, EXTERN void TclpFree _ANSI_ARGS_((char *ptr)); EXTERN unsigned long TclpGetClicks _ANSI_ARGS_((void)); EXTERN Tcl_Channel TclpGetDefaultStdChannel _ANSI_ARGS_((int type)); +EXTERN long TclpGetGMTOffset _ANSI_ARGS_((void)); EXTERN unsigned long TclpGetSeconds _ANSI_ARGS_((void)); EXTERN void TclpGetTime _ANSI_ARGS_((Tcl_Time *time)); EXTERN int TclpGetTimeZone _ANSI_ARGS_((unsigned long time)); @@ -1832,6 +1810,25 @@ EXTERN void TclpMasterUnlock _ANSI_ARGS_((void)); 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 int TclpObjCreateDirectory _ANSI_ARGS_((Tcl_Obj *pathPtr)); +EXTERN int TclpObjDeleteFile _ANSI_ARGS_((Tcl_Obj *pathPtr)); +EXTERN int TclpObjCopyDirectory _ANSI_ARGS_((Tcl_Obj *srcPathPtr, + Tcl_Obj *destPathPtr, Tcl_Obj **errorPtr)); +EXTERN int TclpObjCopyFile _ANSI_ARGS_((Tcl_Obj *srcPathPtr, + Tcl_Obj *destPathPtr)); +EXTERN int TclpObjRemoveDirectory _ANSI_ARGS_((Tcl_Obj *pathPtr, + int recursive, Tcl_Obj **errorPtr)); +EXTERN int TclpObjRenameFile _ANSI_ARGS_((Tcl_Obj *srcPathPtr, + Tcl_Obj *destPathPtr)); +EXTERN int TclpMatchInDirectory _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *resultPtr, Tcl_Obj *pathPtr, char *pattern, Tcl_GlobTypeData *types)); +EXTERN int TclpChdir _ANSI_ARGS_((CONST char *dirName)); +EXTERN char * TclpGetCwd _ANSI_ARGS_((Tcl_Interp *interp, Tcl_DString *bufferPtr)); +EXTERN Tcl_Obj* TclpObjGetCwd _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN Tcl_Obj* TclpObjReadlink _ANSI_ARGS_((Tcl_Obj *pathPtr)); +EXTERN int TclpObjChdir _ANSI_ARGS_((Tcl_Obj *pathPtr)); +EXTERN int TclpObjStat _ANSI_ARGS_((Tcl_Obj *pathPtr, struct stat *buf)); EXTERN Tcl_Channel TclpOpenFileChannel _ANSI_ARGS_((Tcl_Interp *interp, char *fileName, char *modeString, int permissions)); @@ -1894,14 +1891,14 @@ EXTERN int TclSockGetPort _ANSI_ARGS_((Tcl_Interp *interp, 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)); +EXTERN Tcl_Obj* TclpNativeToNormalized + _ANSI_ARGS_((ClientData clientData)); /* *---------------------------------------------------------------- diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index 32b6ede..8d55864 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIntDecls.h,v 1.24 2001/05/17 02:13:03 hobbs Exp $ + * RCS: @(#) $Id: tclIntDecls.h,v 1.25 2001/07/31 19:12:06 vincentdarley Exp $ */ #ifndef _TCLINTDECLS @@ -89,28 +89,18 @@ EXTERN void TclDeleteVars _ANSI_ARGS_((Interp * iPtr, /* 13 */ EXTERN int TclDoGlob _ANSI_ARGS_((Tcl_Interp * interp, char * separators, Tcl_DString * headPtr, - char * tail, GlobTypeData * types)); + char * tail, Tcl_GlobTypeData * types)); /* 14 */ EXTERN void TclDumpMemoryInfo _ANSI_ARGS_((FILE * outFile)); /* Slot 15 is reserved */ /* 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)); +/* 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,10 +213,7 @@ EXTERN Var * TclLookupVar _ANSI_ARGS_((Tcl_Interp * interp, 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)); +/* Slot 59 is reserved */ /* 60 */ EXTERN int TclNeedSpace _ANSI_ARGS_((char * start, char * end)); /* 61 */ @@ -253,16 +240,10 @@ EXTERN int TclOpenFileChannelInsertProc _ANSI_ARGS_(( 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)); +/* 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,12 +263,8 @@ EXTERN Tcl_Channel TclpOpenFileChannel _ANSI_ARGS_((Tcl_Interp * interp, /* 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 82 is reserved */ +/* Slot 83 is reserved */ /* Slot 84 is reserved */ /* Slot 85 is reserved */ /* Slot 86 is reserved */ @@ -456,8 +433,7 @@ EXTERN size_t TclpStrftime _ANSI_ARGS_((char * s, size_t maxsize, /* 135 */ EXTERN int TclpCheckStackSpace _ANSI_ARGS_((void)); /* Slot 136 is reserved */ -/* 137 */ -EXTERN int TclpChdir _ANSI_ARGS_((CONST char * dirName)); +/* Slot 137 is reserved */ /* 138 */ EXTERN char * TclGetEnv _ANSI_ARGS_((CONST char * name, Tcl_DString * valuePtr)); @@ -470,9 +446,7 @@ EXTERN int TclpLoadFile _ANSI_ARGS_((Tcl_Interp * interp, /* 140 */ EXTERN int TclLooksLikeInt _ANSI_ARGS_((char * bytes, int length)); -/* 141 */ -EXTERN char * TclpGetCwd _ANSI_ARGS_((Tcl_Interp * interp, - Tcl_DString * cwdPtr)); +/* Slot 141 is reserved */ /* 142 */ EXTERN int TclSetByteCodeFromAny _ANSI_ARGS_(( Tcl_Interp * interp, Tcl_Obj * objPtr, @@ -518,17 +492,32 @@ EXTERN void TclSetStartupScriptFileName _ANSI_ARGS_(( 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)); +/* 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 int TclFileCopyCmd _ANSI_ARGS_((Tcl_Interp * interp, + int objc, Tcl_Obj *CONST objv[])); +/* 164 */ +EXTERN int TclFileRenameCmd _ANSI_ARGS_((Tcl_Interp * interp, + int objc, Tcl_Obj *CONST objv[])); +/* 165 */ +EXTERN int TclFileDeleteCmd _ANSI_ARGS_((Tcl_Interp * interp, + int objc, Tcl_Obj *CONST objv[])); +/* 166 */ +EXTERN int TclFileMakeDirsCmd _ANSI_ARGS_((Tcl_Interp * interp, + int objc, Tcl_Obj *CONST objv[])); +/* 167 */ +EXTERN int TclFileAttrsCmd _ANSI_ARGS_((Tcl_Interp * interp, + int objc, Tcl_Obj *CONST objv[])); +/* 168 */ +EXTERN Tcl_Obj* TclpTempFileName _ANSI_ARGS_((void)); +/* 169 */ +EXTERN void TclpSetInitialEncodings _ANSI_ARGS_((void)); typedef struct TclIntStubs { int magic; @@ -563,15 +552,15 @@ typedef struct TclIntStubs { int (*tclCreateProc) _ANSI_ARGS_((Tcl_Interp * interp, Namespace * nsPtr, CONST char * procName, Tcl_Obj * argsPtr, Tcl_Obj * bodyPtr, Proc ** procPtrPtr)); /* 10 */ void (*tclDeleteCompiledLocalVars) _ANSI_ARGS_((Interp * iPtr, CallFrame * framePtr)); /* 11 */ void (*tclDeleteVars) _ANSI_ARGS_((Interp * iPtr, Tcl_HashTable * tablePtr)); /* 12 */ - int (*tclDoGlob) _ANSI_ARGS_((Tcl_Interp * interp, char * separators, Tcl_DString * headPtr, char * tail, GlobTypeData * types)); /* 13 */ + int (*tclDoGlob) _ANSI_ARGS_((Tcl_Interp * interp, char * separators, Tcl_DString * headPtr, char * tail, Tcl_GlobTypeData * types)); /* 13 */ 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 */ + 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 */ @@ -609,7 +598,7 @@ typedef struct TclIntStubs { 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 */ + 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 */ @@ -620,10 +609,10 @@ typedef struct TclIntStubs { 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 *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 */ @@ -632,8 +621,8 @@ typedef struct TclIntStubs { 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 *reserved82; + void *reserved83; void *reserved84; void *reserved85; void *reserved86; @@ -703,11 +692,11 @@ typedef struct TclIntStubs { 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 */ + 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 */ - char * (*tclpGetCwd) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_DString * cwdPtr)); /* 141 */ + 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 */ @@ -726,9 +715,16 @@ typedef struct TclIntStubs { 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 */ + 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 */ + int (*tclFileCopyCmd) _ANSI_ARGS_((Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 163 */ + int (*tclFileRenameCmd) _ANSI_ARGS_((Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 164 */ + int (*tclFileDeleteCmd) _ANSI_ARGS_((Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 165 */ + int (*tclFileMakeDirsCmd) _ANSI_ARGS_((Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 166 */ + int (*tclFileAttrsCmd) _ANSI_ARGS_((Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 167 */ + Tcl_Obj* (*tclpTempFileName) _ANSI_ARGS_((void)); /* 168 */ + void (*tclpSetInitialEncodings) _ANSI_ARGS_((void)); /* 169 */ } TclIntStubs; #ifdef __cplusplus @@ -823,26 +819,11 @@ extern TclIntStubs *tclIntStubsPtr; #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 +/* 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 */ @@ -979,10 +960,7 @@ extern TclIntStubs *tclIntStubsPtr; #define TclLookupVar \ (tclIntStubsPtr->tclLookupVar) /* 58 */ #endif -#ifndef TclpMatchFiles -#define TclpMatchFiles \ - (tclIntStubsPtr->tclpMatchFiles) /* 59 */ -#endif +/* Slot 59 is reserved */ #ifndef TclNeedSpace #define TclNeedSpace \ (tclIntStubsPtr->tclNeedSpace) /* 60 */ @@ -1023,22 +1001,10 @@ extern TclIntStubs *tclIntStubsPtr; #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 +/* Slot 70 is reserved */ +/* Slot 71 is reserved */ +/* Slot 72 is reserved */ +/* Slot 73 is reserved */ #ifndef TclpFree #define TclpFree \ (tclIntStubsPtr->tclpFree) /* 74 */ @@ -1071,14 +1037,8 @@ extern TclIntStubs *tclIntStubsPtr; #define TclpRealloc \ (tclIntStubsPtr->tclpRealloc) /* 81 */ #endif -#ifndef TclpRemoveDirectory -#define TclpRemoveDirectory \ - (tclIntStubsPtr->tclpRemoveDirectory) /* 82 */ -#endif -#ifndef TclpRenameFile -#define TclpRenameFile \ - (tclIntStubsPtr->tclpRenameFile) /* 83 */ -#endif +/* Slot 82 is reserved */ +/* Slot 83 is reserved */ /* Slot 84 is reserved */ /* Slot 85 is reserved */ /* Slot 86 is reserved */ @@ -1286,10 +1246,7 @@ extern TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclpCheckStackSpace) /* 135 */ #endif /* Slot 136 is reserved */ -#ifndef TclpChdir -#define TclpChdir \ - (tclIntStubsPtr->tclpChdir) /* 137 */ -#endif +/* Slot 137 is reserved */ #ifndef TclGetEnv #define TclGetEnv \ (tclIntStubsPtr->tclGetEnv) /* 138 */ @@ -1302,10 +1259,7 @@ extern TclIntStubs *tclIntStubsPtr; #define TclLooksLikeInt \ (tclIntStubsPtr->tclLooksLikeInt) /* 140 */ #endif -#ifndef TclpGetCwd -#define TclpGetCwd \ - (tclIntStubsPtr->tclpGetCwd) /* 141 */ -#endif +/* Slot 141 is reserved */ #ifndef TclSetByteCodeFromAny #define TclSetByteCodeFromAny \ (tclIntStubsPtr->tclSetByteCodeFromAny) /* 142 */ @@ -1372,10 +1326,7 @@ extern TclIntStubs *tclIntStubsPtr; #define TclGetStartupScriptFileName \ (tclIntStubsPtr->tclGetStartupScriptFileName) /* 159 */ #endif -#ifndef TclpMatchFilesTypes -#define TclpMatchFilesTypes \ - (tclIntStubsPtr->tclpMatchFilesTypes) /* 160 */ -#endif +/* Slot 160 is reserved */ #ifndef TclChannelTransform #define TclChannelTransform \ (tclIntStubsPtr->tclChannelTransform) /* 161 */ @@ -1384,6 +1335,34 @@ extern TclIntStubs *tclIntStubsPtr; #define TclChannelEventScriptInvoker \ (tclIntStubsPtr->tclChannelEventScriptInvoker) /* 162 */ #endif +#ifndef TclFileCopyCmd +#define TclFileCopyCmd \ + (tclIntStubsPtr->tclFileCopyCmd) /* 163 */ +#endif +#ifndef TclFileRenameCmd +#define TclFileRenameCmd \ + (tclIntStubsPtr->tclFileRenameCmd) /* 164 */ +#endif +#ifndef TclFileDeleteCmd +#define TclFileDeleteCmd \ + (tclIntStubsPtr->tclFileDeleteCmd) /* 165 */ +#endif +#ifndef TclFileMakeDirsCmd +#define TclFileMakeDirsCmd \ + (tclIntStubsPtr->tclFileMakeDirsCmd) /* 166 */ +#endif +#ifndef TclFileAttrsCmd +#define TclFileAttrsCmd \ + (tclIntStubsPtr->tclFileAttrsCmd) /* 167 */ +#endif +#ifndef TclpTempFileName +#define TclpTempFileName \ + (tclIntStubsPtr->tclpTempFileName) /* 168 */ +#endif +#ifndef TclpSetInitialEncodings +#define TclpSetInitialEncodings \ + (tclIntStubsPtr->tclpSetInitialEncodings) /* 169 */ +#endif #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */ diff --git a/generic/tclLoad.c b/generic/tclLoad.c index 3b36b9c..9dd9975 100644 --- a/generic/tclLoad.c +++ b/generic/tclLoad.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclLoad.c,v 1.4 1999/12/01 00:08:28 hobbs Exp $ + * RCS: @(#) $Id: tclLoad.c,v 1.5 2001/07/31 19:12:06 vincentdarley Exp $ */ #include "tclInt.h" @@ -19,7 +19,8 @@ * 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. + * are never unloaded, until the application exits, when + * TclFinalizeLoad is called, and these structures are freed. */ typedef struct LoadedPackage { @@ -32,7 +33,7 @@ typedef struct LoadedPackage { * others LC), no "_", as in "Net". * Malloc-ed. */ ClientData clientData; /* Token for the loaded file which should be - * passed to TclpUnloadFile() when the file + * passed to (*unLoadProcPtr)() when the file * is no longer needed. If fileName is NULL, * then this field is irrelevant. */ Tcl_PackageInitProc *initProc; @@ -46,6 +47,11 @@ typedef struct LoadedPackage { * untrusted scripts). NULL means the * package can't be used in unsafe * interpreters. */ + Tcl_FSUnloadFileProc *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,12 +119,13 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv) { Tcl_Interp *target; LoadedPackage *pkgPtr, *defaultPtr; - Tcl_DString pkgName, tmp, initName, safeInitName, fileName; + Tcl_DString pkgName, tmp, initName, safeInitName; Tcl_PackageInitProc *initProc, *safeInitProc; InterpPackage *ipFirstPtr, *ipPtr; int code, namesMatch, filesMatch; - char *p, *tempString, *fullFileName, *packageName; + char *p, *fullFileName, *packageName; ClientData clientData; + Tcl_FSUnloadFileProc *unLoadProcPtr = NULL; Tcl_UniChar ch; int offset; @@ -126,11 +133,11 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv) 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) { + 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,9 +335,9 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv) */ Tcl_MutexLock(&packageMutex); - code = TclpLoadFile(interp, fullFileName, Tcl_DStringValue(&initName), + code = Tcl_FSLoadFile(interp, objv[1], Tcl_DStringValue(&initName), Tcl_DStringValue(&safeInitName), &initProc, &safeInitProc, - &clientData); + &clientData,&unLoadProcPtr); Tcl_MutexUnlock(&packageMutex); if (code != TCL_OK) { goto done; @@ -338,7 +345,9 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv) if (initProc == NULL) { Tcl_AppendResult(interp, "couldn't find procedure ", Tcl_DStringValue(&initName), (char *) NULL); - TclpUnloadFile(clientData); + if (unLoadProcPtr != NULL) { + (*unLoadProcPtr)(clientData); + } code = TCL_ERROR; goto done; } @@ -355,6 +364,7 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv) (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,7 +420,6 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv) Tcl_DStringFree(&pkgName); Tcl_DStringFree(&initName); Tcl_DStringFree(&safeInitName); - Tcl_DStringFree(&fileName); Tcl_DStringFree(&tmp); return code; } @@ -653,7 +662,10 @@ TclFinalizeLoad() * call a function in the dll after it's been unloaded. */ if (pkgPtr->fileName[0] != '\0') { - TclpUnloadFile(pkgPtr->clientData); + Tcl_FSUnloadFileProc *unLoadProcPtr = pkgPtr->unLoadProcPtr; + if (unLoadProcPtr != NULL) { + (*unLoadProcPtr)(pkgPtr->clientData); + } } #endif ckfree(pkgPtr->fileName); diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 1fe3582..54f55c6 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclStubInit.c,v 1.53 2001/07/12 13:15:09 dkf Exp $ + * RCS: @(#) $Id: tclStubInit.c,v 1.54 2001/07/31 19:12:06 vincentdarley Exp $ */ #include "tclInt.h" @@ -80,11 +80,11 @@ TclIntStubs tclIntStubs = { TclDumpMemoryInfo, /* 14 */ NULL, /* 15 */ TclExprFloatError, /* 16 */ - TclFileAttrsCmd, /* 17 */ - TclFileCopyCmd, /* 18 */ - TclFileDeleteCmd, /* 19 */ - TclFileMakeDirsCmd, /* 20 */ - TclFileRenameCmd, /* 21 */ + NULL, /* 17 */ + NULL, /* 18 */ + NULL, /* 19 */ + NULL, /* 20 */ + NULL, /* 21 */ TclFindElement, /* 22 */ TclFindProc, /* 23 */ TclFormatInt, /* 24 */ @@ -122,7 +122,7 @@ TclIntStubs tclIntStubs = { NULL, /* 56 */ NULL, /* 57 */ TclLookupVar, /* 58 */ - TclpMatchFiles, /* 59 */ + NULL, /* 59 */ TclNeedSpace, /* 60 */ TclNewProcBodyObj, /* 61 */ TclObjCommandComplete, /* 62 */ @@ -133,10 +133,10 @@ TclIntStubs tclIntStubs = { TclOpenFileChannelInsertProc, /* 67 */ TclpAccess, /* 68 */ TclpAlloc, /* 69 */ - TclpCopyFile, /* 70 */ - TclpCopyDirectory, /* 71 */ - TclpCreateDirectory, /* 72 */ - TclpDeleteFile, /* 73 */ + NULL, /* 70 */ + NULL, /* 71 */ + NULL, /* 72 */ + NULL, /* 73 */ TclpFree, /* 74 */ TclpGetClicks, /* 75 */ TclpGetSeconds, /* 76 */ @@ -145,8 +145,8 @@ TclIntStubs tclIntStubs = { TclpListVolumes, /* 79 */ TclpOpenFileChannel, /* 80 */ TclpRealloc, /* 81 */ - TclpRemoveDirectory, /* 82 */ - TclpRenameFile, /* 83 */ + NULL, /* 82 */ + NULL, /* 83 */ NULL, /* 84 */ NULL, /* 85 */ NULL, /* 86 */ @@ -216,11 +216,11 @@ TclIntStubs tclIntStubs = { TclpStrftime, /* 134 */ TclpCheckStackSpace, /* 135 */ NULL, /* 136 */ - TclpChdir, /* 137 */ + NULL, /* 137 */ TclGetEnv, /* 138 */ TclpLoadFile, /* 139 */ TclLooksLikeInt, /* 140 */ - TclpGetCwd, /* 141 */ + NULL, /* 141 */ TclSetByteCodeFromAny, /* 142 */ TclAddLiteralObj, /* 143 */ TclHideLiteral, /* 144 */ @@ -239,9 +239,16 @@ TclIntStubs tclIntStubs = { TclVarTraceExists, /* 157 */ TclSetStartupScriptFileName, /* 158 */ TclGetStartupScriptFileName, /* 159 */ - TclpMatchFilesTypes, /* 160 */ + NULL, /* 160 */ TclChannelTransform, /* 161 */ TclChannelEventScriptInvoker, /* 162 */ + TclFileCopyCmd, /* 163 */ + TclFileRenameCmd, /* 164 */ + TclFileDeleteCmd, /* 165 */ + TclFileMakeDirsCmd, /* 166 */ + TclFileAttrsCmd, /* 167 */ + TclpTempFileName, /* 168 */ + TclpSetInitialEncodings, /* 169 */ }; TclIntPlatStubs tclIntPlatStubs = { @@ -833,6 +840,44 @@ TclStubs tclStubs = { Tcl_GetMathFuncInfo, /* 435 */ Tcl_ListMathFuncs, /* 436 */ Tcl_SubstObj, /* 437 */ + Tcl_DetachChannel, /* 438 */ + Tcl_IsStandardChannel, /* 439 */ + Tcl_FSCopyFile, /* 440 */ + Tcl_FSCopyDirectory, /* 441 */ + Tcl_FSCreateDirectory, /* 442 */ + Tcl_FSDeleteFile, /* 443 */ + Tcl_FSLoadFile, /* 444 */ + Tcl_FSMatchInDirectory, /* 445 */ + Tcl_FSReadlink, /* 446 */ + Tcl_FSRemoveDirectory, /* 447 */ + Tcl_FSRenameFile, /* 448 */ + Tcl_FSLstat, /* 449 */ + Tcl_FSUtime, /* 450 */ + Tcl_FSFileAttrsGet, /* 451 */ + Tcl_FSFileAttrsSet, /* 452 */ + Tcl_FSFileAttrStrings, /* 453 */ + Tcl_FSStat, /* 454 */ + Tcl_FSAccess, /* 455 */ + Tcl_FSOpenFileChannel, /* 456 */ + Tcl_FSGetCwd, /* 457 */ + Tcl_FSChdir, /* 458 */ + Tcl_FSConvertToPathType, /* 459 */ + Tcl_FSJoinPath, /* 460 */ + Tcl_FSSplitPath, /* 461 */ + Tcl_FSEqualPaths, /* 462 */ + Tcl_FSGetNormalizedPath, /* 463 */ + Tcl_FSJoinToPath, /* 464 */ + Tcl_FSGetInternalRep, /* 465 */ + Tcl_FSGetTranslatedPath, /* 466 */ + Tcl_FSEvalFile, /* 467 */ + Tcl_FSNewNativePath, /* 468 */ + Tcl_FSGetNativePath, /* 469 */ + Tcl_FSFileSystemInfo, /* 470 */ + Tcl_FSPathSeparator, /* 471 */ + Tcl_FSListVolumes, /* 472 */ + Tcl_FSRegister, /* 473 */ + Tcl_FSUnregister, /* 474 */ + Tcl_FSData, /* 475 */ }; /* !END!: Do not edit above this line. */ diff --git a/generic/tclTest.c b/generic/tclTest.c index 8c3ae5c..08925bd 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -13,7 +13,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclTest.c,v 1.25 2001/04/04 17:35:25 andreas_kupries Exp $ + * RCS: @(#) $Id: tclTest.c,v 1.26 2001/07/31 19:12:06 vincentdarley Exp $ */ #define TCL_TEST @@ -301,7 +301,73 @@ static int TestChannelCmd _ANSI_ARGS_((ClientData clientData, 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 void TestReport _ANSI_ARGS_((CONST char* cmd, Tcl_Obj* arg1, Tcl_Obj* arg2)); + +static Tcl_FSStatProc TestReportStat; +static Tcl_FSAccessProc TestReportAccess; +static Tcl_FSOpenFileChannelProc TestReportOpenFileChannel; +static Tcl_FSMatchInDirectoryProc TestReportMatchInDirectory; +static Tcl_FSGetCwdProc TestReportGetCwd; +static Tcl_FSChdirProc TestReportChdir; +static Tcl_FSLstatProc TestReportLstat; +static Tcl_FSCopyFileProc TestReportCopyFile; +static Tcl_FSDeleteFileProc TestReportDeleteFile; +static Tcl_FSRenameFileProc TestReportRenameFile; +static Tcl_FSCreateDirectoryProc TestReportCreateDirectory; +static Tcl_FSCopyDirectoryProc TestReportCopyDirectory; +static Tcl_FSRemoveDirectoryProc TestReportRemoveDirectory; +static Tcl_FSLoadFileProc TestReportLoadFile; +static Tcl_FSUnloadFileProc TestReportUnloadFile; +static Tcl_FSReadlinkProc TestReportReadlink; +static Tcl_FSListVolumesProc TestReportListVolumes; +static Tcl_FSFileAttrStringsProc TestReportFileAttrStrings; +static Tcl_FSFileAttrsGetProc TestReportFileAttrsGet; +static Tcl_FSFileAttrsSetProc TestReportFileAttrsSet; +static Tcl_FSUtimeProc TestReportUtime; +static Tcl_FSNormalizePathProc TestReportNormalizePath; + +static Tcl_Filesystem testReportingFilesystem = { + "reporting", + sizeof(Tcl_Filesystem), + TCL_FILESYSTEM_VERSION_1, + NULL, /* path in */ + NULL, /* native dup */ + NULL, /* native free */ + NULL, /* native to norm */ + NULL, /* convert to native */ + &TestReportNormalizePath, + NULL, /* path type */ + NULL, /* separator */ + &TestReportStat, + &TestReportAccess, + &TestReportOpenFileChannel, + &TestReportMatchInDirectory, + &TestReportUtime, + &TestReportReadlink, + &TestReportListVolumes, + &TestReportFileAttrStrings, + &TestReportFileAttrsGet, + &TestReportFileAttrsSet, + &TestReportCreateDirectory, + &TestReportRemoveDirectory, + &TestReportDeleteFile, + &TestReportLstat, + &TestReportCopyFile, + &TestReportRenameFile, + &TestReportCopyDirectory, + &TestReportLoadFile, + &TestReportUnloadFile, + &TestReportGetCwd, + &TestReportChdir +}; + + /* * External (platform specific) initialization routine, these declarations * explicitly don't use EXTERN since this code does not get compiled @@ -352,6 +418,8 @@ Tcltest_Init(interp) (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); @@ -4269,10 +4337,18 @@ TestOpenFileChannelProc1(interp, fileName, modeString, permissions) * file, with what modes to create * it? */ { - if (!strcmp("testOpenFileChannel1%.fil", fileName)) { + char *expectname="testOpenFileChannel1%.fil"; + Tcl_DString ds; + + Tcl_DStringInit(&ds); + Tcl_JoinPath(1, &expectname, &ds); + + if (!strcmp(Tcl_DStringValue(&ds), fileName)) { + Tcl_DStringFree(&ds); return (TclpOpenFileChannel(interp, "__testOpenFileChannel1%__.fil", modeString, permissions)); } else { + Tcl_DStringFree(&ds); return (NULL); } } @@ -4289,10 +4365,18 @@ TestOpenFileChannelProc2(interp, fileName, modeString, permissions) * file, with what modes to create * it? */ { - if (!strcmp("testOpenFileChannel2%.fil", fileName)) { + char *expectname="testOpenFileChannel2%.fil"; + Tcl_DString ds; + + Tcl_DStringInit(&ds); + Tcl_JoinPath(1, &expectname, &ds); + + if (!strcmp(Tcl_DStringValue(&ds), fileName)) { + Tcl_DStringFree(&ds); return (TclpOpenFileChannel(interp, "__testOpenFileChannel2%__.fil", modeString, permissions)); } else { + Tcl_DStringFree(&ds); return (NULL); } } @@ -4309,10 +4393,18 @@ TestOpenFileChannelProc3(interp, fileName, modeString, permissions) * file, with what modes to create * it? */ { - if (!strcmp("testOpenFileChannel3%.fil", fileName)) { + char *expectname="testOpenFileChannel3%.fil"; + Tcl_DString ds; + + Tcl_DStringInit(&ds); + Tcl_JoinPath(1, &expectname, &ds); + + if (!strcmp(Tcl_DStringValue(&ds), fileName)) { + Tcl_DStringFree(&ds); return (TclpOpenFileChannel(interp, "__testOpenFileChannel3%__.fil", modeString, permissions)); } else { + Tcl_DStringFree(&ds); return (NULL); } } @@ -4535,6 +4627,17 @@ TestChannelCmd(clientData, interp, argc, argv) 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", @@ -5053,3 +5156,296 @@ TestGetIndexFromObjStructObjCmd(dummy, interp, objc, objv) Tcl_WrongNumArgs(interp, 3, objv, NULL); return TCL_OK; } + +/* + *---------------------------------------------------------------------- + * + * TestFilesystemObjCmd -- + * + * This procedure implements the "testfilesystem" command. It is + * used to test Tcl_FSRegister, Tcl_FSUnregister, 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 = Tcl_FSRegister((ClientData)interp, &testReportingFilesystem); + if (res == TCL_OK) { + Tcl_SetResult(interp, "registered", TCL_STATIC); + } else { + Tcl_SetResult(interp, "failed", TCL_STATIC); + } + } else { + res = Tcl_FSUnregister(&testReportingFilesystem); + if (res == TCL_OK) { + Tcl_SetResult(interp, "unregistered", TCL_STATIC); + } else { + Tcl_SetResult(interp, "failed", TCL_STATIC); + } + } + return res; +} + +void +TestReport(cmd, arg1, arg2) + CONST char* cmd; + Tcl_Obj* arg1; + Tcl_Obj* arg2; +{ + Tcl_Interp* interp = (Tcl_Interp*) Tcl_FSData(&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(interp, resultPtr, dirPtr, pattern, types) + 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. */ + Tcl_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(interp) + Tcl_Interp *interp; /* Interpreter for returning volume list. */ +{ + TestReport("listvolumes",NULL,NULL); + return TCL_OK; +} +int +TestReportRenameFile(src, dst) + 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(src, dst) + 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(path) + Tcl_Obj *path; /* Pathname of file to be removed (UTF-8). */ +{ + TestReport("deletefile",path,NULL); + return -1; +} +int +TestReportCreateDirectory(path) + Tcl_Obj *path; /* Pathname of directory to create (UTF-8). */ +{ + TestReport("createdirectory",path,NULL); + return -1; +} +int +TestReportCopyDirectory(src, dst, errorPtr) + Tcl_Obj *src; /* Pathname of directory to be copied + * (UTF-8). */ + Tcl_Obj *dst; /* Pathname of target directory (UTF-8). */ + Tcl_Obj **errorPtr; /* If non-NULL, uninitialized or free + * DString filled with UTF-8 name of file + * causing error. */ +{ + TestReport("copydirectory",src,dst); + return -1; +} +int +TestReportRemoveDirectory(path, recursive, errorPtr) + 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; +} diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 340d004..daab08c 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclUtil.c,v 1.20 2001/07/03 03:33:42 hobbs Exp $ + * RCS: @(#) $Id: tclUtil.c,v 1.21 2001/07/31 19:12:07 vincentdarley Exp $ */ #include "tclInt.h" @@ -2274,103 +2274,3 @@ Tcl_GetNameOfExecutable() { 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); -} diff --git a/library/init.tcl b/library/init.tcl index 4de3ceb..5f7e58f 100644 --- a/library/init.tcl +++ b/library/init.tcl @@ -3,7 +3,7 @@ # Default system startup file for Tcl-based applications. Defines # "unknown" procedure and auto-load facilities. # -# RCS: @(#) $Id: init.tcl,v 1.48 2001/05/28 22:27:08 hobbs Exp $ +# RCS: @(#) $Id: init.tcl,v 1.49 2001/07/31 19:12:07 vincentdarley Exp $ # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. @@ -626,3 +626,82 @@ proc auto_execok name { } } + +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 { + # Depending on the platform, and on the current + # working directory, the directories '.', '..' + # can be returned in various combinations. Anyway, + # if any other file is returned, we must signal an error. + set existing [glob -nocomplain -directory $dest * .*] + eval [list lappend existing] \ + [glob -nocomplain -directory $dest -type hidden * .*] + foreach s $existing { + if {([file tail $s] != ".") && ([file tail $s] != "..")} { + 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 +} diff --git a/mac/tclMacFCmd.c b/mac/tclMacFCmd.c index a83011d..462d48e 100644 --- a/mac/tclMacFCmd.c +++ b/mac/tclMacFCmd.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclMacFCmd.c,v 1.7 1999/10/15 04:47:03 jingham Exp $ + * RCS: @(#) $Id: tclMacFCmd.c,v 1.8 2001/07/31 19:12:07 vincentdarley Exp $ */ #include "tclInt.h" @@ -25,6 +25,7 @@ #include <Script.h> #include <string.h> #include <Finder.h> +#include <Aliases.h> /* * Callback for the file attributes code. @@ -97,6 +98,73 @@ static OSErr MoveRename _ANSI_ARGS_((const FSSpec *srcSpecPtr, static int Pstrequal _ANSI_ARGS_((ConstStr255Param stringA, ConstStr255Param stringB)); +int +TclpObjCreateDirectory(pathPtr) + Tcl_Obj *pathPtr; +{ + return TclpCreateDirectory(Tcl_FSGetTranslatedPath(NULL, pathPtr)); +} + +int +TclpObjDeleteFile(pathPtr) + Tcl_Obj *pathPtr; +{ + return TclpDeleteFile(Tcl_FSGetTranslatedPath(NULL, pathPtr)); +} + +int +TclpObjCopyDirectory(srcPathPtr, destPathPtr, errorPtr) + 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(srcPathPtr, destPathPtr) + Tcl_Obj *srcPathPtr; + Tcl_Obj *destPathPtr; +{ + return TclpCopyFile(Tcl_FSGetTranslatedPath(NULL,srcPathPtr), + Tcl_FSGetTranslatedPath(NULL,destPathPtr)); +} + +int +TclpObjRemoveDirectory(pathPtr, recursive, errorPtr) + 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(srcPathPtr, destPathPtr) + Tcl_Obj *srcPathPtr; + Tcl_Obj *destPathPtr; +{ + return TclpRenameFile(Tcl_FSGetTranslatedPath(NULL,srcPathPtr), + Tcl_FSGetTranslatedPath(NULL,destPathPtr)); +} + /* *--------------------------------------------------------------------------- * @@ -1548,4 +1616,174 @@ TclpListVolumes( 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 means + * resolving all aliases present in the path and replacing the head of + * pathPtr with the absolute case-sensitive path to the last file or + * directory that could be validated in the 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 + * possibly modified in place. + * + *--------------------------------------------------------------------------- + */ + +int +TclpObjNormalizePath(interp, pathPtr, nextCheckpoint) + Tcl_Interp *interp; + Tcl_Obj *pathPtr; + int nextCheckpoint; +{ + #define MAXMACFILENAMELEN 31 /* assumed to be < sizeof(StrFileName) */ + + StrFileName fileName; + StringPtr fileNamePtr; + int fileNameLen,newPathLen; + Handle newPathHandle; + OSErr err; + short vRefNum; + long dirID; + Boolean isDirectory; + Boolean wasAlias; + FSSpec fileSpec; + + Tcl_DString nativeds; + + char cur; + int firstCheckpoint=nextCheckpoint, lastCheckpoint; + int origPathLen; + char *path = Tcl_GetStringFromObj(pathPtr,&origPathLen); + + { + int currDirValid=0; + /* + * check if substring to first ':' after initial + * nextCheckpoint is a valid relative or absolute + * path to a directory, if not we return without + * normalizing anything + */ + + while (1) { + cur = path[nextCheckpoint]; + if (cur == ':' || cur == 0) { + if (cur == ':') { nextCheckpoint++; cur = path[nextCheckpoint]; } /* jump over separator */ + Tcl_UtfToExternalDString(NULL,path,nextCheckpoint,&nativeds); + err = FSpLocationFromPath(Tcl_DStringLength(&nativeds), Tcl_DStringValue(&nativeds), &fileSpec); + Tcl_DStringFree(&nativeds); + if (err == noErr) { + err = FSpGetDirectoryID(&fileSpec, &dirID, &isDirectory); + currDirValid = ((err == noErr) && isDirectory); + vRefNum = fileSpec.vRefNum; + } + break; + } + nextCheckpoint++; + } + + if(!currDirValid) return firstCheckpoint; /* can't determine root dir, bail out */ + } + + /* + * Now vRefNum and dirID point to a valid + * directory, so walk the rest of the path + * ( code adapted from FSpLocationFromPath() ) + */ + + lastCheckpoint=nextCheckpoint; + while (1) { + cur = path[nextCheckpoint]; + if (cur == ':' || cur == 0) { + fileNameLen=nextCheckpoint-lastCheckpoint; + fileNamePtr=fileName; + if(fileNameLen==0) { + if (cur == ':') { + /* + * special case for empty dirname i.e. encountered + * a '::' path component: get parent dir of currDir + */ + fileName[0]=2; + strcpy((char *) fileName + 1, "::"); + lastCheckpoint--; + } else { + /* + * empty filename, i.e. want FSSpec for currDir + */ + fileNamePtr=NULL; + } + } else { + Tcl_UtfToExternalDString(NULL,&path[lastCheckpoint],fileNameLen,&nativeds); + fileNameLen=Tcl_DStringLength(&nativeds); + if(fileNameLen > MAXMACFILENAMELEN) fileNameLen=MAXMACFILENAMELEN; + fileName[0]=fileNameLen; + strncpy((char *) fileName + 1, Tcl_DStringValue(&nativeds), fileNameLen); + Tcl_DStringFree(&nativeds); + } + err=FSMakeFSSpecCompat(vRefNum, dirID, fileNamePtr, &fileSpec); + if(err != noErr) { + if(err != fnfErr) { + /* + * this can if trying to get parent of a root volume via '::' + * or when using an illegal filename + * revert to last checkpoint and stop processing path further + */ + err=FSMakeFSSpecCompat(vRefNum, dirID, NULL, &fileSpec); + if(err != noErr) return firstCheckpoint; /* should never happen, bail out */ + nextCheckpoint=lastCheckpoint; + cur = path[lastCheckpoint]; + } + break; /* arrived at nonexistent file or dir */ + } else { + /* fileSpec could point to an alias, resolve it */ + err = ResolveAliasFile(&fileSpec, true, &isDirectory, &wasAlias); + if (err != noErr || !isDirectory) break; /* fileSpec doesn't point to a dir */ + } + if (cur == 0) break; /* arrived at end of path */ + + /* fileSpec points to possibly nonexisting subdirectory; validate */ + err = FSpGetDirectoryID(&fileSpec, &dirID, &isDirectory); + if (err != noErr || !isDirectory) break; /* fileSpec doesn't point to existing dir */ + vRefNum = fileSpec.vRefNum; + + /* found a new valid subdir in path, continue processing path */ + lastCheckpoint=nextCheckpoint+1; + } + nextCheckpoint++; + } + + /* + * fileSpec now points to a possibly nonexisting file or dir + * inside a valid dir; get full path name to it + */ + + err=FSpPathFromLocation(&fileSpec, &newPathLen, &newPathHandle); + if(err != noErr) return firstCheckpoint; /* should not see any errors here, bail out */ + + HLock(newPathHandle); + Tcl_ExternalToUtfDString(NULL,*newPathHandle,newPathLen,&nativeds); + if (cur != 0) { + /* not at end, append remaining path */ + if ( newPathLen==0 || *(*newPathHandle+(newPathLen-1))!=':') { + Tcl_DStringAppend(&nativeds, ":" , 1); + } + Tcl_DStringAppend(&nativeds, &path[nextCheckpoint+1], strlen(&path[nextCheckpoint+1])); + } + DisposeHandle(newPathHandle); + + fileNameLen=Tcl_DStringLength(&nativeds); + Tcl_SetStringObj(pathPtr,Tcl_DStringValue(&nativeds),fileNameLen); + Tcl_DStringFree(&nativeds); + + return nextCheckpoint+(fileNameLen-origPathLen); +} diff --git a/mac/tclMacFile.c b/mac/tclMacFile.c index b6ae7a2..fd186b7 100644 --- a/mac/tclMacFile.c +++ b/mac/tclMacFile.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclMacFile.c,v 1.9 1999/12/12 22:46:45 hobbs Exp $ + * RCS: @(#) $Id: tclMacFile.c,v 1.10 2001/07/31 19:12:07 vincentdarley Exp $ */ /* @@ -31,12 +31,16 @@ #include <MoreFilesExtras.h> #include <FSpCompat.h> -/* - * Static variables used by the TclpStat function. - */ -static int initialized = false; -static long gmt_offset; -TCL_DECLARE_MUTEX(gmtMutex) +static OSErr FspLocationFromFsPath _ANSI_ARGS_((Tcl_Obj *pathPtr, FSSpec* specPtr)); + +OSErr +FspLocationFromFsPath(pathPtr, specPtr) + Tcl_Obj *pathPtr; + FSSpec* specPtr; +{ + char *native = Tcl_FSGetNativePath(pathPtr); + return FSpLocationFromPath(strlen(native), native, specPtr); +} /* @@ -102,17 +106,16 @@ TclpFindExecutable( /* *---------------------------------------------------------------------- * - * TclpMatchFilesTypes -- + * TclpMatchInDirectory -- * * 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. + * + * 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,21 +123,18 @@ TclpFindExecutable( *---------------------------------------------------------------------- */ 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. */ +TclpMatchInDirectory(interp, resultPtr, pathPtr, pattern, 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. */ + Tcl_GlobTypeData *types; /* Object containing list of acceptable types. + * May be NULL. In particular the directory + * flag is very important. */ { - char *fname, *patternEnd = tail; - char savedChar; + char *fname; int fnameLen, result = TCL_OK; - int baseLength = Tcl_DStringLength(dirPtr); + int baseLength; CInfoPBRec pb; OSErr err; FSSpec dirSpec; @@ -143,26 +143,59 @@ TclpMatchFilesTypes( short itemIndex; Str255 fileName; Tcl_DString fileString; - Tcl_Obj *resultPtr; OSType okType = 0; OSType okCreator = 0; + Tcl_DString dsOrig; + char *fileName2; + + fileName2 = Tcl_FSGetTranslatedPath(interp, pathPtr); + if (fileName2 == NULL) { + return TCL_ERROR; + } + Tcl_DStringInit(&dsOrig); + Tcl_DStringAppend(&dsOrig, fileName2, -1); + baseLength = Tcl_DStringLength(&dsOrig); /* * Make sure that the directory part of the name really is a * directory. */ - Tcl_UtfToExternalDString(NULL, Tcl_DStringValue(dirPtr), - Tcl_DStringLength(dirPtr), &fileString); + Tcl_UtfToExternalDString(NULL, Tcl_DStringValue(&dsOrig), + Tcl_DStringLength(&dsOrig), &fileString); - FSpLocationFromPath(fileString.length, fileString.string, &dirSpec); + err = FSpLocationFromPath(Tcl_DStringLength(&fileString), Tcl_DStringValue(&fileString), &dirSpec); Tcl_DStringFree(&fileString); + if (err == noErr) + err = FSpGetDirectoryID(&dirSpec, &dirID, &isDirectory); + if ((err != noErr) || !isDirectory) { + /* + * Check if we had a relative path (unix style rel path compatibility for glob) + */ + Tcl_DStringFree(&dsOrig); + Tcl_DStringAppend(&dsOrig, ":", 1); + Tcl_DStringAppend(&dsOrig, fileName2, -1); + baseLength = Tcl_DStringLength(&dsOrig); + Tcl_UtfToExternalDString(NULL, Tcl_DStringValue(&dsOrig), + Tcl_DStringLength(&dsOrig), &fileString); + + err = FSpLocationFromPath(Tcl_DStringLength(&fileString), Tcl_DStringValue(&fileString), &dirSpec); + Tcl_DStringFree(&fileString); + if (err == noErr) err = FSpGetDirectoryID(&dirSpec, &dirID, &isDirectory); if ((err != noErr) || !isDirectory) { - return TCL_OK; + 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. */ @@ -172,25 +205,6 @@ TclpMatchFilesTypes( 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); @@ -209,128 +223,112 @@ TclpMatchFilesTypes( } /* - * 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. + * 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(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) && - (TclpAccess(fname, W_OK) != 0)) || - ((types->perm & TCL_GLOB_PERM_X) && - (TclpAccess(fname, X_OK) != 0)) - ) { - typeOk = 0; - } + int typeOk = 1; + Tcl_DStringSetLength(&dsOrig, baseLength); + Tcl_DStringAppend(&dsOrig, Tcl_DStringValue(&fileString), -1); + fname = Tcl_DStringValue(&dsOrig); + fnameLen = Tcl_DStringLength(&dsOrig); + + 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; } - if (typeOk == 1 && types->type != 0) { - struct stat buf; + } 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) && + (TclpAccess(fname, W_OK) != 0)) || + ((types->perm & TCL_GLOB_PERM_X) && + (TclpAccess(fname, X_OK) != 0)) + ) { + typeOk = 0; + } + } + if (typeOk == 1 && types->type != 0) { + struct stat buf; + /* + * We must match at least one flag to be listed + */ + typeOk = 0; + if (TclpLstat(fname, &buf) >= 0) { /* - * We must match at least one flag to be listed + * In order bcdpfls as in 'find -t' */ - typeOk = 0; - if (TclpLstat(fname, &buf) >= 0) { - /* - * In order bcdpfls as in 'find -t' - */ - if ( - ((types->type & TCL_GLOB_TYPE_BLOCK) && - S_ISBLK(buf.st_mode)) || - ((types->type & TCL_GLOB_TYPE_CHAR) && - S_ISCHR(buf.st_mode)) || - ((types->type & TCL_GLOB_TYPE_DIR) && - S_ISDIR(buf.st_mode)) || - ((types->type & TCL_GLOB_TYPE_PIPE) && - S_ISFIFO(buf.st_mode)) || - ((types->type & TCL_GLOB_TYPE_FILE) && - S_ISREG(buf.st_mode)) + if ( + ((types->type & TCL_GLOB_TYPE_BLOCK) && + S_ISBLK(buf.st_mode)) || + ((types->type & TCL_GLOB_TYPE_CHAR) && + S_ISCHR(buf.st_mode)) || + ((types->type & TCL_GLOB_TYPE_DIR) && + S_ISDIR(buf.st_mode)) || + ((types->type & TCL_GLOB_TYPE_PIPE) && + S_ISFIFO(buf.st_mode)) || + ((types->type & TCL_GLOB_TYPE_FILE) && + S_ISREG(buf.st_mode)) #ifdef S_ISLNK - || ((types->type & TCL_GLOB_TYPE_LINK) && - S_ISLNK(buf.st_mode)) + || ((types->type & TCL_GLOB_TYPE_LINK) && + S_ISLNK(buf.st_mode)) #endif #ifdef S_ISSOCK - || ((types->type & TCL_GLOB_TYPE_SOCK) && - S_ISSOCK(buf.st_mode)) + || ((types->type & TCL_GLOB_TYPE_SOCK) && + S_ISSOCK(buf.st_mode)) #endif - ) { - typeOk = 1; - } - } else { - /* Posix error occurred */ + ) { + typeOk = 1; } - } - if (typeOk && ( - ((okType != 0) && (okType != - pb.hFileInfo.ioFlFndrInfo.fdType)) || - ((okCreator != 0) && (okCreator != - pb.hFileInfo.ioFlFndrInfo.fdCreator)))) { - typeOk = 0; - } - } - if (typeOk) { - if ((fnameLen > 1) && (strchr(fname+1, ':') == NULL)) { - Tcl_ListObjAppendElement(interp, resultPtr, - Tcl_NewStringObj(fname+1, fnameLen-1)); } else { - Tcl_ListObjAppendElement(interp, resultPtr, - Tcl_NewStringObj(fname, fnameLen)); + /* Posix error occurred */ } } - } 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; + if (typeOk && ( + ((okType != 0) && (okType != + pb.hFileInfo.ioFlFndrInfo.fdType)) || + ((okCreator != 0) && (okCreator != + pb.hFileInfo.ioFlFndrInfo.fdCreator)))) { + typeOk = 0; + } + } + if (typeOk) { + if ((fnameLen > 1) && (strchr(fname+1, ':') == NULL)) { + Tcl_ListObjAppendElement(interp, resultPtr, + Tcl_NewStringObj(fname+1, fnameLen-1)); + } else { + Tcl_ListObjAppendElement(interp, resultPtr, + Tcl_NewStringObj(fname, fnameLen)); } } } Tcl_DStringFree(&fileString); itemIndex++; } - *patternEnd = savedChar; + Tcl_DStringFree(&dsOrig); 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); -} - /* *---------------------------------------------------------------------- * @@ -352,82 +350,12 @@ TclpAccess( 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; + int ret; + Tcl_Obj *obj = Tcl_NewStringObj(path,-1); + Tcl_IncrRefCount(obj); + ret = TclpObjAccess(obj,mode); + Tcl_DecrRefCount(obj); + return ret; } /* @@ -451,46 +379,12 @@ int 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; + int ret; + Tcl_Obj *obj = Tcl_NewStringObj(dirName,-1); + Tcl_IncrRefCount(obj); + ret = TclpObjChdir(obj); + Tcl_DecrRefCount(obj); + return ret; } /* @@ -728,116 +622,12 @@ TclpStat( 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); + int ret; + Tcl_Obj *obj = Tcl_NewStringObj(path,-1); + Tcl_IncrRefCount(obj); + ret = TclpObjStat(obj,bufPtr); + Tcl_DecrRefCount(obj); + return ret; } /* @@ -994,6 +784,7 @@ TclMacOSErrorToPosixError( return EINVAL; } } + int TclMacChmod( char *path, @@ -1021,3 +812,295 @@ TclMacChmod( return 0; } + +int +TclpObjStat(pathPtr, bufPtr) + Tcl_Obj *pathPtr; + struct stat *bufPtr; +{ + 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". + */ + + bufPtr->st_atime = bufPtr->st_mtime = fpb.ioFlMdDat - TclpGetGMTOffset() + tcl_mac_epoch_offset; + bufPtr->st_ctime = fpb.ioFlCrDat - TclpGetGMTOffset() + tcl_mac_epoch_offset; + } + } + + if (err != noErr) { + errno = TclMacOSErrorToPosixError(err); + } + + return (err == noErr ? 0 : -1); +} + +Tcl_Obj* +TclpObjGetCwd(interp) + 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(pathPtr) + 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(pathPtr, mode) + 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(pathPtr, buf) + Tcl_Obj *pathPtr; + struct stat *buf; +{ + return TclpObjStat(pathPtr, buf); +} + + +/* + *---------------------------------------------------------------------- + * + * TclpTempFileName -- + * + * This function returns a unique filename. + * + * Results: + * Returns a valid Tcl_Obj* with refCount 0, or NULL on failure. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj* +TclpTempFileName() +{ + char fileName[L_tmpnam]; + + if (tmpnam(fileName) == NULL) { /* INTL: Native. */ + return NULL; + } + + return TclpNativeToNormalized((ClientData) fileName); +} + +#ifdef S_IFLNK + +Tcl_Obj* +TclpObjReadlink(pathPtr) + 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 diff --git a/mac/tclMacInit.c b/mac/tclMacInit.c index 53ab851..eb6a066 100644 --- a/mac/tclMacInit.c +++ b/mac/tclMacInit.c @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclMacInit.c,v 1.4 1999/05/11 07:12:16 jingham Exp $ + * RCS: @(#) $Id: tclMacInit.c,v 1.5 2001/07/31 19:12:07 vincentdarley Exp $ */ #include <AppleEvents.h> @@ -132,6 +132,11 @@ static Map cyrillicMap[] = { static int GetFinderFont(int *finderID); +/* Used to store the encoding used for binary files */ +static Tcl_Encoding binaryEncoding = NULL; +/* Has the basic library path encoding issue been fixed */ +static int libraryPathEncodingFixed = 0; + /* *---------------------------------------------------------------------- @@ -393,13 +398,18 @@ TclpInitLibraryPath(argv0) * Based on the locale, determine the encoding of the operating * system and the default encoding for newly opened files. * - * Called at process initialization time. + * Called at process initialization time, and 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). * * Results: * None. * * Side effects: - * The Tcl library path is converted from native encoding to UTF-8. + * The Tcl library path is converted from native encoding to UTF-8, + * on the first call, and the encodings may be changed on first or + * second call. * *--------------------------------------------------------------------------- */ @@ -419,7 +429,9 @@ TclpSetInitialEncodings() } Tcl_SetSystemEncoding(NULL, encoding); - + + if (libraryPathEncodingFixed == 0) { + /* * Until the system encoding was actually set, the library path was * actually in the native multi-byte encoding, and not really UTF-8 @@ -461,13 +473,17 @@ TclpSetInitialEncodings() Tcl_DStringFree(&ds); } } - - /* - * Keep the iso8859-1 encoding preloaded. The IO package uses it for - * gets on a binary channel. - */ - - Tcl_GetEncoding(NULL, "iso8859-1"); + libraryPathEncodingFixed = 1; + } + + /* This is only ever called from the startup thread */ + if (binaryEncoding == NULL) { + /* + * Keep the iso8859-1 encoding preloaded. The IO package uses + * it for gets on a binary channel. + */ + binaryEncoding = Tcl_GetEncoding(NULL, "iso8859-1"); + } } /* diff --git a/mac/tclMacPort.h b/mac/tclMacPort.h index 18b0f2d..1336f87 100644 --- a/mac/tclMacPort.h +++ b/mac/tclMacPort.h @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclMacPort.h,v 1.11 2000/07/26 01:28:24 davidg Exp $ + * RCS: @(#) $Id: tclMacPort.h,v 1.12 2001/07/31 19:12:07 vincentdarley Exp $ */ @@ -219,6 +219,26 @@ extern char **environ; #define HAVE_TM_ZONE + +/* + * If we're using the Metrowerks MSL, we need to convert time_t values from + * the mac epoch to the msl epoch (== unix epoch) by adding the offset from + * <time.mac.h> to mac time_t values, as MSL is using its epoch for file + * access routines such as stat or utime + */ + +#ifdef __MSL__ +#include <time.mac.h> +#ifdef _mac_msl_epoch_offset_ +#define tcl_mac_epoch_offset _mac_msl_epoch_offset_ +#define TCL_MAC_USE_MSL_EPOCH /* flag for TclDate.c */ +#else +#define tcl_mac_epoch_offset 0L +#endif +#else +#define tcl_mac_epoch_offset 0L +#endif + /* * The following macros have trivial definitions, allowing generic code to * address platform-specific issues. diff --git a/mac/tclMacResource.c b/mac/tclMacResource.c index 4362ede..4c06237 100644 --- a/mac/tclMacResource.c +++ b/mac/tclMacResource.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclMacResource.c,v 1.7 1999/08/15 04:54:03 jingham Exp $ + * RCS: @(#) $Id: tclMacResource.c,v 1.8 2001/07/31 19:12:07 vincentdarley Exp $ */ #include <Errors.h> @@ -954,8 +954,7 @@ Tcl_MacSourceObjCmd( } if (objc == 2) { - string = Tcl_GetStringFromObj(objv[1], &length); - return Tcl_EvalFile(interp, string); + return Tcl_FSEvalFile(interp, objv[1]); } /* diff --git a/mac/tclMacTime.c b/mac/tclMacTime.c index 1a2d1ed..25bf08e 100644 --- a/mac/tclMacTime.c +++ b/mac/tclMacTime.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclMacTime.c,v 1.3 1999/03/10 05:52:51 stanton Exp $ + * RCS: @(#) $Id: tclMacTime.c,v 1.4 2001/07/31 19:12:07 vincentdarley Exp $ */ #include "tclInt.h" @@ -26,6 +26,13 @@ static int initalized = false; static unsigned long baseSeconds; static UnsignedWide microOffset; +static int gmt_initialized = false; +static long gmt_offset; +static int gmt_isdst; +TCL_DECLARE_MUTEX(gmtMutex) + +static int gmt_lastGetDateUseGMT = 0; + /* * Prototypes for procedures that are private to this file: */ @@ -36,6 +43,43 @@ static void SubtractUnsignedWide _ANSI_ARGS_((UnsignedWide *x, /* *----------------------------------------------------------------------------- * + * TclpGetGMTOffset -- + * + * This procedure gets the offset seconds that needs to be _added_ to tcl time + * in seconds (i.e. GMT time) to get local time needed as input to various + * Mac OS APIs, to convert Mac OS API output to tcl time, _subtract_ this value. + * + * Results: + * Number of seconds separating GMT time and mac. + * + * Side effects: + * None. + * + *----------------------------------------------------------------------------- + */ + +long +TclpGetGMTOffset() +{ + if (gmt_initialized == false) { + MachineLocation loc; + + Tcl_MutexLock(&gmtMutex); + ReadLocation(&loc); + gmt_offset = loc.u.gmtDelta & 0x00ffffff; + if (gmt_offset & 0x00800000) { + gmt_offset = gmt_offset | 0xff000000; + } + gmt_isdst=(loc.u.dlsDelta < 0); + gmt_initialized = true; + Tcl_MutexUnlock(&gmtMutex); + } + return (gmt_offset); +} + +/* + *----------------------------------------------------------------------------- + * * TclpGetSeconds -- * * This procedure returns the number of seconds from the epoch. On @@ -57,21 +101,9 @@ unsigned long TclpGetSeconds() { unsigned long seconds; - MachineLocation loc; - long int offset; - - ReadLocation(&loc); - offset = loc.u.gmtDelta & 0x00ffffff; - if (offset & 0x00800000) { - offset = offset | 0xff000000; - } - if (ReadDateTime(&seconds) == noErr) { - return (seconds - offset); - } else { - panic("Can't get time."); - return 0; - } + GetDateTime(&seconds); + return (seconds - TclpGetGMTOffset() + tcl_mac_epoch_offset); } /* @@ -123,22 +155,15 @@ int TclpGetTimeZone ( unsigned long currentTime) /* Ignored on Mac. */ { - MachineLocation loc; - long int offset; - - ReadLocation(&loc); - offset = loc.u.gmtDelta & 0x00ffffff; - if (offset & 0x00700000) { - offset |= 0xff000000; - } + long offset; /* * Convert the Mac offset from seconds to minutes and * add an hour if we have daylight savings time. */ - offset = -offset; + offset = -TclpGetGMTOffset(); offset /= 60; - if (loc.u.dlsDelta < 0) { + if (gmt_isdst) { offset += 60; } @@ -172,24 +197,11 @@ TclpGetTime( #endif if (initalized == false) { - MachineLocation loc; - long int offset; - - ReadLocation(&loc); - offset = loc.u.gmtDelta & 0x00ffffff; - if (offset & 0x00800000) { - offset = offset | 0xff000000; - } - if (ReadDateTime(&baseSeconds) != noErr) { - /* - * This should never happen! - */ - return; - } + GetDateTime(&baseSeconds); /* * Remove the local offset that ReadDateTime() adds. */ - baseSeconds -= offset; + baseSeconds -= TclpGetGMTOffset() - tcl_mac_epoch_offset; Microseconds(µOffset); initalized = true; } @@ -246,25 +258,16 @@ TclpGetDate( { const time_t *tp = (const time_t *)time; DateTimeRec dtr; - MachineLocation loc; - long int offset; + unsigned long offset=0L; static struct tm statictime; static const short monthday[12] = {0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334}; - - ReadLocation(&loc); + + if(useGMT) + SecondsToDate(*tp - tcl_mac_epoch_offset, &dtr); + else + SecondsToDate(*tp + TclpGetGMTOffset() - tcl_mac_epoch_offset, &dtr); - if (useGMT) { - SecondsToDate(*tp, &dtr); - } else { - offset = loc.u.gmtDelta & 0x00ffffff; - if (offset & 0x00700000) { - offset |= 0xff000000; - } - - SecondsToDate(*tp + offset, &dtr); - } - statictime.tm_sec = dtr.second; statictime.tm_min = dtr.minute; statictime.tm_hour = dtr.hour; @@ -277,7 +280,11 @@ TclpGetDate( if (1 < statictime.tm_mon && !(statictime.tm_year & 3)) { ++statictime.tm_yday; } - statictime.tm_isdst = loc.u.dlsDelta; + if(useGMT) + statictime.tm_isdst = 0; + else + statictime.tm_isdst = gmt_isdst; + gmt_lastGetDateUseGMT=useGMT; /* hack to make TclpGetTZName below work */ return(&statictime); } diff --git a/tests/cmdAH.test b/tests/cmdAH.test index 156e1fd..51bad09 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -10,13 +10,15 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: cmdAH.test,v 1.13 2001/07/06 09:29:36 dkf Exp $ +# RCS: @(#) $Id: cmdAH.test,v 1.14 2001/07/31 19:12:07 vincentdarley Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } +tcltest::testConstraint testchmod [string equal testchmod [info commands testchmod]] + global env set cmdAHwd [pwd] catch {set platform [testgetplatform]} @@ -166,11 +168,13 @@ test cmdAH-5.1 {Tcl_FileObjCmd} { } {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}} +} {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"}} - +test cmdAH-5.4 {Tcl_FileObjCmd} { + list [catch {file exists ""} msg] $msg +} {0 0} #volume @@ -1000,38 +1004,39 @@ testsetplatform $platform # readable +makeFile abcde gorp.file +makeDirectory dir.file + 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} { +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 0444 gorp.file -test cmdAH-16.2 {Tcl_FileObjCmd: readable} { +test cmdAH-16.2 {Tcl_FileObjCmd: readable} {testchmod} { file readable gorp.file } 1 testchmod 0333 gorp.file -test cmdAH-16.3 {Tcl_FileObjCmd: readable} {unixOnly notRoot} { +test cmdAH-16.3 {Tcl_FileObjCmd: readable} {unixOnly notRoot testchmod} { file reada gorp.file } 0 # writable -test cmdAH-17.1 {Tcl_FileObjCmd: 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 0555 gorp.file -test cmdAH-17.2 {Tcl_FileObjCmd: writable} {notRoot} { +test cmdAH-17.2 {Tcl_FileObjCmd: writable} {notRoot testchmod} { file writable gorp.file } 0 testchmod 0222 gorp.file -test cmdAH-17.3 {Tcl_FileObjCmd: writable} { +test cmdAH-17.3 {Tcl_FileObjCmd: writable} {testchmod} { file writable gorp.file } 1 +} # executable @@ -1039,13 +1044,13 @@ file delete -force dir.file gorp.file file mkdir dir.file makeFile abcde gorp.file -test cmdAH-18.1 {Tcl_FileObjCmd: executable} { +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} { +test cmdAH-18.2 {Tcl_FileObjCmd: executable} {testchmod} { file executable gorp.file } 0 -test cmdAH-18.3 {Tcl_FileObjCmd: executable} {unixOnly} { +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,14 +1058,14 @@ test cmdAH-18.3 {Tcl_FileObjCmd: executable} {unixOnly} { file exe gorp.file } 1 -test cmdAH-18.4 {Tcl_FileObjCmd: executable} {macOnly} { +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} { +test cmdAH-18.5 {Tcl_FileObjCmd: executable} {pcOnly testchmod} { # On pc, must be a .exe, .com, etc. set x [file exe gorp.file] @@ -1069,7 +1074,7 @@ test cmdAH-18.5 {Tcl_FileObjCmd: executable} {pcOnly} { file delete gorp.exe set x } {0 1} -test cmdAH-18.6 {Tcl_FileObjCmd: executable} { +test cmdAH-18.6 {Tcl_FileObjCmd: executable} {testchmod} { # Directories are always executable. file exe dir.file @@ -1078,7 +1083,6 @@ test cmdAH-18.6 {Tcl_FileObjCmd: executable} { file delete -force dir.file file delete gorp.file file delete link.file -} # exists @@ -1243,6 +1247,39 @@ test cmdAH-23.6 {Tcl_FileObjCmd: lstat errors} { } {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,25 +1504,25 @@ test cmdAH-29.5 {Tcl_FileObjCmd: type} { 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}} +} {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, owned, pathtype, readable, readlink, rename, rootname, size, split, stat, tail, type, volumes, or writable}} +} {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, owned, pathtype, readable, readlink, rename, rootname, size, split, stat, tail, type, volumes, or writable}} +} {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, owned, pathtype, readable, readlink, rename, rootname, size, split, stat, tail, type, volumes, or writable}} +} {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, owned, pathtype, readable, readlink, rename, rootname, size, split, stat, tail, type, volumes, or writable}} +} {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, owned, pathtype, readable, readlink, rename, rootname, size, split, stat, tail, type, volumes, or writable}} +} {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, owned, pathtype, readable, readlink, rename, rootname, size, split, stat, tail, type, volumes, or writable}} +} {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}} diff --git a/tests/event.test b/tests/event.test index 9d2e5fd..44d6610 100644 --- a/tests/event.test +++ b/tests/event.test @@ -9,7 +9,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: event.test,v 1.12 2001/06/27 15:34:16 dkf Exp $ +# RCS: @(#) $Id: event.test,v 1.13 2001/07/31 19:12:07 vincentdarley Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -170,6 +170,7 @@ test event-5.1 {Tcl_BackgroundError, HandleBgErrors procedures} { set x {} update idletasks rename bgerror {} + regsub -all [file join {} non_existent] $x "non_existent" x set x } {{{a simple error} {a simple error while executing diff --git a/tests/fCmd.test b/tests/fCmd.test index 2e8d383..c9e4ca0 100644 --- a/tests/fCmd.test +++ b/tests/fCmd.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: fCmd.test,v 1.9 2000/09/29 01:12:14 hobbs Exp $ +# RCS: @(#) $Id: fCmd.test,v 1.10 2001/07/31 19:12:07 vincentdarley Exp $ # if {[lsearch [namespace children] ::tcltest] == -1} { @@ -18,21 +18,8 @@ if {[lsearch [namespace children] ::tcltest] == -1} { 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 -} +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 {} @@ -74,7 +61,7 @@ proc openup {path} { testchmod 777 $path if {[file isdirectory $path]} { catch { - foreach p [glob [file join $path *]] { + foreach p [glob -directory $path *] { openup $p } } @@ -82,10 +69,15 @@ proc openup {path} { } proc cleanup {args} { - foreach p ". $args" { + if {$::tcl_platform(platform) == "macintosh"} { + set wd [list :] + } else { + set wd [list .] + } + foreach p [concat $wd $args] { set x "" catch { - set x [glob [file join $p tf*] [file join $p td*]] + set x [glob -directory $p tf* td*] } foreach file $x { if {[catch {file delete -force -- $file}]} { @@ -299,7 +291,7 @@ test fCmd-4.10 {TclFileMakeDirsCmd: exists, is dir} {notRoot} { list $x [file exist td1] } {1 1} test fCmd-4.11 {TclFileMakeDirsCmd: doesn't exist: errno != ENOENT} \ - {unixOnly notRoot} { + {unixOnly notRoot testchmod} { cleanup file mkdir td1/td2/td3 testchmod 000 td1/td2 @@ -309,8 +301,8 @@ test fCmd-4.11 {TclFileMakeDirsCmd: doesn't exist: errno != ENOENT} \ } {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}} + 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,7 +407,7 @@ test fCmd-6.5 {CopyRenameOneFile: lstat(target) != 0} {notRoot} { file rename tf1 tf2 glob tf* } {tf2} -test fCmd-6.6 {CopyRenameOneFile: errno != ENOENT} {unixOnly notRoot} { +test fCmd-6.6 {CopyRenameOneFile: errno != ENOENT} {unixOnly notRoot testchmod} { cleanup file mkdir td1 testchmod 000 td1 @@ -676,7 +668,7 @@ test fCmd-9.2 {file rename: comprehensive: source doesn't exist} {notRoot} { 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} { +test fCmd-9.3 {file rename: comprehensive: file to new name} {notRoot testchmod} { cleanup createfile tf1 createfile tf2 @@ -685,7 +677,7 @@ test fCmd-9.3 {file rename: comprehensive: file to new name} {notRoot} { 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} { +test fCmd-9.4 {file rename: comprehensive: dir to new name} {unixOrPc notRoot testchmod} { cleanup file mkdir td1 td2 testchmod 555 td2 @@ -693,7 +685,7 @@ test fCmd-9.4 {file rename: comprehensive: dir to new name} {unixOrPc notRoot} { 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} { +test fCmd-9.5 {file rename: comprehensive: file to self} {notRoot testchmod} { cleanup createfile tf1 tf1 createfile tf2 tf2 @@ -702,7 +694,7 @@ test fCmd-9.5 {file rename: comprehensive: file to self} {notRoot} { 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} { +test fCmd-9.6 {file rename: comprehensive: dir to self} {notRoot unixOrPc testchmod} { cleanup file mkdir td1 file mkdir td2 @@ -711,7 +703,7 @@ test fCmd-9.6 {file rename: comprehensive: dir to self} {notRoot unixOrPc} { 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} { +test fCmd-9.7 {file rename: comprehensive: file to existing file} {notRoot testchmod} { cleanup createfile tf1 createfile tf2 @@ -734,7 +726,7 @@ test fCmd-9.7 {file rename: comprehensive: file to existing file} {notRoot} { 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} { +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,7 +764,7 @@ test fCmd-9.8 {file rename: comprehensive: dir to empty dir} {notRoot} { 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} { +test fCmd-9.9 {file rename: comprehensive: dir to non-empty dir} {notRoot testchmod} { cleanup file mkdir tds1 file mkdir tds2 @@ -790,7 +782,7 @@ test fCmd-9.9 {file rename: comprehensive: dir to non-empty dir} {notRoot} { } 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} { +test fCmd-9.10 {file rename: comprehensive: file to new name and dir} {notRoot testchmod} { cleanup createfile tf1 createfile tf2 @@ -798,10 +790,10 @@ test fCmd-9.10 {file rename: comprehensive: file to new name and dir} {notRoot} 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*]]] \ + 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} { +test fCmd-9.11 {file rename: comprehensive: dir to new name and dir} {notRoot testchmod} { cleanup file mkdir td1 file mkdir td2 @@ -816,10 +808,10 @@ test fCmd-9.11 {file rename: comprehensive: dir to new name and dir} {notRoot} { } else { set w4 0 } - list [lsort [glob td*]] [lsort [glob [file join td3 t*]]] \ + 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} { +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,7 +855,7 @@ test fCmd-10.1 {file copy: comprehensive: source doesn't exist} {notRoot} { 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} { +test fCmd-10.2 {file copy: comprehensive: file to new name} {notRoot testchmod} { cleanup createfile tf1 tf1 createfile tf2 tf2 @@ -872,22 +864,22 @@ test fCmd-10.2 {file copy: comprehensive: file to new name} {notRoot} { 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} { +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 [file join td3 t*]] \ - [glob [file join td4 t*]] [file writable td3] [file writable 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} { +test fCmd-10.4 {file copy: comprehensive: file to existing file} {notRoot testchmod} { cleanup createfile tf1 createfile tf2 @@ -910,7 +902,7 @@ test fCmd-10.4 {file copy: comprehensive: file to existing file} {notRoot} { 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} { +test fCmd-10.5 {file copy: comprehensive: dir to empty dir} {notRoot testchmod} { cleanup file mkdir td1 file mkdir [file join td2 td1] @@ -936,7 +928,7 @@ test fCmd-10.5 {file copy: comprehensive: dir to empty dir} {notRoot} { 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} { + {notRoot unixOrPc testchmod} { cleanup file mkdir tds1 file mkdir tds2 @@ -947,7 +939,7 @@ test fCmd-10.6 {file copy: comprehensive: dir to non-empty dir} \ 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} { +test fCmd-10.7 {file rename: comprehensive: file to new name and dir} {notRoot testchmod} { cleanup createfile tf1 createfile tf2 @@ -955,11 +947,11 @@ test fCmd-10.7 {file rename: comprehensive: file to new name and dir} {notRoot} 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*]]] \ + 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} { + {notRoot unixOrPc testchmod} { cleanup file mkdir td1 file mkdir td2 @@ -967,7 +959,7 @@ test fCmd-10.8 {file rename: comprehensive: dir to new name and dir} \ 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*]]] \ + 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,7 +2103,8 @@ test fCmd-26.3 { TclDeleteFilesCmd : delete dangling symlink} {unixOnly notRoot} set result } {1} -test fCmd-27.2 {TclFileAttrsCmd - Tcl_TranslateFileName fails} { +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} {}} diff --git a/tests/fileName.test b/tests/fileName.test index eb0b502..318b3ab 100644 --- a/tests/fileName.test +++ b/tests/fileName.test @@ -10,885 +10,883 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: fileName.test,v 1.10 2001/05/15 21:23:53 hobbs Exp $ +# RCS: @(#) $Id: fileName.test,v 1.11 2001/07/31 19:12:07 vincentdarley Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 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 -} +tcltest::testConstraint testsetplatform [string equal testsetplatform [info commands testsetplatform]] +tcltest::testConstraint testtranslatefilename [string equal testtranslatefilename [info commands testtranslatefilename]] global env -set platform [testgetplatform] +if {[tcltest::testConstraint testsetplatform]} { + set platform [testgetplatform] +} -test filename-1.1 {Tcl_GetPathType: unix} { +test filename-1.1 {Tcl_GetPathType: unix} {testsetplatform} { testsetplatform unix file pathtype / } absolute -test filename-1.2 {Tcl_GetPathType: unix} { +test filename-1.2 {Tcl_GetPathType: unix} {testsetplatform} { testsetplatform unix file pathtype /foo } absolute -test filename-1.3 {Tcl_GetPathType: unix} { +test filename-1.3 {Tcl_GetPathType: unix} {testsetplatform} { testsetplatform unix file pathtype foo } relative -test filename-1.4 {Tcl_GetPathType: unix} { +test filename-1.4 {Tcl_GetPathType: unix} {testsetplatform} { testsetplatform unix file pathtype c:/foo } relative -test filename-1.5 {Tcl_GetPathType: unix} { +test filename-1.5 {Tcl_GetPathType: unix} {testsetplatform} { testsetplatform unix file pathtype ~ } absolute -test filename-1.6 {Tcl_GetPathType: unix} { +test filename-1.6 {Tcl_GetPathType: unix} {testsetplatform} { testsetplatform unix file pathtype ~/foo } absolute -test filename-1.7 {Tcl_GetPathType: unix} { +test filename-1.7 {Tcl_GetPathType: unix} {testsetplatform} { testsetplatform unix file pathtype ~foo } absolute -test filename-1.8 {Tcl_GetPathType: unix} { +test filename-1.8 {Tcl_GetPathType: unix} {testsetplatform} { testsetplatform unix file pathtype ./~foo } relative -test filename-2.1 {Tcl_GetPathType: mac, denerate names} { +test filename-2.1 {Tcl_GetPathType: mac, denerate names} {testsetplatform} { testsetplatform mac file pathtype / } relative -test filename-2.2 {Tcl_GetPathType: mac, denerate names} { +test filename-2.2 {Tcl_GetPathType: mac, denerate names} {testsetplatform} { testsetplatform mac file pathtype /. } relative -test filename-2.3 {Tcl_GetPathType: mac, denerate names} { +test filename-2.3 {Tcl_GetPathType: mac, denerate names} {testsetplatform} { testsetplatform mac file pathtype /.. } relative -test filename-2.4 {Tcl_GetPathType: mac, denerate names} { +test filename-2.4 {Tcl_GetPathType: mac, denerate names} {testsetplatform} { testsetplatform mac file pathtype //.// } relative -test filename-2.5 {Tcl_GetPathType: mac, denerate names} { +test filename-2.5 {Tcl_GetPathType: mac, denerate names} {testsetplatform} { testsetplatform mac file pathtype //.//../. } relative -test filename-2.6 {Tcl_GetPathType: mac, tilde names} { +test filename-2.6 {Tcl_GetPathType: mac, tilde names} {testsetplatform} { testsetplatform mac file pathtype ~ } absolute -test filename-2.7 {Tcl_GetPathType: mac, tilde names} { +test filename-2.7 {Tcl_GetPathType: mac, tilde names} {testsetplatform} { testsetplatform mac file pathtype ~: } absolute -test filename-2.8 {Tcl_GetPathType: mac, tilde names} { +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} { +test filename-2.9 {Tcl_GetPathType: mac, tilde names} {testsetplatform} { testsetplatform mac file pathtype ~/ } absolute -test filename-2.10 {Tcl_GetPathType: mac, tilde names} { +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} { +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} { +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} { +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} { +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} { +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} { +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} { +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} { +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} { +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} { +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} { +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} { +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} { +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} { +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} { +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} { +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} { +test filename-2.27 {Tcl_GetPathType: mac, mac-style names} {testsetplatform} { testsetplatform mac file pathtype foo } relative -test filename-3.1 {Tcl_GetPathType: windows} { +test filename-3.1 {Tcl_GetPathType: windows} {testsetplatform} { testsetplatform windows file pathtype / } volumerelative -test filename-3.2 {Tcl_GetPathType: windows} { +test filename-3.2 {Tcl_GetPathType: windows} {testsetplatform} { testsetplatform windows file pathtype \\ } volumerelative -test filename-3.3 {Tcl_GetPathType: windows} { +test filename-3.3 {Tcl_GetPathType: windows} {testsetplatform} { testsetplatform windows file pathtype /foo } volumerelative -test filename-3.4 {Tcl_GetPathType: windows} { +test filename-3.4 {Tcl_GetPathType: windows} {testsetplatform} { testsetplatform windows file pathtype \\foo } volumerelative -test filename-3.5 {Tcl_GetPathType: windows} { +test filename-3.5 {Tcl_GetPathType: windows} {testsetplatform} { testsetplatform windows file pathtype c:/ } absolute -test filename-3.6 {Tcl_GetPathType: windows} { +test filename-3.6 {Tcl_GetPathType: windows} {testsetplatform} { testsetplatform windows file pathtype c:\\ } absolute -test filename-3.7 {Tcl_GetPathType: windows} { +test filename-3.7 {Tcl_GetPathType: windows} {testsetplatform} { testsetplatform windows file pathtype c:/foo } absolute -test filename-3.8 {Tcl_GetPathType: windows} { +test filename-3.8 {Tcl_GetPathType: windows} {testsetplatform} { testsetplatform windows file pathtype c:\\foo } absolute -test filename-3.9 {Tcl_GetPathType: windows} { +test filename-3.9 {Tcl_GetPathType: windows} {testsetplatform} { testsetplatform windows file pathtype c: } volumerelative -test filename-3.10 {Tcl_GetPathType: windows} { +test filename-3.10 {Tcl_GetPathType: windows} {testsetplatform} { testsetplatform windows file pathtype c:foo } volumerelative -test filename-3.11 {Tcl_GetPathType: windows} { +test filename-3.11 {Tcl_GetPathType: windows} {testsetplatform} { testsetplatform windows file pathtype foo } relative -test filename-3.12 {Tcl_GetPathType: windows} { +test filename-3.12 {Tcl_GetPathType: windows} {testsetplatform} { testsetplatform windows file pathtype //foo/bar } absolute -test filename-3.13 {Tcl_GetPathType: windows} { +test filename-3.13 {Tcl_GetPathType: windows} {testsetplatform} { testsetplatform windows file pathtype ~foo } absolute -test filename-3.14 {Tcl_GetPathType: windows} { +test filename-3.14 {Tcl_GetPathType: windows} {testsetplatform} { testsetplatform windows file pathtype ~ } absolute -test filename-3.15 {Tcl_GetPathType: windows} { +test filename-3.15 {Tcl_GetPathType: windows} {testsetplatform} { testsetplatform windows file pathtype ~/foo } absolute -test filename-3.16 {Tcl_GetPathType: windows} { +test filename-3.16 {Tcl_GetPathType: windows} {testsetplatform} { testsetplatform windows file pathtype ./~foo } relative -test filename-4.1 {Tcl_SplitPath: unix} { +test filename-4.1 {Tcl_SplitPath: unix} {testsetplatform} { testsetplatform unix file split / } {/} -test filename-4.2 {Tcl_SplitPath: unix} { +test filename-4.2 {Tcl_SplitPath: unix} {testsetplatform} { testsetplatform unix file split /foo } {/ foo} -test filename-4.3 {Tcl_SplitPath: unix} { +test filename-4.3 {Tcl_SplitPath: unix} {testsetplatform} { testsetplatform unix file split /foo/bar } {/ foo bar} -test filename-4.4 {Tcl_SplitPath: unix} { +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} { +test filename-4.5 {Tcl_SplitPath: unix} {testsetplatform} { testsetplatform unix file split foo/bar } {foo bar} -test filename-4.6 {Tcl_SplitPath: unix} { +test filename-4.6 {Tcl_SplitPath: unix} {testsetplatform} { testsetplatform unix file split ./foo/bar } {. foo bar} -test filename-4.7 {Tcl_SplitPath: unix} { +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} { +test filename-4.8 {Tcl_SplitPath: unix} {testsetplatform} { testsetplatform unix file split ../foo/bar } {.. foo bar} -test filename-4.9 {Tcl_SplitPath: unix} { +test filename-4.9 {Tcl_SplitPath: unix} {testsetplatform} { testsetplatform unix file split {} } {} -test filename-4.10 {Tcl_SplitPath: unix} { +test filename-4.10 {Tcl_SplitPath: unix} {testsetplatform} { testsetplatform unix file split . } {.} -test filename-4.11 {Tcl_SplitPath: unix} { +test filename-4.11 {Tcl_SplitPath: unix} {testsetplatform} { testsetplatform unix file split ../ } {..} -test filename-4.12 {Tcl_SplitPath: unix} { +test filename-4.12 {Tcl_SplitPath: unix} {testsetplatform} { testsetplatform unix file split ../.. } {.. ..} -test filename-4.13 {Tcl_SplitPath: unix} { +test filename-4.13 {Tcl_SplitPath: unix} {testsetplatform} { testsetplatform unix file split //foo } {/ foo} -test filename-4.14 {Tcl_SplitPath: unix} { +test filename-4.14 {Tcl_SplitPath: unix} {testsetplatform} { testsetplatform unix file split foo//bar } {foo bar} -test filename-4.15 {Tcl_SplitPath: unix} { +test filename-4.15 {Tcl_SplitPath: unix} {testsetplatform} { testsetplatform unix file split ~foo } {~foo} -test filename-4.16 {Tcl_SplitPath: unix} { +test filename-4.16 {Tcl_SplitPath: unix} {testsetplatform} { testsetplatform unix file split ~foo/~bar } {~foo ./~bar} -test filename-4.17 {Tcl_SplitPath: unix} { +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} { +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} { +test filename-5.1 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split a:b } {a: b} -test filename-5.2 {Tcl_SplitPath: mac} { +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} { +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} { +test filename-5.4 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split a: } {a:} -test filename-5.5 {Tcl_SplitPath: mac} { +test filename-5.5 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split a:: } {a: ::} -test filename-5.6 {Tcl_SplitPath: mac} { +test filename-5.6 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split a::: } {a: :: ::} -test filename-5.7 {Tcl_SplitPath: mac} { +test filename-5.7 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split :a } {a} -test filename-5.8 {Tcl_SplitPath: mac} { +test filename-5.8 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split :a:: } {a ::} -test filename-5.9 {Tcl_SplitPath: mac} { +test filename-5.9 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split : } {:} -test filename-5.10 {Tcl_SplitPath: mac} { +test filename-5.10 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split :: } {::} -test filename-5.11 {Tcl_SplitPath: mac} { +test filename-5.11 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split ::: } {:: ::} -test filename-5.12 {Tcl_SplitPath: mac} { +test filename-5.12 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split a:::b } {a: :: :: b} -test filename-5.13 {Tcl_SplitPath: mac} { +test filename-5.13 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split /a:b } {/a: b} -test filename-5.14 {Tcl_SplitPath: mac} { +test filename-5.14 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split ~: } {~:} -test filename-5.15 {Tcl_SplitPath: mac} { +test filename-5.15 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split ~/: } {~/:} -test filename-5.16 {Tcl_SplitPath: mac} { +test filename-5.16 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split ~:foo } {~: foo} -test filename-5.17 {Tcl_SplitPath: mac} { +test filename-5.17 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split ~/foo } {~: foo} -test filename-5.18 {Tcl_SplitPath: mac} { +test filename-5.18 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split ~foo: } {~foo:} -test filename-5.19 {Tcl_SplitPath: mac} { +test filename-5.19 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split a:~foo } {a: :~foo} -test filename-5.20 {Tcl_SplitPath: mac} { +test filename-5.20 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split / } {:/} -test filename-5.21 {Tcl_SplitPath: mac} { +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} { +test filename-5.22 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split /foo } {foo:} -test filename-5.23 {Tcl_SplitPath: mac} { +test filename-5.23 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split /a/b } {a: b} -test filename-5.24 {Tcl_SplitPath: mac} { +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} { +test filename-5.25 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split a/b } {a b} -test filename-5.26 {Tcl_SplitPath: mac} { +test filename-5.26 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split ./foo/bar } {: foo bar} -test filename-5.27 {Tcl_SplitPath: mac} { +test filename-5.27 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split ../foo/bar } {:: foo bar} -test filename-5.28 {Tcl_SplitPath: mac} { +test filename-5.28 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split {} } {} -test filename-5.29 {Tcl_SplitPath: mac} { +test filename-5.29 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split . } {:} -test filename-5.30 {Tcl_SplitPath: mac} { +test filename-5.30 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split ././ } {: :} -test filename-5.31 {Tcl_SplitPath: mac} { +test filename-5.31 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split ././. } {: : :} -test filename-5.32 {Tcl_SplitPath: mac} { +test filename-5.32 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split ../ } {::} -test filename-5.33 {Tcl_SplitPath: mac} { +test filename-5.33 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split .. } {::} -test filename-5.34 {Tcl_SplitPath: mac} { +test filename-5.34 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split ../.. } {:: ::} -test filename-5.35 {Tcl_SplitPath: mac} { +test filename-5.35 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split //foo } {foo:} -test filename-5.36 {Tcl_SplitPath: mac} { +test filename-5.36 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split foo//bar } {foo bar} -test filename-5.37 {Tcl_SplitPath: mac} { +test filename-5.37 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split ~foo } {~foo:} -test filename-5.38 {Tcl_SplitPath: mac} { +test filename-5.38 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split ~ } {~:} -test filename-5.39 {Tcl_SplitPath: mac} { +test filename-5.39 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split foo } {foo} -test filename-5.40 {Tcl_SplitPath: mac} { +test filename-5.40 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split ~/ } {~:} -test filename-5.41 {Tcl_SplitPath: mac} { +test filename-5.41 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split ~foo/~bar } {~foo: :~bar} -test filename-5.42 {Tcl_SplitPath: mac} { +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} { +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} { +test filename-5.44 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split a/../b } {a :: b} -test filename-5.45 {Tcl_SplitPath: mac} { +test filename-5.45 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split a/../../b } {a :: :: b} -test filename-5.46 {Tcl_SplitPath: mac} { +test filename-5.46 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split a/.././../b } {a :: : :: b} -test filename-5.47 {Tcl_SplitPath: mac} { +test filename-5.47 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split /../bar } {bar:} -test filename-5.48 {Tcl_SplitPath: mac} { +test filename-5.48 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split /./bar } {bar:} -test filename-5.49 {Tcl_SplitPath: mac} { +test filename-5.49 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split //.//.././bar } {bar:} -test filename-5.50 {Tcl_SplitPath: mac} { +test filename-5.50 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split /.. } {:/..} -test filename-5.51 {Tcl_SplitPath: mac} { +test filename-5.51 {Tcl_SplitPath: mac} {testsetplatform} { testsetplatform mac file split //.//.././ } {://.//.././} -test filename-6.1 {Tcl_SplitPath: win} { +test filename-6.1 {Tcl_SplitPath: win} {testsetplatform} { testsetplatform win file split / } {/} -test filename-6.2 {Tcl_SplitPath: win} { +test filename-6.2 {Tcl_SplitPath: win} {testsetplatform} { testsetplatform win file split /foo } {/ foo} -test filename-6.3 {Tcl_SplitPath: win} { +test filename-6.3 {Tcl_SplitPath: win} {testsetplatform} { testsetplatform win file split /foo/bar } {/ foo bar} -test filename-6.4 {Tcl_SplitPath: win} { +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} { +test filename-6.5 {Tcl_SplitPath: win} {testsetplatform} { testsetplatform win file split foo/bar } {foo bar} -test filename-6.6 {Tcl_SplitPath: win} { +test filename-6.6 {Tcl_SplitPath: win} {testsetplatform} { testsetplatform win file split ./foo/bar } {. foo bar} -test filename-6.7 {Tcl_SplitPath: win} { +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} { +test filename-6.8 {Tcl_SplitPath: win} {testsetplatform} { testsetplatform win file split ../foo/bar } {.. foo bar} -test filename-6.9 {Tcl_SplitPath: win} { +test filename-6.9 {Tcl_SplitPath: win} {testsetplatform} { testsetplatform win file split {} } {} -test filename-6.10 {Tcl_SplitPath: win} { +test filename-6.10 {Tcl_SplitPath: win} {testsetplatform} { testsetplatform win file split . } {.} -test filename-6.11 {Tcl_SplitPath: win} { +test filename-6.11 {Tcl_SplitPath: win} {testsetplatform} { testsetplatform win file split ../ } {..} -test filename-6.12 {Tcl_SplitPath: win} { +test filename-6.12 {Tcl_SplitPath: win} {testsetplatform} { testsetplatform win file split ../.. } {.. ..} -test filename-6.13 {Tcl_SplitPath: win} { +test filename-6.13 {Tcl_SplitPath: win} {testsetplatform} { testsetplatform win file split //foo } {/ foo} -test filename-6.14 {Tcl_SplitPath: win} { +test filename-6.14 {Tcl_SplitPath: win} {testsetplatform} { testsetplatform win file split foo//bar } {foo bar} -test filename-6.15 {Tcl_SplitPath: win} { +test filename-6.15 {Tcl_SplitPath: win} {testsetplatform} { testsetplatform win file split /\\/foo//bar } {//foo/bar} -test filename-6.16 {Tcl_SplitPath: win} { +test filename-6.16 {Tcl_SplitPath: win} {testsetplatform} { testsetplatform win file split /\\/foo//bar } {//foo/bar} -test filename-6.17 {Tcl_SplitPath: win} { +test filename-6.17 {Tcl_SplitPath: win} {testsetplatform} { testsetplatform win file split /\\/foo//bar } {//foo/bar} -test filename-6.18 {Tcl_SplitPath: win} { +test filename-6.18 {Tcl_SplitPath: win} {testsetplatform} { testsetplatform win file split \\\\foo\\bar } {//foo/bar} -test filename-6.19 {Tcl_SplitPath: win} { +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} { +test filename-6.20 {Tcl_SplitPath: win} {testsetplatform} { testsetplatform win file split c:/foo } {c:/ foo} -test filename-6.21 {Tcl_SplitPath: win} { +test filename-6.21 {Tcl_SplitPath: win} {testsetplatform} { testsetplatform win file split c:foo } {c: foo} -test filename-6.22 {Tcl_SplitPath: win} { +test filename-6.22 {Tcl_SplitPath: win} {testsetplatform} { testsetplatform win file split c: } {c:} -test filename-6.23 {Tcl_SplitPath: win} { +test filename-6.23 {Tcl_SplitPath: win} {testsetplatform} { testsetplatform win file split c:\\ } {c:/} -test filename-6.24 {Tcl_SplitPath: win} { +test filename-6.24 {Tcl_SplitPath: win} {testsetplatform} { testsetplatform win file split c:/ } {c:/} -test filename-6.25 {Tcl_SplitPath: win} { +test filename-6.25 {Tcl_SplitPath: win} {testsetplatform} { testsetplatform win file split c:/./.. } {c:/ . ..} -test filename-6.26 {Tcl_SplitPath: win} { +test filename-6.26 {Tcl_SplitPath: win} {testsetplatform} { testsetplatform win file split ~foo } {~foo} -test filename-6.27 {Tcl_SplitPath: win} { +test filename-6.27 {Tcl_SplitPath: win} {testsetplatform} { testsetplatform win file split ~foo/~bar } {~foo ./~bar} -test filename-6.28 {Tcl_SplitPath: win} { +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} { +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} { +test filename-6.30 {Tcl_SplitPath: win} {testsetplatform} { testsetplatform win file split c:~foo } {c: ./~foo} -test filename-7.1 {Tcl_JoinPath: unix} { +test filename-7.1 {Tcl_JoinPath: unix} {testsetplatform} { testsetplatform unix file join / a } {/a} -test filename-7.2 {Tcl_JoinPath: unix} { +test filename-7.2 {Tcl_JoinPath: unix} {testsetplatform} { testsetplatform unix file join a b } {a/b} -test filename-7.3 {Tcl_JoinPath: unix} { +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} { +test filename-7.4 {Tcl_JoinPath: unix} {testsetplatform} { testsetplatform unix file join / } {/} -test filename-7.5 {Tcl_JoinPath: unix} { +test filename-7.5 {Tcl_JoinPath: unix} {testsetplatform} { testsetplatform unix file join a } {a} -test filename-7.6 {Tcl_JoinPath: unix} { +test filename-7.6 {Tcl_JoinPath: unix} {testsetplatform} { testsetplatform unix file join {} } {} -test filename-7.7 {Tcl_JoinPath: unix} { +test filename-7.7 {Tcl_JoinPath: unix} {testsetplatform} { testsetplatform unix file join /a/ b } {/a/b} -test filename-7.8 {Tcl_JoinPath: unix} { +test filename-7.8 {Tcl_JoinPath: unix} {testsetplatform} { testsetplatform unix file join /a// b } {/a/b} -test filename-7.9 {Tcl_JoinPath: unix} { +test filename-7.9 {Tcl_JoinPath: unix} {testsetplatform} { testsetplatform unix file join /a/./../. b } {/a/./.././b} -test filename-7.10 {Tcl_JoinPath: unix} { +test filename-7.10 {Tcl_JoinPath: unix} {testsetplatform} { testsetplatform unix file join ~ a } {~/a} -test filename-7.11 {Tcl_JoinPath: unix} { +test filename-7.11 {Tcl_JoinPath: unix} {testsetplatform} { testsetplatform unix file join ~a ~b } {~b} -test filename-7.12 {Tcl_JoinPath: unix} { +test filename-7.12 {Tcl_JoinPath: unix} {testsetplatform} { testsetplatform unix file join ./~a b } {./~a/b} -test filename-7.13 {Tcl_JoinPath: unix} { +test filename-7.13 {Tcl_JoinPath: unix} {testsetplatform} { testsetplatform unix file join ./~a ~b } {~b} -test filename-7.14 {Tcl_JoinPath: unix} { +test filename-7.14 {Tcl_JoinPath: unix} {testsetplatform} { testsetplatform unix file join ./~a ./~b } {./~a/~b} -test filename-7.15 {Tcl_JoinPath: unix} { +test filename-7.15 {Tcl_JoinPath: unix} {testsetplatform} { testsetplatform unix file join a . b } {a/./b} -test filename-7.16 {Tcl_JoinPath: unix} { +test filename-7.16 {Tcl_JoinPath: unix} {testsetplatform} { testsetplatform unix file join a . ./~b } {a/./~b} -test filename-7.17 {Tcl_JoinPath: unix} { +test filename-7.17 {Tcl_JoinPath: unix} {testsetplatform} { testsetplatform unix file join //a b } {/a/b} -test filename-7.18 {Tcl_JoinPath: unix} { +test filename-7.18 {Tcl_JoinPath: unix} {testsetplatform} { testsetplatform unix file join /// a b } {/a/b} -test filename-8.1 {Tcl_JoinPath: mac} { +test filename-8.1 {Tcl_JoinPath: mac} {testsetplatform} { testsetplatform mac file join a b } {:a:b} -test filename-8.2 {Tcl_JoinPath: mac} { +test filename-8.2 {Tcl_JoinPath: mac} {testsetplatform} { testsetplatform mac file join :a b } {:a:b} -test filename-8.3 {Tcl_JoinPath: mac} { +test filename-8.3 {Tcl_JoinPath: mac} {testsetplatform} { testsetplatform mac file join a b: } {b:} -test filename-8.4 {Tcl_JoinPath: mac} { +test filename-8.4 {Tcl_JoinPath: mac} {testsetplatform} { testsetplatform mac file join a: :b } {a:b} -test filename-8.5 {Tcl_JoinPath: mac} { +test filename-8.5 {Tcl_JoinPath: mac} {testsetplatform} { testsetplatform mac file join a: :b: } {a:b} -test filename-8.6 {Tcl_JoinPath: mac} { +test filename-8.6 {Tcl_JoinPath: mac} {testsetplatform} { testsetplatform mac file join a :: b } {:a::b} -test filename-8.7 {Tcl_JoinPath: mac} { +test filename-8.7 {Tcl_JoinPath: mac} {testsetplatform} { testsetplatform mac file join a :: :: b } {:a:::b} -test filename-8.8 {Tcl_JoinPath: mac} { +test filename-8.8 {Tcl_JoinPath: mac} {testsetplatform} { testsetplatform mac file join a ::: b } {:a:::b} -test filename-8.9 {Tcl_JoinPath: mac} { +test filename-8.9 {Tcl_JoinPath: mac} {testsetplatform} { testsetplatform mac file join a: b: } {b:} -test filename-8.10 {Tcl_JoinPath: mac} { +test filename-8.10 {Tcl_JoinPath: mac} {testsetplatform} { testsetplatform mac file join /a/b } {a:b} -test filename-8.11 {Tcl_JoinPath: mac} { +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} { +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} { +test filename-8.13 {Tcl_JoinPath: mac} {testsetplatform} { testsetplatform mac file join ~ foo } {~:foo} -test filename-8.14 {Tcl_JoinPath: mac} { +test filename-8.14 {Tcl_JoinPath: mac} {testsetplatform} { testsetplatform mac file join :: :: } {:::} -test filename-8.15 {Tcl_JoinPath: mac} { +test filename-8.15 {Tcl_JoinPath: mac} {testsetplatform} { testsetplatform mac file join a: :: } {a::} -test filename-8.16 {Tcl_JoinPath: mac} { +test filename-8.16 {Tcl_JoinPath: mac} {testsetplatform} { testsetplatform mac file join a {} b } {:a:b} -test filename-8.17 {Tcl_JoinPath: mac} { +test filename-8.17 {Tcl_JoinPath: mac} {testsetplatform} { testsetplatform mac file join a::: b } {a:::b} -test filename-8.18 {Tcl_JoinPath: mac} { +test filename-8.18 {Tcl_JoinPath: mac} {testsetplatform} { testsetplatform mac file join a : : : } {:a} -test filename-8.19 {Tcl_JoinPath: mac} { +test filename-8.19 {Tcl_JoinPath: mac} {testsetplatform} { testsetplatform mac file join : } {:} -test filename-8.20 {Tcl_JoinPath: mac} { +test filename-8.20 {Tcl_JoinPath: mac} {testsetplatform} { testsetplatform mac file join : a } {:a} -test filename-8.21 {Tcl_JoinPath: mac} { +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} { +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} { +test filename-9.1 {Tcl_JoinPath: win} {testsetplatform} { testsetplatform win file join a b } {a/b} -test filename-9.2 {Tcl_JoinPath: win} { +test filename-9.2 {Tcl_JoinPath: win} {testsetplatform} { testsetplatform win file join /a b } {/a/b} -test filename-9.3 {Tcl_JoinPath: win} { +test filename-9.3 {Tcl_JoinPath: win} {testsetplatform} { testsetplatform win file join /a /b } {/b} -test filename-9.4 {Tcl_JoinPath: win} { +test filename-9.4 {Tcl_JoinPath: win} {testsetplatform} { testsetplatform win file join c: foo } {c:foo} -test filename-9.5 {Tcl_JoinPath: win} { +test filename-9.5 {Tcl_JoinPath: win} {testsetplatform} { testsetplatform win file join c:/ foo } {c:/foo} -test filename-9.6 {Tcl_JoinPath: win} { +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} { +test filename-9.7 {Tcl_JoinPath: win} {testsetplatform} { testsetplatform win file join /foo c:bar } {c:bar} -test filename-9.8 {Tcl_JoinPath: win} { +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} { +test filename-9.9 {Tcl_JoinPath: win} {testsetplatform} { testsetplatform win file join ~ foo } {~/foo} -test filename-9.10 {Tcl_JoinPath: win} { +test filename-9.10 {Tcl_JoinPath: win} {testsetplatform} { testsetplatform win file join ~/~foo } {~/~foo} -test filename-9.11 {Tcl_JoinPath: win} { +test filename-9.11 {Tcl_JoinPath: win} {testsetplatform} { testsetplatform win file join ~ ./~foo } {~/~foo} -test filename-9.12 {Tcl_JoinPath: win} { +test filename-9.12 {Tcl_JoinPath: win} {testsetplatform} { testsetplatform win file join / ~foo } {~foo} -test filename-9.13 {Tcl_JoinPath: win} { +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} { +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} { +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} { +test filename-9.16 {Tcl_JoinPath: win} {testsetplatform} { testsetplatform win file join foo . bar } {foo/./bar} -test filename-9.17 {Tcl_JoinPath: win} { +test filename-9.17 {Tcl_JoinPath: win} {testsetplatform} { testsetplatform win file join foo .. bar } {foo/../bar} -test filename-9.18 {Tcl_JoinPath: win} { +test filename-9.18 {Tcl_JoinPath: win} {testsetplatform} { testsetplatform win file join foo/./bar } {foo/./bar} -test filename-10.1 {Tcl_TranslateFileName} { +test filename-10.1 {Tcl_TranslateFileName} {testsetplatform} { testsetplatform unix list [catch {testtranslatefilename foo} msg] $msg } {0 foo} -test filename-10.2 {Tcl_TranslateFileName} { +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} { +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} { +test filename-10.4 {Tcl_TranslateFileName} {testsetplatform} { testsetplatform mac list [catch {testtranslatefilename foo} msg] $msg } {0 :foo} -test filename-10.5 {Tcl_TranslateFileName} { +test filename-10.5 {Tcl_TranslateFileName} {testsetplatform} { testsetplatform mac list [catch {testtranslatefilename :~foo} msg] $msg } {0 :~foo} -test filename-10.6 {Tcl_TranslateFileName} { +test filename-10.6 {Tcl_TranslateFileName} {testsetplatform} { global env set temp $env(HOME) set env(HOME) "/home/test" @@ -897,7 +895,7 @@ test filename-10.6 {Tcl_TranslateFileName} { set env(HOME) $temp set result } {0 /home/test/foo} -test filename-10.7 {Tcl_TranslateFileName} { +test filename-10.7 {Tcl_TranslateFileName} {testsetplatform} { global env set temp $env(HOME) unset env(HOME) @@ -906,7 +904,7 @@ test filename-10.7 {Tcl_TranslateFileName} { set env(HOME) $temp set result } {1 {couldn't find HOME environment variable to expand path}} -test filename-10.8 {Tcl_TranslateFileName} { +test filename-10.8 {Tcl_TranslateFileName} {testsetplatform} { global env set temp $env(HOME) set env(HOME) "/home/test" @@ -915,7 +913,7 @@ test filename-10.8 {Tcl_TranslateFileName} { set env(HOME) $temp set result } {0 /home/test} -test filename-10.9 {Tcl_TranslateFileName} { +test filename-10.9 {Tcl_TranslateFileName} {testsetplatform} { global env set temp $env(HOME) set env(HOME) "/home/test/" @@ -924,7 +922,7 @@ test filename-10.9 {Tcl_TranslateFileName} { set env(HOME) $temp set result } {0 /home/test} -test filename-10.10 {Tcl_TranslateFileName} { +test filename-10.10 {Tcl_TranslateFileName} {testsetplatform} { global env set temp $env(HOME) set env(HOME) "/home/test/" @@ -933,7 +931,7 @@ test filename-10.10 {Tcl_TranslateFileName} { set env(HOME) $temp set result } {0 /home/test/foo} -test filename-10.11 {Tcl_TranslateFileName} { +test filename-10.11 {Tcl_TranslateFileName} {testsetplatform} { global env set temp $env(HOME) set env(HOME) "Root:" @@ -942,7 +940,7 @@ test filename-10.11 {Tcl_TranslateFileName} { set env(HOME) $temp set result } {0 Root:foo} -test filename-10.12 {Tcl_TranslateFileName} { +test filename-10.12 {Tcl_TranslateFileName} {testsetplatform} { global env set temp $env(HOME) set env(HOME) "Root:home" @@ -951,7 +949,7 @@ test filename-10.12 {Tcl_TranslateFileName} { set env(HOME) $temp set result } {0 Root:home:foo} -test filename-10.13 {Tcl_TranslateFileName} { +test filename-10.13 {Tcl_TranslateFileName} {testsetplatform} { global env set temp $env(HOME) set env(HOME) "Root:home" @@ -960,7 +958,7 @@ test filename-10.13 {Tcl_TranslateFileName} { set env(HOME) $temp set result } {0 Root:home::foo} -test filename-10.14 {Tcl_TranslateFileName} { +test filename-10.14 {Tcl_TranslateFileName} {testsetplatform} { global env set temp $env(HOME) set env(HOME) "Root:home" @@ -969,7 +967,7 @@ test filename-10.14 {Tcl_TranslateFileName} { set env(HOME) $temp set result } {0 Root:home} -test filename-10.15 {Tcl_TranslateFileName} { +test filename-10.15 {Tcl_TranslateFileName} {testsetplatform} { global env set temp $env(HOME) set env(HOME) "Root:home:" @@ -978,7 +976,7 @@ test filename-10.15 {Tcl_TranslateFileName} { set env(HOME) $temp set result } {0 Root:home::foo} -test filename-10.16 {Tcl_TranslateFileName} { +test filename-10.16 {Tcl_TranslateFileName} {testsetplatform} { global env set temp $env(HOME) set env(HOME) "Root:home::" @@ -987,7 +985,7 @@ test filename-10.16 {Tcl_TranslateFileName} { set env(HOME) $temp set result } {0 Root:home:::foo} -test filename-10.17 {Tcl_TranslateFileName} { +test filename-10.17 {Tcl_TranslateFileName} {testsetplatform} { global env set temp $env(HOME) set env(HOME) "\\home\\" @@ -996,7 +994,7 @@ test filename-10.17 {Tcl_TranslateFileName} { set env(HOME) $temp set result } {0 {\home\foo}} -test filename-10.18 {Tcl_TranslateFileName} { +test filename-10.18 {Tcl_TranslateFileName} {testsetplatform} { global env set temp $env(HOME) set env(HOME) "\\home\\" @@ -1005,7 +1003,7 @@ test filename-10.18 {Tcl_TranslateFileName} { set env(HOME) $temp set result } {0 {\home\foo\bar}} -test filename-10.19 {Tcl_TranslateFileName} { +test filename-10.19 {Tcl_TranslateFileName} {testsetplatform} { global env set temp $env(HOME) set env(HOME) "c:" @@ -1014,10 +1012,10 @@ test filename-10.19 {Tcl_TranslateFileName} { set env(HOME) $temp set result } {0 c:foo} -test filename-10.20 {Tcl_TranslateFileName} { +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} { +test filename-10.21 {Tcl_TranslateFileName} {testsetplatform} { global env set temp $env(HOME) set env(HOME) "c:\\" @@ -1026,12 +1024,14 @@ test filename-10.21 {Tcl_TranslateFileName} { set env(HOME) $temp set result } {0 {c:\foo}} -test filename-10.22 {Tcl_TranslateFileName} { +test filename-10.22 {Tcl_TranslateFileName} {testsetplatform} { testsetplatform windows list [catch {testtranslatefilename foo//bar} msg] $msg } {0 {foo\bar}} -testsetplatform $platform +if {[tcltest::testConstraint testsetplatform]} { + testsetplatform $platform +} test filename-10.23 {Tcl_TranslateFileName} {unixOnly nonPortable} { # this test fails if ~ouster is not /home/ouster @@ -1048,7 +1048,7 @@ test filename-11.1 {Tcl_GlobCmd} { } {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 --}} +} {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,19 +1067,19 @@ test filename-11.7 {Tcl_GlobCmd} { test filename-11.8 {Tcl_GlobCmd} { list [catch {glob -nocomplain -- -nocomplain} msg] $msg } {0 {}} -test filename-11.9 {Tcl_GlobCmd} { +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} { +test filename-11.10 {Tcl_GlobCmd} {testsetplatform} { testsetplatform unix list [catch {glob -nocomplain ~\\xyqrszzz/bar} msg] $msg } {0 {}} -test filename-11.11 {Tcl_GlobCmd} { +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} { +test filename-11.12 {Tcl_GlobCmd} {testsetplatform} { testsetplatform unix set home $env(HOME) unset env(HOME) @@ -1088,7 +1088,9 @@ test filename-11.12 {Tcl_GlobCmd} { set x } {1 {couldn't find HOME environment variable to expand path}} -testsetplatform $platform +if {[tcltest::testConstraint testsetplatform]} { + testsetplatform $platform +} test filename-11.13 {Tcl_GlobCmd} { list [catch {file join [lindex [glob ~] 0]} msg] $msg @@ -1124,7 +1126,7 @@ test filename-11.16 {Tcl_GlobCmd} { set globname "globTest" set horribleglobname "glob\[\{Test" -test filename-11.17 {Tcl_GlobCmd} { +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]\ @@ -1132,15 +1134,33 @@ test filename-11.17 {Tcl_GlobCmd} { [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} { +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} { +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]\ @@ -1149,6 +1169,16 @@ test filename-11.19 {Tcl_GlobCmd} { [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]\ + [file join $globname x1.c]\ + [file join $globname y1.c] [file join $globname z1.c]]]] test filename-11.20 {Tcl_GlobCmd} { list [catch {lsort [glob -type d -dir $globname *]} msg] $msg } [list 0 [lsort [list [file join $globname a1]\ @@ -1161,7 +1191,7 @@ test filename-11.21 {Tcl_GlobCmd} { file rename globTest $horribleglobname set globname $horribleglobname -test filename-11.22 {Tcl_GlobCmd} { +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,7 +1199,16 @@ test filename-11.22 {Tcl_GlobCmd} { [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} { +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]\ @@ -1177,7 +1216,16 @@ test filename-11.23 {Tcl_GlobCmd} { [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} { +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,6 +1234,16 @@ test filename-11.24 {Tcl_GlobCmd} { [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,7 +1279,39 @@ test filename-11.34 {Tcl_GlobCmd} { } {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 --}} +} {1 {bad option "-paths": must be -directory, -join, -nocomplain, -path, -tails, -types, or --}} +# Test '-tails' flag to glob. +test filename-11.36 {Tcl_GlobCmd} { + list [catch {glob -tails *} msg] $msg +} {1 {"-tails" must be used with either "-directory" or "-path"}} +test filename-11.37 {Tcl_GlobCmd} { + list [catch {glob -type d -tails -path $globname *} msg] $msg +} [list 0 [list $globname]] +test filename-11.38 {Tcl_GlobCmd} { + list [catch {glob -tails -path $globname *} msg] $msg +} [list 0 [list $globname]] +test filename-11.39 {Tcl_GlobCmd} { + list [catch {glob -tails -join -path $globname *} msg] $msg +} [list 0 [list $globname]] +test filename-11.40 {Tcl_GlobCmd} { + expr {[glob -dir [pwd] -tails *] == [glob *]} +} {1} +test filename-11.41 {Tcl_GlobCmd} { + expr {[glob -dir [pwd] -tails *] != [glob -dir [pwd] *]} +} {1} +test filename-11.42 {Tcl_GlobCmd} { + set res [list] + foreach f [glob -dir [pwd] *] { + lappend res [file tail $f] + } + expr {$res == [glob *]} +} {1} +test filename-11.43 {Tcl_GlobCmd} { + list [catch {glob -t *} msg] $msg +} {1 {ambiguous option "-t": must be -directory, -join, -nocomplain, -path, -tails, -types, or --}} +test filename-11.44 {Tcl_GlobCmd} { + list [catch {glob -tails -path hello -directory hello *} msg] $msg +} {1 {"-directory" cannot be used with "-path"}} file rename $horribleglobname globTest set globname globTest @@ -1339,9 +1429,12 @@ test filename-14.5 {asterisks, question marks, and brackets} {unixOrPc} { 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} { +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,13 +1491,21 @@ test filename-14.23 {slash globbing} {unixOrPc} { test filename-14.24 {slash globbing} {pcOnly} { glob {\\} } / -test filename-14.25 {type specific globbing} { +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,7 +1619,10 @@ file delete -force C:/globTest cd $oldDir file delete -force globTest set env(HOME) $oldhome -testsetplatform $platform -catch {unset oldhome platform temp result} +if {[tcltest::testConstraint testsetplatform]} { + testsetplatform $platform + catch {unset platform} +} +catch {unset oldhome temp result} ::tcltest::cleanupTests return diff --git a/tests/io.test b/tests/io.test index 792a2a2..3c4d8ed 100644 --- a/tests/io.test +++ b/tests/io.test @@ -12,18 +12,14 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: io.test,v 1.19 2001/07/17 18:46:47 andreas_kupries Exp $ +# RCS: @(#) $Id: io.test,v 1.20 2001/07/31 19:12:07 vincentdarley Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 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::testConstraint testchannel [string equal testchannel [info commands testchannel]] ::tcltest::saveState @@ -630,7 +626,7 @@ test io-6.29 {Tcl_GetsObj: crlf mode: several chars} { close $f set x } [list 14 "abcd\nefgh\rijkl" 4 "mnop" -1 ""] -test io-6.30 {Tcl_GetsObj: crlf mode: buffer exhausted} { +test io-6.30 {Tcl_GetsObj: crlf mode: buffer exhausted} {testchannel} { # if (eol >= dstEnd) set f [open test1 w] @@ -643,7 +639,7 @@ test io-6.30 {Tcl_GetsObj: crlf mode: buffer exhausted} { close $f set x } [list 15 "123456789012345" 15] -test io-6.31 {Tcl_GetsObj: crlf mode: buffer exhausted, blocked} {stdio} { +test io-6.31 {Tcl_GetsObj: crlf mode: buffer exhausted, blocked} {stdio testchannel} { # (FilterInputBytes() != 0) set f [open "|[list $::tcltest::tcltest cat]" w+] @@ -656,7 +652,7 @@ test io-6.31 {Tcl_GetsObj: crlf mode: buffer exhausted, blocked} {stdio} { close $f set x } [list "bbbbbbbbbbbbbb" -1 "" 1 16] -test io-6.32 {Tcl_GetsObj: crlf mode: buffer exhausted, more data} { +test io-6.32 {Tcl_GetsObj: crlf mode: buffer exhausted, more data} {testchannel} { # not (FilterInputBytes() != 0) set f [open test1 w] @@ -782,7 +778,7 @@ test io-6.42 {Tcl_GetsObj: auto mode: several chars} { close $f set x } [list 4 "abcd" 4 "efgh" 4 "ijkl" 4 "mnop" -1 ""] -test io-6.43 {Tcl_GetsObj: input saw cr} {stdio} { +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,7 +795,7 @@ test io-6.43 {Tcl_GetsObj: input saw cr} {stdio} { 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} { +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,7 +812,7 @@ test io-6.44 {Tcl_GetsObj: input saw cr, not followed by cr} {stdio} { 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} { +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,7 +829,7 @@ test io-6.45 {Tcl_GetsObj: input saw cr, skip right number of bytes} {stdio} { 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} { +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,7 +845,7 @@ test io-6.46 {Tcl_GetsObj: input saw cr, followed by just \n should give eof} {s 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} { +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,7 +858,7 @@ test io-6.47 {Tcl_GetsObj: auto mode: \r at end of buffer, peek for \n} { close $f set x } [list "123456789012345" 15] -test io-6.48 {Tcl_GetsObj: auto mode: \r at end of buffer, no more avail} { +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,7 +871,7 @@ test io-6.48 {Tcl_GetsObj: auto mode: \r at end of buffer, no more avail} { close $f set x } [list "123456789012345" 1] -test io-6.49 {Tcl_GetsObj: auto mode: \r followed by \n} { +test io-6.49 {Tcl_GetsObj: auto mode: \r followed by \n} {testchannel} { # if (*eol == '\n') {skip++} set f [open test1 w] @@ -887,7 +883,7 @@ test io-6.49 {Tcl_GetsObj: auto mode: \r followed by \n} { close $f set x } [list "123456" 0 8 "78901"] -test io-6.50 {Tcl_GetsObj: auto mode: \r not followed by \n} { +test io-6.50 {Tcl_GetsObj: auto mode: \r not followed by \n} {testchannel} { # not (*eol == '\n') set f [open test1 w] @@ -911,7 +907,7 @@ test io-6.51 {Tcl_GetsObj: auto mode: \n} { close $f set x } [list "123456" 7 "78901"] -test io-6.52 {Tcl_GetsObj: saw EOF character} { +test io-6.52 {Tcl_GetsObj: saw EOF character} {testchannel} { # if (eof != NULL) set f [open test1 w] @@ -1005,7 +1001,7 @@ test io-7.2 {FilterInputBytes: split up character in middle of buffer} { close $f set x } [list 10 "1234567890" 0] -test io-7.3 {FilterInputBytes: split up character at EOF} { +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,7 +1033,7 @@ test io-7.4 {FilterInputBytes: recover from split up character} {stdio} { 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} { +test io-8.1 {PeekAhead: only go to device if no more cached data} {testchannel} { # (bufPtr->nextPtr == NULL) set f [open "test1" w] @@ -1052,7 +1048,7 @@ test io-8.1 {PeekAhead: only go to device if no more cached data} { close $f set x } "7" -test io-8.2 {PeekAhead: only go to device if no more cached data} {stdio} { +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,7 +1067,7 @@ test io-8.2 {PeekAhead: only go to device if no more cached data} {stdio} { close $f set x } [list -1 "" 42 15 "123456789012345" 25] -test io-8.3 {PeekAhead: no cached data available} {stdio} { +test io-8.3 {PeekAhead: no cached data available} {stdio testchannel} { # (bytesLeft == 0) set f [open "|[list $::tcltest::tcltest cat]" w+] @@ -1104,7 +1100,7 @@ test io-8.4 {PeekAhead: cached data available in this buffer} { set x } $a unset a -test io-8.5 {PeekAhead: don't peek if last read was short} {stdio} { +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,7 +1112,7 @@ test io-8.5 {PeekAhead: don't peek if last read was short} {stdio} { close $f set x } {15 abcdefghijklmno 1} -test io-8.6 {PeekAhead: change to non-blocking mode} {stdio} { +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,7 +1124,7 @@ test io-8.6 {PeekAhead: change to non-blocking mode} {stdio} { close $f set x } {15 abcdefghijklmno 1} -test io-8.7 {PeekAhead: cleanup} {stdio} { +test io-8.7 {PeekAhead: cleanup} {stdio testchannel} { # Make sure bytes are removed from buffer. set f [open "|[list $::tcltest::tcltest cat]" w+] @@ -1294,7 +1290,7 @@ test io-12.3 {ReadChars: allocate more space} { close $f set x } {abcdefghijklmnopqrstuvwxyz} -test io-12.4 {ReadChars: split-up char} {stdio} { +test io-12.4 {ReadChars: split-up char} {stdio testchannel} { # (srcRead == 0) set f [open "|[list $::tcltest::tcltest cat]" w+] @@ -1413,7 +1409,7 @@ test io-13.5 {TranslateInputEOL: crlf mode: naked lf} { close $f set x } "abcd\ndef\nfgh" -test io-13.6 {TranslateInputEOL: auto mode: saw cr in last segment} {stdio} { +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,7 +1433,7 @@ test io-13.6 {TranslateInputEOL: auto mode: saw cr in last segment} {stdio} { close $f set x } [list "abcdefghj\n" 1 "01234" 0] -test io-13.7 {TranslateInputEOL: auto mode: naked \r} { +test io-13.7 {TranslateInputEOL: auto mode: naked \r} {testchannel} { # (src >= srcMax) set f [open test1 w] @@ -1518,12 +1514,18 @@ test io-13.12 {TranslateInputEOL: find EOF char in src} { # Tcl_SetStdChannel and Tcl_GetStdChannel. Incidentally we are # also testing channel table management. -if {$tcl_platform(platform) == "macintosh"} { - set consoleFileNames [list console0 console1 console2] +if {[info commands testchannel] != ""} { + if {$tcl_platform(platform) == "macintosh"} { + set consoleFileNames [list console0 console1 console2] + } else { + set consoleFileNames [lsort [testchannel open]] + } } else { - set consoleFileNames [lsort [testchannel open]] + # just to avoid an error + set consoleFileNames [list] } -test io-14.1 {Tcl_SetStdChannel and Tcl_GetStdChannel} { + +test io-14.1 {Tcl_SetStdChannel and Tcl_GetStdChannel} {testchannel} { set l "" lappend l [fconfigure stdin -buffering] lappend l [fconfigure stdout -buffering] @@ -1677,7 +1679,7 @@ test io-16.1 {Tcl_DeleteCloseHandler} { # 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} { +test io-17.1 {GetChannelTable, DeleteChannelTable on std handles} {testchannel} { set l1 [testchannel refcount stdin] eof stdin interp create x @@ -1689,7 +1691,7 @@ test io-17.1 {GetChannelTable, DeleteChannelTable on std handles} { lappend l [expr [testchannel refcount stdin] - $l1] set l } {0 1 0} -test io-17.2 {GetChannelTable, DeleteChannelTable on std handles} { +test io-17.2 {GetChannelTable, DeleteChannelTable on std handles} {testchannel} { set l1 [testchannel refcount stdout] eof stdin interp create x @@ -1701,7 +1703,7 @@ test io-17.2 {GetChannelTable, DeleteChannelTable on std handles} { lappend l [expr [testchannel refcount stdout] - $l1] set l } {0 1 0} -test io-17.3 {GetChannelTable, DeleteChannelTable on std handles} { +test io-17.3 {GetChannelTable, DeleteChannelTable on std handles} {testchannel} { set l1 [testchannel refcount stderr] eof stdin interp create x @@ -1714,7 +1716,7 @@ test io-17.3 {GetChannelTable, DeleteChannelTable on std handles} { set l } {0 1 0} -test io-18.1 {Tcl_RegisterChannel, Tcl_UnregisterChannel} { +test io-18.1 {Tcl_RegisterChannel, Tcl_UnregisterChannel} {testchannel} { removeFile test1 set l "" set f [open test1 w] @@ -1728,7 +1730,7 @@ test io-18.1 {Tcl_RegisterChannel, Tcl_UnregisterChannel} { string compare [string tolower $l] \ [list 1 [format "can not find channel named \"%s\"" $f]] } 0 -test io-18.2 {Tcl_RegisterChannel, Tcl_UnregisterChannel} { +test io-18.2 {Tcl_RegisterChannel, Tcl_UnregisterChannel} {testchannel} { removeFile test1 set l "" set f [open test1 w] @@ -1749,7 +1751,7 @@ test io-18.2 {Tcl_RegisterChannel, Tcl_UnregisterChannel} { 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} { +test io-18.3 {Tcl_RegisterChannel, Tcl_UnregisterChannel} {testchannel} { removeFile test1 set l "" set f [open test1 w] @@ -1782,7 +1784,7 @@ test io-19.2 {testing Tcl_GetChannel, user opened handle} { 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} { +test io-19.4 {Tcl_CreateChannel, insertion into channel table} {testchannel} { removeFile test1 set f [open test1 w] set l "" @@ -1853,7 +1855,7 @@ test io-22.1 {Tcl_GetChannelMode} { # Not used anywhere in Tcl. } {} -test io-23.1 {Tcl_GetChannelName} { +test io-23.1 {Tcl_GetChannelName} {testchannel} { removeFile test1 set f [open test1 w] set n [testchannel name $f] @@ -1861,7 +1863,7 @@ test io-23.1 {Tcl_GetChannelName} { string compare $n $f } 0 -test io-24.1 {Tcl_GetChannelType} { +test io-24.1 {Tcl_GetChannelType} {testchannel} { removeFile test1 set f [open test1 w] set t [testchannel type $f] @@ -1869,7 +1871,7 @@ test io-24.1 {Tcl_GetChannelType} { string compare $t file } 0 -test io-25.1 {Tcl_GetChannelHandle, input} { +test io-25.1 {Tcl_GetChannelHandle, input} {testchannel} { set f [open test1 w] fconfigure $f -translation lf -eofchar {} puts $f "1234567890\n098765432" @@ -1882,7 +1884,7 @@ test io-25.1 {Tcl_GetChannelHandle, input} { close $f set l } {10 11} -test io-25.2 {Tcl_GetChannelHandle, output} { +test io-25.2 {Tcl_GetChannelHandle, output} {testchannel} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf @@ -2012,7 +2014,7 @@ test io-27.6 {FlushChannel, async flushing, async close} \ # Tests closing a channel. The functions tested are CloseChannel and Tcl_Close. -test io-28.1 {CloseChannel called when all references are dropped} { +test io-28.1 {CloseChannel called when all references are dropped} {testchannel} { removeFile test1 set f [open test1 w] interp create x @@ -2086,7 +2088,7 @@ test io-28.3 {CloseChannel, not called before output queue is empty} \ set result ok } } ok -test io-28.4 {Tcl_Close} { +test io-28.4 {Tcl_Close} {testchannel} { removeFile test1 set l "" lappend l [lsort [testchannel open]] @@ -2099,7 +2101,7 @@ test io-28.4 {Tcl_Close} { $consoleFileNames] string compare $l $x } 0 -test io-28.5 {Tcl_Close vs standard handles} {stdio unixOnly} { +test io-28.5 {Tcl_Close vs standard handles} {stdio unixOnly testchannel} { removeFile script set f [open script w] puts $f { @@ -2132,7 +2134,7 @@ test io-29.3 {Tcl_WriteChars, nonempty string} { close $f file size test1 } 5 -test io-29.4 {Tcl_WriteChars, buffering in full buffering mode} { +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,7 +2148,7 @@ test io-29.4 {Tcl_WriteChars, buffering in full buffering mode} { close $f set l } {6 0 0 6} -test io-29.5 {Tcl_WriteChars, buffering in line buffering mode} { +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,7 +2162,7 @@ test io-29.5 {Tcl_WriteChars, buffering in line buffering mode} { close $f set l } {5 0 0 11} -test io-29.6 {Tcl_WriteChars, buffering in no buffering mode} { +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,7 +2177,7 @@ test io-29.6 {Tcl_WriteChars, buffering in no buffering mode} { set l } {0 5 0 11} -test io-29.7 {Tcl_Flush, full buffering} { +test io-29.7 {Tcl_Flush, full buffering} {testchannel} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf -buffering full -eofchar {} @@ -2192,7 +2194,7 @@ test io-29.7 {Tcl_Flush, full buffering} { close $f set l } {5 0 11 0 0 11} -test io-29.8 {Tcl_Flush, full buffering} { +test io-29.8 {Tcl_Flush, full buffering} {testchannel} { removeFile test1 set f [open test1 w] fconfigure $f -translation lf -buffering line @@ -4671,7 +4673,7 @@ test io-36.6 {Tcl_InputBlocked vs files, event driven read} {nonBlockFiles} { # Test Tcl_InputBuffered -test io-37.1 {Tcl_InputBuffered} { +test io-37.1 {Tcl_InputBuffered} {testchannel} { set f [open longfile r] fconfigure $f -buffersize 4096 read $f 3 @@ -4681,7 +4683,7 @@ test io-37.1 {Tcl_InputBuffered} { close $f set l } {4093 3} -test io-37.2 {Tcl_InputBuffered, test input flushing on seek} { +test io-37.2 {Tcl_InputBuffered, test input flushing on seek} {testchannel} { set f [open longfile r] fconfigure $f -buffersize 4096 read $f 3 @@ -5097,6 +5099,7 @@ test io-40.6 {POSIX open access modes: EXCL} { close $f set msg [list [catch {open test3 {WRONLY CREAT EXCL}} msg] $msg] regsub " already " $msg " " msg + regsub [file join {} test3] $msg "test3" msg string tolower $msg } {1 {couldn't open "test3": file exists}} test io-40.7 {POSIX open access modes: EXCL} { @@ -5144,11 +5147,15 @@ test io-40.10 {POSIX open access modes: RDONLY} { } 0 test io-40.11 {POSIX open access modes: RDONLY} { removeFile test3 - string tolower [list [catch {open test3 RDONLY} msg] $msg] + set msg [list [catch {open test3 RDONLY} msg] $msg] + regsub [file join {} test3] $msg "test3" msg + string tolower $msg } {1 {couldn't open "test3": no such file or directory}} test io-40.12 {POSIX open access modes: WRONLY} { removeFile test3 - string tolower [list [catch {open test3 WRONLY} msg] $msg] + set msg [list [catch {open test3 WRONLY} msg] $msg] + regsub [file join {} test3] $msg "test3" msg + string tolower $msg } {1 {couldn't open "test3": no such file or directory}} test io-40.13 {POSIX open access modes: WRONLY} { makeFile xyzzy test3 @@ -5164,7 +5171,9 @@ test io-40.13 {POSIX open access modes: WRONLY} { } 0 test io-40.14 {POSIX open access modes: RDWR} { removeFile test3 - string tolower [list [catch {open test3 RDWR} msg] $msg] + set msg [list [catch {open test3 RDWR} msg] $msg] + regsub [file join {} test3] $msg "test3" msg + string tolower $msg } {1 {couldn't open "test3": no such file or directory}} test io-40.15 {POSIX open access modes: RDWR} { makeFile xyzzy test3 @@ -6054,7 +6063,7 @@ test io-49.5 {testing crlf reading, leftover cr disgorgment} { set l } [list 7 a\rb\rc 7 {} 7 1] -test io-50.1 {testing handler deletion} {} { +test io-50.1 {testing handler deletion} {testchannel} { removeFile test1 set f [open test1 w] close $f @@ -6070,7 +6079,7 @@ test io-50.1 {testing handler deletion} {} { close $f set z } called -test io-50.2 {testing handler deletion with multiple handlers} {} { +test io-50.2 {testing handler deletion with multiple handlers} {testchannel} { removeFile test1 set f [open test1 w] close $f @@ -6088,7 +6097,7 @@ test io-50.2 {testing handler deletion with multiple handlers} {} { 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} {} { +test io-50.3 {testing handler deletion with multiple handlers} {testchannel} { removeFile test1 set f [open test1 w] close $f @@ -6114,7 +6123,7 @@ test io-50.3 {testing handler deletion with multiple handlers} {} { [list [list delhandler $f 0 called] \ [list delhandler $f 0 deleted myself]] } 0 -test io-50.4 {testing handler deletion vs reentrant calls} {} { +test io-50.4 {testing handler deletion vs reentrant calls} {testchannel} { removeFile test1 set f [open test1 w] close $f @@ -6138,7 +6147,7 @@ test io-50.4 {testing handler deletion vs reentrant calls} {} { string compare [string tolower $z] \ {{delrecursive calling recursive} {delrecursive deleting recursive}} } 0 -test io-50.5 {testing handler deletion vs reentrant calls} {} { +test io-50.5 {testing handler deletion vs reentrant calls} {testchannel} { removeFile test1 set f [open test1 w] close $f @@ -6171,7 +6180,7 @@ test io-50.5 {testing handler deletion vs reentrant calls} {} { [list {del calling recursive} {del deleted notcalled} \ {del deleted myself} {del after update}] } 0 -test io-50.6 {testing handler deletion vs reentrant calls} {} { +test io-50.6 {testing handler deletion vs reentrant calls} {testchannel} { removeFile test1 set f [open test1 w] close $f @@ -6723,7 +6732,7 @@ test io-55.1 {ChannelEventScriptInvoker: deletion} { set x } {got_error} -test io-56.1 {ChannelTimerProc} { +test io-56.1 {ChannelTimerProc} {testchannel} { set f [open fooBar w] puts $f "this is a test" close $f diff --git a/tests/ioCmd.test b/tests/ioCmd.test index 5655c7b..38a3e32 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -12,7 +12,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: ioCmd.test,v 1.8 2000/04/10 17:19:01 ericm Exp $ +# RCS: @(#) $Id: ioCmd.test,v 1.9 2001/07/31 19:12:07 vincentdarley Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -361,11 +361,15 @@ test iocmd-12.1 {POSIX open access modes: RDONLY} { } 0 test iocmd-12.2 {POSIX open access modes: RDONLY} { removeFile test3 - string tolower [list [catch {open test3 RDONLY} msg] $msg] + set msg [list [catch {open test3 RDONLY} msg] $msg] + regsub [file join {} test3] $msg "test3" msg + string tolower $msg } {1 {couldn't open "test3": no such file or directory}} test iocmd-12.3 {POSIX open access modes: WRONLY} { removeFile test3 - string tolower [list [catch {open test3 WRONLY} msg] $msg] + set msg [list [catch {open test3 WRONLY} msg] $msg] + regsub [file join {} test3] $msg "test3" msg + string tolower $msg } {1 {couldn't open "test3": no such file or directory}} # # Test 13.4 relies on assigning the same channel name twice. @@ -391,7 +395,9 @@ test iocmd-12.4 {POSIX open access modes: WRONLY} {unixOnly} { } 0 test iocmd-12.5 {POSIX open access modes: RDWR} { removeFile test3 - string tolower [list [catch {open test3 RDWR} msg] $msg] + set msg [list [catch {open test3 RDWR} msg] $msg] + regsub [file join {} test3] $msg "test3" msg + string tolower $msg } {1 {couldn't open "test3": no such file or directory}} test iocmd-12.6 {POSIX open access modes: errors} { concat [catch {open test3 "FOO \{BAR BAZ"} msg] $msg\n$errorInfo @@ -423,7 +429,9 @@ test iocmd-13.5 {errors in open command} { list [catch {open test1 r+1} msg] $msg } {1 {illegal access mode "r+1"}} test iocmd-13.6 {errors in open command} { - string tolower [list [catch {open _non_existent_} msg] $msg $errorCode] + set msg [list [catch {open _non_existent_} msg] $msg $errorCode] + regsub [file join {} _non_existent_] $msg "_non_existent_" msg + string tolower $msg } {1 {couldn't open "_non_existent_": no such file or directory} {posix enoent {no such file or directory}}} test iocmd-14.1 {file id parsing errors} { diff --git a/tests/proc-old.test b/tests/proc-old.test index 9365042..e4dae6a 100644 --- a/tests/proc-old.test +++ b/tests/proc-old.test @@ -14,7 +14,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: proc-old.test,v 1.7 2000/05/03 00:14:36 hobbs Exp $ +# RCS: @(#) $Id: proc-old.test,v 1.8 2001/07/31 19:12:07 vincentdarley Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -433,7 +433,9 @@ test proc-old-7.11 {return with special completion code} { catch {open _bad_file_name r} msg return -code error -errorinfo $errorInfo -errorcode $errorCode $msg } - normalizeMsg [list [catch tproc2 msg] $msg $errorInfo $errorCode] + set msg [list [catch tproc2 msg] $msg $errorInfo $errorCode] + regsub -all [file join {} _bad_file_name] $msg "_bad_file_name" msg + normalizeMsg $msg } {1 {couldn't open "_bad_file_name": no such file or directory} {couldn't open "_bad_file_name": no such file or directory while executing "open _bad_file_name r" @@ -445,7 +447,9 @@ test proc-old-7.12 {return with special completion code} { catch {open _bad_file_name r} msg return -code error -errorcode $errorCode $msg } - normalizeMsg [list [catch tproc2 msg] $msg $errorInfo $errorCode] + set msg [list [catch tproc2 msg] $msg $errorInfo $errorCode] + regsub -all [file join {} _bad_file_name] $msg "_bad_file_name" msg + normalizeMsg $msg } {1 {couldn't open "_bad_file_name": no such file or directory} {couldn't open "_bad_file_name": no such file or directory while executing "tproc2"} {posix enoent {no such file or directory}}} @@ -455,7 +459,9 @@ test proc-old-7.13 {return with special completion code} { catch {open _bad_file_name r} msg return -code error -errorinfo $errorInfo $msg } - normalizeMsg [list [catch tproc2 msg] $msg $errorInfo $errorCode] + set msg [list [catch tproc2 msg] $msg $errorInfo $errorCode] + regsub -all [file join {} _bad_file_name] $msg "_bad_file_name" msg + normalizeMsg $msg } {1 {couldn't open "_bad_file_name": no such file or directory} {couldn't open "_bad_file_name": no such file or directory while executing "open _bad_file_name r" @@ -467,7 +473,9 @@ test proc-old-7.14 {return with special completion code} { catch {open _bad_file_name r} msg return -code error $msg } - normalizeMsg [list [catch tproc2 msg] $msg $errorInfo $errorCode] + set msg [list [catch tproc2 msg] $msg $errorInfo $errorCode] + regsub -all [file join {} _bad_file_name] $msg "_bad_file_name" msg + normalizeMsg $msg } {1 {couldn't open "_bad_file_name": no such file or directory} {couldn't open "_bad_file_name": no such file or directory while executing "tproc2"} none} diff --git a/tests/registry.test b/tests/registry.test index f9e7055..4b22cc8 100644 --- a/tests/registry.test +++ b/tests/registry.test @@ -10,7 +10,7 @@ # Copyright (c) 1997 by Sun Microsystems, Inc. All rights reserved. # Copyright (c) 1998-1999 by Scriptics Corporation. # -# RCS: @(#) $Id: registry.test,v 1.10 2000/04/10 17:19:03 ericm Exp $ +# RCS: @(#) $Id: registry.test,v 1.11 2001/07/31 19:12:07 vincentdarley Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -19,8 +19,8 @@ if {[lsearch [namespace children] ::tcltest] == -1} { if {$tcl_platform(platform) == "windows"} { if [catch { - set lib [lindex [glob [file join [pwd] [file dirname \ - [info nameofexecutable]] tclreg*.dll]] 0] + 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." diff --git a/tests/unixFCmd.test b/tests/unixFCmd.test index 7a388c8..d2d8f9d 100644 --- a/tests/unixFCmd.test +++ b/tests/unixFCmd.test @@ -9,7 +9,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: unixFCmd.test,v 1.11 2000/04/10 17:19:05 ericm Exp $ +# RCS: @(#) $Id: unixFCmd.test,v 1.12 2001/07/31 19:12:07 vincentdarley Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -32,7 +32,7 @@ proc openup {path} { testchmod 777 $path if {[file isdirectory $path]} { catch { - foreach p [glob [file join $path *]] { + foreach p [glob -directory $path *] { openup $p } } @@ -43,7 +43,7 @@ proc cleanup {args} { foreach p ". $args" { set x "" catch { - set x [glob [file join $p tf*] [file join $p td*]] + set x [glob -directory $p tf* td*] } foreach file $x { if {[catch {file delete -force -- $file}]} { diff --git a/tests/winDde.test b/tests/winDde.test index 90c51ed..3657d43 100644 --- a/tests/winDde.test +++ b/tests/winDde.test @@ -9,7 +9,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: winDde.test,v 1.9 2001/01/12 09:54:17 dkf Exp $ +# RCS: @(#) $Id: winDde.test,v 1.10 2001/07/31 19:12:07 vincentdarley Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -18,11 +18,11 @@ if {[lsearch [namespace children] ::tcltest] == -1} { if {$tcl_platform(platform) == "windows"} { if [catch { - set lib [lindex [glob [file join [pwd] [file dirname \ - [info nameofexecutable]] tcldde*.dll]] 0] + 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." + puts "Unable to find the dde package. Skipping dde tests." ::tcltest::cleanupTests return } @@ -38,11 +38,11 @@ proc createChildProcess { ddeServerName } { set f [open $::scriptName w+] puts $f { if [catch { - set lib [lindex [glob [file join [pwd] [file dirname \ - [info nameofexecutable]] tcldde*.dll]] 0] + 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." + puts "Unable to find the dde package. Skipping dde tests." ::tcltest::cleanupTests return } diff --git a/tests/winFCmd.test b/tests/winFCmd.test index 97fc2d5..b26f385 100644 --- a/tests/winFCmd.test +++ b/tests/winFCmd.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: winFCmd.test,v 1.9 2000/04/10 17:19:06 ericm Exp $ +# RCS: @(#) $Id: winFCmd.test,v 1.10 2001/07/31 19:12:07 vincentdarley Exp $ # if {[lsearch [namespace children] ::tcltest] == -1} { @@ -36,7 +36,7 @@ proc cleanup {args} { foreach p ". $args" { set x "" catch { - set x [glob [file join $p tf*] [file join $p td*]] + set x [glob -directory $p tf* td*] } if {$x != ""} { catch {eval file delete -force -- $x} diff --git a/unix/mkLinks b/unix/mkLinks index 1b57e15..fa82057 100644 --- a/unix/mkLinks +++ b/unix/mkLinks @@ -442,6 +442,74 @@ if test -r ExprLongObj.3; then ln ExprLongObj.3 Tcl_ExprBooleanObj.3 ln ExprLongObj.3 Tcl_ExprObj.3 fi +if test -r FileSystem.3; then + rm -f Tcl_FSCopyFile.3 + rm -f Tcl_FSCopyDirectory.3 + rm -f Tcl_FSCreateDirectory.3 + rm -f Tcl_FSDeleteFile.3 + rm -f Tcl_FSRemoveDirectory.3 + rm -f Tcl_FSRenameFile.3 + rm -f Tcl_FSListVolumes.3 + rm -f Tcl_FSEvalFile.3 + rm -f Tcl_FSLoadFile.3 + rm -f Tcl_FSMatchInDirectory.3 + rm -f Tcl_FSReadlink.3 + rm -f Tcl_FSLstat.3 + rm -f Tcl_FSUtime.3 + rm -f Tcl_FSFileAttrsGet.3 + rm -f Tcl_FSFileAttrsSet.3 + rm -f Tcl_FSFileAttrStrings.3 + rm -f Tcl_FSStat.3 + rm -f Tcl_FSAccess.3 + rm -f Tcl_FSOpenFileChannel.3 + rm -f Tcl_FSGetCwd.3 + rm -f Tcl_FSChdir.3 + rm -f Tcl_FSPathSeparator.3 + rm -f Tcl_FSJoinPath.3 + rm -f Tcl_FSSplitPath.3 + rm -f Tcl_FSEqualPaths.3 + rm -f Tcl_FSGetNormalizedPath.3 + rm -f Tcl_FSJoinToPath.3 + rm -f Tcl_FSConvertToPathType.3 + rm -f Tcl_FSGetInternalRep.3 + rm -f Tcl_FSGetTranslatedPath.3 + rm -f Tcl_FSNewNativePath.3 + rm -f Tcl_FSGetNativePath.3 + rm -f Tcl_FSFileSystemInfo.3 + ln FileSystem.3 Tcl_FSCopyFile.3 + ln FileSystem.3 Tcl_FSCopyDirectory.3 + ln FileSystem.3 Tcl_FSCreateDirectory.3 + ln FileSystem.3 Tcl_FSDeleteFile.3 + ln FileSystem.3 Tcl_FSRemoveDirectory.3 + ln FileSystem.3 Tcl_FSRenameFile.3 + ln FileSystem.3 Tcl_FSListVolumes.3 + ln FileSystem.3 Tcl_FSEvalFile.3 + ln FileSystem.3 Tcl_FSLoadFile.3 + ln FileSystem.3 Tcl_FSMatchInDirectory.3 + ln FileSystem.3 Tcl_FSReadlink.3 + ln FileSystem.3 Tcl_FSLstat.3 + ln FileSystem.3 Tcl_FSUtime.3 + ln FileSystem.3 Tcl_FSFileAttrsGet.3 + ln FileSystem.3 Tcl_FSFileAttrsSet.3 + ln FileSystem.3 Tcl_FSFileAttrStrings.3 + ln FileSystem.3 Tcl_FSStat.3 + ln FileSystem.3 Tcl_FSAccess.3 + ln FileSystem.3 Tcl_FSOpenFileChannel.3 + ln FileSystem.3 Tcl_FSGetCwd.3 + ln FileSystem.3 Tcl_FSChdir.3 + ln FileSystem.3 Tcl_FSPathSeparator.3 + ln FileSystem.3 Tcl_FSJoinPath.3 + ln FileSystem.3 Tcl_FSSplitPath.3 + ln FileSystem.3 Tcl_FSEqualPaths.3 + ln FileSystem.3 Tcl_FSGetNormalizedPath.3 + ln FileSystem.3 Tcl_FSJoinToPath.3 + ln FileSystem.3 Tcl_FSConvertToPathType.3 + ln FileSystem.3 Tcl_FSGetInternalRep.3 + ln FileSystem.3 Tcl_FSGetTranslatedPath.3 + ln FileSystem.3 Tcl_FSNewNativePath.3 + ln FileSystem.3 Tcl_FSGetNativePath.3 + ln FileSystem.3 Tcl_FSFileSystemInfo.3 +fi if test -r FindExec.3; then rm -f Tcl_FindExecutable.3 rm -f Tcl_GetNameOfExecutable.3 @@ -651,6 +719,8 @@ if test -r OpenFileChnl.3; then rm -f Tcl_GetChannelNamesEx.3 rm -f Tcl_RegisterChannel.3 rm -f Tcl_UnregisterChannel.3 + rm -f Tcl_DetachChannel.3 + rm -f Tcl_IsStandardChannel.3 rm -f Tcl_Close.3 rm -f Tcl_ReadChars.3 rm -f Tcl_Read.3 @@ -676,6 +746,8 @@ if test -r OpenFileChnl.3; then ln OpenFileChnl.3 Tcl_GetChannelNamesEx.3 ln OpenFileChnl.3 Tcl_RegisterChannel.3 ln OpenFileChnl.3 Tcl_UnregisterChannel.3 + ln OpenFileChnl.3 Tcl_DetachChannel.3 + ln OpenFileChnl.3 Tcl_IsStandardChannel.3 ln OpenFileChnl.3 Tcl_Close.3 ln OpenFileChnl.3 Tcl_ReadChars.3 ln OpenFileChnl.3 Tcl_Read.3 diff --git a/unix/tclUnixFCmd.c b/unix/tclUnixFCmd.c index 20998ca..e3d4d95 100644 --- a/unix/tclUnixFCmd.c +++ b/unix/tclUnixFCmd.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclUnixFCmd.c,v 1.6 2000/04/04 08:05:57 hobbs Exp $ + * RCS: @(#) $Id: tclUnixFCmd.c,v 1.7 2001/07/31 19:12:07 vincentdarley Exp $ * * Portions of this code were derived from NetBSD source code which has * the following copyright notice: @@ -150,6 +150,73 @@ static int TraverseUnixTree _ANSI_ARGS_(( Tcl_DString *sourcePtr, Tcl_DString *destPtr, Tcl_DString *errorPtr)); +int +TclpObjCreateDirectory(pathPtr) + Tcl_Obj *pathPtr; +{ + return TclpCreateDirectory(Tcl_FSGetTranslatedPath(NULL, pathPtr)); +} + +int +TclpObjDeleteFile(pathPtr) + Tcl_Obj *pathPtr; +{ + return TclpDeleteFile(Tcl_FSGetTranslatedPath(NULL, pathPtr)); +} + +int +TclpObjCopyDirectory(srcPathPtr, destPathPtr, errorPtr) + 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(srcPathPtr, destPathPtr) + Tcl_Obj *srcPathPtr; + Tcl_Obj *destPathPtr; +{ + return TclpCopyFile(Tcl_FSGetTranslatedPath(NULL,srcPathPtr), + Tcl_FSGetTranslatedPath(NULL,destPathPtr)); +} + +int +TclpObjRemoveDirectory(pathPtr, recursive, errorPtr) + 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(srcPathPtr, destPathPtr) + Tcl_Obj *srcPathPtr; + Tcl_Obj *destPathPtr; +{ + return TclpRenameFile(Tcl_FSGetTranslatedPath(NULL,srcPathPtr), + Tcl_FSGetTranslatedPath(NULL,destPathPtr)); +} + /* *--------------------------------------------------------------------------- * @@ -1609,3 +1676,52 @@ GetModeFromPermString(interp, modeStringPtr, modePtr) } 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; +} diff --git a/unix/tclUnixFile.c b/unix/tclUnixFile.c index 2679fdb..308a320 100644 --- a/unix/tclUnixFile.c +++ b/unix/tclUnixFile.c @@ -9,12 +9,14 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclUnixFile.c,v 1.9 2000/01/11 22:09:19 hobbs Exp $ + * RCS: @(#) $Id: tclUnixFile.c,v 1.10 2001/07/31 19:12:07 vincentdarley Exp $ */ #include "tclInt.h" #include "tclPort.h" +char * TclpGetCwd _ANSI_ARGS_((Tcl_Interp *interp, Tcl_DString *bufferPtr)); + /* *--------------------------------------------------------------------------- @@ -176,46 +178,49 @@ TclpFindExecutable(argv0) /* *---------------------------------------------------------------------- * - * TclpMatchFilesTypes -- + * TclpMatchInDirectory -- * * 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. + * 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 -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. */ +TclpMatchInDirectory(interp, resultPtr, pathPtr, pattern, 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. */ - char *tail; /* Pointer to end of pattern. Tail must - * point to a location in pattern and must - * not be static. */ - GlobTypeData *types; /* Object containing list of acceptable types. - * May be NULL. */ + Tcl_GlobTypeData *types; /* Object containing list of acceptable types. + * May be NULL. In particular the directory + * flag is very important. */ { - char *native, *fname, *dirName, *patternEnd = tail; - char savedChar = 0; /* lint. */ + char *native, *fname, *dirName; DIR *d; Tcl_DString ds; struct stat statBuf; int matchHidden; int result = TCL_OK; - int baseLength = Tcl_DStringLength(dirPtr); - Tcl_Obj *resultPtr; + 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,14 +229,21 @@ TclpMatchFilesTypes(interp, separators, dirPtr, pattern, tail, types) * otherwise "glob foo.c" would return "./foo.c". */ - if (Tcl_DStringLength(dirPtr) == 0) { + if (baseLength == 0) { dirName = "."; } else { - dirName = Tcl_DStringValue(dirPtr); + 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,6 +266,7 @@ TclpMatchFilesTypes(interp, separators, dirPtr, pattern, tail, types) d = opendir(native); /* INTL: Native. */ Tcl_DStringFree(&ds); if (d == NULL) { + char savedChar = '\0'; Tcl_ResetResult(interp); /* @@ -261,39 +274,21 @@ TclpMatchFilesTypes(interp, separators, dirPtr, pattern, tail, types) */ if (baseLength > 0) { - savedChar = (Tcl_DStringValue(dirPtr))[baseLength-1]; + savedChar = (Tcl_DStringValue(&dsOrig))[baseLength-1]; if (savedChar == '/') { - (Tcl_DStringValue(dirPtr))[baseLength-1] = '\0'; + (Tcl_DStringValue(&dsOrig))[baseLength-1] = '\0'; } } Tcl_AppendResult(interp, "couldn't read directory \"", - Tcl_DStringValue(dirPtr), "\": ", + Tcl_DStringValue(&dsOrig), "\": ", Tcl_PosixError(interp), (char *) NULL); if (baseLength > 0) { - (Tcl_DStringValue(dirPtr))[baseLength-1] = savedChar; + (Tcl_DStringValue(&dsOrig))[baseLength-1] = savedChar; } + Tcl_DStringFree(&dsOrig); 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; @@ -328,114 +323,85 @@ TclpMatchFilesTypes(interp, separators, dirPtr, pattern, tail, types) 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) { - struct stat buf; - - if (TclpStat(fname, &buf) != 0) { - panic("stat failed on known file"); - } - /* - * readonly means that there are NO write permissions - * (even for user), but execute is OK for anybody - */ - if ( - ((types->perm & TCL_GLOB_PERM_RONLY) && - (buf.st_mode & (S_IWOTH|S_IWGRP|S_IWUSR))) || - ((types->perm & TCL_GLOB_PERM_R) && - (TclpAccess(fname, R_OK) != 0)) || - ((types->perm & TCL_GLOB_PERM_W) && - (TclpAccess(fname, W_OK) != 0)) || - ((types->perm & TCL_GLOB_PERM_X) && - (TclpAccess(fname, X_OK) != 0)) - ) { - typeOk = 0; - } + int typeOk = 1; + + Tcl_DStringSetLength(&dsOrig, baseLength); + Tcl_DStringAppend(&dsOrig, utf, -1); + fname = Tcl_DStringValue(&dsOrig); + if (types != NULL) { + if (types->perm != 0) { + struct stat buf; + + if (TclpStat(fname, &buf) != 0) { + panic("stat failed on known file"); } - if (typeOk && (types->type != 0)) { - struct stat buf; + /* + * readonly means that there are NO write permissions + * (even for user), but execute is OK for anybody + */ + if ( + ((types->perm & TCL_GLOB_PERM_RONLY) && + (buf.st_mode & (S_IWOTH|S_IWGRP|S_IWUSR))) || + ((types->perm & TCL_GLOB_PERM_R) && + (TclpAccess(fname, R_OK) != 0)) || + ((types->perm & TCL_GLOB_PERM_W) && + (TclpAccess(fname, W_OK) != 0)) || + ((types->perm & TCL_GLOB_PERM_X) && + (TclpAccess(fname, X_OK) != 0)) + ) { + typeOk = 0; + } + } + if (typeOk && (types->type != 0)) { + struct stat buf; + /* + * We must match at least one flag to be listed + */ + typeOk = 0; + if (TclpLstat(fname, &buf) >= 0) { /* - * We must match at least one flag to be listed + * In order bcdpfls as in 'find -t' */ - typeOk = 0; - if (TclpLstat(fname, &buf) >= 0) { - /* - * In order bcdpfls as in 'find -t' - */ - if ( - ((types->type & TCL_GLOB_TYPE_BLOCK) && - S_ISBLK(buf.st_mode)) || - ((types->type & TCL_GLOB_TYPE_CHAR) && - S_ISCHR(buf.st_mode)) || - ((types->type & TCL_GLOB_TYPE_DIR) && - S_ISDIR(buf.st_mode)) || - ((types->type & TCL_GLOB_TYPE_PIPE) && - S_ISFIFO(buf.st_mode)) || - ((types->type & TCL_GLOB_TYPE_FILE) && - S_ISREG(buf.st_mode)) + if ( + ((types->type & TCL_GLOB_TYPE_BLOCK) && + S_ISBLK(buf.st_mode)) || + ((types->type & TCL_GLOB_TYPE_CHAR) && + S_ISCHR(buf.st_mode)) || + ((types->type & TCL_GLOB_TYPE_DIR) && + S_ISDIR(buf.st_mode)) || + ((types->type & TCL_GLOB_TYPE_PIPE) && + S_ISFIFO(buf.st_mode)) || + ((types->type & TCL_GLOB_TYPE_FILE) && + S_ISREG(buf.st_mode)) #ifdef S_ISLNK - || ((types->type & TCL_GLOB_TYPE_LINK) && - S_ISLNK(buf.st_mode)) + || ((types->type & TCL_GLOB_TYPE_LINK) && + S_ISLNK(buf.st_mode)) #endif #ifdef S_ISSOCK - || ((types->type & TCL_GLOB_TYPE_SOCK) && - S_ISSOCK(buf.st_mode)) + || ((types->type & TCL_GLOB_TYPE_SOCK) && + S_ISSOCK(buf.st_mode)) #endif - ) { - typeOk = 1; - } - } else { - /* Posix error occurred */ + ) { + typeOk = 1; } + } else { + /* Posix error occurred */ } } - 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; - } + } + if (typeOk) { + Tcl_ListObjAppendElement(interp, resultPtr, + Tcl_NewStringObj(fname, Tcl_DStringLength(&dsOrig))); } } Tcl_DStringFree(&ds); } - *patternEnd = savedChar; closedir(d); + Tcl_DStringFree(&dsOrig); 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); -} - /* *--------------------------------------------------------------------------- * @@ -693,4 +659,106 @@ TclpStat(path, bufPtr) return result; } + +int +TclpObjLstat(pathPtr, buf) + Tcl_Obj *pathPtr; + struct stat *buf; +{ + char *path = Tcl_FSGetNativePath(pathPtr); + if (path == NULL) { + return -1; + } else { + return lstat(path, buf); + } +} + +int +TclpObjStat(pathPtr, buf) + Tcl_Obj *pathPtr; + struct stat *buf; +{ + char *path = Tcl_FSGetNativePath(pathPtr); + if (path == NULL) { + return -1; + } else { + return stat(path, buf); + } +} + +Tcl_Obj* +TclpObjGetCwd(interp) + 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(pathPtr) + Tcl_Obj *pathPtr; +{ + char *path = Tcl_FSGetNativePath(pathPtr); + if (path == NULL) { + return -1; + } else { + return chdir(path); + } +} + +int +TclpObjAccess(pathPtr, mode) + Tcl_Obj *pathPtr; + int mode; +{ + char *path = Tcl_FSGetNativePath(pathPtr); + if (path == NULL) { + return -1; + } else { + return access(path, mode); + } +} + +#ifdef S_IFLNK + +Tcl_Obj* +TclpObjReadlink(pathPtr) + 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; + } + + /* + * Allocate and copy the name, taking care since the + * name need not be null terminated. + */ + native = (char*)ckalloc((unsigned)(1+length)); + strncpy(native, link, (unsigned)length); + native[length] = '\0'; + + linkPtr = Tcl_FSNewNativePath(pathPtr, native); + Tcl_IncrRefCount(linkPtr); + return linkPtr; +} + +#endif + + diff --git a/unix/tclUnixInit.c b/unix/tclUnixInit.c index 3fd7d1f..b75acd7 100644 --- a/unix/tclUnixInit.c +++ b/unix/tclUnixInit.c @@ -7,7 +7,7 @@ * Copyright (c) 1999 by Scriptics Corporation. * All rights reserved. * - * RCS: @(#) $Id: tclUnixInit.c,v 1.22 2001/07/02 20:57:02 dgp Exp $ + * RCS: @(#) $Id: tclUnixInit.c,v 1.23 2001/07/31 19:12:08 vincentdarley Exp $ */ #include "tclInt.h" @@ -29,6 +29,10 @@ */ #include "tclInitScript.h" +/* Used to store the encoding used for binary files */ +static Tcl_Encoding binaryEncoding = NULL; +/* Has the basic library path encoding issue been fixed */ +static int libraryPathEncodingFixed = 0; /* * Default directory in which to look for Tcl library scripts. The @@ -370,13 +374,18 @@ CONST char *path; /* Path to the executable in native * Based on the locale, determine the encoding of the operating * system and the default encoding for newly opened files. * - * Called at process initialization time. + * Called at process initialization time, and 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). * * Results: * None. * * Side effects: - * The Tcl library path is converted from native encoding to UTF-8. + * The Tcl library path is converted from native encoding to UTF-8, + * on the first call, and the encodings may be changed on first or + * second call. * *--------------------------------------------------------------------------- */ @@ -384,141 +393,147 @@ CONST char *path; /* Path to the executable in native void TclpSetInitialEncodings() { - CONST char *encoding; - int i; - Tcl_Obj *pathPtr; - char *langEnv; + if (libraryPathEncodingFixed == 0) { + CONST char *encoding; + int i; + Tcl_Obj *pathPtr; + char *langEnv; - /* - * Determine the current encoding from the LC_* or LANG environment - * variables. We previously used setlocale() to determine the locale, - * but this does not work on some systems (e.g. Linux/i386 RH 5.0). - */ + /* + * Determine the current encoding from the LC_* or LANG environment + * variables. We previously used setlocale() to determine the locale, + * but this does not work on some systems (e.g. Linux/i386 RH 5.0). + */ - langEnv = getenv("LC_ALL"); + langEnv = getenv("LC_ALL"); - if (langEnv == NULL || langEnv[0] == '\0') { - langEnv = getenv("LC_CTYPE"); - } - if (langEnv == NULL || langEnv[0] == '\0') { - langEnv = getenv("LANG"); - } - if (langEnv == NULL || langEnv[0] == '\0') { - langEnv = NULL; - } - - encoding = NULL; - if (langEnv != NULL) { - for (i = 0; localeTable[i].lang != NULL; i++) { - if (strcmp(localeTable[i].lang, langEnv) == 0) { - encoding = localeTable[i].encoding; - break; - } + if (langEnv == NULL || langEnv[0] == '\0') { + langEnv = getenv("LC_CTYPE"); + } + if (langEnv == NULL || langEnv[0] == '\0') { + langEnv = getenv("LANG"); + } + if (langEnv == NULL || langEnv[0] == '\0') { + langEnv = NULL; } - /* - * There was no mapping in the locale table. If there is an - * encoding subfield, we can try to guess from that. - */ - if (encoding == NULL) { - char *p; - for (p = langEnv; *p != '\0'; p++) { - if (*p == '.') { - p++; + encoding = NULL; + if (langEnv != NULL) { + for (i = 0; localeTable[i].lang != NULL; i++) { + if (strcmp(localeTable[i].lang, langEnv) == 0) { + encoding = localeTable[i].encoding; break; } } - if (*p != '\0') { - Tcl_DString ds; - Tcl_DStringInit(&ds); - Tcl_DStringAppend(&ds, p, -1); + /* + * There was no mapping in the locale table. If there is an + * encoding subfield, we can try to guess from that. + */ - encoding = Tcl_DStringValue(&ds); - Tcl_UtfToLower(Tcl_DStringValue(&ds)); - if (Tcl_SetSystemEncoding(NULL, encoding) == TCL_OK) { + if (encoding == NULL) { + char *p; + for (p = langEnv; *p != '\0'; p++) { + if (*p == '.') { + p++; + break; + } + } + if (*p != '\0') { + Tcl_DString ds; + Tcl_DStringInit(&ds); + Tcl_DStringAppend(&ds, p, -1); + + encoding = Tcl_DStringValue(&ds); + Tcl_UtfToLower(Tcl_DStringValue(&ds)); + if (Tcl_SetSystemEncoding(NULL, encoding) == TCL_OK) { + Tcl_DStringFree(&ds); + goto resetPath; + } Tcl_DStringFree(&ds); - goto resetPath; + encoding = NULL; } - Tcl_DStringFree(&ds); - encoding = NULL; } } - } - if (encoding == NULL) { - encoding = "iso8859-1"; - } + if (encoding == NULL) { + encoding = "iso8859-1"; + } - Tcl_SetSystemEncoding(NULL, encoding); + Tcl_SetSystemEncoding(NULL, encoding); - resetPath: - /* - * Initialize the C library's locale subsystem. This is required - * for input methods to work properly on X11. We only do this for - * LC_CTYPE because that's the necessary one, and we don't want to - * affect LC_TIME here. The side effect of setting the default locale - * should be to load any locale specific modules that are needed by X. - * [BUG: 5422 3345 4236 2522 2521]. - */ + resetPath: + /* + * Initialize the C library's locale subsystem. This is required + * for input methods to work properly on X11. We only do this for + * LC_CTYPE because that's the necessary one, and we don't want to + * affect LC_TIME here. The side effect of setting the default locale + * should be to load any locale specific modules that are needed by X. + * [BUG: 5422 3345 4236 2522 2521]. + */ - setlocale(LC_CTYPE, ""); + setlocale(LC_CTYPE, ""); - /* - * In case the initial locale is not "C", ensure that the numeric - * processing is done in "C" locale regardless. This is needed because - * Tcl relies on routines like strtod, but should not have locale - * dependent behavior. - */ + /* + * In case the initial locale is not "C", ensure that the numeric + * processing is done in "C" locale regardless. This is needed because + * Tcl relies on routines like strtod, but should not have locale + * dependent behavior. + */ - setlocale(LC_NUMERIC, "C"); + setlocale(LC_NUMERIC, "C"); - /* - * Until the system encoding was actually set, the library path was - * actually in the native multi-byte encoding, and not really UTF-8 - * as advertised. We cheated as follows: - * - * 1. It was safe to allow the Tcl_SetSystemEncoding() call to - * append the ASCII chars that make up the encoding's filename to - * the names (in the native encoding) of directories in the library - * path, since all Unix multi-byte encodings have ASCII in the - * beginning. - * - * 2. To open the encoding file, the native bytes in the file name - * were passed to the OS, without translating from UTF-8 to native, - * because the name was already in the native encoding. - * - * Now that the system encoding was actually successfully set, - * translate all the names in the library path to UTF-8. That way, - * next time we search the library path, we'll translate the names - * from UTF-8 to the system encoding which will be the native - * encoding. - */ + /* + * Until the system encoding was actually set, the library path was + * actually in the native multi-byte encoding, and not really UTF-8 + * as advertised. We cheated as follows: + * + * 1. It was safe to allow the Tcl_SetSystemEncoding() call to + * append the ASCII chars that make up the encoding's filename to + * the names (in the native encoding) of directories in the library + * path, since all Unix multi-byte encodings have ASCII in the + * beginning. + * + * 2. To open the encoding file, the native bytes in the file name + * were passed to the OS, without translating from UTF-8 to native, + * because the name was already in the native encoding. + * + * Now that the system encoding was actually successfully set, + * translate all the names in the library path to UTF-8. That way, + * next time we search the library path, we'll translate the names + * from UTF-8 to the system encoding which will be the native + * encoding. + */ - pathPtr = TclGetLibraryPath(); - if (pathPtr != NULL) { - int objc; - Tcl_Obj **objv; - - objc = 0; - Tcl_ListObjGetElements(NULL, pathPtr, &objc, &objv); - for (i = 0; i < objc; i++) { - int length; - char *string; - Tcl_DString ds; - - string = Tcl_GetStringFromObj(objv[i], &length); - Tcl_ExternalToUtfDString(NULL, string, length, &ds); - Tcl_SetStringObj(objv[i], Tcl_DStringValue(&ds), - Tcl_DStringLength(&ds)); - Tcl_DStringFree(&ds); - } - } + pathPtr = TclGetLibraryPath(); + if (pathPtr != NULL) { + int objc; + Tcl_Obj **objv; + + objc = 0; + Tcl_ListObjGetElements(NULL, pathPtr, &objc, &objv); + for (i = 0; i < objc; i++) { + int length; + char *string; + Tcl_DString ds; - /* - * Keep the iso8859-1 encoding preloaded. The IO package uses it for - * gets on a binary channel. - */ + string = Tcl_GetStringFromObj(objv[i], &length); + Tcl_ExternalToUtfDString(NULL, string, length, &ds); + Tcl_SetStringObj(objv[i], Tcl_DStringValue(&ds), + Tcl_DStringLength(&ds)); + Tcl_DStringFree(&ds); + } + } - Tcl_GetEncoding(NULL, "iso8859-1"); + libraryPathEncodingFixed = 1; + } + + /* This is only ever called from the startup thread */ + if (binaryEncoding == NULL) { + /* + * Keep the iso8859-1 encoding preloaded. The IO package uses + * it for gets on a binary channel. + */ + binaryEncoding = Tcl_GetEncoding(NULL, "iso8859-1"); + } } /* diff --git a/unix/tclUnixPipe.c b/unix/tclUnixPipe.c index 318b9c6..9da1b11 100644 --- a/unix/tclUnixPipe.c +++ b/unix/tclUnixPipe.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclUnixPipe.c,v 1.12 2001/05/15 21:23:31 hobbs Exp $ + * RCS: @(#) $Id: tclUnixPipe.c,v 1.13 2001/07/31 19:12:08 vincentdarley Exp $ */ #include "tclInt.h" @@ -221,6 +221,34 @@ TclpCreateTempFile(contents) /* *---------------------------------------------------------------------- * + * TclpTempFileName -- + * + * This function returns unique filename. + * + * Results: + * Returns a valid Tcl_Obj* with refCount 0, or NULL on failure. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj* +TclpTempFileName() +{ + char fileName[L_tmpnam]; + + if (tmpnam(fileName) == NULL) { /* INTL: Native. */ + return NULL; + } + + return TclpNativeToNormalized((ClientData) fileName); +} + +/* + *---------------------------------------------------------------------- + * * TclpCreatePipe -- * * Creates a pipe - simply calls the pipe() function. diff --git a/win/tclWinFCmd.c b/win/tclWinFCmd.c index bf80bf0..230723c 100644 --- a/win/tclWinFCmd.c +++ b/win/tclWinFCmd.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclWinFCmd.c,v 1.8 2000/05/22 23:55:09 hobbs Exp $ + * RCS: @(#) $Id: tclWinFCmd.c,v 1.9 2001/07/31 19:12:08 vincentdarley Exp $ */ #include "tclWinInt.h" @@ -103,6 +103,73 @@ static int TraverseWinTree(TraversalProc *traverseProc, Tcl_DString *errorPtr); +int +TclpObjCreateDirectory(pathPtr) + Tcl_Obj *pathPtr; +{ + return TclpCreateDirectory(Tcl_FSGetTranslatedPath(NULL, pathPtr)); +} + +int +TclpObjDeleteFile(pathPtr) + Tcl_Obj *pathPtr; +{ + return TclpDeleteFile(Tcl_FSGetTranslatedPath(NULL, pathPtr)); +} + +int +TclpObjCopyDirectory(srcPathPtr, destPathPtr, errorPtr) + 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(srcPathPtr, destPathPtr) + Tcl_Obj *srcPathPtr; + Tcl_Obj *destPathPtr; +{ + return TclpCopyFile(Tcl_FSGetTranslatedPath(NULL,srcPathPtr), + Tcl_FSGetTranslatedPath(NULL,destPathPtr)); +} + +int +TclpObjRemoveDirectory(pathPtr, recursive, errorPtr) + 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(srcPathPtr, destPathPtr) + Tcl_Obj *srcPathPtr; + Tcl_Obj *destPathPtr; +{ + return TclpRenameFile(Tcl_FSGetTranslatedPath(NULL,srcPathPtr), + Tcl_FSGetTranslatedPath(NULL,destPathPtr)); +} + /* *--------------------------------------------------------------------------- * @@ -1289,6 +1356,106 @@ GetWinFileAttributes( } /* + *--------------------------------------------------------------------------- + * + * 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,7 +1616,7 @@ cleanup: * * GetWinFileLongName -- * - * Returns a Tcl_Obj containing the short version of the file + * Returns a Tcl_Obj containing the long version of the file * name. * * Results: @@ -1662,3 +1829,100 @@ TclpListVolumes( } 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; +} diff --git a/win/tclWinFile.c b/win/tclWinFile.c index 1038758..c40a0b8 100644 --- a/win/tclWinFile.c +++ b/win/tclWinFile.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclWinFile.c,v 1.10 2001/07/17 19:40:37 mdejong Exp $ + * RCS: @(#) $Id: tclWinFile.c,v 1.11 2001/07/31 19:12:08 vincentdarley Exp $ */ #include "tclWinInt.h" @@ -89,17 +89,16 @@ TclpFindExecutable(argv0) /* *---------------------------------------------------------------------- * - * TclpMatchFilesTypes -- + * TclpMatchInDirectory -- * * 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. + * + * 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,54 +106,63 @@ TclpFindExecutable(argv0) *---------------------------------------------------------------------- */ 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. */ +TclpMatchInDirectory(interp, resultPtr, pathPtr, pattern, 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. */ + Tcl_GlobTypeData *types; /* Object containing list of acceptable types. + * May be NULL. In particular the directory + * flag is very important. */ { char drivePat[] = "?:\\"; const char *message; - char *dir, *newPattern, *root; - int matchDotFiles; - int dirLength, result = TCL_OK; - Tcl_DString dirString, patternString; + 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; - Tcl_Obj *resultPtr; - + int matchSpecialDots; + /* * 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); + 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(dirPtr), - Tcl_DStringLength(dirPtr)); + 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,14 +228,20 @@ TclpMatchFilesTypes( } /* - * 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. + * 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. */ - Tcl_DStringInit(&patternString); - newPattern = Tcl_DStringAppend(&patternString, pattern, tail - pattern); - Tcl_UtfToLower(newPattern); + 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,39 +259,14 @@ TclpMatchFilesTypes( } /* - * 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; char *name, *fname; + int typeOk = 1; if (tclWinProcs->useWide) { nativeName = (TCHAR *) data.w.cFileName; @@ -286,9 +275,17 @@ TclpMatchFilesTypes( } 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. We need to convert - * the file name to lower case for comparison purposes. Note that we + * 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,14 +294,9 @@ TclpMatchFilesTypes( * 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) { + if (Tcl_StringCaseMatch(name, pattern, 1) != 0) { nativeMatchResult = nativeName; } Tcl_DStringFree(&ds); @@ -315,96 +307,98 @@ TclpMatchFilesTypes( /* * 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. + * path. */ name = Tcl_WinTCharToUtf(nativeMatchResult, -1, &ds); - Tcl_DStringAppend(dirPtr, name, -1); + Tcl_DStringAppend(&dsOrig, name, -1); Tcl_DStringFree(&ds); - fname = Tcl_DStringValue(dirPtr); - nativeName = Tcl_WinUtfToTChar(fname, Tcl_DStringLength(dirPtr), &ds); + fname = Tcl_DStringValue(&dsOrig); + nativeName = Tcl_WinUtfToTChar(fname, Tcl_DStringLength(&dsOrig), &ds); /* * 'attr' represents the attributes of the file, but we only * want to retrieve this info if it is absolutely necessary - * because it is an expensive call. + * because it is an expensive call. Unfortunately, to deal + * with hidden files properly, we must always retrieve it. + * There are more modern Win32 APIs available which we should + * look into. */ - 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) && - (TclpAccess(fname, W_OK) != 0)) || - ((types->perm & TCL_GLOB_PERM_X) && - (TclpAccess(fname, X_OK) != 0)) - ) { - typeOk = 0; - } + 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 && types->type != 0) { - struct stat buf; + } + 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) && + (TclpAccess(fname, W_OK) != 0)) || + ((types->perm & TCL_GLOB_PERM_X) && + (TclpAccess(fname, X_OK) != 0)) + ) { + typeOk = 0; + } + } + if (typeOk && types->type != 0) { + struct stat buf; + /* + * We must match at least one flag to be listed + */ + typeOk = 0; + if (TclpLstat(fname, &buf) >= 0) { /* - * We must match at least one flag to be listed + * In order bcdpfls as in 'find -t' */ - typeOk = 0; - if (TclpLstat(fname, &buf) >= 0) { - /* - * In order bcdpfls as in 'find -t' - */ - if ( - ((types->type & TCL_GLOB_TYPE_BLOCK) && - S_ISBLK(buf.st_mode)) || - ((types->type & TCL_GLOB_TYPE_CHAR) && - S_ISCHR(buf.st_mode)) || - ((types->type & TCL_GLOB_TYPE_DIR) && - S_ISDIR(buf.st_mode)) || - ((types->type & TCL_GLOB_TYPE_PIPE) && - S_ISFIFO(buf.st_mode)) || - ((types->type & TCL_GLOB_TYPE_FILE) && - S_ISREG(buf.st_mode)) + if ( + ((types->type & TCL_GLOB_TYPE_BLOCK) && + S_ISBLK(buf.st_mode)) || + ((types->type & TCL_GLOB_TYPE_CHAR) && + S_ISCHR(buf.st_mode)) || + ((types->type & TCL_GLOB_TYPE_DIR) && + S_ISDIR(buf.st_mode)) || + ((types->type & TCL_GLOB_TYPE_PIPE) && + S_ISFIFO(buf.st_mode)) || + ((types->type & TCL_GLOB_TYPE_FILE) && + S_ISREG(buf.st_mode)) #ifdef S_ISLNK - || ((types->type & TCL_GLOB_TYPE_LINK) && - S_ISLNK(buf.st_mode)) + || ((types->type & TCL_GLOB_TYPE_LINK) && + S_ISLNK(buf.st_mode)) #endif #ifdef S_ISSOCK - || ((types->type & TCL_GLOB_TYPE_SOCK) && - S_ISSOCK(buf.st_mode)) + || ((types->type & TCL_GLOB_TYPE_SOCK) && + S_ISSOCK(buf.st_mode)) #endif - ) { - typeOk = 1; - } - } else { - /* Posix error occurred */ + ) { + typeOk = 1; } - } - } - 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; + } else { + /* Posix error occurred */ } - } + } + } + if (typeOk) { + Tcl_ListObjAppendElement(interp, resultPtr, + Tcl_NewStringObj(fname, Tcl_DStringLength(&dsOrig))); } /* * Free ds here to ensure that nativeName is valid above. @@ -412,43 +406,25 @@ TclpMatchFilesTypes( Tcl_DStringFree(&ds); - Tcl_DStringSetLength(dirPtr, dirLength); + Tcl_DStringSetLength(&dsOrig, dirLength); } FindClose(handle); Tcl_DStringFree(&dirString); - Tcl_DStringFree(&patternString); + Tcl_DStringFree(&dsOrig); - return result; + return TCL_OK; error: Tcl_DStringFree(&dirString); TclWinConvertError(GetLastError()); Tcl_ResetResult(interp); - Tcl_AppendResult(interp, message, Tcl_DStringValue(dirPtr), "\": ", + Tcl_AppendResult(interp, message, Tcl_DStringValue(&dsOrig), "\": ", Tcl_PosixError(interp), (char *) NULL); + Tcl_DStringFree(&dsOrig); 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); -} - /* *---------------------------------------------------------------------- * @@ -573,6 +549,7 @@ TclpGetUserHome(name, bufferPtr) return result; } + /* *--------------------------------------------------------------------------- @@ -813,7 +790,7 @@ TclpGetCwd(interp, bufferPtr) /* *---------------------------------------------------------------------- * - * TclpStat -- + * TclpObjStat -- * * This function replaces the library version of stat(), fixing * the following bugs: @@ -833,10 +810,10 @@ TclpGetCwd(interp, bufferPtr) *---------------------------------------------------------------------- */ -int -TclpStat(path, statPtr) - CONST char *path; /* Path of file to stat (UTF-8). */ - struct stat *statPtr; /* Filled with results of stat call. */ +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; @@ -853,12 +830,12 @@ TclpStat(path, statPtr) * call to FindFirstFile() will expand them, matching some other file. */ - if (strpbrk(path, "?*") != NULL) { + if (strpbrk(Tcl_FSGetTranslatedPath(NULL, pathPtr), "?*") != NULL) { Tcl_SetErrno(ENOENT); return -1; } - nativePath = Tcl_WinUtfToTChar(path, -1, &ds); + nativePath = (TCHAR *) Tcl_FSGetNativePath(pathPtr); handle = (*tclWinProcs->findFirstFileProc)(nativePath, &data); if (handle == INVALID_HANDLE_VALUE) { /* @@ -868,7 +845,6 @@ TclpStat(path, statPtr) attr = (*tclWinProcs->getFileAttributesProc)(nativePath); if (attr == 0xffffffff) { - Tcl_DStringFree(&ds); Tcl_SetErrno(ENOENT); return -1; } @@ -887,7 +863,6 @@ TclpStat(path, statPtr) (*tclWinProcs->getFullPathNameProc)(nativePath, MAX_PATH, nativeFullPath, &nativePart); - Tcl_DStringFree(&ds); fullPath = Tcl_WinTCharToUtf((TCHAR *) nativeFullPath, -1, &ds); dev = -1; @@ -932,7 +907,7 @@ TclpStat(path, statPtr) 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, '.'); + p = strrchr(Tcl_FSGetTranslatedPath(NULL, pathPtr), '.'); if (p != NULL) { if ((lstrcmpiA(p, ".exe") == 0) || (lstrcmpiA(p, ".com") == 0) @@ -1093,3 +1068,133 @@ TclWinResolveShortcut(bufferPtr) return 0; } #endif + +Tcl_Obj* +TclpObjGetCwd(interp) + 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(pathPtr) + 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(pathPtr, mode) + 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(pathPtr, buf) + Tcl_Obj *pathPtr; + struct stat *buf; { + return TclpObjStat(pathPtr,buf); +} + +#ifdef S_IFLNK + +Tcl_Obj* +TclpObjReadlink(pathPtr) + 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; +} diff --git a/win/tclWinInit.c b/win/tclWinInit.c index d657784..a1eb02a 100644 --- a/win/tclWinInit.c +++ b/win/tclWinInit.c @@ -7,7 +7,7 @@ * Copyright (c) 1998-1999 by Scriptics Corporation. * All rights reserved. * - * RCS: @(#) $Id: tclWinInit.c,v 1.26 2001/07/02 20:57:02 dgp Exp $ + * RCS: @(#) $Id: tclWinInit.c,v 1.27 2001/07/31 19:12:08 vincentdarley Exp $ */ #include "tclWinInt.h" @@ -72,6 +72,11 @@ static char* processors[NUMPROCESSORS] = { "intel", "mips", "alpha", "ppc" }; +/* Used to store the encoding used for binary files */ +static Tcl_Encoding binaryEncoding = NULL; +/* Has the basic library path encoding issue been fixed */ +static int libraryPathEncodingFixed = 0; + /* * The Init script (common to Windows and Unix platforms) is * defined in tkInitScript.h @@ -462,13 +467,18 @@ ToUtf( * Based on the locale, determine the encoding of the operating * system and the default encoding for newly opened files. * - * Called at process initialization time. + * Called at process initialization time, and 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). * * Results: * None. * * Side effects: - * The Tcl library path is converted from native encoding to UTF-8. + * The Tcl library path is converted from native encoding to UTF-8, + * on the first call, and the encodings may be changed on first or + * second call. * *--------------------------------------------------------------------------- */ @@ -478,45 +488,52 @@ TclpSetInitialEncodings() { CONST char *encoding; char buf[4 + TCL_INTEGER_SPACE]; - int platformId; - Tcl_Obj *pathPtr; - - platformId = TclWinGetPlatformId(); - - TclWinSetInterfaces(platformId == VER_PLATFORM_WIN32_NT); - wsprintfA(buf, "cp%d", GetACP()); - Tcl_SetSystemEncoding(NULL, buf); - - if (platformId != VER_PLATFORM_WIN32_NT) { - pathPtr = TclGetLibraryPath(); - if (pathPtr != NULL) { - int i, objc; - Tcl_Obj **objv; - - objc = 0; - Tcl_ListObjGetElements(NULL, pathPtr, &objc, &objv); - for (i = 0; i < objc; i++) { - int length; - char *string; - Tcl_DString ds; - - string = Tcl_GetStringFromObj(objv[i], &length); - Tcl_ExternalToUtfDString(NULL, string, length, &ds); - Tcl_SetStringObj(objv[i], Tcl_DStringValue(&ds), - Tcl_DStringLength(&ds)); - Tcl_DStringFree(&ds); + if (libraryPathEncodingFixed == 0) { + int platformId; + platformId = TclWinGetPlatformId(); + TclWinSetInterfaces(platformId == VER_PLATFORM_WIN32_NT); + + wsprintfA(buf, "cp%d", GetACP()); + Tcl_SetSystemEncoding(NULL, buf); + + if (platformId != VER_PLATFORM_WIN32_NT) { + Tcl_Obj *pathPtr = TclGetLibraryPath(); + if (pathPtr != NULL) { + int i, objc; + Tcl_Obj **objv; + + objc = 0; + Tcl_ListObjGetElements(NULL, pathPtr, &objc, &objv); + for (i = 0; i < objc; i++) { + int length; + char *string; + Tcl_DString ds; + + string = Tcl_GetStringFromObj(objv[i], &length); + Tcl_ExternalToUtfDString(NULL, string, length, &ds); + Tcl_SetStringObj(objv[i], Tcl_DStringValue(&ds), + Tcl_DStringLength(&ds)); + Tcl_DStringFree(&ds); + } } } + + libraryPathEncodingFixed = 1; + } else { + wsprintfA(buf, "cp%d", GetACP()); + Tcl_SetSystemEncoding(NULL, buf); } - /* - * Keep this encoding preloaded. The IO package uses it for gets on a - * binary channel. - */ - - encoding = "iso8859-1"; - Tcl_GetEncoding(NULL, encoding); + /* This is only ever called from the startup thread */ + if (binaryEncoding == NULL) { + /* + * Keep this encoding preloaded. The IO package uses it for + * gets on a binary channel. + */ + encoding = "iso8859-1"; + binaryEncoding = Tcl_GetEncoding(NULL, encoding); + } } /* diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c index 00635cf..432d956 100644 --- a/win/tclWinPipe.c +++ b/win/tclWinPipe.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclWinPipe.c,v 1.17 2001/07/17 01:45:30 hobbs Exp $ + * RCS: @(#) $Id: tclWinPipe.c,v 1.18 2001/07/31 19:12:08 vincentdarley Exp $ */ #include "tclWinInt.h" @@ -767,6 +767,34 @@ TclpCreateTempFile(contents) /* *---------------------------------------------------------------------- * + * TclpTempFileName -- + * + * This function returns a unique filename. + * + * Results: + * Returns a valid Tcl_Obj* with refCount 0, or NULL on failure. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj* +TclpTempFileName() +{ + WCHAR fileName[MAX_PATH]; + + if (TempFileName(fileName) == 0) { + return NULL; + } + + return TclpNativeToNormalized((ClientData) fileName); +} + +/* + *---------------------------------------------------------------------- + * * TclpCreatePipe -- * * Creates an anonymous pipe. |