--- /dev/null
+2001-05-09 Vince Darley <vincentdarley@sourceforge.net>
+
+ * initial distribution
--- /dev/null
+# 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$
+
+#========================================================================
+# 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:
--- /dev/null
+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.
--- /dev/null
+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 <http://www.santafe.edu/~vince/Alphatk.html>).
+
+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
+
+
--- /dev/null
+builtin(include,tcl.m4)
--- /dev/null
+#--------------------------------------------------------------------
+# 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])
--- /dev/null
+/*
+ * 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 <tcl.h>
+/* 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
+
+
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+}
+
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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);
+}
+
--- /dev/null
+#!/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
--- /dev/null
+
+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]
+ }
+ }
+}
+
--- /dev/null
+# 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]]]
--- /dev/null
+# 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]]
--- /dev/null
+
+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"
+ }
+ }
+ }
+ }
+}
+
--- /dev/null
+
+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]
+ }
+ }
+}
+
--- /dev/null
+
+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} {
+}
--- /dev/null
+
+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"
+ }
+}
--- /dev/null
+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.
--- /dev/null
+# 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
+ }
+}
--- /dev/null
+#! /bin/sh
+# mkinstalldirs --- make directory hierarchy
+# Author: Noah Friedman <friedman@prep.ai.mit.edu>
+# Created: 1993-05-16
+# Public domain
+
+# $Id$
+
+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
--- /dev/null
+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
--- /dev/null
+# all.tcl --\r#\r# This file contains a top-level script to run all of the Tcl\r# tests. Execute it by invoking "source all.test" when running tcltest\r# in this directory.\r#\r# Copyright (c) 1998-2000 by Scriptics Corporation.\r# All rights reserved.\r# \r# RCS: @(#) $Id$\r\rset tcltestVersion [package require tcltest]\rnamespace import -force tcltest::*\r\r#tcltest::testsDirectory [file dir [info script]]\r#tcltest::runAllTests\r\rset ::tcltest::testSingleFile false\rset ::tcltest::testsDirectory [file dir [info script]]\r\r# We need to ensure that the testsDirectory is absolute\r::tcltest::normalizePath ::tcltest::testsDirectory\r\rputs stdout "Tests running in interp: [info nameofexecutable]"\rputs stdout "Tests running in working dir: $::tcltest::testsDirectory"\rif {[llength $::tcltest::skip] > 0} {\r puts stdout "Skipping tests that match: $::tcltest::skip"\r}\rif {[llength $::tcltest::match] > 0} {\r puts stdout "Only running tests that match: $::tcltest::match"\r}\r\rif {[llength $::tcltest::skipFiles] > 0} {\r puts stdout "Skipping test files that match: $::tcltest::skipFiles"\r}\rif {[llength $::tcltest::matchFiles] > 0} {\r puts stdout "Only sourcing test files that match: $::tcltest::matchFiles"\r}\r\rtcltest::testConstraint fsIsWritable [expr {1 - [catch {file mkdir isreadonly ; file delete isreadonly}]}]\r\rset timeCmd {clock format [clock seconds]}\rputs stdout "Tests began at [eval $timeCmd]"\r\r# source each of the specified tests\rforeach file [lsort [::tcltest::getMatchingFiles]] {\r set tail [file tail $file]\r puts stdout $tail\r if {[catch {source $file} msg]} {\r puts stdout $msg\r }\r}\r\r# cleanup\rputs stdout "\nTests ended at [eval $timeCmd]"\r::tcltest::cleanupTests 1\rreturn\r\r
\ No newline at end of file
--- /dev/null
+# The file tests the tclCmdAH.c file.\r#\r# This file contains a collection of tests for one or more of the Tcl\r# built-in commands. Sourcing this file into Tcl runs the tests and\r# generates output for errors. No output means no errors were found.\r#\r# Copyright (c) 1996-1998 by Sun Microsystems, Inc.\r# Copyright (c) 1998-1999 by Scriptics Corporation.\r#\r# See the file "license.terms" for information on usage and redistribution\r# of this file, and for a DISCLAIMER OF ALL WARRANTIES.\r#\r# RCS: @(#) $Id$\r\rif {[lsearch [namespace children] ::tcltest] == -1} {\r package require tcltest\r namespace import -force ::tcltest::*\r}\r\rtcltest::testConstraint testchmod [string equal testchmod [info commands testchmod]]\rtcltest::testConstraint fsIsWritable [expr {1 - [catch {file mkdir isreadonly ; file delete isreadonly}]}]\r\rglobal env\rset cmdAHwd [pwd]\rcatch {set platform [testgetplatform]}\r\rtest cmdAH-0.1 {Tcl_BreakObjCmd, errors} {\r list [catch {break foo} msg] $msg\r} {1 {wrong # args: should be "break"}}\rtest cmdAH-0.2 {Tcl_BreakObjCmd, success} {\r list [catch {break} msg] $msg\r} {3 {}}\r\r# Tcl_CaseObjCmd is tested in case.test\r\rtest cmdAH-1.1 {Tcl_CatchObjCmd, errors} {\r list [catch {catch} msg] $msg\r} {1 {wrong # args: should be "catch command ?varName?"}}\rtest cmdAH-1.2 {Tcl_CatchObjCmd, errors} {\r list [catch {catch foo bar baz} msg] $msg\r} {1 {wrong # args: should be "catch command ?varName?"}}\r\rtest cmdAH-2.1 {Tcl_CdObjCmd} {\r list [catch {cd foo bar} msg] $msg\r} {1 {wrong # args: should be "cd ?dirName?"}}\rtest cmdAH-2.2 {Tcl_CdObjCmd} {fsIsWritable} {\r file delete -force foo\r file mkdir foo\r cd foo\r set result [file tail [pwd]]\r cd ..\r file delete foo\r set result\r} foo\rtest cmdAH-2.3 {Tcl_CdObjCmd} {fsIsWritable} {\r global env\r set oldpwd [pwd]\r set temp $env(HOME)\r set env(HOME) $oldpwd\r file delete -force foo\r file mkdir foo\r cd foo\r cd ~\r set result [string match [pwd] $oldpwd]\r file delete foo\r set env(HOME) $temp\r set result\r} 1\rtest cmdAH-2.4 {Tcl_CdObjCmd} {fsIsWritable} {\r global env\r set oldpwd [pwd]\r set temp $env(HOME)\r set env(HOME) $oldpwd\r file delete -force foo\r file mkdir foo\r cd foo\r cd\r set result [string match [pwd] $oldpwd]\r file delete foo\r set env(HOME) $temp\r set result\r} 1\rtest cmdAH-2.5 {Tcl_CdObjCmd} {\r list [catch {cd ~~} msg] $msg\r} {1 {user "~" doesn't exist}}\rtest cmdAH-2.6 {Tcl_CdObjCmd} {\r list [catch {cd _foobar} msg] $msg\r} {1 {couldn't change working directory to "_foobar": no such file or directory}}\r\rtest cmdAH-2.7 {Tcl_ConcatObjCmd} {\r concat\r} {}\rtest cmdAH-2.8 {Tcl_ConcatObjCmd} {\r concat a\r} a\rtest cmdAH-2.9 {Tcl_ConcatObjCmd} {\r concat a {b c}\r} {a b c}\r\rtest cmdAH-3.1 {Tcl_ContinueObjCmd, errors} {\r list [catch {continue foo} msg] $msg\r} {1 {wrong # args: should be "continue"}}\rtest cmdAH-3.2 {Tcl_ContinueObjCmd, success} {\r list [catch {continue} msg] $msg\r} {4 {}}\r\rtest cmdAH-4.1 {Tcl_EncodingObjCmd} {\r list [catch {encoding} msg] $msg\r} {1 {wrong # args: should be "encoding option ?arg ...?"}}\rtest cmdAH-4.2 {Tcl_EncodingObjCmd} {\r list [catch {encoding foo} msg] $msg\r} {1 {bad option "foo": must be convertfrom, convertto, names, or system}}\rtest cmdAH-4.3 {Tcl_EncodingObjCmd} {\r list [catch {encoding convertto} msg] $msg\r} {1 {wrong # args: should be "encoding convertto ?encoding? data"}}\rtest cmdAH-4.4 {Tcl_EncodingObjCmd} {\r list [catch {encoding convertto foo bar} msg] $msg\r} {1 {unknown encoding "foo"}}\rtest cmdAH-4.5 {Tcl_EncodingObjCmd} {\r set system [encoding system]\r encoding system jis0208\r set x [encoding convertto \u4e4e]\r encoding system $system\r set x\r} 8C\rtest cmdAH-4.6 {Tcl_EncodingObjCmd} {\r set system [encoding system]\r encoding system identity\r set x [encoding convertto jis0208 \u4e4e]\r encoding system $system\r set x\r} 8C\rtest cmdAH-4.7 {Tcl_EncodingObjCmd} {\r list [catch {encoding convertfrom} msg] $msg\r} {1 {wrong # args: should be "encoding convertfrom ?encoding? data"}}\rtest cmdAH-4.8 {Tcl_EncodingObjCmd} {\r list [catch {encoding convertfrom foo bar} msg] $msg\r} {1 {unknown encoding "foo"}}\rtest cmdAH-4.9 {Tcl_EncodingObjCmd} {\r set system [encoding system]\r encoding system jis0208\r set x [encoding convertfrom 8C]\r encoding system $system\r set x\r} \u4e4e\rtest cmdAH-4.10 {Tcl_EncodingObjCmd} {\r set system [encoding system]\r encoding system identity\r set x [encoding convertfrom jis0208 8C]\r encoding system $system\r set x\r} \u4e4e\rtest cmdAH-4.11 {Tcl_EncodingObjCmd} {\r list [catch {encoding names foo} msg] $msg\r} {1 {wrong # args: should be "encoding names"}}\rtest cmdAH-4.12 {Tcl_EncodingObjCmd} {\r list [catch {encoding system foo bar} msg] $msg\r} {1 {wrong # args: should be "encoding system ?encoding?"}}\rtest cmdAH-4.13 {Tcl_EncodingObjCmd} {\r set system [encoding system]\r encoding system identity\r set x [encoding system]\r encoding system $system\r set x\r} identity\r\rtest cmdAH-5.1 {Tcl_FileObjCmd} {\r list [catch file msg] $msg\r} {1 {wrong # args: should be "file option ?arg ...?"}}\rtest cmdAH-5.2 {Tcl_FileObjCmd} {\r list [catch {file x} msg] $msg\r} {1 {bad option "x": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}}\rtest cmdAH-5.3 {Tcl_FileObjCmd} {\r list [catch {file exists} msg] $msg\r} {1 {wrong # args: should be "file exists name"}}\rtest cmdAH-5.4 {Tcl_FileObjCmd} {\r list [catch {file exists ""} msg] $msg\r} {0 0}\r\r#volume\r\rtest cmdAH-6.1 {Tcl_FileObjCmd: volumes} {\r list [catch {file volumes x} msg] $msg \r} {1 {wrong # args: should be "file volumes"}}\rtest cmdAH-6.2 {Tcl_FileObjCmd: volumes} {\r set volumeList [file volumes]\r if { [llength $volumeList] == 0 } {\r set result 0\r } else {\r set result 1\r } \r} {1}\rtest cmdAH-6.3 {Tcl_FileObjCmd: volumes} {macOrUnix} {\r set volumeList [file volumes]\r catch [list glob -nocomplain [lindex $volumeList 0]*]\r} {0}\rtest cmdAH-6.4 {Tcl_FileObjCmd: volumes} {pcOnly} {\r set volumeList [string tolower [file volumes]]\r list [catch {lsearch $volumeList "c:/"} element] [expr $element != -1] [catch {list glob -nocomplain [lindex $volumeList $element]*}]\r} {0 1 0}\r\r# attributes\r\rtest cmdAH-7.1 {Tcl_FileObjCmd - file attrs} {fsIsWritable} {\r catch {file delete -force foo.file}\r close [open foo.file w]\r list [catch {file attributes foo.file}] [file delete -force foo.file]\r} {0 {}}\r\r# dirname\r\rif {[info commands testsetplatform] == {}} {\r puts "This application hasn't been compiled with the \"testsetplatform\""\r puts "command, so I can't test Tcl_FileObjCmd etc."\r} else {\rtest cmdAH-8.1 {Tcl_FileObjCmd: dirname} {\r testsetplatform unix\r list [catch {file dirname a b} msg] $msg\r} {1 {wrong # args: should be "file dirname name"}}\rtest cmdAH-8.2 {Tcl_FileObjCmd: dirname} {\r testsetplatform unix\r file dirname /a/b\r} /a\rtest cmdAH-8.3 {Tcl_FileObjCmd: dirname} {\r testsetplatform unix\r file dirname {}\r} .\rtest cmdAH-8.4 {Tcl_FileObjCmd: dirname} {\r testsetplatform mac\r file dirname {}\r} :\rtest cmdAH-8.5 {Tcl_FileObjCmd: dirname} {\r testsetplatform win\r file dirname {}\r} .\rtest cmdAH-8.6 {Tcl_FileObjCmd: dirname} {\r testsetplatform unix\r file dirname .def\r} .\rtest cmdAH-8.7 {Tcl_FileObjCmd: dirname} {\r testsetplatform mac\r file dirname a\r} :\rtest cmdAH-8.8 {Tcl_FileObjCmd: dirname} {\r testsetplatform win\r file dirname a\r} .\rtest cmdAH-8.9 {Tcl_FileObjCmd: dirname} {\r testsetplatform unix\r file dirname a/b/c.d\r} a/b\rtest cmdAH-8.10 {Tcl_FileObjCmd: dirname} {\r testsetplatform unix\r file dirname a/b.c/d\r} a/b.c\rtest cmdAH-8.11 {Tcl_FileObjCmd: dirname} {\r testsetplatform unix\r file dirname /.\r} /\rtest cmdAH-8.12 {Tcl_FileObjCmd: dirname} {\r testsetplatform unix\r list [catch {file dirname /} msg] $msg\r} {0 /}\rtest cmdAH-8.13 {Tcl_FileObjCmd: dirname} {\r testsetplatform unix\r list [catch {file dirname /foo} msg] $msg\r} {0 /}\rtest cmdAH-8.14 {Tcl_FileObjCmd: dirname} {\r testsetplatform unix\r list [catch {file dirname //foo} msg] $msg\r} {0 /}\rtest cmdAH-8.15 {Tcl_FileObjCmd: dirname} {\r testsetplatform unix\r list [catch {file dirname //foo/bar} msg] $msg\r} {0 /foo}\rtest cmdAH-8.16 {Tcl_FileObjCmd: dirname} {\r testsetplatform unix\r list [catch {file dirname {//foo\/bar/baz}} msg] $msg\r} {0 {/foo\/bar}}\rtest cmdAH-8.17 {Tcl_FileObjCmd: dirname} {\r testsetplatform unix\r list [catch {file dirname {//foo\/bar/baz/blat}} msg] $msg\r} {0 {/foo\/bar/baz}}\rtest cmdAH-8.18 {Tcl_FileObjCmd: dirname} {\r testsetplatform unix\r list [catch {file dirname /foo//} msg] $msg\r} {0 /}\rtest cmdAH-8.19 {Tcl_FileObjCmd: dirname} {\r testsetplatform unix\r list [catch {file dirname ./a} msg] $msg\r} {0 .}\rtest cmdAH-8.20 {Tcl_FileObjCmd: dirname} {\r testsetplatform unix\r list [catch {file dirname a/.a} msg] $msg\r} {0 a}\rtest cmdAH-8.21 {Tcl_FileObjCmd: dirname} {\r testsetplatform windows\r list [catch {file dirname c:foo} msg] $msg\r} {0 c:}\rtest cmdAH-8.22 {Tcl_FileObjCmd: dirname} {\r testsetplatform windows\r list [catch {file dirname c:} msg] $msg\r} {0 c:}\rtest cmdAH-8.23 {Tcl_FileObjCmd: dirname} {\r testsetplatform windows\r list [catch {file dirname c:/} msg] $msg\r} {0 c:/}\rtest cmdAH-8.24 {Tcl_FileObjCmd: dirname} {\r testsetplatform windows\r list [catch {file dirname {c:\foo}} msg] $msg\r} {0 c:/}\rtest cmdAH-8.25 {Tcl_FileObjCmd: dirname} {\r testsetplatform windows\r list [catch {file dirname {//foo/bar/baz}} msg] $msg\r} {0 //foo/bar}\rtest cmdAH-8.26 {Tcl_FileObjCmd: dirname} {\r testsetplatform windows\r list [catch {file dirname {//foo/bar}} msg] $msg\r} {0 //foo/bar}\rtest cmdAH-8.27 {Tcl_FileObjCmd: dirname} {\r testsetplatform mac\r list [catch {file dirname :} msg] $msg\r} {0 :}\rtest cmdAH-8.28 {Tcl_FileObjCmd: dirname} {\r testsetplatform mac\r list [catch {file dirname :Foo} msg] $msg\r} {0 :}\rtest cmdAH-8.29 {Tcl_FileObjCmd: dirname} {\r testsetplatform mac\r list [catch {file dirname Foo:} msg] $msg\r} {0 Foo:}\rtest cmdAH-8.30 {Tcl_FileObjCmd: dirname} {\r testsetplatform mac\r list [catch {file dirname Foo:bar} msg] $msg\r} {0 Foo:}\rtest cmdAH-8.31 {Tcl_FileObjCmd: dirname} {\r testsetplatform mac\r list [catch {file dirname :Foo:bar} msg] $msg\r} {0 :Foo}\rtest cmdAH-8.32 {Tcl_FileObjCmd: dirname} {\r testsetplatform mac\r list [catch {file dirname ::} msg] $msg\r} {0 :}\rtest cmdAH-8.33 {Tcl_FileObjCmd: dirname} {\r testsetplatform mac\r list [catch {file dirname :::} msg] $msg\r} {0 ::}\rtest cmdAH-8.34 {Tcl_FileObjCmd: dirname} {\r testsetplatform mac\r list [catch {file dirname /foo/bar/} msg] $msg\r} {0 foo:}\rtest cmdAH-8.35 {Tcl_FileObjCmd: dirname} {\r testsetplatform mac\r list [catch {file dirname /foo/bar} msg] $msg\r} {0 foo:}\rtest cmdAH-8.36 {Tcl_FileObjCmd: dirname} {\r testsetplatform mac\r list [catch {file dirname /foo} msg] $msg\r} {0 foo:}\rtest cmdAH-8.37 {Tcl_FileObjCmd: dirname} {\r testsetplatform mac\r list [catch {file dirname foo} msg] $msg\r} {0 :}\rtest cmdAH-8.38 {Tcl_FileObjCmd: dirname} {\r testsetplatform unix\r list [catch {file dirname ~/foo} msg] $msg\r} {0 ~}\rtest cmdAH-8.39 {Tcl_FileObjCmd: dirname} {\r testsetplatform unix\r list [catch {file dirname ~bar/foo} msg] $msg\r} {0 ~bar}\rtest cmdAH-8.40 {Tcl_FileObjCmd: dirname} {\r testsetplatform mac\r list [catch {file dirname ~bar/foo} msg] $msg\r} {0 ~bar:}\rtest cmdAH-8.41 {Tcl_FileObjCmd: dirname} {\r testsetplatform mac\r list [catch {file dirname ~/foo} msg] $msg\r} {0 ~:}\rtest cmdAH-8.42 {Tcl_FileObjCmd: dirname} {\r testsetplatform mac\r list [catch {file dirname ~:baz} msg] $msg\r} {0 ~:}\rtest cmdAH-8.43 {Tcl_FileObjCmd: dirname} {\r global env\r set temp $env(HOME)\r set env(HOME) "/home/test"\r testsetplatform unix\r set result [list [catch {file dirname ~} msg] $msg]\r set env(HOME) $temp\r set result\r} {0 /home}\rtest cmdAH-8.44 {Tcl_FileObjCmd: dirname} {\r global env\r set temp $env(HOME)\r set env(HOME) "~"\r testsetplatform unix\r set result [list [catch {file dirname ~} msg] $msg]\r set env(HOME) $temp\r set result\r} {0 ~}\rtest cmdAH-8.45 {Tcl_FileObjCmd: dirname} {\r global env\r set temp $env(HOME)\r set env(HOME) "/home/test"\r testsetplatform windows\r set result [list [catch {file dirname ~} msg] $msg]\r set env(HOME) $temp\r set result\r} {0 /home}\rtest cmdAH-8.46 {Tcl_FileObjCmd: dirname} {\r global env\r set temp $env(HOME)\r set env(HOME) "/home/test"\r testsetplatform mac\r set result [list [catch {file dirname ~} msg] $msg]\r set env(HOME) $temp\r set result\r} {0 home:}\r\r# tail\r\rtest cmdAH-9.1 {Tcl_FileObjCmd: tail} {\r testsetplatform unix\r list [catch {file tail a b} msg] $msg\r} {1 {wrong # args: should be "file tail name"}}\rtest cmdAH-9.2 {Tcl_FileObjCmd: tail} {\r testsetplatform unix\r file tail /a/b\r} b\rtest cmdAH-9.3 {Tcl_FileObjCmd: tail} {\r testsetplatform unix\r file tail {}\r} {}\rtest cmdAH-9.4 {Tcl_FileObjCmd: tail} {\r testsetplatform mac\r file tail {}\r} {}\rtest cmdAH-9.5 {Tcl_FileObjCmd: tail} {\r testsetplatform win\r file tail {}\r} {}\rtest cmdAH-9.6 {Tcl_FileObjCmd: tail} {\r testsetplatform unix\r file tail .def\r} .def\rtest cmdAH-9.7 {Tcl_FileObjCmd: tail} {\r testsetplatform mac\r file tail a\r} a\rtest cmdAH-9.8 {Tcl_FileObjCmd: tail} {\r testsetplatform win\r file tail a\r} a\rtest cmdAH-9.9 {Tcl_FileObjCmd: tail} {\r testsetplatform unix\r file ta a/b/c.d\r} c.d\rtest cmdAH-9.10 {Tcl_FileObjCmd: tail} {\r testsetplatform unix\r file tail a/b.c/d\r} d\rtest cmdAH-9.11 {Tcl_FileObjCmd: tail} {\r testsetplatform unix\r file tail /.\r} .\rtest cmdAH-9.12 {Tcl_FileObjCmd: tail} {\r testsetplatform unix\r file tail /\r} {}\rtest cmdAH-9.13 {Tcl_FileObjCmd: tail} {\r testsetplatform unix\r file tail /foo\r} foo\rtest cmdAH-9.14 {Tcl_FileObjCmd: tail} {\r testsetplatform unix\r file tail //foo\r} foo\rtest cmdAH-9.15 {Tcl_FileObjCmd: tail} {\r testsetplatform unix\r file tail //foo/bar\r} bar\rtest cmdAH-9.16 {Tcl_FileObjCmd: tail} {\r testsetplatform unix\r file tail {//foo\/bar/baz}\r} baz\rtest cmdAH-9.17 {Tcl_FileObjCmd: tail} {\r testsetplatform unix\r file tail {//foo\/bar/baz/blat}\r} blat\rtest cmdAH-9.18 {Tcl_FileObjCmd: tail} {\r testsetplatform unix\r file tail /foo//\r} foo\rtest cmdAH-9.19 {Tcl_FileObjCmd: tail} {\r testsetplatform unix\r file tail ./a\r} a\rtest cmdAH-9.20 {Tcl_FileObjCmd: tail} {\r testsetplatform unix\r file tail a/.a\r} .a\rtest cmdAH-9.21 {Tcl_FileObjCmd: tail} {\r testsetplatform windows\r file tail c:foo\r} foo\rtest cmdAH-9.22 {Tcl_FileObjCmd: tail} {\r testsetplatform windows\r file tail c:\r} {}\rtest cmdAH-9.23 {Tcl_FileObjCmd: tail} {\r testsetplatform windows\r file tail c:/\r} {}\rtest cmdAH-9.24 {Tcl_FileObjCmd: tail} {\r testsetplatform windows\r file tail {c:\foo}\r} foo\rtest cmdAH-9.25 {Tcl_FileObjCmd: tail} {\r testsetplatform windows\r file tail {//foo/bar/baz}\r} baz\rtest cmdAH-9.26 {Tcl_FileObjCmd: tail} {\r testsetplatform windows\r file tail {//foo/bar}\r} {}\rtest cmdAH-9.27 {Tcl_FileObjCmd: tail} {\r testsetplatform mac\r file tail :\r} :\rtest cmdAH-9.28 {Tcl_FileObjCmd: tail} {\r testsetplatform mac\r file tail :Foo\r} Foo\rtest cmdAH-9.29 {Tcl_FileObjCmd: tail} {\r testsetplatform mac\r file tail Foo:\r} {}\rtest cmdAH-9.30 {Tcl_FileObjCmd: tail} {\r testsetplatform mac\r file tail Foo:bar\r} bar\rtest cmdAH-9.31 {Tcl_FileObjCmd: tail} {\r testsetplatform mac\r file tail :Foo:bar\r} bar\rtest cmdAH-9.32 {Tcl_FileObjCmd: tail} {\r testsetplatform mac\r file tail ::\r} ::\rtest cmdAH-9.33 {Tcl_FileObjCmd: tail} {\r testsetplatform mac\r file tail :::\r} ::\rtest cmdAH-9.34 {Tcl_FileObjCmd: tail} {\r testsetplatform mac\r file tail /foo/bar/\r} bar\rtest cmdAH-9.35 {Tcl_FileObjCmd: tail} {\r testsetplatform mac\r file tail /foo/bar\r} bar\rtest cmdAH-9.36 {Tcl_FileObjCmd: tail} {\r testsetplatform mac\r file tail /foo\r} {}\rtest cmdAH-9.37 {Tcl_FileObjCmd: tail} {\r testsetplatform mac\r file tail foo\r} foo\rtest cmdAH-9.38 {Tcl_FileObjCmd: tail} {\r testsetplatform mac\r file tail ~:foo\r} foo\rtest cmdAH-9.39 {Tcl_FileObjCmd: tail} {\r testsetplatform mac\r file tail ~bar:foo\r} foo\rtest cmdAH-9.40 {Tcl_FileObjCmd: tail} {\r testsetplatform mac\r file tail ~bar/foo\r} foo\rtest cmdAH-9.41 {Tcl_FileObjCmd: tail} {\r testsetplatform mac\r file tail ~/foo\r} foo\rtest cmdAH-9.42 {Tcl_FileObjCmd: tail} {\r global env\r set temp $env(HOME)\r set env(HOME) "/home/test"\r testsetplatform unix\r set result [file tail ~]\r set env(HOME) $temp\r set result\r} test\rtest cmdAH-9.43 {Tcl_FileObjCmd: tail} {\r global env\r set temp $env(HOME)\r set env(HOME) "~"\r testsetplatform unix\r set result [file tail ~]\r set env(HOME) $temp\r set result\r} {}\rtest cmdAH-9.44 {Tcl_FileObjCmd: tail} {\r global env\r set temp $env(HOME)\r set env(HOME) "/home/test"\r testsetplatform windows\r set result [file tail ~]\r set env(HOME) $temp\r set result\r} test\rtest cmdAH-9.45 {Tcl_FileObjCmd: tail} {\r global env\r set temp $env(HOME)\r set env(HOME) "/home/test"\r testsetplatform mac\r set result [file tail ~]\r set env(HOME) $temp\r set result\r} test\rtest cmdAH-9.46 {Tcl_FileObjCmd: tail} {\r testsetplatform unix\r file tail {f.oo\bar/baz.bat}\r} baz.bat\rtest cmdAH-9.47 {Tcl_FileObjCmd: tail} {\r testsetplatform windows\r file tail c:foo\r} foo\rtest cmdAH-9.48 {Tcl_FileObjCmd: tail} {\r testsetplatform windows\r file tail c:\r} {}\rtest cmdAH-9.49 {Tcl_FileObjCmd: tail} {\r testsetplatform windows\r file tail c:/foo\r} foo\rtest cmdAH-9.50 {Tcl_FileObjCmd: tail} {\r testsetplatform windows\r file tail {c:/foo\bar}\r} bar\rtest cmdAH-9.51 {Tcl_FileObjCmd: tail} {\r testsetplatform windows\r file tail {foo\bar}\r} bar\r\r# rootname\r\rtest cmdAH-10.1 {Tcl_FileObjCmd: rootname} {\r testsetplatform unix\r list [catch {file rootname a b} msg] $msg\r} {1 {wrong # args: should be "file rootname name"}}\rtest cmdAH-10.2 {Tcl_FileObjCmd: rootname} {\r testsetplatform unix\r file rootname {}\r} {}\rtest cmdAH-10.3 {Tcl_FileObjCmd: rootname} {\r testsetplatform unix\r file ro foo\r} foo\rtest cmdAH-10.4 {Tcl_FileObjCmd: rootname} {\r testsetplatform unix\r file rootname foo.\r} foo\rtest cmdAH-10.5 {Tcl_FileObjCmd: rootname} {\r testsetplatform unix\r file rootname .foo\r} {}\rtest cmdAH-10.6 {Tcl_FileObjCmd: rootname} {\r testsetplatform unix\r file rootname abc.def\r} abc\rtest cmdAH-10.7 {Tcl_FileObjCmd: rootname} {\r testsetplatform unix\r file rootname abc.def.ghi\r} abc.def\rtest cmdAH-10.8 {Tcl_FileObjCmd: rootname} {\r testsetplatform unix\r file rootname a/b/c.d\r} a/b/c\rtest cmdAH-10.9 {Tcl_FileObjCmd: rootname} {\r testsetplatform unix\r file rootname a/b.c/d\r} a/b.c/d\rtest cmdAH-10.10 {Tcl_FileObjCmd: rootname} {\r testsetplatform unix\r file rootname a/b.c/\r} a/b.c/\rtest cmdAH-10.11 {Tcl_FileObjCmd: rootname} {\r testsetplatform mac\r file ro foo\r} foo\rtest cmdAH-10.12 {Tcl_FileObjCmd: rootname} {\r testsetplatform mac\r file rootname {}\r} {}\rtest cmdAH-10.13 {Tcl_FileObjCmd: rootname} {\r testsetplatform mac\r file rootname foo.\r} foo\rtest cmdAH-10.14 {Tcl_FileObjCmd: rootname} {\r testsetplatform mac\r file rootname .foo\r} {}\rtest cmdAH-10.15 {Tcl_FileObjCmd: rootname} {\r testsetplatform mac\r file rootname abc.def\r} abc\rtest cmdAH-10.16 {Tcl_FileObjCmd: rootname} {\r testsetplatform mac\r file rootname abc.def.ghi\r} abc.def\rtest cmdAH-10.17 {Tcl_FileObjCmd: rootname} {\r testsetplatform mac\r file rootname a:b:c.d\r} a:b:c\rtest cmdAH-10.18 {Tcl_FileObjCmd: rootname} {\r testsetplatform mac\r file rootname a:b.c:d\r} a:b.c:d\rtest cmdAH-10.19 {Tcl_FileObjCmd: rootname} {\r testsetplatform mac\r file rootname a/b/c.d\r} a/b/c\rtest cmdAH-10.20 {Tcl_FileObjCmd: rootname} {\r testsetplatform mac\r file rootname a/b.c/d\r} a/b.c/d\rtest cmdAH-10.21 {Tcl_FileObjCmd: rootname} {\r testsetplatform mac\r file rootname /a.b\r} /a\rtest cmdAH-10.22 {Tcl_FileObjCmd: rootname} {\r testsetplatform mac\r file rootname foo.c:\r} foo.c:\rtest cmdAH-10.23 {Tcl_FileObjCmd: rootname} {\r testsetplatform windows\r file rootname {}\r} {}\rtest cmdAH-10.24 {Tcl_FileObjCmd: rootname} {\r testsetplatform windows\r file ro foo\r} foo\rtest cmdAH-10.25 {Tcl_FileObjCmd: rootname} {\r testsetplatform windows\r file rootname foo.\r} foo\rtest cmdAH-10.26 {Tcl_FileObjCmd: rootname} {\r testsetplatform windows\r file rootname .foo\r} {}\rtest cmdAH-10.27 {Tcl_FileObjCmd: rootname} {\r testsetplatform windows\r file rootname abc.def\r} abc\rtest cmdAH-10.28 {Tcl_FileObjCmd: rootname} {\r testsetplatform windows\r file rootname abc.def.ghi\r} abc.def\rtest cmdAH-10.29 {Tcl_FileObjCmd: rootname} {\r testsetplatform windows\r file rootname a/b/c.d\r} a/b/c\rtest cmdAH-10.30 {Tcl_FileObjCmd: rootname} {\r testsetplatform windows\r file rootname a/b.c/d\r} a/b.c/d\rtest cmdAH-10.31 {Tcl_FileObjCmd: rootname} {\r testsetplatform windows\r file rootname a\\b.c\\\r} a\\b.c\\\rtest cmdAH-10.32 {Tcl_FileObjCmd: rootname} {\r testsetplatform windows\r file rootname a\\b\\c.d\r} a\\b\\c\rtest cmdAH-10.33 {Tcl_FileObjCmd: rootname} {\r testsetplatform windows\r file rootname a\\b.c\\d\r} a\\b.c\\d\rtest cmdAH-10.34 {Tcl_FileObjCmd: rootname} {\r testsetplatform windows\r file rootname a\\b.c\\\r} a\\b.c\\\rset num 35\rforeach outer { {} a .a a. a.a } {\r foreach inner { {} a .a a. a.a } {\r set thing [format %s/%s $outer $inner]\r; test cmdAH-6.$num {Tcl_FileObjCmd: rootname and extension options} {\r testsetplatform unix\r format %s%s [file rootname $thing] [file ext $thing]\r } $thing\r set num [expr $num+1]\r }\r}\r\r# extension\r\rtest cmdAH-11.1 {Tcl_FileObjCmd: extension} {\r testsetplatform unix\r list [catch {file extension a b} msg] $msg\r} {1 {wrong # args: should be "file extension name"}}\rtest cmdAH-11.2 {Tcl_FileObjCmd: extension} {\r testsetplatform unix\r file extension {}\r} {}\rtest cmdAH-11.3 {Tcl_FileObjCmd: extension} {\r testsetplatform unix\r file ext foo\r} {}\rtest cmdAH-11.4 {Tcl_FileObjCmd: extension} {\r testsetplatform unix\r file extension foo.\r} .\rtest cmdAH-11.5 {Tcl_FileObjCmd: extension} {\r testsetplatform unix\r file extension .foo\r} .foo\rtest cmdAH-11.6 {Tcl_FileObjCmd: extension} {\r testsetplatform unix\r file extension abc.def\r} .def\rtest cmdAH-11.7 {Tcl_FileObjCmd: extension} {\r testsetplatform unix\r file extension abc.def.ghi\r} .ghi\rtest cmdAH-11.8 {Tcl_FileObjCmd: extension} {\r testsetplatform unix\r file extension a/b/c.d\r} .d\rtest cmdAH-11.9 {Tcl_FileObjCmd: extension} {\r testsetplatform unix\r file extension a/b.c/d\r} {}\rtest cmdAH-11.10 {Tcl_FileObjCmd: extension} {\r testsetplatform unix\r file extension a/b.c/\r} {}\rtest cmdAH-11.11 {Tcl_FileObjCmd: extension} {\r testsetplatform mac\r file ext foo\r} {}\rtest cmdAH-11.12 {Tcl_FileObjCmd: extension} {\r testsetplatform mac\r file extension {}\r} {}\rtest cmdAH-11.13 {Tcl_FileObjCmd: extension} {\r testsetplatform mac\r file extension foo.\r} .\rtest cmdAH-11.14 {Tcl_FileObjCmd: extension} {\r testsetplatform mac\r file extension .foo\r} .foo\rtest cmdAH-11.15 {Tcl_FileObjCmd: extension} {\r testsetplatform mac\r file extension abc.def\r} .def\rtest cmdAH-11.16 {Tcl_FileObjCmd: extension} {\r testsetplatform mac\r file extension abc.def.ghi\r} .ghi\rtest cmdAH-11.17 {Tcl_FileObjCmd: extension} {\r testsetplatform mac\r file extension a:b:c.d\r} .d\rtest cmdAH-11.18 {Tcl_FileObjCmd: extension} {\r testsetplatform mac\r file extension a:b.c:d\r} {}\rtest cmdAH-11.19 {Tcl_FileObjCmd: extension} {\r testsetplatform mac\r file extension a/b/c.d\r} .d\rtest cmdAH-11.20 {Tcl_FileObjCmd: extension} {\r testsetplatform mac\r file extension a/b.c/d\r} {}\rtest cmdAH-11.21 {Tcl_FileObjCmd: extension} {\r testsetplatform mac\r file extension /a.b\r} .b\rtest cmdAH-11.22 {Tcl_FileObjCmd: extension} {\r testsetplatform mac\r file extension foo.c:\r} {}\rtest cmdAH-11.23 {Tcl_FileObjCmd: extension} {\r testsetplatform windows\r file extension {}\r} {}\rtest cmdAH-11.24 {Tcl_FileObjCmd: extension} {\r testsetplatform windows\r file ext foo\r} {}\rtest cmdAH-11.25 {Tcl_FileObjCmd: extension} {\r testsetplatform windows\r file extension foo.\r} .\rtest cmdAH-11.26 {Tcl_FileObjCmd: extension} {\r testsetplatform windows\r file extension .foo\r} .foo\rtest cmdAH-11.27 {Tcl_FileObjCmd: extension} {\r testsetplatform windows\r file extension abc.def\r} .def\rtest cmdAH-11.28 {Tcl_FileObjCmd: extension} {\r testsetplatform windows\r file extension abc.def.ghi\r} .ghi\rtest cmdAH-11.29 {Tcl_FileObjCmd: extension} {\r testsetplatform windows\r file extension a/b/c.d\r} .d\rtest cmdAH-11.30 {Tcl_FileObjCmd: extension} {\r testsetplatform windows\r file extension a/b.c/d\r} {}\rtest cmdAH-11.31 {Tcl_FileObjCmd: extension} {\r testsetplatform windows\r file extension a\\b.c\\\r} {}\rtest cmdAH-11.32 {Tcl_FileObjCmd: extension} {\r testsetplatform windows\r file extension a\\b\\c.d\r} .d\rtest cmdAH-11.33 {Tcl_FileObjCmd: extension} {\r testsetplatform windows\r file extension a\\b.c\\d\r} {}\rtest cmdAH-11.34 {Tcl_FileObjCmd: extension} {\r testsetplatform windows\r file extension a\\b.c\\\r} {}\rset num 35\rforeach value {a..b a...b a.c..b ..b} result {.b .b .b .b} {\r foreach p {unix mac windows} {\r; test cmdAH-7.$num {Tcl_FileObjCmd: extension} "\r testsetplatform $p\r file extension $value\r " $result\r incr num\r }\r}\r\r# pathtype\r\rtest cmdAH-12.1 {Tcl_FileObjCmd: pathtype} {\r testsetplatform unix\r list [catch {file pathtype a b} msg] $msg\r} {1 {wrong # args: should be "file pathtype name"}}\rtest cmdAH-12.2 {Tcl_FileObjCmd: pathtype} {\r testsetplatform unix\r file pathtype /a\r} absolute\rtest cmdAH-12.3 {Tcl_FileObjCmd: pathtype} {\r testsetplatform unix\r file p a\r} relative\rtest cmdAH-12.4 {Tcl_FileObjCmd: pathtype} {\r testsetplatform windows\r file pathtype c:a\r} volumerelative\r\r# split\r\rtest cmdAH-13.1 {Tcl_FileObjCmd: split} {\r testsetplatform unix\r list [catch {file split a b} msg] $msg\r} {1 {wrong # args: should be "file split name"}}\rtest cmdAH-13.2 {Tcl_FileObjCmd: split} {\r testsetplatform unix\r file split a\r} a\rtest cmdAH-13.3 {Tcl_FileObjCmd: split} {\r testsetplatform unix\r file split a/b\r} {a b}\r\r# join\r\rtest cmdAH-14.1 {Tcl_FileObjCmd: join} {\r testsetplatform unix\r file join a\r} a\rtest cmdAH-14.2 {Tcl_FileObjCmd: join} {\r testsetplatform unix\r file join a b\r} a/b\rtest cmdAH-14.3 {Tcl_FileObjCmd: join} {\r testsetplatform unix\r file join a b c d\r} a/b/c/d\r\r# error handling of Tcl_TranslateFileName\r\rtest cmdAH-15.1 {Tcl_FileObjCmd} {\r testsetplatform unix\r list [catch {file atime ~_bad_user} msg] $msg\r} {1 {user "_bad_user" doesn't exist}}\r\rtestsetplatform $platform\r}\r\r# readable\r\rmakeFile abcde gorp.file\rmakeDirectory dir.file\r\rtest cmdAH-16.1 {Tcl_FileObjCmd: readable} {testchmod} {\r list [catch {file readable a b} msg] $msg\r} {1 {wrong # args: should be "file readable name"}}\rtestchmod 444 gorp.file\rtest cmdAH-16.2 {Tcl_FileObjCmd: readable} {testchmod} {\r file readable gorp.file\r} 1\rtestchmod 333 gorp.file\rtest cmdAH-16.3 {Tcl_FileObjCmd: readable} {unixOnly notRoot testchmod} {\r file reada gorp.file\r} 0\r\r# writable\r\rtest cmdAH-17.1 {Tcl_FileObjCmd: writable} {testchmod} {\r list [catch {file writable a b} msg] $msg\r} {1 {wrong # args: should be "file writable name"}}\rtestchmod 555 gorp.file\rtest cmdAH-17.2 {Tcl_FileObjCmd: writable} {notRoot testchmod} {\r file writable gorp.file\r} 0\rtestchmod 222 gorp.file\rtest cmdAH-17.3 {Tcl_FileObjCmd: writable} {testchmod} {\r file writable gorp.file\r} 1\r\r# executable\r\rfile delete -force dir.file gorp.file\rfile mkdir dir.file\rmakeFile abcde gorp.file\r\rtest cmdAH-18.1 {Tcl_FileObjCmd: executable} {testchmod} {\r list [catch {file executable a b} msg] $msg\r} {1 {wrong # args: should be "file executable name"}}\rtest cmdAH-18.2 {Tcl_FileObjCmd: executable} {testchmod} {\r file executable gorp.file\r} 0\rtest cmdAH-18.3 {Tcl_FileObjCmd: executable} {unixOnly testchmod} {\r # Only on unix will setting the execute bit on a regular file\r # cause that file to be executable. \r \r testchmod 775 gorp.file\r file exe gorp.file\r} 1\r\rtest cmdAH-18.4 {Tcl_FileObjCmd: executable} {macOnly testchmod} {\r # On mac, the only executable files are of type APPL.\r\r set x [file exe gorp.file] \r file attrib gorp.file -type APPL\r lappend x [file exe gorp.file]\r} {0 1}\rtest cmdAH-18.5 {Tcl_FileObjCmd: executable} {pcOnly testchmod} {\r # On pc, must be a .exe, .com, etc.\r \r set x [file exe gorp.file]\r makeFile foo gorp.exe\r lappend x [file exe gorp.exe]\r file delete gorp.exe\r set x\r} {0 1}\rtest cmdAH-18.6 {Tcl_FileObjCmd: executable} {testchmod} {\r # Directories are always executable.\r \r file exe dir.file\r} 1\r\rfile delete -force dir.file \rfile delete gorp.file\rfile delete link.file\r\r# exists\r\rtest cmdAH-19.1 {Tcl_FileObjCmd: exists} {\r list [catch {file exists a b} msg] $msg\r} {1 {wrong # args: should be "file exists name"}}\rtest cmdAH-19.2 {Tcl_FileObjCmd: exists} {file exists gorp.file} 0\rtest cmdAH-19.3 {Tcl_FileObjCmd: exists} {\r file exists [file join dir.file gorp.file]\r} 0\rcatch {\r makeFile abcde gorp.file\r makeDirectory dir.file\r makeFile 12345 [file join dir.file gorp.file]\r}\rtest cmdAH-19.4 {Tcl_FileObjCmd: exists} {\r file exists gorp.file\r} 1\rtest cmdAH-19.5 {Tcl_FileObjCmd: exists} {\r file exists [file join dir.file gorp.file]\r} 1\r\r# nativename\rif {[info commands testsetplatform] == {}} {\r puts "This application hasn't been compiled with the \"testsetplatform\""\r puts "command, so I can't test Tcl_FileObjCmd etc."\r} else {\rtest cmdAH-19.6 {Tcl_FileObjCmd: nativename} {\r testsetplatform unix\r list [catch {file nativename a/b} msg] $msg [testsetplatform $platform]\r} {0 a/b {}}\rtest cmdAH-19.7 {Tcl_FileObjCmd: nativename} {\r testsetplatform windows\r list [catch {file nativename a/b} msg] $msg [testsetplatform $platform]\r} {0 {a\b} {}}\rtest cmdAH-19.8 {Tcl_FileObjCmd: nativename} {\r testsetplatform mac\r list [catch {file nativename a/b} msg] $msg [testsetplatform $platform]\r} {0 :a:b {}}\r}\r\rtest cmdAH-19.9 {Tcl_FileObjCmd: ~ : exists} {\r file exists ~nOsUcHuSeR\r} 0\rtest cmdAH-19.10 {Tcl_FileObjCmd: ~ : nativename} {\r # should probably be 0 in fact...\r catch {file nativename ~nOsUcHuSeR}\r} 1\r\r# The test below has to be done in /tmp rather than the current\r# directory in order to guarantee (?) a local file system: some\r# NFS file systems won't do the stuff below correctly.\r\rtest cmdAH-19.11 {Tcl_FileObjCmd: exists} {unixOnly notRoot} {\r removeFile /tmp/tcl.foo.dir/file\r removeDirectory /tmp/tcl.foo.dir\r makeDirectory /tmp/tcl.foo.dir\r makeFile 12345 /tmp/tcl.foo.dir/file\r exec chmod 000 /tmp/tcl.foo.dir\r\r set result [file exists /tmp/tcl.foo.dir/file]\r\r exec chmod 775 /tmp/tcl.foo.dir\r removeFile /tmp/tcl.foo.dir/file\r removeDirectory /tmp/tcl.foo.dir\r set result\r} 0\r\r# Stat related commands\r\rcatch {testsetplatform $platform}\rfile delete gorp.file\rmakeFile "Test string" gorp.file\rcatch {exec chmod 765 gorp.file}\r\r# atime\r\rset file [makeFile "data" touch.me]\r\rtest cmdAH-20.1 {Tcl_FileObjCmd: atime} {\r list [catch {file atime a b c} msg] $msg\r} {1 {wrong # args: should be "file atime name ?time?"}}\rtest cmdAH-20.2 {Tcl_FileObjCmd: atime} {\r catch {unset stat}\r file stat gorp.file stat\r list [expr {[file mtime gorp.file] == $stat(mtime)}] \\r [expr {[file atime gorp.file] == $stat(atime)}]\r} {1 1}\rtest cmdAH-20.3 {Tcl_FileObjCmd: atime} {\r string tolower [list [catch {file atime _bogus_} msg] \\r $msg $errorCode]\r} {1 {could not read "_bogus_": no such file or directory} {posix enoent {no such file or directory}}}\rtest cmdAH-20.4 {Tcl_FileObjCmd: atime} {\r list [catch {file atime $file notint} msg] $msg\r} {1 {expected integer but got "notint"}}\rtest cmdAH-20.5 {Tcl_FileObjCmd: atime touch} {\r if {[string equal $tcl_platform(platform) "windows"]} {\r set old [pwd]\r cd $::tcltest::temporaryDirectory\r if {![string equal "NTFS" [testvolumetype]]} {\r # Windows FAT doesn't understand atime, but NTFS does\r # May also fail for Windows on NFS mounted disks\r cd $old\r return 1\r }\r cd $old\r }\r set atime [file atime $file]\r after 1100; # pause a sec to notice change in atime\r set newatime [clock seconds]\r expr {$newatime==[file atime $file $newatime]}\r} 1\r\r# isdirectory\r\rtest cmdAH-21.1 {Tcl_FileObjCmd: isdirectory} {\r list [catch {file isdirectory a b} msg] $msg\r} {1 {wrong # args: should be "file isdirectory name"}}\rtest cmdAH-21.2 {Tcl_FileObjCmd: isdirectory} {\r file isdirectory gorp.file\r} 0\rtest cmdAH-21.3 {Tcl_FileObjCmd: isdirectory} {\r file isd dir.file\r} 1\r\r# isfile\r\rtest cmdAH-22.1 {Tcl_FileObjCmd: isfile} {\r list [catch {file isfile a b} msg] $msg\r} {1 {wrong # args: should be "file isfile name"}}\rtest cmdAH-22.2 {Tcl_FileObjCmd: isfile} {file isfile gorp.file} 1\rtest cmdAH-22.3 {Tcl_FileObjCmd: isfile} {file isfile dir.file} 0\r\r# lstat and readlink: don't run these tests everywhere, since not all\r# sites will have symbolic links\r\rcatch {exec ln -s gorp.file link.file}\rtest cmdAH-23.1 {Tcl_FileObjCmd: lstat} {\r list [catch {file lstat a} msg] $msg\r} {1 {wrong # args: should be "file lstat name varName"}}\rtest cmdAH-23.2 {Tcl_FileObjCmd: lstat} {\r list [catch {file lstat a b c} msg] $msg\r} {1 {wrong # args: should be "file lstat name varName"}}\rtest cmdAH-23.3 {Tcl_FileObjCmd: lstat} {unixOnly nonPortable} {\r catch {unset stat}\r file lstat link.file stat\r lsort [array names stat]\r} {atime ctime dev gid ino mode mtime nlink size type uid}\rtest cmdAH-23.4 {Tcl_FileObjCmd: lstat} {unixOnly nonPortable} {\r catch {unset stat}\r file lstat link.file stat\r list $stat(nlink) [expr $stat(mode)&0777] $stat(type)\r} {1 511 link}\rtest cmdAH-23.5 {Tcl_FileObjCmd: lstat errors} {nonPortable} {\r string tolower [list [catch {file lstat _bogus_ stat} msg] \\r $msg $errorCode]\r} {1 {could not read "_bogus_": no such file or directory} {posix enoent {no such file or directory}}}\rtest cmdAH-23.6 {Tcl_FileObjCmd: lstat errors} {\r catch {unset x}\r set x 44\r list [catch {file lstat gorp.file x} msg] $msg $errorCode\r} {1 {can't set "x(dev)": variable isn't array} NONE}\rcatch {unset stat}\r\r# mkdir\r\rtest cmdAH-23.7 {Tcl_FileObjCmd: mkdir} {\r catch {file delete -force a}\r file mkdir a\r set res [file isdirectory a]\r file delete a\r set res\r} {1}\rtest cmdAH-23.8 {Tcl_FileObjCmd: mkdir} {\r catch {file delete -force a}\r file mkdir a/b\r set res [file isdirectory a/b]\r file delete -force a\r set res\r} {1}\rtest cmdAH-23.9 {Tcl_FileObjCmd: mkdir} {\r catch {file delete -force a}\r file mkdir a/b/c\r set res [file isdirectory a/b/c]\r file delete -force a\r set res\r} {1}\rtest cmdAH-23.10 {Tcl_FileObjCmd: mkdir} {\r catch {file delete -force a}\r catch {file delete -force b}\r file mkdir a/b b/a/c\r set res [list [file isdirectory a/b] [file isdirectory b/a/c]]\r file delete -force a\r file delete -force b\r set res\r} {1 1}\r\r# mtime \r\rset file [makeFile "data" touch.me]\r\rtest cmdAH-24.1 {Tcl_FileObjCmd: mtime} {\r list [catch {file mtime a b c} msg] $msg\r} {1 {wrong # args: should be "file mtime name ?time?"}}\rtest cmdAH-24.2 {Tcl_FileObjCmd: mtime} {\r set old [file mtime gorp.file]\r after 2000\r set f [open gorp.file w]\r puts $f "More text"\r close $f\r set new [file mtime gorp.file]\r expr {($new > $old) && ($new <= ($old+5))}\r} {1}\rtest cmdAH-24.3 {Tcl_FileObjCmd: mtime} {\r catch {unset stat}\r file stat gorp.file stat\r list [expr {[file mtime gorp.file] == $stat(mtime)}] \\r [expr {[file atime gorp.file] == $stat(atime)}]\r} {1 1}\rtest cmdAH-24.4 {Tcl_FileObjCmd: mtime} {\r string tolower [list [catch {file mtime _bogus_} msg] $msg \\r $errorCode]\r} {1 {could not read "_bogus_": no such file or directory} {posix enoent {no such file or directory}}}\rtest cmdAH-24.5 {Tcl_FileObjCmd: mtime} {\r # Under Unix, use a file in /tmp to avoid clock skew due to NFS.\r # On other platforms, just use a file in the local directory.\r\r if {[string equal $tcl_platform(platform) "unix"]} {\r set name /tmp/tcl.test\r } else {\r set name tf\r }\r\r # Make sure that a new file's time is correct. 10 seconds variance \r # is allowed used due to slow networks or clock skew on a network drive.\r\r file delete -force $name\r close [open $name w]\r set a [expr abs([clock seconds]-[file mtime $name])<10]\r file delete $name\r set a\r} {1}\rtest cmdAH-24.7 {Tcl_FileObjCmd: mtime} {\r list [catch {file mtime $file notint} msg] $msg\r} {1 {expected integer but got "notint"}}\rtest cmdAH-24.8 {Tcl_FileObjCmd: mtime touch} {\r set mtime [file mtime $file]\r after 1100; # pause a sec to notice change in mtime\r set newmtime [clock seconds]\r expr {$newmtime==[file mtime $file $newmtime]}\r} 1\r\r\r# owned\r\rtest cmdAH-25.1 {Tcl_FileObjCmd: owned} {\r list [catch {file owned a b} msg] $msg\r} {1 {wrong # args: should be "file owned name"}}\rtest cmdAH-25.2 {Tcl_FileObjCmd: owned} {\r file owned gorp.file\r} 1\rtest cmdAH-25.3 {Tcl_FileObjCmd: owned} {unixOnly notRoot} {\r file owned /\r} 0\r\r# readlink\r\rtest cmdAH-26.1 {Tcl_FileObjCmd: readlink} {\r list [catch {file readlink a b} msg] $msg\r} {1 {wrong # args: should be "file readlink name"}}\rtest cmdAH-26.2 {Tcl_FileObjCmd: readlink} {unixOnly nonPortable} {\r file readlink link.file\r} gorp.file\rtest cmdAH-26.3 {Tcl_FileObjCmd: readlink errors} {unixOnly nonPortable} {\r list [catch {file readlink _bogus_} msg] [string tolower $msg] \\r [string tolower $errorCode]\r} {1 {could not readlink "_bogus_": no such file or directory} {posix enoent {no such file or directory}}}\rtest cmdAH-26.4 {Tcl_FileObjCmd: readlink errors} {macOnly nonPortable} {\r list [catch {file readlink _bogus_} msg] [string tolower $msg] \\r [string tolower $errorCode]\r} {1 {could not readlink "_bogus_": no such file or directory} {posix enoent {no such file or directory}}}\rtest cmdAH-26.5 {Tcl_FileObjCmd: readlink errors} {pcOnly nonPortable} {\r list [catch {file readlink _bogus_} msg] [string tolower $msg] \\r [string tolower $errorCode]\r} {1 {could not readlink "_bogus_": invalid argument} {posix einval {invalid argument}}}\r\r# size\r\rtest cmdAH-27.1 {Tcl_FileObjCmd: size} {\r list [catch {file size a b} msg] $msg\r} {1 {wrong # args: should be "file size name"}}\rtest cmdAH-27.2 {Tcl_FileObjCmd: size} {\r set oldsize [file size gorp.file]\r set f [open gorp.file a]\r fconfigure $f -translation lf -eofchar {}\r puts $f "More text"\r close $f\r expr {[file size gorp.file] - $oldsize}\r} {10}\rtest cmdAH-27.3 {Tcl_FileObjCmd: size} {\r string tolower [list [catch {file size _bogus_} msg] $msg \\r $errorCode]\r} {1 {could not read "_bogus_": no such file or directory} {posix enoent {no such file or directory}}}\r\r# stat\r\rcatch {testsetplatform $platform}\rmakeFile "Test string" gorp.file\rcatch {exec chmod 765 gorp.file}\r\rtest cmdAH-28.1 {Tcl_FileObjCmd: stat} {\r list [catch {file stat _bogus_} msg] $msg $errorCode\r} {1 {wrong # args: should be "file stat name varName"} NONE}\rtest cmdAH-28.2 {Tcl_FileObjCmd: stat} {\r list [catch {file stat _bogus_ a b} msg] $msg $errorCode\r} {1 {wrong # args: should be "file stat name varName"} NONE}\rtest cmdAH-28.3 {Tcl_FileObjCmd: stat} {\r catch {unset stat}\r file stat gorp.file stat\r lsort [array names stat]\r} {atime ctime dev gid ino mode mtime nlink size type uid}\rtest cmdAH-28.4 {Tcl_FileObjCmd: stat} {\r catch {unset stat}\r file stat gorp.file stat\r list $stat(nlink) $stat(size) $stat(type)\r} {1 12 file}\rtest cmdAH-28.5 {Tcl_FileObjCmd: stat} {unixOnly} {\r catch {unset stat}\r file stat gorp.file stat\r expr $stat(mode)&0777\r} {501}\rtest cmdAH-28.6 {Tcl_FileObjCmd: stat} {\r string tolower [list [catch {file stat _bogus_ stat} msg] \\r $msg $errorCode]\r} {1 {could not read "_bogus_": no such file or directory} {posix enoent {no such file or directory}}}\rtest cmdAH-28.7 {Tcl_FileObjCmd: stat} {\r catch {unset x}\r set x 44\r list [catch {file stat gorp.file x} msg] $msg $errorCode\r} {1 {can't set "x(dev)": variable isn't array} NONE}\rtest cmdAH-28.8 {Tcl_FileObjCmd: stat} {\r # Sign extension of purported unsigned short to int.\r\r close [open foo.test w]\r file stat foo.test stat\r set x [expr {$stat(mode) > 0}]\r file delete foo.test\r set x\r} 1\rtest cmdAH-28.9 {Tcl_FileObjCmd: stat} {pcOnly} {\r # stat of root directory was failing.\r # don't care about answer, just that test runs.\r\r # relative paths that resolve to root\r set old [pwd]\r cd c:/\r file stat c: stat \r file stat c:. stat\r file stat . stat\r cd $old\r\r file stat / stat\r file stat c:/ stat\r file stat c:/. stat\r} {}\rtest cmdAH-28.10 {Tcl_FileObjCmd: stat} {pcOnly nonPortable} {\r # stat of root directory was failing.\r # don't care about answer, just that test runs.\r\r file stat //pop/$env(USERNAME) stat\r file stat //pop/$env(USERNAME)/ stat\r file stat //pop/$env(USERNAME)/. stat\r} {} \rtest cmdAH-28.11 {Tcl_FileObjCmd: stat} {pcOnly nonPortable} {\r # stat of network directory was returning id of current local drive.\r\r set old [pwd]\r cd c:/\r\r file stat //pop/$env(USERNAME) stat\r cd $old\r expr {$stat(dev) == 2}\r} 0\rtest cmdAH-28.12 {Tcl_FileObjCmd: stat} {\r # stat(mode) with S_IFREG flag was returned as a negative number\r # if mode_t was a short instead of an unsigned short.\r\r close [open foo.test w]\r file stat foo.test stat\r file delete foo.test\r expr {$stat(mode) > 0}\r} 1\rcatch {unset stat}\r\r# type\r\rfile delete link.file\r\rtest cmdAH-29.1 {Tcl_FileObjCmd: type} {\r list [catch {file size a b} msg] $msg\r} {1 {wrong # args: should be "file size name"}}\rtest cmdAH-29.2 {Tcl_FileObjCmd: type} {\r file type dir.file\r} directory\rtest cmdAH-29.3 {Tcl_FileObjCmd: type} {\r file type gorp.file\r} file\rtest cmdAH-29.4 {Tcl_FileObjCmd: type} {unixOnly nonPortable} {\r exec ln -s a/b/c link.file\r set result [file type link.file]\r file delete link.file\r set result\r} link\rtest cmdAH-29.5 {Tcl_FileObjCmd: type} {\r string tolower [list [catch {file type _bogus_} msg] $msg $errorCode]\r} {1 {could not read "_bogus_": no such file or directory} {posix enoent {no such file or directory}}}\r\r# Error conditions\r\rtest cmdAH-30.1 {Tcl_FileObjCmd: error conditions} {\r list [catch {file gorp x} msg] $msg\r} {1 {bad option "gorp": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}}\rtest cmdAH-30.2 {Tcl_FileObjCmd: error conditions} {\r list [catch {file ex x} msg] $msg\r} {1 {ambiguous option "ex": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}}\rtest cmdAH-30.3 {Tcl_FileObjCmd: error conditions} {\r list [catch {file is x} msg] $msg\r} {1 {ambiguous option "is": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}}\rtest cmdAH-30.4 {Tcl_FileObjCmd: error conditions} {\r list [catch {file z x} msg] $msg\r} {1 {bad option "z": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}}\rtest cmdAH-30.5 {Tcl_FileObjCmd: error conditions} {\r list [catch {file read x} msg] $msg\r} {1 {ambiguous option "read": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}}\rtest cmdAH-30.6 {Tcl_FileObjCmd: error conditions} {\r list [catch {file s x} msg] $msg\r} {1 {ambiguous option "s": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}}\rtest cmdAH-30.7 {Tcl_FileObjCmd: error conditions} {\r list [catch {file t x} msg] $msg\r} {1 {ambiguous option "t": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}}\rtest cmdAH-30.8 {Tcl_FileObjCmd: error conditions} {\r list [catch {file dirname ~woohgy} msg] $msg\r} {1 {user "woohgy" doesn't exist}}\r\r# channels\r# In testing 'file channels', we need to make sure that a channel\r# created in one interp isn't visible in another.\r\rinterp create simpleInterp\rinterp create -safe safeInterp\rinterp c\rsafeInterp expose file file\r\rtest cmdAH-31.1 {Tcl_FileObjCmd: channels, too many args} {\r list [catch {file channels a b} msg] $msg\r} {1 {wrong # args: should be "file channels ?pattern?"}}\rtest cmdAH-31.2 {Tcl_FileObjCmd: channels, too many args} {\r # Normal interps start out with only the standard channels\r lsort [simpleInterp eval [list file chan]]\r} [lsort {stderr stdout stdin}]\rtest cmdAH-31.3 {Tcl_FileObjCmd: channels, globbing} {\r string equal [file channels] [file channels *]\r} {1}\rtest cmdAH-31.4 {Tcl_FileObjCmd: channels, globbing} {\r lsort [file channels std*]\r} [lsort {stdout stderr stdin}]\r\rset newFileId [open gorp.file w]\r\rtest cmdAH-31.5 {Tcl_FileObjCmd: channels} {\r set res [file channels $newFileId]\r string equal $newFileId $res\r} {1}\rtest cmdAH-31.6 {Tcl_FileObjCmd: channels in other interp} {\r # Safe interps start out with no channels\r safeInterp eval [list file channels]\r} {}\rtest cmdAH-31.7 {Tcl_FileObjCmd: channels in other interp} {\r list [catch {safeInterp eval [list puts $newFileId "hello"]} msg] $msg\r} [list 1 "can not find channel named \"$newFileId\""]\r\rinterp share {} $newFileId safeInterp\rinterp share {} stdout safeInterp\r\rtest cmdAH-31.8 {Tcl_FileObjCmd: channels in other interp} {\r # $newFileId should now be visible in both interps\r list [file channels $newFileId] \\r [safeInterp eval [list file channels $newFileId]]\r} [list $newFileId $newFileId]\rtest cmdAH-31.9 {Tcl_FileObjCmd: channels in other interp} {\r lsort [safeInterp eval [list file channels]]\r} [lsort [list stdout $newFileId]]\rtest cmdAH-31.10 {Tcl_FileObjCmd: channels in other interp} {\r # we can now write to $newFileId from slave\r safeInterp eval [list puts $newFileId "hello"]\r} {}\r\rinterp transfer {} $newFileId safeInterp\r\rtest cmdAH-31.11 {Tcl_FileObjCmd: channels in other interp} {\r # $newFileId should now be visible only in safeInterp\r list [file channels $newFileId] \\r [safeInterp eval [list file channels $newFileId]]\r} [list {} $newFileId]\rtest cmdAH-31.12 {Tcl_FileObjCmd: channels in other interp} {\r lsort [safeInterp eval [list file channels]]\r} [lsort [list stdout $newFileId]]\rtest cmdAH-31.13 {Tcl_FileObjCmd: channels in other interp} {\r safeInterp eval [list close $newFileId]\r safeInterp eval [list file channels]\r} {stdout}\r\r# This shouldn't work, but just in case a test above failed...\rcatch {close $newFileId}\r\rinterp delete safeInterp\rinterp delete simpleInterp\r\r# cleanup\rcatch {testsetplatform $platform}\rcatch {unset platform}\r\r# Tcl_ForObjCmd is tested in for.test\r\rcatch {exec chmod 777 dir.file}\rfile delete -force dir.file\rfile delete gorp.file\rfile delete link.file\r\rcd $cmdAHwd\r\r::tcltest::cleanupTests\rreturn\r\r\r\r\r\r\r\r\r\r\r\r\r\r
\ No newline at end of file
--- /dev/null
+# This file contains a collection of tests for tclEncoding.c\r# Sourcing this file into Tcl runs the tests and generates output for\r# errors. No output means no errors were found.\r#\r# Copyright (c) 1997 Sun Microsystems, Inc.\r# Copyright (c) 1998-1999 by Scriptics Corporation.\r#\r# See the file "license.terms" for information on usage and redistribution\r# of this file, and for a DISCLAIMER OF ALL WARRANTIES.\r#\r# RCS: @(#) $Id$\r\rif {[lsearch [namespace children] ::tcltest] == -1} {\r package require tcltest\r namespace import -force ::tcltest::*\r}\r\rproc toutf {args} {\r global x\r lappend x "toutf $args"\r}\rproc fromutf {args} {\r global x\r lappend x "fromutf $args"\r}\r\r# Some tests require the testencoding command\r\rset ::tcltest::testConstraints(testencoding) \\r [expr {[info commands testencoding] != {}}]\r\r\r# TclInitEncodingSubsystem is tested by the rest of this file\r# TclFinalizeEncodingSubsystem is not currently tested\r\rtest encoding-1.1 {Tcl_GetEncoding: system encoding} {testencoding} {\r testencoding create foo toutf fromutf\r set old [encoding system]\r encoding system foo\r set x {}\r encoding convertto abcd\r encoding system $old\r testencoding delete foo\r set x\r} {{fromutf }}\rtest encoding-1.2 {Tcl_GetEncoding: existing encoding} {testencoding} {\r testencoding create foo toutf fromutf\r set x {}\r encoding convertto foo abcd\r testencoding delete foo\r set x\r} {{fromutf }}\rtest encoding-1.3 {Tcl_GetEncoding: load encoding} {\r list [encoding convertto jis0208 \u4e4e] \\r [encoding convertfrom jis0208 8C]\r} "8C \u4e4e"\r\rtest encoding-2.1 {Tcl_FreeEncoding: refcount == 0} {\r encoding convertto jis0208 \u4e4e\r} {8C}\rtest encoding-2.2 {Tcl_FreeEncoding: refcount != 0} {testencoding} {\r set system [encoding system]\r set path [testencoding path]\r encoding system shiftjis ;# incr ref count\r testencoding path [list [pwd]]\r set x [encoding convertto shiftjis \u4e4e] ;# old one found \r encoding system identity\r lappend x [catch {encoding convertto shiftjis \u4e4e} msg] $msg\r encoding system identity\r testencoding path $path\r encoding system $system\r set x\r} "\u008c\u00c1 1 {unknown encoding \"shiftjis\"}"\r\rtest encoding-3.1 {Tcl_GetEncodingName, NULL} {\r set old [encoding system]\r encoding system shiftjis\r set x [encoding system]\r encoding system $old\r set x\r} {shiftjis}\rtest encoding-3.2 {Tcl_GetEncodingName, non-null} {\r set old [fconfigure stdout -encoding]\r fconfigure stdout -encoding jis0208\r set x [fconfigure stdout -encoding]\r fconfigure stdout -encoding $old\r set x\r} {jis0208}\r\rtest encoding-4.1 {Tcl_GetEncodingNames} {testencoding} {\r file mkdir tmp/encoding\r close [open tmp/encoding/junk.enc w]\r close [open tmp/encoding/junk2.enc w]\r cd tmp\r set path [testencoding path]\r testencoding path {}\r catch {unset encodings}\r catch {unset x}\r foreach encoding [encoding names] {\r set encodings($encoding) 1\r }\r testencoding path [list [pwd]]\r foreach encoding [encoding names] {\r if {![info exists encodings($encoding)]} {\r lappend x $encoding\r }\r }\r testencoding path $path\r cd ..\r file delete -force tmp\r lsort $x\r} {junk junk2}\r\rtest encoding-5.1 {Tcl_SetSystemEncoding} {\r set old [encoding system]\r encoding system jis0208\r set x [encoding convertto \u4e4e]\r encoding system identity\r encoding system $old\r set x\r} {8C}\rtest encoding-5.2 {Tcl_SetSystemEncoding: test ref count} {\r set old [encoding system]\r encoding system $old\r string compare $old [encoding system]\r} {0}\r\rtest encoding-6.1 {Tcl_CreateEncoding: new} {testencoding} {\r testencoding create foo {toutf 1} {fromutf 2}\r set x {}\r encoding convertfrom foo abcd\r encoding convertto foo abcd\r testencoding delete foo\r set x\r} {{toutf 1} {fromutf 2}}\rtest encoding-6.2 {Tcl_CreateEncoding: replace encoding} {testencoding} {\r testencoding create foo {toutf a} {fromutf b}\r set x {}\r encoding convertfrom foo abcd\r encoding convertto foo abcd\r testencoding delete foo\r set x\r} {{toutf a} {fromutf b}}\r\rtest encoding-7.1 {Tcl_ExternalToUtfDString: small buffer} {\r encoding convertfrom jis0208 8c8c8c8c\r} "\u543e\u543e\u543e\u543e"\rtest encoding-7.2 {Tcl_UtfToExternalDString: big buffer} {\r set a 8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C\r append a $a\r append a $a\r append a $a\r append a $a\r set x [encoding convertfrom jis0208 $a]\r list [string length $x] [string index $x 0]\r} "512 \u4e4e"\r\rtest encoding-8.1 {Tcl_ExternalToUtf} {fsIsWritable} {\r set f [open dummy w]\r fconfigure $f -translation binary -encoding iso8859-1\r puts -nonewline $f "ab\x8c\xc1g"\r close $f\r set f [open dummy r]\r fconfigure $f -translation binary -encoding shiftjis \r set x [read $f]\r close $f\r file delete dummy\r set x\r} "ab\u4e4eg"\r\rtest encoding-9.1 {Tcl_UtfToExternalDString: small buffer} {\r encoding convertto jis0208 "\u543e\u543e\u543e\u543e"\r} {8c8c8c8c}\rtest encoding-9.2 {Tcl_UtfToExternalDString: big buffer} {\r set a \u4e4e\u4e4e\u4e4e\u4e4e\u4e4e\u4e4e\u4e4e\u4e4e\r append a $a\r append a $a\r append a $a\r append a $a\r append a $a\r append a $a\r set x [encoding convertto jis0208 $a]\r list [string length $x] [string range $x 0 1]\r} "1024 8C"\r\rtest encoding-10.1 {Tcl_UtfToExternal} {fsIsWritable} {\r set f [open dummy w]\r fconfigure $f -translation binary -encoding shiftjis\r puts -nonewline $f "ab\u4e4eg"\r close $f\r set f [open dummy r]\r fconfigure $f -translation binary -encoding iso8859-1\r set x [read $f]\r close $f\r file delete dummy\r set x\r} "ab\x8c\xc1g"\r\rtest encoding-11.1 {LoadEncodingFile: unknown encoding} {testencoding} {\r set system [encoding system]\r set path [testencoding path]\r encoding system iso8859-1\r testencoding path {}\r set x [list [catch {encoding convertto jis0208 \u4e4e} msg] $msg]\r testencoding path $path\r encoding system $system\r lappend x [encoding convertto jis0208 \u4e4e]\r} {1 {unknown encoding "jis0208"} 8C}\rtest encoding-11.2 {LoadEncodingFile: single-byte} {\r encoding convertfrom jis0201 \xa1\r} "\uff61"\rtest encoding-11.3 {LoadEncodingFile: double-byte} {\r encoding convertfrom jis0208 8C\r} "\u4e4e"\rtest encoding-11.4 {LoadEncodingFile: multi-byte} {\r encoding convertfrom shiftjis \x8c\xc1\r} "\u4e4e"\rtest encoding-11.5 {LoadEncodingFile: escape file} {\r encoding convertto iso2022 \u4e4e\r} "\x1b(B\x1b$@8C"\rtest encoding-11.6 {LoadEncodingFile: invalid file} {testencoding} {\r set system [encoding system]\r set path [testencoding path]\r encoding system identity\r testencoding path tmp\r file mkdir tmp/encoding\r set f [open tmp/encoding/splat.enc w]\r fconfigure $f -translation binary \r puts $f "abcdefghijklmnop"\r close $f\r set x [list [catch {encoding convertto splat \u4e4e} msg] $msg]\r file delete -force tmp\r catch {file delete encoding}\r testencoding path $path\r encoding system $system\r set x\r} {1 {invalid encoding file "splat"}}\r\r# OpenEncodingFile is fully tested by the rest of the tests in this file.\r\rtest encoding-12.1 {LoadTableEncoding: normal encoding} {\r set x [encoding convertto iso8859-3 \u120]\r append x [encoding convertto iso8859-3 \ud5]\r append x [encoding convertfrom iso8859-3 \xd5]\r} "\xd5?\u120"\rtest encoding-12.2 {LoadTableEncoding: single-byte encoding} {\r set x [encoding convertto iso8859-3 ab\u0120g] \r append x [encoding convertfrom iso8859-3 ab\xd5g]\r} "ab\xd5gab\u120g"\rtest encoding-12.3 {LoadTableEncoding: multi-byte encoding} {\r set x [encoding convertto shiftjis ab\u4e4eg] \r append x [encoding convertfrom shiftjis ab\x8c\xc1g]\r} "ab\x8c\xc1gab\u4e4eg"\rtest encoding-12.4 {LoadTableEncoding: double-byte encoding} {\r set x [encoding convertto jis0208 \u4e4e\u3b1]\r append x [encoding convertfrom jis0208 8C&A]\r} "8C&A\u4e4e\u3b1"\rtest encoding-12.5 {LoadTableEncoding: symbol encoding} {\r set x [encoding convertto symbol \u3b3]\r append x [encoding convertto symbol \u67]\r append x [encoding convertfrom symbol \x67]\r} "\x67\x67\u3b3"\r\rtest encoding-13.1 {LoadEscapeTable} {\r set x [encoding convertto iso2022 ab\u4e4e\u68d9g]\r} "\x1b(Bab\x1b$@8C\x1b$\(DD%\x1b(Bg"\r\rtest encoding-14.1 {BinaryProc} {\r encoding convertto identity \x12\x34\x56\xff\x69\r} "\x12\x34\x56\xc3\xbf\x69"\r\rtest encoding-15.1 {UtfToUtfProc} {\r encoding convertto utf-8 \xa3\r} "\xc2\xa3"\r\rtest encoding-16.1 {UnicodeToUtfProc} {\r encoding convertfrom unicode NN\r} "\u4e4e"\r\rtest encoding-17.1 {UtfToUnicodeProc} {\r} {}\r\rtest encoding-18.1 {TableToUtfProc} {\r} {}\r\rtest encoding-19.1 {TableFromUtfProc} {\r} {}\r\rtest encoding-20.1 {TableFreefProc} {\r} {}\r\rtest encoding-21.1 {EscapeToUtfProc} {\r} {}\r\rtest encoding-22.1 {EscapeFromUtfProc} {\r} {}\r\r# EscapeFreeProc, GetTableEncoding, unilen\r# are fully tested by the rest of this file\r\r# cleanup\r::tcltest::cleanupTests\rreturn\r\r\r\r\r\r\r\r\r\r\r\r\r\r\r
\ No newline at end of file
--- /dev/null
+# This file tests the tclFCmd.c file.\r#\r# This file contains a collection of tests for one or more of the Tcl\r# built-in commands. Sourcing this file into Tcl runs the tests and\r# generates output for errors. No output means no errors were found.\r#\r# Copyright (c) 1996-1997 Sun Microsystems, Inc.\r# Copyright (c) 1999 by Scriptics Corporation.\r#\r# See the file "license.terms" for information on usage and redistribution\r# of this file, and for a DISCLAIMER OF ALL WARRANTIES.\r#\r# RCS: @(#) $Id$\r#\r\rif {[lsearch [namespace children] ::tcltest] == -1} {\r package require tcltest\r namespace import -force ::tcltest::*\r}\r\rtcltest::testConstraint testsetplatform [string equal testsetplatform [info commands testsetplatform]]\rtcltest::testConstraint testchmod [string equal testchmod [info commands testchmod]]\r\r# Several tests require need to match results against the unix username\rset user {}\rif {$tcl_platform(platform) == "unix"} {\r catch {set user [exec whoami]}\r if {$user == ""} {\r catch {regexp {^[^(]*\(([^)]*)\)} [exec id] dummy user}\r }\r if {$user == ""} {\r set user "root"\r }\r}\r\rproc createfile {file {string a}} {\r set f [open $file w]\r puts -nonewline $f $string\r close $f\r return $string\r}\r\r# \r# checkcontent --\r#\r# Ensures that file "file" contains only the string "matchString"\r# returns 0 if the file does not exist, or has a different content\r#\rproc checkcontent {file matchString} {\r if {[catch {\r set f [open $file]\r set fileString [read $f]\r close $f \r }]} {\r return 0\r }\r return [string match $matchString $fileString]\r}\r\rproc openup {path} {\r testchmod 777 $path\r if {[file isdirectory $path]} {\r catch {\r foreach p [glob -directory $path *] {\r openup $p\r }\r }\r }\r}\r\rproc cleanup {args} {\r foreach p [concat [list .] $args] {\r set x ""\r catch {\r set x [glob -directory $p tf* td*]\r }\r foreach file $x {\r if {[catch {file delete -force -- $file}]} {\r catch {openup $file}\r catch {file delete -force -- $file}\r }\r }\r }\r}\r\rproc contents {file} {\r set f [open $file r]\r set r [read $f]\r close $f\r set r\r}\r\rset ::tcltest::testConstraints(fileSharing) 0\rset ::tcltest::testConstraints(notFileSharing) 1\r\rif {$tcl_platform(platform) == "macintosh"} {\r catch {file delete -force foo.dir}\r file mkdir foo.dir\r if {[catch {file attributes foo.dir -readonly 1}] == 0} {\r set ::tcltest::testConstraints(fileSharing) 1\r set ::tcltest::testConstraints(notFileSharing) 0\r }\r file delete -force foo.dir\r}\r\rset ::tcltest::testConstraints(xdev) 0\r\rif {$tcl_platform(platform) == "unix"} {\r if {[catch {set m1 [exec df .]; set m2 [exec df /tmp]}] == 0} {\r set m1 [string range $m1 0 [expr [string first " " $m1]-1]]\r set m2 [string range $m2 0 [expr [string first " " $m2]-1]]\r if {$m1 != "" && $m2 != "" && $m1 != $m2 && [file exists $m1] && [file exists $m2]} {\r set ::tcltest::testConstraints(xdev) 1\r }\r }\r}\r\rset root [lindex [file split [pwd]] 0]\r\r# A really long file name\r# length of long is 1216 chars, which should be greater than any static\r# buffer or allowable filename.\r\rset long "abcdefghihjllmnopqrstuvwxyz01234567890"\rappend long $long\rappend long $long\rappend long $long\rappend long $long\rappend long $long\r\rtest fCmd-1.1 {TclFileRenameCmd} {notRoot fsIsWritable} {\r cleanup\r createfile tf1\r file rename tf1 tf2\r glob tf*\r} {tf2}\r\rtest fCmd-2.1 {TclFileCopyCmd} {notRoot fsIsWritable} {\r cleanup\r createfile tf1\r file copy tf1 tf2\r lsort [glob tf*]\r} {tf1 tf2}\r\rtest fCmd-3.1 {FileCopyRename: FileForceOption fails} {notRoot} {\r list [catch {file rename -xyz} msg] $msg\r} {1 {bad option "-xyz": should be -force or --}}\rtest fCmd-3.2 {FileCopyRename: not enough args} {notRoot} {\r list [catch {file rename xyz} msg] $msg\r} {1 {wrong # args: should be "file rename ?options? source ?source ...? target"}}\rtest fCmd-3.3 {FileCopyRename: Tcl_TranslateFileName fails} {notRoot} {\r list [catch {file rename xyz ~_totally_bogus_user} msg] $msg\r} {1 {user "_totally_bogus_user" doesn't exist}}\rtest fCmd-3.4 {FileCopyRename: Tcl_TranslateFileName passes} {notRoot} {\r cleanup\r list [catch {file copy tf1 ~} msg] $msg\r} {1 {error copying "tf1": no such file or directory}}\rtest fCmd-3.5 {FileCopyRename: target doesn't exist: stat(target) != 0} {notRoot} {\r cleanup\r list [catch {file rename tf1 tf2 tf3} msg] $msg\r} {1 {error renaming: target "tf3" is not a directory}}\rtest fCmd-3.6 {FileCopyRename: target tf3 is not a dir: !S_ISDIR(target)} \\r {notRoot fsIsWritable} {\r cleanup\r createfile tf3\r list [catch {file rename tf1 tf2 tf3} msg] $msg\r} {1 {error renaming: target "tf3" is not a directory}}\rtest fCmd-3.7 {FileCopyRename: target exists & is directory} \\r {notRoot fsIsWritable} {\r cleanup\r file mkdir td1\r createfile tf1 tf1\r file rename tf1 td1\r contents [file join td1 tf1]\r} {tf1}\rtest fCmd-3.8 {FileCopyRename: too many arguments: argc - i > 2} {notRoot} {\r cleanup\r list [catch {file rename tf1 tf2 tf3} msg] $msg\r} {1 {error renaming: target "tf3" is not a directory}}\rtest fCmd-3.9 {FileCopyRename: too many arguments: argc - i > 2} {notRoot} {\r cleanup\r list [catch {file copy -force -- tf1 tf2 tf3} msg] $msg\r} {1 {error copying: target "tf3" is not a directory}}\rtest fCmd-3.10 {FileCopyRename: just 2 arguments} {notRoot fsIsWritable} {\r cleanup\r createfile tf1 tf1\r file rename tf1 tf2\r contents tf2\r} {tf1}\rtest fCmd-3.11 {FileCopyRename: just 2 arguments} {notRoot fsIsWritable} {\r cleanup\r createfile tf1 tf1\r file rename -force -force -- tf1 tf2\r contents tf2\r} {tf1}\rtest fCmd-3.12 {FileCopyRename: move each source: 1 source} \\r {notRoot fsIsWritable} {\r cleanup\r createfile tf1 tf1\r file mkdir td1\r file rename tf1 td1\r contents [file join td1 tf1]\r} {tf1}\rtest fCmd-3.13 {FileCopyRename: move each source: multiple sources} \\r {notRoot fsIsWritable} {\r cleanup\r createfile tf1 tf1\r createfile tf2 tf2\r createfile tf3 tf3\r createfile tf4 tf4\r file mkdir td1\r file rename tf1 tf2 tf3 tf4 td1\r list [contents [file join td1 tf1]] [contents [file join td1 tf2]] \\r [contents [file join td1 tf3]] [contents [file join td1 tf4]]\r} {tf1 tf2 tf3 tf4}\rtest fCmd-3.14 {FileCopyRename: FileBasename fails} {notRoot fsIsWritable} {\r cleanup\r file mkdir td1\r list [catch {file rename ~_totally_bogus_user td1} msg] $msg\r} {1 {user "_totally_bogus_user" doesn't exist}}\rtest fCmd-3.15 {FileCopyRename: source[0] == '\0'} \\r {notRoot unixOrPc fsIsWritable} {\r cleanup\r file mkdir td1\r list [catch {file rename / td1} msg] $msg\r} {1 {error renaming "/" to "td1": file already exists}}\rtest fCmd-3.16 {FileCopyRename: break on first error} {notRoot fsIsWritable} {\r cleanup\r createfile tf1 \r createfile tf2 \r createfile tf3 \r createfile tf4 \r file mkdir td1\r createfile [file join td1 tf3]\r list [catch {file rename tf1 tf2 tf3 tf4 td1} msg] $msg\r} [subst {1 {error renaming "tf3" to "[file join td1 tf3]": file already exists}}]\r\rtest fCmd-4.1 {TclFileMakeDirsCmd: make each dir: 1 dir} \\r {notRoot fsIsWritable} {\r cleanup\r file mkdir td1\r glob td*\r} {td1}\rtest fCmd-4.2 {TclFileMakeDirsCmd: make each dir: multiple dirs} \\r {notRoot fsIsWritable} {\r cleanup\r file mkdir td1 td2 td3\r lsort [glob td*]\r} {td1 td2 td3}\rtest fCmd-4.3 {TclFileMakeDirsCmd: stops on first error} \\r {notRoot fsIsWritable} {\r cleanup\r createfile tf1\r catch {file mkdir td1 td2 tf1 td3 td4}\r glob td1 td2 tf1 td3 td4\r} {td1 td2 tf1}\rtest fCmd-4.4 {TclFileMakeDirsCmd: Tcl_TranslateFileName fails} {notRoot} {\r cleanup\r list [catch {file mkdir ~_totally_bogus_user} msg] $msg\r} {1 {user "_totally_bogus_user" doesn't exist}}\rtest fCmd-4.5 {TclFileMakeDirsCmd: Tcl_SplitPath returns 0: *name == '\0'} \\r {notRoot} {\r cleanup\r list [catch {file mkdir ""} msg] $msg\r} {1 {can't create directory "": no such file or directory}}\rtest fCmd-4.6 {TclFileMakeDirsCmd: one level deep} {notRoot} {\r cleanup\r file mkdir td1\r glob td1\r} {td1}\rtest fCmd-4.7 {TclFileMakeDirsCmd: multi levels deep} {notRoot} {\r cleanup\r file mkdir [file join td1 td2 td3 td4]\r glob td1 [file join td1 td2]\r} "td1 [file join td1 td2]"\rtest fCmd-4.8 {TclFileMakeDirsCmd: already exist: lstat(target) == 0} {notRoot} {\r cleanup\r file mkdir td1\r set x [file exist td1]\r file mkdir td1\r list $x [file exist td1]\r} {1 1}\rtest fCmd-4.9 {TclFileMakeDirsCmd: exists, not dir} {notRoot} {\r cleanup\r createfile tf1\r list [catch {file mkdir tf1} msg] $msg\r} [subst {1 {can't create directory "[file join tf1]": file already exists}}]\rtest fCmd-4.10 {TclFileMakeDirsCmd: exists, is dir} {notRoot} {\r cleanup\r file mkdir td1\r set x [file exist td1]\r file mkdir td1\r list $x [file exist td1]\r} {1 1}\rtest fCmd-4.11 {TclFileMakeDirsCmd: doesn't exist: errno != ENOENT} \\r {unixOnly notRoot testchmod} {\r cleanup\r file mkdir td1/td2/td3\r testchmod 000 td1/td2\r set msg [list [catch {file mkdir td1/td2/td3/td4} msg] $msg]\r testchmod 755 td1/td2\r set msg\r} {1 {can't create directory "td1/td2/td3": permission denied}}\rtest fCmd-4.12 {TclFileMakeDirsCmd: doesn't exist: errno != ENOENT} {macOnly} {\r cleanup\r list [catch {file mkdir nonexistentvolume:} msg] $msg\r} {1 {can't create directory "nonexistentvolume:": invalid argument}}\rtest fCmd-4.13 {TclFileMakeDirsCmd: doesn't exist: errno == ENOENT} {notRoot} {\r cleanup\r set x [file exist td1]\r file mkdir td1\r list $x [file exist td1]\r} {0 1}\rtest fCmd-4.14 {TclFileMakeDirsCmd: TclpCreateDirectory fails} \\r {unixOnly notRoot} {\r cleanup\r file delete -force foo\r file mkdir foo\r file attr foo -perm 040000\r set result [list [catch {file mkdir foo/tf1} msg] $msg]\r file delete -force foo\r set result\r} {1 {can't create directory "foo/tf1": permission denied}}\rtest fCmd-4.15 {TclFileMakeDirsCmd: TclpCreateDirectory fails} {macOnly} {\r list [catch {file mkdir ${root}:} msg] $msg\r} [subst {1 {can't create directory "${root}:": no such file or directory}}]\rtest fCmd-4.16 {TclFileMakeDirsCmd: TclpCreateDirectory succeeds} {notRoot} {\r cleanup\r file mkdir tf1\r file exists tf1\r} {1}\r\rtest fCmd-5.1 {TclFileDeleteCmd: FileForceOption fails} {notRoot} {\r list [catch {file delete -xyz} msg] $msg\r} {1 {bad option "-xyz": should be -force or --}}\rtest fCmd-5.2 {TclFileDeleteCmd: not enough args} {notRoot} {\r list [catch {file delete -force -force} msg] $msg\r} {1 {wrong # args: should be "file delete ?options? file ?file ...?"}}\rtest fCmd-5.3 {TclFileDeleteCmd: 1 file} {notRoot} {\r cleanup\r createfile tf1\r createfile tf2\r file mkdir td1\r file delete tf2\r glob tf* td*\r} {tf1 td1}\rtest fCmd-5.4 {TclFileDeleteCmd: multiple files} {notRoot} {\r cleanup\r createfile tf1\r createfile tf2\r file mkdir td1\r set x [list [file exist tf1] [file exist tf2] [file exist td1]]\r file delete tf1 td1 tf2\r lappend x [file exist tf1] [file exist tf2] [file exist tf3]\r} {1 1 1 0 0 0}\rtest fCmd-5.5 {TclFileDeleteCmd: stop at first error} {notRoot unixOrPc} {\r cleanup\r createfile tf1\r createfile tf2\r file mkdir td1\r catch {file delete tf1 td1 $root tf2}\r list [file exist tf1] [file exist tf2] [file exist td1]\r} {0 1 0}\rtest fCmd-5.6 {TclFileDeleteCmd: Tcl_TranslateFileName fails} {notRoot} {\r list [catch {file delete ~_totally_bogus_user} msg] $msg\r} {1 {user "_totally_bogus_user" doesn't exist}}\rtest fCmd-5.7 {TclFileDeleteCmd: Tcl_TranslateFileName succeeds} {notRoot} {\r catch {file delete ~/tf1}\r createfile ~/tf1\r file delete ~/tf1\r} {}\rtest fCmd-5.8 {TclFileDeleteCmd: file doesn't exist: lstat(name) != 0} {notRoot} {\r cleanup\r set x [file exist tf1]\r file delete tf1\r list $x [file exist tf1]\r} {0 0} \rtest fCmd-5.9 {TclFileDeleteCmd: is directory} {notRoot} {\r cleanup\r file mkdir td1\r file delete td1\r file exist td1\r} {0}\rtest fCmd-5.10 {TclFileDeleteCmd: TclpRemoveDirectory fails} {notRoot} {\r cleanup\r file mkdir td1/td2\r list [catch {file delete td1} msg] $msg\r} {1 {error deleting "td1": directory not empty}}\r\rtest fCmd-6.1 {CopyRenameOneFile: bad source} {notRoot} {\r # can't test this, because it's caught by FileCopyRename\r} {}\rtest fCmd-6.2 {CopyRenameOneFile: bad target} {notRoot} {\r # can't test this, because it's caught by FileCopyRename\r} {}\rtest fCmd-6.3 {CopyRenameOneFile: lstat(source) != 0} {notRoot} {\r cleanup\r list [catch {file rename tf1 tf2} msg] $msg\r} {1 {error renaming "tf1": no such file or directory}}\rtest fCmd-6.4 {CopyRenameOneFile: lstat(source) == 0} {notRoot} {\r cleanup\r createfile tf1\r file rename tf1 tf2\r glob tf*\r} {tf2}\rtest fCmd-6.5 {CopyRenameOneFile: lstat(target) != 0} {notRoot} {\r cleanup\r createfile tf1\r file rename tf1 tf2\r glob tf*\r} {tf2}\rtest fCmd-6.6 {CopyRenameOneFile: errno != ENOENT} {unixOnly notRoot testchmod} {\r cleanup\r file mkdir td1\r testchmod 000 td1\r createfile tf1\r set msg [list [catch {file rename tf1 td1} msg] $msg]\r testchmod 755 td1\r set msg\r} {1 {error renaming "tf1" to "td1/tf1": permission denied}}\rtest fCmd-6.7 {CopyRenameOneFile: errno != ENOENT} {95} {\r cleanup\r createfile tf1\r list [catch {file rename tf1 $long} msg] $msg\r} [subst {1 {error renaming "tf1" to "$long": file name too long}}]\rtest fCmd-6.8 {CopyRenameOneFile: errno != ENOENT} {macOnly} {\r cleanup\r createfile tf1\r list [catch {file rename tf1 $long} msg] $msg\r} [subst {1 {error renaming "tf1" to "$long": file name too long}}]\rtest fCmd-6.9 {CopyRenameOneFile: errno == ENOENT} {unixOnly notRoot} {\r cleanup\r createfile tf1\r file rename tf1 tf2\r glob tf*\r} {tf2}\rtest fCmd-6.10 {CopyRenameOneFile: lstat(target) == 0} {notRoot} {\r cleanup\r createfile tf1\r createfile tf2\r list [catch {file rename tf1 tf2} msg] $msg\r} {1 {error renaming "tf1" to "tf2": file already exists}}\rtest fCmd-6.11 {CopyRenameOneFile: force == 0} {notRoot} {\r cleanup\r createfile tf1\r createfile tf2\r list [catch {file rename tf1 tf2} msg] $msg\r} {1 {error renaming "tf1" to "tf2": file already exists}}\rtest fCmd-6.12 {CopyRenameOneFile: force != 0} {notRoot} {\r cleanup\r createfile tf1\r createfile tf2\r file rename -force tf1 tf2\r glob tf*\r} {tf2}\rtest fCmd-6.13 {CopyRenameOneFile: source is dir, target is file} {notRoot} {\r cleanup\r file mkdir td1\r file mkdir td2\r createfile [file join td2 td1]\r list [catch {file rename -force td1 td2} msg] $msg\r} [subst {1 {can't overwrite file "[file join td2 td1]" with directory "td1"}}]\rtest fCmd-6.14 {CopyRenameOneFile: source is file, target is dir} {notRoot} {\r cleanup\r createfile tf1\r file mkdir [file join td1 tf1]\r list [catch {file rename -force tf1 td1} msg] $msg\r} [subst {1 {can't overwrite directory "[file join td1 tf1]" with file "tf1"}}]\rtest fCmd-6.15 {CopyRenameOneFile: TclpRenameFile succeeds} {notRoot} {\r cleanup\r file mkdir [file join td1 td2]\r file mkdir td2\r createfile [file join td2 tf1]\r file rename -force td2 td1\r file exists [file join td1 td2 tf1]\r} {1}\rtest fCmd-6.16 {CopyRenameOneFile: TclpCopyRenameOneFile fails} {notRoot} {\r cleanup\r file mkdir [file join td1 td2]\r createfile [file join td1 td2 tf1]\r file mkdir td2\r list [catch {file rename -force td2 td1} msg] $msg\r} [subst {1 {error renaming "td2" to "[file join td1 td2]": file already exists}}]\r\rtest fCmd-6.17 {CopyRenameOneFile: errno == EINVAL} {notRoot} {\r cleanup\r list [catch {file rename -force $root tf1} msg] $msg\r} [subst {1 {error renaming "$root" to "tf1": trying to rename a volume or move a directory into itself}}]\rtest fCmd-6.18 {CopyRenameOneFile: errno != EXDEV} {notRoot} {\r cleanup\r file mkdir [file join td1 td2]\r createfile [file join td1 td2 tf1]\r file mkdir td2\r list [catch {file rename -force td2 td1} msg] $msg\r} [subst {1 {error renaming "td2" to "[file join td1 td2]": file already exists}}]\rtest fCmd-6.19 {CopyRenameOneFile: errno == EXDEV} {unixOnly notRoot} {\r cleanup /tmp\r createfile tf1\r file rename tf1 /tmp\r glob tf* /tmp/tf1\r} {/tmp/tf1}\rtest fCmd-6.20 {CopyRenameOneFile: errno == EXDEV} {pcOnly} {\r catch {file delete -force c:/tcl8975@ d:/tcl8975@}\r file mkdir c:/tcl8975@\r if [catch {file rename c:/tcl8975@ d:/}] {\r set msg d:/tcl8975@\r } else {\r set msg [glob c:/tcl8975@ d:/tcl8975@]\r file delete -force d:/tcl8975@\r }\r file delete -force c:/tcl8975@\r set msg\r} {d:/tcl8975@}\rtest fCmd-6.21 {CopyRenameOneFile: copy/rename: S_ISDIR(source)} \\r {unixOnly notRoot} {\r cleanup /tmp\r file mkdir td1\r file rename td1 /tmp\r glob td* /tmp/td*\r} {/tmp/td1}\rtest fCmd-6.22 {CopyRenameOneFile: copy/rename: !S_ISDIR(source)} \\r {unixOnly notRoot} {\r cleanup /tmp\r createfile tf1\r file rename tf1 /tmp\r glob tf* /tmp/tf*\r} {/tmp/tf1}\rtest fCmd-6.23 {CopyRenameOneFile: TclpCopyDirectory failed} \\r {unixOnly notRoot xdev} {\r cleanup /tmp\r file mkdir td1/td2/td3\r exec chmod 000 td1\r set msg [list [catch {file rename td1 /tmp} msg] $msg]\r exec chmod 755 td1\r set msg \r} {1 {error renaming "td1": permission denied}}\rtest fCmd-6.24 {CopyRenameOneFile: error uses original name} \\r {unixOnly notRoot} {\r cleanup\r file mkdir ~/td1/td2\r exec chmod 000 [file join [file dirname ~] [file tail ~] td1]\r set msg [list [catch {file copy ~/td1 td1} msg] $msg]\r exec chmod 755 [file join [file dirname ~] [file tail ~] td1]\r file delete -force ~/td1\r set msg\r} {1 {error copying "~/td1": permission denied}}\rtest fCmd-6.25 {CopyRenameOneFile: error uses original name} \\r {unixOnly notRoot} {\r cleanup\r file mkdir td2\r file mkdir ~/td1\r exec chmod 000 [file join [file dirname ~] [file tail ~] td1]\r set msg [list [catch {file copy td2 ~/td1} msg] $msg]\r exec chmod 755 [file join [file dirname ~] [file tail ~] td1]\r file delete -force ~/td1\r set msg\r} {1 {error copying "td2" to "~/td1/td2": permission denied}}\rtest fCmd-6.26 {CopyRenameOneFile: doesn't use original name} \\r {unixOnly notRoot} {\r cleanup\r file mkdir ~/td1/td2\r exec chmod 000 [file join [file dirname ~] [file tail ~] td1 td2]\r set msg [list [catch {file copy ~/td1 td1} msg] $msg]\r exec chmod 755 [file join [file dirname ~] [file tail ~] td1 td2]\r file delete -force ~/td1\r set msg\r} "1 {error copying \"~/td1\" to \"td1\": \"[file join [file dirname ~] [file tail ~] td1 td2]\": permission denied}"\rtest fCmd-6.27 {CopyRenameOneFile: TclpCopyDirectory failed} \\r {unixOnly notRoot xdev} {\r cleanup /tmp\r file mkdir td1/td2/td3\r file mkdir /tmp/td1\r createfile /tmp/td1/tf1\r list [catch {file rename -force td1 /tmp} msg] $msg\r} {1 {error renaming "td1" to "/tmp/td1": file already exists}}\rtest fCmd-6.28 {CopyRenameOneFile: TclpCopyDirectory failed} \\r {unixOnly notRoot xdev} {\r cleanup /tmp\r file mkdir td1/td2/td3\r exec chmod 000 td1/td2/td3 \r set msg [list [catch {file rename td1 /tmp} msg] $msg]\r exec chmod 755 td1/td2/td3 \r set msg\r} {1 {error renaming "td1" to "/tmp/td1": "td1/td2/td3": permission denied}}\rtest fCmd-6.29 {CopyRenameOneFile: TclpCopyDirectory passed} \\r {unixOnly notRoot xdev} {\r cleanup /tmp\r file mkdir td1/td2/td3\r file rename td1 /tmp\r glob td* /tmp/td1/t*\r} {/tmp/td1/td2}\rtest fCmd-6.30 {CopyRenameOneFile: TclpRemoveDirectory failed} \\r {unixOnly notRoot} {\r cleanup\r file mkdir foo/bar\r file attr foo -perm 040555\r set catchResult [catch {file rename foo/bar /tmp} msg]\r set msg [lindex [split $msg :] end]\r catch {file delete /tmp/bar}\r catch {file attr foo -perm 040777}\r catch {file delete -force foo}\r list $catchResult $msg\r} {1 { permission denied}}\rtest fCmd-6.31 {CopyRenameOneFile: TclpDeleteFile passed} \\r {unixOnly notRoot xdev} {\r catch {cleanup /tmp}\r file mkdir /tmp/td1\r createfile /tmp/td1/tf1\r file rename /tmp/td1/tf1 tf1\r list [file exists /tmp/td1/tf1] [file exists tf1]\r} {0 1}\rtest fCmd-6.32 {CopyRenameOneFile: copy} {notRoot} {\r cleanup\r list [catch {file copy tf1 tf2} msg] $msg\r} {1 {error copying "tf1": no such file or directory}}\rcatch {cleanup /tmp}\r\rtest fCmd-7.1 {FileForceOption: none} {notRoot} {\r cleanup\r file mkdir [file join tf1 tf2]\r list [catch {file delete tf1} msg] $msg\r} {1 {error deleting "tf1": directory not empty}}\rtest fCmd-7.2 {FileForceOption: -force} {notRoot} {\r cleanup\r file mkdir [file join tf1 tf2]\r file delete -force tf1\r} {}\rtest fCmd-7.3 {FileForceOption: --} {notRoot} {\r createfile -tf1\r file delete -- -tf1\r} {}\rtest fCmd-7.4 {FileForceOption: bad option} {notRoot} {\r createfile -tf1\r set msg [list [catch {file delete -tf1} msg] $msg]\r file delete -- -tf1\r set msg\r} {1 {bad option "-tf1": should be -force or --}}\rtest fCmd-7.5 {FileForceOption: multiple times through loop} {notRoot} {\r createfile --\r createfile -force\r file delete -force -force -- -- -force\r list [catch {glob -- -- -force} msg] $msg\r} {1 {no files matched glob patterns "-- -force"}}\r\rtest fCmd-8.1 {FileBasename: basename of ~user: argc == 1 && *path == ~} \\r {unixOnly notRoot knownBug} {\r # Labelled knownBug because it is dangerous [Bug: 3881]\r file mkdir td1\r file attr td1 -perm 040000\r set result [list [catch {file rename ~$user td1} msg] $msg]\r file delete -force td1\r set result\r} "1 {error renaming \"~$user\" to \"td1/[file tail ~$user]\": permission denied}"\rtest fCmd-8.2 {FileBasename: basename of ~user: argc == 1 && *path == ~} \\r {unixOnly notRoot} {\r file tail ~$user\r} "$user"\r\rtest fCmd-9.1 {file rename: comprehensive: EACCES} {unixOnly notRoot} {\r cleanup\r file mkdir td1\r file mkdir td2\r file attr td2 -perm 040000\r set result [list [catch {file rename td1 td2/} msg] $msg]\r file delete -force td2\r file delete -force td1\r set result\r} {1 {error renaming "td1" to "td2/td1": permission denied}}\rtest fCmd-9.2 {file rename: comprehensive: source doesn't exist} {notRoot} {\r cleanup\r list [catch {file rename tf1 tf2} msg] $msg\r} {1 {error renaming "tf1": no such file or directory}}\rtest fCmd-9.3 {file rename: comprehensive: file to new name} {notRoot testchmod} {\r cleanup\r createfile tf1\r createfile tf2\r testchmod 444 tf2\r file rename tf1 tf3\r file rename tf2 tf4\r list [lsort [glob tf*]] [file writable tf3] [file writable tf4]\r} {{tf3 tf4} 1 0} \rtest fCmd-9.4 {file rename: comprehensive: dir to new name} {unixOrPc notRoot testchmod} {\r cleanup\r file mkdir td1 td2\r testchmod 555 td2\r file rename td1 td3\r file rename td2 td4\r list [lsort [glob td*]] [file writable td3] [file writable td4]\r} {{td3 td4} 1 0} \rtest fCmd-9.5 {file rename: comprehensive: file to self} {notRoot testchmod} {\r cleanup\r createfile tf1 tf1\r createfile tf2 tf2\r testchmod 444 tf2\r file rename -force tf1 tf1\r file rename -force tf2 tf2\r list [contents tf1] [contents tf2] [file writable tf1] [file writable tf2]\r} {tf1 tf2 1 0} \rtest fCmd-9.6 {file rename: comprehensive: dir to self} {notRoot unixOrPc testchmod} {\r cleanup\r file mkdir td1\r file mkdir td2\r testchmod 555 td2\r file rename -force td1 .\r file rename -force td2 .\r list [lsort [glob td*]] [file writable td1] [file writable td2]\r} {{td1 td2} 1 0} \rtest fCmd-9.7 {file rename: comprehensive: file to existing file} {notRoot testchmod} {\r cleanup\r createfile tf1\r createfile tf2\r createfile tfs1\r createfile tfs2\r createfile tfs3\r createfile tfs4\r createfile tfd1\r createfile tfd2\r createfile tfd3\r createfile tfd4\r testchmod 444 tfs3\r testchmod 444 tfs4\r testchmod 444 tfd2\r testchmod 444 tfd4\r set msg [list [catch {file rename tf1 tf2} msg] $msg]\r file rename -force tfs1 tfd1\r file rename -force tfs2 tfd2\r file rename -force tfs3 tfd3\r file rename -force tfs4 tfd4\r list [lsort [glob tf*]] $msg [file writable tfd1] [file writable tfd2] [file writable tfd3] [file writable tfd4] \r} {{tf1 tf2 tfd1 tfd2 tfd3 tfd4} {1 {error renaming "tf1" to "tf2": file already exists}} 1 1 0 0}\rtest fCmd-9.8 {file rename: comprehensive: dir to empty dir} {notRoot testchmod} {\r # Under unix, you can rename a read-only directory, but you can't\r # move it into another directory.\r\r cleanup\r file mkdir td1\r file mkdir [file join td2 td1]\r file mkdir tds1\r file mkdir tds2\r file mkdir tds3\r file mkdir tds4\r file mkdir [file join tdd1 tds1]\r file mkdir [file join tdd2 tds2]\r file mkdir [file join tdd3 tds3]\r file mkdir [file join tdd4 tds4]\r if {$tcl_platform(platform) != "unix" && $tcl_platform(platform) != "macintosh"} {\r testchmod 555 tds3\r testchmod 555 tds4\r }\r if {$tcl_platform(platform) != "macintosh"} {\r testchmod 555 [file join tdd2 tds2]\r testchmod 555 [file join tdd4 tds4]\r }\r set msg [list [catch {file rename td1 td2} msg] $msg]\r file rename -force tds1 tdd1\r file rename -force tds2 tdd2\r file rename -force tds3 tdd3\r file rename -force tds4 tdd4\r if {$tcl_platform(platform) != "unix" && $tcl_platform(platform) != "macintosh"} {\r set w3 [file writable [file join tdd3 tds3]]\r set w4 [file writable [file join tdd4 tds4]]\r } else {\r set w3 0\r set w4 0\r }\r list [lsort [glob td*]] $msg [file writable [file join tdd1 tds1]] \\r [file writable [file join tdd2 tds2]] $w3 $w4\r} [subst {{td1 td2 tdd1 tdd2 tdd3 tdd4} {1 {error renaming "td1" to "[file join td2 td1]": file already exists}} 1 1 0 0}]\rtest fCmd-9.9 {file rename: comprehensive: dir to non-empty dir} {notRoot testchmod} {\r cleanup\r file mkdir tds1\r file mkdir tds2\r file mkdir [file join tdd1 tds1 xxx]\r file mkdir [file join tdd2 tds2 xxx]\r if {$tcl_platform(platform) != "unix" && $tcl_platform(platform) != "macintosh"} {\r testchmod 555 tds2\r }\r set a1 [list [catch {file rename -force tds1 tdd1} msg] $msg]\r set a2 [list [catch {file rename -force tds2 tdd2} msg] $msg]\r if {$tcl_platform(platform) != "unix" && $tcl_platform(platform) != "macintosh"} {\r set w2 [file writable tds2]\r } else {\r set w2 0\r }\r list [lsort [glob td*]] $a1 $a2 [file writable tds1] $w2\r} [subst {{tdd1 tdd2 tds1 tds2} {1 {error renaming "tds1" to "[file join tdd1 tds1]": file already exists}} {1 {error renaming "tds2" to "[file join tdd2 tds2]": file already exists}} 1 0}]\rtest fCmd-9.10 {file rename: comprehensive: file to new name and dir} {notRoot testchmod} {\r cleanup\r createfile tf1\r createfile tf2\r file mkdir td1\r testchmod 444 tf2\r file rename tf1 [file join td1 tf3]\r file rename tf2 [file join td1 tf4]\r list [catch {glob tf*}] [lsort [glob -directory td1 t*]] \\r [file writable [file join td1 tf3]] [file writable [file join td1 tf4]]\r} [subst {1 {[file join td1 tf3] [file join td1 tf4]} 1 0}]\rtest fCmd-9.11 {file rename: comprehensive: dir to new name and dir} {notRoot testchmod} {\r cleanup\r file mkdir td1\r file mkdir td2\r file mkdir td3\r if {$tcl_platform(platform) != "unix" && $tcl_platform(platform) != "macintosh"} {\r testchmod 555 td2\r }\r file rename td1 [file join td3 td3]\r file rename td2 [file join td3 td4]\r if {$tcl_platform(platform) != "unix" && $tcl_platform(platform) != "macintosh"} {\r set w4 [file writable [file join td3 td4]]\r } else {\r set w4 0\r }\r list [lsort [glob td*]] [lsort [glob -directory td3 t*]] \\r [file writable [file join td3 td3]] $w4\r} [subst {td3 {[file join td3 td3] [file join td3 td4]} 1 0}]\rtest fCmd-9.12 {file rename: comprehensive: target exists} {notRoot testchmod} {\r cleanup\r file mkdir [file join td1 td2] [file join td2 td1]\r if {$tcl_platform(platform) != "macintosh"} {\r testchmod 555 [file join td2 td1]\r }\r file mkdir [file join td3 td4] [file join td4 td3]\r file rename -force td3 td4\r set msg [list [file exists td3] [file exists [file join td4 td3 td4]] \\r [catch {file rename td1 td2} msg] $msg]\r if {$tcl_platform(platform) != "macintosh"} {\r testchmod 755 [file join td2 td1]\r }\r set msg\r} [subst {0 1 1 {error renaming "td1" to "[file join td2 td1]": file already exists}}]\rtest fCmd-9.13 {file rename: comprehensive: can't overwrite target} {notRoot} {\r cleanup\r file mkdir [file join td1 td2] [file join td2 td1 td4]\r list [catch {file rename -force td1 td2} msg] $msg\r} [subst {1 {error renaming "td1" to "[file join td2 td1]": file already exists}}]\rtest fCmd-9.14 {file rename: comprehensive: dir into self} {notRoot} {\r cleanup\r file mkdir td1\r list [glob td*] [list [catch {file rename td1 td1} msg] $msg]\r} [subst {td1 {1 {error renaming "td1" to "[file join td1 td1]": trying to rename a volume or move a directory into itself}}}]\rtest fCmd-9.15 {file rename: comprehensive: source and target incompatible} \\r {notRoot} {\r cleanup\r file mkdir td1\r createfile tf1\r list [catch {file rename -force td1 tf1} msg] $msg\r} {1 {can't overwrite file "tf1" with directory "td1"}}\rtest fCmd-9.16 {file rename: comprehensive: source and target incompatible} \\r {notRoot} {\r cleanup\r file mkdir td1/tf1\r createfile tf1\r list [catch {file rename -force tf1 td1} msg] $msg\r} [subst {1 {can't overwrite directory "[file join td1 tf1]" with file "tf1"}}]\r\rtest fCmd-10.1 {file copy: comprehensive: source doesn't exist} {notRoot} {\r cleanup\r list [catch {file copy tf1 tf2} msg] $msg\r} {1 {error copying "tf1": no such file or directory}}\rtest fCmd-10.2 {file copy: comprehensive: file to new name} {notRoot testchmod} {\r cleanup\r createfile tf1 tf1\r createfile tf2 tf2\r testchmod 444 tf2\r file copy tf1 tf3\r file copy tf2 tf4\r list [lsort [glob tf*]] [contents tf3] [contents tf4] [file writable tf3] [file writable tf4]\r} {{tf1 tf2 tf3 tf4} tf1 tf2 1 0}\rtest fCmd-10.3 {file copy: comprehensive: dir to new name} {notRoot unixOrPc testchmod} {\r cleanup\r file mkdir [file join td1 tdx]\r file mkdir [file join td2 tdy]\r testchmod 555 td2\r file copy td1 td3\r file copy td2 td4\r set msg [list [lsort [glob td*]] [glob -directory td3 t*] \\r [glob -directory td4 t*] [file writable td3] [file writable td4]]\r if {$tcl_platform(platform) != "macintosh"} {\r testchmod 755 td2\r testchmod 755 td4\r }\r set msg\r} [subst {{td1 td2 td3 td4} [file join td3 tdx] [file join td4 tdy] 1 0}]\rtest fCmd-10.4 {file copy: comprehensive: file to existing file} {notRoot testchmod} {\r cleanup\r createfile tf1\r createfile tf2\r createfile tfs1\r createfile tfs2\r createfile tfs3\r createfile tfs4\r createfile tfd1\r createfile tfd2\r createfile tfd3\r createfile tfd4\r testchmod 444 tfs3\r testchmod 444 tfs4\r testchmod 444 tfd2\r testchmod 444 tfd4\r set msg [list [catch {file copy tf1 tf2} msg] $msg]\r file copy -force tfs1 tfd1\r file copy -force tfs2 tfd2\r file copy -force tfs3 tfd3\r file copy -force tfs4 tfd4\r list [lsort [glob tf*]] $msg [file writable tfd1] [file writable tfd2] [file writable tfd3] [file writable tfd4] \r} {{tf1 tf2 tfd1 tfd2 tfd3 tfd4 tfs1 tfs2 tfs3 tfs4} {1 {error copying "tf1" to "tf2": file already exists}} 1 1 0 0}\rtest fCmd-10.5 {file copy: comprehensive: dir to empty dir} {notRoot testchmod} {\r cleanup\r file mkdir td1\r file mkdir [file join td2 td1]\r file mkdir tds1\r file mkdir tds2\r file mkdir tds3\r file mkdir tds4\r file mkdir [file join tdd1 tds1]\r file mkdir [file join tdd2 tds2]\r file mkdir [file join tdd3 tds3]\r file mkdir [file join tdd4 tds4]\r if {$tcl_platform(platform) != "macintosh"} {\r testchmod 555 tds3\r testchmod 555 tds4\r testchmod 555 [file join tdd2 tds2]\r testchmod 555 [file join tdd4 tds4]\r }\r set a1 [list [catch {file copy td1 td2} msg] $msg]\r set a2 [list [catch {file copy -force tds1 tdd1} msg] $msg]\r set a3 [catch {file copy -force tds2 tdd2}]\r set a4 [catch {file copy -force tds3 tdd3}]\r set a5 [catch {file copy -force tds4 tdd4}]\r list [lsort [glob td*]] $a1 $a2 $a3 $a4 $a5 \r} [subst {{td1 td2 tdd1 tdd2 tdd3 tdd4 tds1 tds2 tds3 tds4} {1 {error copying "td1" to "[file join td2 td1]": file already exists}} {1 {error copying "tds1" to "[file join tdd1 tds1]": file already exists}} 1 1 1}]\rtest fCmd-10.6 {file copy: comprehensive: dir to non-empty dir} \\r {notRoot unixOrPc testchmod} {\r cleanup\r file mkdir tds1\r file mkdir tds2\r file mkdir [file join tdd1 tds1 xxx]\r file mkdir [file join tdd2 tds2 xxx]\r testchmod 555 tds2\r set a1 [list [catch {file copy -force tds1 tdd1} msg] $msg]\r set a2 [list [catch {file copy -force tds2 tdd2} msg] $msg]\r list [lsort [glob td*]] $a1 $a2 [file writable tds1] [file writable tds2]\r} [subst {{tdd1 tdd2 tds1 tds2} {1 {error copying "tds1" to "[file join tdd1 tds1]": file already exists}} {1 {error copying "tds2" to "[file join tdd2 tds2]": file already exists}} 1 0}]\rtest fCmd-10.7 {file rename: comprehensive: file to new name and dir} {notRoot testchmod} {\r cleanup\r createfile tf1\r createfile tf2\r file mkdir td1\r testchmod 444 tf2\r file copy tf1 [file join td1 tf3]\r file copy tf2 [file join td1 tf4]\r list [lsort [glob tf*]] [lsort [glob -directory td1 t*]] \\r [file writable [file join td1 tf3]] [file writable [file join td1 tf4]]\r} [subst {{tf1 tf2} {[file join td1 tf3] [file join td1 tf4]} 1 0}]\rtest fCmd-10.8 {file rename: comprehensive: dir to new name and dir} \\r {notRoot unixOrPc testchmod} {\r cleanup\r file mkdir td1\r file mkdir td2\r file mkdir td3\r testchmod 555 td2\r file copy td1 [file join td3 td3]\r file copy td2 [file join td3 td4]\r list [lsort [glob td*]] [lsort [glob -directory td3 t*]] \\r [file writable [file join td3 td3]] [file writable [file join td3 td4]]\r} [subst {{td1 td2 td3} {[file join td3 td3] [file join td3 td4]} 1 0}]\rtest fCmd-10.9 {file copy: comprehensive: source and target incompatible} \\r {notRoot} {\r cleanup\r file mkdir td1\r createfile tf1\r list [catch {file copy -force td1 tf1} msg] $msg\r} {1 {can't overwrite file "tf1" with directory "td1"}}\rtest fCmd-10.10 {file copy: comprehensive: source and target incompatible} \\r {notRoot} {\r cleanup\r file mkdir [file join td1 tf1]\r createfile tf1\r list [catch {file copy -force tf1 td1} msg] $msg\r} [subst {1 {can't overwrite directory "[file join td1 tf1]" with file "tf1"}}]\rcleanup \r\r# old tests \r\rtest fCmd-11.1 {TclFileRenameCmd: -- option } {notRoot} {\r catch {file delete -force -- -tfa1}\r set s [createfile -tfa1]\r file rename -- -tfa1 tfa2\r set result [expr [checkcontent tfa2 $s] && ![file exists -tfa1]]\r file delete tfa2\r set result\r} {1}\r\rtest fCmd-11.2 {TclFileRenameCmd: bad option } {notRoot} {\r catch {file delete -force -- tfa1}\r set s [createfile tfa1]\r set r1 [catch {file rename -x tfa1 tfa2}]\r set result [expr $r1 && [checkcontent tfa1 $s] && ![file exists tfa2]]\r file delete tfa1\r set result\r} {1}\r\rtest fCmd-11.3 {TclFileRenameCmd: bad \# args} {\r catch {file rename -- }\r} {1}\r\rtest fCmd-11.4 {TclFileRenameCmd: target filename translation failing} {notRoot} {\r global env\r set temp $env(HOME)\r unset env(HOME)\r set result [catch {file rename tfa ~/foobar }]\r set env(HOME) $temp\r set result\r } {1}\r\rtest fCmd-11.5 {TclFileRenameCmd: > 1 source & target is not a dir} {notRoot} {\r catch {file delete -force -- tfa1 tfa2 tfa3}\r createfile tfa1 \r createfile tfa2 \r createfile tfa3 \r set result [catch {file rename tfa1 tfa2 tfa3}]\r file delete tfa1 tfa2 tfa3\r set result\r} {1}\r\rtest fCmd-11.6 {TclFileRenameCmd: : single file into directory} {notRoot} {\r catch {file delete -force -- tfa1 tfad}\r set s [createfile tfa1]\r file mkdir tfad\r file rename tfa1 tfad\r set result [expr [checkcontent tfad/tfa1 $s] && ![file exists tfa1]]\r file delete -force tfad\r set result\r} {1}\r\rtest fCmd-11.7 {TclFileRenameCmd: : multiple files into directory} {notRoot} {\r catch {file delete -force -- tfa1 tfa2 tfad}\r set s1 [createfile tfa1 ]\r set s2 [createfile tfa2 ]\r file mkdir tfad\r file rename tfa1 tfa2 tfad\r set r1 [checkcontent tfad/tfa1 $s1]\r set r2 [checkcontent tfad/tfa2 $s2]\r \r set result [expr $r1 && $r2 && ![file exists tfa1] && ![file exists tfa2]]\r \r file delete -force tfad\r set result\r} {1}\r\rtest fCmd-11.8 {TclFileRenameCmd: error renaming file to directory} {notRoot} {\r catch {file delete -force -- tfa tfad}\r set s [createfile tfa ]\r file mkdir tfad\r file mkdir tfad/tfa\r set r1 [catch {file rename tfa tfad}]\r set r2 [checkcontent tfa $s]\r set r3 [file isdir tfad]\r set result [expr $r1 && $r2 && $r3 ]\r file delete -force tfa tfad\r set result\r} {1}\r\r#\r# Coverage tests for renamefile() ;\r#\rtest fCmd-12.1 {renamefile: source filename translation failing} {notRoot} {\r global env\r set temp $env(HOME)\r unset env(HOME)\r set result [catch {file rename ~/tfa1 tfa2}]\r set env(HOME) $temp\r set result\r} {1}\r\rtest fCmd-12.2 {renamefile: src filename translation failing} {notRoot} {\r global env\r set temp $env(HOME)\r unset env(HOME)\r set s [createfile tfa1]\r file mkdir tfad\r set result [catch {file rename tfa1 ~/tfa2 tfad}]\r set env(HOME) $temp\r file delete -force tfad\r set result\r} {1}\r\rtest fCmd-12.3 {renamefile: stat failing on source} {notRoot} {\r catch {file delete -force -- tfa1 tfa2}\r set r1 [catch {file rename tfa1 tfa2}]\r expr {$r1 && ![file exists tfa1] && ![file exists tfa2]}\r} {1}\r\rtest fCmd-12.4 {renamefile: error renaming file to directory} {notRoot} {\r catch {file delete -force -- tfa tfad}\r set s1 [createfile tfa ]\r file mkdir tfad\r file mkdir tfad/tfa\r set r1 [catch {file rename tfa tfad}]\r set r2 [checkcontent tfa $s1]\r set r3 [file isdir tfad/tfa]\r set result [expr $r1 && $r2 && $r3]\r file delete -force tfa tfad\r set result\r} {1}\r\rtest fCmd-12.5 {renamefile: error renaming directory to file} {notRoot} {\r catch {file delete -force -- tfa tfad}\r file mkdir tfa\r file mkdir tfad\r set s [createfile tfad/tfa]\r set r1 [catch {file rename tfa tfad}]\r set r2 [checkcontent tfad/tfa $s]\r set r3 [file isdir tfad]\r set r4 [file isdir tfa]\r set result [expr $r1 && $r2 && $r3 && $r4 ]\r file delete -force tfa tfad\r set result\r} {1}\r\rtest fCmd-12.6 {renamefile: TclRenameFile succeeding} {notRoot} {\r catch {file delete -force -- tfa1 tfa2}\r set s [createfile tfa1]\r file rename tfa1 tfa2\r set result [expr [checkcontent tfa2 $s] && ![file exists tfa1]]\r file delete tfa2\r set result\r} {1}\r\rtest fCmd-12.7 {renamefile: renaming directory into offspring} {notRoot} {\r catch {file delete -force -- tfad}\r file mkdir tfad\r file mkdir tfad/dir\r set result [catch {file rename tfad tfad/dir}]\r file delete -force tfad \r set result\r} {1}\r\rtest fCmd-12.8 {renamefile: generic error} {unixOnly notRoot} {\r catch {file delete -force -- tfa}\r file mkdir tfa\r file mkdir tfa/dir\r exec chmod 555 tfa\r set result [catch {file rename tfa/dir tfa2}]\r exec chmod 777 tfa\r file delete -force tfa\r set result\r} {1}\r\r\rtest fCmd-12.9 {renamefile: moving a file across volumes} {unixOnly notRoot} {\r catch {file delete -force -- tfa /tmp/tfa}\r set s [createfile tfa ]\r file rename tfa /tmp\r set result [expr [checkcontent /tmp/tfa $s] && ![file exists tfa]]\r file delete /tmp/tfa\r set result\r} {1}\r\rtest fCmd-12.10 {renamefile: moving a directory across volumes } \\r {unixOnly notRoot} {\r catch {file delete -force -- tfad /tmp/tfad}\r file mkdir tfad\r set s [createfile tfad/a ]\r file rename tfad /tmp\r set restul [expr [checkcontent /tmp/tfad/a $s] && ![file exists tfad]]\r file delete -force /tmp/tfad\r set result\r} {1}\r\r#\r# Coverage tests for TclCopyFilesCmd()\r#\rtest fCmd-13.1 {TclCopyFilesCmd: -force option} {notRoot} {\r catch {file delete -force -- tfa1}\r set s [createfile tfa1]\r file copy -force tfa1 tfa2\r set result [expr [checkcontent tfa2 $s] && [checkcontent tfa1 $s]]\r file delete tfa1 tfa2\r set result\r} {1}\r\rtest fCmd-13.2 {TclCopyFilesCmd: -- option} {notRoot} {\r catch {file delete -force -- tfa1}\r set s [createfile -tfa1]\r file copy -- -tfa1 tfa2\r set result [expr [checkcontent tfa2 $s] && [checkcontent -tfa1 $s]]\r file delete -- -tfa1 tfa2\r set result\r} {1}\r\rtest fCmd-13.3 {TclCopyFilesCmd: bad option} {notRoot} {\r catch {file delete -force -- tfa1}\r set s [createfile tfa1]\r set r1 [catch {file copy -x tfa1 tfa2}]\r set result [expr $r1 && [checkcontent tfa1 $s] && ![file exists tfa2]]\r file delete tfa1\r set result\r} {1}\r\rtest fCmd-13.4 {TclCopyFilesCmd: bad \# args} {notRoot} {\r catch {file copy -- }\r} {1}\r\rtest fCmd-13.5 {TclCopyFilesCmd: target filename translation failing} {\r global env\r set temp $env(HOME)\r unset env(HOME)\r set result [catch {file copy tfa ~/foobar }]\r set env(HOME) $temp\r set result\r } {1}\r\rtest fCmd-13.6 {TclCopyFilesCmd: > 1 source & target is not a dir} {notRoot} {\r catch {file delete -force -- tfa1 tfa2 tfa3}\r createfile tfa1 \r createfile tfa2 \r createfile tfa3 \r set result [catch {file copy tfa1 tfa2 tfa3}]\r file delete tfa1 tfa2 tfa3\r set result\r} {1}\r\rtest fCmd-13.7 {TclCopyFilesCmd: single file into directory} {notRoot} {\r catch {file delete -force -- tfa1 tfad}\r set s [createfile tfa1]\r file mkdir tfad\r file copy tfa1 tfad\r set result [expr [checkcontent tfad/tfa1 $s] && [checkcontent tfa1 $s]]\r file delete -force tfad tfa1\r set result\r} {1}\r\rtest fCmd-13.8 {TclCopyFilesCmd: multiple files into directory} {notRoot} {\r catch {file delete -force -- tfa1 tfa2 tfad}\r set s1 [createfile tfa1 ]\r set s2 [createfile tfa2 ]\r file mkdir tfad\r file copy tfa1 tfa2 tfad\r set r1 [checkcontent tfad/tfa1 $s1]\r set r2 [checkcontent tfad/tfa2 $s2]\r set r3 [checkcontent tfa1 $s1]\r set r4 [checkcontent tfa2 $s2]\r set result [expr $r1 && $r2 && $r3 && $r4 ]\r \r file delete -force tfad tfa1 tfa2\r set result\r} {1}\r\rtest fCmd-13.9 {TclCopyFilesCmd: error copying file to directory} {notRoot} {\r catch {file delete -force -- tfa tfad}\r set s [createfile tfa ]\r file mkdir tfad\r file mkdir tfad/tfa\r set r1 [catch {file copy tfa tfad}]\r set r2 [expr [checkcontent tfa $s] && [file isdir tfad/tfa]]\r set r3 [file isdir tfad]\r set result [expr $r1 && $r2 && $r3 ]\r file delete -force tfa tfad\r set result\r} {1}\r\r#\r# Coverage tests for copyfile()\r# \rtest fCmd-14.1 {copyfile: source filename translation failing} {notRoot} {\r global env\r set temp $env(HOME)\r unset env(HOME)\r set result [catch {file copy ~/tfa1 tfa2}]\r set env(HOME) $temp\r set result\r} {1}\r\rtest fCmd-14.2 {copyfile: dst filename translation failing} {notRoot} {\r global env\r set temp $env(HOME)\r unset env(HOME)\r set s [createfile tfa1]\r file mkdir tfad\r set r1 [catch {file copy tfa1 ~/tfa2 tfad}]\r set result [expr $r1 && [checkcontent tfad/tfa1 $s]]\r set env(HOME) $temp\r file delete -force tfa1 tfad\r set result\r} {1}\r\rtest fCmd-14.3 {copyfile: stat failing on source} {notRoot} {\r catch {file delete -force -- tfa1 tfa2}\r set r1 [catch {file copy tfa1 tfa2}]\r expr $r1 && ![file exists tfa1] && ![file exists tfa2]\r} {1}\r\rtest fCmd-14.4 {copyfile: error copying file to directory} {notRoot} {\r catch {file delete -force -- tfa tfad}\r set s1 [createfile tfa ]\r file mkdir tfad\r file mkdir tfad/tfa\r set r1 [catch {file copy tfa tfad}]\r set r2 [checkcontent tfa $s1]\r set r3 [file isdir tfad]\r set r4 [file isdir tfad/tfa]\r set result [expr $r1 && $r2 && $r3 && $r4 ]\r file delete -force tfa tfad\r set result\r} {1}\r\r test fCmd-14.5 {copyfile: error copying directory to file} {notRoot} {\r catch {file delete -force -- tfa tfad}\r file mkdir tfa\r file mkdir tfad\r set s [createfile tfad/tfa]\r set r1 [catch {file copy tfa tfad}]\r set r2 [checkcontent tfad/tfa $s]\r set r3 [file isdir tfad]\r set r4 [file isdir tfa]\r set result [expr $r1 && $r2 && $r3 && $r4 ]\r file delete -force tfa tfad\r set result\r} {1}\r\rtest fCmd-14.6 {copyfile: copy file succeeding} {notRoot} {\r catch {file delete -force -- tfa tfa2}\r set s [createfile tfa]\r file copy tfa tfa2\r set result [expr [checkcontent tfa $s] && [checkcontent tfa2 $s]]\r file delete tfa tfa2\r set result\r} {1}\r\rtest fCmd-14.7 {copyfile: copy directory succeeding} {notRoot} {\r catch {file delete -force -- tfa tfa2}\r file mkdir tfa\r set s [createfile tfa/file]\r file copy tfa tfa2\r set result [expr [checkcontent tfa/file $s] && [checkcontent tfa2/file $s]]\r file delete -force tfa tfa2\r set result\r} {1}\r\rtest fCmd-14.8 {copyfile: copy directory failing} {unixOnly notRoot} {\r catch {file delete -force -- tfa}\r file mkdir tfa/dir/a/b/c\r exec chmod 000 tfa/dir\r set r1 [catch {file copy tfa tfa2}]\r exec chmod 777 tfa/dir\r set result $r1\r file delete -force tfa tfa2\r set result\r} {1}\r\r#\r# Coverage tests for TclMkdirCmd()\r#\rtest fCmd-15.1 {TclMakeDirsCmd: target filename translation failing} {notRoot} {\r global env\r set temp $env(HOME)\r unset env(HOME) \r set result [catch {file mkdir ~/tfa}]\r set env(HOME) $temp\r set result\r} {1}\r#\r# Can Tcl_SplitPath return argc == 0? If so them we need a\r# test for that code.\r#\rtest fCmd-15.2 {TclMakeDirsCmd - one directory } {notRoot} {\r catch {file delete -force -- tfa}\r file mkdir tfa\r set result [file isdirectory tfa]\r file delete tfa\r set result\r} {1}\r\rtest fCmd-15.3 {TclMakeDirsCmd: - two directories} {notRoot} {\r catch {file delete -force -- tfa1 tfa2}\r file mkdir tfa1 tfa2\r set result [expr [file isdirectory tfa1] && [file isdirectory tfa2]]\r file delete tfa1 tfa2\r set result\r} {1}\r\rtest fCmd-15.4 {TclMakeDirsCmd - stat failing} {unixOnly notRoot} {\r catch {file delete -force -- tfa}\r file mkdir tfa\r createfile tfa/file\r exec chmod 000 tfa\r set result [catch {file mkdir tfa/file}]\r exec chmod 777 tfa\r file delete -force tfa\r set result\r} {1}\r\rtest fCmd-15.5 {TclMakeDirsCmd: - making a directory several levels deep} \\r {notRoot} {\r catch {file delete -force -- tfa}\r file mkdir tfa/a/b/c\r set result [file isdir tfa/a/b/c]\r file delete -force tfa\r set result\r} {1}\r\r \rtest fCmd-15.6 {TclMakeDirsCmd: - trying to overwrite a file} {notRoot} {\r catch {file delete -force -- tfa}\r set s [createfile tfa]\r set r1 [catch {file mkdir tfa}]\r set r2 [file isdir tfa]\r set r3 [file exists tfa]\r set result [expr $r1 && !$r2 && $r3 && [checkcontent tfa $s]]\r file delete tfa\r set result\r} {1}\r\rtest fCmd-15.7 {TclMakeDirsCmd - making several directories} {notRoot} {\r catch {file delete -force -- tfa1 tfa2}\r file mkdir tfa1 tfa2/a/b/c\r set result [expr [file isdir tfa1] && [file isdir tfa2/a/b/c]]\r file delete -force tfa1 tfa2\r set result\r} {1}\r\rtest fCmd-15.8 {TclFileMakeDirsCmd: trying to create an existing dir} {notRoot} {\r file mkdir tfa\r file mkdir tfa\r set result [file isdir tfa]\r file delete tfa\r set result\r} {1}\r\r\r# Coverage tests for TclDeleteFilesCommand()\rtest fCmd-16.1 { test the -- argument } {notRoot} {\r catch {file delete -force -- tfa}\r createfile tfa\r file delete -- tfa\r file exists tfa\r} {0}\r\rtest fCmd-16.2 { test the -force and -- arguments } {notRoot} {\r catch {file delete -force -- tfa}\r createfile tfa\r file delete -force -- tfa\r file exists tfa\r} {0}\r\rtest fCmd-16.3 { test bad option } {notRoot} {\r catch {file delete -force -- tfa}\r createfile tfa\r set result [catch {file delete -dog tfa}]\r file delete tfa\r set result\r} {1}\r\rtest fCmd-16.4 { test not enough args } {notRoot} {\r catch {file delete}\r} {1}\r\rtest fCmd-16.5 { test not enough args with options } {notRoot} {\r catch {file delete --}\r} {1}\r\rtest fCmd-16.6 {delete: source filename translation failing} {notRoot} {\r global env\r set temp $env(HOME)\r unset env(HOME)\r set result [catch {file delete ~/tfa}]\r set env(HOME) $temp\r set result\r} {1}\r\rtest fCmd-16.7 {remove a non-empty directory without -force } {notRoot} {\r catch {file delete -force -- tfa}\r file mkdir tfa\r createfile tfa/a\r set result [catch {file delete tfa }]\r file delete -force tfa\r set result\r} {1}\r\rtest fCmd-16.8 {remove a normal file } {notRoot} {\r catch {file delete -force -- tfa}\r file mkdir tfa\r createfile tfa/a\r set result [catch {file delete tfa }]\r file delete -force tfa\r set result\r} {1}\r\rtest fCmd-16.9 {error while deleting file } {unixOnly notRoot} {\r catch {file delete -force -- tfa}\r file mkdir tfa\r createfile tfa/a\r exec chmod 555 tfa\r set result [catch {file delete tfa/a }]\r #######\r ####### If any directory in a tree that is being removed does not \r ####### have write permission, the process will fail!\r ####### This is also the case with "rm -rf"\r #######\r exec chmod 777 tfa\r file delete -force tfa\r set result\r} {1}\r\rtest fCmd-16.10 {deleting multiple files} {notRoot} {\r catch {file delete -force -- tfa1 tfa2}\r createfile tfa1\r createfile tfa2\r file delete tfa1 tfa2\r expr ![file exists tfa1] && ![file exists tfa2]\r} {1}\r\rtest fCmd-16.11 { TclFileDeleteCmd: removing a nonexistant file} {notRoot} {\r catch {file delete -force -- tfa}\r file delete tfa\r set result 1\r} {1}\r\r# More coverage tests for mkpath()\r test fCmd-17.1 {mkdir stat failing on target but not ENOENT} {unixOnly notRoot} {\r catch {file delete -force -- tfa1}\r file mkdir tfa1\r exec chmod 555 tfa1\r set result [catch {file mkdir tfa1/tfa2}]\r exec chmod 777 tfa1\r file delete -force tfa1\r set result\r} {1}\r\rtest fCmd-17.2 {mkdir several levels deep - relative } {notRoot} {\r catch {file delete -force -- tfa}\r file mkdir tfa/a/b\r set result [file isdir tfa/a/b ]\r file delete tfa/a/b tfa/a tfa\r set result\r} {1}\r\rtest fCmd-17.3 {mkdir several levels deep - absolute } {notRoot} {\r catch {file delete -force -- tfa}\r set f [file join [pwd] tfa a ]\r file mkdir $f\r set result [file isdir $f ]\r file delete $f [file join [pwd] tfa]\r set result\r} {1}\r\r#\r# Functionality tests for TclFileRenameCmd()\r#\r\rtest fCmd-18.1 {TclFileRenameCmd: rename (first form) in the same directory} \\r {notRoot} {\r catch {file delete -force -- tfad}\r file mkdir tfad/dir\r cd tfad/dir\r set s [createfile foo ]\r file rename foo bar\r file rename bar ./foo\r file rename ./foo bar\r file rename ./bar ./foo\r file rename foo ../dir/bar\r file rename ../dir/bar ./foo\r file rename ../../tfad/dir/foo ../../tfad/dir/bar\r file rename [file join [pwd] bar] foo\r file rename foo [file join [pwd] bar]\r set result [expr [checkcontent bar $s] && ![file exists foo]]\r cd ../..\r file delete -force tfad\r set result\r} {1}\r\rtest fCmd-18.2 {TclFileRenameCmd: single dir to nonexistant} {notRoot} {\r catch {file delete -force -- tfa1 tfa2}\r file mkdir tfa1\r file rename tfa1 tfa2\r set result [expr [file exists tfa2] && ![file exists tfa1]]\r file delete tfa2\r set result\r} {1}\r\rtest fCmd-18.3 {TclFileRenameCmd: mixed dirs and files into directory} {notRoot} {\r catch {file delete -force -- tfa1 tfad1 tfad2}\r set s [createfile tfa1 ]\r file mkdir tfad1 tfad2\r file rename tfa1 tfad1 tfad2\r set r1 [checkcontent tfad2/tfa1 $s]\r set r2 [file isdir tfad2/tfad1]\r set result [expr $r1 && $r2 && ![file exists tfa1] && ![file exists tfad1]]\r file delete tfad2/tfa1\r file delete -force tfad2\r set result\r} {1}\r\rtest fCmd-18.4 {TclFileRenameCmd: attempt to replace non-dir with dir} {notRoot} {\r catch {file delete -force -- tfa tfad}\r set s [createfile tfa ]\r file mkdir tfad\r set r1 [catch {file rename tfad tfa}]\r set r2 [checkcontent tfa $s]\r set r3 [file isdir tfad]\r set result [expr $r1 && $r2 && $r3 ]\r file delete tfa tfad\r set result\r} {1}\r\rtest fCmd-18.5 {TclFileRenameCmd: attempt to replace dir with non-dir} {notRoot} {\r catch {file delete -force -- tfa tfad}\r set s [createfile tfa ]\r file mkdir tfad/tfa\r set r1 [catch {file rename tfa tfad}]\r set r2 [checkcontent tfa $s]\r set r3 [file isdir tfad/tfa]\r set result [expr $r1 && $r2 && $r3 ]\r file delete -force tfa tfad\r set result\r} {1}\r\r#\r# On Windows there is no easy way to determine if two files are the same\r#\rtest fCmd-18.6 {TclFileRenameCmd: rename a file to itself} {macOrUnix notRoot} {\r catch {file delete -force -- tfa}\r set s [createfile tfa]\r set r1 [catch {file rename tfa tfa}]\r set result [expr $r1 && [checkcontent tfa $s]]\r file delete tfa\r set result\r} {1}\r\rtest fCmd-18.7 {TclFileRenameCmd: rename dir on top of another empty dir w/o -force} \\r {notRoot} {\r catch {file delete -force -- tfa tfad}\r file mkdir tfa tfad/tfa\r set r1 [catch {file rename tfa tfad}]\r set result [expr $r1 && [file isdir tfa]]\r file delete -force tfa tfad\r set result\r} {1}\r\rtest fCmd-18.8 {TclFileRenameCmd: rename dir on top of another empty dir w/ -force} \\r {notRoot} {\r catch {file delete -force -- tfa tfad}\r file mkdir tfa tfad/tfa\r file rename -force tfa tfad\r set result [expr ![file isdir tfa]]\r file delete -force tfad\r set result\r} {1}\r\rtest fCmd-18.9 {TclFileRenameCmd: rename dir on top of a non-empty dir w/o -force} \\r {notRoot} {\r catch {file delete -force -- tfa tfad}\r file mkdir tfa tfad/tfa/file\r set r1 [catch {file rename tfa tfad}]\r set result [expr $r1 && [file isdir tfa] && [file isdir tfad/tfa/file]]\r file delete -force tfa tfad\r set result\r} {1}\r\rtest fCmd-18.10 {TclFileRenameCmd: rename dir on top of a non-empty dir w/ -force} \\r {notRoot} {\r catch {file delete -force -- tfa tfad}\r file mkdir tfa tfad/tfa/file\r set r1 [catch {file rename -force tfa tfad}]\r set result [expr $r1 && [file isdir tfa] && [file isdir tfad/tfa/file]]\r file delete -force tfa tfad\r set result\r} {1}\r\rtest fCmd-18.11 {TclFileRenameCmd: rename a non-existant file} {notRoot} {\r catch {file delete -force -- tfa1}\r set r1 [catch {file rename tfa1 tfa2}]\r set result [expr $r1 && ![file exists tfa1] && ![file exists tfa2]]\r} {1}\r\rtest fCmd-18.12 {TclFileRenameCmd : rename a symbolic link to file} \\r {unixOnly notRoot} {\r catch {file delete -force -- tfa1 tfa2 tfa3}\r \r set s [createfile tfa1]\r exec ln -s tfa1 tfa2\r file rename tfa2 tfa3\r set t [file type tfa3]\r set result [expr { $t == "link" }]\r file delete tfa1 tfa3\r set result\r} {1}\r\rtest fCmd-18.13 {TclFileRenameCmd : rename a symbolic link to dir} \\r {unixOnly notRoot} {\r catch {file delete -force -- tfa1 tfa2 tfa3}\r \r file mkdir tfa1\r exec ln -s tfa1 tfa2\r file rename tfa2 tfa3\r set t [file type tfa3]\r set result [expr { $t == "link" }]\r file delete tfa1 tfa3\r set result\r} {1}\r\rtest fCmd-18.14 {TclFileRenameCmd : rename a path with sym link} \\r {unixOnly notRoot} {\r catch {file delete -force -- tfa1 tfa2 tfa3}\r \r file mkdir tfa1/a/b/c/d\r file mkdir tfa2\r set f [file join [pwd] tfa1/a/b] \r set f2 [file join [pwd] {tfa2/b alias}]\r exec ln -s $f $f2\r file rename {tfa2/b alias/c} tfa3\r set r1 [file isdir tfa3]\r set r2 [file exists tfa1/a/b/c]\r set result [expr $r1 && !$r2]\r file delete -force tfa1 tfa2 tfa3\r set result\r} {1}\r\rtest fCmd-18.15 {TclFileRenameCmd : rename a file to a symlink dir} \\r {unixOnly notRoot} {\r catch {file delete -force -- tfa1 tfa2 tfalink}\r \r file mkdir tfa1\r set s [createfile tfa2]\r exec ln -s tfa1 tfalink\r\r file rename tfa2 tfalink\r set result [checkcontent tfa1/tfa2 $s ]\r file delete -force tfa1 tfalink\r set result\r} {1}\r\rtest fCmd-18.16 {TclFileRenameCmd: rename a dangling symlink} {unixOnly notRoot} {\r catch {file delete -force -- tfa1 tfalink}\r \r file mkdir tfa1\r exec ln -s tfa1 tfalink\r file delete tfa1 \r file rename tfalink tfa2\r set result [expr [string compare [file type tfa2] "link"] == 0]\r file delete tfa2\r set result\r} {1}\r\r\r#\r# Coverage tests for TclUnixRmdir\r#\rtest fCmd-19.1 { remove empty directory } {notRoot} {\r catch {file delete -force -- tfa}\r file mkdir tfa\r file delete tfa\r file exists tfa\r} {0}\r\rtest fCmd-19.2 { rmdir error besides EEXIST} {unixOnly notRoot} {\r catch {file delete -force -- tfa}\r file mkdir tfa\r file mkdir tfa/a\r exec chmod 555 tfa\r set result [catch {file delete tfa/a}]\r exec chmod 777 tfa\r file delete -force tfa\r set result\r} {1}\r\rtest fCmd-19.3 { recursive remove } {notRoot} {\r catch {file delete -force -- tfa}\r file mkdir tfa\r file mkdir tfa/a\r file delete -force tfa\r file exists tfa\r} {0}\r\r#\r# TclUnixDeleteFile and TraversalDelete are covered by tests from the \r# TclDeleteFilesCmd suite\r#\r#\r\r#\r# Coverage tests for TraverseUnixTree(), called from TclDeleteFilesCmd\r#\r\rtest fCmd-20.1 {TraverseUnixTree : failure opening a subdirectory directory } \\r {unixOnly notRoot} {\r catch {file delete -force -- tfa}\r file mkdir tfa\r file mkdir tfa/a\r exec chmod 000 tfa/a\r set result [catch {file delete -force tfa}]\r exec chmod 777 tfa/a\r file delete -force tfa\r set result\r} {1}\r\r\r#\r# Feature testing for TclCopyFilesCmd\r# \rtest fCmd-21.1 {copy : single file to nonexistant } {notRoot} {\r catch {file delete -force -- tfa1 tfa2}\r set s [createfile tfa1]\r file copy tfa1 tfa2\r set result [expr [checkcontent tfa2 $s] && [checkcontent tfa1 $s]]\r file delete tfa1 tfa2\r set result\r} {1}\r\rtest fCmd-21.2 {copy : single dir to nonexistant } {notRoot} {\r catch {file delete -force -- tfa1 tfa2}\r file mkdir tfa1\r file copy tfa1 tfa2\r set result [expr [file isdir tfa2] && [file isdir tfa1]]\r file delete tfa1 tfa2\r set result\r} {1}\r\rtest fCmd-21.3 {copy : single file into directory } {notRoot} {\r catch {file delete -force -- tfa1 tfad}\r set s [createfile tfa1]\r file mkdir tfad\r file copy tfa1 tfad\r set result [expr [checkcontent tfad/tfa1 $s] && [checkcontent tfa1 $s]]\r file delete -force tfa1 tfad\r set result\r} {1}\r\rtest fCmd-21.4 {copy : more than one source and target is not a directory} \\r {notRoot} {\r catch {file delete -force -- tfa1 tfa2 tfa3}\r createfile tfa1 \r createfile tfa2 \r createfile tfa3 \r set result [catch {file copy tfa1 tfa2 tfa3}]\r file delete tfa1 tfa2 tfa3\r set result\r} {1}\r\rtest fCmd-21.5 {copy : multiple files into directory } {notRoot} {\r catch {file delete -force -- tfa1 tfa2 tfad}\r set s1 [createfile tfa1 ]\r set s2 [createfile tfa2 ]\r file mkdir tfad\r file copy tfa1 tfa2 tfad\r set r1 [checkcontent tfad/tfa1 $s1]\r set r2 [checkcontent tfad/tfa2 $s2]\r set r3 [checkcontent tfa1 $s1]\r set r4 [checkcontent tfa2 $s2]\r set result [expr $r1 && $r2 && $r3 && $r4]\r file delete -force tfa1 tfa2 tfad\r set result\r} {1}\r\rtest fCmd-21.6 {copy: mixed dirs and files into directory} \\r {notRoot notFileSharing} {\r catch {file delete -force -- tfa1 tfad1 tfad2}\r set s [createfile tfa1 ]\r file mkdir tfad1 tfad2\r file copy tfa1 tfad1 tfad2\r set r1 [checkcontent [file join tfad2 tfa1] $s]\r set r2 [file isdir [file join tfad2 tfad1]]\r set r3 [checkcontent tfa1 $s]\r set result [expr $r1 && $r2 && $r3 && [file isdir tfad1]]\r file delete -force tfa1 tfad1 tfad2\r set result\r} {1}\r\rtest fCmd-21.7 {TclCopyFilesCmd: copy a dangling link} {unixOnly notRoot} {\r file mkdir tfad1\r exec ln -s tfad1 tfalink\r file delete tfad1\r file copy tfalink tfalink2\r set result [string match [file type tfalink2] link]\r file delete tfalink tfalink2 \r set result\r} {1}\r\rtest fCmd-21.8 {TclCopyFilesCmd : copy a link } {unixOnly notRoot} {\r file mkdir tfad1\r exec ln -s tfad1 tfalink\r file copy tfalink tfalink2\r set r1 [file type tfalink]\r set r2 [file type tfalink2]\r set r3 [file isdir tfad1]\r set result [expr {("$r1" == "link" ) && ("$r2" == "link" ) && $r3}]\r file delete tfad1 tfalink tfalink2\r set result\r} {1}\r\rtest fCmd-21.9 {TclCopyFilesCmd: copy dir with a link in it} {unixOnly notRoot} {\r file mkdir tfad1\r exec ln -s "[pwd]/tfad1" tfad1/tfalink\r file copy tfad1 tfad2\r set result [string match [file type tfad2/tfalink] link]\r file delete -force tfad1 tfad2\r set result\r} {1}\r\rtest fCmd-21.10 {TclFileCopyCmd: copy dir on top of another empty dir w/o -force} \\r {notRoot} {\r catch {file delete -force -- tfa tfad}\r file mkdir tfa [file join tfad tfa]\r set r1 [catch {file copy tfa tfad}]\r set result [expr $r1 && [file isdir tfa]]\r file delete -force tfa tfad\r set result\r} {1}\r\rtest fCmd-21.11 {TclFileCopyCmd: copy dir on top of a dir w/o -force} {notRoot} {\r catch {file delete -force -- tfa tfad}\r file mkdir tfa [file join tfad tfa file]\r set r1 [catch {file copy tfa tfad}]\r set result [expr $r1 && [file isdir tfa] && [file isdir [file join tfad tfa file]]]\r file delete -force tfa tfad\r set result\r} {1}\r\rtest fCmd-21.12 {TclFileCopyCmd: copy dir on top of a non-empty dir w/ -force} \\r {notRoot} {\r catch {file delete -force -- tfa tfad}\r file mkdir tfa [file join tfad tfa file]\r set r1 [catch {file copy -force tfa tfad}]\r set result [expr $r1 && [file isdir tfa] && [file isdir [file join tfad tfa file]]]\r file delete -force tfa tfad\r set result\r} {1}\r \r#\r# Coverage testing for TclpRenameFile\r#\rtest fCmd-22.1 {TclpRenameFile: rename and overwrite in a single dir} {notRoot} {\r catch {file delete -force -- tfa1 tfa2}\r set s [createfile tfa1]\r set s2 [createfile tfa2 q]\r \r set r1 [catch {rename tfa1 tfa2}]\r file rename -force tfa1 tfa2\r set result [expr $r1 && [checkcontent tfa2 $s]]\r file delete [glob tfa1 tfa2]\r set result\r} {1}\r\rtest fCmd-22.2 {TclpRenameFile: attempt to overwrite itself} {macOrUnix notRoot} {\r catch {file delete -force -- tfa1}\r set s [createfile tfa1] \r file rename -force tfa1 tfa1\r set result [checkcontent tfa1 $s]\r file delete tfa1 \r set result\r} {1}\r\rtest fCmd-22.3 { TclpRenameFile : rename dir to existing dir } {notRoot} {\r catch {file delete -force -- d1 tfad}\r file mkdir d1 [file join tfad d1]\r set r1 [catch {file rename d1 tfad}]\r set result [expr $r1 && [file isdir d1] && [file isdir [file join tfad d1]]]\r file delete -force d1 tfad\r set result\r} {1}\r\rtest fCmd-22.4 {TclpRenameFile: rename dir to dir several levels deep} {notRoot} {\r catch {file delete -force -- d1 tfad}\r file mkdir d1 [file join tfad a b c]\r file rename d1 [file join tfad a b c d1]\r set result [expr ![file isdir d1] && [file isdir [file join tfad a b c d1]]]\r file delete -force [glob d1 tfad]\r set result\r} {1}\r\r\r#\r# TclMacCopyFile needs to be redone.\r#\rtest fCmd-22.5 {TclMacCopyFile: copy and overwrite in a single dir} {notRoot} {\r catch {file delete -force -- tfa1 tfa2}\r set s [createfile tfa1]\r set s2 [createfile tfa2 q]\r\r set r1 [catch {file copy tfa1 tfa2}]\r file copy -force tfa1 tfa2\r set result [expr $r1 && [checkcontent tfa2 $s] && [checkcontent tfa1 $s]]\r file delete tfa1 tfa2\r set result\r} {1}\r\r#\r# TclMacMkdir - basic cases are covered elsewhere.\r# Error cases are not covered.\r#\r\r#\r# TclMacRmdir\r# Error cases are not covered.\r#\r\rtest fCmd-23.1 {TclMacRmdir: trying to remove a nonempty directory} {notRoot} {\r catch {file delete -force -- tfad}\r \r file mkdir [file join tfad dir]\r \r set result [catch {file delete tfad}]\r file delete -force tfad \r set result\r} {1}\r\r#\r# TclMacDeleteFile \r# Error cases are not covered.\r#\rtest fCmd-24.1 {TclMacDeleteFile: deleting a normal file} {notRoot} {\r catch {file delete -force -- tfa1}\r \r createfile tfa1\r file delete tfa1\r file exists tfa1\r} {0}\r\r#\r# TclMacCopyDirectory\r# Error cases are not covered.\r#\rtest fCmd-25.1 { TclMacCopyDirectory : copying a normal directory} \\r {notRoot notFileSharing} {\r catch {file delete -force -- tfad1 tfad2}\r \r file mkdir [file join tfad1 a b c]\r file copy tfad1 tfad2\r set result [expr [file isdir [file join tfad1 a b c]] && [file isdir [file join tfad2 a b c]]]\r file delete -force tfad1 tfad2\r set result\r} {1}\r\rtest fCmd-25.2 { TclMacCopyDirectory : copying a short path normal directory} \\r {notRoot notFileSharing} {\r catch {file delete -force -- tfad1 tfad2}\r \r file mkdir tfad1\r file copy tfad1 tfad2\r set result [expr [file isdir tfad1] && [file isdir tfad2]]\r file delete tfad1 tfad2\r set result\r} {1}\r\rtest fCmd-25.3 { TclMacCopyDirectory : copying dirs between different dirs} \\r {notRoot notFileSharing} {\r catch {file delete -force -- tfad1 tfad2}\r \r file mkdir [file join tfad1 x y z]\r file mkdir [file join tfad2 dir]\r file copy tfad1 [file join tfad2 dir]\r set result [expr [file isdir [file join tfad1 x y z]] && [file isdir [file join tfad2 dir tfad1 x y z]]]\r file delete -force tfad1 tfad2\r set result\r} {1}\r\r#\r# Functionality tests for TclDeleteFilesCmd\r#\r\rtest fCmd-26.1 { TclDeleteFilesCmd : delete symlink} {unixOnly notRoot} {\r catch {file delete -force -- tfad1 tfad2}\r \r file mkdir tfad1\r exec ln -s tfad1 tfalink\r file delete tfalink\r\r set r1 [file isdir tfad1]\r set r2 [file exists tfalink]\r \r set result [expr $r1 && !$r2]\r file delete tfad1\r set result\r} {1}\r\rtest fCmd-26.2 { TclDeleteFilesCmd : delete dir with symlink} {unixOnly notRoot} {\r catch {file delete -force -- tfad1 tfad2}\r \r file mkdir tfad1\r file mkdir tfad2\r exec ln -s tfad1 [file join tfad2 link]\r file delete -force tfad2\r\r set r1 [file isdir tfad1]\r set r2 [file exists tfad2]\r \r set result [expr $r1 && !$r2]\r file delete tfad1\r set result\r} {1}\r\rtest fCmd-26.3 { TclDeleteFilesCmd : delete dangling symlink} {unixOnly notRoot} {\r catch {file delete -force -- tfad1 tfad2}\r \r file mkdir tfad1\r exec ln -s tfad1 tfad2\r file delete tfad1\r file delete tfad2\r\r set r1 [file exists tfad1]\r set r2 [file exists tfad2]\r \r set result [expr !$r1 && !$r2]\r set result\r} {1}\r\rtest fCmd-27.2 {TclFileAttrsCmd - Tcl_TranslateFileName fails} {testsetplatform} {\r set platform [testgetplatform]\r testsetplatform unix\r list [catch {file attributes ~_totally_bogus_user} msg] $msg [testsetplatform $platform]\r} {1 {user "_totally_bogus_user" doesn't exist} {}}\rtest fCmd-27.3 {TclFileAttrsCmd - all attributes} {\r catch {file delete -force -- foo.tmp}\r createfile foo.tmp\r list [catch {file attributes foo.tmp} msg] [expr {[llength $msg] > 0}] [file delete -force -- foo.tmp]\r} {0 1 {}}\rtest fCmd-27.4 {TclFileAttrsCmd - getting one option} {\r catch {file delete -force -- foo.tmp}\r createfile foo.tmp\r set attrs [file attributes foo.tmp]\r list [catch {eval file attributes foo.tmp [lindex $attrs 0]}] [file delete -force -- foo.tmp]\r} {0 {}}\r\r# Find a group that exists on this Unix system, or else skip tests that\r# require Unix groups.\rif {$tcl_platform(platform) == "unix"} {\r set ::tcltest::testConstraints(foundGroup) 0\r catch {\r set groupList [exec groups]\r set group [lindex $groupList 0]\r set ::tcltest::testConstraints(foundGroup) 1\r }\r} else {\r set ::tcltest::testConstraints(foundGroup) 1\r}\r\rtest fCmd-27.5 {TclFileAttrsCmd - setting one option} {foundGroup} {\r catch {file delete -force -- foo.tmp}\r createfile foo.tmp\r set attrs [file attributes foo.tmp]\r list [catch {eval file attributes foo.tmp [lrange $attrs 0 1]} msg] $msg [file delete -force -- foo.tmp]\r} {0 {} {}}\rtest fCmd-27.6 {TclFileAttrsCmd - setting more than one option} {foundGroup} {\r catch {file delete -force -- foo.tmp}\r createfile foo.tmp\r set attrs [file attributes foo.tmp]\r list [catch {eval file attributes foo.tmp [lrange $attrs 0 3]} msg] $msg [file delete -force -- foo.tmp]\r} {0 {} {}}\r\r# cleanup\rcleanup\r::tcltest::cleanupTests\rreturn\r\r\r\r\r\r\r\r\r\r\r\r\r
\ No newline at end of file
--- /dev/null
+# 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$
+
+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
--- /dev/null
+# 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$
+#
+
+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
+
+
+
+
+
+
+
+
+
+
+
+
--- /dev/null
+# 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$
+
+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
+
+
+
+
+
+
+
+
+
+
+
+
--- /dev/null
+# 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$
+
+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
+
+
+
+
+
+
+
+
+
+
+
+
--- /dev/null
+# 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
--- /dev/null
+# 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$
+#
+
+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
+
+
+
+
+
+
+
+
+
+
+
+
--- /dev/null
+# This file tests the tclWinFile.c file.\r#\r# This file contains a collection of tests for one or more of the Tcl\r# built-in commands. Sourcing this file into Tcl runs the tests and\r# generates output for errors. No output means no errors were found.\r#\r# Copyright (c) 1997 Sun Microsystems, Inc.\r# Copyright (c) 1998-1999 by Scriptics Corporation.\r#\r# See the file "license.terms" for information on usage and redistribution\r# of this file, and for a DISCLAIMER OF ALL WARRANTIES.\r#\r# RCS: @(#) $Id$\r\rif {[lsearch [namespace children] ::tcltest] == -1} {\r package require tcltest\r namespace import -force ::tcltest::*\r}\r\rtest winFile-1.1 {TclpGetUserHome} {pcOnly} {\r list [catch {glob ~nosuchuser} msg] $msg\r} {1 {user "nosuchuser" doesn't exist}}\rtest winFile-1.2 {TclpGetUserHome} {nt nonPortable} {\r # The administrator account should always exist.\r\r catch {glob ~administrator}\r} {0}\rtest winFile-1.2 {TclpGetUserHome} {95} {\r # Find some user in system.ini and then see if they have a home.\r\r set f [open $::env(windir)/system.ini]\r set x 0\r while {![eof $f]} {\r set line [gets $f]\r if {$line == "\[Password Lists]"} {\r gets $f\r set name [lindex [split [gets $f] =] 0]\r if {$name != ""} {\r set x [catch {glob ~$name}]\r break\r }\r }\r }\r close $f\r set x\r} {0}\rtest winFile-1.3 {TclpGetUserHome} {nt nonPortable} {\r catch {glob ~stanton@workgroup}\r} {0}\r\rtest winFile-2.1 {TclpMatchFiles: case sensitivity} {pcOnly fsIsWritable} {\r makeFile {} GlobCapS\r set result [list [glob -nocomplain GlobC*] [glob -nocomplain globc*]]\r removeFile GlobCapS\r set result\r} {GlobCapS GlobCapS}\r\rtest winFile-2.2 {TclpMatchFiles: case sensitivity} {pcOnly fsIsWritable} {\r makeFile {} globlower\r set result [list [glob -nocomplain globl*] [glob -nocomplain gLOBl*]]\r removeFile globlower\r set result\r} {globlower globlower}\r\r# cleanup\r::tcltest::cleanupTests\rreturn\r\r\r\r\r\r\r\r\r\r\r\r\r
\ No newline at end of file
--- /dev/null
+# 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
projects / tclvfs / commitdiff