ADDED ChangeLog Index: ChangeLog ================================================================== --- /dev/null +++ ChangeLog @@ -0,0 +1,3 @@ +2001-05-09 Vince Darley + + * initial distribution ADDED Makefile.in Index: Makefile.in ================================================================== --- /dev/null +++ Makefile.in @@ -0,0 +1,397 @@ +# Makefile.in -- +# +# This file is a Makefile for Sample TEA Extension. If it has the name +# "Makefile.in" then it is a template for a Makefile; to generate the +# actual Makefile, run "./configure", which is a configuration script +# generated by the "autoconf" program (constructs like "@foo@" will get +# replaced in the actual Makefile. +# +# Copyright (c) 1999 Scriptics Corporation. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: Makefile.in,v 1.1.1.1 2001/08/03 16:19:00 vincentdarley Exp $ + +#======================================================================== +# Edit the following few lines when writing a new extension +#======================================================================== + +#======================================================================== +# Change the name of the variable "vfs_LIB_FILE" to match the one +# used in the configure script. This is the parameterized name of the +# library that we are building. +#======================================================================== + +lib_BINARIES=$(vfs_LIB_FILE) +BINARIES=$(lib_BINARIES) + +#======================================================================== +# Enumerate the names of the source files included in this package. +# This will be used when a dist target is added to the Makefile. +#======================================================================== + +vfs_SOURCES = vfs.c +SOURCES = $(vfs_SOURCES) + +#======================================================================== +# Enumerate the names of the object files included in this package. +# These objects are created and linked into the final library. In +# most cases these object files will correspond to the source files +# above. +# +#======================================================================== + +vfs_OBJECTS = vfs.$(OBJEXT) +OBJECTS = $(vfs_OBJECTS) + +#======================================================================== +# The substitution of "vfs_LIB_FILE" into the variable name below +# allows us to refer to the objects for the library without knowing the name +# of the library in advance. It also lets us use the "$@" variable in +# the rule for building the library, so we can refer to both the list of +# objects and the library itself in a platform-independent manner. +#======================================================================== + +vfs_LIB_FILE = @vfs_LIB_FILE@ +$(vfs_LIB_FILE)_OBJECTS = $(vfs_OBJECTS) + +#======================================================================== +# This is a list of header files to be installed +#======================================================================== + +GENERIC_HDRS= + +#======================================================================== +# Add additional lines to handle any additional AC_SUBST cases that +# have been added to the configure script. +#======================================================================== + +SAMPLE_NEW_VAR=@SAMPLE_NEW_VAR@ + +#======================================================================== +# Nothing of the variables below this line need to be changed. Please +# check the TARGETS section below to make sure the make targets are +# correct. +#======================================================================== + +SHELL = @SHELL@ + +srcdir = @srcdir@ +top_srcdir = @top_srcdir@ +prefix = @prefix@ +exec_prefix = @exec_prefix@ + +bindir = @bindir@ +sbindir = @sbindir@ +libexecdir = @libexecdir@ +datadir = @datadir@ +sysconfdir = @sysconfdir@ +sharedstatedir = @sharedstatedir@ +localstatedir = @localstatedir@ +libdir = @libdir@ +infodir = @infodir@ +mandir = @mandir@ +includedir = @includedir@ +oldincludedir = /usr/include + +DESTDIR = + +pkgdatadir = $(datadir)/@PACKAGE@@VERSION@ +pkglibdir = $(libdir)/@PACKAGE@@VERSION@ +pkgincludedir = $(includedir)/@PACKAGE@@VERSION@ + +top_builddir = . + +INSTALL = @INSTALL@ +INSTALL_PROGRAM = @INSTALL_PROGRAM@ +INSTALL_DATA = @INSTALL_DATA@ +INSTALL_SCRIPT = @INSTALL_SCRIPT@ +INSTALL_STRIP_FLAG = +transform = @program_transform_name@ + +NORMAL_INSTALL = : +PRE_INSTALL = : +POST_INSTALL = : +NORMAL_UNINSTALL = : +PRE_UNINSTALL = : +POST_UNINSTALL = : + +PACKAGE = @PACKAGE@ +VERSION = @VERSION@ +CC = @CC@ +CFLAGS_DEBUG = @CFLAGS_DEBUG@ +CFLAGS_DEFAULT = @CFLAGS_DEFAULT@ +CFLAGS_OPTIMIZE = @CFLAGS_OPTIMIZE@ +CLEANFILES = @CLEANFILES@ +EXEEXT = @EXEEXT@ +LDFLAGS_DEBUG = @LDFLAGS_DEBUG@ +LDFLAGS_DEFAULT = @LDFLAGS_DEFAULT@ +LDFLAGS_OPTIMIZE = @LDFLAGS_OPTIMIZE@ +MAKE_LIB = @MAKE_LIB@ +MAKE_SHARED_LIB = @MAKE_SHARED_LIB@ +MAKE_STATIC_LIB = @MAKE_STATIC_LIB@ +OBJEXT = @OBJEXT@ +RANLIB = @RANLIB@ +SHLIB_CFLAGS = @SHLIB_CFLAGS@ +SHLIB_LD = @SHLIB_LD@ +SHLIB_LDFLAGS = @SHLIB_LDFLAGS@ +SHLIB_LD_LIBS = @SHLIB_LD_LIBS@ +STLIB_LD = @STLIB_LD@ +TCL_BIN_DIR = @TCL_BIN_DIR@ +TCL_DEFS = @TCL_DEFS@ +TCL_EXTRA_CFLAGS = @TCL_EXTRA_CFLAGS@ +TCL_LD_FLAGS = @TCL_LD_FLAGS@ +TCL_LIBS = @TCL_LIBS@ +TCL_SHLIB_LD_LIBS = @TCL_SHLIB_LD_LIBS@ +TCL_SRC_DIR = @TCL_SRC_DIR@ +TCL_DBGX = @TCL_DBGX@ +TCL_STUB_LIB_FILE = @TCL_STUB_LIB_FILE@ +TCL_STUB_LIB_SPEC = @TCL_STUB_LIB_SPEC@ +TCL_TOOL_DIR_NATIVE = @TCL_TOOL_DIR_NATIVE@ +TCL_TOP_DIR_NATIVE = @TCL_TOP_DIR_NATIVE@ +TCL_UNIX_DIR_NATIVE = @TCL_UNIX_DIR_NATIVE@ +TCL_WIN_DIR_NATIVE = @TCL_WIN_DIR_NATIVE@ +INCLUDE_DIR_NATIVE = @INCLUDE_DIR_NATIVE@ +TCL_BMAP_DIR_NATIVE = @TCL_BMAP_DIR_NATIVE@ +TCL_PLATFORM_DIR_NATIVE = @TCL_PLATFORM_DIR_NATIVE@ +TCL_GENERIC_DIR_NATIVE = @TCL_GENERIC_DIR_NATIVE@ +TCLSH_PROG = @TCLSH_PROG@ +SHARED_BUILD = @SHARED_BUILD@ + +AUTOCONF = autoconf + +LDFLAGS = $(LDFLAGS_DEFAULT) + +INCLUDES = @TCL_INCLUDES@ + +EXTRA_CFLAGS = $(TCL_DEFS) $(PROTO_FLAGS) $(SECURITY_FLAGS) $(MEM_DEBUG_FLAGS) $(KEYSYM_FLAGS) $(NO_DEPRECATED_FLAGS) $(TCL_EXTRA_CFLAGS) + +DEFS = @DEFS@ $(EXTRA_CFLAGS) + +ACLOCAL_M4 = $(top_srcdir)/aclocal.m4 +CONFIGDIR = $(top_srcdir) +mkinstalldirs = $(SHELL) $(CONFIGDIR)/mkinstalldirs +CONFIG_CLEAN_FILES = mkIndex.tcl + +CPPFLAGS = @CPPFLAGS@ +LIBS = @LIBS@ +AR = ar +CFLAGS = @CFLAGS@ +COMPILE = $(CC) $(DEFS) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) +CCLD = $(CC) +LINK = $(CCLD) $(AM_CFLAGS) $(CFLAGS) $(LDFLAGS) -o $@ + +#======================================================================== +# Start of user-definable TARGETS section +#======================================================================== + +#======================================================================== +# TEA TARGETS. Please note that the "libraries:" target refers to platform +# independent files, and the "binaries:" target inclues executable programs and +# platform-dependent libraries. Modify these targets so that they install +# the various pieces of your package. The make and install rules +# for the BINARIES that you specified above have already been done. +#======================================================================== + +all: binaries libraries doc + +#======================================================================== +# The binaries target builds executable programs, Windows .dll's, unix +# shared/static libraries, and any other platform-dependent files. +# The list of targets to build for "binaries:" is specified at the top +# of the Makefile, in the "BINARIES" variable. +#======================================================================== + +binaries: $(BINARIES) + +libraries: + +doc: + @echo "If you have documentation to create, place the commands to" + @echo "build the docs in the 'doc:' target. For example:" + @echo "" + @echo "xml2nroff VFS.xml > VFS.n" + @echo "xml2html VFS.xml > VFS.html" + +install: all install-binaries install-libraries install-doc + +install-binaries: binaries install-lib-binaries install-bin-binaries + $(TCLSH_PROG) mkIndex.tcl $(vfs_LIB_FILE) + if test "x$(SHARED_BUILD)" = "x1"; then \ + $(TCLSH_PROG) mkIndex.tcl $(vfs_LIB_FILE); \ + fi + +#======================================================================== +# This rule installs platform-independent files, such as header files. +#======================================================================== + +install-libraries: libraries + $(mkinstalldirs) $(includedir) + @echo "Installing header files in $(includedir)" + @for i in $(GENERIC_HDRS) ; do \ + echo "Installing $$i" ; \ + $(INSTALL_DATA) $$i $(includedir) ; \ + done; + +#======================================================================== +# Install documentation. Unix manpages should go in the $(mandir) +# directory. +#======================================================================== + +install-doc: doc + $(mkinstalldirs) $(mandir)/man1 + $(mkinstalldirs) $(mandir)/man3 + $(mkinstalldirs) $(mandir)/mann + @echo "Installing documentation in $(mandir)" + @for i in $(srcdir)/*.n; \ + do \ + echo "Installing $$i"; \ + rm -f $(mandir)/mann/$$i; \ + $(INSTALL_DATA) $$i $(mandir)/mann ; \ + done + +test: binaries libraries + ( echo \ + pkg_mkIndex . $(vfs_LIB_FILE) \;\ + exit; ) | \ + $(TCLSH_PROG) + TCL_LIBRARY=$(TCL_LIBRARY_DIR) \ + LD_LIBRARY_PATH=$(BUILD_DIR):$(TCL_BIN_DIR):$(LD_LIBRARY_PATH) \ + TCLLIBPATH=. \ + PATH="$(BUILD_DIR)":"$(TCL_BIN_DIR)":"$(PATH)" \ + $(TCLSH_PROG) `@CYGPATH@ $(srcdir)/tests/all.tcl` $(TCLTESTARGS) + +depend: + +#======================================================================== +# Enumerate the names of the object files included in this package. +# These objects are created and linked into the final library. In +# most cases these object files will correspond to the source files +# above. +# +# $(vfs_LIB_FILE) should be listed as part of the BINARIES variable +# at the top of the Makefile. That will ensure that this target is built +# when you run "make binaries". +# +# You shouldn't need to modify this target, except to change the package +# name from "VFS" to your package's name. +#======================================================================== + +$(vfs_LIB_FILE): $(vfs_OBJECTS) + -rm -f $(vfs_LIB_FILE) + @MAKE_LIB@ + $(RANLIB) $(vfs_LIB_FILE) + +#======================================================================== +# We need to enumerate the list of .c to .o lines here. +# Unfortunately, there does not seem to be any other way to do this +# in a Makefile-independent way. We can't use VPATH because it picks up +# object files that may be located in the source directory. +# +# In the following lines, $(srcdir) refers to the toplevel directory +# containing your extension. If your sources are in a subdirectory, +# you will have to modify the paths to reflect this: +# +# VFS.$(OBJEXT): $(srcdir)/src/win/VFS.c +# $(COMPILE) -c `@CYGPATH@ $(srcdir)/src/win/VFS.c` -o $@ +#======================================================================== + +vfs.$(OBJEXT): $(srcdir)/vfs.c + $(COMPILE) -c `@CYGPATH@ $(srcdir)/vfs.c` -o $@ + +#======================================================================== +# End of user-definable section +#======================================================================== + +#======================================================================== +# Don't modify the file to clean here. Instead, set the "CLEANFILES" +# variable in configure.in +#======================================================================== + +clean: + -test -z "$(BINARIES)" || rm -f $(BINARIES) + -rm -f *.o core *.core + -rm -f *.$(OBJEXT) + -test -z "$(CLEANFILES)" || rm -f $(CLEANFILES) + +distclean: clean + -rm -f *.tab.c + -rm -f Makefile $(CONFIG_CLEAN_FILES) + -rm -f config.cache config.log stamp-h stamp-h[0-9]* + -rm -f config.status + +#======================================================================== +# Install binary object libraries. On Windows this includes both .dll and +# .lib files. Because the .lib files are not explicitly listed anywhere, +# we need to deduce their existence from the .dll file of the same name. +# Additionally, the .dll files go into the bin directory, but the .lib +# files go into the lib directory. On Unix platforms, all library files +# go into the lib directory. In addition, this will generate the pkgIndex.tcl +# file in the install location (assuming it can find a usable tclsh8.2 shell) +# +# You should not have to modify this target. +#======================================================================== + +install-lib-binaries: installdirs + @list='$(lib_BINARIES)'; for p in $$list; do \ + if test -f $$p; then \ + ext=`echo $$p|sed -e "s/.*\.//"`; \ + if test "x$$ext" = "xdll"; then \ + echo " $(INSTALL_DATA) $$p $(DESTDIR)$(bindir)/$$p"; \ + $(INSTALL_DATA) $$p $(DESTDIR)$(bindir)/$$p; \ + lib=`basename $$p|sed -e 's/.[^.]*$$//'`.lib; \ + if test -f $$lib; then \ + echo " $(INSTALL_DATA) $$lib $(DESTDIR)$(libdir)/$$lib"; \ + $(INSTALL_DATA) $$lib $(DESTDIR)$(libdir)/$$lib; \ + fi; \ + else \ + echo " $(INSTALL_DATA) $$p $(DESTDIR)$(libdir)/$$p"; \ + $(INSTALL_DATA) $$p $(DESTDIR)$(libdir)/$$p; \ + fi; \ + else :; fi; \ + done + @list='$(lib_BINARIES)'; for p in $$list; do \ + if test -f $$p; then \ + echo " $(RANLIB) $(DESTDIR)$(libdir)/$$p"; \ + $(RANLIB) $(DESTDIR)$(libdir)/$$p; \ + else :; fi; \ + done + +#======================================================================== +# Install binary executables (e.g. .exe files) +# +# You should not have to modify this target. +#======================================================================== + +install-bin-binaries: installdirs + @list='$(bin_BINARIES)'; for p in $$list; do \ + if test -f $$p; then \ + echo " $(INSTALL_DATA) $$p $(DESTDIR)$(bindir)/$$p"; \ + $(INSTALL_DATA) $$p $(DESTDIR)$(bindir)/$$p; \ + else :; fi; \ + done + +.SUFFIXES: .c .o .obj + +Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status + cd $(top_builddir) \ + && CONFIG_FILES=$@ CONFIG_HEADERS= $(SHELL) ./config.status + +uninstall-binaries: + @$(NORMAL_UNINSTALL) + list='$(BINARIES)'; for p in $$list; do \ + rm -f $(DESTDIR)$(libdir)/$$p; \ + done + +installdirs: + $(mkinstalldirs) $(DESTDIR)$(libdir) + $(mkinstalldirs) $(DESTDIR)$(bindir) + $(mkinstalldirs) $(DESTDIR)$(pkglibdir) + +.PHONY: all binaries clean depend distclean doc install installdirs \ +libraries test + +# Tell versions [3.59,3.63) of GNU make to not export all variables. +# Otherwise a system limit (for SysV at least) may be exceeded. +.NOEXPORT: ADDED README.cygwin Index: README.cygwin ================================================================== --- /dev/null +++ README.cygwin @@ -0,0 +1,41 @@ +The information below is completely out of date. TEA is basically +hopeless on Windows, and I do not recommend you wasting your time +with it. No-one seems to take any interest in fixing the millions +of problems with TEA. + +There is a good old VC++ makefile in the 'win' directory, which seems to +work (I actually have to run it twice, but at least I get a .dll, which is +more than TEA provides). + +---------------------- + +To use cygwin for building TEA extensions, there are a couple of things +you will need to do. + +1. Make sure you have a working Visual C++ (version 5.0 or later) compiler. + +2. Download and install the free Cygnus Cywgin full tools package from + ftp://go.cygnus.com/pub/sourceware.cygnus.com/pub/cygwin/cygwin-b20/full.exe + +3. Create a directory called "C:\bin". Copy the sh.exe + program from the cygnus bin directory + (C:\cygnus\cygwin-b20\H-i586-cygwin32\bin\sh.exe) to "C:\bin". + This will allow you to run shell scripts that use the + "#!/bin/sh" invocation. + + Create another directory called "C:\tmp". The bash.exe program + requires this directory for storing temporary files. + +4. Set your environment variable "MAKE_MODE" to have the value "UNIX" + This will set up the "make" program to operate in a more sane manner. + +5. Run vcvars32.bat. You must do this every time you wish to + perform a build of an extension. It is strongly recommended + that you modify your sytem environment so that you don't have to + run vcvars32.bat all the time. If you look in the vcvars32.bat + file you will see what system environment variables need to be + set in order to make this work. + +6. If you are authoring a TEA extension, you will also want the GNU + autoconf package. This can be obtained from http://www.gnu.org + Autoconf version 2.13 or later is required. ADDED Readme.txt Index: Readme.txt ================================================================== --- /dev/null +++ Readme.txt @@ -0,0 +1,28 @@ +This is an implementation of a 'vfs' extension (and a 'vfs' package, +including a small library of Tcl code). The goal of this extension +is to expose Tcl 8.4a3's new filesystem C API to the Tcl level. + +Since 8.4 is still in alpha, the APIs on which this extension depends may of +course change (although this isn't too likely). If that happens, it will of +course require changes to this extension, until the point at which 8.4 goes +final, when only backwards-compatible changes should occur. + +The 'zip' vfs package should work (more or less). There is a framework for +a 'ftp' vfs package which needs filling in. + +Using this extension, the editor Alphatk can actually auto-mount, view and +edit (but not save, since they're read-only) the contents of .zip files +directly (see ). + +The 'tests' directory contains a partially modified version of some of +Tcl's core tests. They are modified in that there is a new 'fsIsWritable' +test constraint, which needs adding to several hundred tests (I've done +some of that work). + +To install, you probably want to rename the directory 'library' to 'vfs1.0' +and place it in your Tcl hierarchy, with the necessary shared library +inside. + +-- Vince Darley, August 1st 2001 + + ADDED aclocal.m4 Index: aclocal.m4 ================================================================== --- /dev/null +++ aclocal.m4 @@ -0,0 +1,1 @@ +builtin(include,tcl.m4) ADDED configure.in Index: configure.in ================================================================== --- /dev/null +++ configure.in @@ -0,0 +1,278 @@ +#-------------------------------------------------------------------- +# Sample configure.in for Tcl Extensions. The only places you should +# need to modify this file are marked by the string __CHANGE__ +#-------------------------------------------------------------------- + +#-------------------------------------------------------------------- +# __CHANGE__ +# This very first macro is used to verify that the configure script can +# find the sources. The argument to AC_INIT should be a unique filename +# for this package, and can be a relative path, such as: +# +# AC_INIT(../generic/tcl.h) +#-------------------------------------------------------------------- + +AC_INIT(vfs.c) + +#AC_CONFIG_AUX_DIR(config) +#CONFIGDIR=${srcdir}/config +#AC_SUBST(CONFIGDIR) + +#-------------------------------------------------------------------- +# __CHANGE__ +# Set your package name and version numbers here. The NODOT_VERSION is +# required for constructing the library name on systems that don't like +# dots in library names (Windows). The VERSION variable is used on the +# other systems. +#-------------------------------------------------------------------- + +PACKAGE=vfs + +MAJOR_VERSION=1 +MINOR_VERSION=0 +PATCHLEVEL= + +VERSION=${MAJOR_VERSION}.${MINOR_VERSION}${PATCHLEVEL} +NODOT_VERSION=${MAJOR_VERSION}${MINOR_VERSION} + + +AC_SUBST(PACKAGE) +AC_SUBST(VERSION) + +#-------------------------------------------------------------------- +# We put this here so that you can compile with -DVERSION="1.2" to +# encode the package version directly into the source files. +#-------------------------------------------------------------------- + +eval AC_DEFINE_UNQUOTED(VERSION, "${VERSION}") + +#-------------------------------------------------------------------- +# Check whether --enable-gcc or --disable-gcc was given. Do this +# before AC_CYGWIN is called so the compiler can +# be fully tested by built-in autoconf tools. +# This macro also calls AC_PROG_CC to set the compiler if --enable-gcc +# was not used. +#-------------------------------------------------------------------- + +SC_ENABLE_GCC +AC_PROG_INSTALL + +#-------------------------------------------------------------------- +# Checks to see if the make program sets the $MAKE variable. +#-------------------------------------------------------------------- + +AC_PROG_MAKE_SET + +#-------------------------------------------------------------------- +# Find ranlib +#-------------------------------------------------------------------- + +AC_PROG_RANLIB + +#-------------------------------------------------------------------- +# This macro performs additional compiler tests. +#-------------------------------------------------------------------- + +AC_CYGWIN + +#-------------------------------------------------------------------- +# Determines the correct binary file extension (.o, .obj, .exe etc.) +#-------------------------------------------------------------------- + +AC_OBJEXT +AC_EXEEXT + +#-------------------------------------------------------------------- +# "cygpath" is used on windows to generate native path names for include +# files. +# These variables should only be used with the compiler and linker since +# they generate native path names. +# +# Unix tclConfig.sh points SRC_DIR at the top-level directory of +# the Tcl sources, while the Windows tclConfig.sh points SRC_DIR at +# the win subdirectory. Hence the different usages of SRC_DIR below. +# +# This must be done before calling SC_PUBLIC_TCL_HEADERS +#-------------------------------------------------------------------- + +case "`uname -s`" in + *win32* | *WIN32* | *CYGWIN_NT*|*CYGWIN_98*|*CYGWIN_95*) + CYGPATH="cygpath -w" + ;; + *) + CYGPATH=echo + ;; +esac + +AC_SUBST(CYGPATH) + +#-------------------------------------------------------------------- +# Load the tclConfig.sh file +#-------------------------------------------------------------------- + +SC_PATH_TCLCONFIG +SC_LOAD_TCLCONFIG + +#-------------------------------------------------------------------- +# __CHANGE__ +# Choose which headers you need. Extension authors should try very +# hard to only rely on the Tcl public header files. Internal headers +# contain private data structures and are subject to change without +# notice. +# This MUST be called after SC_PATH_TCLCONFIG/SC_LOAD_TCLCONFIG +#-------------------------------------------------------------------- + +SC_PUBLIC_TCL_HEADERS +#SC_PRIVATE_TCL_HEADERS + +#-------------------------------------------------------------------- +# __CHANGE__ +# A few miscellaneous platform-specific items: +# +# Define a special symbol for Windows (BUILD_VFS in this case) so +# that we create the export library with the dll. See sha1.h on how +# to use this. +# +# Windows creates a few extra files that need to be cleaned up. +# You can add more files to clean if your extension creates any extra +# files. +# +# Define any extra compiler flags in the PACKAGE_CFLAGS variable. +# These will be appended to the current set of compiler flags for +# your system. +#-------------------------------------------------------------------- + +case "`uname -s`" in + *win32* | *WIN32* | *CYGWIN_NT*|*CYGWIN_98*|*CYGWIN_95*) + AC_DEFINE_UNQUOTED(BUILD_${PACKAGE}) + CLEANFILES="*.lib *.dll *.exp *.ilk *.pdb vc50.pch" + AC_SUBST(CLEANFILES) + ;; + *) + CLEANFILES= + ;; +esac + +#-------------------------------------------------------------------- +# Check whether --enable-threads or --disable-threads was given. +# So far only Tcl responds to this one. +#-------------------------------------------------------------------- + +SC_ENABLE_THREADS + +#-------------------------------------------------------------------- +# The statement below defines a collection of symbols related to +# building as a shared library instead of a static library. +#-------------------------------------------------------------------- + +SC_ENABLE_SHARED + +#-------------------------------------------------------------------- +# This macro figures out what flags to use with the compiler/linker +# when building shared/static debug/optimized objects. This information +# is all taken from the tclConfig.sh file. +#-------------------------------------------------------------------- + +CFLAGS_DEBUG=${TCL_CFLAGS_DEBUG} +CFLAGS_OPTIMIZE=${TCL_CFLAGS_OPTIMIZE} +LDFLAGS_DEBUG=${TCL_LDFLAGS_DEBUG} +LDFLAGS_OPTIMIZE=${TCL_LDFLAGS_OPTIMIZE} +SHLIB_LD=${TCL_SHLIB_LD} +STLIB_LD=${TCL_STLIB_LD} +SHLIB_CFLAGS=${TCL_SHLIB_CFLAGS} + +AC_SUBST(CFLAGS_DEBUG) +AC_SUBST(CFLAGS_OPTIMIZE) +AC_SUBST(STLIB_LD) +AC_SUBST(SHLIB_LD) +AC_SUBST(SHLIB_CFLAGS) +AC_SUBST(SHLIB_LDFLAGS) + +#-------------------------------------------------------------------- +# Set the default compiler switches based on the --enable-symbols +# option. +#-------------------------------------------------------------------- + +SC_ENABLE_SYMBOLS + +if test "${SHARED_BUILD}" = "1" ; then + CFLAGS='${CFLAGS_DEFAULT} ${CFLAGS_WARNING} ${SHLIB_CFLAGS}' +else + CFLAGS='${CFLAGS_DEFAULT} ${CFLAGS_WARNING}' +fi + +#-------------------------------------------------------------------- +# Everyone should be linking against the Tcl stub library. If you +# can't for some reason, remove this definition. If you aren't using +# stubs, you also need to modify the SHLIB_LD_LIBS setting below to +# link against the non-stubbed Tcl library. +#-------------------------------------------------------------------- + +AC_DEFINE(USE_TCL_STUBS) + +#-------------------------------------------------------------------- +# This macro generates a line to use when building a library. It +# depends on values set by the SC_ENABLE_SHARED, SC_ENABLE_SYMBOLS, +# and SC_LOAD_TCLCONFIG macros above. +#-------------------------------------------------------------------- + +SC_MAKE_LIB + +#-------------------------------------------------------------------- +# eval these two values to dereference the ${DBGX} variable. +#-------------------------------------------------------------------- + +eval "SHARED_LIB_SUFFIX=${TCL_SHARED_LIB_SUFFIX}" +eval "UNSHARED_LIB_SUFFIX=${TCL_UNSHARED_LIB_SUFFIX}" + +#-------------------------------------------------------------------- +# Shared libraries and static libraries have different names. +#-------------------------------------------------------------------- + +case "`uname -s`" in + *win32* | *WIN32* | *CYGWIN_NT*|*CYGWIN_98*|*CYGWIN_95*) + if test "${SHARED_BUILD}" = "1" ; then + SHLIB_LD_LIBS="\"`cygpath -w ${TCL_BIN_DIR}/${TCL_STUB_LIB_FILE}`\" ${TCL_SHLIB_LD_LIBS}" + eval "${PACKAGE}_LIB_FILE=${PACKAGE}${SHARED_LIB_SUFFIX}" + RANLIB=: + else + eval "${PACKAGE}_LIB_FILE=${PACKAGE}${UNSHARED_LIB_SUFFIX}" + fi + ;; + *) + if test "${SHARED_BUILD}" = "1" ; then + SHLIB_LD_LIBS="${TCL_STUB_LIB_SPEC}" + eval "${PACKAGE}_LIB_FILE=lib${PACKAGE}${SHARED_LIB_SUFFIX}" + RANLIB=: + else + eval "${PACKAGE}_LIB_FILE=lib${PACKAGE}${UNSHARED_LIB_SUFFIX}" + fi + ;; +esac + +AC_SUBST(SHARED_BUILD) + +#-------------------------------------------------------------------- +# __CHANGE__ +# Change the name from exampeA_LIB_FILE to match your package name. +#-------------------------------------------------------------------- + +AC_SUBST(vfs_LIB_FILE) +AC_SUBST(SHLIB_LD_LIBS) + +#-------------------------------------------------------------------- +# Find tclsh so that we can run pkg_mkIndex to generate the pkgIndex.tcl +# file during the install process. Don't run the TCLSH_PROG through +# ${CYGPATH} because it's being used directly by make. +# Require that we use a tclsh shell version 8.2 or later since earlier +# versions have bugs in the pkg_mkIndex routine. +#-------------------------------------------------------------------- + +SC_PROG_TCLSH + +#-------------------------------------------------------------------- +# Finally, substitute all of the various values into the Makefile. +#-------------------------------------------------------------------- + +AC_OUTPUT([Makefile \ + mkIndex.tcl]) ADDED generic/vfs.c Index: generic/vfs.c ================================================================== --- /dev/null +++ generic/vfs.c @@ -0,0 +1,1083 @@ +/* + * vfs.c -- + * + * This file contains the implementation of the Vfs extension + * to Tcl. It provides a script level interface to Tcl's + * virtual file system support, and therefore allows + * vfs's to be implemented in Tcl. + * + * Copyright (c) Vince Darley. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +#include +/* Required to access the 'stat' structure fields */ +#include "tclPort.h" + +/* + * Windows needs to know which symbols to export. Unix does not. + * BUILD_Vfs should be undefined for Unix. + */ + +#ifdef BUILD_Vfs +#undef TCL_STORAGE_CLASS +#define TCL_STORAGE_CLASS DLLEXPORT +#endif /* BUILD_Vfs */ + +/* + * Only the _Init function is exported. + */ + +EXTERN int Vfs_Init _ANSI_ARGS_((Tcl_Interp*)); + +/* + * Native representation for a path in a Tcl vfs. + */ + +typedef struct VfsNativeRep { + int splitPosition; + Tcl_Obj* fsCmd; +} VfsNativeRep; + +/* + * Structure we use to retain sufficient information about + * a channel that we can properly clean up all resources + * when the channel is closed. This is required when using + * 'open' on things inside the vfs. + */ + +typedef struct VfsChannelCleanupInfo { + Tcl_Channel channel; + Tcl_Obj* closeCallback; + Tcl_Interp* interp; +} VfsChannelCleanupInfo; + + +/* + * Forward declarations for procedures defined later in this file: + */ + +static int VfsFilesystemObjCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); + +/* + * Now we define the filesystem + */ + +static Tcl_FSStatProc VfsStat; +static Tcl_FSAccessProc VfsAccess; +static Tcl_FSOpenFileChannelProc VfsOpenFileChannel; +static Tcl_FSMatchInDirectoryProc VfsMatchInDirectory; +static Tcl_FSDeleteFileProc VfsDeleteFile; +static Tcl_FSCreateDirectoryProc VfsCreateDirectory; +static Tcl_FSRemoveDirectoryProc VfsRemoveDirectory; +static Tcl_FSFileAttrStringsProc VfsFileAttrStrings; +static Tcl_FSFileAttrsGetProc VfsFileAttrsGet; +static Tcl_FSFileAttrsSetProc VfsFileAttrsSet; +static Tcl_FSUtimeProc VfsUtime; +static Tcl_FSPathInFilesystemProc VfsInFilesystem; +static Tcl_FSFilesystemPathTypeProc VfsFilesystemPathType; +static Tcl_FSFilesystemSeparatorProc VfsFilesystemSeparator; +static Tcl_FSFreeInternalRepProc VfsFreeInternalRep; +static Tcl_FSDupInternalRepProc VfsDupInternalRep; + +static Tcl_Filesystem vfsFilesystem = { + "tclvfs", + sizeof(Tcl_Filesystem), + TCL_FILESYSTEM_VERSION_1, + &VfsInFilesystem, + &VfsDupInternalRep, + &VfsFreeInternalRep, + /* No native to normalized */ + NULL, + /* No create native rep function */ + NULL, + /* normalize path isn't needed */ + NULL, + &VfsFilesystemPathType, + &VfsFilesystemSeparator, + &VfsStat, + &VfsAccess, + &VfsOpenFileChannel, + &VfsMatchInDirectory, + &VfsUtime, + /* readlink and listvolumes are not important */ + NULL, + NULL, + &VfsFileAttrStrings, + &VfsFileAttrsGet, + &VfsFileAttrsSet, + &VfsCreateDirectory, + &VfsRemoveDirectory, + &VfsDeleteFile, + /* Use stat for lstat */ + NULL, + /* No copy file */ + NULL, + /* No rename file */ + NULL, + /* No copy directory */ + NULL, + /* No load, unload */ + NULL, + NULL, + /* We don't need a getcwd or chdir */ + NULL, + NULL +}; + +/* And some helper procedures */ + +static VfsNativeRep* VfsGetNativePath(Tcl_Obj* pathObjPtr); +static Tcl_CloseProc VfsCloseProc; +static void VfsExitProc(ClientData clientData); +static Tcl_Obj* VfsCommand(Tcl_Interp* interp, CONST char* cmd, + Tcl_Obj * pathPtr); + +/* + * Hard-code platform dependencies. We do not need to worry + * about backslash-separators on windows, because a normalized + * path will never contain them. + */ +#ifdef MAC_TCL + #define VFS_SEPARATOR ':' +#else + #define VFS_SEPARATOR '/' +#endif + + + +/* + *---------------------------------------------------------------------- + * + * Vfs_Init -- + * + * This procedure is the main initialisation point of the Vfs + * extension. + * + * Results: + * Returns a standard Tcl completion code, and leaves an error + * message in the interp's result if an error occurs. + * + * Side effects: + * Adds a command to the Tcl interpreter. + * + *---------------------------------------------------------------------- + */ + +int +Vfs_Init(interp) + Tcl_Interp *interp; /* Interpreter for application. */ +{ + if (Tcl_InitStubs(interp, "8.4", 0) == NULL) { + return TCL_ERROR; + } + if (Tcl_PkgRequire(interp, "Tcl", "8.4", 0) == NULL) { + return TCL_ERROR; + } + if (Tcl_PkgProvide(interp, "vfs", "1.0") == TCL_ERROR) { + return TCL_ERROR; + } + + /* + * Create additional commands. + */ + + Tcl_CreateObjCommand(interp, "vfs::filesystem", VfsFilesystemObjCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + /* Register our filesystem */ + Tcl_FSRegister((ClientData)interp, &vfsFilesystem); + Tcl_CreateExitHandler(VfsExitProc, (ClientData)NULL); + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * VfsFilesystemObjCmd -- + * + * This procedure implements the "vfs::filesystem" command. It is + * used to (un)register the vfs filesystem, and to mount/unmount + * particular interfaces to new filesystems, or to query for + * what is mounted where. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Inserts or removes a filesystem from Tcl's stack. + * + *---------------------------------------------------------------------- + */ + +static int +VfsFilesystemObjCmd(dummy, interp, objc, objv) + ClientData dummy; + Tcl_Interp *interp; + int objc; + Tcl_Obj *CONST objv[]; +{ + int index; + + static char *optionStrings[] = { + "info", "mount", "unmount", + NULL + }; + enum options { + VFS_INFO, VFS_MOUNT, VFS_UNMOUNT + }; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?"); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0, + &index) != TCL_OK) { + return TCL_ERROR; + } + + switch ((enum options) index) { + case VFS_MOUNT: { + Tcl_Obj * path; + Tcl_Interp* vfsInterp; + if (objc != 4) { + Tcl_WrongNumArgs(interp, 1, objv, "mount path cmd"); + return TCL_ERROR; + } + vfsInterp = (Tcl_Interp*) Tcl_FSData(&vfsFilesystem); + if (vfsInterp == NULL) { + Tcl_SetResult(interp, "vfs not registered", TCL_STATIC); + return TCL_ERROR; + } + path = Tcl_FSGetNormalizedPath(interp, objv[2]); + if (Tcl_SetVar2Ex(vfsInterp, "vfs::mount", + Tcl_GetString(path), objv[3], + TCL_LEAVE_ERR_MSG | TCL_GLOBAL_ONLY) == NULL) { + return TCL_ERROR; + } + break; + } + case VFS_INFO: { + Tcl_Obj * path; + Tcl_Interp* vfsInterp; + Tcl_Obj * val; + if (objc > 3) { + Tcl_WrongNumArgs(interp, 2, objv, "path"); + return TCL_ERROR; + } + vfsInterp = (Tcl_Interp*) Tcl_FSData(&vfsFilesystem); + if (vfsInterp == NULL) { + Tcl_SetResult(interp, "vfs not registered", TCL_STATIC); + return TCL_ERROR; + } + if (objc == 2) { + /* List all vfs paths */ + Tcl_GlobalEval(interp, "array names ::vfs::mount"); + } else { + path = Tcl_FSGetNormalizedPath(interp, objv[2]); + val = Tcl_GetVar2Ex(vfsInterp, "vfs::mount", Tcl_GetString(path), + TCL_LEAVE_ERR_MSG | TCL_GLOBAL_ONLY); + + if (val == NULL) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, val); + } + break; + } + case VFS_UNMOUNT: { + Tcl_Obj * path; + Tcl_Interp* vfsInterp; + int res; + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "path"); + return TCL_ERROR; + } + vfsInterp = (Tcl_Interp*) Tcl_FSData(&vfsFilesystem); + if (vfsInterp == NULL) { + Tcl_SetResult(interp, "vfs not registered", TCL_STATIC); + return TCL_ERROR; + } + path = Tcl_FSGetNormalizedPath(interp, objv[2]); + res = Tcl_UnsetVar2(vfsInterp, "vfs::mount", Tcl_GetString(path), + TCL_LEAVE_ERR_MSG | TCL_GLOBAL_ONLY); + return res; + } + } + return TCL_OK; +} + +int +VfsInFilesystem(Tcl_Obj *pathPtr, ClientData *clientDataPtr) { + Tcl_Obj *normedObj; + int len, splitPosition; + char *normed; + Tcl_Interp* interp; + VfsNativeRep *nativeRep; + Tcl_Obj* mountCmd = NULL; + + /* + * Even Tcl_FSGetNormalizedPath may fail due to lack of system + * encodings, so we just say we can't handle anything if + * we are in the middle of the exit sequence. We could + * perhaps be more subtle than this! + */ + if (TclInExit()) { + return -1; + } + + interp = (Tcl_Interp*) Tcl_FSData(&vfsFilesystem); + if (interp == NULL) { + /* This is bad, but not much we can do about it */ + return -1; + } + + normedObj = Tcl_FSGetNormalizedPath(interp, pathPtr); + if (normedObj == NULL) { + return -1; + } + normed = Tcl_GetStringFromObj(normedObj, &len); + splitPosition = len; + + /* + * Find the most specific mount point for this path. + * Mount points are specified by unique strings, so + * we have to use a unique normalised path for the + * checks here. + */ + while (mountCmd == NULL) { + mountCmd = Tcl_GetVar2Ex(interp, "vfs::mount", normed, + TCL_GLOBAL_ONLY); + + if (mountCmd != NULL) break; + if (splitPosition != len) { + normed[splitPosition] = VFS_SEPARATOR; + } + while ((splitPosition > 0) + && (normed[--splitPosition] != VFS_SEPARATOR)) { + /* Do nothing */ + } + /* Terminate the string there */ + if (splitPosition == 0) { + break; + } + normed[splitPosition] = 0; + } + + /* + * Now either splitPosition is zero, or we found a mount point. + * Test for both possibilities, just to be sure. + */ + if ((splitPosition == 0) || (mountCmd == NULL)) { + return -1; + } + if (splitPosition != len) { + normed[splitPosition] = VFS_SEPARATOR; + } + nativeRep = (VfsNativeRep*) ckalloc(sizeof(VfsNativeRep)); + nativeRep->splitPosition = splitPosition; + nativeRep->fsCmd = mountCmd; + Tcl_IncrRefCount(nativeRep->fsCmd); + *clientDataPtr = (ClientData)nativeRep; + return TCL_OK; +} + +VfsNativeRep* +VfsGetNativePath(Tcl_Obj* pathObjPtr) { + return (VfsNativeRep*) Tcl_FSGetInternalRep(pathObjPtr, &vfsFilesystem); +} + +void +VfsFreeInternalRep(ClientData clientData) { + VfsNativeRep *nativeRep = (VfsNativeRep*)clientData; + if (nativeRep != NULL) { + /* Free the command to use on this mount point */ + Tcl_DecrRefCount(nativeRep->fsCmd); + /* Free the native memory allocation */ + ckfree((char*)nativeRep); + } +} + +ClientData +VfsDupInternalRep(ClientData clientData) { + VfsNativeRep *original = (VfsNativeRep*)clientData; + + VfsNativeRep *nativeRep = (VfsNativeRep*) ckalloc(sizeof(VfsNativeRep)); + nativeRep->splitPosition = original->splitPosition; + nativeRep->fsCmd = original->fsCmd; + Tcl_IncrRefCount(nativeRep->fsCmd); + + return (ClientData)nativeRep; +} + +Tcl_Obj* +VfsFilesystemPathType(Tcl_Obj *pathPtr) { + VfsNativeRep* nativeRep = VfsGetNativePath(pathPtr); + if (nativeRep == NULL) { + return NULL; + } else { + return nativeRep->fsCmd; + } +} + +Tcl_Obj* +VfsFilesystemSeparator(Tcl_Obj* pathObjPtr) { + return Tcl_NewStringObj("/",1); +} + +int +VfsStat(pathPtr, bufPtr) + Tcl_Obj *pathPtr; /* Path of file to stat (in current CP). */ + struct stat *bufPtr; /* Filled with results of stat call. */ +{ + Tcl_Obj *mountCmd = NULL; + Tcl_SavedResult savedResult; + int returnVal; + Tcl_Interp* interp; + + interp = (Tcl_Interp*) Tcl_FSData(&vfsFilesystem); + mountCmd = VfsCommand(interp, "stat", pathPtr); + if (mountCmd == NULL) { + return -1; + } + + Tcl_SaveResult(interp, &savedResult); + /* Now we execute this mount point's callback. */ + returnVal = Tcl_EvalObjEx(interp, mountCmd, + TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT); + if (returnVal == TCL_OK) { + int statListLength; + Tcl_Obj* resPtr = Tcl_GetObjResult(interp); + if (Tcl_ListObjLength(interp, resPtr, &statListLength) == TCL_ERROR) { + returnVal = TCL_ERROR; + } else if (statListLength & 1) { + /* It is odd! */ + returnVal = TCL_ERROR; + } else { + /* + * The st_mode field is set part by the 'mode' + * and part by the 'type' stat fields. + */ + bufPtr->st_mode = 0; + while (statListLength > 0) { + Tcl_Obj *field, *val; + char *fieldName; + statListLength -= 2; + Tcl_ListObjIndex(interp, resPtr, statListLength, &field); + Tcl_ListObjIndex(interp, resPtr, statListLength+1, &val); + fieldName = Tcl_GetString(field); + if (!strcmp(fieldName,"dev")) { + long v; + if (Tcl_GetLongFromObj(interp, val, &v) != TCL_OK) { + returnVal = TCL_ERROR; + break; + } + bufPtr->st_dev = v; + } else if (!strcmp(fieldName,"ino")) { + long v; + if (Tcl_GetLongFromObj(interp, val, &v) != TCL_OK) { + returnVal = TCL_ERROR; + break; + } + bufPtr->st_ino = (unsigned short)v; + } else if (!strcmp(fieldName,"mode")) { + int v; + if (Tcl_GetIntFromObj(interp, val, &v) != TCL_OK) { + returnVal = TCL_ERROR; + break; + } + bufPtr->st_mode |= v; + } else if (!strcmp(fieldName,"nlink")) { + long v; + if (Tcl_GetLongFromObj(interp, val, &v) != TCL_OK) { + returnVal = TCL_ERROR; + break; + } + bufPtr->st_nlink = (short)v; + } else if (!strcmp(fieldName,"uid")) { + long v; + if (Tcl_GetLongFromObj(interp, val, &v) != TCL_OK) { + returnVal = TCL_ERROR; + break; + } + bufPtr->st_uid = (short)v; + } else if (!strcmp(fieldName,"gid")) { + long v; + if (Tcl_GetLongFromObj(interp, val, &v) != TCL_OK) { + returnVal = TCL_ERROR; + break; + } + bufPtr->st_gid = (short)v; + } else if (!strcmp(fieldName,"size")) { + long v; + if (Tcl_GetLongFromObj(interp, val, &v) != TCL_OK) { + returnVal = TCL_ERROR; + break; + } + bufPtr->st_size = v; + } else if (!strcmp(fieldName,"atime")) { + long v; + if (Tcl_GetLongFromObj(interp, val, &v) != TCL_OK) { + returnVal = TCL_ERROR; + break; + } + bufPtr->st_atime = v; + } else if (!strcmp(fieldName,"mtime")) { + long v; + if (Tcl_GetLongFromObj(interp, val, &v) != TCL_OK) { + returnVal = TCL_ERROR; + break; + } + bufPtr->st_mtime = v; + } else if (!strcmp(fieldName,"ctime")) { + long v; + if (Tcl_GetLongFromObj(interp, val, &v) != TCL_OK) { + returnVal = TCL_ERROR; + break; + } + bufPtr->st_ctime = v; + } else if (!strcmp(fieldName,"type")) { + char *str; + str = Tcl_GetString(val); + if (!strcmp(str,"directory")) { + bufPtr->st_mode |= S_IFDIR; + } else if (!strcmp(str,"file")) { + bufPtr->st_mode |= S_IFREG; + } else { + /* + * Do nothing. This means we do not currently + * support anything except files and directories + */ + } + } else { + /* Ignore additional stat arguments */ + } + } + } + } + + Tcl_RestoreResult(interp, &savedResult); + Tcl_DecrRefCount(mountCmd); + + if (returnVal != 0) { + Tcl_SetErrno(ENOENT); + return -1; + } else { + return returnVal; + } +} + +int +VfsAccess(pathPtr, mode) + Tcl_Obj *pathPtr; /* Path of file to access (in current CP). */ + int mode; /* Permission setting. */ +{ + Tcl_Obj *mountCmd = NULL; + Tcl_SavedResult savedResult; + int returnVal; + Tcl_Interp* interp; + + interp = (Tcl_Interp*) Tcl_FSData(&vfsFilesystem); + mountCmd = VfsCommand(interp, "access", pathPtr); + if (mountCmd == NULL) { + return -1; + } + + Tcl_ListObjAppendElement(interp, mountCmd, Tcl_NewIntObj(mode)); + /* Now we execute this mount point's callback. */ + Tcl_SaveResult(interp, &savedResult); + returnVal = Tcl_EvalObjEx(interp, mountCmd, + TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT); + Tcl_RestoreResult(interp, &savedResult); + Tcl_DecrRefCount(mountCmd); + + if (returnVal != 0) { + Tcl_SetErrno(ENOENT); + return -1; + } else { + return returnVal; + } +} + +Tcl_Channel +VfsOpenFileChannel(cmdInterp, pathPtr, modeString, permissions) + Tcl_Interp *cmdInterp; /* Interpreter for error reporting; + * can be NULL. */ + Tcl_Obj *pathPtr; /* Name of file to open. */ + char *modeString; /* A list of POSIX open modes or + * a string such as "rw". */ + int permissions; /* If the open involves creating a + * file, with what modes to create + * it? */ +{ + Tcl_Channel chan = NULL; + VfsChannelCleanupInfo *channelRet = NULL; + Tcl_Obj *mountCmd = NULL; + Tcl_SavedResult savedResult; + int returnVal; + Tcl_Interp* interp; + + interp = (Tcl_Interp*) Tcl_FSData(&vfsFilesystem); + mountCmd = VfsCommand(interp, "open", pathPtr); + if (mountCmd == NULL) { + return NULL; + } + + Tcl_ListObjAppendElement(interp, mountCmd, Tcl_NewStringObj(modeString,-1)); + Tcl_ListObjAppendElement(interp, mountCmd, Tcl_NewIntObj(permissions)); + Tcl_SaveResult(interp, &savedResult); + /* Now we execute this mount point's callback. */ + returnVal = Tcl_EvalObjEx(interp, mountCmd, + TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT); + if (returnVal == TCL_OK) { + int reslen; + Tcl_Obj *resultObj; + /* + * There may be file channel leaks on these two + * error conditions, if the open command actually + * created a channel, but then passed us a bogus list. + */ + resultObj = Tcl_GetObjResult(interp); + if ((Tcl_ListObjLength(interp, resultObj, &reslen) == TCL_ERROR) + || (reslen > 2) || (reslen == 0)) { + returnVal = TCL_ERROR; + } else { + Tcl_Obj *element; + Tcl_Channel theChannel = NULL; + Tcl_ListObjIndex(interp, resultObj, 0, &element); + theChannel = Tcl_GetChannel(interp, Tcl_GetString(element), 0); + + if (theChannel == NULL) { + returnVal == TCL_ERROR; + } else { + channelRet = (VfsChannelCleanupInfo*) + ckalloc(sizeof(VfsChannelCleanupInfo)); + channelRet->channel = theChannel; + if (reslen == 2) { + Tcl_ListObjIndex(interp, resultObj, 1, &element); + channelRet->closeCallback = element; + Tcl_IncrRefCount(channelRet->closeCallback); + channelRet->interp = interp; + } else { + channelRet->closeCallback = NULL; + channelRet->interp = NULL; + } + } + } + } else { + /* + * Copy over the error message to cmdInterp, duplicating it in + * case of threading issues. + */ + Tcl_SetObjResult(cmdInterp, Tcl_DuplicateObj(Tcl_GetObjResult(interp))); + } + + Tcl_RestoreResult(interp, &savedResult); + Tcl_DecrRefCount(mountCmd); + + if (channelRet != NULL) { + /* + * This is a pain. We got the Channel from some Tcl code. + * This means it was registered with the interpreter. But we + * want a pristine channel which hasn't been registered with + * anyone. We use Tcl_DetachChannel to do this for us. + */ + chan = channelRet->channel; + /* We must use the correct interpreter, not our own 'vfs' interpreter */ + Tcl_DetachChannel(channelRet->interp, chan); + if (channelRet->closeCallback != NULL) { + Tcl_CreateCloseHandler(chan, &VfsCloseProc, (ClientData)channelRet); + /* The channelRet structure will be freed in the callback */ + } else { + ckfree((char*)channelRet); + } + } + return chan; +} + +/* + * IMPORTANT: This procedure must *not* modify the interpreter's result + * this leads to the objResultPtr being corrupted (somehow), and curious + * crashes in the future (which are very hard to debug ;-). + */ +void +VfsCloseProc(ClientData clientData) { + VfsChannelCleanupInfo * channelRet = (VfsChannelCleanupInfo*) clientData; + Tcl_SavedResult savedResult; + Tcl_Channel chan = channelRet->channel; + Tcl_Interp * interp = channelRet->interp; + + Tcl_SaveResult(interp, &savedResult); + + /* + * The interpreter needs to know about the channel, else the Tcl + * callback will fail, so we register the channel (this allows + * the Tcl code to use the channel's string-name). + */ + Tcl_RegisterChannel(interp, chan); + Tcl_EvalObjEx(interp, channelRet->closeCallback, + TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT); + Tcl_DecrRefCount(channelRet->closeCallback); + + /* + * More complications; we can't just unregister the channel, + * because it is in the middle of being cleaned up, and the cleanup + * code doesn't like a channel to be closed again while it is + * already being closed. So, we do the same trick as above to + * unregister it without cleanup. + */ + Tcl_DetachChannel(interp, chan); + + Tcl_RestoreResult(interp, &savedResult); + ckfree((char*)channelRet); +} + +int +VfsMatchInDirectory( + Tcl_Interp *cmdInterp, /* Interpreter to receive results. */ + Tcl_Obj *returnPtr, /* Interpreter to receive results. */ + 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. */ +{ + Tcl_Obj *mountCmd = NULL; + Tcl_SavedResult savedResult; + int returnVal; + Tcl_Interp* interp; + int type = 0; + Tcl_Obj *vfsResultPtr = NULL; + + interp = (Tcl_Interp*) Tcl_FSData(&vfsFilesystem); + mountCmd = VfsCommand(interp, "matchindirectory", dirPtr); + if (mountCmd == NULL) { + return -1; + } + + if (types != NULL) { + type = types->type; + } + + Tcl_ListObjAppendElement(interp, mountCmd, Tcl_NewStringObj(pattern,-1)); + Tcl_ListObjAppendElement(interp, mountCmd, Tcl_NewIntObj(type)); + Tcl_SaveResult(interp, &savedResult); + /* Now we execute this mount point's callback. */ + returnVal = Tcl_EvalObjEx(interp, mountCmd, + TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT); + if (returnVal != -1) { + vfsResultPtr = Tcl_DuplicateObj(Tcl_GetObjResult(interp)); + } + Tcl_RestoreResult(interp, &savedResult); + Tcl_DecrRefCount(mountCmd); + + if (vfsResultPtr != NULL) { + if (returnVal == TCL_OK) { + Tcl_ListObjAppendList(cmdInterp, returnPtr, vfsResultPtr); + } else { + Tcl_SetObjResult(cmdInterp, vfsResultPtr); + } + } + return returnVal; +} + +int +VfsDeleteFile( + Tcl_Obj *pathPtr) /* Pathname of file to be removed (UTF-8). */ +{ + Tcl_Obj *mountCmd = NULL; + Tcl_SavedResult savedResult; + int returnVal; + Tcl_Interp* interp; + + interp = (Tcl_Interp*) Tcl_FSData(&vfsFilesystem); + mountCmd = VfsCommand(interp, "deletefile", pathPtr); + if (mountCmd == NULL) { + return -1; + } + + /* Now we execute this mount point's callback. */ + Tcl_SaveResult(interp, &savedResult); + returnVal = Tcl_EvalObjEx(interp, mountCmd, + TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT); + Tcl_RestoreResult(interp, &savedResult); + Tcl_DecrRefCount(mountCmd); + return returnVal; +} + +int +VfsCreateDirectory( + Tcl_Obj *pathPtr) /* Pathname of directory to create (UTF-8). */ +{ + Tcl_Obj *mountCmd = NULL; + Tcl_SavedResult savedResult; + int returnVal; + Tcl_Interp* interp; + + interp = (Tcl_Interp*) Tcl_FSData(&vfsFilesystem); + mountCmd = VfsCommand(interp, "createdirectory", pathPtr); + if (mountCmd == NULL) { + return -1; + } + + /* Now we execute this mount point's callback. */ + Tcl_SaveResult(interp, &savedResult); + returnVal = Tcl_EvalObjEx(interp, mountCmd, + TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT); + Tcl_RestoreResult(interp, &savedResult); + Tcl_DecrRefCount(mountCmd); + return returnVal; +} + +int +VfsRemoveDirectory( + 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) /* Location to store name of file + * causing error. */ +{ + Tcl_Obj *mountCmd = NULL; + Tcl_SavedResult savedResult; + int returnVal; + Tcl_Interp* interp; + + interp = (Tcl_Interp*) Tcl_FSData(&vfsFilesystem); + mountCmd = VfsCommand(interp, "removedirectory", pathPtr); + if (mountCmd == NULL) { + return -1; + } + + Tcl_ListObjAppendElement(interp, mountCmd, Tcl_NewIntObj(recursive)); + /* Now we execute this mount point's callback. */ + Tcl_SaveResult(interp, &savedResult); + returnVal = Tcl_EvalObjEx(interp, mountCmd, + TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT); + Tcl_RestoreResult(interp, &savedResult); + Tcl_DecrRefCount(mountCmd); + + if (returnVal == TCL_ERROR) { + /* Assume there was a problem with the directory being non-empty */ + if (errorPtr != NULL) { + *errorPtr = pathPtr; + } + Tcl_SetErrno(EEXIST); + } + return returnVal; +} + +char** +VfsFileAttrStrings(pathPtr, objPtrRef) + Tcl_Obj* pathPtr; + Tcl_Obj** objPtrRef; +{ + Tcl_Obj *mountCmd = NULL; + Tcl_SavedResult savedResult; + int returnVal; + Tcl_Interp* interp; + + interp = (Tcl_Interp*) Tcl_FSData(&vfsFilesystem); + mountCmd = VfsCommand(interp, "fileattributes", pathPtr); + if (mountCmd == NULL) { + *objPtrRef = NULL; + return NULL; + } + + Tcl_SaveResult(interp, &savedResult); + /* Now we execute this mount point's callback. */ + returnVal = Tcl_EvalObjEx(interp, mountCmd, + TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT); + if (returnVal == TCL_OK) { + *objPtrRef = Tcl_DuplicateObj(Tcl_GetObjResult(interp)); + } else { + *objPtrRef = NULL; + } + Tcl_RestoreResult(interp, &savedResult); + Tcl_DecrRefCount(mountCmd); + return NULL; +} + +int +VfsFileAttrsGet(cmdInterp, index, pathPtr, objPtrRef) + Tcl_Interp *cmdInterp; /* 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_Obj *mountCmd = NULL; + Tcl_SavedResult savedResult; + int returnVal; + Tcl_Interp* interp; + + interp = (Tcl_Interp*) Tcl_FSData(&vfsFilesystem); + mountCmd = VfsCommand(interp, "fileattributes", pathPtr); + if (mountCmd == NULL) { + return -1; + } + + Tcl_ListObjAppendElement(interp, mountCmd, Tcl_NewIntObj(index)); + Tcl_SaveResult(interp, &savedResult); + /* Now we execute this mount point's callback. */ + returnVal = Tcl_EvalObjEx(interp, mountCmd, + TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT); + if (returnVal != -1) { + *objPtrRef = Tcl_DuplicateObj(Tcl_GetObjResult(interp)); + } + Tcl_RestoreResult(interp, &savedResult); + Tcl_DecrRefCount(mountCmd); + + if (returnVal != -1) { + if (returnVal == TCL_OK) { + Tcl_IncrRefCount(*objPtrRef); + } else { + /* Leave error message in correct interp */ + Tcl_SetObjResult(cmdInterp, *objPtrRef); + *objPtrRef = NULL; + } + } + + return returnVal; +} + +int +VfsFileAttrsSet(cmdInterp, index, pathPtr, objPtr) + Tcl_Interp *cmdInterp; /* The interpreter for error reporting. */ + int index; /* index of the attribute command. */ + Tcl_Obj *pathPtr; /* filename we are operating on. */ + Tcl_Obj *objPtr; /* for input. */ +{ + Tcl_Obj *mountCmd = NULL; + Tcl_SavedResult savedResult; + int returnVal; + Tcl_Interp* interp; + Tcl_Obj *errorPtr = NULL; + + interp = (Tcl_Interp*) Tcl_FSData(&vfsFilesystem); + mountCmd = VfsCommand(interp, "fileattributes", pathPtr); + if (mountCmd == NULL) { + return -1; + } + + Tcl_ListObjAppendElement(interp, mountCmd, Tcl_NewIntObj(index)); + Tcl_ListObjAppendElement(interp, mountCmd, objPtr); + Tcl_SaveResult(interp, &savedResult); + /* Now we execute this mount point's callback. */ + returnVal = Tcl_EvalObjEx(interp, mountCmd, + TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT); + if (returnVal != -1 && returnVal != TCL_OK) { + errorPtr = Tcl_DuplicateObj(Tcl_GetObjResult(interp)); + } + + Tcl_RestoreResult(interp, &savedResult); + Tcl_DecrRefCount(mountCmd); + + if (errorPtr != NULL) { + /* + * Leave error message in correct interp, errorPtr was + * duplicated above, in case of threading issues. + */ + Tcl_SetObjResult(cmdInterp, errorPtr); + } + + return returnVal; +} + +int +VfsUtime(pathPtr, tval) + Tcl_Obj* pathPtr; + struct utimbuf *tval; +{ + Tcl_Obj *mountCmd = NULL; + Tcl_SavedResult savedResult; + int returnVal; + Tcl_Interp* interp; + + interp = (Tcl_Interp*) Tcl_FSData(&vfsFilesystem); + mountCmd = VfsCommand(interp, "utime", pathPtr); + if (mountCmd == NULL) { + return -1; + } + + Tcl_ListObjAppendElement(interp, mountCmd, Tcl_NewLongObj(tval->actime)); + Tcl_ListObjAppendElement(interp, mountCmd, Tcl_NewLongObj(tval->modtime)); + /* Now we execute this mount point's callback. */ + Tcl_SaveResult(interp, &savedResult); + returnVal = Tcl_EvalObjEx(interp, mountCmd, + TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT); + Tcl_RestoreResult(interp, &savedResult); + Tcl_DecrRefCount(mountCmd); + + return returnVal; +} + + +/* + *---------------------------------------------------------------------- + * + * VfsCommand -- + * + * Build a portion of a command to be evaluated in Tcl. + * + * Results: + * Returns a list containing the command, or NULL if an + * error occurred. + * + * Side effects: + * None except memory allocation. + * + *---------------------------------------------------------------------- + */ + +static Tcl_Obj* +VfsCommand(Tcl_Interp* interp, CONST char* cmd, Tcl_Obj * pathPtr) { + Tcl_Obj *normed; + Tcl_Obj *mountCmd; + int len; + int splitPosition; + int dummyLen; + int returnVal; + VfsNativeRep *nativeRep; + char *normedString; + + nativeRep = VfsGetNativePath(pathPtr); + if (nativeRep == NULL) { + return NULL; + } + + splitPosition = nativeRep->splitPosition; + normed = Tcl_FSGetNormalizedPath(interp, pathPtr); + normedString = Tcl_GetStringFromObj(normed, &len); + + mountCmd = Tcl_DuplicateObj(nativeRep->fsCmd); + Tcl_IncrRefCount(mountCmd); + if (Tcl_ListObjLength(interp, mountCmd, &dummyLen) == TCL_ERROR) { + Tcl_DecrRefCount(mountCmd); + return NULL; + } + Tcl_ListObjAppendElement(interp, mountCmd, Tcl_NewStringObj(cmd,-1)); + if (splitPosition == len) { + Tcl_ListObjAppendElement(interp, mountCmd, normed); + Tcl_ListObjAppendElement(interp, mountCmd, Tcl_NewStringObj("",0)); + } else { + Tcl_ListObjAppendElement(interp, mountCmd, + Tcl_NewStringObj(normedString,splitPosition)); + Tcl_ListObjAppendElement(interp, mountCmd, + Tcl_NewStringObj(normedString+splitPosition+1, + len-splitPosition-1)); + } + Tcl_ListObjAppendElement(interp, mountCmd, pathPtr); + + return mountCmd; +} + +static +void VfsExitProc(ClientData clientData) +{ + Tcl_FSUnregister(&vfsFilesystem); +} + ADDED install-sh Index: install-sh ================================================================== --- /dev/null +++ install-sh @@ -0,0 +1,119 @@ +#!/bin/sh + +# +# install - install a program, script, or datafile +# This comes from X11R5; it is not part of GNU. +# +# $XConsortium: install.sh,v 1.2 89/12/18 14:47:22 jim Exp $ +# +# This script is compatible with the BSD install script, but was written +# from scratch. +# + + +# set DOITPROG to echo to test this script + +# Don't use :- since 4.3BSD and earlier shells don't like it. +doit="${DOITPROG-}" + + +# put in absolute paths if you don't have them in your path; or use env. vars. + +mvprog="${MVPROG-mv}" +cpprog="${CPPROG-cp}" +chmodprog="${CHMODPROG-chmod}" +chownprog="${CHOWNPROG-chown}" +chgrpprog="${CHGRPPROG-chgrp}" +stripprog="${STRIPPROG-strip}" +rmprog="${RMPROG-rm}" + +instcmd="$mvprog" +chmodcmd="" +chowncmd="" +chgrpcmd="" +stripcmd="" +rmcmd="$rmprog -f" +mvcmd="$mvprog" +src="" +dst="" + +while [ x"$1" != x ]; do + case $1 in + -c) instcmd="$cpprog" + shift + continue;; + + -m) chmodcmd="$chmodprog $2" + shift + shift + continue;; + + -o) chowncmd="$chownprog $2" + shift + shift + continue;; + + -g) chgrpcmd="$chgrpprog $2" + shift + shift + continue;; + + -s) stripcmd="$stripprog" + shift + continue;; + + *) if [ x"$src" = x ] + then + src=$1 + else + dst=$1 + fi + shift + continue;; + esac +done + +if [ x"$src" = x ] +then + echo "install: no input file specified" + exit 1 +fi + +if [ x"$dst" = x ] +then + echo "install: no destination specified" + exit 1 +fi + + +# If destination is a directory, append the input filename; if your system +# does not like double slashes in filenames, you may need to add some logic + +if [ -d $dst ] +then + dst="$dst"/`basename $src` +fi + +# Make a temp file name in the proper directory. + +dstdir=`dirname $dst` +dsttmp=$dstdir/#inst.$$# + +# Move or copy the file name to the temp name + +$doit $instcmd $src $dsttmp + +# and set any options; do chmod last to preserve setuid bits + +if [ x"$chowncmd" != x ]; then $doit $chowncmd $dsttmp; fi +if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dsttmp; fi +if [ x"$stripcmd" != x ]; then $doit $stripcmd $dsttmp; fi +if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dsttmp; fi + +# Now rename the file to the real destination. + +$doit $rmcmd $dst +$doit $mvcmd $dsttmp $dst + + +exit 0 ADDED library/ftpvfs.tcl Index: library/ftpvfs.tcl ================================================================== --- /dev/null +++ library/ftpvfs.tcl @@ -0,0 +1,92 @@ + +package require vfs 1.0 +package require ftp + +namespace eval vfs::ftp {} + +proc vfs::ftp::Mount {dirurl local} { + regexp {(([^:]*)(:([^@]*))?@)?([^/]*)/(.*/)?([^/]*)$} $dirurl \ + junk junk user junk pass host path file + + set fd [::ftp::Open $host $user $pass $path] + ::ftp::Cd $fd $path + puts "ftp $host, $path mounted at $fd" + vfs::filesystem mount $local [list vfs::ftp::handler $fd $path] + return $fd +} + +proc vfs::ftp::Unmount {fd} { + ::ftp::Close $fd +} + +proc vfs::ftp::handler {fd path cmd root relative actualpath args} { + eval [list $cmd $fd $path $relative] $args +} + +# If we implement the commands below, we will have a perfect +# virtual file system for remote ftp sites. + +proc vfs::ftp::stat {fd path name} { + puts "stat $name" +} + +proc vfs::ftp::access {fd path name mode} { + puts "access $name $mode" +} + +proc vfs::ftp::open {fd name mode permissions} { + puts "open $name $mode $permissions" + # return a list of two elements: + # 1. first element is the Tcl channel name which has been opened + # 2. second element (optional) is a command to evaluate when + # the channel is closed. + return [list] +} + +proc vfs::ftp::matchindirectory {fd prefix path pattern type} { + puts "matchindirectory $path $pattern $type" + set ftpList [ftp::List $fd $path] + puts "ftpList: $ftpList" + set res [list] + + if {[::vfs::matchDirectories $type]} { + # add matching directories to $res + } + + if {[::vfs::matchFiles $type]} { + # add matching files to $res + } + return $res +} + +proc vfs::ftp::createdirectory {fd name} { + puts "createdirectory $name" +} + +proc vfs::ftp::removedirectory {fd name} { + puts "removedirectory $name" +} + +proc vfs::ftp::deletefile {fd name} { + puts "deletefile $name" +} + +proc vfs::ftp::fileattributes {fd path args} { + puts "fileattributes $args" + switch -- [llength $args] { + 0 { + # list strings + return [list] + } + 1 { + # get value + set index [lindex $args 0] + } + 2 { + # set value + set index [lindex $args 0] + set val [lindex $args 1] + } + } +} + ADDED library/pkgIndex.tcl Index: library/pkgIndex.tcl ================================================================== --- /dev/null +++ library/pkgIndex.tcl @@ -0,0 +1,12 @@ +# Tcl package index file, version 1.1 +# This file is generated by the "pkg_mkIndex" command +# and sourced either when an application starts up or +# by a "package unknown" script. It invokes the +# "package ifneeded" command to set up package-related +# information so that packages will be loaded automatically +# in response to "package require" commands. When this +# script is sourced, the variable $dir must contain the +# full path name of this file's directory. + +lappend auto_path $dir +package ifneeded vfs 1.0 [list load [file join $dir vfs10[info sharedlibextension]]] ADDED library/tclIndex Index: library/tclIndex ================================================================== --- /dev/null +++ library/tclIndex @@ -0,0 +1,74 @@ +# Tcl autoload index file, version 2.0 +# This file is generated by the "auto_mkindex" command +# and sourced to set up indexing information for one or +# more commands. Typically each line is a command that +# sets an element in the auto_index array, where the +# element name is the name of a command and the value is +# a script that loads the command. + +set auto_index(::vfs::ftp::Mount) [list source [file join $dir ftpvfs.tcl]] +set auto_index(::vfs::ftp::Unmount) [list source [file join $dir ftpvfs.tcl]] +set auto_index(::vfs::ftp::handler) [list source [file join $dir ftpvfs.tcl]] +set auto_index(::vfs::ftp::stat) [list source [file join $dir ftpvfs.tcl]] +set auto_index(::vfs::ftp::access) [list source [file join $dir ftpvfs.tcl]] +set auto_index(::vfs::ftp::open) [list source [file join $dir ftpvfs.tcl]] +set auto_index(::vfs::ftp::matchindirectory) [list source [file join $dir ftpvfs.tcl]] +set auto_index(::vfs::ftp::createdirectory) [list source [file join $dir ftpvfs.tcl]] +set auto_index(::vfs::ftp::removedirectory) [list source [file join $dir ftpvfs.tcl]] +set auto_index(::vfs::ftp::deletefile) [list source [file join $dir ftpvfs.tcl]] +set auto_index(::vfs::ftp::fileattributes) [list source [file join $dir ftpvfs.tcl]] +set auto_index(::vfs::tclproc::Mount) [list source [file join $dir tclprocvfs.tcl]] +set auto_index(::vfs::tclproc::Unmount) [list source [file join $dir tclprocvfs.tcl]] +set auto_index(::vfs::tclproc::handler) [list source [file join $dir tclprocvfs.tcl]] +set auto_index(::vfs::tclproc::stat) [list source [file join $dir tclprocvfs.tcl]] +set auto_index(::vfs::tclproc::access) [list source [file join $dir tclprocvfs.tcl]] +set auto_index(::vfs::tclproc::exists) [list source [file join $dir tclprocvfs.tcl]] +set auto_index(::vfs::tclproc::open) [list source [file join $dir tclprocvfs.tcl]] +set auto_index(::vfs::tclproc::matchindirectory) [list source [file join $dir tclprocvfs.tcl]] +set auto_index(::vfs::tclproc::createdirectory) [list source [file join $dir tclprocvfs.tcl]] +set auto_index(::vfs::tclproc::removedirectory) [list source [file join $dir tclprocvfs.tcl]] +set auto_index(::vfs::tclproc::deletefile) [list source [file join $dir tclprocvfs.tcl]] +set auto_index(::vfs::tclproc::fileattributes) [list source [file join $dir tclprocvfs.tcl]] +set auto_index(::vfs::testMount) [list source [file join $dir testvfs.tcl]] +set auto_index(::vfs::test::handler) [list source [file join $dir testvfs.tcl]] +set auto_index(::vfs::test::stat) [list source [file join $dir testvfs.tcl]] +set auto_index(::vfs::test::access) [list source [file join $dir testvfs.tcl]] +set auto_index(::vfs::test::open) [list source [file join $dir testvfs.tcl]] +set auto_index(::vfs::test::matchindirectory) [list source [file join $dir testvfs.tcl]] +set auto_index(::vfs::test::createdirectory) [list source [file join $dir testvfs.tcl]] +set auto_index(::vfs::test::removedirectory) [list source [file join $dir testvfs.tcl]] +set auto_index(::vfs::test::deletefile) [list source [file join $dir testvfs.tcl]] +set auto_index(::vfs::test::fileattributes) [list source [file join $dir testvfs.tcl]] +set auto_index(::vfs::autoMountExtension) [list source [file join $dir vfsUtils.tcl]] +set auto_index(::vfs::autoMountUrl) [list source [file join $dir vfsUtils.tcl]] +set auto_index(::vfs::haveMount) [list source [file join $dir vfsUtils.tcl]] +set auto_index(::vfs::urlMount) [list source [file join $dir vfsUtils.tcl]] +set auto_index(::vfs::fileUrlMount) [list source [file join $dir vfsUtils.tcl]] +set auto_index(::vfs::auto) [list source [file join $dir vfsUtils.tcl]] +set auto_index(::vfs::matchCorrectTypes) [list source [file join $dir vfsUtils.tcl]] +set auto_index(::vfs::accessMode) [list source [file join $dir vfsUtils.tcl]] +set auto_index(::vfs::matchDirectories) [list source [file join $dir vfsUtils.tcl]] +set auto_index(::vfs::matchFiles) [list source [file join $dir vfsUtils.tcl]] +set auto_index(::vfs::modeToString) [list source [file join $dir vfsUtils.tcl]] +set auto_index(::vfs::zip::Mount) [list source [file join $dir zipvfs.tcl]] +set auto_index(::vfs::zip::Unmount) [list source [file join $dir zipvfs.tcl]] +set auto_index(::vfs::zip::handler) [list source [file join $dir zipvfs.tcl]] +set auto_index(::vfs::zip::matchindirectory) [list source [file join $dir zipvfs.tcl]] +set auto_index(::vfs::zip::stat) [list source [file join $dir zipvfs.tcl]] +set auto_index(::vfs::zip::access) [list source [file join $dir zipvfs.tcl]] +set auto_index(::vfs::zip::open) [list source [file join $dir zipvfs.tcl]] +set auto_index(::vfs::zip::createdirectory) [list source [file join $dir zipvfs.tcl]] +set auto_index(::vfs::zip::removedirectory) [list source [file join $dir zipvfs.tcl]] +set auto_index(::vfs::zip::deletefile) [list source [file join $dir zipvfs.tcl]] +set auto_index(::vfs::zip::fileattributes) [list source [file join $dir zipvfs.tcl]] +set auto_index(::zip::u_short) [list source [file join $dir zipvfs.tcl]] +set auto_index(::zip::DosTime) [list source [file join $dir zipvfs.tcl]] +set auto_index(::zip::Data) [list source [file join $dir zipvfs.tcl]] +set auto_index(::zip::EndOfArchive) [list source [file join $dir zipvfs.tcl]] +set auto_index(::zip::TOC) [list source [file join $dir zipvfs.tcl]] +set auto_index(::zip::open) [list source [file join $dir zipvfs.tcl]] +set auto_index(::zip::FAKEDIR) [list source [file join $dir zipvfs.tcl]] +set auto_index(::zip::exists) [list source [file join $dir zipvfs.tcl]] +set auto_index(::zip::stat) [list source [file join $dir zipvfs.tcl]] +set auto_index(::zip::getdir) [list source [file join $dir zipvfs.tcl]] +set auto_index(::zip::_close) [list source [file join $dir zipvfs.tcl]] ADDED library/tclprocvfs.tcl Index: library/tclprocvfs.tcl ================================================================== --- /dev/null +++ library/tclprocvfs.tcl @@ -0,0 +1,183 @@ + +package require vfs 1.0 + +# Thanks to jcw for the idea here. This is a 'file system' which +# is actually a representation of the Tcl command namespace hierarchy. +# Namespaces are directories, and procedures are files. Tcl allows +# procedures with the same name as a namespace, which are hidden in +# a filesystem representation. + +namespace eval vfs::tclproc {} + +proc vfs::tclproc::Mount {ns local} { + if {![namespace exists ::$ns]} { + error "No such namespace" + } + puts "tclproc $ns mounted at $local" + vfs::filesystem mount $local [list vfs::tclproc::handler $ns] +} + +proc vfs::tclproc::Unmount {ns} { +} + +proc vfs::tclproc::handler {ns cmd root relative actualpath args} { + regsub -all / $relative :: relative + if {$cmd == "matchindirectory"} { + eval [list $cmd $ns $relative $actualpath] $args + } else { + eval [list $cmd $ns $relative] $args + } +} + +# If we implement the commands below, we will have a perfect +# virtual file system for remote tclproc sites. + +proc vfs::tclproc::stat {ns name} { + puts stderr "stat $name" + if {[namespace exists ::${ns}::${name}]} { + puts "directory" + return [list type directory size 0 mode 0777 \ + ino -1 depth 0 name $name atime 0 ctime 0 mtime 0 dev -1 \ + uid -1 gid -1 nlink 1] + } elseif {[llength [info procs ::${ns}::${name}]]} { + puts "file" + return [list type file] + } else { + return -code error "could not read \"$name\": no such file or directory" + } +} + +proc vfs::tclproc::access {ns name mode} { + puts stderr "access $name $mode" + if {[namespace exists ::${ns}::${name}]} { + return 1 + } elseif {[llength [info procs ::${ns}::${name}]]} { + if {$mode & 2} { + error "read-only" + } + return 1 + } else { + error "No such file" + } +} + +proc vfs::tclproc::exists {ns name} { + if {[namespace exists ::${ns}::${name}]} { + return 1 + } elseif {[llength [info procs ::${ns}::${name}]]} { + return 1 + } else { + return 0 + } +} + +proc vfs::tclproc::open {ns name mode permissions} { + puts stderr "open $name $mode $permissions" + # return a list of two elements: + # 1. first element is the Tcl channel name which has been opened + # 2. second element (optional) is a command to evaluate when + # the channel is closed. + switch -- $mode { + "" - + "r" { + package require Memchan + + set nfd [memchan] + fconfigure $nfd -translation binary + puts -nonewline $nfd [_generate ::${ns}::${name}] + fconfigure $nfd -translation auto + seek $nfd 0 + return [list $nfd] + } + default { + return -code error "illegal access mode \"$mode\"" + } + } +} + +proc vfs::tclproc::_generate {p} { + lappend a proc $p + set argslist [list] + foreach arg [info args $p] { + if {[info default $p $arg v]} { + lappend argslist [list $arg $v] + } else { + lappend argslist $arg + } + } + lappend a $argslist [info body $p] +} + +proc vfs::tclproc::matchindirectory {ns path actualpath pattern type} { + puts stderr "matchindirectory $path $actualpath $pattern $type" + set res [list] + + if {[::vfs::matchDirectories $type]} { + # add matching directories to $res + eval lappend res [namespace children ::${ns}::${path} $pattern] + } + + if {[::vfs::matchFiles $type]} { + # add matching files to $res + eval lappend res [info procs ::${ns}::${path}::$pattern] + } + set realres [list] + foreach r $res { + regsub "^(::)?${ns}(::)?${path}(::)?" $r $actualpath rr + lappend realres $rr + } + #puts $realres + + return $realres +} + +proc vfs::tclproc::createdirectory {ns name} { + puts stderr "createdirectory $name" + namespace eval ::${ns}::${name} {} +} + +proc vfs::tclproc::removedirectory {ns name} { + puts stderr "removedirectory $name" + namespace delete ::${ns}::${name} +} + +proc vfs::tclproc::deletefile {ns name} { + puts stderr "deletefile $name" + rename ::${ns}::${name} {} +} + +proc vfs::tclproc::fileattributes {ns name args} { + puts stderr "fileattributes $args" + switch -- [llength $args] { + 0 { + # list strings + return [list -args -body] + } + 1 { + # get value + set index [lindex $args 0] + switch -- $index { + 0 { + ::info args ::${ns}::${name} + } + 1 { + ::info body ::${ns}::${name} + } + } + } + 2 { + # set value + set index [lindex $args 0] + set val [lindex $args 1] + switch -- $index { + 0 { + error "read-only" + } + 1 { + error "unimplemented" + } + } + } + } +} + ADDED library/testvfs.tcl Index: library/testvfs.tcl ================================================================== --- /dev/null +++ library/testvfs.tcl @@ -0,0 +1,77 @@ + +package require vfs 1.0 + +proc vfs::testMount {what local} { + vfs::filesystem mount $local [list vfs::test::handler $what] +} + +namespace eval vfs::test {} + +proc vfs::test::handler {what cmd root relative actualpath args} { + eval [list $cmd $what $relative] $args +} + +# If we implement the commands below, we will have a perfect +# virtual file system. + +proc vfs::test::stat {what name} { + puts "stat $name" +} + +proc vfs::test::access {what name mode} { + puts "access $name $mode" +} + +proc vfs::test::open {what name mode permissions} { + puts "open $name $mode $permissions" + # return a list of two elements: + # 1. first element is the Tcl channel name which has been opened + # 2. second element (optional) is a command to evaluate when + # the channel is closed. + return [list] +} + +proc vfs::test::matchindirectory {what path pattern type} { + puts "matchindirectory $path $pattern $type" + set res [list] + + if {[::vfs::matchDirectories $type]} { + # add matching directories to $res + } + + if {[::vfs::matchFiles $type]} { + # add matching files to $res + } + return $res +} + +proc vfs::test::createdirectory {what name} { + puts "createdirectory $name" +} + +proc vfs::test::removedirectory {what name} { + puts "removedirectory $name" +} + +proc vfs::test::deletefile {what name} { + puts "deletefile $name" +} + +proc vfs::test::fileattributes {what args} { + puts "fileattributes $args" + switch -- [llength $args] { + 0 { + # list strings + } + 1 { + # get value + set index [lindex $args 0] + } + 2 { + # set value + set index [lindex $args 0] + set val [lindex $args 1] + } + } +} + ADDED library/vfs10.dll Index: library/vfs10.dll ================================================================== --- /dev/null +++ library/vfs10.dll cannot compute difference between binary files ADDED library/vfsUtils.tcl Index: library/vfsUtils.tcl ================================================================== --- /dev/null +++ library/vfsUtils.tcl @@ -0,0 +1,139 @@ + +package require vfs + +proc ::vfs::autoMountExtension {ext cmd {pkg ""}} { + variable extMounts + set extMounts($ext) [list $cmd $pkg] +} + +proc ::vfs::autoMountUrl {type cmd {pkg ""}} { + variable urlMounts + set urlMounts($type) [list $cmd $pkg] +} + +::vfs::autoMountExtension .zip ::vfs::zip::Mount vfs +::vfs::autoMountUrl ftp ::vfs::ftp::Mount vfs +::vfs::autoMountUrl file ::vfs::fileUrlMount vfs +::vfs::autoMountUrl tclns ::vfs::tclprocMount vfs + +proc ::vfs::haveMount {url} { + variable mounted + info exists mounted($url) +} + +proc ::vfs::urlMount {url args} { + puts "$url $args" + variable urlMounts + if {[regexp {^([a-zA-Z]+)://(.*)} $url "" urltype rest]} { + if {[info exists urlMounts($urltype)]} { + #::vfs::log "automounting $path" + foreach {cmd pkg} $urlMounts($urltype) {} + if {[string length $pkg]} { + package require $pkg + } + eval $cmd [list $url] $args + variable mounted + set mounted($url) 1 + return + } + error "Unknown url type '$urltype'" + } + error "Couldn't parse url $url" +} + +proc ::vfs::fileUrlMount {url args} { + # Strip off the leading 'file://' + set file [string range $url 7 end] + eval [list ::vfs::auto $file] $args +} + +proc ::vfs::tclprocMount {url args} { + # Strip off the leading 'tclns://' + set ns [string range $url 8 end] + eval [list ::vfs::tclproc::Mount $ns] $args +} + +proc ::vfs::auto {filename args} { + variable extMounts + + set np {} + + set split [::file split $filename] + + foreach ele $split { + lappend np $ele + set path [::file normalize [eval [list ::file join] $np]] + if {[::file isdirectory $path]} { + # already mounted + continue + } elseif {[::file isfile $path]} { + set ext [string tolower [::file extension $ele]] + if {[::info exists extMounts($ext)]} { + #::vfs::log "automounting $path" + foreach {cmd pkg} $extMounts($ext) {} + if {[string length $pkg]} { + package require $pkg + } + eval $cmd [list $path $path] $args + } else { + continue + } + } else { + # It doesn't exist, so just return + # return -code error "$path doesn't exist" + return + } + } +} + +# Helper procedure for vfs matchindirectory +# implementations. It is very important that +# we match properly when given 'directory' +# specifications, since this is used for +# recursive globbing by Tcl. +proc vfs::matchCorrectTypes {types filelist} { + if {$types != 0} { + # Which types to return. We must do special + # handling of directories and files. + set file [matchFiles $types] + set dir [matchDirectories $types] + if {$file && $dir} { + return $filelist + } + if {$file == 0 && $dir == 0} { + return [list] + } + set newres [list] + if {$file} { + foreach r $filelist { + if {[::file isfile $r]} { + lappend newres $r + } + } + } else { + foreach r $filelist { + if {[::file isdirectory $r]} { + lappend newres $r + } + } + } + set filelist $newres + } + return $filelist +} + +# Convert integer mode to a somewhat preferable string. +proc vfs::accessMode {mode} { + lindex [list F X W XW R RX RW] $mode +} + +proc vfs::matchDirectories {types} { + return [expr {$types == 0 ? 1 : $types & (1<<2)}] +} + +proc vfs::matchFiles {types} { + return [expr {$types == 0 ? 1 : $types & (1<<4)}] +} + +proc vfs::modeToString {mode} { +} ADDED library/zipvfs.tcl Index: library/zipvfs.tcl ================================================================== --- /dev/null +++ library/zipvfs.tcl @@ -0,0 +1,566 @@ + +package require vfs 1.0 + +# Using the vfs, memchan and Trf extensions, we ought to be able +# to write a Tcl-only zip virtual filesystem. + +namespace eval vfs::zip {} + +proc vfs::zip::Mount {zipfile local} { + set fd [::zip::open [::file normalize $zipfile]] + vfs::filesystem mount $local [list vfs::zip::handler $fd] + return $fd +} + +proc vfs::zip::Unmount {fd} { + ::zip::_close $fd +} + +proc vfs::zip::handler {zipfd cmd root relative actualpath args} { + #puts [list $zipfd $cmd $root $relative $actualpath $args] + #update + if {$cmd == "matchindirectory"} { + eval [list $cmd $zipfd $relative $actualpath] $args + } else { + eval [list $cmd $zipfd $relative] $args + } +} + +# If we implement the commands below, we will have a perfect +# virtual file system for zip files. + +proc vfs::zip::matchindirectory {zipfd path actualpath pattern type} { + puts stderr [list matchindirectory $path $actualpath $pattern $type] + set res [::zip::getdir $zipfd $path $pattern] + set newres [list] + foreach p [::vfs::matchCorrectTypes $type $res] { + lappend newres "$actualpath$p" + } + #puts "got $newres" + return $newres +} + +proc vfs::zip::stat {zipfd name} { + puts "stat $name" + ::zip::stat $zipfd $name sb + puts [array get sb] + array get sb +} + +proc vfs::zip::access {zipfd name mode} { + puts "zip-access $name $mode" + if {$mode & 2} { + error "read-only" + } + # Readable, Exists and Executable are treated as 'exists' + # Could we get more information from the archive? + if {[::zip::exists $zipfd $name]} { + return 1 + } else { + error "No such file" + } + +} + +proc vfs::zip::open {zipfd name mode permissions} { + puts "open $name $mode $permissions" + # return a list of two elements: + # 1. first element is the Tcl channel name which has been opened + # 2. second element (optional) is a command to evaluate when + # the channel is closed. + + switch -- $mode { + "" - + "r" { + ::zip::stat $zipfd $name sb + + package require Trf + package require Memchan + + set nfd [memchan] + fconfigure $nfd -translation binary + + seek $zipfd $sb(ino) start + zip::Data $zipfd sb data + + puts -nonewline $nfd $data + + fconfigure $nfd -translation auto + seek $nfd 0 + return [list $nfd] + } + default { + return -code error "illegal access mode \"$mode\"" + } + } +} + +proc vfs::zip::createdirectory {zipfd name} { + puts stderr "createdirectory $name" + error "read-only" +} + +proc vfs::zip::removedirectory {zipfd name} { + puts stderr "removedirectory $name" + error "read-only" +} + +proc vfs::zip::deletefile {zipfd name} { + puts "deletefile $name" + error "read-only" +} + +proc vfs::zip::fileattributes {zipfd name args} { + puts "fileattributes $args" + switch -- [llength $args] { + 0 { + # list strings + return [list] + } + 1 { + # get value + set index [lindex $args 0] + return "" + } + 2 { + # set value + set index [lindex $args 0] + set val [lindex $args 1] + error "read-only" + } + } +} + +# Below copied from TclKit distribution + +# +# ZIP decoder: +# +# Format of zip file: +# [ Data ]* [ TOC ]* EndOfArchive +# +# Note: TOC is refered to in ZIP doc as "Central Archive" +# +# This means there are two ways of accessing: +# +# 1) from the begining as a stream - until the header +# is not "PK\03\04" - ideal for unzipping. +# +# 2) for table of contents without reading entire +# archive by first fetching EndOfArchive, then +# just loading the TOC +# +package provide vfs.zip 0.5 + +namespace eval zip { + array set methods { + 0 {stored - The file is stored (no compression)} + 1 {shrunk - The file is Shrunk} + 2 {reduce1 - The file is Reduced with compression factor 1} + 3 {reduce2 - The file is Reduced with compression factor 2} + 4 {reduce3 - The file is Reduced with compression factor 3} + 5 {reduce4 - The file is Reduced with compression factor 4} + 6 {implode - The file is Imploded} + 7 {reserved - Reserved for Tokenizing compression algorithm} + 8 {deflate - The file is Deflated} + 9 {reserved - Reserved for enhanced Deflating} + 10 {pkimplode - PKWARE Date Compression Library Imploding} + } + # Version types (high-order byte) + array set systems { + 0 {dos} + 1 {amiga} + 2 {vms} + 3 {unix} + 4 {vm cms} + 5 {atari} + 6 {os/2} + 7 {macos} + 8 {z system 8} + 9 {cp/m} + 10 {tops20} + 11 {windows} + 12 {qdos} + 13 {riscos} + 14 {vfat} + 15 {mvs} + 16 {beos} + 17 {tandem} + 18 {theos} + } + # DOS File Attrs + array set dosattrs { + 1 {readonly} + 2 {hidden} + 4 {system} + 8 {unknown8} + 16 {directory} + 32 {archive} + 64 {unknown64} + 128 {normal} + } + + proc u_short {n} { return [expr { ($n+0x10000)%0x10000 }] } +} + +proc zip::DosTime {date time} { + set time [u_short $time] + set date [u_short $date] + + set sec [expr { ($time & 0x1F) * 2 }] + set min [expr { ($time >> 5) & 0x3F }] + set hour [expr { ($time >> 11) & 0x1F }] + + set mday [expr { $date & 0x1F }] + set mon [expr { (($date >> 5) & 0xF) }] + set year [expr { (($date >> 9) & 0xFF) + 1980 }] + + set dt [format {%4.4d-%2.2d-%2.2d %2.2d:%2.2d:%2.2d} \ + $year $mon $mday $hour $min $sec] + return [clock scan $dt -gmt 1] +} + + +proc zip::Data {fd arr {varPtr ""} {verify 0}} { + upvar 1 $arr sb + + if { $varPtr != "" } { + upvar 1 $varPtr data + } + + set buf [read $fd 30] + set n [binary scan $buf A4sssssiiiss \ + hdr sb(ver) sb(flags) sb(method) \ + time date \ + sb(crc) sb(csize) sb(size) flen elen] + + if { ![string equal "PK\03\04" $hdr] } { + error "bad header: [hexdump $hdr]" + } + set sb(ver) [u_short $sb(ver)] + set sb(flags) [u_short $sb(flags)] + set sb(method) [u_short $sb(method)] + set sb(mtime) [DosTime $date $time] + + set sb(name) [read $fd [u_short $flen]] + set sb(extra) [read $fd [u_short $elen]] + + if { $varPtr == "" } { + seek $fd $sb(csize) current + } else { + set data [read $fd $sb(csize)] + } + + if { $sb(flags) & 0x4 } { + # Data Descriptor used + set buf [read $fd 12] + binary scan $buf iii sb(crc) sb(csize) sb(size) + } + + + if { $varPtr == "" } { + return "" + } + + if { $sb(method) != 0 } { + if { [catch { + set data [zip -mode decompress -nowrap 1 $data] + } err] } { + puts "$sb(name): inflate error: $err" + puts [hexdump $data] + } + } + return + if { $verify } { + set ncrc [pink zlib crc $data] + if { $ncrc != $sb(crc) } { + tclLog [format {%s: crc mismatch: expected 0x%x, got 0x%x} \ + $sb(name) $sb(crc) $ncrc] + } + } +} + +proc zip::EndOfArchive {fd arr} { + upvar 1 $arr cb + + seek $fd -22 end + set pos [tell $fd] + set hdr [read $fd 22] + + binary scan $hdr A4ssssiis xhdr \ + cb(ndisk) cb(cdisk) \ + cb(nitems) cb(ntotal) \ + cb(csize) cb(coff) \ + cb(comment) + + if { ![string equal "PK\05\06" $xhdr]} { + error "bad header" + } + + set cb(ndisk) [u_short $cb(ndisk)] + set cb(nitems) [u_short $cb(nitems)] + set cb(ntotal) [u_short $cb(ntotal)] + set cb(comment) [u_short $cb(comment)] + + # Compute base for situations where ZIP file + # has been appended to another media (e.g. EXE) + set cb(base) [expr { $pos - $cb(csize) - $cb(coff) }] +} + +proc zip::TOC {fd arr} { + upvar 1 $arr sb + + set buf [read $fd 46] + + binary scan $buf A4ssssssiiisssssii hdr \ + sb(vem) sb(ver) sb(flags) sb(method) time date \ + sb(crc) sb(csize) sb(size) \ + flen elen clen sb(disk) sb(attr) \ + sb(atx) sb(ino) + + if { ![string equal "PK\01\02" $hdr] } { + error "bad central header: [hexdump $buf]" + } + + foreach v {vem ver flags method disk attr} { + set cb($v) [u_short [set sb($v)]] + } + + set sb(mtime) [DosTime $date $time] + set sb(mode) [expr { ($sb(atx) >> 16) & 0xffff }] + if { ( $sb(atx) & 0xff ) & 16 } { + set sb(type) directory + } else { + set sb(type) file + } + set sb(name) [read $fd [u_short $flen]] + set sb(extra) [read $fd [u_short $elen]] + set sb(comment) [read $fd [u_short $clen]] +} + +proc zip::open {path} { + set fd [::open $path] + upvar #0 zip::$fd cb + upvar #0 zip::$fd.toc toc + + fconfigure $fd -translation binary ;#-buffering none + + zip::EndOfArchive $fd cb + + seek $fd $cb(coff) start + + set toc(_) 0; unset toc(_); #MakeArray + + for { set i 0 } { $i < $cb(nitems) } { incr i } { + zip::TOC $fd sb + + set sb(depth) [llength [file split $sb(name)]] + + set name [string tolower $sb(name)] + set toc($name) [array get sb] + FAKEDIR toc [file dirname $name] + } + + return $fd +} + +proc zip::FAKEDIR {arr path} { + upvar 1 $arr toc + + if { $path == "."} { return } + + + if { ![info exists toc($path)] } { + # Implicit directory + lappend toc($path) \ + name $path \ + type directory mtime 0 size 0 mode 0777 \ + ino -1 depth [llength [file split $path]] + } + FAKEDIR toc [file dirname $path] +} + +proc zip::exists {fd path} { + #puts stderr "$fd $path" + if {$path == ""} { + return 1 + } else { + upvar #0 zip::$fd.toc toc + info exists toc([string tolower $path]) + } +} + +proc zip::stat {fd path arr} { + upvar #0 zip::$fd.toc toc + upvar 1 $arr sb + + set name [string tolower $path] + if { $name == "" || $name == "." } { + array set sb { + type directory mtime 0 size 0 mode 0777 + ino -1 depth 0 name "" + } + } elseif {![info exists toc($name)] } { + return -code error "could not read \"$path\": no such file or directory" + } else { + array set sb $toc($name) + } + set sb(dev) -1 + set sb(uid) -1 + set sb(gid) -1 + set sb(nlink) 1 + set sb(atime) $sb(mtime) + set sb(ctime) $sb(mtime) + return "" +} + +proc zip::getdir {fd path {pat *}} { +# puts stderr [list getdir $fd $path $pat] + upvar #0 zip::$fd.toc toc + + if { $path == "." || $path == "" } { + set path $pat + } else { + set path [string tolower $path] + append path /$pat + } + set depth [llength [file split $path]] + + set ret {} + foreach key [array names toc $path] { + if {[string index $key end] == "/"} { + # Directories are listed twice: both with and without + # the trailing '/', so we ignore the one with + continue + } + array set sb $toc($key) + + if { $sb(depth) == $depth } { + if {[info exists toc(${key}/)]} { + array set sb $toc(${key}/) + } + lappend ret [file tail $sb(name)] + } else { + #puts "$sb(depth) vs $depth for $sb(name)" + } + unset sb + } + return $ret +} + +proc zip::_close {fd} { + variable $fd + variable $fd.toc + unset $fd + unset $fd.toc +} +# +# +return +# +# DEMO UNZIP -L PROGRAM +# +array set opts { + -datefmt {%m-%d-%y %H:%M} + -verbose 1 + -extract 0 + -debug 0 +} +set file [lindex $argv 0] +array set opts [lrange $argv 1 end] + +set fd [open $file] +fconfigure $fd -translation binary ;#-buffering none + +if { !$opts(-extract) } { + if { !$opts(-verbose) } { + puts " Length Date Time Name" + puts " ------ ---- ---- ----" + } else { + puts " Length Method Size Ratio Date Time CRC-32 Name" + puts " ------ ------ ---- ----- ---- ---- ------ ----" + } +} + +zip::EndOfArchive $fd cb + +seek $fd $cb(coff) start + +set TOC {} +for { set i 0 } { $i < $cb(nitems) } { incr i } { + + zip::TOC $fd sb + + lappend TOC $sb(name) $sb(ino) + + if { $opts(-extract) } { + continue + } + + if { !$opts(-verbose) } { + puts [format {%7d %-16s %s} $sb(size) \ + [clock format $sb(mtime) -format $opts(-datefmt) -gmt 1] \ + $sb(name)] + } else { + if { $sb(size) > 0 } { + set cr [expr { 100 - 100 * $sb(csize) / double($sb(size)) }] + } else { + set cr 0 + } + puts [format {%7d %6.6s %7d %3.0f%% %s %8.8x %s} \ + $sb(size) [lindex $::zip::methods($sb(method)) 0] \ + $sb(csize) $cr \ + [clock format $sb(mtime) -format $opts(-datefmt) -gmt 1] \ + $sb(crc) $sb(name)] + + if { $opts(-debug) } { + set maj [expr { ($sb(vem) & 0xff)/10 }] + set min [expr { ($sb(vem) & 0xff)%10 }] + set sys [expr { $sb(vem) >> 8 }] + puts "made by version $maj.$min on system type $sys -> $::zip::systems($sys)" + + set maj [expr { ($sb(ver) & 0xff)/10 }] + set min [expr { ($sb(ver) & 0xff)%10 }] + set sys [expr { $sb(ver) >> 8 }] + puts "need version $maj.$min on system type $sys -> $::zip::systems($sys)" + + puts "file type is [expr { $sb(attr) == 1 ? "text" : "binary" }]" + puts "file mode is $sb(mode)" + + set att [expr { $sb(atx) & 0xff }] + set flgs {} + foreach {k v} [array get ::zip::dosattrs] { + if { $k & $att } { + lappend flgs $v + } + } + puts "dos file attrs = [join $flgs]" + } + } +} +# +# This doesn't do anything right now except read each +# entry and inflate the data and double-check the crc +# + +if { $opts(-extract) } { + seek $fd $cb(base) start + + foreach {name idx} $TOC { + #seek $fd $idx start + + zip::Data $fd sb data + + # The slowness of this code is actually Tcl's file i/o + # I suspect there are levels of buffer duplication + # wasting cpu and memory cycles.... + file mkdir [file dirname $sb(name)] + + set nfd [open $sb(name) w] + fconfigure $nfd -translation binary -buffering none + puts -nonewline $nfd $data + close $nfd + + puts "$sb(name): $sb(size) bytes" + } +} ADDED license.terms Index: license.terms ================================================================== --- /dev/null +++ license.terms @@ -0,0 +1,38 @@ +This software is copyrighted by the Vince Darley, and other +parties. The following terms apply to all files associated with the +software unless explicitly disclaimed in individual files. + +The authors hereby grant permission to use, copy, modify, distribute, +and license this software and its documentation for any purpose, provided +that existing copyright notices are retained in all copies and that this +notice is included verbatim in any distributions. No written agreement, +license, or royalty fee is required for any of the authorized uses. +Modifications to this software may be copyrighted by their authors +and need not follow the licensing terms described here, provided that +the new terms are clearly indicated on the first page of each file where +they apply. + +IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY +FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES +ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY +DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. + +THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, +INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE +IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE +NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR +MODIFICATIONS. + +GOVERNMENT USE: If you are acquiring this software on behalf of the +U.S. government, the Government shall have only "Restricted Rights" +in the software and related documentation as defined in the Federal +Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you +are acquiring the software on behalf of the Department of Defense, the +software shall be classified as "Commercial Computer Software" and the +Government shall have only "Restricted Rights" as defined in Clause +252.227-7013 (c) (1) of DFARs. Notwithstanding the foregoing, the +authors grant the U.S. Government and others acting in its behalf +permission to use and distribute the software in accordance with the +terms specified in this license. ADDED mkIndex.tcl.in Index: mkIndex.tcl.in ================================================================== --- /dev/null +++ mkIndex.tcl.in @@ -0,0 +1,114 @@ +# mkIndex.tcl -- +# +# This script generates a pkgIndex.tcl file for an installed extension. +# +# Copyright (c) 1999 Scriptics Corporation. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# +# Notes: +# +# If you redefine $(libdir) using the configure switch --libdir=, then +# this script will probably fail for you. +# +# UNIX: +# exec_prefix +# | +# | +# | +# lib +# / \ +# / \ +# / \ +# PACKAGE (.so files) +# | +# | +# | +# pkgIndex.tcl +# +# WIN: +# exec_prefix +# / \ +# / \ +# / \ +# bin lib +# | \ +# | \ +# | \ +# (.dll files) PACKAGE +# | +# | +# | +# pkgIndex.tcl + +# The pkg_mkIndex routines from Tcl 8.2 and later support stub-enabled +# extensions. Notify the user if this is not a valid tcl shell. +# Exit with a status of 0 so that the make-install process does not stop. + +if {[catch {package require Tcl 8.4} msg]} { + puts stderr "**WARNING**" + puts stderr $msg + puts stderr "Could not build pkgIndex.tcl file. You must create one by hand" + exit 0 +} + +# The name of the library(s) should be passed in as arguments. + +set libraryList $argv + +# Nativepath -- +# +# Convert a Cygnus style path to a native path +# +# Arguments: +# pathName Path to convert +# +# Results: +# The result is the native name of the input pathName. +# On Windows, this is z:/foo/bar, on Unix the input pathName is +# returned. + +proc Nativepath {pathName} { + global tcl_platform + + if {![string match $tcl_platform(platform) unix]} { + if {[regexp {//(.)/(.*)} $pathName null driveLetter pathRemains]} { + set pathName $driveLetter:/$pathRemains + } + } + return $pathName +} + +set prefix "@prefix@" +set exec_prefix "@exec_prefix@" + +set exec_prefix [Nativepath $exec_prefix] + +set libdir @libdir@ +set package @PACKAGE@ +set version @VERSION@ + +cd $libdir +puts "Making pkgIndex.tcl in [file join [pwd] $package]" + +if {$tcl_platform(platform) == "unix"} { + if {[llength $libraryList] > 0} { + set libraryPathList {} + foreach lib $libraryList { + lappend libraryPathList [file join .. $lib] + } + puts "eval pkg_mkIndex $package$version $libraryPathList *.tcl" + eval pkg_mkIndex $package$version $libraryPathList *.tcl + } +} else { + if {[llength $libraryList] > 0} { + set libraryPathList {} + foreach lib $libraryList { + lappend libraryPathList [file join .. .. bin $lib] + } + puts "eval pkg_mkIndex $package$version $libraryPathList *.tcl" + eval pkg_mkIndex $package$version $libraryPathList *.tcl + } +} ADDED mkinstalldirs Index: mkinstalldirs ================================================================== --- /dev/null +++ mkinstalldirs @@ -0,0 +1,40 @@ +#! /bin/sh +# mkinstalldirs --- make directory hierarchy +# Author: Noah Friedman +# Created: 1993-05-16 +# Public domain + +# $Id: mkinstalldirs,v 1.1.1.1 2001/08/03 16:19:00 vincentdarley Exp $ + +errstatus=0 + +for file +do + set fnord `echo ":$file" | sed -ne 's/^:\//#/;s/^://;s/\// /g;s/^#/\//;p'` + shift + + pathcomp= + for d + do + pathcomp="$pathcomp$d" + case "$pathcomp" in + -* ) pathcomp=./$pathcomp ;; + esac + + if test ! -d "$pathcomp"; then + echo "mkdir $pathcomp" + + mkdir "$pathcomp" || lasterr=$? + + if test ! -d "$pathcomp"; then + errstatus=$lasterr + fi + fi + + pathcomp="$pathcomp/" + done +done + +exit $errstatus + +# mkinstalldirs ends here ADDED runZippedTests.tcl Index: runZippedTests.tcl ================================================================== --- /dev/null +++ runZippedTests.tcl @@ -0,0 +1,27 @@ +catch { + wm withdraw . + console show +} + +catch {file delete tests.zip} + +puts stdout "Zipping tests" ; update +exec zip -q -9 tests.zip tests/* +puts stdout "Done zipping" + +package require vfs +set mount [vfs::zip::Mount tests.zip tests.zip] +puts "Zip mount is $mount" +update +if {[catch { + cd tests.zip + cd tests + #source cmdAH.test + source all.tcl +} err]} { + puts stdout "Got error $err" +} +puts "Tests complete" +#vfs::zip::Unmount $mount + +#exit ADDED tests/all.tcl Index: tests/all.tcl ================================================================== --- /dev/null +++ tests/all.tcl @@ -0,0 +1,1 @@ +# all.tcl -- # # This file contains a top-level script to run all of the Tcl # tests. Execute it by invoking "source all.test" when running tcltest # in this directory. # # Copyright (c) 1998-2000 by Scriptics Corporation. # All rights reserved. # # RCS: @(#) $Id: all.tcl,v 1.1.1.1 2001/08/03 16:19:01 vincentdarley Exp $ set tcltestVersion [package require tcltest] namespace import -force tcltest::* #tcltest::testsDirectory [file dir [info script]] #tcltest::runAllTests set ::tcltest::testSingleFile false set ::tcltest::testsDirectory [file dir [info script]] # We need to ensure that the testsDirectory is absolute ::tcltest::normalizePath ::tcltest::testsDirectory puts stdout "Tests running in interp: [info nameofexecutable]" puts stdout "Tests running in working dir: $::tcltest::testsDirectory" if {[llength $::tcltest::skip] > 0} { puts stdout "Skipping tests that match: $::tcltest::skip" } if {[llength $::tcltest::match] > 0} { puts stdout "Only running tests that match: $::tcltest::match" } if {[llength $::tcltest::skipFiles] > 0} { puts stdout "Skipping test files that match: $::tcltest::skipFiles" } if {[llength $::tcltest::matchFiles] > 0} { puts stdout "Only sourcing test files that match: $::tcltest::matchFiles" } tcltest::testConstraint fsIsWritable [expr {1 - [catch {file mkdir isreadonly ; file delete isreadonly}]}] set timeCmd {clock format [clock seconds]} puts stdout "Tests began at [eval $timeCmd]" # source each of the specified tests foreach file [lsort [::tcltest::getMatchingFiles]] { set tail [file tail $file] puts stdout $tail if {[catch {source $file} msg]} { puts stdout $msg } } # cleanup puts stdout "\nTests ended at [eval $timeCmd]" ::tcltest::cleanupTests 1 return ADDED tests/cmdAH.test Index: tests/cmdAH.test ================================================================== --- /dev/null +++ tests/cmdAH.test cannot compute difference between binary files ADDED tests/encoding.test Index: tests/encoding.test ================================================================== --- /dev/null +++ tests/encoding.test @@ -0,0 +1,1 @@ +# This file contains a collection of tests for tclEncoding.c # Sourcing this file into Tcl runs the tests and generates output for # errors. No output means no errors were found. # # Copyright (c) 1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: encoding.test,v 1.1.1.1 2001/08/03 16:19:02 vincentdarley Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } proc toutf {args} { global x lappend x "toutf $args" } proc fromutf {args} { global x lappend x "fromutf $args" } # Some tests require the testencoding command set ::tcltest::testConstraints(testencoding) \ [expr {[info commands testencoding] != {}}] # TclInitEncodingSubsystem is tested by the rest of this file # TclFinalizeEncodingSubsystem is not currently tested test encoding-1.1 {Tcl_GetEncoding: system encoding} {testencoding} { testencoding create foo toutf fromutf set old [encoding system] encoding system foo set x {} encoding convertto abcd encoding system $old testencoding delete foo set x } {{fromutf }} test encoding-1.2 {Tcl_GetEncoding: existing encoding} {testencoding} { testencoding create foo toutf fromutf set x {} encoding convertto foo abcd testencoding delete foo set x } {{fromutf }} test encoding-1.3 {Tcl_GetEncoding: load encoding} { list [encoding convertto jis0208 \u4e4e] \ [encoding convertfrom jis0208 8C] } "8C \u4e4e" test encoding-2.1 {Tcl_FreeEncoding: refcount == 0} { encoding convertto jis0208 \u4e4e } {8C} test encoding-2.2 {Tcl_FreeEncoding: refcount != 0} {testencoding} { set system [encoding system] set path [testencoding path] encoding system shiftjis ;# incr ref count testencoding path [list [pwd]] set x [encoding convertto shiftjis \u4e4e] ;# old one found encoding system identity lappend x [catch {encoding convertto shiftjis \u4e4e} msg] $msg encoding system identity testencoding path $path encoding system $system set x } "\u008c\u00c1 1 {unknown encoding \"shiftjis\"}" test encoding-3.1 {Tcl_GetEncodingName, NULL} { set old [encoding system] encoding system shiftjis set x [encoding system] encoding system $old set x } {shiftjis} test encoding-3.2 {Tcl_GetEncodingName, non-null} { set old [fconfigure stdout -encoding] fconfigure stdout -encoding jis0208 set x [fconfigure stdout -encoding] fconfigure stdout -encoding $old set x } {jis0208} test encoding-4.1 {Tcl_GetEncodingNames} {testencoding} { file mkdir tmp/encoding close [open tmp/encoding/junk.enc w] close [open tmp/encoding/junk2.enc w] cd tmp set path [testencoding path] testencoding path {} catch {unset encodings} catch {unset x} foreach encoding [encoding names] { set encodings($encoding) 1 } testencoding path [list [pwd]] foreach encoding [encoding names] { if {![info exists encodings($encoding)]} { lappend x $encoding } } testencoding path $path cd .. file delete -force tmp lsort $x } {junk junk2} test encoding-5.1 {Tcl_SetSystemEncoding} { set old [encoding system] encoding system jis0208 set x [encoding convertto \u4e4e] encoding system identity encoding system $old set x } {8C} test encoding-5.2 {Tcl_SetSystemEncoding: test ref count} { set old [encoding system] encoding system $old string compare $old [encoding system] } {0} test encoding-6.1 {Tcl_CreateEncoding: new} {testencoding} { testencoding create foo {toutf 1} {fromutf 2} set x {} encoding convertfrom foo abcd encoding convertto foo abcd testencoding delete foo set x } {{toutf 1} {fromutf 2}} test encoding-6.2 {Tcl_CreateEncoding: replace encoding} {testencoding} { testencoding create foo {toutf a} {fromutf b} set x {} encoding convertfrom foo abcd encoding convertto foo abcd testencoding delete foo set x } {{toutf a} {fromutf b}} test encoding-7.1 {Tcl_ExternalToUtfDString: small buffer} { encoding convertfrom jis0208 8c8c8c8c } "\u543e\u543e\u543e\u543e" test encoding-7.2 {Tcl_UtfToExternalDString: big buffer} { set a 8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C append a $a append a $a append a $a append a $a set x [encoding convertfrom jis0208 $a] list [string length $x] [string index $x 0] } "512 \u4e4e" test encoding-8.1 {Tcl_ExternalToUtf} {fsIsWritable} { set f [open dummy w] fconfigure $f -translation binary -encoding iso8859-1 puts -nonewline $f "ab\x8c\xc1g" close $f set f [open dummy r] fconfigure $f -translation binary -encoding shiftjis set x [read $f] close $f file delete dummy set x } "ab\u4e4eg" test encoding-9.1 {Tcl_UtfToExternalDString: small buffer} { encoding convertto jis0208 "\u543e\u543e\u543e\u543e" } {8c8c8c8c} test encoding-9.2 {Tcl_UtfToExternalDString: big buffer} { set a \u4e4e\u4e4e\u4e4e\u4e4e\u4e4e\u4e4e\u4e4e\u4e4e append a $a append a $a append a $a append a $a append a $a append a $a set x [encoding convertto jis0208 $a] list [string length $x] [string range $x 0 1] } "1024 8C" test encoding-10.1 {Tcl_UtfToExternal} {fsIsWritable} { set f [open dummy w] fconfigure $f -translation binary -encoding shiftjis puts -nonewline $f "ab\u4e4eg" close $f set f [open dummy r] fconfigure $f -translation binary -encoding iso8859-1 set x [read $f] close $f file delete dummy set x } "ab\x8c\xc1g" test encoding-11.1 {LoadEncodingFile: unknown encoding} {testencoding} { set system [encoding system] set path [testencoding path] encoding system iso8859-1 testencoding path {} set x [list [catch {encoding convertto jis0208 \u4e4e} msg] $msg] testencoding path $path encoding system $system lappend x [encoding convertto jis0208 \u4e4e] } {1 {unknown encoding "jis0208"} 8C} test encoding-11.2 {LoadEncodingFile: single-byte} { encoding convertfrom jis0201 \xa1 } "\uff61" test encoding-11.3 {LoadEncodingFile: double-byte} { encoding convertfrom jis0208 8C } "\u4e4e" test encoding-11.4 {LoadEncodingFile: multi-byte} { encoding convertfrom shiftjis \x8c\xc1 } "\u4e4e" test encoding-11.5 {LoadEncodingFile: escape file} { encoding convertto iso2022 \u4e4e } "\x1b(B\x1b$@8C" test encoding-11.6 {LoadEncodingFile: invalid file} {testencoding} { set system [encoding system] set path [testencoding path] encoding system identity testencoding path tmp file mkdir tmp/encoding set f [open tmp/encoding/splat.enc w] fconfigure $f -translation binary puts $f "abcdefghijklmnop" close $f set x [list [catch {encoding convertto splat \u4e4e} msg] $msg] file delete -force tmp catch {file delete encoding} testencoding path $path encoding system $system set x } {1 {invalid encoding file "splat"}} # OpenEncodingFile is fully tested by the rest of the tests in this file. test encoding-12.1 {LoadTableEncoding: normal encoding} { set x [encoding convertto iso8859-3 \u120] append x [encoding convertto iso8859-3 \ud5] append x [encoding convertfrom iso8859-3 \xd5] } "\xd5?\u120" test encoding-12.2 {LoadTableEncoding: single-byte encoding} { set x [encoding convertto iso8859-3 ab\u0120g] append x [encoding convertfrom iso8859-3 ab\xd5g] } "ab\xd5gab\u120g" test encoding-12.3 {LoadTableEncoding: multi-byte encoding} { set x [encoding convertto shiftjis ab\u4e4eg] append x [encoding convertfrom shiftjis ab\x8c\xc1g] } "ab\x8c\xc1gab\u4e4eg" test encoding-12.4 {LoadTableEncoding: double-byte encoding} { set x [encoding convertto jis0208 \u4e4e\u3b1] append x [encoding convertfrom jis0208 8C&A] } "8C&A\u4e4e\u3b1" test encoding-12.5 {LoadTableEncoding: symbol encoding} { set x [encoding convertto symbol \u3b3] append x [encoding convertto symbol \u67] append x [encoding convertfrom symbol \x67] } "\x67\x67\u3b3" test encoding-13.1 {LoadEscapeTable} { set x [encoding convertto iso2022 ab\u4e4e\u68d9g] } "\x1b(Bab\x1b$@8C\x1b$\(DD%\x1b(Bg" test encoding-14.1 {BinaryProc} { encoding convertto identity \x12\x34\x56\xff\x69 } "\x12\x34\x56\xc3\xbf\x69" test encoding-15.1 {UtfToUtfProc} { encoding convertto utf-8 \xa3 } "\xc2\xa3" test encoding-16.1 {UnicodeToUtfProc} { encoding convertfrom unicode NN } "\u4e4e" test encoding-17.1 {UtfToUnicodeProc} { } {} test encoding-18.1 {TableToUtfProc} { } {} test encoding-19.1 {TableFromUtfProc} { } {} test encoding-20.1 {TableFreefProc} { } {} test encoding-21.1 {EscapeToUtfProc} { } {} test encoding-22.1 {EscapeFromUtfProc} { } {} # EscapeFreeProc, GetTableEncoding, unilen # are fully tested by the rest of this file # cleanup ::tcltest::cleanupTests return ADDED tests/fCmd.test Index: tests/fCmd.test ================================================================== --- /dev/null +++ tests/fCmd.test cannot compute difference between binary files ADDED tests/fileName.test Index: tests/fileName.test ================================================================== --- /dev/null +++ tests/fileName.test @@ -0,0 +1,1596 @@ +# This file tests the filename manipulation routines. +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1995-1996 Sun Microsystems, Inc. +# Copyright (c) 1999 by Scriptics Corporation. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: fileName.test,v 1.1.1.1 2001/08/03 16:19:04 vincentdarley Exp $ + +if {[lsearch [namespace children] ::tcltest] == -1} { + package require tcltest + namespace import -force ::tcltest::* +} + +tcltest::testConstraint testsetplatform [string equal testsetplatform [info commands testsetplatform]] +tcltest::testConstraint testtranslatefilename [string equal testtranslatefilename [info commands testtranslatefilename]] + +global env +if {[tcltest::testConstraint testsetplatform]} { + set platform [testgetplatform] +} + +test filename-1.1 {Tcl_GetPathType: unix} {testsetplatform} { + testsetplatform unix + file pathtype / +} absolute +test filename-1.2 {Tcl_GetPathType: unix} {testsetplatform} { + testsetplatform unix + file pathtype /foo +} absolute +test filename-1.3 {Tcl_GetPathType: unix} {testsetplatform} { + testsetplatform unix + file pathtype foo +} relative +test filename-1.4 {Tcl_GetPathType: unix} {testsetplatform} { + testsetplatform unix + file pathtype c:/foo +} relative +test filename-1.5 {Tcl_GetPathType: unix} {testsetplatform} { + testsetplatform unix + file pathtype ~ +} absolute +test filename-1.6 {Tcl_GetPathType: unix} {testsetplatform} { + testsetplatform unix + file pathtype ~/foo +} absolute +test filename-1.7 {Tcl_GetPathType: unix} {testsetplatform} { + testsetplatform unix + file pathtype ~foo +} absolute +test filename-1.8 {Tcl_GetPathType: unix} {testsetplatform} { + testsetplatform unix + file pathtype ./~foo +} relative + +test filename-2.1 {Tcl_GetPathType: mac, denerate names} {testsetplatform} { + testsetplatform mac + file pathtype / +} relative +test filename-2.2 {Tcl_GetPathType: mac, denerate names} {testsetplatform} { + testsetplatform mac + file pathtype /. +} relative +test filename-2.3 {Tcl_GetPathType: mac, denerate names} {testsetplatform} { + testsetplatform mac + file pathtype /.. +} relative +test filename-2.4 {Tcl_GetPathType: mac, denerate names} {testsetplatform} { + testsetplatform mac + file pathtype //.// +} relative +test filename-2.5 {Tcl_GetPathType: mac, denerate names} {testsetplatform} { + testsetplatform mac + file pathtype //.//../. +} relative +test filename-2.6 {Tcl_GetPathType: mac, tilde names} {testsetplatform} { + testsetplatform mac + file pathtype ~ +} absolute +test filename-2.7 {Tcl_GetPathType: mac, tilde names} {testsetplatform} { + testsetplatform mac + file pathtype ~: +} absolute +test filename-2.8 {Tcl_GetPathType: mac, tilde names} {testsetplatform} { + testsetplatform mac + file pathtype ~:foo +} absolute +test filename-2.9 {Tcl_GetPathType: mac, tilde names} {testsetplatform} { + testsetplatform mac + file pathtype ~/ +} absolute +test filename-2.10 {Tcl_GetPathType: mac, tilde names} {testsetplatform} { + testsetplatform mac + file pathtype ~/foo +} absolute +test filename-2.11 {Tcl_GetPathType: mac, unix-style names} {testsetplatform} { + testsetplatform mac + file pathtype /foo +} absolute +test filename-2.12 {Tcl_GetPathType: mac, unix-style names} {testsetplatform} { + testsetplatform mac + file pathtype /./foo +} absolute +test filename-2.13 {Tcl_GetPathType: mac, unix-style names} {testsetplatform} { + testsetplatform mac + file pathtype /..//./foo +} absolute +test filename-2.14 {Tcl_GetPathType: mac, unix-style names} {testsetplatform} { + testsetplatform mac + file pathtype /foo/bar +} absolute +test filename-2.15 {Tcl_GetPathType: mac, unix-style names} {testsetplatform} { + testsetplatform mac + file pathtype foo/bar +} relative +test filename-2.16 {Tcl_GetPathType: mac, mac-style names} {testsetplatform} { + testsetplatform mac + file pathtype : +} relative +test filename-2.17 {Tcl_GetPathType: mac, mac-style names} {testsetplatform} { + testsetplatform mac + file pathtype :foo +} relative +test filename-2.18 {Tcl_GetPathType: mac, mac-style names} {testsetplatform} { + testsetplatform mac + file pathtype foo: +} absolute +test filename-2.19 {Tcl_GetPathType: mac, mac-style names} {testsetplatform} { + testsetplatform mac + file pathtype foo:bar +} absolute +test filename-2.20 {Tcl_GetPathType: mac, mac-style names} {testsetplatform} { + testsetplatform mac + file pathtype :foo:bar +} relative +test filename-2.21 {Tcl_GetPathType: mac, mac-style names} {testsetplatform} { + testsetplatform mac + file pathtype ::foo:bar +} relative +test filename-2.22 {Tcl_GetPathType: mac, mac-style names} {testsetplatform} { + testsetplatform mac + file pathtype ~foo +} absolute +test filename-2.23 {Tcl_GetPathType: mac, mac-style names} {testsetplatform} { + testsetplatform mac + file pathtype :~foo +} relative +test filename-2.24 {Tcl_GetPathType: mac, mac-style names} {testsetplatform} { + testsetplatform mac + file pathtype ~foo: +} absolute +test filename-2.25 {Tcl_GetPathType: mac, mac-style names} {testsetplatform} { + testsetplatform mac + file pathtype foo/bar: +} absolute +test filename-2.26 {Tcl_GetPathType: mac, mac-style names} {testsetplatform} { + testsetplatform mac + file pathtype /foo: +} absolute +test filename-2.27 {Tcl_GetPathType: mac, mac-style names} {testsetplatform} { + testsetplatform mac + file pathtype foo +} relative + +test filename-3.1 {Tcl_GetPathType: windows} {testsetplatform} { + testsetplatform windows + file pathtype / +} volumerelative +test filename-3.2 {Tcl_GetPathType: windows} {testsetplatform} { + testsetplatform windows + file pathtype \\ +} volumerelative +test filename-3.3 {Tcl_GetPathType: windows} {testsetplatform} { + testsetplatform windows + file pathtype /foo +} volumerelative +test filename-3.4 {Tcl_GetPathType: windows} {testsetplatform} { + testsetplatform windows + file pathtype \\foo +} volumerelative +test filename-3.5 {Tcl_GetPathType: windows} {testsetplatform} { + testsetplatform windows + file pathtype c:/ +} absolute +test filename-3.6 {Tcl_GetPathType: windows} {testsetplatform} { + testsetplatform windows + file pathtype c:\\ +} absolute +test filename-3.7 {Tcl_GetPathType: windows} {testsetplatform} { + testsetplatform windows + file pathtype c:/foo +} absolute +test filename-3.8 {Tcl_GetPathType: windows} {testsetplatform} { + testsetplatform windows + file pathtype c:\\foo +} absolute +test filename-3.9 {Tcl_GetPathType: windows} {testsetplatform} { + testsetplatform windows + file pathtype c: +} volumerelative +test filename-3.10 {Tcl_GetPathType: windows} {testsetplatform} { + testsetplatform windows + file pathtype c:foo +} volumerelative +test filename-3.11 {Tcl_GetPathType: windows} {testsetplatform} { + testsetplatform windows + file pathtype foo +} relative +test filename-3.12 {Tcl_GetPathType: windows} {testsetplatform} { + testsetplatform windows + file pathtype //foo/bar +} absolute +test filename-3.13 {Tcl_GetPathType: windows} {testsetplatform} { + testsetplatform windows + file pathtype ~foo +} absolute +test filename-3.14 {Tcl_GetPathType: windows} {testsetplatform} { + testsetplatform windows + file pathtype ~ +} absolute +test filename-3.15 {Tcl_GetPathType: windows} {testsetplatform} { + testsetplatform windows + file pathtype ~/foo +} absolute +test filename-3.16 {Tcl_GetPathType: windows} {testsetplatform} { + testsetplatform windows + file pathtype ./~foo +} relative + +test filename-4.1 {Tcl_SplitPath: unix} {testsetplatform} { + testsetplatform unix + file split / +} {/} +test filename-4.2 {Tcl_SplitPath: unix} {testsetplatform} { + testsetplatform unix + file split /foo +} {/ foo} +test filename-4.3 {Tcl_SplitPath: unix} {testsetplatform} { + testsetplatform unix + file split /foo/bar +} {/ foo bar} +test filename-4.4 {Tcl_SplitPath: unix} {testsetplatform} { + testsetplatform unix + file split /foo/bar/baz +} {/ foo bar baz} +test filename-4.5 {Tcl_SplitPath: unix} {testsetplatform} { + testsetplatform unix + file split foo/bar +} {foo bar} +test filename-4.6 {Tcl_SplitPath: unix} {testsetplatform} { + testsetplatform unix + file split ./foo/bar +} {. foo bar} +test filename-4.7 {Tcl_SplitPath: unix} {testsetplatform} { + testsetplatform unix + file split /foo/../././foo/bar +} {/ foo .. . . foo bar} +test filename-4.8 {Tcl_SplitPath: unix} {testsetplatform} { + testsetplatform unix + file split ../foo/bar +} {.. foo bar} +test filename-4.9 {Tcl_SplitPath: unix} {testsetplatform} { + testsetplatform unix + file split {} +} {} +test filename-4.10 {Tcl_SplitPath: unix} {testsetplatform} { + testsetplatform unix + file split . +} {.} +test filename-4.11 {Tcl_SplitPath: unix} {testsetplatform} { + testsetplatform unix + file split ../ +} {..} +test filename-4.12 {Tcl_SplitPath: unix} {testsetplatform} { + testsetplatform unix + file split ../.. +} {.. ..} +test filename-4.13 {Tcl_SplitPath: unix} {testsetplatform} { + testsetplatform unix + file split //foo +} {/ foo} +test filename-4.14 {Tcl_SplitPath: unix} {testsetplatform} { + testsetplatform unix + file split foo//bar +} {foo bar} +test filename-4.15 {Tcl_SplitPath: unix} {testsetplatform} { + testsetplatform unix + file split ~foo +} {~foo} +test filename-4.16 {Tcl_SplitPath: unix} {testsetplatform} { + testsetplatform unix + file split ~foo/~bar +} {~foo ./~bar} +test filename-4.17 {Tcl_SplitPath: unix} {testsetplatform} { + testsetplatform unix + file split ~foo/~bar/~baz +} {~foo ./~bar ./~baz} +test filename-4.18 {Tcl_SplitPath: unix} {testsetplatform} { + testsetplatform unix + file split foo/bar~/baz +} {foo bar~ baz} + +test filename-5.1 {Tcl_SplitPath: mac} {testsetplatform} { + testsetplatform mac + file split a:b +} {a: b} +test filename-5.2 {Tcl_SplitPath: mac} {testsetplatform} { + testsetplatform mac + file split a:b:c +} {a: b c} +test filename-5.3 {Tcl_SplitPath: mac} {testsetplatform} { + testsetplatform mac + file split a:b:c: +} {a: b c} +test filename-5.4 {Tcl_SplitPath: mac} {testsetplatform} { + testsetplatform mac + file split a: +} {a:} +test filename-5.5 {Tcl_SplitPath: mac} {testsetplatform} { + testsetplatform mac + file split a:: +} {a: ::} +test filename-5.6 {Tcl_SplitPath: mac} {testsetplatform} { + testsetplatform mac + file split a::: +} {a: :: ::} +test filename-5.7 {Tcl_SplitPath: mac} {testsetplatform} { + testsetplatform mac + file split :a +} {a} +test filename-5.8 {Tcl_SplitPath: mac} {testsetplatform} { + testsetplatform mac + file split :a:: +} {a ::} +test filename-5.9 {Tcl_SplitPath: mac} {testsetplatform} { + testsetplatform mac + file split : +} {:} +test filename-5.10 {Tcl_SplitPath: mac} {testsetplatform} { + testsetplatform mac + file split :: +} {::} +test filename-5.11 {Tcl_SplitPath: mac} {testsetplatform} { + testsetplatform mac + file split ::: +} {:: ::} +test filename-5.12 {Tcl_SplitPath: mac} {testsetplatform} { + testsetplatform mac + file split a:::b +} {a: :: :: b} +test filename-5.13 {Tcl_SplitPath: mac} {testsetplatform} { + testsetplatform mac + file split /a:b +} {/a: b} +test filename-5.14 {Tcl_SplitPath: mac} {testsetplatform} { + testsetplatform mac + file split ~: +} {~:} +test filename-5.15 {Tcl_SplitPath: mac} {testsetplatform} { + testsetplatform mac + file split ~/: +} {~/:} +test filename-5.16 {Tcl_SplitPath: mac} {testsetplatform} { + testsetplatform mac + file split ~:foo +} {~: foo} +test filename-5.17 {Tcl_SplitPath: mac} {testsetplatform} { + testsetplatform mac + file split ~/foo +} {~: foo} +test filename-5.18 {Tcl_SplitPath: mac} {testsetplatform} { + testsetplatform mac + file split ~foo: +} {~foo:} +test filename-5.19 {Tcl_SplitPath: mac} {testsetplatform} { + testsetplatform mac + file split a:~foo +} {a: :~foo} +test filename-5.20 {Tcl_SplitPath: mac} {testsetplatform} { + testsetplatform mac + file split / +} {:/} +test filename-5.21 {Tcl_SplitPath: mac} {testsetplatform} { + testsetplatform mac + file split a:b/c +} {a: :b/c} +test filename-5.22 {Tcl_SplitPath: mac} {testsetplatform} { + testsetplatform mac + file split /foo +} {foo:} +test filename-5.23 {Tcl_SplitPath: mac} {testsetplatform} { + testsetplatform mac + file split /a/b +} {a: b} +test filename-5.24 {Tcl_SplitPath: mac} {testsetplatform} { + testsetplatform mac + file split /a/b/foo +} {a: b foo} +test filename-5.25 {Tcl_SplitPath: mac} {testsetplatform} { + testsetplatform mac + file split a/b +} {a b} +test filename-5.26 {Tcl_SplitPath: mac} {testsetplatform} { + testsetplatform mac + file split ./foo/bar +} {: foo bar} +test filename-5.27 {Tcl_SplitPath: mac} {testsetplatform} { + testsetplatform mac + file split ../foo/bar +} {:: foo bar} +test filename-5.28 {Tcl_SplitPath: mac} {testsetplatform} { + testsetplatform mac + file split {} +} {} +test filename-5.29 {Tcl_SplitPath: mac} {testsetplatform} { + testsetplatform mac + file split . +} {:} +test filename-5.30 {Tcl_SplitPath: mac} {testsetplatform} { + testsetplatform mac + file split ././ +} {: :} +test filename-5.31 {Tcl_SplitPath: mac} {testsetplatform} { + testsetplatform mac + file split ././. +} {: : :} +test filename-5.32 {Tcl_SplitPath: mac} {testsetplatform} { + testsetplatform mac + file split ../ +} {::} +test filename-5.33 {Tcl_SplitPath: mac} {testsetplatform} { + testsetplatform mac + file split .. +} {::} +test filename-5.34 {Tcl_SplitPath: mac} {testsetplatform} { + testsetplatform mac + file split ../.. +} {:: ::} +test filename-5.35 {Tcl_SplitPath: mac} {testsetplatform} { + testsetplatform mac + file split //foo +} {foo:} +test filename-5.36 {Tcl_SplitPath: mac} {testsetplatform} { + testsetplatform mac + file split foo//bar +} {foo bar} +test filename-5.37 {Tcl_SplitPath: mac} {testsetplatform} { + testsetplatform mac + file split ~foo +} {~foo:} +test filename-5.38 {Tcl_SplitPath: mac} {testsetplatform} { + testsetplatform mac + file split ~ +} {~:} +test filename-5.39 {Tcl_SplitPath: mac} {testsetplatform} { + testsetplatform mac + file split foo +} {foo} +test filename-5.40 {Tcl_SplitPath: mac} {testsetplatform} { + testsetplatform mac + file split ~/ +} {~:} +test filename-5.41 {Tcl_SplitPath: mac} {testsetplatform} { + testsetplatform mac + file split ~foo/~bar +} {~foo: :~bar} +test filename-5.42 {Tcl_SplitPath: mac} {testsetplatform} { + testsetplatform mac + file split ~foo/~bar/~baz +} {~foo: :~bar :~baz} +test filename-5.43 {Tcl_SplitPath: mac} {testsetplatform} { + testsetplatform mac + file split foo/bar~/baz +} {foo bar~ baz} +test filename-5.44 {Tcl_SplitPath: mac} {testsetplatform} { + testsetplatform mac + file split a/../b +} {a :: b} +test filename-5.45 {Tcl_SplitPath: mac} {testsetplatform} { + testsetplatform mac + file split a/../../b +} {a :: :: b} +test filename-5.46 {Tcl_SplitPath: mac} {testsetplatform} { + testsetplatform mac + file split a/.././../b +} {a :: : :: b} +test filename-5.47 {Tcl_SplitPath: mac} {testsetplatform} { + testsetplatform mac + file split /../bar +} {bar:} +test filename-5.48 {Tcl_SplitPath: mac} {testsetplatform} { + testsetplatform mac + file split /./bar +} {bar:} +test filename-5.49 {Tcl_SplitPath: mac} {testsetplatform} { + testsetplatform mac + file split //.//.././bar +} {bar:} +test filename-5.50 {Tcl_SplitPath: mac} {testsetplatform} { + testsetplatform mac + file split /.. +} {:/..} +test filename-5.51 {Tcl_SplitPath: mac} {testsetplatform} { + testsetplatform mac + file split //.//.././ +} {://.//.././} + +test filename-6.1 {Tcl_SplitPath: win} {testsetplatform} { + testsetplatform win + file split / +} {/} +test filename-6.2 {Tcl_SplitPath: win} {testsetplatform} { + testsetplatform win + file split /foo +} {/ foo} +test filename-6.3 {Tcl_SplitPath: win} {testsetplatform} { + testsetplatform win + file split /foo/bar +} {/ foo bar} +test filename-6.4 {Tcl_SplitPath: win} {testsetplatform} { + testsetplatform win + file split /foo/bar/baz +} {/ foo bar baz} +test filename-6.5 {Tcl_SplitPath: win} {testsetplatform} { + testsetplatform win + file split foo/bar +} {foo bar} +test filename-6.6 {Tcl_SplitPath: win} {testsetplatform} { + testsetplatform win + file split ./foo/bar +} {. foo bar} +test filename-6.7 {Tcl_SplitPath: win} {testsetplatform} { + testsetplatform win + file split /foo/../././foo/bar +} {/ foo .. . . foo bar} +test filename-6.8 {Tcl_SplitPath: win} {testsetplatform} { + testsetplatform win + file split ../foo/bar +} {.. foo bar} +test filename-6.9 {Tcl_SplitPath: win} {testsetplatform} { + testsetplatform win + file split {} +} {} +test filename-6.10 {Tcl_SplitPath: win} {testsetplatform} { + testsetplatform win + file split . +} {.} +test filename-6.11 {Tcl_SplitPath: win} {testsetplatform} { + testsetplatform win + file split ../ +} {..} +test filename-6.12 {Tcl_SplitPath: win} {testsetplatform} { + testsetplatform win + file split ../.. +} {.. ..} +test filename-6.13 {Tcl_SplitPath: win} {testsetplatform} { + testsetplatform win + file split //foo +} {/ foo} +test filename-6.14 {Tcl_SplitPath: win} {testsetplatform} { + testsetplatform win + file split foo//bar +} {foo bar} +test filename-6.15 {Tcl_SplitPath: win} {testsetplatform} { + testsetplatform win + file split /\\/foo//bar +} {//foo/bar} +test filename-6.16 {Tcl_SplitPath: win} {testsetplatform} { + testsetplatform win + file split /\\/foo//bar +} {//foo/bar} +test filename-6.17 {Tcl_SplitPath: win} {testsetplatform} { + testsetplatform win + file split /\\/foo//bar +} {//foo/bar} +test filename-6.18 {Tcl_SplitPath: win} {testsetplatform} { + testsetplatform win + file split \\\\foo\\bar +} {//foo/bar} +test filename-6.19 {Tcl_SplitPath: win} {testsetplatform} { + testsetplatform win + file split \\\\foo\\bar/baz +} {//foo/bar baz} +test filename-6.20 {Tcl_SplitPath: win} {testsetplatform} { + testsetplatform win + file split c:/foo +} {c:/ foo} +test filename-6.21 {Tcl_SplitPath: win} {testsetplatform} { + testsetplatform win + file split c:foo +} {c: foo} +test filename-6.22 {Tcl_SplitPath: win} {testsetplatform} { + testsetplatform win + file split c: +} {c:} +test filename-6.23 {Tcl_SplitPath: win} {testsetplatform} { + testsetplatform win + file split c:\\ +} {c:/} +test filename-6.24 {Tcl_SplitPath: win} {testsetplatform} { + testsetplatform win + file split c:/ +} {c:/} +test filename-6.25 {Tcl_SplitPath: win} {testsetplatform} { + testsetplatform win + file split c:/./.. +} {c:/ . ..} +test filename-6.26 {Tcl_SplitPath: win} {testsetplatform} { + testsetplatform win + file split ~foo +} {~foo} +test filename-6.27 {Tcl_SplitPath: win} {testsetplatform} { + testsetplatform win + file split ~foo/~bar +} {~foo ./~bar} +test filename-6.28 {Tcl_SplitPath: win} {testsetplatform} { + testsetplatform win + file split ~foo/~bar/~baz +} {~foo ./~bar ./~baz} +test filename-6.29 {Tcl_SplitPath: win} {testsetplatform} { + testsetplatform win + file split foo/bar~/baz +} {foo bar~ baz} +test filename-6.30 {Tcl_SplitPath: win} {testsetplatform} { + testsetplatform win + file split c:~foo +} {c: ./~foo} + +test filename-7.1 {Tcl_JoinPath: unix} {testsetplatform} { + testsetplatform unix + file join / a +} {/a} +test filename-7.2 {Tcl_JoinPath: unix} {testsetplatform} { + testsetplatform unix + file join a b +} {a/b} +test filename-7.3 {Tcl_JoinPath: unix} {testsetplatform} { + testsetplatform unix + file join /a c /b d +} {/b/d} +test filename-7.4 {Tcl_JoinPath: unix} {testsetplatform} { + testsetplatform unix + file join / +} {/} +test filename-7.5 {Tcl_JoinPath: unix} {testsetplatform} { + testsetplatform unix + file join a +} {a} +test filename-7.6 {Tcl_JoinPath: unix} {testsetplatform} { + testsetplatform unix + file join {} +} {} +test filename-7.7 {Tcl_JoinPath: unix} {testsetplatform} { + testsetplatform unix + file join /a/ b +} {/a/b} +test filename-7.8 {Tcl_JoinPath: unix} {testsetplatform} { + testsetplatform unix + file join /a// b +} {/a/b} +test filename-7.9 {Tcl_JoinPath: unix} {testsetplatform} { + testsetplatform unix + file join /a/./../. b +} {/a/./.././b} +test filename-7.10 {Tcl_JoinPath: unix} {testsetplatform} { + testsetplatform unix + file join ~ a +} {~/a} +test filename-7.11 {Tcl_JoinPath: unix} {testsetplatform} { + testsetplatform unix + file join ~a ~b +} {~b} +test filename-7.12 {Tcl_JoinPath: unix} {testsetplatform} { + testsetplatform unix + file join ./~a b +} {./~a/b} +test filename-7.13 {Tcl_JoinPath: unix} {testsetplatform} { + testsetplatform unix + file join ./~a ~b +} {~b} +test filename-7.14 {Tcl_JoinPath: unix} {testsetplatform} { + testsetplatform unix + file join ./~a ./~b +} {./~a/~b} +test filename-7.15 {Tcl_JoinPath: unix} {testsetplatform} { + testsetplatform unix + file join a . b +} {a/./b} +test filename-7.16 {Tcl_JoinPath: unix} {testsetplatform} { + testsetplatform unix + file join a . ./~b +} {a/./~b} +test filename-7.17 {Tcl_JoinPath: unix} {testsetplatform} { + testsetplatform unix + file join //a b +} {/a/b} +test filename-7.18 {Tcl_JoinPath: unix} {testsetplatform} { + testsetplatform unix + file join /// a b +} {/a/b} + +test filename-8.1 {Tcl_JoinPath: mac} {testsetplatform} { + testsetplatform mac + file join a b +} {:a:b} +test filename-8.2 {Tcl_JoinPath: mac} {testsetplatform} { + testsetplatform mac + file join :a b +} {:a:b} +test filename-8.3 {Tcl_JoinPath: mac} {testsetplatform} { + testsetplatform mac + file join a b: +} {b:} +test filename-8.4 {Tcl_JoinPath: mac} {testsetplatform} { + testsetplatform mac + file join a: :b +} {a:b} +test filename-8.5 {Tcl_JoinPath: mac} {testsetplatform} { + testsetplatform mac + file join a: :b: +} {a:b} +test filename-8.6 {Tcl_JoinPath: mac} {testsetplatform} { + testsetplatform mac + file join a :: b +} {:a::b} +test filename-8.7 {Tcl_JoinPath: mac} {testsetplatform} { + testsetplatform mac + file join a :: :: b +} {:a:::b} +test filename-8.8 {Tcl_JoinPath: mac} {testsetplatform} { + testsetplatform mac + file join a ::: b +} {:a:::b} +test filename-8.9 {Tcl_JoinPath: mac} {testsetplatform} { + testsetplatform mac + file join a: b: +} {b:} +test filename-8.10 {Tcl_JoinPath: mac} {testsetplatform} { + testsetplatform mac + file join /a/b +} {a:b} +test filename-8.11 {Tcl_JoinPath: mac} {testsetplatform} { + testsetplatform mac + file join /a/b c/d +} {a:b:c:d} +test filename-8.12 {Tcl_JoinPath: mac} {testsetplatform} { + testsetplatform mac + file join /a/b :c:d +} {a:b:c:d} +test filename-8.13 {Tcl_JoinPath: mac} {testsetplatform} { + testsetplatform mac + file join ~ foo +} {~:foo} +test filename-8.14 {Tcl_JoinPath: mac} {testsetplatform} { + testsetplatform mac + file join :: :: +} {:::} +test filename-8.15 {Tcl_JoinPath: mac} {testsetplatform} { + testsetplatform mac + file join a: :: +} {a::} +test filename-8.16 {Tcl_JoinPath: mac} {testsetplatform} { + testsetplatform mac + file join a {} b +} {:a:b} +test filename-8.17 {Tcl_JoinPath: mac} {testsetplatform} { + testsetplatform mac + file join a::: b +} {a:::b} +test filename-8.18 {Tcl_JoinPath: mac} {testsetplatform} { + testsetplatform mac + file join a : : : +} {:a} +test filename-8.19 {Tcl_JoinPath: mac} {testsetplatform} { + testsetplatform mac + file join : +} {:} +test filename-8.20 {Tcl_JoinPath: mac} {testsetplatform} { + testsetplatform mac + file join : a +} {:a} +test filename-8.21 {Tcl_JoinPath: mac} {testsetplatform} { + testsetplatform mac + file join a: :b/c +} {a:b/c} +test filename-8.22 {Tcl_JoinPath: mac} {testsetplatform} { + testsetplatform mac + file join :a :b/c +} {:a:b/c} + +test filename-9.1 {Tcl_JoinPath: win} {testsetplatform} { + testsetplatform win + file join a b +} {a/b} +test filename-9.2 {Tcl_JoinPath: win} {testsetplatform} { + testsetplatform win + file join /a b +} {/a/b} +test filename-9.3 {Tcl_JoinPath: win} {testsetplatform} { + testsetplatform win + file join /a /b +} {/b} +test filename-9.4 {Tcl_JoinPath: win} {testsetplatform} { + testsetplatform win + file join c: foo +} {c:foo} +test filename-9.5 {Tcl_JoinPath: win} {testsetplatform} { + testsetplatform win + file join c:/ foo +} {c:/foo} +test filename-9.6 {Tcl_JoinPath: win} {testsetplatform} { + testsetplatform win + file join c:\\bar foo +} {c:/bar/foo} +test filename-9.7 {Tcl_JoinPath: win} {testsetplatform} { + testsetplatform win + file join /foo c:bar +} {c:bar} +test filename-9.8 {Tcl_JoinPath: win} {testsetplatform} { + testsetplatform win + file join ///host//share dir +} {//host/share/dir} +test filename-9.9 {Tcl_JoinPath: win} {testsetplatform} { + testsetplatform win + file join ~ foo +} {~/foo} +test filename-9.10 {Tcl_JoinPath: win} {testsetplatform} { + testsetplatform win + file join ~/~foo +} {~/~foo} +test filename-9.11 {Tcl_JoinPath: win} {testsetplatform} { + testsetplatform win + file join ~ ./~foo +} {~/~foo} +test filename-9.12 {Tcl_JoinPath: win} {testsetplatform} { + testsetplatform win + file join / ~foo +} {~foo} +test filename-9.13 {Tcl_JoinPath: win} {testsetplatform} { + testsetplatform win + file join ./a/ b c +} {./a/b/c} +test filename-9.14 {Tcl_JoinPath: win} {testsetplatform} { + testsetplatform win + file join ./~a/ b c +} {./~a/b/c} +test filename-9.15 {Tcl_JoinPath: win} {testsetplatform} { + testsetplatform win + file join // host share path +} {/host/share/path} +test filename-9.16 {Tcl_JoinPath: win} {testsetplatform} { + testsetplatform win + file join foo . bar +} {foo/./bar} +test filename-9.17 {Tcl_JoinPath: win} {testsetplatform} { + testsetplatform win + file join foo .. bar +} {foo/../bar} +test filename-9.18 {Tcl_JoinPath: win} {testsetplatform} { + testsetplatform win + file join foo/./bar +} {foo/./bar} + +test filename-10.1 {Tcl_TranslateFileName} {testsetplatform} { + testsetplatform unix + list [catch {testtranslatefilename foo} msg] $msg +} {0 foo} +test filename-10.2 {Tcl_TranslateFileName} {testsetplatform} { + testsetplatform windows + list [catch {testtranslatefilename {c:/foo}} msg] $msg +} {0 {c:\foo}} +test filename-10.3 {Tcl_TranslateFileName} {testsetplatform} { + testsetplatform windows + list [catch {testtranslatefilename {c:/\\foo/}} msg] $msg +} {0 {c:\foo}} +test filename-10.4 {Tcl_TranslateFileName} {testsetplatform} { + testsetplatform mac + list [catch {testtranslatefilename foo} msg] $msg +} {0 :foo} +test filename-10.5 {Tcl_TranslateFileName} {testsetplatform} { + testsetplatform mac + list [catch {testtranslatefilename :~foo} msg] $msg +} {0 :~foo} +test filename-10.6 {Tcl_TranslateFileName} {testsetplatform} { + global env + set temp $env(HOME) + set env(HOME) "/home/test" + testsetplatform unix + set result [list [catch {testtranslatefilename ~/foo} msg] $msg] + set env(HOME) $temp + set result +} {0 /home/test/foo} +test filename-10.7 {Tcl_TranslateFileName} {testsetplatform} { + global env + set temp $env(HOME) + unset env(HOME) + testsetplatform unix + set result [list [catch {testtranslatefilename ~/foo} msg] $msg] + set env(HOME) $temp + set result +} {1 {couldn't find HOME environment variable to expand path}} +test filename-10.8 {Tcl_TranslateFileName} {testsetplatform} { + global env + set temp $env(HOME) + set env(HOME) "/home/test" + testsetplatform unix + set result [list [catch {testtranslatefilename ~} msg] $msg] + set env(HOME) $temp + set result +} {0 /home/test} +test filename-10.9 {Tcl_TranslateFileName} {testsetplatform} { + global env + set temp $env(HOME) + set env(HOME) "/home/test/" + testsetplatform unix + set result [list [catch {testtranslatefilename ~} msg] $msg] + set env(HOME) $temp + set result +} {0 /home/test} +test filename-10.10 {Tcl_TranslateFileName} {testsetplatform} { + global env + set temp $env(HOME) + set env(HOME) "/home/test/" + testsetplatform unix + set result [list [catch {testtranslatefilename ~/foo} msg] $msg] + set env(HOME) $temp + set result +} {0 /home/test/foo} +test filename-10.11 {Tcl_TranslateFileName} {testsetplatform} { + global env + set temp $env(HOME) + set env(HOME) "Root:" + testsetplatform mac + set result [list [catch {testtranslatefilename ~/foo} msg] $msg] + set env(HOME) $temp + set result +} {0 Root:foo} +test filename-10.12 {Tcl_TranslateFileName} {testsetplatform} { + global env + set temp $env(HOME) + set env(HOME) "Root:home" + testsetplatform mac + set result [list [catch {testtranslatefilename ~/foo} msg] $msg] + set env(HOME) $temp + set result +} {0 Root:home:foo} +test filename-10.13 {Tcl_TranslateFileName} {testsetplatform} { + global env + set temp $env(HOME) + set env(HOME) "Root:home" + testsetplatform mac + set result [list [catch {testtranslatefilename ~::foo} msg] $msg] + set env(HOME) $temp + set result +} {0 Root:home::foo} +test filename-10.14 {Tcl_TranslateFileName} {testsetplatform} { + global env + set temp $env(HOME) + set env(HOME) "Root:home" + testsetplatform mac + set result [list [catch {testtranslatefilename ~} msg] $msg] + set env(HOME) $temp + set result +} {0 Root:home} +test filename-10.15 {Tcl_TranslateFileName} {testsetplatform} { + global env + set temp $env(HOME) + set env(HOME) "Root:home:" + testsetplatform mac + set result [list [catch {testtranslatefilename ~::foo} msg] $msg] + set env(HOME) $temp + set result +} {0 Root:home::foo} +test filename-10.16 {Tcl_TranslateFileName} {testsetplatform} { + global env + set temp $env(HOME) + set env(HOME) "Root:home::" + testsetplatform mac + set result [list [catch {testtranslatefilename ~::foo} msg] $msg] + set env(HOME) $temp + set result +} {0 Root:home:::foo} +test filename-10.17 {Tcl_TranslateFileName} {testsetplatform} { + global env + set temp $env(HOME) + set env(HOME) "\\home\\" + testsetplatform windows + set result [list [catch {testtranslatefilename ~/foo} msg] $msg] + set env(HOME) $temp + set result +} {0 {\home\foo}} +test filename-10.18 {Tcl_TranslateFileName} {testsetplatform} { + global env + set temp $env(HOME) + set env(HOME) "\\home\\" + testsetplatform windows + set result [list [catch {testtranslatefilename ~/foo\\bar} msg] $msg] + set env(HOME) $temp + set result +} {0 {\home\foo\bar}} +test filename-10.19 {Tcl_TranslateFileName} {testsetplatform} { + global env + set temp $env(HOME) + set env(HOME) "c:" + testsetplatform windows + set result [list [catch {testtranslatefilename ~/foo} msg] $msg] + set env(HOME) $temp + set result +} {0 c:foo} +test filename-10.20 {Tcl_TranslateFileName} {testtranslatefilename} { + list [catch {testtranslatefilename ~blorp/foo} msg] $msg +} {1 {user "blorp" doesn't exist}} +test filename-10.21 {Tcl_TranslateFileName} {testsetplatform} { + global env + set temp $env(HOME) + set env(HOME) "c:\\" + testsetplatform windows + set result [list [catch {testtranslatefilename ~/foo} msg] $msg] + set env(HOME) $temp + set result +} {0 {c:\foo}} +test filename-10.22 {Tcl_TranslateFileName} {testsetplatform} { + testsetplatform windows + list [catch {testtranslatefilename foo//bar} msg] $msg +} {0 {foo\bar}} + +if {[tcltest::testConstraint testsetplatform]} { + testsetplatform $platform +} + +test filename-10.23 {Tcl_TranslateFileName} {unixOnly nonPortable} { + # this test fails if ~ouster is not /home/ouster + list [catch {testtranslatefilename ~ouster} msg] $msg +} {0 /home/ouster} +test filename-10.24 {Tcl_TranslateFileName} {unixOnly nonPortable} { + # this test fails if ~ouster is not /home/ouster + list [catch {testtranslatefilename ~ouster/foo} msg] $msg +} {0 /home/ouster/foo} + + +test filename-11.1 {Tcl_GlobCmd} { + list [catch {glob} msg] $msg +} {1 {wrong # args: should be "glob ?switches? name ?name ...?"}} +test filename-11.2 {Tcl_GlobCmd} { + list [catch {glob -gorp} msg] $msg +} {1 {bad option "-gorp": must be -directory, -join, -nocomplain, -path, -tails, -types, or --}} +test filename-11.3 {Tcl_GlobCmd} { + list [catch {glob -nocomplai} msg] $msg +} {1 {wrong # args: should be "glob ?switches? name ?name ...?"}} +test filename-11.4 {Tcl_GlobCmd} { + list [catch {glob -nocomplain} msg] $msg +} {1 {wrong # args: should be "glob ?switches? name ?name ...?"}} +test filename-11.5 {Tcl_GlobCmd} { + list [catch {glob -nocomplain ~xyqrszzz} msg] $msg +} {0 {}} +test filename-11.6 {Tcl_GlobCmd} { + list [catch {glob ~xyqrszzz} msg] $msg +} {1 {user "xyqrszzz" doesn't exist}} +test filename-11.7 {Tcl_GlobCmd} { + list [catch {glob -- -nocomplain} msg] $msg +} {1 {no files matched glob pattern "-nocomplain"}} +test filename-11.8 {Tcl_GlobCmd} { + list [catch {glob -nocomplain -- -nocomplain} msg] $msg +} {0 {}} +test filename-11.9 {Tcl_GlobCmd} {testsetplatform} { + testsetplatform unix + list [catch {glob ~\\xyqrszzz/bar} msg] $msg +} {1 {user "\xyqrszzz" doesn't exist}} +test filename-11.10 {Tcl_GlobCmd} {testsetplatform} { + testsetplatform unix + list [catch {glob -nocomplain ~\\xyqrszzz/bar} msg] $msg +} {0 {}} +test filename-11.11 {Tcl_GlobCmd} {testsetplatform} { + testsetplatform unix + list [catch {glob ~xyqrszzz\\/\\bar} msg] $msg +} {1 {user "xyqrszzz" doesn't exist}} +test filename-11.12 {Tcl_GlobCmd} {testsetplatform} { + testsetplatform unix + set home $env(HOME) + unset env(HOME) + set x [list [catch {glob ~/*} msg] $msg] + set env(HOME) $home + set x +} {1 {couldn't find HOME environment variable to expand path}} + +if {[tcltest::testConstraint testsetplatform]} { + testsetplatform $platform +} + +test filename-11.13 {Tcl_GlobCmd} { + list [catch {file join [lindex [glob ~] 0]} msg] $msg +} [list 0 [file join $env(HOME)]] + +set oldhome $env(HOME) +set env(HOME) [pwd] +file delete -force globTest +file mkdir globTest/a1/b1 +file mkdir globTest/a1/b2 +file mkdir globTest/a2/b3 +file mkdir globTest/a3 +close [open globTest/x1.c w] +close [open globTest/y1.c w] +close [open globTest/z1.c w] +close [open "globTest/weird name.c" w] +close [open globTest/a1/b1/x2.c w] +close [open globTest/a1/b2/y2.c w] + +catch {close [open globTest/.1 w]} +catch {close [open globTest/x,z1.c w]} + +test filename-11.14 {Tcl_GlobCmd} { + list [catch {glob ~/globTest} msg] $msg +} [list 0 [list [file join $env(HOME) globTest]]] +test filename-11.15 {Tcl_GlobCmd} { + list [catch {glob ~\\/globTest} msg] $msg +} [list 0 [list [file join $env(HOME) globTest]]] +test filename-11.16 {Tcl_GlobCmd} { + list [catch {glob globTest} msg] $msg +} {0 globTest} + +set globname "globTest" +set horribleglobname "glob\[\{Test" + +test filename-11.17 {Tcl_GlobCmd} {unixOnly} { + list [catch {lsort [glob -directory $globname *]} msg] $msg +} [list 0 [lsort [list [file join $globname a1] [file join $globname a2]\ + [file join $globname a3]\ + [file join $globname "weird name.c"]\ + [file join $globname x,z1.c]\ + [file join $globname x1.c]\ + [file join $globname y1.c] [file join $globname z1.c]]]] +test filename-11.17.1 {Tcl_GlobCmd} {pcOnly macOnly} { + list [catch {lsort [glob -directory $globname *]} msg] $msg +} [list 0 [lsort [list [file join $globname a1] [file join $globname a2]\ + [file join $globname .1]\ + [file join $globname a3]\ + [file join $globname "weird name.c"]\ + [file join $globname x,z1.c]\ + [file join $globname x1.c]\ + [file join $globname y1.c] [file join $globname z1.c]]]] +test filename-11.18 {Tcl_GlobCmd} {unixOnly} { + list [catch {lsort [glob -path $globname/ *]} msg] $msg +} [list 0 [lsort [list [file join $globname a1] [file join $globname a2]\ + [file join $globname a3]\ + [file join $globname "weird name.c"]\ + [file join $globname x,z1.c]\ + [file join $globname x1.c]\ + [file join $globname y1.c] [file join $globname z1.c]]]] +test filename-11.18.1 {Tcl_GlobCmd} {pcOnly macOnly} { + list [catch {lsort [glob -path $globname/ *]} msg] $msg +} [list 0 [lsort [list [file join $globname a1] [file join $globname a2]\ + [file join $globname .1]\ + [file join $globname a3]\ + [file join $globname "weird name.c"]\ + [file join $globname x,z1.c]\ + [file join $globname x1.c]\ + [file join $globname y1.c] [file join $globname z1.c]]]] +test filename-11.19 {Tcl_GlobCmd} {unixOnly} { + list [catch {lsort [glob -join -path \ + [string range $globname 0 5] * *]} msg] $msg +} [list 0 [lsort [list [file join $globname a1] [file join $globname a2]\ + [file join $globname a3]\ + [file join $globname "weird name.c"]\ + [file join $globname x,z1.c]\ + [file join $globname x1.c]\ + [file join $globname y1.c] [file join $globname z1.c]]]] +test filename-11.19.1 {Tcl_GlobCmd} {pcOnly macOnly} { + list [catch {lsort [glob -join -path \ + [string range $globname 0 5] * *]} msg] $msg +} [list 0 [lsort [list [file join $globname a1] [file join $globname a2]\ + [file join $globname .1]\ + [file join $globname a3]\ + [file join $globname "weird name.c"]\ + [file join $globname x,z1.c]\ + [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]\ + [file join $globname a2]\ + [file join $globname a3]]]] +test filename-11.21 {Tcl_GlobCmd} { + list [catch {lsort [glob -type d -path $globname *]} msg] $msg +} [list 0 [lsort [list $globname]]] + +file rename globTest $horribleglobname +set globname $horribleglobname + +test filename-11.22 {Tcl_GlobCmd} {unixOnly} { + list [catch {lsort [glob -dir $globname *]} msg] $msg +} [list 0 [lsort [list [file join $globname a1] [file join $globname a2]\ + [file join $globname a3]\ + [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.22.1 {Tcl_GlobCmd} {pcOnly macOnly} { + list [catch {lsort [glob -dir $globname *]} msg] $msg +} [list 0 [lsort [list [file join $globname a1] [file join $globname a2]\ + [file join $globname .1]\ + [file join $globname a3]\ + [file join $globname "weird name.c"]\ + [file join $globname x,z1.c]\ + [file join $globname x1.c]\ + [file join $globname y1.c] [file join $globname z1.c]]]] +test filename-11.23 {Tcl_GlobCmd} {unixOnly} { + list [catch {lsort [glob -path $globname/ *]} msg] $msg +} [list 0 [lsort [list [file join $globname a1] [file join $globname a2]\ + [file join $globname a3]\ + [file join $globname "weird name.c"]\ + [file join $globname x,z1.c]\ + [file join $globname x1.c]\ + [file join $globname y1.c] [file join $globname z1.c]]]] +test filename-11.23.1 {Tcl_GlobCmd} {pcOnly macOnly} { + list [catch {lsort [glob -path $globname/ *]} msg] $msg +} [list 0 [lsort [list [file join $globname a1] [file join $globname a2]\ + [file join $globname .1]\ + [file join $globname a3]\ + [file join $globname "weird name.c"]\ + [file join $globname x,z1.c]\ + [file join $globname x1.c]\ + [file join $globname y1.c] [file join $globname z1.c]]]] +test filename-11.24 {Tcl_GlobCmd} {unixOnly} { + list [catch {lsort [glob -join -path \ + [string range $globname 0 5] * *]} msg] $msg +} [list 0 [lsort [list [file join $globname a1] [file join $globname a2]\ + [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.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]\ + [file join $globname a2]\ + [file join $globname a3]]]] +test filename-11.26 {Tcl_GlobCmd} { + list [catch {glob -type d -path $globname *} msg] $msg +} [list 0 [list $globname]] +test filename-11.27 {Tcl_GlobCmd} { + list [catch {glob -types abcde *} msg] $msg +} {1 {bad argument to "-types": abcde}} +test filename-11.28 {Tcl_GlobCmd} { + list [catch {glob -types z *} msg] $msg +} {1 {bad argument to "-types": z}} +test filename-11.29 {Tcl_GlobCmd} { + list [catch {glob -types {abcd efgh} *} msg] $msg +} {1 {only one MacOS type or creator argument to "-types" allowed}} +test filename-11.30 {Tcl_GlobCmd} { + list [catch {glob -types {{macintosh type TEXT} \ + {macintosh creator ALFA} efgh} *} msg] $msg +} {1 {only one MacOS type or creator argument to "-types" allowed}} +test filename-11.31 {Tcl_GlobCmd} { + list [catch {glob -types} msg] $msg +} {1 {missing argument to "-types"}} +test filename-11.32 {Tcl_GlobCmd} { + list [catch {glob -path hello -dir hello *} msg] $msg +} {1 {"-directory" cannot be used with "-path"}} +test filename-11.33 {Tcl_GlobCmd} { + list [catch {glob -path} msg] $msg +} {1 {missing argument to "-path"}} +test filename-11.34 {Tcl_GlobCmd} { + list [catch {glob -direct} msg] $msg +} {1 {missing argument to "-directory"}} +test filename-11.35 {Tcl_GlobCmd} { + list [catch {glob -paths *} msg] $msg +} {1 {bad option "-paths": must be -directory, -join, -nocomplain, -path, -tails, -types, or --}} + +file rename $horribleglobname globTest +set globname globTest +unset horribleglobname + +test filename-12.1 {simple globbing} {unixOrPc} { + list [catch {glob {}} msg] $msg +} {0 .} +test filename-12.2 {simple globbing} {macOnly} { + list [catch {glob {}} msg] $msg +} {0 :} +test filename-12.3 {simple globbing} { + list [catch {glob -nocomplain \{a1,a2\}} msg] $msg +} {0 {}} + +if {$tcl_platform(platform) == "macintosh"} { + set globPreResult :globTest: +} else { + set globPreResult globTest/ +} +set x1 x1.c +set y1 y1.c +test filename-12.4 {simple globbing} {unixOrPc} { + lsort [glob globTest/x1.c globTest/y1.c globTest/foo] +} "$globPreResult$x1 $globPreResult$y1" +test filename-12.5 {simple globbing} { + list [catch {glob globTest\\/x1.c} msg] $msg +} "0 $globPreResult$x1" +test filename-12.6 {simple globbing} { + list [catch {glob globTest\\/\\x1.c} msg] $msg +} "0 $globPreResult$x1" + +test filename-13.1 {globbing with brace substitution} { + list [catch {glob globTest/\{\}} msg] $msg +} "0 $globPreResult" +test filename-13.2 {globbing with brace substitution} { + list [catch {glob globTest/\{} msg] $msg +} {1 {unmatched open-brace in file name}} +test filename-13.3 {globbing with brace substitution} { + list [catch {glob globTest/\{\\\}} msg] $msg +} {1 {unmatched open-brace in file name}} +test filename-13.4 {globbing with brace substitution} { + list [catch {glob globTest/\{\\} msg] $msg +} {1 {unmatched open-brace in file name}} +test filename-13.5 {globbing with brace substitution} { + list [catch {glob globTest/\}} msg] $msg +} {1 {unmatched close-brace in file name}} +test filename-13.6 {globbing with brace substitution} { + list [catch {glob globTest/\{\}x1.c} msg] $msg +} "0 $globPreResult$x1" +test filename-13.7 {globbing with brace substitution} { + list [catch {glob globTest/\{x\}1.c} msg] $msg +} "0 $globPreResult$x1" +test filename-13.8 {globbing with brace substitution} { + list [catch {glob globTest/\{x\{\}\}1.c} msg] $msg +} "0 $globPreResult$x1" +test filename-13.9 {globbing with brace substitution} { + list [lsort [catch {glob globTest/\{x,y\}1.c} msg]] $msg +} [list 0 [list $globPreResult$x1 $globPreResult$y1]] +test filename-13.10 {globbing with brace substitution} { + list [lsort [catch {glob globTest/\{x,,y\}1.c} msg]] $msg +} [list 0 [list $globPreResult$x1 $globPreResult$y1]] +test filename-13.11 {globbing with brace substitution} {unixOrPc} { + list [lsort [catch {glob globTest/\{x,x\\,z,z\}1.c} msg]] $msg +} {0 {globTest/x1.c globTest/x,z1.c globTest/z1.c}} +test filename-13.12 {globbing with brace substitution} {macOnly} { + list [lsort [catch {glob globTest/\{x,x\\,z,z\}1.c} msg]] $msg +} {0 {:globTest:x1.c :globTest:x,z1.c :globTest:z1.c}} +test filename-13.13 {globbing with brace substitution} { + lsort [glob globTest/{a,b,x,y}1.c] +} [list $globPreResult$x1 $globPreResult$y1] +test filename-13.14 {globbing with brace substitution} {unixOrPc} { + lsort [glob {globTest/{x1,y2,weird name}.c}] +} {{globTest/weird name.c} globTest/x1.c} +test filename-13.15 {globbing with brace substitution} {macOnly} { + lsort [glob {globTest/{x1,y2,weird name}.c}] +} {{:globTest:weird name.c} :globTest:x1.c} +test filename-13.16 {globbing with brace substitution} {unixOrPc} { + lsort [glob globTest/{x1.c,a1/*}] +} {globTest/a1/b1 globTest/a1/b2 globTest/x1.c} +test filename-13.17 {globbing with brace substitution} {macOnly} { + lsort [glob globTest/{x1.c,a1/*}] +} {:globTest:a1:b1 :globTest:a1:b2 :globTest:x1.c} +test filename-13.18 {globbing with brace substitution} {unixOrPc} { + lsort [glob globTest/{x1.c,{a},a1/*}] +} {globTest/a1/b1 globTest/a1/b2 globTest/x1.c} +test filename-13.19 {globbing with brace substitution} {macOnly} { + lsort [glob globTest/{x1.c,{a},a1/*}] +} {:globTest:a1:b1 :globTest:a1:b2 :globTest:x1.c} +test filename-13.20 {globbing with brace substitution} {unixOrPc} { + lsort [glob globTest/{a,x}1/*/{x,y}*] +} {globTest/a1/b1/x2.c globTest/a1/b2/y2.c} +test filename-13.21 {globbing with brace substitution} {macOnly} { + lsort [glob globTest/{a,x}1/*/{x,y}*] +} {:globTest:a1:b1:x2.c :globTest:a1:b2:y2.c} +test filename-13.22 {globbing with brace substitution} { + list [catch {glob globTest/\{a,x\}1/*/\{} msg] $msg +} {1 {unmatched open-brace in file name}} + +test filename-14.1 {asterisks, question marks, and brackets} {unixOrPc} { + lsort [glob glo*/*.c] +} {{globTest/weird name.c} globTest/x,z1.c globTest/x1.c globTest/y1.c globTest/z1.c} +test filename-14.2 {asterisks, question marks, and brackets} {macOnly} { + lsort [glob glo*/*.c] +} {{:globTest:weird name.c} :globTest:x,z1.c :globTest:x1.c :globTest:y1.c :globTest:z1.c} +test filename-14.3 {asterisks, question marks, and brackets} {unixOrPc} { + lsort [glob globTest/?1.c] +} {globTest/x1.c globTest/y1.c globTest/z1.c} +test filename-14.4 {asterisks, question marks, and brackets} {macOnly} { + lsort [glob globTest/?1.c] +} {:globTest:x1.c :globTest:y1.c :globTest:z1.c} +test filename-14.5 {asterisks, question marks, and brackets} {unixOrPc} { + lsort [glob */*/*/*.c] +} {globTest/a1/b1/x2.c globTest/a1/b2/y2.c} +test filename-14.6 {asterisks, question marks, and brackets} {macOnly} { + lsort [glob */*/*/*.c] +} {:globTest:a1:b1:x2.c :globTest:a1:b2:y2.c} +test filename-14.7 {asterisks, question marks, and brackets} {unixOnly} { + lsort [glob globTest/*] +} {globTest/a1 globTest/a2 globTest/a3 {globTest/weird name.c} globTest/x,z1.c globTest/x1.c globTest/y1.c globTest/z1.c} +test filename-14.7.1 {asterisks, question marks, and brackets} {pcOnly} { + lsort [glob globTest/*] +} {globTest/.1 globTest/a1 globTest/a2 globTest/a3 {globTest/weird name.c} globTest/x,z1.c globTest/x1.c globTest/y1.c globTest/z1.c} +test filename-14.8 {asterisks, question marks, and brackets} {macOnly} { + lsort [glob globTest/*] +} {:globTest:.1 :globTest:a1 :globTest:a2 :globTest:a3 {:globTest:weird name.c} :globTest:x,z1.c :globTest:x1.c :globTest:y1.c :globTest:z1.c} +test filename-14.9 {asterisks, question marks, and brackets} {unixOrPc} { + lsort [glob globTest/.*] +} {globTest/. globTest/.. globTest/.1} +test filename-14.10 {asterisks, question marks, and brackets} {macOnly} { + lsort [glob globTest/.*] +} {:globTest:.1} +test filename-14.11 {asterisks, question marks, and brackets} {unixOrPc} { + lsort [glob globTest/*/*] +} {globTest/a1/b1 globTest/a1/b2 globTest/a2/b3} +test filename-14.12 {asterisks, question marks, and brackets} {macOnly} { + lsort [glob globTest/*/*] +} {:globTest:a1:b1 :globTest:a1:b2 :globTest:a2:b3} +test filename-14.13 {asterisks, question marks, and brackets} {unixOrPc} { + lsort [glob {globTest/[xyab]1.*}] +} {globTest/x1.c globTest/y1.c} +test filename-14.14 {asterisks, question marks, and brackets} {macOnly} { + lsort [glob {globTest/[xyab]1.*}] +} {:globTest:x1.c :globTest:y1.c} +test filename-14.15 {asterisks, question marks, and brackets} {unixOrPc} { + lsort [glob globTest/*/] +} {globTest/a1/ globTest/a2/ globTest/a3/} +test filename-14.16 {asterisks, question marks, and brackets} {macOnly} { + lsort [glob globTest/*/] +} {:globTest:a1: :globTest:a2: :globTest:a3:} +test filename-14.17 {asterisks, question marks, and brackets} { + global env + set temp $env(HOME) + set env(HOME) [file join $env(HOME) globTest] + set result [list [catch {glob ~/z*} msg] $msg] + set env(HOME) $temp + set result +} [list 0 [list [file join $env(HOME) globTest z1.c]]] +test filename-14.18 {asterisks, question marks, and brackets} {unixOrPc} { + list [catch {lsort [glob globTest/*.c goo/*]} msg] $msg +} {0 {{globTest/weird name.c} globTest/x,z1.c globTest/x1.c globTest/y1.c globTest/z1.c}} +test filename-14.19 {asterisks, question marks, and brackets} {macOnly} { + list [catch {lsort [glob globTest/*.c goo/*]} msg] $msg +} {0 {{:globTest:weird name.c} :globTest:x,z1.c :globTest:x1.c :globTest:y1.c :globTest:z1.c}} +test filename-14.20 {asterisks, question marks, and brackets} { + list [catch {glob -nocomplain goo/*} msg] $msg +} {0 {}} +test filename-14.21 {asterisks, question marks, and brackets} { + list [catch {glob globTest/*/gorp} msg] $msg +} {1 {no files matched glob pattern "globTest/*/gorp"}} +test filename-14.22 {asterisks, question marks, and brackets} { + list [catch {glob goo/* x*z foo?q} msg] $msg +} {1 {no files matched glob patterns "goo/* x*z foo?q"}} +test filename-14.23 {slash globbing} {unixOrPc} { + glob / +} / +test filename-14.24 {slash globbing} {pcOnly} { + glob {\\} +} / +test filename-14.25 {type specific globbing} {unixOnly} { + list [catch {lsort [glob -dir globTest -types f *]} msg] $msg +} [list 0 [lsort [list \ + [file join $globname "weird name.c"]\ + [file join $globname x,z1.c]\ + [file join $globname x1.c]\ + [file join $globname y1.c] [file join $globname z1.c]]]] +test filename-14.25.1 {type specific globbing} {pcOnly macOnly} { + list [catch {lsort [glob -dir globTest -types f *]} msg] $msg +} [list 0 [lsort [list \ + [file join $globname .1]\ + [file join $globname "weird name.c"]\ + [file join $globname x,z1.c]\ + [file join $globname x1.c]\ + [file join $globname y1.c] [file join $globname z1.c]]]] +test filename-14.26 {type specific globbing} { + list [catch {glob -nocomplain -dir globTest -types {readonly} *} msg] $msg +} [list 0 {}] + +unset globname + +# The following tests are only valid for Unix systems. +# On some systems, like AFS, "000" protection doesn't prevent +# access by owner, so the following test is not portable. + +catch {exec chmod 000 globTest/a1} +test filename-15.1 {unix specific globbing} {unixOnly nonPortable} { + string tolower [list [catch {glob globTest/a1/*} msg] $msg $errorCode] +} {1 {couldn't read directory "globtest/a1": permission denied} {posix eacces {permission denied}}} +test filename-15.2 {unix specific no complain: no errors} {unixOnly nonPortable} { + glob -nocomplain globTest/a1/* +} {} +test filename-15.3 {unix specific no complain: no errors, good result} \ + {unixOnly nonPortable knownBug} { + # test fails because if an error occur , the interp's result + # is reset... + glob -nocomplain globTest/a2 globTest/a1/* globTest/a3 +} {globTest/a2 globTest/a3} + +catch {exec chmod 755 globTest/a1} +test filename-15.4 {unix specific no complain: no errors, good result} \ + {unixOnly nonPortable knownBug} { + # test fails because if an error occurs, the interp's result + # is reset... or you don't run at scriptics where the + # outser and welch users exists + glob -nocomplain ~ouster ~foo ~welch +} {/home/ouster /home/welch} +test filename-15.5 {unix specific globbing} {unixOnly nonPortable} { + glob ~ouster/.csh* +} "/home/ouster/.cshrc" +catch {close [open globTest/odd\\\[\]*?\{\}name w]} +test filename-15.6 {unix specific globbing} {unixOnly} { + global env + set temp $env(HOME) + set env(HOME) $env(HOME)/globTest/odd\\\[\]*?\{\}name + set result [list [catch {glob ~} msg] $msg] + set env(HOME) $temp + set result +} [list 0 [list [glob ~]/globTest/odd\\\[\]*?\{\}name]] +catch {exec rm -f globTest/odd\\\[\]*?\{\}name} + +# The following tests are only valid for Windows systems. +set oldDir [pwd] +if {$::tcltest::testConstraints(pcOnly)} { + cd c:/ + file delete -force globTest + file mkdir globTest + close [open globTest/x1.BAT w] + close [open globTest/y1.Bat w] + close [open globTest/z1.bat w] +} + +test filename-16.1 {windows specific globbing} {pcOnly} { + lsort [glob globTest/*.bat] +} {globTest/x1.BAT globTest/y1.Bat globTest/z1.bat} +test filename-16.2 {windows specific globbing} {pcOnly} { + glob c: +} c: +test filename-16.3 {windows specific globbing} {pcOnly} { + glob c:\\\\ +} c:/ +test filename-16.4 {windows specific globbing} {pcOnly} { + glob c:/ +} c:/ +test filename-16.5 {windows specific globbing} {pcOnly} { + glob c:*Test +} c:globTest +test filename-16.6 {windows specific globbing} {pcOnly} { + glob c:\\\\*Test +} c:/globTest +test filename-16.7 {windows specific globbing} {pcOnly} { + glob c:/*Test +} c:/globTest +test filename-16.8 {windows specific globbing} {pcOnly} { + lsort [glob c:globTest/*.bat] +} {c:globTest/x1.BAT c:globTest/y1.Bat c:globTest/z1.bat} +test filename-16.9 {windows specific globbing} {pcOnly} { + lsort [glob c:/globTest/*.bat] +} {c:/globTest/x1.BAT c:/globTest/y1.Bat c:/globTest/z1.bat} +test filename-16.10 {windows specific globbing} {pcOnly} { + lsort [glob c:globTest\\\\*.bat] +} {c:globTest/x1.BAT c:globTest/y1.Bat c:globTest/z1.bat} +test filename-16.11 {windows specific globbing} {pcOnly} { + lsort [glob c:\\\\globTest\\\\*.bat] +} {c:/globTest/x1.BAT c:/globTest/y1.Bat c:/globTest/z1.bat} + +# some tests require a shared C drive + +if {[catch {cd //[info hostname]/c}]} { + set ::tcltest::testConstraints(sharedCdrive) 0 +} else { + set ::tcltest::testConstraints(sharedCdrive) 1 +} + +test filename-16.12 {windows specific globbing} {pcOnly sharedCdrive} { + cd //[info hostname]/c + glob //[info hostname]/c/*Test +} //[info hostname]/c/globTest +test filename-16.13 {windows specific globbing} {pcOnly sharedCdrive} { + cd //[info hostname]/c + glob "\\\\\\\\[info hostname]\\\\c\\\\*Test" +} //[info hostname]/c/globTest + +# cleanup +file delete -force C:/globTest +cd $oldDir +file delete -force globTest +set env(HOME) $oldhome +if {[tcltest::testConstraint testsetplatform]} { + testsetplatform $platform + catch {unset platform} +} +catch {unset oldhome temp result} +::tcltest::cleanupTests +return ADDED tests/macFCmd.test Index: tests/macFCmd.test ================================================================== --- /dev/null +++ tests/macFCmd.test @@ -0,0 +1,209 @@ +# This file tests the tclfCmd.c file. +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1997 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: macFCmd.test,v 1.1.1.1 2001/08/03 16:19:04 vincentdarley Exp $ +# + +if {[lsearch [namespace children] ::tcltest] == -1} { + package require tcltest + namespace import -force ::tcltest::* +} + +catch {file delete -force foo.dir} +file mkdir foo.dir +if {[catch {file attributes foo.dir -readonly 1}]} { + set ::tcltest::testConstraints(fileSharing) 0 + set ::tcltest::testConstraints(notFileSharing) 1 +} else { + set ::tcltest::testConstraints(fileSharing) 1 + set ::tcltest::testConstraints(notFileSharing) 0 +} +file delete -force foo.dir + +test macFCmd-1.1 {GetFileFinderAttributes - no file} {macOnly} { + catch {file delete -force foo.file} + list [catch {file attributes foo.file -creator} msg] $msg +} {1 {could not read ":foo.file": no such file or directory}} +test macFCmd-1.2 {GetFileFinderAttributes - creator} {macOnly} { + catch {file delete -force foo.file} + catch {close [open foo.file w]} + list [catch {file attributes foo.file -creator} msg] $msg \ + [file delete -force foo.file] +} {0 {MPW } {}} +test macFCmd-1.3 {GetFileFinderAttributes - type} {macOnly} { + catch {file delete -force foo.file} + catch {close [open foo.file w]} + list [catch {file attributes foo.file -type} msg] $msg \ + [file delete -force foo.file] +} {0 TEXT {}} +test macFCmd-1.4 {GetFileFinderAttributes - not hidden} {macOnly} { + catch {file delete -force foo.file} + catch {close [open foo.file w]} + list [catch {file attributes foo.file -hidden} msg] $msg \ + [file delete -force foo.file] +} {0 0 {}} +test macFCmd-1.5 {GetFileFinderAttributes - hidden} {macOnly} { + catch {file delete -force foo.file} + catch {close [open foo.file w]} + file attributes foo.file -hidden 1 + list [catch {file attributes foo.file -hidden} msg] $msg \ + [file delete -force foo.file] +} {0 1 {}} +test macFCmd-1.6 {GetFileFinderAttributes - folder creator} {macOnly} { + catch {file delete -force foo.dir} + file mkdir foo.dir + list [catch {file attributes foo.dir -creator} msg] $msg \ + [file delete -force foo.dir] +} {0 Fldr {}} +test macFCmd-1.7 {GetFileFinderAttributes - folder type} {macOnly} { + catch {file delete -force foo.dir} + file mkdir foo.dir + list [catch {file attributes foo.dir -type} msg] $msg \ + [file delete -force foo.dir] +} {0 Fldr {}} +test macFCmd-1.8 {GetFileFinderAttributes - folder hidden} {macOnly} { + catch {file delete -force foo.dir} + file mkdir foo.dir + list [catch {file attributes foo.dir -hidden} msg] $msg \ + [file delete -force foo.dir] +} {0 0 {}} + +test macFCmd-2.1 {GetFileReadOnly - bad file} {macOnly} { + catch {file delete -force foo.file} + list [catch {file attributes foo.file -readonly} msg] $msg +} {1 {could not read ":foo.file": no such file or directory}} +test macFCmd-2.2 {GetFileReadOnly - file not read only} {macOnly} { + catch {file delete -force foo.file} + close [open foo.file w] + list [catch {file attributes foo.file -readonly} msg] $msg \ + [file delete -force foo.file] +} {0 0 {}} +test macFCmd-2.3 {GetFileReadOnly - file read only} {macOnly} { + catch {file delete -force foo.file} + close [open foo.file w] + file attributes foo.file -readonly 1 + list [catch {file attributes foo.file -readonly} msg] $msg \ + [file delete -force foo.file] +} {0 1 {}} +test macFCmd-2.4 {GetFileReadOnly - directory not read only} {macOnly} { + catch {file delete -force foo.dir} + file mkdir foo.dir + list [catch {file attributes foo.dir -readonly} msg] $msg \ + [file delete -force foo.dir] +} {0 0 {}} +test macFCmd-2.5 {GetFileReadOnly - directory read only} {macOnly fileSharing} { + catch {file delete -force foo.dir} + file mkdir foo.dir + file attributes foo.dir -readonly 1 + list [catch {file attributes foo.dir -readonly} msg] $msg \ + [file delete -force foo.dir] +} {0 1 {}} + +test macFCmd-3.1 {SetFileFinderAttributes - bad file} {macOnly} { + catch {file delete -force foo.file} + list [catch {file attributes foo.file -creator FOOO} msg] $msg +} {1 {could not read ":foo.file": no such file or directory}} +test macFCmd-3.2 {SetFileFinderAttributes - creator} {macOnly} { + catch {file delete -force foo.file} + close [open foo.file w] + list [catch {file attributes foo.file -creator FOOO} msg] $msg \ + [file attributes foo.file -creator] [file delete -force foo.file] +} {0 {} FOOO {}} +test macFCmd-3.3 {SetFileFinderAttributes - bad creator} {macOnly} { + catch {file delete -force foo.file} + close [open foo.file w] + list [catch {file attributes foo.file -creator 0} msg] $msg \ + [file delete -force foo.file] +} {1 {expected Macintosh OS type but got "0"} {}} +test macFCmd-3.4 {SetFileFinderAttributes - hidden} {macOnly} { + catch {file delete -force foo.file} + close [open foo.file w] + list [catch {file attributes foo.file -hidden 1} msg] $msg \ + [file attributes foo.file -hidden] [file delete -force foo.file] +} {0 {} 1 {}} +test macFCmd-3.5 {SetFileFinderAttributes - type} {macOnly} { + catch {file delete -force foo.file} + close [open foo.file w] + list [catch {file attributes foo.file -type FOOO} msg] $msg \ + [file attributes foo.file -type] [file delete -force foo.file] +} {0 {} FOOO {}} +test macFCmd-3.6 {SetFileFinderAttributes - bad type} {macOnly} { + catch {file delete -force foo.file} + close [open foo.file w] + list [catch {file attributes foo.file -type 0} msg] $msg \ + [file delete -force foo.file] +} {1 {expected Macintosh OS type but got "0"} {}} +test macFCmd-3.7 {SetFileFinderAttributes - directory} {macOnly} { + catch {file delete -force foo.dir} + file mkdir foo.dir + list [catch {file attributes foo.dir -creator FOOO} msg] \ + $msg [file delete -force foo.dir] +} {1 {cannot set -creator: ":foo.dir" is a directory} {}} + +test macFCmd-4.1 {SetFileReadOnly - bad file} {macOnly} { + catch {file delete -force foo.file} + list [catch {file attributes foo.file -readonly 1} msg] $msg +} {1 {could not read ":foo.file": no such file or directory}} +test macFCmd-4.2 {SetFileReadOnly - file not readonly} {macOnly} { + catch {file delete -force foo.file} + close [open foo.file w] + list [catch {file attributes foo.file -readonly 0} msg] \ + $msg [file attributes foo.file -readonly] [file delete -force foo.file] +} {0 {} 0 {}} +test macFCmd-4.3 {SetFileReadOnly - file readonly} {macOnly} { + catch {file delete -force foo.file} + close [open foo.file w] + list [catch {file attributes foo.file -readonly 1} msg] \ + $msg [file attributes foo.file -readonly] [file delete -force foo.file] +} {0 {} 1 {}} +test macFCmd-4.4 {SetFileReadOnly - directory not readonly} \ + {macOnly fileSharing} { + catch {file delete -force foo.dir} + file mkdir foo.dir + list [catch {file attributes foo.dir -readonly 0} msg] \ + $msg [file attributes foo.dir -readonly] [file delete -force foo.dir] +} {0 {} 0 {}} +test macFCmd-4.5 {SetFileReadOnly - directory not readonly} \ + {macOnly notFileSharing} { + catch {file delete -force foo.dir} + file mkdir foo.dir + list [catch {file attributes foo.dir -readonly 0} msg] $msg \ + [file delete -force foo.dir] +} {1 {cannot set a directory to read-only when File Sharing is turned off} {}} +test macFCmd-4.6 {SetFileReadOnly - directory readonly} {macOnly fileSharing} { + catch {file delete -force foo.dir} + file mkdir foo.dir + list [catch {file attributes foo.dir -readonly 1} msg] $msg \ + [file attributes foo.dir -readonly] [file delete -force foo.dir] +} {0 {} 1 {}} +test macFCmd-4.7 {SetFileReadOnly - directory readonly} {macOnly notFileSharing} { + catch {file delete -force foo.dir} + file mkdir foo.dir + list [catch {file attributes foo.dir -readonly 1} msg] $msg \ + [file delete -force foo.dir] +} {1 {cannot set a directory to read-only when File Sharing is turned off} {}} + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + ADDED tests/unixFCmd.test Index: tests/unixFCmd.test ================================================================== --- /dev/null +++ tests/unixFCmd.test @@ -0,0 +1,328 @@ +# This file tests the tclUnixFCmd.c file. +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: unixFCmd.test,v 1.1.1.1 2001/08/03 16:19:04 vincentdarley Exp $ + +if {[lsearch [namespace children] ::tcltest] == -1} { + package require tcltest + namespace import -force ::tcltest::* +} + +# Several tests require need to match results against the unix username +set user {} +if {$tcl_platform(platform) == "unix"} { + catch {set user [exec whoami]} + if {$user == ""} { + catch {regexp {^[^(]*\(([^)]*)\)} [exec id] dummy user} + } + if {$user == ""} { + set user "root" + } +} + +proc openup {path} { + testchmod 777 $path + if {[file isdirectory $path]} { + catch { + foreach p [glob -directory $path *] { + openup $p + } + } + } +} + +proc cleanup {args} { + foreach p ". $args" { + set x "" + catch { + set x [glob -directory $p tf* td*] + } + foreach file $x { + if {[catch {file delete -force -- $file}]} { + openup $file + file delete -force -- $file + } + } + } +} + +test unixFCmd-1.1 {TclpRenameFile: EACCES} {unixOnly notRoot} { + cleanup + file mkdir td1/td2/td3 + exec chmod 000 td1/td2 + set msg [list [catch {file rename td1/td2/td3 td2} msg] $msg] + exec chmod 755 td1/td2 + set msg +} {1 {error renaming "td1/td2/td3": permission denied}} +test unixFCmd-1.2 {TclpRenameFile: EEXIST} {unixOnly notRoot} { + cleanup + file mkdir td1/td2 + file mkdir td2 + list [catch {file rename td2 td1} msg] $msg +} {1 {error renaming "td2" to "td1/td2": file already exists}} +test unixFCmd-1.3 {TclpRenameFile: EINVAL} {unixOnly notRoot} { + cleanup + file mkdir td1 + list [catch {file rename td1 td1} msg] $msg +} {1 {error renaming "td1" to "td1/td1": trying to rename a volume or move a directory into itself}} +test unixFCmd-1.4 {TclpRenameFile: EISDIR} {emptyTest unixOnly notRoot} { + # can't make it happen +} {} +test unixFCmd-1.5 {TclpRenameFile: ENOENT} {unixOnly notRoot} { + cleanup + file mkdir td1 + list [catch {file rename td2 td1} msg] $msg +} {1 {error renaming "td2": no such file or directory}} +test unixFCmd-1.6 {TclpRenameFile: ENOTDIR} {emptyTest unixOnly notRoot} { + # can't make it happen +} {} +test unixFCmd-1.7 {TclpRenameFile: EXDEV} {unixOnly notRoot} { + cleanup + file mkdir foo/bar + file attr foo -perm 040555 + set catchResult [catch {file rename foo/bar /tmp} msg] + set msg [lindex [split $msg :] end] + catch {file delete /tmp/bar} + catch {file attr foo -perm 040777} + catch {file delete -force foo} + list $catchResult $msg +} {1 { permission denied}} +test unixFCmd-1.8 {Checking EINTR Bug} {unixOnly notRoot nonPortable} { + testalarm + after 2000 + list [testgotsig] [testgotsig] +} {1 0} +test unixFCmd-1.9 {Checking EINTR Bug} {unixOnly notRoot nonPortable} { + cleanup + set f [open tfalarm w] + puts $f { + after 2000 + puts "hello world" + exit 0 + } + close $f + testalarm + set pipe [open "|[info nameofexecutable] tfalarm" r+] + set line [read $pipe 1] + catch {close $pipe} + list $line [testgotsig] +} {h 1} +test unixFCmd-2.1 {TclpCopyFile: target exists: lstat(dst) == 0} \ + {unixOnly notRoot} { + cleanup + exec touch tf1 + exec touch tf2 + file copy -force tf1 tf2 +} {} +test unixFCmd-2.2 {TclpCopyFile: src is symlink} {unixOnly notRoot} { + cleanup + exec ln -s tf1 tf2 + file copy tf2 tf3 + file type tf3 +} {link} +test unixFCmd-2.3 {TclpCopyFile: src is block} {unixOnly notRoot} { + cleanup + set null "/dev/null" + while {[file type $null] != "characterSpecial"} { + set null [file join [file dirname $null] [file readlink $null]] + } + # file copy $null tf1 +} {} +test unixFCmd-2.4 {TclpCopyFile: src is fifo} {unixOnly notRoot} { + cleanup + if [catch {exec mknod tf1 p}] { + list 1 + } else { + file copy tf1 tf2 + expr {"[file type tf1]" == "[file type tf2]"} + } +} {1} +test unixFCmd-2.5 {TclpCopyFile: copy attributes} {unixOnly notRoot} { + cleanup + exec touch tf1 + exec chmod 472 tf1 + file copy tf1 tf2 + string range [exec ls -l tf2] 0 9 +} {-r--rwx-w-} + +test unixFCmd-3.1 {CopyFile not done} {emptyTest unixOnly notRoot} { +} {} + +test unixFCmd-4.1 {TclpDeleteFile not done} {emptyTest unixOnly notRoot} { +} {} + +test unixFCmd-5.1 {TclpCreateDirectory not done} {emptyTest unixOnly notRoot} { +} {} + +test unixFCmd-6.1 {TclpCopyDirectory not done} {emptyTest unixOnly notRoot} { +} {} + +test unixFCmd-7.1 {TclpRemoveDirectory not done} {emptyTest unixOnly notRoot} { +} {} + +test unixFCmd-8.1 {TraverseUnixTree not done} {emptyTest unixOnly notRoot} { +} {} + +test unixFCmd-9.1 {TraversalCopy not done} {emptyTest unixOnly notRoot} { +} {} + +test unixFCmd-10.1 {TraversalDelete not done} {emptyTest unixOnly notRoot} { +} {} + +test unixFCmd-11.1 {CopyFileAttrs not done} {emptyTest unixOnly notRoot} { +} {} + +test unixFCmd-12.1 {GetGroupAttribute - file not found} {unixOnly notRoot} { + catch {file delete -force -- foo.test} + list [catch {file attributes foo.test -group} msg] $msg +} {1 {could not read "foo.test": no such file or directory}} +test unixFCmd-12.2 {GetGroupAttribute - file found} {unixOnly notRoot} { + catch {file delete -force -- foo.test} + close [open foo.test w] + list [catch {file attributes foo.test -group}] [file delete -force -- foo.test] +} {0 {}} + +test unixFCmd-13.1 {GetOwnerAttribute - file not found} {unixOnly notRoot} { + catch {file delete -force -- foo.test} + list [catch {file attributes foo.test -group} msg] $msg +} {1 {could not read "foo.test": no such file or directory}} +test unixFCmd-13.2 {GetOwnerAttribute} {unixOnly notRoot} { + catch {file delete -force -- foo.test} + close [open foo.test w] + list [catch {file attributes foo.test -owner} msg] \ + [string compare $msg $user] [file delete -force -- foo.test] +} {0 0 {}} + +test unixFCmd-14.1 {GetPermissionsAttribute - file not found} {unixOnly notRoot} { + catch {file delete -force -- foo.test} + list [catch {file attributes foo.test -permissions} msg] $msg +} {1 {could not read "foo.test": no such file or directory}} +test unixFCmd-14.2 {GetPermissionsAttribute} {unixOnly notRoot} { + catch {file delete -force -- foo.test} + close [open foo.test w] + list [catch {file attribute foo.test -permissions}] \ + [file delete -force -- foo.test] +} {0 {}} + +# Find a group that exists on this system, or else skip tests that require +# groups +set ::tcltest::testConstraints(foundGroup) 0 +catch { + set groupList [exec groups] + set group [lindex $groupList 0] + set ::tcltest::testConstraints(foundGroup) 1 +} + +#groups hard to test +test unixFCmd-15.1 {SetGroupAttribute - invalid group} {unixOnly notRoot} { + catch {file delete -force -- foo.test} + list [catch {file attributes foo.test -group foozzz} msg] \ + $msg [file delete -force -- foo.test] +} {1 {could not set group for file "foo.test": group "foozzz" does not exist} {}} +test unixFCmd-15.2 {SetGroupAttribute - invalid file} \ + {unixOnly notRoot foundGroup} { + catch {file delete -force -- foo.test} + list [catch {file attributes foo.test -group $group} msg] $msg +} {1 {could not set group for file "foo.test": no such file or directory}} + +#changing owners hard to do +test unixFCmd-16.1 {SetOwnerAttribute - current owner} {unixOnly notRoot} { + catch {file delete -force -- foo.test} + close [open foo.test w] + list [catch {file attributes foo.test -owner $user} msg] \ + $msg [string compare [file attributes foo.test -owner] $user] \ + [file delete -force -- foo.test] +} {0 {} 0 {}} +test unixFCmd-16.2 {SetOwnerAttribute - invalid file} {unixOnly notRoot} { + catch {file delete -force -- foo.test} + list [catch {file attributes foo.test -owner $user} msg] $msg +} {1 {could not set owner for file "foo.test": no such file or directory}} +test unixFCmd-16.3 {SetOwnerAttribute - invalid owner} {unixOnly notRoot} { + catch {file delete -force -- foo.test} + list [catch {file attributes foo.test -owner foozzz} msg] $msg +} {1 {could not set owner for file "foo.test": user "foozzz" does not exist}} + + +test unixFCmd-17.1 {SetPermissionsAttribute} {unixOnly notRoot} { + catch {file delete -force -- foo.test} + close [open foo.test w] + list [catch {file attributes foo.test -permissions 0000} msg] \ + $msg [file attributes foo.test -permissions] \ + [file delete -force -- foo.test] +} {0 {} 00000 {}} +test unixFCmd-17.2 {SetPermissionsAttribute} {unixOnly notRoot} { + catch {file delete -force -- foo.test} + list [catch {file attributes foo.test -permissions 0000} msg] $msg +} {1 {could not set permissions for file "foo.test": no such file or directory}} +test unixFCmd-17.3 {SetPermissionsAttribute} {unixOnly notRoot} { + catch {file delete -force -- foo.test} + close [open foo.test w] + list [catch {file attributes foo.test -permissions foo} msg] $msg \ + [file delete -force -- foo.test] +} {1 {unknown permission string format "foo"} {}} +test unixFCmd-17.3 {SetPermissionsAttribute} {unixOnly notRoot} { + catch {file delete -force -- foo.test} + close [open foo.test w] + list [catch {file attributes foo.test -permissions ---rwx} msg] $msg \ + [file delete -force -- foo.test] +} {1 {unknown permission string format "---rwx"} {}} + +close [open foo.test w] +set ::i 4 +proc permcheck {permstr expected} { + test unixFCmd-17.[incr ::i] {SetPermissionsAttribute} {unixOnly notRoot} \ + [subst { + file attributes foo.test -permissions $permstr + file attributes foo.test -permissions + } + ] $expected +} +permcheck rwxrwxrwx 00777 +permcheck r--r---w- 00442 +permcheck 0 00000 +permcheck u+rwx,g+r 00740 +permcheck u-w 00540 +permcheck o+rwx 00547 +permcheck --x--x--x 00111 +permcheck a+rwx 00777 +file delete -force -- foo.test + +test unixFCmd-18.1 {Unix pwd} {nonPortable unixOnly notRoot} { + # This test is nonportable because SunOS generates a weird error + # message when the current directory isn't readable. + set cd [pwd] + set nd $cd/tstdir + file mkdir $nd + cd $nd + exec chmod 000 $nd + set r [list [catch {pwd} res] [string range $res 0 36]]; + cd $cd; + exec chmod 755 $nd + file delete $nd + set r +} {1 {error getting working directory name:}} + +# cleanup +cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + ADDED tests/unixFile.test Index: tests/unixFile.test ================================================================== --- /dev/null +++ tests/unixFile.test @@ -0,0 +1,78 @@ +# This file contains tests for the routines in the file tclUnixFile.c +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1998-1999 by Scriptics Corporation. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: unixFile.test,v 1.1.1.1 2001/08/03 16:19:04 vincentdarley Exp $ + +if {[lsearch [namespace children] ::tcltest] == -1} { + package require tcltest + namespace import -force ::tcltest::* +} + +if {[info commands testobj] == {}} { + puts "This application hasn't been compiled with the \"testfindexecutable\"" + puts "command, so I can't test the Tcl_FindExecutable function" + ::tcltest::cleanupTests + return +} + +catch { + set oldPath $env(PATH) + close [open junk w] + file attributes junk -perm 0777 +} +set absPath [file join [pwd] junk] + +test unixFile-1.1 {Tcl_FindExecutable} {unixOnly} { + set env(PATH) "" + testfindexecutable junk +} $absPath +test unixFile-1.2 {Tcl_FindExecutable} {unixOnly} { + set env(PATH) "/dummy" + testfindexecutable junk +} {} +test unixFile-1.3 {Tcl_FindExecutable} {unixOnly} { + set env(PATH) "/dummy:[pwd]" + testfindexecutable junk +} $absPath +test unixFile-1.4 {Tcl_FindExecutable} {unixOnly} { + set env(PATH) "/dummy:" + testfindexecutable junk +} $absPath +test unixFile-1.5 {Tcl_FindExecutable} {unixOnly} { + set env(PATH) "/dummy:/dummy" + testfindexecutable junk +} {} +test unixFile-1.6 {Tcl_FindExecutable} {unixOnly} { + set env(PATH) "/dummy::/dummy" + testfindexecutable junk +} $absPath +test unixFile-1.7 {Tcl_FindExecutable} {unixOnly} { + set env(PATH) ":/dummy" + testfindexecutable junk +} $absPath + +# cleanup +catch {set env(PATH) $oldPath} +file delete junk +::tcltest::cleanupTests +return + + + + + + + + + + + + ADDED tests/vfs.test Index: tests/vfs.test ================================================================== --- /dev/null +++ tests/vfs.test @@ -0,0 +1,31 @@ +# Commands covered: vfs::filesystem +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 2001 by Vince Darley. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# + +if {[lsearch [namespace children] ::tcltest] == -1} { + package require tcltest + namespace import ::tcltest::* +} + +package require vfs + +test vfs-1.1 {mount unmount} { + vfs::filesystem mount foo bar + set res [list [catch {vfs::filesystem unmount foo bar} err]] + lappend res $err + vfs::filesystem unmount foo + unset err + set res +} {1 {wrong # args: should be "vfs::filesystem unmount path"}} + +# cleanup +::tcltest::cleanupTests +return ADDED tests/winFCmd.test Index: tests/winFCmd.test ================================================================== --- /dev/null +++ tests/winFCmd.test @@ -0,0 +1,981 @@ +# This file tests the tclWinFCmd.c file. +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1996-1997 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: winFCmd.test,v 1.1.1.1 2001/08/03 16:19:05 vincentdarley Exp $ +# + +if {[lsearch [namespace children] ::tcltest] == -1} { + package require tcltest + namespace import -force ::tcltest::* +} + +proc createfile {file {string a}} { + set f [open $file w] + puts -nonewline $f $string + close $f + return $string +} + +proc contents {file} { + set f [open $file r] + set r [read $f] + close $f + set r +} + +proc cleanup {args} { + foreach p ". $args" { + set x "" + catch { + set x [glob -directory $p tf* td*] + } + if {$x != ""} { + catch {eval file delete -force -- $x} + } + } +} + +set ::tcltest::testConstraints(cdrom) 0 +set ::tcltest::testConstraints(exdev) 0 + +# find a CD-ROM so we can test read-only filesystems. + +set cdrom {} +set nodrive x: +foreach p {d e f g h i j k l m n o p q r s t u v w x y z} { + set name ${p}:/dummy~~.fil + if [catch {set fd [open $name w]}] { + set err [lindex $errorCode 1] + if {$cdrom == "" && $err == "EACCES"} { + set cdrom ${p}: + } + if {$err == "ENOENT"} { + set nodrive ${p}: + } + } else { + close $fd + file delete $name + } +} + +proc findfile {dir} { + foreach p [glob $dir/*] { + if {[file type $p] == "file"} { + return $p + } + } + foreach p [glob $dir/*] { + if {[file type $p] == "directory"} { + set f [findfile $p] + if {$f != ""} { + return $f + } + } + } + return "" +} + +if {$cdrom != ""} { + set ::tcltest::testConstraints(cdrom) 1 + set cdfile [findfile $cdrom] +} + +if {[file exists c:/] && [file exists d:/]} { + catch {file delete d:/tf1} + if {[catch {close [open d:/tf1 w]}] == 0} { + file delete d:/tf1 + set ::tcltest::testConstraints(exdev) 1 + } +} + +file delete -force -- td1 +set foo [catch {open td1 w} testfile] +if {$foo} { + set ::tcltest::testConstraints(longFileNames) 0 +} else { + close $testfile + set ::tcltest::testConstraints(longFileNames) 1 + file delete -force -- td1 +} + +# A really long file name +# length of longname is 1216 chars, which should be greater than any static +# buffer or allowable filename. + +set longname "abcdefghihjllmnopqrstuvwxyz01234567890" +append longname $longname +append longname $longname +append longname $longname +append longname $longname +append longname $longname + +# Uses the "testfile" command instead of the "file" command. The "file" +# command provides several layers of sanity checks on the arguments and +# it can be difficult to actually forward "insane" arguments to the +# low-level posix emulation layer. + +test winFCmd-1.1 {TclpRenameFile: errno: EACCES} {pcOnly cdrom} { + list [catch {testfile mv $cdfile $cdrom/dummy~~.fil} msg] $msg +} {1 EACCES} +test winFCmd-1.2 {TclpRenameFile: errno: EEXIST} {pcOnly} { + cleanup + file mkdir td1/td2/td3 + file mkdir td2 + list [catch {testfile mv td2 td1/td2} msg] $msg +} {1 EEXIST} +test winFCmd-1.3 {TclpRenameFile: errno: EINVAL} {pcOnly} { + cleanup + list [catch {testfile mv / td1} msg] $msg +} {1 EINVAL} +test winFCmd-1.4 {TclpRenameFile: errno: EINVAL} {pcOnly} { + cleanup + file mkdir td1 + list [catch {testfile mv td1 td1/td2} msg] $msg +} {1 EINVAL} +test winFCmd-1.5 {TclpRenameFile: errno: EISDIR} {pcOnly} { + cleanup + file mkdir td1 + createfile tf1 + list [catch {testfile mv tf1 td1} msg] $msg +} {1 EISDIR} +test winFCmd-1.6 {TclpRenameFile: errno: ENOENT} {pcOnly} { + cleanup + list [catch {testfile mv tf1 tf2} msg] $msg +} {1 ENOENT} +test winFCmd-1.7 {TclpRenameFile: errno: ENOENT} {pcOnly} { + cleanup + list [catch {testfile mv "" tf2} msg] $msg +} {1 ENOENT} +test winFCmd-1.8 {TclpRenameFile: errno: ENOENT} {pcOnly} { + cleanup + createfile tf1 + list [catch {testfile mv tf1 ""} msg] $msg +} {1 ENOENT} +test winFCmd-1.9 {TclpRenameFile: errno: ENOTDIR} {pcOnly} { + cleanup + file mkdir td1 + createfile tf1 + list [catch {testfile mv td1 tf1} msg] $msg +} {1 ENOTDIR} +test winFCmd-1.10 {TclpRenameFile: errno: EXDEV} {pcOnly exdev} { + file delete -force d:/tf1 + file mkdir c:/tf1 + set msg [list [catch {testfile mv c:/tf1 d:/tf1} msg] $msg] + file delete -force c:/tf1 + set msg +} {1 EXDEV} +test winFCmd-1.11 {TclpRenameFile: errno: EACCES} {pcOnly} { + cleanup + set fd [open tf1 w] + set msg [list [catch {testfile mv tf1 tf2} msg] $msg] + close $fd + set msg +} {1 EACCES} +test winFCmd-1.12 {TclpRenameFile: errno: EACCES} {pcOnly} { + cleanup + createfile tf1 + set fd [open tf2 w] + set msg [list [catch {testfile mv tf1 tf2} msg] $msg] + close $fd + set msg +} {1 EACCES} +test winFCmd-1.13 {TclpRenameFile: errno: EACCES} {pcOnly} { + cleanup + list [catch {testfile mv nul tf1} msg] $msg +} {1 EACCES} +test winFCmd-1.14 {TclpRenameFile: errno: EACCES} {95} { + cleanup + createfile tf1 + list [catch {testfile mv tf1 nul} msg] $msg +} {1 EACCES} +test winFCmd-1.15 {TclpRenameFile: errno: EEXIST} {nt} { + cleanup + createfile tf1 + list [catch {testfile mv tf1 nul} msg] $msg +} {1 EEXIST} +test winFCmd-1.16 {TclpRenameFile: MoveFile() != FALSE} {pcOnly} { + cleanup + createfile tf1 tf1 + testfile mv tf1 tf2 + list [file exists tf1] [contents tf2] +} {0 tf1} +test winFCmd-1.17 {TclpRenameFile: MoveFile() == FALSE} {pcOnly} { + cleanup + list [catch {testfile mv tf1 tf2} msg] $msg +} {1 ENOENT} +test winFCmd-1.18 {TclpRenameFile: srcAttr == -1} {pcOnly} { + cleanup + list [catch {testfile mv tf1 tf2} msg] $msg +} {1 ENOENT} +test winFCmd-1.19 {TclpRenameFile: errno == EACCES} {pcOnly} { + cleanup + list [catch {testfile mv nul tf1} msg] $msg +} {1 EACCES} +test winFCmd-1.20 {TclpRenameFile: src is dir} {nt} { + # under 95, this would actually succeed and move the current dir out from + # under the current process! + cleanup + file delete /tf1 + list [catch {testfile mv [pwd] /tf1} msg] $msg +} {1 EACCES} +test winFCmd-1.21 {TclpRenameFile: long src} {pcOnly} { + cleanup + list [catch {testfile mv $longname tf1} msg] $msg +} {1 ENAMETOOLONG} +test winFCmd-1.22 {TclpRenameFile: long dst} {pcOnly} { + cleanup + createfile tf1 + list [catch {testfile mv tf1 $longname} msg] $msg +} {1 ENAMETOOLONG} +test winFCmd-1.23 {TclpRenameFile: move dir into self} {pcOnly} { + cleanup + file mkdir td1 + list [catch {testfile mv [pwd]/td1 td1/td2} msg] $msg +} {1 EINVAL} +test winFCmd-1.24 {TclpRenameFile: move a root dir} {pcOnly} { + cleanup + list [catch {testfile mv / c:/} msg] $msg +} {1 EINVAL} +test winFCmd-1.25 {TclpRenameFile: cross file systems} {pcOnly cdrom} { + cleanup + file mkdir td1 + list [catch {testfile mv td1 $cdrom/td1} msg] $msg +} {1 EXDEV} +test winFCmd-1.26 {TclpRenameFile: readonly fs} {pcOnly cdrom} { + cleanup + list [catch {testfile mv $cdfile $cdrom/dummy~~.fil} msg] $msg +} {1 EACCES} +test winFCmd-1.27 {TclpRenameFile: open file} {pcOnly} { + cleanup + set fd [open tf1 w] + set msg [list [catch {testfile mv tf1 tf2} msg] $msg] + close $fd + set msg +} {1 EACCES} +test winFCmd-1.28 {TclpRenameFile: errno == EEXIST} {pcOnly} { + cleanup + createfile tf1 + createfile tf2 + testfile mv tf1 tf2 + list [file exist tf1] [file exist tf2] +} {0 1} +test winFCmd-1.29 {TclpRenameFile: src is dir} {pcOnly} { + cleanup + file mkdir td1 + createfile tf1 + list [catch {testfile mv td1 tf1} msg] $msg +} {1 ENOTDIR} +test winFCmd-1.30 {TclpRenameFile: dst is dir} {pcOnly} { + cleanup + file mkdir td1 + file mkdir td2/td2 + list [catch {testfile mv td1 td2} msg] $msg +} {1 EEXIST} +test winFCmd-1.31 {TclpRenameFile: TclpRemoveDirectory fails} {pcOnly} { + cleanup + file mkdir td1 + file mkdir td2/td2 + list [catch {testfile mv td1 td2} msg] $msg +} {1 EEXIST} +test winFCmd-1.32 {TclpRenameFile: TclpRemoveDirectory succeeds} {pcOnly} { + cleanup + file mkdir td1/td2 + file mkdir td2 + testfile mv td1 td2 + list [file exist td1] [file exist td2] [file exist td2/td2] +} {0 1 1} +test winFCmd-1.33 {TclpRenameFile: After removing dst dir, MoveFile fails} \ + {pcOnly exdev} { + file mkdir d:/td1 + testchmod 000 d:/td1 + file mkdir c:/tf1 + set msg [list [catch {testfile mv c:/tf1 d:/td1} msg] $msg] + set msg "$msg [file writable d:/td1]" + file delete d:/td1 + file delete -force c:/tf1 + set msg +} {1 EXDEV 0} +test winFCmd-1.34 {TclpRenameFile: src is dir, dst is not} {pcOnly} { + file mkdir td1 + createfile tf1 + list [catch {testfile mv td1 tf1} msg] $msg +} {1 ENOTDIR} +test winFCmd-1.35 {TclpRenameFile: src is not dir, dst is} {pcOnly} { + file mkdir td1 + createfile tf1 + list [catch {testfile mv tf1 td1} msg] $msg +} {1 EISDIR} +test winFCmd-1.36 {TclpRenameFile: src and dst not dir} {pcOnly} { + createfile tf1 tf1 + createfile tf2 tf2 + testfile mv tf1 tf2 + contents tf2 +} {tf1} +test winFCmd-1.37 {TclpRenameFile: need to restore temp file} {pcOnly} { + # Can't figure out how to cause this. + # Need a file that can't be copied. +} {} + +test winFCmd-2.1 {TclpCopyFile: errno: EACCES} {pcOnly cdrom} { + cleanup + list [catch {testfile cp $cdfile $cdrom/dummy~~.fil} msg] $msg +} {1 EACCES} +test winFCmd-2.2 {TclpCopyFile: errno: EISDIR} {pcOnly} { + cleanup + file mkdir td1 + list [catch {testfile cp td1 tf1} msg] $msg +} {1 EISDIR} +test winFCmd-2.3 {TclpCopyFile: errno: EISDIR} {pcOnly} { + cleanup + createfile tf1 + file mkdir td1 + list [catch {testfile cp tf1 td1} msg] $msg +} {1 EISDIR} +test winFCmd-2.4 {TclpCopyFile: errno: ENOENT} {pcOnly} { + cleanup + list [catch {testfile cp tf1 tf2} msg] $msg +} {1 ENOENT} +test winFCmd-2.5 {TclpCopyFile: errno: ENOENT} {pcOnly} { + cleanup + list [catch {testfile cp "" tf2} msg] $msg +} {1 ENOENT} +test winFCmd-2.6 {TclpCopyFile: errno: ENOENT} {pcOnly} { + cleanup + createfile tf1 + list [catch {testfile cp tf1 ""} msg] $msg +} {1 ENOENT} +test winFCmd-2.7 {TclpCopyFile: errno: EACCES} {95} { + cleanup + createfile tf1 + set fd [open tf2 w] + set msg [list [catch {testfile cp tf1 tf2} msg] $msg] + close $fd + set msg +} {1 EACCES} +test winFCmd-2.8 {TclpCopyFile: errno: EACCES} {nt} { + cleanup + list [catch {testfile cp nul tf1} msg] $msg +} {1 EACCES} +test winFCmd-2.9 {TclpCopyFile: errno: ENOENT} {95} { + cleanup + list [catch {testfile cp nul tf1} msg] $msg +} {1 ENOENT} +test winFCmd-2.10 {TclpCopyFile: CopyFile succeeds} {pcOnly} { + cleanup + createfile tf1 tf1 + testfile cp tf1 tf2 + list [contents tf1] [contents tf2] +} {tf1 tf1} +test winFCmd-2.11 {TclpCopyFile: CopyFile succeeds} {pcOnly} { + cleanup + createfile tf1 tf1 + createfile tf2 tf2 + testfile cp tf1 tf2 + list [contents tf1] [contents tf2] +} {tf1 tf1} +test winFCmd-2.12 {TclpCopyFile: CopyFile succeeds} {pcOnly} { + cleanup + createfile tf1 tf1 + testchmod 000 tf1 + testfile cp tf1 tf2 + list [contents tf2] [file writable tf2] +} {tf1 0} +test winFCmd-2.13 {TclpCopyFile: CopyFile fails} {pcOnly} { + cleanup + createfile tf1 + file mkdir td1 + list [catch {testfile cp tf1 td1} msg] $msg +} {1 EISDIR} +test winFCmd-2.14 {TclpCopyFile: errno == EACCES} {pcOnly} { + cleanup + file mkdir td1 + list [catch {testfile cp td1 tf1} msg] $msg +} {1 EISDIR} +test winFCmd-2.15 {TclpCopyFile: src is directory} {pcOnly} { + cleanup + file mkdir td1 + list [catch {testfile cp td1 tf1} msg] $msg +} {1 EISDIR} +test winFCmd-2.16 {TclpCopyFile: dst is directory} {pcOnly} { + cleanup + createfile tf1 + file mkdir td1 + list [catch {testfile cp tf1 td1} msg] $msg +} {1 EISDIR} +test winFCmd-2.17 {TclpCopyFile: dst is readonly} {pcOnly} { + cleanup + createfile tf1 tf1 + createfile tf2 tf2 + testchmod 000 tf2 + testfile cp tf1 tf2 + list [file writable tf2] [contents tf2] +} {1 tf1} +test winFCmd-2.18 {TclpCopyFile: still can't copy onto dst} {95} { + cleanup + createfile tf1 + createfile tf2 + testchmod 000 tf2 + set fd [open tf2] + set msg [list [catch {testfile cp tf1 tf2} msg] $msg] + close $fd + set msg "$msg [file writable tf2]" +} {1 EACCES 0} + +test winFCmd-3.1 {TclpDeleteFile: errno: EACCES} {pcOnly cdrom} { + list [catch {testfile rm $cdfile $cdrom/dummy~~.fil} msg] $msg +} {1 EACCES} +test winFCmd-3.2 {TclpDeleteFile: errno: EISDIR} {pcOnly} { + cleanup + file mkdir td1 + list [catch {testfile rm td1} msg] $msg +} {1 EISDIR} +test winFCmd-3.3 {TclpDeleteFile: errno: ENOENT} {pcOnly} { + cleanup + list [catch {testfile rm tf1} msg] $msg +} {1 ENOENT} +test winFCmd-3.4 {TclpDeleteFile: errno: ENOENT} {pcOnly} { + cleanup + list [catch {testfile rm ""} msg] $msg +} {1 ENOENT} +test winFCmd-3.5 {TclpDeleteFile: errno: EACCES} {pcOnly} { + cleanup + set fd [open tf1 w] + set msg [list [catch {testfile rm tf1} msg] $msg] + close $fd + set msg +} {1 EACCES} +test winFCmd-3.6 {TclpDeleteFile: errno: EACCES} {pcOnly} { + cleanup + list [catch {testfile rm nul} msg] $msg +} {1 EACCES} +test winFCmd-3.7 {TclpDeleteFile: DeleteFile succeeds} {pcOnly} { + cleanup + createfile tf1 + testfile rm tf1 + file exist tf1 +} {0} +test winFCmd-3.8 {TclpDeleteFile: DeleteFile fails} {pcOnly} { + cleanup + file mkdir td1 + list [catch {testfile rm td1} msg] $msg +} {1 EISDIR} +test winFCmd-3.9 {TclpDeleteFile: errno == EACCES} {pcOnly} { + cleanup + set fd [open tf1 w] + set msg [list [catch {testfile rm tf1} msg] $msg] + close $fd + set msg +} {1 EACCES} +test winFCmd-3.10 {TclpDeleteFile: path is readonly} {pcOnly} { + cleanup + createfile tf1 + testchmod 000 tf1 + testfile rm tf1 + file exists tf1 +} {0} +test winFCmd-3.11 {TclpDeleteFile: still can't remove path} {pcOnly} { + cleanup + set fd [open tf1 w] + testchmod 000 tf1 + set msg [list [catch {testfile rm tf1} msg] $msg] + close $fd + set msg +} {1 EACCES} + +test winFCmd-4.1 {TclpCreateDirectory: errno: EACCES} {nt cdrom} { + list [catch {testfile mkdir $cdrom/dummy~~.dir} msg] $msg +} {1 EACCES} +test winFCmd-4.2 {TclpCreateDirectory: errno: EACCES} {95 cdrom} { + list [catch {testfile mkdir $cdrom/dummy~~.dir} msg] $msg +} {1 ENOSPC} +test winFCmd-4.3 {TclpCreateDirectory: errno: EEXIST} {pcOnly} { + cleanup + file mkdir td1 + list [catch {testfile mkdir td1} msg] $msg +} {1 EEXIST} +test winFCmd-4.4 {TclpCreateDirectory: errno: ENOENT} {pcOnly} { + cleanup + list [catch {testfile mkdir td1/td2} msg] $msg +} {1 ENOENT} +test winFCmd-4.5 {TclpCreateDirectory: CreateDirectory succeeds} {pcOnly} { + cleanup + testfile mkdir td1 + file type td1 +} {directory} + +test winFCmd-5.1 {TclpCopyDirectory: calls TraverseWinTree} {pcOnly} { + cleanup + file mkdir td1 + testfile cpdir td1 td2 + list [file type td1] [file type td2] +} {directory directory} + +test winFCmd-6.1 {TclpRemoveDirectory: errno: EACCES} {pcOnly} { + cleanup + file mkdir td1 + testchmod 000 td1 + testfile rmdir td1 + file exist td1 +} {0} +test winFCmd-6.2 {TclpRemoveDirectory: errno: EEXIST} {pcOnly fsIsWritable} { + cleanup + file mkdir td1/td2 + list [catch {testfile rmdir td1} msg] $msg +} {1 {td1 EEXIST}} +test winFCmd-6.3 {TclpRemoveDirectory: errno: EACCES} {pcOnly} { + # can't test this w/o removing everything on your hard disk first! + # testfile rmdir / +} {} +test winFCmd-6.4 {TclpRemoveDirectory: errno: ENOENT} {pcOnly} { + cleanup + list [catch {testfile rmdir td1} msg] $msg +} {1 {td1 ENOENT}} +test winFCmd-6.5 {TclpRemoveDirectory: errno: ENOENT} {pcOnly} { + cleanup + list [catch {testfile rmdir ""} msg] $msg +} {1 ENOENT} +test winFCmd-6.6 {TclpRemoveDirectory: errno: ENOTDIR} {pcOnly fsIsWritable} { + cleanup + createfile tf1 + list [catch {testfile rmdir tf1} msg] $msg +} {1 {tf1 ENOTDIR}} +test winFCmd-6.7 {TclpRemoveDirectory: RemoveDirectory succeeds} {pcOnly fsIsWritable} { + cleanup + file mkdir td1 + testfile rmdir td1 + file exists td1 +} {0} +test winFCmd-6.8 {TclpRemoveDirectory: RemoveDirectory fails} {pcOnly fsIsWritable} { + cleanup + createfile tf1 + list [catch {testfile rmdir tf1} msg] $msg +} {1 {tf1 ENOTDIR}} +test winFCmd-6.9 {TclpRemoveDirectory: errno == EACCES} {pcOnly fsIsWritable} { + cleanup + file mkdir td1 + testchmod 000 td1 + testfile rmdir td1 + file exists td1 +} {0} +test winFCmd-6.10 {TclpRemoveDirectory: attr == -1} {95} { + cleanup + list [catch {testfile rmdir nul} msg] $msg +} {1 {nul EACCES}} +test winFCmd-6.11 {TclpRemoveDirectory: attr == -1} {nt} { + cleanup + list [catch {testfile rmdir /} msg] $msg +} {1 {\ EACCES}} +test winFCmd-6.12 {TclpRemoveDirectory: errno == EACCES} {95 fsIsWritable} { + cleanup + createfile tf1 + list [catch {testfile rmdir tf1} msg] $msg +} {1 {tf1 ENOTDIR}} +test winFCmd-6.13 {TclpRemoveDirectory: write-protected} {pcOnly fsIsWritable} { + cleanup + file mkdir td1 + testchmod 000 td1 + testfile rmdir td1 + file exists td1 +} {0} +test winFCmd-6.14 {TclpRemoveDirectory: check if empty dir} {95 fsIsWritable} { + cleanup + file mkdir td1/td2 + list [catch {testfile rmdir td1} msg] $msg +} {1 {td1 EEXIST}} +test winFCmd-6.15 {TclpRemoveDirectory: !recursive} {pcOnly fsIsWritable} { + cleanup + file mkdir td1/td2 + list [catch {testfile rmdir td1} msg] $msg +} {1 {td1 EEXIST}} +test winFCmd-6.16 {TclpRemoveDirectory: recursive, but errno != EEXIST} {pcOnly} { + cleanup + createfile tf1 + list [catch {testfile rmdir -force tf1} msg] $msg +} {1 {tf1 ENOTDIR}} +test winFCmd-6.17 {TclpRemoveDirectory: calls TraverseWinTree} {pcOnly fsIsWritable} { + cleanup + file mkdir td1/td2 + testfile rmdir -force td1 + file exists td1 +} {0} + +test winFCmd-7.1 {TraverseWinTree: targetPtr == NULL} {pcOnly fsIsWritable} { + cleanup + file mkdir td1/td2/td3 + testfile rmdir -force td1 + file exists td1 +} {0} +test winFCmd-7.2 {TraverseWinTree: targetPtr != NULL} {pcOnly fsIsWritable} { + cleanup + file mkdir td1/td2/td3 + testfile cpdir td1 td2 + list [file exists td1] [file exists td2] +} {1 1} +test winFCmd-7.3 {TraverseWinTree: sourceAttr == -1} {pcOnly} { + cleanup + list [catch {testfile cpdir td1 td2} msg] $msg +} {1 {td1 ENOENT}} +test winFCmd-7.4 {TraverseWinTree: source isn't directory} {pcOnly fsIsWritable} { + cleanup + file mkdir td1 + createfile td1/tf1 tf1 + testfile cpdir td1 td2 + contents td2/tf1 +} {tf1} +test winFCmd-7.5 {TraverseWinTree: call TraversalCopy: DOTREE_F} {pcOnly fsIsWritable} { + cleanup + file mkdir td1 + createfile td1/tf1 tf1 + testfile cpdir td1 td2 + contents td2/tf1 +} {tf1} +test winFCmd-7.6 {TraverseWinTree: call TraversalDelete: DOTREE_F} {pcOnly fsIsWritable} { + cleanup + file mkdir td1 + createfile td1/tf1 tf1 + testfile rmdir -force td1 + file exists td1 +} {0} +test winFCmd-7.7 {TraverseWinTree: append \ to source if necessary} {pcOnly fsIsWritable} { + cleanup + file mkdir td1 + createfile td1/tf1 tf1 + testfile cpdir td1 td2 + contents td2/tf1 +} {tf1} +test winFCmd-7.8 {TraverseWinTree: append \ to source if necessary} {95 cdrom} { + list [catch {testfile rmdir $cdrom/} msg] $msg +} "1 {$cdrom\\ EEXIST}" +test winFCmd-7.9 {TraverseWinTree: append \ to source if necessary} {nt cdrom} { + list [catch {testfile rmdir $cdrom/} msg] $msg +} "1 {$cdrom\\ EACCES}" +test winFCmd-7.10 {TraverseWinTree: can't read directory: handle == INVALID} \ + {pcOnly} { + # can't make it happen +} {} +test winFCmd-7.11 {TraverseWinTree: call TraversalCopy: DOTREE_PRED} {pcOnly fsIsWritable} { + cleanup + file mkdir td1 + testchmod 000 td1 + createfile td1/tf1 tf1 + testfile cpdir td1 td2 + list [file exists td2] [file writable td2] +} {1 0} +test winFCmd-7.12 {TraverseWinTree: call TraversalDelete: DOTREE_PRED} {pcOnly fsIsWritable} { + cleanup + file mkdir td1 + createfile td1/tf1 tf1 + testfile rmdir -force td1 + file exists td1 +} {0} +test winFCmd-7.13 {TraverseWinTree: append \ to target if necessary} {pcOnly fsIsWritable} { + cleanup + file mkdir td1 + createfile td1/tf1 tf1 + testfile cpdir td1 td2 + contents td2/tf1 +} {tf1} +test winFCmd-7.14 {TraverseWinTree: append \ to target if necessary} {95 fsIsWritable} { + cleanup + file mkdir td1 + list [catch {testfile cpdir td1 /} msg] $msg +} {1 {\ EEXIST}} +test winFCmd-7.15 {TraverseWinTree: append \ to target if necessary} {nt fsIsWritable} { + cleanup + file mkdir td1 + list [catch {testfile cpdir td1 /} msg] $msg +} {1 {\ EACCES}} +test winFCmd-7.16 {TraverseWinTree: recurse on files: no files} {pcOnly fsIsWritable} { + cleanup + file mkdir td1 + testfile cpdir td1 td2 +} {} +test winFCmd-7.17 {TraverseWinTree: recurse on files: one file} {pcOnly fsIsWritable} { + cleanup + file mkdir td1 + createfile td1/td2 + testfile cpdir td1 td2 + glob td2/* +} {td2/td2} +test winFCmd-7.18 {TraverseWinTree: recurse on files: several files and dir} \ + {pcOnly fsIsWritable} { + cleanup + file mkdir td1 + createfile td1/tf1 + createfile td1/tf2 + file mkdir td1/td2/td3 + createfile td1/tf3 + createfile td1/tf4 + testfile cpdir td1 td2 + lsort [glob td2/*] +} {td2/td2 td2/tf1 td2/tf2 td2/tf3 td2/tf4} +test winFCmd-7.19 {TraverseWinTree: call TraversalCopy: DOTREE_POSTD} {pcOnly fsIsWritable} { + cleanup + file mkdir td1 + testchmod 000 td1 + createfile td1/tf1 tf1 + testfile cpdir td1 td2 + list [file exists td2] [file writable td2] +} {1 0} +test winFCmd-7.20 {TraverseWinTree: call TraversalDelete: DOTREE_POSTD} \ + {pcOnly fsIsWritable} { + cleanup + file mkdir td1 + createfile td1/tf1 tf1 + testfile rmdir -force td1 + file exists td1 +} {0} +test winFCmd-7.21 {TraverseWinTree: fill errorPtr} {pcOnly} { + cleanup + list [catch {testfile cpdir td1 td2} msg] $msg +} {1 {td1 ENOENT}} + +test winFCmd-8.1 {TraversalCopy: DOTREE_F} {pcOnly fsIsWritable} { + cleanup + file mkdir td1 + list [catch {testfile cpdir td1 td1} msg] $msg +} {1 {td1 EEXIST}} +test winFCmd-8.2 {TraversalCopy: DOTREE_PRED} {pcOnly fsIsWritable} { + cleanup + file mkdir td1/td2 + testchmod 000 td1 + testfile cpdir td1 td2 + list [file writable td1] [file writable td1/td2] +} {0 1} +test winFCmd-8.3 {TraversalCopy: DOTREE_POSTD} {pcOnly fsIsWritable} { + cleanup + file mkdir td1 + testfile cpdir td1 td2 +} {} + +test winFCmd-9.1 {TraversalDelete: DOTREE_F} {pcOnly fsIsWritable} { + cleanup + file mkdir td1 + createfile td1/tf1 + testfile rmdir -force td1 +} {} +test winFCmd-9.2 {TraversalDelete: DOTREE_F} {95 fsIsWritable} { + cleanup + file mkdir td1 + set fd [open td1/tf1 w] + set msg [list [catch {testfile rmdir -force td1} msg] $msg] + close $fd + set msg +} {1 {td1\tf1 EACCES}} +test winFCmd-9.3 {TraversalDelete: DOTREE_PRED} {pcOnly fsIsWritable} { + cleanup + file mkdir td1/td2 + testchmod 000 td1 + testfile rmdir -force td1 + file exists td1 +} {0} +test winFCmd-9.4 {TraversalDelete: DOTREE_POSTD} {pcOnly fsIsWritable} { + cleanup + file mkdir td1/td1/td3/td4/td5 + testfile rmdir -force td1 +} {} + +test winFCmd-10.1 {AttributesPosixError - get} {pcOnly} { + cleanup + list [catch {file attributes td1 -archive} msg] $msg +} {1 {could not read "td1": no such file or directory}} +test winFCmd-10.2 {AttributesPosixError - set} {pcOnly} { + cleanup + list [catch {file attributes td1 -archive 0} msg] $msg +} {1 {could not read "td1": no such file or directory}} + +test winFCmd-11.1 {GetWinFileAttributes} {pcOnly fsIsWritable} { + cleanup + close [open td1 w] + list [catch {file attributes td1 -archive} msg] $msg [cleanup] +} {0 1 {}} +test winFCmd-11.2 {GetWinFileAttributes} {pcOnly fsIsWritable} { + cleanup + close [open td1 w] + list [catch {file attributes td1 -readonly} msg] $msg [cleanup] +} {0 0 {}} +test winFCmd-11.3 {GetWinFileAttributes} {pcOnly fsIsWritable} { + cleanup + close [open td1 w] + list [catch {file attributes td1 -hidden} msg] $msg [cleanup] +} {0 0 {}} +test winFCmd-11.4 {GetWinFileAttributes} {pcOnly fsIsWritable} { + cleanup + close [open td1 w] + list [catch {file attributes td1 -system} msg] $msg [cleanup] +} {0 0 {}} +test winfcmd-11.5 {GetWinFileAttributes} {pcOnly} { + # attr of relative paths that resolve to root was failing + # don't care about answer, just that test runs. + + set old [pwd] + cd c:/ + file attr c: + file attr c:. + file attr . + cd $old +} {} + +test winFCmd-12.1 {ConvertFileNameFormat} {pcOnly fsIsWritable} { + cleanup + close [open td1 w] + list [catch {string tolower [file attributes td1 -longname]} msg] $msg [cleanup] +} {0 td1 {}} +test winFCmd-12.2 {ConvertFileNameFormat} {pcOnly fsIsWritable} { + cleanup + file mkdir td1 + close [open td1/td1 w] + list [catch {string tolower [file attributes td1/td1 -longname]} msg] $msg [cleanup] +} {0 td1/td1 {}} +test winFCmd-12.3 {ConvertFileNameFormat} {pcOnly fsIsWritable} { + cleanup + file mkdir td1 + file mkdir td1/td2 + close [open td1/td3 w] + list [catch {string tolower [file attributes td1/td2/../td3 -longname]} msg] $msg [cleanup] +} {0 td1/td2/../td3 {}} +test winFCmd-12.4 {ConvertFileNameFormat} {pcOnly fsIsWritable} { + cleanup + close [open td1 w] + list [catch {string tolower [file attributes ./td1 -longname]} msg] $msg [cleanup] +} {0 ./td1 {}} +test winFCmd-12.5 {ConvertFileNameFormat: absolute path} {pcOnly} { + list [file attributes / -longname] [file attributes \\ -longname] +} {/ /} +test winFCmd-12.6 {ConvertFileNameFormat: absolute path with drive} {pcOnly} { + catch {file delete -force -- c:/td1} + close [open c:/td1 w] + list [catch {string tolower [file attributes c:/td1 -longname]} msg] $msg [file delete -force -- c:/td1] +} {0 c:/td1 {}} +test winFCmd-12.7 {ConvertFileNameFormat} {nonPortable pcOnly} { + string tolower [file attributes //bisque/tcl/ws -longname] +} {//bisque/tcl/ws} +test winFCmd-12.8 {ConvertFileNameFormat} {pcOnly longFileNames fsIsWritable} { + cleanup + close [open td1 w] + list [catch {string tolower [file attributes td1 -longname]} msg] $msg [cleanup] +} {0 td1 {}} +test winFCmd-12.10 {ConvertFileNameFormat} {longFileNames pcOnly fsIsWritable} { + cleanup + close [open td1td1td1 w] + list [catch {file attributes td1td1td1 -shortname}] [cleanup] +} {0 {}} +test winFCmd-12.11 {ConvertFileNameFormat} {longFileNames pcOnly fsIsWritable} { + cleanup + close [open td1 w] + list [catch {string tolower [file attributes td1 -shortname]} msg] $msg [cleanup] +} {0 td1 {}} + +test winFCmd-13.1 {GetWinFileLongName} {pcOnly fsIsWritable} { + cleanup + close [open td1 w] + list [catch {string tolower [file attributes td1 -longname]} msg] $msg [cleanup] +} {0 td1 {}} + +test winFCmd-14.1 {GetWinFileShortName} {pcOnly fsIsWritable} { + cleanup + close [open td1 w] + list [catch {string tolower [file attributes td1 -shortname]} msg] $msg [cleanup] +} {0 td1 {}} + +test winFCmd-15.1 {SetWinFileAttributes} {pcOnly} { + cleanup + list [catch {file attributes td1 -archive 0} msg] $msg +} {1 {could not read "td1": no such file or directory}} +test winFCmd-15.2 {SetWinFileAttributes - archive} {pcOnly fsIsWritable} { + cleanup + close [open td1 w] + list [catch {file attributes td1 -archive 1} msg] $msg [file attributes td1 -archive] [cleanup] +} {0 {} 1 {}} +test winFCmd-15.3 {SetWinFileAttributes - archive} {pcOnly fsIsWritable} { + cleanup + close [open td1 w] + list [catch {file attributes td1 -archive 0} msg] $msg [file attributes td1 -archive] [cleanup] +} {0 {} 0 {}} +test winFCmd-15.4 {SetWinFileAttributes - hidden} {pcOnly fsIsWritable} { + cleanup + close [open td1 w] + list [catch {file attributes td1 -hidden 1} msg] $msg [file attributes td1 -hidden] [file attributes td1 -hidden 0] [cleanup] +} {0 {} 1 {} {}} +test winFCmd-15.5 {SetWinFileAttributes - hidden} {pcOnly fsIsWritable} { + cleanup + close [open td1 w] + list [catch {file attributes td1 -hidden 0} msg] $msg [file attributes td1 -hidden] [cleanup] +} {0 {} 0 {}} +test winFCmd-15.6 {SetWinFileAttributes - readonly} {pcOnly fsIsWritable} { + cleanup + close [open td1 w] + list [catch {file attributes td1 -readonly 1} msg] $msg [file attributes td1 -readonly] [cleanup] +} {0 {} 1 {}} +test winFCmd-15.7 {SetWinFileAttributes - readonly} {pcOnly fsIsWritable} { + cleanup + close [open td1 w] + list [catch {file attributes td1 -readonly 0} msg] $msg [file attributes td1 -readonly] [cleanup] +} {0 {} 0 {}} +test winFCmd-15.8 {SetWinFileAttributes - system} {pcOnly fsIsWritable} { + cleanup + close [open td1 w] + list [catch {file attributes td1 -system 1} msg] $msg [file attributes td1 -system] [cleanup] +} {0 {} 1 {}} +test winFCmd-15.9 {SetWinFileAttributes - system} {pcOnly fsIsWritable} { + cleanup + close [open td1 w] + list [catch {file attributes td1 -system 0} msg] $msg [file attributes td1 -system] [cleanup] +} {0 {} 0 {}} +test winFCmd-15.10 {SetWinFileAttributes - failing} {pcOnly cdrom} { + cleanup + catch {file attributes $cdfile -archive 1} +} {1} + +# This block of code used to occur after the "return" call, so I'm +# commenting it out and assuming that this code is still under construction. +#foreach source {tef ted tnf tnd "" nul com1} { +# foreach chmodsrc {000 755} { +# foreach dest "tfn tfe tdn tdempty tdfull td1/td2 $p $p/td1 {} nul" { +# foreach chmoddst {000 755} { +# puts hi +# cleanup +# file delete -force ted tef +# file mkdir ted +# createfile tef +# createfile tfe +# file mkdir tdempty +# file mkdir tdfull/td1/td2 +# +# catch {testchmod $chmodsrc $source} +# catch {testchmod $chmoddst $dest} +# +# if [catch {file rename $source $dest} msg] { +# puts "file rename $source ($chmodsrc) $dest ($chmoddst)" +# puts $msg +# } +# } +# } +# } +#} + +# cleanup +cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + ADDED tests/winFile.test Index: tests/winFile.test ================================================================== --- /dev/null +++ tests/winFile.test @@ -0,0 +1,1 @@ +# This file tests the tclWinFile.c file. # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: winFile.test,v 1.1.1.1 2001/08/03 16:19:05 vincentdarley Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } test winFile-1.1 {TclpGetUserHome} {pcOnly} { list [catch {glob ~nosuchuser} msg] $msg } {1 {user "nosuchuser" doesn't exist}} test winFile-1.2 {TclpGetUserHome} {nt nonPortable} { # The administrator account should always exist. catch {glob ~administrator} } {0} test winFile-1.2 {TclpGetUserHome} {95} { # Find some user in system.ini and then see if they have a home. set f [open $::env(windir)/system.ini] set x 0 while {![eof $f]} { set line [gets $f] if {$line == "\[Password Lists]"} { gets $f set name [lindex [split [gets $f] =] 0] if {$name != ""} { set x [catch {glob ~$name}] break } } } close $f set x } {0} test winFile-1.3 {TclpGetUserHome} {nt nonPortable} { catch {glob ~stanton@workgroup} } {0} test winFile-2.1 {TclpMatchFiles: case sensitivity} {pcOnly fsIsWritable} { makeFile {} GlobCapS set result [list [glob -nocomplain GlobC*] [glob -nocomplain globc*]] removeFile GlobCapS set result } {GlobCapS GlobCapS} test winFile-2.2 {TclpMatchFiles: case sensitivity} {pcOnly fsIsWritable} { makeFile {} globlower set result [list [glob -nocomplain globl*] [glob -nocomplain gLOBl*]] removeFile globlower set result } {globlower globlower} # cleanup ::tcltest::cleanupTests return ADDED win/makefile.vc Index: win/makefile.vc ================================================================== --- /dev/null +++ win/makefile.vc @@ -0,0 +1,143 @@ +# Makefile.vc +# +# This makefile is suitable for use with # Microsoft Visual C++ 2.x and 4.0. +# +# This makefile was hacked from Sun's 'example.zip' +# Copyright (c) 1996 Sun Microsystems, Inc. +# Copyright 1997 Tom Poindexter. +# Copyright 2001 Vince Darley. +# +MACHINE = IX86 + +VFS_VERSION = 1.0 +DLL_VERSION = 10 + +PROJECT = vfs$(DLL_VERSION) + +# +# Project directories -- these may need to be customized for your site +# +# ROOT -- location of the example files. +# TOOLS32 -- location of VC++ compiler installation. +# TCL -- location where Tcl is installed. +# TCLLIB -- define the Tcl lib (with correct version) + +# note that the tcl vclibs should have been unpacked in $(TCL)\lib !! + +ROOT = .. +WINDIR = $(ROOT)\win +GENERICDIR = $(ROOT)\generic +TOOLS32 = C:\Progra~1\devstudio\vc +TOOLS32_rc = C:\Progra~1\devstudio\sharedide + +cc32 = "$(TOOLS32)\bin\cl.exe" +link32 = "$(TOOLS32)\bin\link.exe" +libpath32 = /LIBPATH:"$(TOOLS32)\lib" +lib32 = "$(TOOLS32)\bin\lib.exe" + +rc32 = "$(TOOLS32_rc)\bin\rc.exe" +include32 = -I"$(TOOLS32)\include" + +# point TCL and TCLLIB to your tcl distribution + +TCL = c:\progra~1\tcl +TCLLIB = $(TCL)\lib\tclstub84.lib + +# comment the following line to compile with symbols +NODEBUG=1 + +###################################################################### +# Link flags +###################################################################### + +!IF "$(NODEBUG)" == "1" +ldebug = /RELEASE +!ELSE +ldebug = -debug:full -debugtype:cv +!ENDIF + +# declarations common to all linker options +lflags = /NODEFAULTLIB /NOLOGO /MACHINE:$(MACHINE) $(libpath32) + +# declarations for use on Intel i386, i486, and Pentium systems +!IF "$(MACHINE)" == "IX86" +DLLENTRY = @12 +dlllflags = $(lflags) -entry:_DllMainCRTStartup$(DLLENTRY) -dll +!ELSE IF "$(MACHINE)" == "IA64" +DLLENTRY = @12 +dlllflags = $(lflags) -dll +!ELSE +dlllflags = $(lflags) -entry:_DllMainCRTStartup$(DLLENTRY) -dll +!ENDIF + +conlflags = $(lflags) -subsystem:console -entry:mainCRTStartup +guilflags = $(lflags) -subsystem:windows -entry:WinMainCRTStartup + +!IF "$(MACHINE)" == "PPC" +libc = libc$(DBGX).lib +libcdll = crtdll$(DBGX).lib +!ELSE +libc = libc$(DBGX).lib oldnames.lib +libcdll = msvcrt$(DBGX).lib oldnames.lib +!ENDIF + +baselibs = kernel32.lib $(optlibs) advapi32.lib user32.lib +winlibs = $(baselibs) gdi32.lib comdlg32.lib winspool.lib + +guilibs = $(libc) $(winlibs) +conlibs = $(libc) $(baselibs) +guilibsdll = $(libcdll) $(winlibs) +conlibsdll = $(libcdll) $(baselibs) + +VFSOBJS = \ + $(WINDIR)\vfs.obj + +# +# Visual C++ tools +# + +PATH=$(COMMON32)/bin;$(TOOLS32)\bin;$(PATH) + +cc32 = $(TOOLS32)\bin\cl -I$(TOOLS32)\include +CP = copy +RM = del + +INCLUDES = \ + -I../../tcl8.4/generic \ + -I../../tcl8.4/windows \ + -I$(TOOLS32)/include \ + -I../generic + +DEFINES = -nologo $(DEBUGDEFINES) -DUSE_TCL_STUBS -DVERSION=\"1.0\" + +# +# Global makefile settings +# + +DLLOBJS = \ + $(WINDIR)\vfs.obj + +# Targets + +all: $(PROJECT).dll + + +$(PROJECT).dll: $(DLLOBJS) + $(link32) $(ldebug) $(dlllflags) $(TCLLIB) \ + $(guilibsdll) -out:$(PROJECT).dll $(DLLOBJS) + +# Implicit Targets + +#.c.obj: +# $(cc32) $(cdebug) $(cflags) $(cvarsdll) $(INCLUDES) \ +# $(DEFINES) -Fo$(WINDIR)\ $< + +$(WINDIR)\vfs.obj: $(GENERICDIR)\vfs.c + $(cc32) $(cdebug) $(cflags) $(cvarsdll) $(INCLUDES) \ + $(DEFINES) -Fo$(WINDIR)\ $? + +clean: + -$(RM) $(WINDIR)\*.obj + -$(RM) $(PROJECT).dll + -$(RM) $(PROJECT).lib + -$(RM) $(PROJECT).exp ADDED win/vfs.exp Index: win/vfs.exp ================================================================== --- /dev/null +++ win/vfs.exp cannot compute difference between binary files ADDED win/vfs.lib Index: win/vfs.lib ================================================================== --- /dev/null +++ win/vfs.lib cannot compute difference between binary files ADDED win/vfs10.exp Index: win/vfs10.exp ================================================================== --- /dev/null +++ win/vfs10.exp cannot compute difference between binary files ADDED win/vfs10.lib Index: win/vfs10.lib ================================================================== --- /dev/null +++ win/vfs10.lib cannot compute difference between binary files