From: Vince Darley Date: Fri, 3 Aug 2001 16:19:00 +0000 (+0000) Subject: Initial revision X-Git-Tag: start~1 X-Git-Url: http://privyetmir.co.uk/gitweb?a=commitdiff_plain;h=1c376f29f164ad156fc63124b639ad80aa3535bb;p=tclvfs Initial revision --- 1c376f29f164ad156fc63124b639ad80aa3535bb diff --git a/ChangeLog b/ChangeLog new file mode 100644 index 0000000..2349449 --- /dev/null +++ b/ChangeLog @@ -0,0 +1,3 @@ +2001-05-09 Vince Darley + + * initial distribution diff --git a/Makefile.in b/Makefile.in new file mode 100644 index 0000000..364d557 --- /dev/null +++ b/Makefile.in @@ -0,0 +1,397 @@ +# Makefile.in -- +# +# This file is a Makefile for Sample TEA Extension. If it has the name +# "Makefile.in" then it is a template for a Makefile; to generate the +# actual Makefile, run "./configure", which is a configuration script +# generated by the "autoconf" program (constructs like "@foo@" will get +# replaced in the actual Makefile. +# +# Copyright (c) 1999 Scriptics Corporation. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id$ + +#======================================================================== +# 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: diff --git a/README.cygwin b/README.cygwin new file mode 100644 index 0000000..82ea869 --- /dev/null +++ b/README.cygwin @@ -0,0 +1,41 @@ +The information below is completely out of date. TEA is basically +hopeless on Windows, and I do not recommend you wasting your time +with it. No-one seems to take any interest in fixing the millions +of problems with TEA. + +There is a good old VC++ makefile in the 'win' directory, which seems to +work (I actually have to run it twice, but at least I get a .dll, which is +more than TEA provides). + +---------------------- + +To use cygwin for building TEA extensions, there are a couple of things +you will need to do. + +1. Make sure you have a working Visual C++ (version 5.0 or later) compiler. + +2. Download and install the free Cygnus Cywgin full tools package from + ftp://go.cygnus.com/pub/sourceware.cygnus.com/pub/cygwin/cygwin-b20/full.exe + +3. Create a directory called "C:\bin". Copy the sh.exe + program from the cygnus bin directory + (C:\cygnus\cygwin-b20\H-i586-cygwin32\bin\sh.exe) to "C:\bin". + This will allow you to run shell scripts that use the + "#!/bin/sh" invocation. + + Create another directory called "C:\tmp". The bash.exe program + requires this directory for storing temporary files. + +4. Set your environment variable "MAKE_MODE" to have the value "UNIX" + This will set up the "make" program to operate in a more sane manner. + +5. Run vcvars32.bat. You must do this every time you wish to + perform a build of an extension. It is strongly recommended + that you modify your sytem environment so that you don't have to + run vcvars32.bat all the time. If you look in the vcvars32.bat + file you will see what system environment variables need to be + set in order to make this work. + +6. If you are authoring a TEA extension, you will also want the GNU + autoconf package. This can be obtained from http://www.gnu.org + Autoconf version 2.13 or later is required. diff --git a/Readme.txt b/Readme.txt new file mode 100644 index 0000000..5e15236 --- /dev/null +++ b/Readme.txt @@ -0,0 +1,28 @@ +This is an implementation of a 'vfs' extension (and a 'vfs' package, +including a small library of Tcl code). The goal of this extension +is to expose Tcl 8.4a3's new filesystem C API to the Tcl level. + +Since 8.4 is still in alpha, the APIs on which this extension depends may of +course change (although this isn't too likely). If that happens, it will of +course require changes to this extension, until the point at which 8.4 goes +final, when only backwards-compatible changes should occur. + +The 'zip' vfs package should work (more or less). There is a framework for +a 'ftp' vfs package which needs filling in. + +Using this extension, the editor Alphatk can actually auto-mount, view and +edit (but not save, since they're read-only) the contents of .zip files +directly (see ). + +The 'tests' directory contains a partially modified version of some of +Tcl's core tests. They are modified in that there is a new 'fsIsWritable' +test constraint, which needs adding to several hundred tests (I've done +some of that work). + +To install, you probably want to rename the directory 'library' to 'vfs1.0' +and place it in your Tcl hierarchy, with the necessary shared library +inside. + +-- Vince Darley, August 1st 2001 + + diff --git a/aclocal.m4 b/aclocal.m4 new file mode 100644 index 0000000..bc7540d --- /dev/null +++ b/aclocal.m4 @@ -0,0 +1 @@ +builtin(include,tcl.m4) diff --git a/configure.in b/configure.in new file mode 100644 index 0000000..d8b082f --- /dev/null +++ b/configure.in @@ -0,0 +1,278 @@ +#-------------------------------------------------------------------- +# Sample configure.in for Tcl Extensions. The only places you should +# need to modify this file are marked by the string __CHANGE__ +#-------------------------------------------------------------------- + +#-------------------------------------------------------------------- +# __CHANGE__ +# This very first macro is used to verify that the configure script can +# find the sources. The argument to AC_INIT should be a unique filename +# for this package, and can be a relative path, such as: +# +# AC_INIT(../generic/tcl.h) +#-------------------------------------------------------------------- + +AC_INIT(vfs.c) + +#AC_CONFIG_AUX_DIR(config) +#CONFIGDIR=${srcdir}/config +#AC_SUBST(CONFIGDIR) + +#-------------------------------------------------------------------- +# __CHANGE__ +# Set your package name and version numbers here. The NODOT_VERSION is +# required for constructing the library name on systems that don't like +# dots in library names (Windows). The VERSION variable is used on the +# other systems. +#-------------------------------------------------------------------- + +PACKAGE=vfs + +MAJOR_VERSION=1 +MINOR_VERSION=0 +PATCHLEVEL= + +VERSION=${MAJOR_VERSION}.${MINOR_VERSION}${PATCHLEVEL} +NODOT_VERSION=${MAJOR_VERSION}${MINOR_VERSION} + + +AC_SUBST(PACKAGE) +AC_SUBST(VERSION) + +#-------------------------------------------------------------------- +# We put this here so that you can compile with -DVERSION="1.2" to +# encode the package version directly into the source files. +#-------------------------------------------------------------------- + +eval AC_DEFINE_UNQUOTED(VERSION, "${VERSION}") + +#-------------------------------------------------------------------- +# Check whether --enable-gcc or --disable-gcc was given. Do this +# before AC_CYGWIN is called so the compiler can +# be fully tested by built-in autoconf tools. +# This macro also calls AC_PROG_CC to set the compiler if --enable-gcc +# was not used. +#-------------------------------------------------------------------- + +SC_ENABLE_GCC +AC_PROG_INSTALL + +#-------------------------------------------------------------------- +# Checks to see if the make program sets the $MAKE variable. +#-------------------------------------------------------------------- + +AC_PROG_MAKE_SET + +#-------------------------------------------------------------------- +# Find ranlib +#-------------------------------------------------------------------- + +AC_PROG_RANLIB + +#-------------------------------------------------------------------- +# This macro performs additional compiler tests. +#-------------------------------------------------------------------- + +AC_CYGWIN + +#-------------------------------------------------------------------- +# Determines the correct binary file extension (.o, .obj, .exe etc.) +#-------------------------------------------------------------------- + +AC_OBJEXT +AC_EXEEXT + +#-------------------------------------------------------------------- +# "cygpath" is used on windows to generate native path names for include +# files. +# These variables should only be used with the compiler and linker since +# they generate native path names. +# +# Unix tclConfig.sh points SRC_DIR at the top-level directory of +# the Tcl sources, while the Windows tclConfig.sh points SRC_DIR at +# the win subdirectory. Hence the different usages of SRC_DIR below. +# +# This must be done before calling SC_PUBLIC_TCL_HEADERS +#-------------------------------------------------------------------- + +case "`uname -s`" in + *win32* | *WIN32* | *CYGWIN_NT*|*CYGWIN_98*|*CYGWIN_95*) + CYGPATH="cygpath -w" + ;; + *) + CYGPATH=echo + ;; +esac + +AC_SUBST(CYGPATH) + +#-------------------------------------------------------------------- +# Load the tclConfig.sh file +#-------------------------------------------------------------------- + +SC_PATH_TCLCONFIG +SC_LOAD_TCLCONFIG + +#-------------------------------------------------------------------- +# __CHANGE__ +# Choose which headers you need. Extension authors should try very +# hard to only rely on the Tcl public header files. Internal headers +# contain private data structures and are subject to change without +# notice. +# This MUST be called after SC_PATH_TCLCONFIG/SC_LOAD_TCLCONFIG +#-------------------------------------------------------------------- + +SC_PUBLIC_TCL_HEADERS +#SC_PRIVATE_TCL_HEADERS + +#-------------------------------------------------------------------- +# __CHANGE__ +# A few miscellaneous platform-specific items: +# +# Define a special symbol for Windows (BUILD_VFS in this case) so +# that we create the export library with the dll. See sha1.h on how +# to use this. +# +# Windows creates a few extra files that need to be cleaned up. +# You can add more files to clean if your extension creates any extra +# files. +# +# Define any extra compiler flags in the PACKAGE_CFLAGS variable. +# These will be appended to the current set of compiler flags for +# your system. +#-------------------------------------------------------------------- + +case "`uname -s`" in + *win32* | *WIN32* | *CYGWIN_NT*|*CYGWIN_98*|*CYGWIN_95*) + AC_DEFINE_UNQUOTED(BUILD_${PACKAGE}) + CLEANFILES="*.lib *.dll *.exp *.ilk *.pdb vc50.pch" + AC_SUBST(CLEANFILES) + ;; + *) + CLEANFILES= + ;; +esac + +#-------------------------------------------------------------------- +# Check whether --enable-threads or --disable-threads was given. +# So far only Tcl responds to this one. +#-------------------------------------------------------------------- + +SC_ENABLE_THREADS + +#-------------------------------------------------------------------- +# The statement below defines a collection of symbols related to +# building as a shared library instead of a static library. +#-------------------------------------------------------------------- + +SC_ENABLE_SHARED + +#-------------------------------------------------------------------- +# This macro figures out what flags to use with the compiler/linker +# when building shared/static debug/optimized objects. This information +# is all taken from the tclConfig.sh file. +#-------------------------------------------------------------------- + +CFLAGS_DEBUG=${TCL_CFLAGS_DEBUG} +CFLAGS_OPTIMIZE=${TCL_CFLAGS_OPTIMIZE} +LDFLAGS_DEBUG=${TCL_LDFLAGS_DEBUG} +LDFLAGS_OPTIMIZE=${TCL_LDFLAGS_OPTIMIZE} +SHLIB_LD=${TCL_SHLIB_LD} +STLIB_LD=${TCL_STLIB_LD} +SHLIB_CFLAGS=${TCL_SHLIB_CFLAGS} + +AC_SUBST(CFLAGS_DEBUG) +AC_SUBST(CFLAGS_OPTIMIZE) +AC_SUBST(STLIB_LD) +AC_SUBST(SHLIB_LD) +AC_SUBST(SHLIB_CFLAGS) +AC_SUBST(SHLIB_LDFLAGS) + +#-------------------------------------------------------------------- +# Set the default compiler switches based on the --enable-symbols +# option. +#-------------------------------------------------------------------- + +SC_ENABLE_SYMBOLS + +if test "${SHARED_BUILD}" = "1" ; then + CFLAGS='${CFLAGS_DEFAULT} ${CFLAGS_WARNING} ${SHLIB_CFLAGS}' +else + CFLAGS='${CFLAGS_DEFAULT} ${CFLAGS_WARNING}' +fi + +#-------------------------------------------------------------------- +# Everyone should be linking against the Tcl stub library. If you +# can't for some reason, remove this definition. If you aren't using +# stubs, you also need to modify the SHLIB_LD_LIBS setting below to +# link against the non-stubbed Tcl library. +#-------------------------------------------------------------------- + +AC_DEFINE(USE_TCL_STUBS) + +#-------------------------------------------------------------------- +# This macro generates a line to use when building a library. It +# depends on values set by the SC_ENABLE_SHARED, SC_ENABLE_SYMBOLS, +# and SC_LOAD_TCLCONFIG macros above. +#-------------------------------------------------------------------- + +SC_MAKE_LIB + +#-------------------------------------------------------------------- +# eval these two values to dereference the ${DBGX} variable. +#-------------------------------------------------------------------- + +eval "SHARED_LIB_SUFFIX=${TCL_SHARED_LIB_SUFFIX}" +eval "UNSHARED_LIB_SUFFIX=${TCL_UNSHARED_LIB_SUFFIX}" + +#-------------------------------------------------------------------- +# Shared libraries and static libraries have different names. +#-------------------------------------------------------------------- + +case "`uname -s`" in + *win32* | *WIN32* | *CYGWIN_NT*|*CYGWIN_98*|*CYGWIN_95*) + if test "${SHARED_BUILD}" = "1" ; then + SHLIB_LD_LIBS="\"`cygpath -w ${TCL_BIN_DIR}/${TCL_STUB_LIB_FILE}`\" ${TCL_SHLIB_LD_LIBS}" + eval "${PACKAGE}_LIB_FILE=${PACKAGE}${SHARED_LIB_SUFFIX}" + RANLIB=: + else + eval "${PACKAGE}_LIB_FILE=${PACKAGE}${UNSHARED_LIB_SUFFIX}" + fi + ;; + *) + if test "${SHARED_BUILD}" = "1" ; then + SHLIB_LD_LIBS="${TCL_STUB_LIB_SPEC}" + eval "${PACKAGE}_LIB_FILE=lib${PACKAGE}${SHARED_LIB_SUFFIX}" + RANLIB=: + else + eval "${PACKAGE}_LIB_FILE=lib${PACKAGE}${UNSHARED_LIB_SUFFIX}" + fi + ;; +esac + +AC_SUBST(SHARED_BUILD) + +#-------------------------------------------------------------------- +# __CHANGE__ +# Change the name from exampeA_LIB_FILE to match your package name. +#-------------------------------------------------------------------- + +AC_SUBST(vfs_LIB_FILE) +AC_SUBST(SHLIB_LD_LIBS) + +#-------------------------------------------------------------------- +# Find tclsh so that we can run pkg_mkIndex to generate the pkgIndex.tcl +# file during the install process. Don't run the TCLSH_PROG through +# ${CYGPATH} because it's being used directly by make. +# Require that we use a tclsh shell version 8.2 or later since earlier +# versions have bugs in the pkg_mkIndex routine. +#-------------------------------------------------------------------- + +SC_PROG_TCLSH + +#-------------------------------------------------------------------- +# Finally, substitute all of the various values into the Makefile. +#-------------------------------------------------------------------- + +AC_OUTPUT([Makefile \ + mkIndex.tcl]) diff --git a/generic/vfs.c b/generic/vfs.c new file mode 100644 index 0000000..69657c0 --- /dev/null +++ b/generic/vfs.c @@ -0,0 +1,1083 @@ +/* + * vfs.c -- + * + * This file contains the implementation of the Vfs extension + * to Tcl. It provides a script level interface to Tcl's + * virtual file system support, and therefore allows + * vfs's to be implemented in Tcl. + * + * Copyright (c) Vince Darley. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +#include +/* Required to access the 'stat' structure fields */ +#include "tclPort.h" + +/* + * Windows needs to know which symbols to export. Unix does not. + * BUILD_Vfs should be undefined for Unix. + */ + +#ifdef BUILD_Vfs +#undef TCL_STORAGE_CLASS +#define TCL_STORAGE_CLASS DLLEXPORT +#endif /* BUILD_Vfs */ + +/* + * Only the _Init function is exported. + */ + +EXTERN int Vfs_Init _ANSI_ARGS_((Tcl_Interp*)); + +/* + * Native representation for a path in a Tcl vfs. + */ + +typedef struct VfsNativeRep { + int splitPosition; + Tcl_Obj* fsCmd; +} VfsNativeRep; + +/* + * Structure we use to retain sufficient information about + * a channel that we can properly clean up all resources + * when the channel is closed. This is required when using + * 'open' on things inside the vfs. + */ + +typedef struct VfsChannelCleanupInfo { + Tcl_Channel channel; + Tcl_Obj* closeCallback; + Tcl_Interp* interp; +} VfsChannelCleanupInfo; + + +/* + * Forward declarations for procedures defined later in this file: + */ + +static int VfsFilesystemObjCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); + +/* + * Now we define the filesystem + */ + +static Tcl_FSStatProc VfsStat; +static Tcl_FSAccessProc VfsAccess; +static Tcl_FSOpenFileChannelProc VfsOpenFileChannel; +static Tcl_FSMatchInDirectoryProc VfsMatchInDirectory; +static Tcl_FSDeleteFileProc VfsDeleteFile; +static Tcl_FSCreateDirectoryProc VfsCreateDirectory; +static Tcl_FSRemoveDirectoryProc VfsRemoveDirectory; +static Tcl_FSFileAttrStringsProc VfsFileAttrStrings; +static Tcl_FSFileAttrsGetProc VfsFileAttrsGet; +static Tcl_FSFileAttrsSetProc VfsFileAttrsSet; +static Tcl_FSUtimeProc VfsUtime; +static Tcl_FSPathInFilesystemProc VfsInFilesystem; +static Tcl_FSFilesystemPathTypeProc VfsFilesystemPathType; +static Tcl_FSFilesystemSeparatorProc VfsFilesystemSeparator; +static Tcl_FSFreeInternalRepProc VfsFreeInternalRep; +static Tcl_FSDupInternalRepProc VfsDupInternalRep; + +static Tcl_Filesystem vfsFilesystem = { + "tclvfs", + sizeof(Tcl_Filesystem), + TCL_FILESYSTEM_VERSION_1, + &VfsInFilesystem, + &VfsDupInternalRep, + &VfsFreeInternalRep, + /* No native to normalized */ + NULL, + /* No create native rep function */ + NULL, + /* normalize path isn't needed */ + NULL, + &VfsFilesystemPathType, + &VfsFilesystemSeparator, + &VfsStat, + &VfsAccess, + &VfsOpenFileChannel, + &VfsMatchInDirectory, + &VfsUtime, + /* readlink and listvolumes are not important */ + NULL, + NULL, + &VfsFileAttrStrings, + &VfsFileAttrsGet, + &VfsFileAttrsSet, + &VfsCreateDirectory, + &VfsRemoveDirectory, + &VfsDeleteFile, + /* Use stat for lstat */ + NULL, + /* No copy file */ + NULL, + /* No rename file */ + NULL, + /* No copy directory */ + NULL, + /* No load, unload */ + NULL, + NULL, + /* We don't need a getcwd or chdir */ + NULL, + NULL +}; + +/* And some helper procedures */ + +static VfsNativeRep* VfsGetNativePath(Tcl_Obj* pathObjPtr); +static Tcl_CloseProc VfsCloseProc; +static void VfsExitProc(ClientData clientData); +static Tcl_Obj* VfsCommand(Tcl_Interp* interp, CONST char* cmd, + Tcl_Obj * pathPtr); + +/* + * Hard-code platform dependencies. We do not need to worry + * about backslash-separators on windows, because a normalized + * path will never contain them. + */ +#ifdef MAC_TCL + #define VFS_SEPARATOR ':' +#else + #define VFS_SEPARATOR '/' +#endif + + + +/* + *---------------------------------------------------------------------- + * + * Vfs_Init -- + * + * This procedure is the main initialisation point of the Vfs + * extension. + * + * Results: + * Returns a standard Tcl completion code, and leaves an error + * message in the interp's result if an error occurs. + * + * Side effects: + * Adds a command to the Tcl interpreter. + * + *---------------------------------------------------------------------- + */ + +int +Vfs_Init(interp) + Tcl_Interp *interp; /* Interpreter for application. */ +{ + if (Tcl_InitStubs(interp, "8.4", 0) == NULL) { + return TCL_ERROR; + } + if (Tcl_PkgRequire(interp, "Tcl", "8.4", 0) == NULL) { + return TCL_ERROR; + } + if (Tcl_PkgProvide(interp, "vfs", "1.0") == TCL_ERROR) { + return TCL_ERROR; + } + + /* + * Create additional commands. + */ + + Tcl_CreateObjCommand(interp, "vfs::filesystem", VfsFilesystemObjCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + /* Register our filesystem */ + Tcl_FSRegister((ClientData)interp, &vfsFilesystem); + Tcl_CreateExitHandler(VfsExitProc, (ClientData)NULL); + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * VfsFilesystemObjCmd -- + * + * This procedure implements the "vfs::filesystem" command. It is + * used to (un)register the vfs filesystem, and to mount/unmount + * particular interfaces to new filesystems, or to query for + * what is mounted where. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Inserts or removes a filesystem from Tcl's stack. + * + *---------------------------------------------------------------------- + */ + +static int +VfsFilesystemObjCmd(dummy, interp, objc, objv) + ClientData dummy; + Tcl_Interp *interp; + int objc; + Tcl_Obj *CONST objv[]; +{ + int index; + + static char *optionStrings[] = { + "info", "mount", "unmount", + NULL + }; + enum options { + VFS_INFO, VFS_MOUNT, VFS_UNMOUNT + }; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?"); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0, + &index) != TCL_OK) { + return TCL_ERROR; + } + + switch ((enum options) index) { + case VFS_MOUNT: { + Tcl_Obj * path; + Tcl_Interp* vfsInterp; + if (objc != 4) { + Tcl_WrongNumArgs(interp, 1, objv, "mount path cmd"); + return TCL_ERROR; + } + vfsInterp = (Tcl_Interp*) Tcl_FSData(&vfsFilesystem); + if (vfsInterp == NULL) { + Tcl_SetResult(interp, "vfs not registered", TCL_STATIC); + return TCL_ERROR; + } + path = Tcl_FSGetNormalizedPath(interp, objv[2]); + if (Tcl_SetVar2Ex(vfsInterp, "vfs::mount", + Tcl_GetString(path), objv[3], + TCL_LEAVE_ERR_MSG | TCL_GLOBAL_ONLY) == NULL) { + return TCL_ERROR; + } + break; + } + case VFS_INFO: { + Tcl_Obj * path; + Tcl_Interp* vfsInterp; + Tcl_Obj * val; + if (objc > 3) { + Tcl_WrongNumArgs(interp, 2, objv, "path"); + return TCL_ERROR; + } + vfsInterp = (Tcl_Interp*) Tcl_FSData(&vfsFilesystem); + if (vfsInterp == NULL) { + Tcl_SetResult(interp, "vfs not registered", TCL_STATIC); + return TCL_ERROR; + } + if (objc == 2) { + /* List all vfs paths */ + Tcl_GlobalEval(interp, "array names ::vfs::mount"); + } else { + path = Tcl_FSGetNormalizedPath(interp, objv[2]); + val = Tcl_GetVar2Ex(vfsInterp, "vfs::mount", Tcl_GetString(path), + TCL_LEAVE_ERR_MSG | TCL_GLOBAL_ONLY); + + if (val == NULL) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, val); + } + break; + } + case VFS_UNMOUNT: { + Tcl_Obj * path; + Tcl_Interp* vfsInterp; + int res; + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "path"); + return TCL_ERROR; + } + vfsInterp = (Tcl_Interp*) Tcl_FSData(&vfsFilesystem); + if (vfsInterp == NULL) { + Tcl_SetResult(interp, "vfs not registered", TCL_STATIC); + return TCL_ERROR; + } + path = Tcl_FSGetNormalizedPath(interp, objv[2]); + res = Tcl_UnsetVar2(vfsInterp, "vfs::mount", Tcl_GetString(path), + TCL_LEAVE_ERR_MSG | TCL_GLOBAL_ONLY); + return res; + } + } + return TCL_OK; +} + +int +VfsInFilesystem(Tcl_Obj *pathPtr, ClientData *clientDataPtr) { + Tcl_Obj *normedObj; + int len, splitPosition; + char *normed; + Tcl_Interp* interp; + VfsNativeRep *nativeRep; + Tcl_Obj* mountCmd = NULL; + + /* + * Even Tcl_FSGetNormalizedPath may fail due to lack of system + * encodings, so we just say we can't handle anything if + * we are in the middle of the exit sequence. We could + * perhaps be more subtle than this! + */ + if (TclInExit()) { + return -1; + } + + interp = (Tcl_Interp*) Tcl_FSData(&vfsFilesystem); + if (interp == NULL) { + /* This is bad, but not much we can do about it */ + return -1; + } + + normedObj = Tcl_FSGetNormalizedPath(interp, pathPtr); + if (normedObj == NULL) { + return -1; + } + normed = Tcl_GetStringFromObj(normedObj, &len); + splitPosition = len; + + /* + * Find the most specific mount point for this path. + * Mount points are specified by unique strings, so + * we have to use a unique normalised path for the + * checks here. + */ + while (mountCmd == NULL) { + mountCmd = Tcl_GetVar2Ex(interp, "vfs::mount", normed, + TCL_GLOBAL_ONLY); + + if (mountCmd != NULL) break; + if (splitPosition != len) { + normed[splitPosition] = VFS_SEPARATOR; + } + while ((splitPosition > 0) + && (normed[--splitPosition] != VFS_SEPARATOR)) { + /* Do nothing */ + } + /* Terminate the string there */ + if (splitPosition == 0) { + break; + } + normed[splitPosition] = 0; + } + + /* + * Now either splitPosition is zero, or we found a mount point. + * Test for both possibilities, just to be sure. + */ + if ((splitPosition == 0) || (mountCmd == NULL)) { + return -1; + } + if (splitPosition != len) { + normed[splitPosition] = VFS_SEPARATOR; + } + nativeRep = (VfsNativeRep*) ckalloc(sizeof(VfsNativeRep)); + nativeRep->splitPosition = splitPosition; + nativeRep->fsCmd = mountCmd; + Tcl_IncrRefCount(nativeRep->fsCmd); + *clientDataPtr = (ClientData)nativeRep; + return TCL_OK; +} + +VfsNativeRep* +VfsGetNativePath(Tcl_Obj* pathObjPtr) { + return (VfsNativeRep*) Tcl_FSGetInternalRep(pathObjPtr, &vfsFilesystem); +} + +void +VfsFreeInternalRep(ClientData clientData) { + VfsNativeRep *nativeRep = (VfsNativeRep*)clientData; + if (nativeRep != NULL) { + /* Free the command to use on this mount point */ + Tcl_DecrRefCount(nativeRep->fsCmd); + /* Free the native memory allocation */ + ckfree((char*)nativeRep); + } +} + +ClientData +VfsDupInternalRep(ClientData clientData) { + VfsNativeRep *original = (VfsNativeRep*)clientData; + + VfsNativeRep *nativeRep = (VfsNativeRep*) ckalloc(sizeof(VfsNativeRep)); + nativeRep->splitPosition = original->splitPosition; + nativeRep->fsCmd = original->fsCmd; + Tcl_IncrRefCount(nativeRep->fsCmd); + + return (ClientData)nativeRep; +} + +Tcl_Obj* +VfsFilesystemPathType(Tcl_Obj *pathPtr) { + VfsNativeRep* nativeRep = VfsGetNativePath(pathPtr); + if (nativeRep == NULL) { + return NULL; + } else { + return nativeRep->fsCmd; + } +} + +Tcl_Obj* +VfsFilesystemSeparator(Tcl_Obj* pathObjPtr) { + return Tcl_NewStringObj("/",1); +} + +int +VfsStat(pathPtr, bufPtr) + Tcl_Obj *pathPtr; /* Path of file to stat (in current CP). */ + struct stat *bufPtr; /* Filled with results of stat call. */ +{ + Tcl_Obj *mountCmd = NULL; + Tcl_SavedResult savedResult; + int returnVal; + Tcl_Interp* interp; + + interp = (Tcl_Interp*) Tcl_FSData(&vfsFilesystem); + mountCmd = VfsCommand(interp, "stat", pathPtr); + if (mountCmd == NULL) { + return -1; + } + + Tcl_SaveResult(interp, &savedResult); + /* Now we execute this mount point's callback. */ + returnVal = Tcl_EvalObjEx(interp, mountCmd, + TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT); + if (returnVal == TCL_OK) { + int statListLength; + Tcl_Obj* resPtr = Tcl_GetObjResult(interp); + if (Tcl_ListObjLength(interp, resPtr, &statListLength) == TCL_ERROR) { + returnVal = TCL_ERROR; + } else if (statListLength & 1) { + /* It is odd! */ + returnVal = TCL_ERROR; + } else { + /* + * The st_mode field is set part by the 'mode' + * and part by the 'type' stat fields. + */ + bufPtr->st_mode = 0; + while (statListLength > 0) { + Tcl_Obj *field, *val; + char *fieldName; + statListLength -= 2; + Tcl_ListObjIndex(interp, resPtr, statListLength, &field); + Tcl_ListObjIndex(interp, resPtr, statListLength+1, &val); + fieldName = Tcl_GetString(field); + if (!strcmp(fieldName,"dev")) { + long v; + if (Tcl_GetLongFromObj(interp, val, &v) != TCL_OK) { + returnVal = TCL_ERROR; + break; + } + bufPtr->st_dev = v; + } else if (!strcmp(fieldName,"ino")) { + long v; + if (Tcl_GetLongFromObj(interp, val, &v) != TCL_OK) { + returnVal = TCL_ERROR; + break; + } + bufPtr->st_ino = (unsigned short)v; + } else if (!strcmp(fieldName,"mode")) { + int v; + if (Tcl_GetIntFromObj(interp, val, &v) != TCL_OK) { + returnVal = TCL_ERROR; + break; + } + bufPtr->st_mode |= v; + } else if (!strcmp(fieldName,"nlink")) { + long v; + if (Tcl_GetLongFromObj(interp, val, &v) != TCL_OK) { + returnVal = TCL_ERROR; + break; + } + bufPtr->st_nlink = (short)v; + } else if (!strcmp(fieldName,"uid")) { + long v; + if (Tcl_GetLongFromObj(interp, val, &v) != TCL_OK) { + returnVal = TCL_ERROR; + break; + } + bufPtr->st_uid = (short)v; + } else if (!strcmp(fieldName,"gid")) { + long v; + if (Tcl_GetLongFromObj(interp, val, &v) != TCL_OK) { + returnVal = TCL_ERROR; + break; + } + bufPtr->st_gid = (short)v; + } else if (!strcmp(fieldName,"size")) { + long v; + if (Tcl_GetLongFromObj(interp, val, &v) != TCL_OK) { + returnVal = TCL_ERROR; + break; + } + bufPtr->st_size = v; + } else if (!strcmp(fieldName,"atime")) { + long v; + if (Tcl_GetLongFromObj(interp, val, &v) != TCL_OK) { + returnVal = TCL_ERROR; + break; + } + bufPtr->st_atime = v; + } else if (!strcmp(fieldName,"mtime")) { + long v; + if (Tcl_GetLongFromObj(interp, val, &v) != TCL_OK) { + returnVal = TCL_ERROR; + break; + } + bufPtr->st_mtime = v; + } else if (!strcmp(fieldName,"ctime")) { + long v; + if (Tcl_GetLongFromObj(interp, val, &v) != TCL_OK) { + returnVal = TCL_ERROR; + break; + } + bufPtr->st_ctime = v; + } else if (!strcmp(fieldName,"type")) { + char *str; + str = Tcl_GetString(val); + if (!strcmp(str,"directory")) { + bufPtr->st_mode |= S_IFDIR; + } else if (!strcmp(str,"file")) { + bufPtr->st_mode |= S_IFREG; + } else { + /* + * Do nothing. This means we do not currently + * support anything except files and directories + */ + } + } else { + /* Ignore additional stat arguments */ + } + } + } + } + + Tcl_RestoreResult(interp, &savedResult); + Tcl_DecrRefCount(mountCmd); + + if (returnVal != 0) { + Tcl_SetErrno(ENOENT); + return -1; + } else { + return returnVal; + } +} + +int +VfsAccess(pathPtr, mode) + Tcl_Obj *pathPtr; /* Path of file to access (in current CP). */ + int mode; /* Permission setting. */ +{ + Tcl_Obj *mountCmd = NULL; + Tcl_SavedResult savedResult; + int returnVal; + Tcl_Interp* interp; + + interp = (Tcl_Interp*) Tcl_FSData(&vfsFilesystem); + mountCmd = VfsCommand(interp, "access", pathPtr); + if (mountCmd == NULL) { + return -1; + } + + Tcl_ListObjAppendElement(interp, mountCmd, Tcl_NewIntObj(mode)); + /* Now we execute this mount point's callback. */ + Tcl_SaveResult(interp, &savedResult); + returnVal = Tcl_EvalObjEx(interp, mountCmd, + TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT); + Tcl_RestoreResult(interp, &savedResult); + Tcl_DecrRefCount(mountCmd); + + if (returnVal != 0) { + Tcl_SetErrno(ENOENT); + return -1; + } else { + return returnVal; + } +} + +Tcl_Channel +VfsOpenFileChannel(cmdInterp, pathPtr, modeString, permissions) + Tcl_Interp *cmdInterp; /* Interpreter for error reporting; + * can be NULL. */ + Tcl_Obj *pathPtr; /* Name of file to open. */ + char *modeString; /* A list of POSIX open modes or + * a string such as "rw". */ + int permissions; /* If the open involves creating a + * file, with what modes to create + * it? */ +{ + Tcl_Channel chan = NULL; + VfsChannelCleanupInfo *channelRet = NULL; + Tcl_Obj *mountCmd = NULL; + Tcl_SavedResult savedResult; + int returnVal; + Tcl_Interp* interp; + + interp = (Tcl_Interp*) Tcl_FSData(&vfsFilesystem); + mountCmd = VfsCommand(interp, "open", pathPtr); + if (mountCmd == NULL) { + return NULL; + } + + Tcl_ListObjAppendElement(interp, mountCmd, Tcl_NewStringObj(modeString,-1)); + Tcl_ListObjAppendElement(interp, mountCmd, Tcl_NewIntObj(permissions)); + Tcl_SaveResult(interp, &savedResult); + /* Now we execute this mount point's callback. */ + returnVal = Tcl_EvalObjEx(interp, mountCmd, + TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT); + if (returnVal == TCL_OK) { + int reslen; + Tcl_Obj *resultObj; + /* + * There may be file channel leaks on these two + * error conditions, if the open command actually + * created a channel, but then passed us a bogus list. + */ + resultObj = Tcl_GetObjResult(interp); + if ((Tcl_ListObjLength(interp, resultObj, &reslen) == TCL_ERROR) + || (reslen > 2) || (reslen == 0)) { + returnVal = TCL_ERROR; + } else { + Tcl_Obj *element; + Tcl_Channel theChannel = NULL; + Tcl_ListObjIndex(interp, resultObj, 0, &element); + theChannel = Tcl_GetChannel(interp, Tcl_GetString(element), 0); + + if (theChannel == NULL) { + returnVal == TCL_ERROR; + } else { + channelRet = (VfsChannelCleanupInfo*) + ckalloc(sizeof(VfsChannelCleanupInfo)); + channelRet->channel = theChannel; + if (reslen == 2) { + Tcl_ListObjIndex(interp, resultObj, 1, &element); + channelRet->closeCallback = element; + Tcl_IncrRefCount(channelRet->closeCallback); + channelRet->interp = interp; + } else { + channelRet->closeCallback = NULL; + channelRet->interp = NULL; + } + } + } + } else { + /* + * Copy over the error message to cmdInterp, duplicating it in + * case of threading issues. + */ + Tcl_SetObjResult(cmdInterp, Tcl_DuplicateObj(Tcl_GetObjResult(interp))); + } + + Tcl_RestoreResult(interp, &savedResult); + Tcl_DecrRefCount(mountCmd); + + if (channelRet != NULL) { + /* + * This is a pain. We got the Channel from some Tcl code. + * This means it was registered with the interpreter. But we + * want a pristine channel which hasn't been registered with + * anyone. We use Tcl_DetachChannel to do this for us. + */ + chan = channelRet->channel; + /* We must use the correct interpreter, not our own 'vfs' interpreter */ + Tcl_DetachChannel(channelRet->interp, chan); + if (channelRet->closeCallback != NULL) { + Tcl_CreateCloseHandler(chan, &VfsCloseProc, (ClientData)channelRet); + /* The channelRet structure will be freed in the callback */ + } else { + ckfree((char*)channelRet); + } + } + return chan; +} + +/* + * IMPORTANT: This procedure must *not* modify the interpreter's result + * this leads to the objResultPtr being corrupted (somehow), and curious + * crashes in the future (which are very hard to debug ;-). + */ +void +VfsCloseProc(ClientData clientData) { + VfsChannelCleanupInfo * channelRet = (VfsChannelCleanupInfo*) clientData; + Tcl_SavedResult savedResult; + Tcl_Channel chan = channelRet->channel; + Tcl_Interp * interp = channelRet->interp; + + Tcl_SaveResult(interp, &savedResult); + + /* + * The interpreter needs to know about the channel, else the Tcl + * callback will fail, so we register the channel (this allows + * the Tcl code to use the channel's string-name). + */ + Tcl_RegisterChannel(interp, chan); + Tcl_EvalObjEx(interp, channelRet->closeCallback, + TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT); + Tcl_DecrRefCount(channelRet->closeCallback); + + /* + * More complications; we can't just unregister the channel, + * because it is in the middle of being cleaned up, and the cleanup + * code doesn't like a channel to be closed again while it is + * already being closed. So, we do the same trick as above to + * unregister it without cleanup. + */ + Tcl_DetachChannel(interp, chan); + + Tcl_RestoreResult(interp, &savedResult); + ckfree((char*)channelRet); +} + +int +VfsMatchInDirectory( + Tcl_Interp *cmdInterp, /* Interpreter to receive results. */ + Tcl_Obj *returnPtr, /* Interpreter to receive results. */ + Tcl_Obj *dirPtr, /* Contains path to directory to search. */ + char *pattern, /* Pattern to match against. */ + Tcl_GlobTypeData *types) /* Object containing list of acceptable types. + * May be NULL. */ +{ + Tcl_Obj *mountCmd = NULL; + Tcl_SavedResult savedResult; + int returnVal; + Tcl_Interp* interp; + int type = 0; + Tcl_Obj *vfsResultPtr = NULL; + + interp = (Tcl_Interp*) Tcl_FSData(&vfsFilesystem); + mountCmd = VfsCommand(interp, "matchindirectory", dirPtr); + if (mountCmd == NULL) { + return -1; + } + + if (types != NULL) { + type = types->type; + } + + Tcl_ListObjAppendElement(interp, mountCmd, Tcl_NewStringObj(pattern,-1)); + Tcl_ListObjAppendElement(interp, mountCmd, Tcl_NewIntObj(type)); + Tcl_SaveResult(interp, &savedResult); + /* Now we execute this mount point's callback. */ + returnVal = Tcl_EvalObjEx(interp, mountCmd, + TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT); + if (returnVal != -1) { + vfsResultPtr = Tcl_DuplicateObj(Tcl_GetObjResult(interp)); + } + Tcl_RestoreResult(interp, &savedResult); + Tcl_DecrRefCount(mountCmd); + + if (vfsResultPtr != NULL) { + if (returnVal == TCL_OK) { + Tcl_ListObjAppendList(cmdInterp, returnPtr, vfsResultPtr); + } else { + Tcl_SetObjResult(cmdInterp, vfsResultPtr); + } + } + return returnVal; +} + +int +VfsDeleteFile( + Tcl_Obj *pathPtr) /* Pathname of file to be removed (UTF-8). */ +{ + Tcl_Obj *mountCmd = NULL; + Tcl_SavedResult savedResult; + int returnVal; + Tcl_Interp* interp; + + interp = (Tcl_Interp*) Tcl_FSData(&vfsFilesystem); + mountCmd = VfsCommand(interp, "deletefile", pathPtr); + if (mountCmd == NULL) { + return -1; + } + + /* Now we execute this mount point's callback. */ + Tcl_SaveResult(interp, &savedResult); + returnVal = Tcl_EvalObjEx(interp, mountCmd, + TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT); + Tcl_RestoreResult(interp, &savedResult); + Tcl_DecrRefCount(mountCmd); + return returnVal; +} + +int +VfsCreateDirectory( + Tcl_Obj *pathPtr) /* Pathname of directory to create (UTF-8). */ +{ + Tcl_Obj *mountCmd = NULL; + Tcl_SavedResult savedResult; + int returnVal; + Tcl_Interp* interp; + + interp = (Tcl_Interp*) Tcl_FSData(&vfsFilesystem); + mountCmd = VfsCommand(interp, "createdirectory", pathPtr); + if (mountCmd == NULL) { + return -1; + } + + /* Now we execute this mount point's callback. */ + Tcl_SaveResult(interp, &savedResult); + returnVal = Tcl_EvalObjEx(interp, mountCmd, + TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT); + Tcl_RestoreResult(interp, &savedResult); + Tcl_DecrRefCount(mountCmd); + return returnVal; +} + +int +VfsRemoveDirectory( + Tcl_Obj *pathPtr, /* Pathname of directory to be removed + * (UTF-8). */ + int recursive, /* If non-zero, removes directories that + * are nonempty. Otherwise, will only remove + * empty directories. */ + Tcl_Obj **errorPtr) /* Location to store name of file + * causing error. */ +{ + Tcl_Obj *mountCmd = NULL; + Tcl_SavedResult savedResult; + int returnVal; + Tcl_Interp* interp; + + interp = (Tcl_Interp*) Tcl_FSData(&vfsFilesystem); + mountCmd = VfsCommand(interp, "removedirectory", pathPtr); + if (mountCmd == NULL) { + return -1; + } + + Tcl_ListObjAppendElement(interp, mountCmd, Tcl_NewIntObj(recursive)); + /* Now we execute this mount point's callback. */ + Tcl_SaveResult(interp, &savedResult); + returnVal = Tcl_EvalObjEx(interp, mountCmd, + TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT); + Tcl_RestoreResult(interp, &savedResult); + Tcl_DecrRefCount(mountCmd); + + if (returnVal == TCL_ERROR) { + /* Assume there was a problem with the directory being non-empty */ + if (errorPtr != NULL) { + *errorPtr = pathPtr; + } + Tcl_SetErrno(EEXIST); + } + return returnVal; +} + +char** +VfsFileAttrStrings(pathPtr, objPtrRef) + Tcl_Obj* pathPtr; + Tcl_Obj** objPtrRef; +{ + Tcl_Obj *mountCmd = NULL; + Tcl_SavedResult savedResult; + int returnVal; + Tcl_Interp* interp; + + interp = (Tcl_Interp*) Tcl_FSData(&vfsFilesystem); + mountCmd = VfsCommand(interp, "fileattributes", pathPtr); + if (mountCmd == NULL) { + *objPtrRef = NULL; + return NULL; + } + + Tcl_SaveResult(interp, &savedResult); + /* Now we execute this mount point's callback. */ + returnVal = Tcl_EvalObjEx(interp, mountCmd, + TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT); + if (returnVal == TCL_OK) { + *objPtrRef = Tcl_DuplicateObj(Tcl_GetObjResult(interp)); + } else { + *objPtrRef = NULL; + } + Tcl_RestoreResult(interp, &savedResult); + Tcl_DecrRefCount(mountCmd); + return NULL; +} + +int +VfsFileAttrsGet(cmdInterp, index, pathPtr, objPtrRef) + Tcl_Interp *cmdInterp; /* The interpreter for error reporting. */ + int index; /* index of the attribute command. */ + Tcl_Obj *pathPtr; /* filename we are operating on. */ + Tcl_Obj **objPtrRef; /* for output. */ +{ + Tcl_Obj *mountCmd = NULL; + Tcl_SavedResult savedResult; + int returnVal; + Tcl_Interp* interp; + + interp = (Tcl_Interp*) Tcl_FSData(&vfsFilesystem); + mountCmd = VfsCommand(interp, "fileattributes", pathPtr); + if (mountCmd == NULL) { + return -1; + } + + Tcl_ListObjAppendElement(interp, mountCmd, Tcl_NewIntObj(index)); + Tcl_SaveResult(interp, &savedResult); + /* Now we execute this mount point's callback. */ + returnVal = Tcl_EvalObjEx(interp, mountCmd, + TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT); + if (returnVal != -1) { + *objPtrRef = Tcl_DuplicateObj(Tcl_GetObjResult(interp)); + } + Tcl_RestoreResult(interp, &savedResult); + Tcl_DecrRefCount(mountCmd); + + if (returnVal != -1) { + if (returnVal == TCL_OK) { + Tcl_IncrRefCount(*objPtrRef); + } else { + /* Leave error message in correct interp */ + Tcl_SetObjResult(cmdInterp, *objPtrRef); + *objPtrRef = NULL; + } + } + + return returnVal; +} + +int +VfsFileAttrsSet(cmdInterp, index, pathPtr, objPtr) + Tcl_Interp *cmdInterp; /* The interpreter for error reporting. */ + int index; /* index of the attribute command. */ + Tcl_Obj *pathPtr; /* filename we are operating on. */ + Tcl_Obj *objPtr; /* for input. */ +{ + Tcl_Obj *mountCmd = NULL; + Tcl_SavedResult savedResult; + int returnVal; + Tcl_Interp* interp; + Tcl_Obj *errorPtr = NULL; + + interp = (Tcl_Interp*) Tcl_FSData(&vfsFilesystem); + mountCmd = VfsCommand(interp, "fileattributes", pathPtr); + if (mountCmd == NULL) { + return -1; + } + + Tcl_ListObjAppendElement(interp, mountCmd, Tcl_NewIntObj(index)); + Tcl_ListObjAppendElement(interp, mountCmd, objPtr); + Tcl_SaveResult(interp, &savedResult); + /* Now we execute this mount point's callback. */ + returnVal = Tcl_EvalObjEx(interp, mountCmd, + TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT); + if (returnVal != -1 && returnVal != TCL_OK) { + errorPtr = Tcl_DuplicateObj(Tcl_GetObjResult(interp)); + } + + Tcl_RestoreResult(interp, &savedResult); + Tcl_DecrRefCount(mountCmd); + + if (errorPtr != NULL) { + /* + * Leave error message in correct interp, errorPtr was + * duplicated above, in case of threading issues. + */ + Tcl_SetObjResult(cmdInterp, errorPtr); + } + + return returnVal; +} + +int +VfsUtime(pathPtr, tval) + Tcl_Obj* pathPtr; + struct utimbuf *tval; +{ + Tcl_Obj *mountCmd = NULL; + Tcl_SavedResult savedResult; + int returnVal; + Tcl_Interp* interp; + + interp = (Tcl_Interp*) Tcl_FSData(&vfsFilesystem); + mountCmd = VfsCommand(interp, "utime", pathPtr); + if (mountCmd == NULL) { + return -1; + } + + Tcl_ListObjAppendElement(interp, mountCmd, Tcl_NewLongObj(tval->actime)); + Tcl_ListObjAppendElement(interp, mountCmd, Tcl_NewLongObj(tval->modtime)); + /* Now we execute this mount point's callback. */ + Tcl_SaveResult(interp, &savedResult); + returnVal = Tcl_EvalObjEx(interp, mountCmd, + TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT); + Tcl_RestoreResult(interp, &savedResult); + Tcl_DecrRefCount(mountCmd); + + return returnVal; +} + + +/* + *---------------------------------------------------------------------- + * + * VfsCommand -- + * + * Build a portion of a command to be evaluated in Tcl. + * + * Results: + * Returns a list containing the command, or NULL if an + * error occurred. + * + * Side effects: + * None except memory allocation. + * + *---------------------------------------------------------------------- + */ + +static Tcl_Obj* +VfsCommand(Tcl_Interp* interp, CONST char* cmd, Tcl_Obj * pathPtr) { + Tcl_Obj *normed; + Tcl_Obj *mountCmd; + int len; + int splitPosition; + int dummyLen; + int returnVal; + VfsNativeRep *nativeRep; + char *normedString; + + nativeRep = VfsGetNativePath(pathPtr); + if (nativeRep == NULL) { + return NULL; + } + + splitPosition = nativeRep->splitPosition; + normed = Tcl_FSGetNormalizedPath(interp, pathPtr); + normedString = Tcl_GetStringFromObj(normed, &len); + + mountCmd = Tcl_DuplicateObj(nativeRep->fsCmd); + Tcl_IncrRefCount(mountCmd); + if (Tcl_ListObjLength(interp, mountCmd, &dummyLen) == TCL_ERROR) { + Tcl_DecrRefCount(mountCmd); + return NULL; + } + Tcl_ListObjAppendElement(interp, mountCmd, Tcl_NewStringObj(cmd,-1)); + if (splitPosition == len) { + Tcl_ListObjAppendElement(interp, mountCmd, normed); + Tcl_ListObjAppendElement(interp, mountCmd, Tcl_NewStringObj("",0)); + } else { + Tcl_ListObjAppendElement(interp, mountCmd, + Tcl_NewStringObj(normedString,splitPosition)); + Tcl_ListObjAppendElement(interp, mountCmd, + Tcl_NewStringObj(normedString+splitPosition+1, + len-splitPosition-1)); + } + Tcl_ListObjAppendElement(interp, mountCmd, pathPtr); + + return mountCmd; +} + +static +void VfsExitProc(ClientData clientData) +{ + Tcl_FSUnregister(&vfsFilesystem); +} + diff --git a/install-sh b/install-sh new file mode 100644 index 0000000..0ff4b6a --- /dev/null +++ b/install-sh @@ -0,0 +1,119 @@ +#!/bin/sh + +# +# install - install a program, script, or datafile +# This comes from X11R5; it is not part of GNU. +# +# $XConsortium: install.sh,v 1.2 89/12/18 14:47:22 jim Exp $ +# +# This script is compatible with the BSD install script, but was written +# from scratch. +# + + +# set DOITPROG to echo to test this script + +# Don't use :- since 4.3BSD and earlier shells don't like it. +doit="${DOITPROG-}" + + +# put in absolute paths if you don't have them in your path; or use env. vars. + +mvprog="${MVPROG-mv}" +cpprog="${CPPROG-cp}" +chmodprog="${CHMODPROG-chmod}" +chownprog="${CHOWNPROG-chown}" +chgrpprog="${CHGRPPROG-chgrp}" +stripprog="${STRIPPROG-strip}" +rmprog="${RMPROG-rm}" + +instcmd="$mvprog" +chmodcmd="" +chowncmd="" +chgrpcmd="" +stripcmd="" +rmcmd="$rmprog -f" +mvcmd="$mvprog" +src="" +dst="" + +while [ x"$1" != x ]; do + case $1 in + -c) instcmd="$cpprog" + shift + continue;; + + -m) chmodcmd="$chmodprog $2" + shift + shift + continue;; + + -o) chowncmd="$chownprog $2" + shift + shift + continue;; + + -g) chgrpcmd="$chgrpprog $2" + shift + shift + continue;; + + -s) stripcmd="$stripprog" + shift + continue;; + + *) if [ x"$src" = x ] + then + src=$1 + else + dst=$1 + fi + shift + continue;; + esac +done + +if [ x"$src" = x ] +then + echo "install: no input file specified" + exit 1 +fi + +if [ x"$dst" = x ] +then + echo "install: no destination specified" + exit 1 +fi + + +# If destination is a directory, append the input filename; if your system +# does not like double slashes in filenames, you may need to add some logic + +if [ -d $dst ] +then + dst="$dst"/`basename $src` +fi + +# Make a temp file name in the proper directory. + +dstdir=`dirname $dst` +dsttmp=$dstdir/#inst.$$# + +# Move or copy the file name to the temp name + +$doit $instcmd $src $dsttmp + +# and set any options; do chmod last to preserve setuid bits + +if [ x"$chowncmd" != x ]; then $doit $chowncmd $dsttmp; fi +if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dsttmp; fi +if [ x"$stripcmd" != x ]; then $doit $stripcmd $dsttmp; fi +if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dsttmp; fi + +# Now rename the file to the real destination. + +$doit $rmcmd $dst +$doit $mvcmd $dsttmp $dst + + +exit 0 diff --git a/library/ftpvfs.tcl b/library/ftpvfs.tcl new file mode 100644 index 0000000..472a3c1 --- /dev/null +++ b/library/ftpvfs.tcl @@ -0,0 +1,92 @@ + +package require vfs 1.0 +package require ftp + +namespace eval vfs::ftp {} + +proc vfs::ftp::Mount {dirurl local} { + regexp {(([^:]*)(:([^@]*))?@)?([^/]*)/(.*/)?([^/]*)$} $dirurl \ + junk junk user junk pass host path file + + set fd [::ftp::Open $host $user $pass $path] + ::ftp::Cd $fd $path + puts "ftp $host, $path mounted at $fd" + vfs::filesystem mount $local [list vfs::ftp::handler $fd $path] + return $fd +} + +proc vfs::ftp::Unmount {fd} { + ::ftp::Close $fd +} + +proc vfs::ftp::handler {fd path cmd root relative actualpath args} { + eval [list $cmd $fd $path $relative] $args +} + +# If we implement the commands below, we will have a perfect +# virtual file system for remote ftp sites. + +proc vfs::ftp::stat {fd path name} { + puts "stat $name" +} + +proc vfs::ftp::access {fd path name mode} { + puts "access $name $mode" +} + +proc vfs::ftp::open {fd name mode permissions} { + puts "open $name $mode $permissions" + # return a list of two elements: + # 1. first element is the Tcl channel name which has been opened + # 2. second element (optional) is a command to evaluate when + # the channel is closed. + return [list] +} + +proc vfs::ftp::matchindirectory {fd prefix path pattern type} { + puts "matchindirectory $path $pattern $type" + set ftpList [ftp::List $fd $path] + puts "ftpList: $ftpList" + set res [list] + + if {[::vfs::matchDirectories $type]} { + # add matching directories to $res + } + + if {[::vfs::matchFiles $type]} { + # add matching files to $res + } + return $res +} + +proc vfs::ftp::createdirectory {fd name} { + puts "createdirectory $name" +} + +proc vfs::ftp::removedirectory {fd name} { + puts "removedirectory $name" +} + +proc vfs::ftp::deletefile {fd name} { + puts "deletefile $name" +} + +proc vfs::ftp::fileattributes {fd path args} { + puts "fileattributes $args" + switch -- [llength $args] { + 0 { + # list strings + return [list] + } + 1 { + # get value + set index [lindex $args 0] + } + 2 { + # set value + set index [lindex $args 0] + set val [lindex $args 1] + } + } +} + diff --git a/library/pkgIndex.tcl b/library/pkgIndex.tcl new file mode 100644 index 0000000..df2a0aa --- /dev/null +++ b/library/pkgIndex.tcl @@ -0,0 +1,12 @@ +# Tcl package index file, version 1.1 +# This file is generated by the "pkg_mkIndex" command +# and sourced either when an application starts up or +# by a "package unknown" script. It invokes the +# "package ifneeded" command to set up package-related +# information so that packages will be loaded automatically +# in response to "package require" commands. When this +# script is sourced, the variable $dir must contain the +# full path name of this file's directory. + +lappend auto_path $dir +package ifneeded vfs 1.0 [list load [file join $dir vfs10[info sharedlibextension]]] diff --git a/library/tclIndex b/library/tclIndex new file mode 100644 index 0000000..dbacdf3 --- /dev/null +++ b/library/tclIndex @@ -0,0 +1,74 @@ +# Tcl autoload index file, version 2.0 +# This file is generated by the "auto_mkindex" command +# and sourced to set up indexing information for one or +# more commands. Typically each line is a command that +# sets an element in the auto_index array, where the +# element name is the name of a command and the value is +# a script that loads the command. + +set auto_index(::vfs::ftp::Mount) [list source [file join $dir ftpvfs.tcl]] +set auto_index(::vfs::ftp::Unmount) [list source [file join $dir ftpvfs.tcl]] +set auto_index(::vfs::ftp::handler) [list source [file join $dir ftpvfs.tcl]] +set auto_index(::vfs::ftp::stat) [list source [file join $dir ftpvfs.tcl]] +set auto_index(::vfs::ftp::access) [list source [file join $dir ftpvfs.tcl]] +set auto_index(::vfs::ftp::open) [list source [file join $dir ftpvfs.tcl]] +set auto_index(::vfs::ftp::matchindirectory) [list source [file join $dir ftpvfs.tcl]] +set auto_index(::vfs::ftp::createdirectory) [list source [file join $dir ftpvfs.tcl]] +set auto_index(::vfs::ftp::removedirectory) [list source [file join $dir ftpvfs.tcl]] +set auto_index(::vfs::ftp::deletefile) [list source [file join $dir ftpvfs.tcl]] +set auto_index(::vfs::ftp::fileattributes) [list source [file join $dir ftpvfs.tcl]] +set auto_index(::vfs::tclproc::Mount) [list source [file join $dir tclprocvfs.tcl]] +set auto_index(::vfs::tclproc::Unmount) [list source [file join $dir tclprocvfs.tcl]] +set auto_index(::vfs::tclproc::handler) [list source [file join $dir tclprocvfs.tcl]] +set auto_index(::vfs::tclproc::stat) [list source [file join $dir tclprocvfs.tcl]] +set auto_index(::vfs::tclproc::access) [list source [file join $dir tclprocvfs.tcl]] +set auto_index(::vfs::tclproc::exists) [list source [file join $dir tclprocvfs.tcl]] +set auto_index(::vfs::tclproc::open) [list source [file join $dir tclprocvfs.tcl]] +set auto_index(::vfs::tclproc::matchindirectory) [list source [file join $dir tclprocvfs.tcl]] +set auto_index(::vfs::tclproc::createdirectory) [list source [file join $dir tclprocvfs.tcl]] +set auto_index(::vfs::tclproc::removedirectory) [list source [file join $dir tclprocvfs.tcl]] +set auto_index(::vfs::tclproc::deletefile) [list source [file join $dir tclprocvfs.tcl]] +set auto_index(::vfs::tclproc::fileattributes) [list source [file join $dir tclprocvfs.tcl]] +set auto_index(::vfs::testMount) [list source [file join $dir testvfs.tcl]] +set auto_index(::vfs::test::handler) [list source [file join $dir testvfs.tcl]] +set auto_index(::vfs::test::stat) [list source [file join $dir testvfs.tcl]] +set auto_index(::vfs::test::access) [list source [file join $dir testvfs.tcl]] +set auto_index(::vfs::test::open) [list source [file join $dir testvfs.tcl]] +set auto_index(::vfs::test::matchindirectory) [list source [file join $dir testvfs.tcl]] +set auto_index(::vfs::test::createdirectory) [list source [file join $dir testvfs.tcl]] +set auto_index(::vfs::test::removedirectory) [list source [file join $dir testvfs.tcl]] +set auto_index(::vfs::test::deletefile) [list source [file join $dir testvfs.tcl]] +set auto_index(::vfs::test::fileattributes) [list source [file join $dir testvfs.tcl]] +set auto_index(::vfs::autoMountExtension) [list source [file join $dir vfsUtils.tcl]] +set auto_index(::vfs::autoMountUrl) [list source [file join $dir vfsUtils.tcl]] +set auto_index(::vfs::haveMount) [list source [file join $dir vfsUtils.tcl]] +set auto_index(::vfs::urlMount) [list source [file join $dir vfsUtils.tcl]] +set auto_index(::vfs::fileUrlMount) [list source [file join $dir vfsUtils.tcl]] +set auto_index(::vfs::auto) [list source [file join $dir vfsUtils.tcl]] +set auto_index(::vfs::matchCorrectTypes) [list source [file join $dir vfsUtils.tcl]] +set auto_index(::vfs::accessMode) [list source [file join $dir vfsUtils.tcl]] +set auto_index(::vfs::matchDirectories) [list source [file join $dir vfsUtils.tcl]] +set auto_index(::vfs::matchFiles) [list source [file join $dir vfsUtils.tcl]] +set auto_index(::vfs::modeToString) [list source [file join $dir vfsUtils.tcl]] +set auto_index(::vfs::zip::Mount) [list source [file join $dir zipvfs.tcl]] +set auto_index(::vfs::zip::Unmount) [list source [file join $dir zipvfs.tcl]] +set auto_index(::vfs::zip::handler) [list source [file join $dir zipvfs.tcl]] +set auto_index(::vfs::zip::matchindirectory) [list source [file join $dir zipvfs.tcl]] +set auto_index(::vfs::zip::stat) [list source [file join $dir zipvfs.tcl]] +set auto_index(::vfs::zip::access) [list source [file join $dir zipvfs.tcl]] +set auto_index(::vfs::zip::open) [list source [file join $dir zipvfs.tcl]] +set auto_index(::vfs::zip::createdirectory) [list source [file join $dir zipvfs.tcl]] +set auto_index(::vfs::zip::removedirectory) [list source [file join $dir zipvfs.tcl]] +set auto_index(::vfs::zip::deletefile) [list source [file join $dir zipvfs.tcl]] +set auto_index(::vfs::zip::fileattributes) [list source [file join $dir zipvfs.tcl]] +set auto_index(::zip::u_short) [list source [file join $dir zipvfs.tcl]] +set auto_index(::zip::DosTime) [list source [file join $dir zipvfs.tcl]] +set auto_index(::zip::Data) [list source [file join $dir zipvfs.tcl]] +set auto_index(::zip::EndOfArchive) [list source [file join $dir zipvfs.tcl]] +set auto_index(::zip::TOC) [list source [file join $dir zipvfs.tcl]] +set auto_index(::zip::open) [list source [file join $dir zipvfs.tcl]] +set auto_index(::zip::FAKEDIR) [list source [file join $dir zipvfs.tcl]] +set auto_index(::zip::exists) [list source [file join $dir zipvfs.tcl]] +set auto_index(::zip::stat) [list source [file join $dir zipvfs.tcl]] +set auto_index(::zip::getdir) [list source [file join $dir zipvfs.tcl]] +set auto_index(::zip::_close) [list source [file join $dir zipvfs.tcl]] diff --git a/library/tclprocvfs.tcl b/library/tclprocvfs.tcl new file mode 100644 index 0000000..d98876c --- /dev/null +++ b/library/tclprocvfs.tcl @@ -0,0 +1,183 @@ + +package require vfs 1.0 + +# Thanks to jcw for the idea here. This is a 'file system' which +# is actually a representation of the Tcl command namespace hierarchy. +# Namespaces are directories, and procedures are files. Tcl allows +# procedures with the same name as a namespace, which are hidden in +# a filesystem representation. + +namespace eval vfs::tclproc {} + +proc vfs::tclproc::Mount {ns local} { + if {![namespace exists ::$ns]} { + error "No such namespace" + } + puts "tclproc $ns mounted at $local" + vfs::filesystem mount $local [list vfs::tclproc::handler $ns] +} + +proc vfs::tclproc::Unmount {ns} { +} + +proc vfs::tclproc::handler {ns cmd root relative actualpath args} { + regsub -all / $relative :: relative + if {$cmd == "matchindirectory"} { + eval [list $cmd $ns $relative $actualpath] $args + } else { + eval [list $cmd $ns $relative] $args + } +} + +# If we implement the commands below, we will have a perfect +# virtual file system for remote tclproc sites. + +proc vfs::tclproc::stat {ns name} { + puts stderr "stat $name" + if {[namespace exists ::${ns}::${name}]} { + puts "directory" + return [list type directory size 0 mode 0777 \ + ino -1 depth 0 name $name atime 0 ctime 0 mtime 0 dev -1 \ + uid -1 gid -1 nlink 1] + } elseif {[llength [info procs ::${ns}::${name}]]} { + puts "file" + return [list type file] + } else { + return -code error "could not read \"$name\": no such file or directory" + } +} + +proc vfs::tclproc::access {ns name mode} { + puts stderr "access $name $mode" + if {[namespace exists ::${ns}::${name}]} { + return 1 + } elseif {[llength [info procs ::${ns}::${name}]]} { + if {$mode & 2} { + error "read-only" + } + return 1 + } else { + error "No such file" + } +} + +proc vfs::tclproc::exists {ns name} { + if {[namespace exists ::${ns}::${name}]} { + return 1 + } elseif {[llength [info procs ::${ns}::${name}]]} { + return 1 + } else { + return 0 + } +} + +proc vfs::tclproc::open {ns name mode permissions} { + puts stderr "open $name $mode $permissions" + # return a list of two elements: + # 1. first element is the Tcl channel name which has been opened + # 2. second element (optional) is a command to evaluate when + # the channel is closed. + switch -- $mode { + "" - + "r" { + package require Memchan + + set nfd [memchan] + fconfigure $nfd -translation binary + puts -nonewline $nfd [_generate ::${ns}::${name}] + fconfigure $nfd -translation auto + seek $nfd 0 + return [list $nfd] + } + default { + return -code error "illegal access mode \"$mode\"" + } + } +} + +proc vfs::tclproc::_generate {p} { + lappend a proc $p + set argslist [list] + foreach arg [info args $p] { + if {[info default $p $arg v]} { + lappend argslist [list $arg $v] + } else { + lappend argslist $arg + } + } + lappend a $argslist [info body $p] +} + +proc vfs::tclproc::matchindirectory {ns path actualpath pattern type} { + puts stderr "matchindirectory $path $actualpath $pattern $type" + set res [list] + + if {[::vfs::matchDirectories $type]} { + # add matching directories to $res + eval lappend res [namespace children ::${ns}::${path} $pattern] + } + + if {[::vfs::matchFiles $type]} { + # add matching files to $res + eval lappend res [info procs ::${ns}::${path}::$pattern] + } + set realres [list] + foreach r $res { + regsub "^(::)?${ns}(::)?${path}(::)?" $r $actualpath rr + lappend realres $rr + } + #puts $realres + + return $realres +} + +proc vfs::tclproc::createdirectory {ns name} { + puts stderr "createdirectory $name" + namespace eval ::${ns}::${name} {} +} + +proc vfs::tclproc::removedirectory {ns name} { + puts stderr "removedirectory $name" + namespace delete ::${ns}::${name} +} + +proc vfs::tclproc::deletefile {ns name} { + puts stderr "deletefile $name" + rename ::${ns}::${name} {} +} + +proc vfs::tclproc::fileattributes {ns name args} { + puts stderr "fileattributes $args" + switch -- [llength $args] { + 0 { + # list strings + return [list -args -body] + } + 1 { + # get value + set index [lindex $args 0] + switch -- $index { + 0 { + ::info args ::${ns}::${name} + } + 1 { + ::info body ::${ns}::${name} + } + } + } + 2 { + # set value + set index [lindex $args 0] + set val [lindex $args 1] + switch -- $index { + 0 { + error "read-only" + } + 1 { + error "unimplemented" + } + } + } + } +} + diff --git a/library/testvfs.tcl b/library/testvfs.tcl new file mode 100644 index 0000000..321f753 --- /dev/null +++ b/library/testvfs.tcl @@ -0,0 +1,77 @@ + +package require vfs 1.0 + +proc vfs::testMount {what local} { + vfs::filesystem mount $local [list vfs::test::handler $what] +} + +namespace eval vfs::test {} + +proc vfs::test::handler {what cmd root relative actualpath args} { + eval [list $cmd $what $relative] $args +} + +# If we implement the commands below, we will have a perfect +# virtual file system. + +proc vfs::test::stat {what name} { + puts "stat $name" +} + +proc vfs::test::access {what name mode} { + puts "access $name $mode" +} + +proc vfs::test::open {what name mode permissions} { + puts "open $name $mode $permissions" + # return a list of two elements: + # 1. first element is the Tcl channel name which has been opened + # 2. second element (optional) is a command to evaluate when + # the channel is closed. + return [list] +} + +proc vfs::test::matchindirectory {what path pattern type} { + puts "matchindirectory $path $pattern $type" + set res [list] + + if {[::vfs::matchDirectories $type]} { + # add matching directories to $res + } + + if {[::vfs::matchFiles $type]} { + # add matching files to $res + } + return $res +} + +proc vfs::test::createdirectory {what name} { + puts "createdirectory $name" +} + +proc vfs::test::removedirectory {what name} { + puts "removedirectory $name" +} + +proc vfs::test::deletefile {what name} { + puts "deletefile $name" +} + +proc vfs::test::fileattributes {what args} { + puts "fileattributes $args" + switch -- [llength $args] { + 0 { + # list strings + } + 1 { + # get value + set index [lindex $args 0] + } + 2 { + # set value + set index [lindex $args 0] + set val [lindex $args 1] + } + } +} + diff --git a/library/vfs10.dll b/library/vfs10.dll new file mode 100644 index 0000000..c10e16d Binary files /dev/null and b/library/vfs10.dll differ diff --git a/library/vfsUtils.tcl b/library/vfsUtils.tcl new file mode 100644 index 0000000..c581891 --- /dev/null +++ b/library/vfsUtils.tcl @@ -0,0 +1,139 @@ + +package require vfs + +proc ::vfs::autoMountExtension {ext cmd {pkg ""}} { + variable extMounts + set extMounts($ext) [list $cmd $pkg] +} + +proc ::vfs::autoMountUrl {type cmd {pkg ""}} { + variable urlMounts + set urlMounts($type) [list $cmd $pkg] +} + +::vfs::autoMountExtension .zip ::vfs::zip::Mount vfs +::vfs::autoMountUrl ftp ::vfs::ftp::Mount vfs +::vfs::autoMountUrl file ::vfs::fileUrlMount vfs +::vfs::autoMountUrl tclns ::vfs::tclprocMount vfs + +proc ::vfs::haveMount {url} { + variable mounted + info exists mounted($url) +} + +proc ::vfs::urlMount {url args} { + puts "$url $args" + variable urlMounts + if {[regexp {^([a-zA-Z]+)://(.*)} $url "" urltype rest]} { + if {[info exists urlMounts($urltype)]} { + #::vfs::log "automounting $path" + foreach {cmd pkg} $urlMounts($urltype) {} + if {[string length $pkg]} { + package require $pkg + } + eval $cmd [list $url] $args + variable mounted + set mounted($url) 1 + return + } + error "Unknown url type '$urltype'" + } + error "Couldn't parse url $url" +} + +proc ::vfs::fileUrlMount {url args} { + # Strip off the leading 'file://' + set file [string range $url 7 end] + eval [list ::vfs::auto $file] $args +} + +proc ::vfs::tclprocMount {url args} { + # Strip off the leading 'tclns://' + set ns [string range $url 8 end] + eval [list ::vfs::tclproc::Mount $ns] $args +} + +proc ::vfs::auto {filename args} { + variable extMounts + + set np {} + + set split [::file split $filename] + + foreach ele $split { + lappend np $ele + set path [::file normalize [eval [list ::file join] $np]] + if {[::file isdirectory $path]} { + # already mounted + continue + } elseif {[::file isfile $path]} { + set ext [string tolower [::file extension $ele]] + if {[::info exists extMounts($ext)]} { + #::vfs::log "automounting $path" + foreach {cmd pkg} $extMounts($ext) {} + if {[string length $pkg]} { + package require $pkg + } + eval $cmd [list $path $path] $args + } else { + continue + } + } else { + # It doesn't exist, so just return + # return -code error "$path doesn't exist" + return + } + } +} + +# Helper procedure for vfs matchindirectory +# implementations. It is very important that +# we match properly when given 'directory' +# specifications, since this is used for +# recursive globbing by Tcl. +proc vfs::matchCorrectTypes {types filelist} { + if {$types != 0} { + # Which types to return. We must do special + # handling of directories and files. + set file [matchFiles $types] + set dir [matchDirectories $types] + if {$file && $dir} { + return $filelist + } + if {$file == 0 && $dir == 0} { + return [list] + } + set newres [list] + if {$file} { + foreach r $filelist { + if {[::file isfile $r]} { + lappend newres $r + } + } + } else { + foreach r $filelist { + if {[::file isdirectory $r]} { + lappend newres $r + } + } + } + set filelist $newres + } + return $filelist +} + +# Convert integer mode to a somewhat preferable string. +proc vfs::accessMode {mode} { + lindex [list F X W XW R RX RW] $mode +} + +proc vfs::matchDirectories {types} { + return [expr {$types == 0 ? 1 : $types & (1<<2)}] +} + +proc vfs::matchFiles {types} { + return [expr {$types == 0 ? 1 : $types & (1<<4)}] +} + +proc vfs::modeToString {mode} { +} diff --git a/library/zipvfs.tcl b/library/zipvfs.tcl new file mode 100644 index 0000000..4a2602c --- /dev/null +++ b/library/zipvfs.tcl @@ -0,0 +1,566 @@ + +package require vfs 1.0 + +# Using the vfs, memchan and Trf extensions, we ought to be able +# to write a Tcl-only zip virtual filesystem. + +namespace eval vfs::zip {} + +proc vfs::zip::Mount {zipfile local} { + set fd [::zip::open [::file normalize $zipfile]] + vfs::filesystem mount $local [list vfs::zip::handler $fd] + return $fd +} + +proc vfs::zip::Unmount {fd} { + ::zip::_close $fd +} + +proc vfs::zip::handler {zipfd cmd root relative actualpath args} { + #puts [list $zipfd $cmd $root $relative $actualpath $args] + #update + if {$cmd == "matchindirectory"} { + eval [list $cmd $zipfd $relative $actualpath] $args + } else { + eval [list $cmd $zipfd $relative] $args + } +} + +# If we implement the commands below, we will have a perfect +# virtual file system for zip files. + +proc vfs::zip::matchindirectory {zipfd path actualpath pattern type} { + puts stderr [list matchindirectory $path $actualpath $pattern $type] + set res [::zip::getdir $zipfd $path $pattern] + set newres [list] + foreach p [::vfs::matchCorrectTypes $type $res] { + lappend newres "$actualpath$p" + } + #puts "got $newres" + return $newres +} + +proc vfs::zip::stat {zipfd name} { + puts "stat $name" + ::zip::stat $zipfd $name sb + puts [array get sb] + array get sb +} + +proc vfs::zip::access {zipfd name mode} { + puts "zip-access $name $mode" + if {$mode & 2} { + error "read-only" + } + # Readable, Exists and Executable are treated as 'exists' + # Could we get more information from the archive? + if {[::zip::exists $zipfd $name]} { + return 1 + } else { + error "No such file" + } + +} + +proc vfs::zip::open {zipfd name mode permissions} { + puts "open $name $mode $permissions" + # return a list of two elements: + # 1. first element is the Tcl channel name which has been opened + # 2. second element (optional) is a command to evaluate when + # the channel is closed. + + switch -- $mode { + "" - + "r" { + ::zip::stat $zipfd $name sb + + package require Trf + package require Memchan + + set nfd [memchan] + fconfigure $nfd -translation binary + + seek $zipfd $sb(ino) start + zip::Data $zipfd sb data + + puts -nonewline $nfd $data + + fconfigure $nfd -translation auto + seek $nfd 0 + return [list $nfd] + } + default { + return -code error "illegal access mode \"$mode\"" + } + } +} + +proc vfs::zip::createdirectory {zipfd name} { + puts stderr "createdirectory $name" + error "read-only" +} + +proc vfs::zip::removedirectory {zipfd name} { + puts stderr "removedirectory $name" + error "read-only" +} + +proc vfs::zip::deletefile {zipfd name} { + puts "deletefile $name" + error "read-only" +} + +proc vfs::zip::fileattributes {zipfd name args} { + puts "fileattributes $args" + switch -- [llength $args] { + 0 { + # list strings + return [list] + } + 1 { + # get value + set index [lindex $args 0] + return "" + } + 2 { + # set value + set index [lindex $args 0] + set val [lindex $args 1] + error "read-only" + } + } +} + +# Below copied from TclKit distribution + +# +# ZIP decoder: +# +# Format of zip file: +# [ Data ]* [ TOC ]* EndOfArchive +# +# Note: TOC is refered to in ZIP doc as "Central Archive" +# +# This means there are two ways of accessing: +# +# 1) from the begining as a stream - until the header +# is not "PK\03\04" - ideal for unzipping. +# +# 2) for table of contents without reading entire +# archive by first fetching EndOfArchive, then +# just loading the TOC +# +package provide vfs.zip 0.5 + +namespace eval zip { + array set methods { + 0 {stored - The file is stored (no compression)} + 1 {shrunk - The file is Shrunk} + 2 {reduce1 - The file is Reduced with compression factor 1} + 3 {reduce2 - The file is Reduced with compression factor 2} + 4 {reduce3 - The file is Reduced with compression factor 3} + 5 {reduce4 - The file is Reduced with compression factor 4} + 6 {implode - The file is Imploded} + 7 {reserved - Reserved for Tokenizing compression algorithm} + 8 {deflate - The file is Deflated} + 9 {reserved - Reserved for enhanced Deflating} + 10 {pkimplode - PKWARE Date Compression Library Imploding} + } + # Version types (high-order byte) + array set systems { + 0 {dos} + 1 {amiga} + 2 {vms} + 3 {unix} + 4 {vm cms} + 5 {atari} + 6 {os/2} + 7 {macos} + 8 {z system 8} + 9 {cp/m} + 10 {tops20} + 11 {windows} + 12 {qdos} + 13 {riscos} + 14 {vfat} + 15 {mvs} + 16 {beos} + 17 {tandem} + 18 {theos} + } + # DOS File Attrs + array set dosattrs { + 1 {readonly} + 2 {hidden} + 4 {system} + 8 {unknown8} + 16 {directory} + 32 {archive} + 64 {unknown64} + 128 {normal} + } + + proc u_short {n} { return [expr { ($n+0x10000)%0x10000 }] } +} + +proc zip::DosTime {date time} { + set time [u_short $time] + set date [u_short $date] + + set sec [expr { ($time & 0x1F) * 2 }] + set min [expr { ($time >> 5) & 0x3F }] + set hour [expr { ($time >> 11) & 0x1F }] + + set mday [expr { $date & 0x1F }] + set mon [expr { (($date >> 5) & 0xF) }] + set year [expr { (($date >> 9) & 0xFF) + 1980 }] + + set dt [format {%4.4d-%2.2d-%2.2d %2.2d:%2.2d:%2.2d} \ + $year $mon $mday $hour $min $sec] + return [clock scan $dt -gmt 1] +} + + +proc zip::Data {fd arr {varPtr ""} {verify 0}} { + upvar 1 $arr sb + + if { $varPtr != "" } { + upvar 1 $varPtr data + } + + set buf [read $fd 30] + set n [binary scan $buf A4sssssiiiss \ + hdr sb(ver) sb(flags) sb(method) \ + time date \ + sb(crc) sb(csize) sb(size) flen elen] + + if { ![string equal "PK\03\04" $hdr] } { + error "bad header: [hexdump $hdr]" + } + set sb(ver) [u_short $sb(ver)] + set sb(flags) [u_short $sb(flags)] + set sb(method) [u_short $sb(method)] + set sb(mtime) [DosTime $date $time] + + set sb(name) [read $fd [u_short $flen]] + set sb(extra) [read $fd [u_short $elen]] + + if { $varPtr == "" } { + seek $fd $sb(csize) current + } else { + set data [read $fd $sb(csize)] + } + + if { $sb(flags) & 0x4 } { + # Data Descriptor used + set buf [read $fd 12] + binary scan $buf iii sb(crc) sb(csize) sb(size) + } + + + if { $varPtr == "" } { + return "" + } + + if { $sb(method) != 0 } { + if { [catch { + set data [zip -mode decompress -nowrap 1 $data] + } err] } { + puts "$sb(name): inflate error: $err" + puts [hexdump $data] + } + } + return + if { $verify } { + set ncrc [pink zlib crc $data] + if { $ncrc != $sb(crc) } { + tclLog [format {%s: crc mismatch: expected 0x%x, got 0x%x} \ + $sb(name) $sb(crc) $ncrc] + } + } +} + +proc zip::EndOfArchive {fd arr} { + upvar 1 $arr cb + + seek $fd -22 end + set pos [tell $fd] + set hdr [read $fd 22] + + binary scan $hdr A4ssssiis xhdr \ + cb(ndisk) cb(cdisk) \ + cb(nitems) cb(ntotal) \ + cb(csize) cb(coff) \ + cb(comment) + + if { ![string equal "PK\05\06" $xhdr]} { + error "bad header" + } + + set cb(ndisk) [u_short $cb(ndisk)] + set cb(nitems) [u_short $cb(nitems)] + set cb(ntotal) [u_short $cb(ntotal)] + set cb(comment) [u_short $cb(comment)] + + # Compute base for situations where ZIP file + # has been appended to another media (e.g. EXE) + set cb(base) [expr { $pos - $cb(csize) - $cb(coff) }] +} + +proc zip::TOC {fd arr} { + upvar 1 $arr sb + + set buf [read $fd 46] + + binary scan $buf A4ssssssiiisssssii hdr \ + sb(vem) sb(ver) sb(flags) sb(method) time date \ + sb(crc) sb(csize) sb(size) \ + flen elen clen sb(disk) sb(attr) \ + sb(atx) sb(ino) + + if { ![string equal "PK\01\02" $hdr] } { + error "bad central header: [hexdump $buf]" + } + + foreach v {vem ver flags method disk attr} { + set cb($v) [u_short [set sb($v)]] + } + + set sb(mtime) [DosTime $date $time] + set sb(mode) [expr { ($sb(atx) >> 16) & 0xffff }] + if { ( $sb(atx) & 0xff ) & 16 } { + set sb(type) directory + } else { + set sb(type) file + } + set sb(name) [read $fd [u_short $flen]] + set sb(extra) [read $fd [u_short $elen]] + set sb(comment) [read $fd [u_short $clen]] +} + +proc zip::open {path} { + set fd [::open $path] + upvar #0 zip::$fd cb + upvar #0 zip::$fd.toc toc + + fconfigure $fd -translation binary ;#-buffering none + + zip::EndOfArchive $fd cb + + seek $fd $cb(coff) start + + set toc(_) 0; unset toc(_); #MakeArray + + for { set i 0 } { $i < $cb(nitems) } { incr i } { + zip::TOC $fd sb + + set sb(depth) [llength [file split $sb(name)]] + + set name [string tolower $sb(name)] + set toc($name) [array get sb] + FAKEDIR toc [file dirname $name] + } + + return $fd +} + +proc zip::FAKEDIR {arr path} { + upvar 1 $arr toc + + if { $path == "."} { return } + + + if { ![info exists toc($path)] } { + # Implicit directory + lappend toc($path) \ + name $path \ + type directory mtime 0 size 0 mode 0777 \ + ino -1 depth [llength [file split $path]] + } + FAKEDIR toc [file dirname $path] +} + +proc zip::exists {fd path} { + #puts stderr "$fd $path" + if {$path == ""} { + return 1 + } else { + upvar #0 zip::$fd.toc toc + info exists toc([string tolower $path]) + } +} + +proc zip::stat {fd path arr} { + upvar #0 zip::$fd.toc toc + upvar 1 $arr sb + + set name [string tolower $path] + if { $name == "" || $name == "." } { + array set sb { + type directory mtime 0 size 0 mode 0777 + ino -1 depth 0 name "" + } + } elseif {![info exists toc($name)] } { + return -code error "could not read \"$path\": no such file or directory" + } else { + array set sb $toc($name) + } + set sb(dev) -1 + set sb(uid) -1 + set sb(gid) -1 + set sb(nlink) 1 + set sb(atime) $sb(mtime) + set sb(ctime) $sb(mtime) + return "" +} + +proc zip::getdir {fd path {pat *}} { +# puts stderr [list getdir $fd $path $pat] + upvar #0 zip::$fd.toc toc + + if { $path == "." || $path == "" } { + set path $pat + } else { + set path [string tolower $path] + append path /$pat + } + set depth [llength [file split $path]] + + set ret {} + foreach key [array names toc $path] { + if {[string index $key end] == "/"} { + # Directories are listed twice: both with and without + # the trailing '/', so we ignore the one with + continue + } + array set sb $toc($key) + + if { $sb(depth) == $depth } { + if {[info exists toc(${key}/)]} { + array set sb $toc(${key}/) + } + lappend ret [file tail $sb(name)] + } else { + #puts "$sb(depth) vs $depth for $sb(name)" + } + unset sb + } + return $ret +} + +proc zip::_close {fd} { + variable $fd + variable $fd.toc + unset $fd + unset $fd.toc +} +# +# +return +# +# DEMO UNZIP -L PROGRAM +# +array set opts { + -datefmt {%m-%d-%y %H:%M} + -verbose 1 + -extract 0 + -debug 0 +} +set file [lindex $argv 0] +array set opts [lrange $argv 1 end] + +set fd [open $file] +fconfigure $fd -translation binary ;#-buffering none + +if { !$opts(-extract) } { + if { !$opts(-verbose) } { + puts " Length Date Time Name" + puts " ------ ---- ---- ----" + } else { + puts " Length Method Size Ratio Date Time CRC-32 Name" + puts " ------ ------ ---- ----- ---- ---- ------ ----" + } +} + +zip::EndOfArchive $fd cb + +seek $fd $cb(coff) start + +set TOC {} +for { set i 0 } { $i < $cb(nitems) } { incr i } { + + zip::TOC $fd sb + + lappend TOC $sb(name) $sb(ino) + + if { $opts(-extract) } { + continue + } + + if { !$opts(-verbose) } { + puts [format {%7d %-16s %s} $sb(size) \ + [clock format $sb(mtime) -format $opts(-datefmt) -gmt 1] \ + $sb(name)] + } else { + if { $sb(size) > 0 } { + set cr [expr { 100 - 100 * $sb(csize) / double($sb(size)) }] + } else { + set cr 0 + } + puts [format {%7d %6.6s %7d %3.0f%% %s %8.8x %s} \ + $sb(size) [lindex $::zip::methods($sb(method)) 0] \ + $sb(csize) $cr \ + [clock format $sb(mtime) -format $opts(-datefmt) -gmt 1] \ + $sb(crc) $sb(name)] + + if { $opts(-debug) } { + set maj [expr { ($sb(vem) & 0xff)/10 }] + set min [expr { ($sb(vem) & 0xff)%10 }] + set sys [expr { $sb(vem) >> 8 }] + puts "made by version $maj.$min on system type $sys -> $::zip::systems($sys)" + + set maj [expr { ($sb(ver) & 0xff)/10 }] + set min [expr { ($sb(ver) & 0xff)%10 }] + set sys [expr { $sb(ver) >> 8 }] + puts "need version $maj.$min on system type $sys -> $::zip::systems($sys)" + + puts "file type is [expr { $sb(attr) == 1 ? "text" : "binary" }]" + puts "file mode is $sb(mode)" + + set att [expr { $sb(atx) & 0xff }] + set flgs {} + foreach {k v} [array get ::zip::dosattrs] { + if { $k & $att } { + lappend flgs $v + } + } + puts "dos file attrs = [join $flgs]" + } + } +} +# +# This doesn't do anything right now except read each +# entry and inflate the data and double-check the crc +# + +if { $opts(-extract) } { + seek $fd $cb(base) start + + foreach {name idx} $TOC { + #seek $fd $idx start + + zip::Data $fd sb data + + # The slowness of this code is actually Tcl's file i/o + # I suspect there are levels of buffer duplication + # wasting cpu and memory cycles.... + file mkdir [file dirname $sb(name)] + + set nfd [open $sb(name) w] + fconfigure $nfd -translation binary -buffering none + puts -nonewline $nfd $data + close $nfd + + puts "$sb(name): $sb(size) bytes" + } +} diff --git a/license.terms b/license.terms new file mode 100644 index 0000000..2aa12c3 --- /dev/null +++ b/license.terms @@ -0,0 +1,38 @@ +This software is copyrighted by the Vince Darley, and other +parties. The following terms apply to all files associated with the +software unless explicitly disclaimed in individual files. + +The authors hereby grant permission to use, copy, modify, distribute, +and license this software and its documentation for any purpose, provided +that existing copyright notices are retained in all copies and that this +notice is included verbatim in any distributions. No written agreement, +license, or royalty fee is required for any of the authorized uses. +Modifications to this software may be copyrighted by their authors +and need not follow the licensing terms described here, provided that +the new terms are clearly indicated on the first page of each file where +they apply. + +IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY +FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES +ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY +DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. + +THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, +INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE +IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE +NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR +MODIFICATIONS. + +GOVERNMENT USE: If you are acquiring this software on behalf of the +U.S. government, the Government shall have only "Restricted Rights" +in the software and related documentation as defined in the Federal +Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you +are acquiring the software on behalf of the Department of Defense, the +software shall be classified as "Commercial Computer Software" and the +Government shall have only "Restricted Rights" as defined in Clause +252.227-7013 (c) (1) of DFARs. Notwithstanding the foregoing, the +authors grant the U.S. Government and others acting in its behalf +permission to use and distribute the software in accordance with the +terms specified in this license. diff --git a/mkIndex.tcl.in b/mkIndex.tcl.in new file mode 100644 index 0000000..4179558 --- /dev/null +++ b/mkIndex.tcl.in @@ -0,0 +1,114 @@ +# mkIndex.tcl -- +# +# This script generates a pkgIndex.tcl file for an installed extension. +# +# Copyright (c) 1999 Scriptics Corporation. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# +# Notes: +# +# If you redefine $(libdir) using the configure switch --libdir=, then +# this script will probably fail for you. +# +# UNIX: +# exec_prefix +# | +# | +# | +# lib +# / \ +# / \ +# / \ +# PACKAGE (.so files) +# | +# | +# | +# pkgIndex.tcl +# +# WIN: +# exec_prefix +# / \ +# / \ +# / \ +# bin lib +# | \ +# | \ +# | \ +# (.dll files) PACKAGE +# | +# | +# | +# pkgIndex.tcl + +# The pkg_mkIndex routines from Tcl 8.2 and later support stub-enabled +# extensions. Notify the user if this is not a valid tcl shell. +# Exit with a status of 0 so that the make-install process does not stop. + +if {[catch {package require Tcl 8.4} msg]} { + puts stderr "**WARNING**" + puts stderr $msg + puts stderr "Could not build pkgIndex.tcl file. You must create one by hand" + exit 0 +} + +# The name of the library(s) should be passed in as arguments. + +set libraryList $argv + +# Nativepath -- +# +# Convert a Cygnus style path to a native path +# +# Arguments: +# pathName Path to convert +# +# Results: +# The result is the native name of the input pathName. +# On Windows, this is z:/foo/bar, on Unix the input pathName is +# returned. + +proc Nativepath {pathName} { + global tcl_platform + + if {![string match $tcl_platform(platform) unix]} { + if {[regexp {//(.)/(.*)} $pathName null driveLetter pathRemains]} { + set pathName $driveLetter:/$pathRemains + } + } + return $pathName +} + +set prefix "@prefix@" +set exec_prefix "@exec_prefix@" + +set exec_prefix [Nativepath $exec_prefix] + +set libdir @libdir@ +set package @PACKAGE@ +set version @VERSION@ + +cd $libdir +puts "Making pkgIndex.tcl in [file join [pwd] $package]" + +if {$tcl_platform(platform) == "unix"} { + if {[llength $libraryList] > 0} { + set libraryPathList {} + foreach lib $libraryList { + lappend libraryPathList [file join .. $lib] + } + puts "eval pkg_mkIndex $package$version $libraryPathList *.tcl" + eval pkg_mkIndex $package$version $libraryPathList *.tcl + } +} else { + if {[llength $libraryList] > 0} { + set libraryPathList {} + foreach lib $libraryList { + lappend libraryPathList [file join .. .. bin $lib] + } + puts "eval pkg_mkIndex $package$version $libraryPathList *.tcl" + eval pkg_mkIndex $package$version $libraryPathList *.tcl + } +} diff --git a/mkinstalldirs b/mkinstalldirs new file mode 100644 index 0000000..6b3b5fc --- /dev/null +++ b/mkinstalldirs @@ -0,0 +1,40 @@ +#! /bin/sh +# mkinstalldirs --- make directory hierarchy +# Author: Noah Friedman +# 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 diff --git a/runZippedTests.tcl b/runZippedTests.tcl new file mode 100644 index 0000000..51f0c06 --- /dev/null +++ b/runZippedTests.tcl @@ -0,0 +1,27 @@ +catch { + wm withdraw . + console show +} + +catch {file delete tests.zip} + +puts stdout "Zipping tests" ; update +exec zip -q -9 tests.zip tests/* +puts stdout "Done zipping" + +package require vfs +set mount [vfs::zip::Mount tests.zip tests.zip] +puts "Zip mount is $mount" +update +if {[catch { + cd tests.zip + cd tests + #source cmdAH.test + source all.tcl +} err]} { + puts stdout "Got error $err" +} +puts "Tests complete" +#vfs::zip::Unmount $mount + +#exit diff --git a/tests/all.tcl b/tests/all.tcl new file mode 100644 index 0000000..ca09d26 --- /dev/null +++ b/tests/all.tcl @@ -0,0 +1 @@ +# all.tcl -- # # This file contains a top-level script to run all of the Tcl # tests. Execute it by invoking "source all.test" when running tcltest # in this directory. # # Copyright (c) 1998-2000 by Scriptics Corporation. # All rights reserved. # # RCS: @(#) $Id$ set tcltestVersion [package require tcltest] namespace import -force tcltest::* #tcltest::testsDirectory [file dir [info script]] #tcltest::runAllTests set ::tcltest::testSingleFile false set ::tcltest::testsDirectory [file dir [info script]] # We need to ensure that the testsDirectory is absolute ::tcltest::normalizePath ::tcltest::testsDirectory puts stdout "Tests running in interp: [info nameofexecutable]" puts stdout "Tests running in working dir: $::tcltest::testsDirectory" if {[llength $::tcltest::skip] > 0} { puts stdout "Skipping tests that match: $::tcltest::skip" } if {[llength $::tcltest::match] > 0} { puts stdout "Only running tests that match: $::tcltest::match" } if {[llength $::tcltest::skipFiles] > 0} { puts stdout "Skipping test files that match: $::tcltest::skipFiles" } if {[llength $::tcltest::matchFiles] > 0} { puts stdout "Only sourcing test files that match: $::tcltest::matchFiles" } tcltest::testConstraint fsIsWritable [expr {1 - [catch {file mkdir isreadonly ; file delete isreadonly}]}] set timeCmd {clock format [clock seconds]} puts stdout "Tests began at [eval $timeCmd]" # source each of the specified tests foreach file [lsort [::tcltest::getMatchingFiles]] { set tail [file tail $file] puts stdout $tail if {[catch {source $file} msg]} { puts stdout $msg } } # cleanup puts stdout "\nTests ended at [eval $timeCmd]" ::tcltest::cleanupTests 1 return \ No newline at end of file diff --git a/tests/cmdAH.test b/tests/cmdAH.test new file mode 100644 index 0000000..0bf9a3e --- /dev/null +++ b/tests/cmdAH.test @@ -0,0 +1 @@ +# The file tests the tclCmdAH.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-1998 by 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::* } tcltest::testConstraint testchmod [string equal testchmod [info commands testchmod]] tcltest::testConstraint fsIsWritable [expr {1 - [catch {file mkdir isreadonly ; file delete isreadonly}]}] global env set cmdAHwd [pwd] catch {set platform [testgetplatform]} test cmdAH-0.1 {Tcl_BreakObjCmd, errors} { list [catch {break foo} msg] $msg } {1 {wrong # args: should be "break"}} test cmdAH-0.2 {Tcl_BreakObjCmd, success} { list [catch {break} msg] $msg } {3 {}} # Tcl_CaseObjCmd is tested in case.test test cmdAH-1.1 {Tcl_CatchObjCmd, errors} { list [catch {catch} msg] $msg } {1 {wrong # args: should be "catch command ?varName?"}} test cmdAH-1.2 {Tcl_CatchObjCmd, errors} { list [catch {catch foo bar baz} msg] $msg } {1 {wrong # args: should be "catch command ?varName?"}} test cmdAH-2.1 {Tcl_CdObjCmd} { list [catch {cd foo bar} msg] $msg } {1 {wrong # args: should be "cd ?dirName?"}} test cmdAH-2.2 {Tcl_CdObjCmd} {fsIsWritable} { file delete -force foo file mkdir foo cd foo set result [file tail [pwd]] cd .. file delete foo set result } foo test cmdAH-2.3 {Tcl_CdObjCmd} {fsIsWritable} { global env set oldpwd [pwd] set temp $env(HOME) set env(HOME) $oldpwd file delete -force foo file mkdir foo cd foo cd ~ set result [string match [pwd] $oldpwd] file delete foo set env(HOME) $temp set result } 1 test cmdAH-2.4 {Tcl_CdObjCmd} {fsIsWritable} { global env set oldpwd [pwd] set temp $env(HOME) set env(HOME) $oldpwd file delete -force foo file mkdir foo cd foo cd set result [string match [pwd] $oldpwd] file delete foo set env(HOME) $temp set result } 1 test cmdAH-2.5 {Tcl_CdObjCmd} { list [catch {cd ~~} msg] $msg } {1 {user "~" doesn't exist}} test cmdAH-2.6 {Tcl_CdObjCmd} { list [catch {cd _foobar} msg] $msg } {1 {couldn't change working directory to "_foobar": no such file or directory}} test cmdAH-2.7 {Tcl_ConcatObjCmd} { concat } {} test cmdAH-2.8 {Tcl_ConcatObjCmd} { concat a } a test cmdAH-2.9 {Tcl_ConcatObjCmd} { concat a {b c} } {a b c} test cmdAH-3.1 {Tcl_ContinueObjCmd, errors} { list [catch {continue foo} msg] $msg } {1 {wrong # args: should be "continue"}} test cmdAH-3.2 {Tcl_ContinueObjCmd, success} { list [catch {continue} msg] $msg } {4 {}} test cmdAH-4.1 {Tcl_EncodingObjCmd} { list [catch {encoding} msg] $msg } {1 {wrong # args: should be "encoding option ?arg ...?"}} test cmdAH-4.2 {Tcl_EncodingObjCmd} { list [catch {encoding foo} msg] $msg } {1 {bad option "foo": must be convertfrom, convertto, names, or system}} test cmdAH-4.3 {Tcl_EncodingObjCmd} { list [catch {encoding convertto} msg] $msg } {1 {wrong # args: should be "encoding convertto ?encoding? data"}} test cmdAH-4.4 {Tcl_EncodingObjCmd} { list [catch {encoding convertto foo bar} msg] $msg } {1 {unknown encoding "foo"}} test cmdAH-4.5 {Tcl_EncodingObjCmd} { set system [encoding system] encoding system jis0208 set x [encoding convertto \u4e4e] encoding system $system set x } 8C test cmdAH-4.6 {Tcl_EncodingObjCmd} { set system [encoding system] encoding system identity set x [encoding convertto jis0208 \u4e4e] encoding system $system set x } 8C test cmdAH-4.7 {Tcl_EncodingObjCmd} { list [catch {encoding convertfrom} msg] $msg } {1 {wrong # args: should be "encoding convertfrom ?encoding? data"}} test cmdAH-4.8 {Tcl_EncodingObjCmd} { list [catch {encoding convertfrom foo bar} msg] $msg } {1 {unknown encoding "foo"}} test cmdAH-4.9 {Tcl_EncodingObjCmd} { set system [encoding system] encoding system jis0208 set x [encoding convertfrom 8C] encoding system $system set x } \u4e4e test cmdAH-4.10 {Tcl_EncodingObjCmd} { set system [encoding system] encoding system identity set x [encoding convertfrom jis0208 8C] encoding system $system set x } \u4e4e test cmdAH-4.11 {Tcl_EncodingObjCmd} { list [catch {encoding names foo} msg] $msg } {1 {wrong # args: should be "encoding names"}} test cmdAH-4.12 {Tcl_EncodingObjCmd} { list [catch {encoding system foo bar} msg] $msg } {1 {wrong # args: should be "encoding system ?encoding?"}} test cmdAH-4.13 {Tcl_EncodingObjCmd} { set system [encoding system] encoding system identity set x [encoding system] encoding system $system set x } identity test cmdAH-5.1 {Tcl_FileObjCmd} { list [catch file msg] $msg } {1 {wrong # args: should be "file option ?arg ...?"}} test cmdAH-5.2 {Tcl_FileObjCmd} { list [catch {file x} msg] $msg } {1 {bad option "x": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}} test cmdAH-5.3 {Tcl_FileObjCmd} { list [catch {file exists} msg] $msg } {1 {wrong # args: should be "file exists name"}} test cmdAH-5.4 {Tcl_FileObjCmd} { list [catch {file exists ""} msg] $msg } {0 0} #volume test cmdAH-6.1 {Tcl_FileObjCmd: volumes} { list [catch {file volumes x} msg] $msg } {1 {wrong # args: should be "file volumes"}} test cmdAH-6.2 {Tcl_FileObjCmd: volumes} { set volumeList [file volumes] if { [llength $volumeList] == 0 } { set result 0 } else { set result 1 } } {1} test cmdAH-6.3 {Tcl_FileObjCmd: volumes} {macOrUnix} { set volumeList [file volumes] catch [list glob -nocomplain [lindex $volumeList 0]*] } {0} test cmdAH-6.4 {Tcl_FileObjCmd: volumes} {pcOnly} { set volumeList [string tolower [file volumes]] list [catch {lsearch $volumeList "c:/"} element] [expr $element != -1] [catch {list glob -nocomplain [lindex $volumeList $element]*}] } {0 1 0} # attributes test cmdAH-7.1 {Tcl_FileObjCmd - file attrs} {fsIsWritable} { catch {file delete -force foo.file} close [open foo.file w] list [catch {file attributes foo.file}] [file delete -force foo.file] } {0 {}} # dirname if {[info commands testsetplatform] == {}} { puts "This application hasn't been compiled with the \"testsetplatform\"" puts "command, so I can't test Tcl_FileObjCmd etc." } else { test cmdAH-8.1 {Tcl_FileObjCmd: dirname} { testsetplatform unix list [catch {file dirname a b} msg] $msg } {1 {wrong # args: should be "file dirname name"}} test cmdAH-8.2 {Tcl_FileObjCmd: dirname} { testsetplatform unix file dirname /a/b } /a test cmdAH-8.3 {Tcl_FileObjCmd: dirname} { testsetplatform unix file dirname {} } . test cmdAH-8.4 {Tcl_FileObjCmd: dirname} { testsetplatform mac file dirname {} } : test cmdAH-8.5 {Tcl_FileObjCmd: dirname} { testsetplatform win file dirname {} } . test cmdAH-8.6 {Tcl_FileObjCmd: dirname} { testsetplatform unix file dirname .def } . test cmdAH-8.7 {Tcl_FileObjCmd: dirname} { testsetplatform mac file dirname a } : test cmdAH-8.8 {Tcl_FileObjCmd: dirname} { testsetplatform win file dirname a } . test cmdAH-8.9 {Tcl_FileObjCmd: dirname} { testsetplatform unix file dirname a/b/c.d } a/b test cmdAH-8.10 {Tcl_FileObjCmd: dirname} { testsetplatform unix file dirname a/b.c/d } a/b.c test cmdAH-8.11 {Tcl_FileObjCmd: dirname} { testsetplatform unix file dirname /. } / test cmdAH-8.12 {Tcl_FileObjCmd: dirname} { testsetplatform unix list [catch {file dirname /} msg] $msg } {0 /} test cmdAH-8.13 {Tcl_FileObjCmd: dirname} { testsetplatform unix list [catch {file dirname /foo} msg] $msg } {0 /} test cmdAH-8.14 {Tcl_FileObjCmd: dirname} { testsetplatform unix list [catch {file dirname //foo} msg] $msg } {0 /} test cmdAH-8.15 {Tcl_FileObjCmd: dirname} { testsetplatform unix list [catch {file dirname //foo/bar} msg] $msg } {0 /foo} test cmdAH-8.16 {Tcl_FileObjCmd: dirname} { testsetplatform unix list [catch {file dirname {//foo\/bar/baz}} msg] $msg } {0 {/foo\/bar}} test cmdAH-8.17 {Tcl_FileObjCmd: dirname} { testsetplatform unix list [catch {file dirname {//foo\/bar/baz/blat}} msg] $msg } {0 {/foo\/bar/baz}} test cmdAH-8.18 {Tcl_FileObjCmd: dirname} { testsetplatform unix list [catch {file dirname /foo//} msg] $msg } {0 /} test cmdAH-8.19 {Tcl_FileObjCmd: dirname} { testsetplatform unix list [catch {file dirname ./a} msg] $msg } {0 .} test cmdAH-8.20 {Tcl_FileObjCmd: dirname} { testsetplatform unix list [catch {file dirname a/.a} msg] $msg } {0 a} test cmdAH-8.21 {Tcl_FileObjCmd: dirname} { testsetplatform windows list [catch {file dirname c:foo} msg] $msg } {0 c:} test cmdAH-8.22 {Tcl_FileObjCmd: dirname} { testsetplatform windows list [catch {file dirname c:} msg] $msg } {0 c:} test cmdAH-8.23 {Tcl_FileObjCmd: dirname} { testsetplatform windows list [catch {file dirname c:/} msg] $msg } {0 c:/} test cmdAH-8.24 {Tcl_FileObjCmd: dirname} { testsetplatform windows list [catch {file dirname {c:\foo}} msg] $msg } {0 c:/} test cmdAH-8.25 {Tcl_FileObjCmd: dirname} { testsetplatform windows list [catch {file dirname {//foo/bar/baz}} msg] $msg } {0 //foo/bar} test cmdAH-8.26 {Tcl_FileObjCmd: dirname} { testsetplatform windows list [catch {file dirname {//foo/bar}} msg] $msg } {0 //foo/bar} test cmdAH-8.27 {Tcl_FileObjCmd: dirname} { testsetplatform mac list [catch {file dirname :} msg] $msg } {0 :} test cmdAH-8.28 {Tcl_FileObjCmd: dirname} { testsetplatform mac list [catch {file dirname :Foo} msg] $msg } {0 :} test cmdAH-8.29 {Tcl_FileObjCmd: dirname} { testsetplatform mac list [catch {file dirname Foo:} msg] $msg } {0 Foo:} test cmdAH-8.30 {Tcl_FileObjCmd: dirname} { testsetplatform mac list [catch {file dirname Foo:bar} msg] $msg } {0 Foo:} test cmdAH-8.31 {Tcl_FileObjCmd: dirname} { testsetplatform mac list [catch {file dirname :Foo:bar} msg] $msg } {0 :Foo} test cmdAH-8.32 {Tcl_FileObjCmd: dirname} { testsetplatform mac list [catch {file dirname ::} msg] $msg } {0 :} test cmdAH-8.33 {Tcl_FileObjCmd: dirname} { testsetplatform mac list [catch {file dirname :::} msg] $msg } {0 ::} test cmdAH-8.34 {Tcl_FileObjCmd: dirname} { testsetplatform mac list [catch {file dirname /foo/bar/} msg] $msg } {0 foo:} test cmdAH-8.35 {Tcl_FileObjCmd: dirname} { testsetplatform mac list [catch {file dirname /foo/bar} msg] $msg } {0 foo:} test cmdAH-8.36 {Tcl_FileObjCmd: dirname} { testsetplatform mac list [catch {file dirname /foo} msg] $msg } {0 foo:} test cmdAH-8.37 {Tcl_FileObjCmd: dirname} { testsetplatform mac list [catch {file dirname foo} msg] $msg } {0 :} test cmdAH-8.38 {Tcl_FileObjCmd: dirname} { testsetplatform unix list [catch {file dirname ~/foo} msg] $msg } {0 ~} test cmdAH-8.39 {Tcl_FileObjCmd: dirname} { testsetplatform unix list [catch {file dirname ~bar/foo} msg] $msg } {0 ~bar} test cmdAH-8.40 {Tcl_FileObjCmd: dirname} { testsetplatform mac list [catch {file dirname ~bar/foo} msg] $msg } {0 ~bar:} test cmdAH-8.41 {Tcl_FileObjCmd: dirname} { testsetplatform mac list [catch {file dirname ~/foo} msg] $msg } {0 ~:} test cmdAH-8.42 {Tcl_FileObjCmd: dirname} { testsetplatform mac list [catch {file dirname ~:baz} msg] $msg } {0 ~:} test cmdAH-8.43 {Tcl_FileObjCmd: dirname} { global env set temp $env(HOME) set env(HOME) "/home/test" testsetplatform unix set result [list [catch {file dirname ~} msg] $msg] set env(HOME) $temp set result } {0 /home} test cmdAH-8.44 {Tcl_FileObjCmd: dirname} { global env set temp $env(HOME) set env(HOME) "~" testsetplatform unix set result [list [catch {file dirname ~} msg] $msg] set env(HOME) $temp set result } {0 ~} test cmdAH-8.45 {Tcl_FileObjCmd: dirname} { global env set temp $env(HOME) set env(HOME) "/home/test" testsetplatform windows set result [list [catch {file dirname ~} msg] $msg] set env(HOME) $temp set result } {0 /home} test cmdAH-8.46 {Tcl_FileObjCmd: dirname} { global env set temp $env(HOME) set env(HOME) "/home/test" testsetplatform mac set result [list [catch {file dirname ~} msg] $msg] set env(HOME) $temp set result } {0 home:} # tail test cmdAH-9.1 {Tcl_FileObjCmd: tail} { testsetplatform unix list [catch {file tail a b} msg] $msg } {1 {wrong # args: should be "file tail name"}} test cmdAH-9.2 {Tcl_FileObjCmd: tail} { testsetplatform unix file tail /a/b } b test cmdAH-9.3 {Tcl_FileObjCmd: tail} { testsetplatform unix file tail {} } {} test cmdAH-9.4 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail {} } {} test cmdAH-9.5 {Tcl_FileObjCmd: tail} { testsetplatform win file tail {} } {} test cmdAH-9.6 {Tcl_FileObjCmd: tail} { testsetplatform unix file tail .def } .def test cmdAH-9.7 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail a } a test cmdAH-9.8 {Tcl_FileObjCmd: tail} { testsetplatform win file tail a } a test cmdAH-9.9 {Tcl_FileObjCmd: tail} { testsetplatform unix file ta a/b/c.d } c.d test cmdAH-9.10 {Tcl_FileObjCmd: tail} { testsetplatform unix file tail a/b.c/d } d test cmdAH-9.11 {Tcl_FileObjCmd: tail} { testsetplatform unix file tail /. } . test cmdAH-9.12 {Tcl_FileObjCmd: tail} { testsetplatform unix file tail / } {} test cmdAH-9.13 {Tcl_FileObjCmd: tail} { testsetplatform unix file tail /foo } foo test cmdAH-9.14 {Tcl_FileObjCmd: tail} { testsetplatform unix file tail //foo } foo test cmdAH-9.15 {Tcl_FileObjCmd: tail} { testsetplatform unix file tail //foo/bar } bar test cmdAH-9.16 {Tcl_FileObjCmd: tail} { testsetplatform unix file tail {//foo\/bar/baz} } baz test cmdAH-9.17 {Tcl_FileObjCmd: tail} { testsetplatform unix file tail {//foo\/bar/baz/blat} } blat test cmdAH-9.18 {Tcl_FileObjCmd: tail} { testsetplatform unix file tail /foo// } foo test cmdAH-9.19 {Tcl_FileObjCmd: tail} { testsetplatform unix file tail ./a } a test cmdAH-9.20 {Tcl_FileObjCmd: tail} { testsetplatform unix file tail a/.a } .a test cmdAH-9.21 {Tcl_FileObjCmd: tail} { testsetplatform windows file tail c:foo } foo test cmdAH-9.22 {Tcl_FileObjCmd: tail} { testsetplatform windows file tail c: } {} test cmdAH-9.23 {Tcl_FileObjCmd: tail} { testsetplatform windows file tail c:/ } {} test cmdAH-9.24 {Tcl_FileObjCmd: tail} { testsetplatform windows file tail {c:\foo} } foo test cmdAH-9.25 {Tcl_FileObjCmd: tail} { testsetplatform windows file tail {//foo/bar/baz} } baz test cmdAH-9.26 {Tcl_FileObjCmd: tail} { testsetplatform windows file tail {//foo/bar} } {} test cmdAH-9.27 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail : } : test cmdAH-9.28 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail :Foo } Foo test cmdAH-9.29 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail Foo: } {} test cmdAH-9.30 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail Foo:bar } bar test cmdAH-9.31 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail :Foo:bar } bar test cmdAH-9.32 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail :: } :: test cmdAH-9.33 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail ::: } :: test cmdAH-9.34 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail /foo/bar/ } bar test cmdAH-9.35 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail /foo/bar } bar test cmdAH-9.36 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail /foo } {} test cmdAH-9.37 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail foo } foo test cmdAH-9.38 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail ~:foo } foo test cmdAH-9.39 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail ~bar:foo } foo test cmdAH-9.40 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail ~bar/foo } foo test cmdAH-9.41 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail ~/foo } foo test cmdAH-9.42 {Tcl_FileObjCmd: tail} { global env set temp $env(HOME) set env(HOME) "/home/test" testsetplatform unix set result [file tail ~] set env(HOME) $temp set result } test test cmdAH-9.43 {Tcl_FileObjCmd: tail} { global env set temp $env(HOME) set env(HOME) "~" testsetplatform unix set result [file tail ~] set env(HOME) $temp set result } {} test cmdAH-9.44 {Tcl_FileObjCmd: tail} { global env set temp $env(HOME) set env(HOME) "/home/test" testsetplatform windows set result [file tail ~] set env(HOME) $temp set result } test test cmdAH-9.45 {Tcl_FileObjCmd: tail} { global env set temp $env(HOME) set env(HOME) "/home/test" testsetplatform mac set result [file tail ~] set env(HOME) $temp set result } test test cmdAH-9.46 {Tcl_FileObjCmd: tail} { testsetplatform unix file tail {f.oo\bar/baz.bat} } baz.bat test cmdAH-9.47 {Tcl_FileObjCmd: tail} { testsetplatform windows file tail c:foo } foo test cmdAH-9.48 {Tcl_FileObjCmd: tail} { testsetplatform windows file tail c: } {} test cmdAH-9.49 {Tcl_FileObjCmd: tail} { testsetplatform windows file tail c:/foo } foo test cmdAH-9.50 {Tcl_FileObjCmd: tail} { testsetplatform windows file tail {c:/foo\bar} } bar test cmdAH-9.51 {Tcl_FileObjCmd: tail} { testsetplatform windows file tail {foo\bar} } bar # rootname test cmdAH-10.1 {Tcl_FileObjCmd: rootname} { testsetplatform unix list [catch {file rootname a b} msg] $msg } {1 {wrong # args: should be "file rootname name"}} test cmdAH-10.2 {Tcl_FileObjCmd: rootname} { testsetplatform unix file rootname {} } {} test cmdAH-10.3 {Tcl_FileObjCmd: rootname} { testsetplatform unix file ro foo } foo test cmdAH-10.4 {Tcl_FileObjCmd: rootname} { testsetplatform unix file rootname foo. } foo test cmdAH-10.5 {Tcl_FileObjCmd: rootname} { testsetplatform unix file rootname .foo } {} test cmdAH-10.6 {Tcl_FileObjCmd: rootname} { testsetplatform unix file rootname abc.def } abc test cmdAH-10.7 {Tcl_FileObjCmd: rootname} { testsetplatform unix file rootname abc.def.ghi } abc.def test cmdAH-10.8 {Tcl_FileObjCmd: rootname} { testsetplatform unix file rootname a/b/c.d } a/b/c test cmdAH-10.9 {Tcl_FileObjCmd: rootname} { testsetplatform unix file rootname a/b.c/d } a/b.c/d test cmdAH-10.10 {Tcl_FileObjCmd: rootname} { testsetplatform unix file rootname a/b.c/ } a/b.c/ test cmdAH-10.11 {Tcl_FileObjCmd: rootname} { testsetplatform mac file ro foo } foo test cmdAH-10.12 {Tcl_FileObjCmd: rootname} { testsetplatform mac file rootname {} } {} test cmdAH-10.13 {Tcl_FileObjCmd: rootname} { testsetplatform mac file rootname foo. } foo test cmdAH-10.14 {Tcl_FileObjCmd: rootname} { testsetplatform mac file rootname .foo } {} test cmdAH-10.15 {Tcl_FileObjCmd: rootname} { testsetplatform mac file rootname abc.def } abc test cmdAH-10.16 {Tcl_FileObjCmd: rootname} { testsetplatform mac file rootname abc.def.ghi } abc.def test cmdAH-10.17 {Tcl_FileObjCmd: rootname} { testsetplatform mac file rootname a:b:c.d } a:b:c test cmdAH-10.18 {Tcl_FileObjCmd: rootname} { testsetplatform mac file rootname a:b.c:d } a:b.c:d test cmdAH-10.19 {Tcl_FileObjCmd: rootname} { testsetplatform mac file rootname a/b/c.d } a/b/c test cmdAH-10.20 {Tcl_FileObjCmd: rootname} { testsetplatform mac file rootname a/b.c/d } a/b.c/d test cmdAH-10.21 {Tcl_FileObjCmd: rootname} { testsetplatform mac file rootname /a.b } /a test cmdAH-10.22 {Tcl_FileObjCmd: rootname} { testsetplatform mac file rootname foo.c: } foo.c: test cmdAH-10.23 {Tcl_FileObjCmd: rootname} { testsetplatform windows file rootname {} } {} test cmdAH-10.24 {Tcl_FileObjCmd: rootname} { testsetplatform windows file ro foo } foo test cmdAH-10.25 {Tcl_FileObjCmd: rootname} { testsetplatform windows file rootname foo. } foo test cmdAH-10.26 {Tcl_FileObjCmd: rootname} { testsetplatform windows file rootname .foo } {} test cmdAH-10.27 {Tcl_FileObjCmd: rootname} { testsetplatform windows file rootname abc.def } abc test cmdAH-10.28 {Tcl_FileObjCmd: rootname} { testsetplatform windows file rootname abc.def.ghi } abc.def test cmdAH-10.29 {Tcl_FileObjCmd: rootname} { testsetplatform windows file rootname a/b/c.d } a/b/c test cmdAH-10.30 {Tcl_FileObjCmd: rootname} { testsetplatform windows file rootname a/b.c/d } a/b.c/d test cmdAH-10.31 {Tcl_FileObjCmd: rootname} { testsetplatform windows file rootname a\\b.c\\ } a\\b.c\\ test cmdAH-10.32 {Tcl_FileObjCmd: rootname} { testsetplatform windows file rootname a\\b\\c.d } a\\b\\c test cmdAH-10.33 {Tcl_FileObjCmd: rootname} { testsetplatform windows file rootname a\\b.c\\d } a\\b.c\\d test cmdAH-10.34 {Tcl_FileObjCmd: rootname} { testsetplatform windows file rootname a\\b.c\\ } a\\b.c\\ set num 35 foreach outer { {} a .a a. a.a } { foreach inner { {} a .a a. a.a } { set thing [format %s/%s $outer $inner] ; test cmdAH-6.$num {Tcl_FileObjCmd: rootname and extension options} { testsetplatform unix format %s%s [file rootname $thing] [file ext $thing] } $thing set num [expr $num+1] } } # extension test cmdAH-11.1 {Tcl_FileObjCmd: extension} { testsetplatform unix list [catch {file extension a b} msg] $msg } {1 {wrong # args: should be "file extension name"}} test cmdAH-11.2 {Tcl_FileObjCmd: extension} { testsetplatform unix file extension {} } {} test cmdAH-11.3 {Tcl_FileObjCmd: extension} { testsetplatform unix file ext foo } {} test cmdAH-11.4 {Tcl_FileObjCmd: extension} { testsetplatform unix file extension foo. } . test cmdAH-11.5 {Tcl_FileObjCmd: extension} { testsetplatform unix file extension .foo } .foo test cmdAH-11.6 {Tcl_FileObjCmd: extension} { testsetplatform unix file extension abc.def } .def test cmdAH-11.7 {Tcl_FileObjCmd: extension} { testsetplatform unix file extension abc.def.ghi } .ghi test cmdAH-11.8 {Tcl_FileObjCmd: extension} { testsetplatform unix file extension a/b/c.d } .d test cmdAH-11.9 {Tcl_FileObjCmd: extension} { testsetplatform unix file extension a/b.c/d } {} test cmdAH-11.10 {Tcl_FileObjCmd: extension} { testsetplatform unix file extension a/b.c/ } {} test cmdAH-11.11 {Tcl_FileObjCmd: extension} { testsetplatform mac file ext foo } {} test cmdAH-11.12 {Tcl_FileObjCmd: extension} { testsetplatform mac file extension {} } {} test cmdAH-11.13 {Tcl_FileObjCmd: extension} { testsetplatform mac file extension foo. } . test cmdAH-11.14 {Tcl_FileObjCmd: extension} { testsetplatform mac file extension .foo } .foo test cmdAH-11.15 {Tcl_FileObjCmd: extension} { testsetplatform mac file extension abc.def } .def test cmdAH-11.16 {Tcl_FileObjCmd: extension} { testsetplatform mac file extension abc.def.ghi } .ghi test cmdAH-11.17 {Tcl_FileObjCmd: extension} { testsetplatform mac file extension a:b:c.d } .d test cmdAH-11.18 {Tcl_FileObjCmd: extension} { testsetplatform mac file extension a:b.c:d } {} test cmdAH-11.19 {Tcl_FileObjCmd: extension} { testsetplatform mac file extension a/b/c.d } .d test cmdAH-11.20 {Tcl_FileObjCmd: extension} { testsetplatform mac file extension a/b.c/d } {} test cmdAH-11.21 {Tcl_FileObjCmd: extension} { testsetplatform mac file extension /a.b } .b test cmdAH-11.22 {Tcl_FileObjCmd: extension} { testsetplatform mac file extension foo.c: } {} test cmdAH-11.23 {Tcl_FileObjCmd: extension} { testsetplatform windows file extension {} } {} test cmdAH-11.24 {Tcl_FileObjCmd: extension} { testsetplatform windows file ext foo } {} test cmdAH-11.25 {Tcl_FileObjCmd: extension} { testsetplatform windows file extension foo. } . test cmdAH-11.26 {Tcl_FileObjCmd: extension} { testsetplatform windows file extension .foo } .foo test cmdAH-11.27 {Tcl_FileObjCmd: extension} { testsetplatform windows file extension abc.def } .def test cmdAH-11.28 {Tcl_FileObjCmd: extension} { testsetplatform windows file extension abc.def.ghi } .ghi test cmdAH-11.29 {Tcl_FileObjCmd: extension} { testsetplatform windows file extension a/b/c.d } .d test cmdAH-11.30 {Tcl_FileObjCmd: extension} { testsetplatform windows file extension a/b.c/d } {} test cmdAH-11.31 {Tcl_FileObjCmd: extension} { testsetplatform windows file extension a\\b.c\\ } {} test cmdAH-11.32 {Tcl_FileObjCmd: extension} { testsetplatform windows file extension a\\b\\c.d } .d test cmdAH-11.33 {Tcl_FileObjCmd: extension} { testsetplatform windows file extension a\\b.c\\d } {} test cmdAH-11.34 {Tcl_FileObjCmd: extension} { testsetplatform windows file extension a\\b.c\\ } {} set num 35 foreach value {a..b a...b a.c..b ..b} result {.b .b .b .b} { foreach p {unix mac windows} { ; test cmdAH-7.$num {Tcl_FileObjCmd: extension} " testsetplatform $p file extension $value " $result incr num } } # pathtype test cmdAH-12.1 {Tcl_FileObjCmd: pathtype} { testsetplatform unix list [catch {file pathtype a b} msg] $msg } {1 {wrong # args: should be "file pathtype name"}} test cmdAH-12.2 {Tcl_FileObjCmd: pathtype} { testsetplatform unix file pathtype /a } absolute test cmdAH-12.3 {Tcl_FileObjCmd: pathtype} { testsetplatform unix file p a } relative test cmdAH-12.4 {Tcl_FileObjCmd: pathtype} { testsetplatform windows file pathtype c:a } volumerelative # split test cmdAH-13.1 {Tcl_FileObjCmd: split} { testsetplatform unix list [catch {file split a b} msg] $msg } {1 {wrong # args: should be "file split name"}} test cmdAH-13.2 {Tcl_FileObjCmd: split} { testsetplatform unix file split a } a test cmdAH-13.3 {Tcl_FileObjCmd: split} { testsetplatform unix file split a/b } {a b} # join test cmdAH-14.1 {Tcl_FileObjCmd: join} { testsetplatform unix file join a } a test cmdAH-14.2 {Tcl_FileObjCmd: join} { testsetplatform unix file join a b } a/b test cmdAH-14.3 {Tcl_FileObjCmd: join} { testsetplatform unix file join a b c d } a/b/c/d # error handling of Tcl_TranslateFileName test cmdAH-15.1 {Tcl_FileObjCmd} { testsetplatform unix list [catch {file atime ~_bad_user} msg] $msg } {1 {user "_bad_user" doesn't exist}} testsetplatform $platform } # readable makeFile abcde gorp.file makeDirectory dir.file test cmdAH-16.1 {Tcl_FileObjCmd: readable} {testchmod} { list [catch {file readable a b} msg] $msg } {1 {wrong # args: should be "file readable name"}} testchmod 444 gorp.file test cmdAH-16.2 {Tcl_FileObjCmd: readable} {testchmod} { file readable gorp.file } 1 testchmod 333 gorp.file test cmdAH-16.3 {Tcl_FileObjCmd: readable} {unixOnly notRoot testchmod} { file reada gorp.file } 0 # writable test cmdAH-17.1 {Tcl_FileObjCmd: writable} {testchmod} { list [catch {file writable a b} msg] $msg } {1 {wrong # args: should be "file writable name"}} testchmod 555 gorp.file test cmdAH-17.2 {Tcl_FileObjCmd: writable} {notRoot testchmod} { file writable gorp.file } 0 testchmod 222 gorp.file test cmdAH-17.3 {Tcl_FileObjCmd: writable} {testchmod} { file writable gorp.file } 1 # executable file delete -force dir.file gorp.file file mkdir dir.file makeFile abcde gorp.file test cmdAH-18.1 {Tcl_FileObjCmd: executable} {testchmod} { list [catch {file executable a b} msg] $msg } {1 {wrong # args: should be "file executable name"}} test cmdAH-18.2 {Tcl_FileObjCmd: executable} {testchmod} { file executable gorp.file } 0 test cmdAH-18.3 {Tcl_FileObjCmd: executable} {unixOnly testchmod} { # Only on unix will setting the execute bit on a regular file # cause that file to be executable. testchmod 775 gorp.file file exe gorp.file } 1 test cmdAH-18.4 {Tcl_FileObjCmd: executable} {macOnly testchmod} { # On mac, the only executable files are of type APPL. set x [file exe gorp.file] file attrib gorp.file -type APPL lappend x [file exe gorp.file] } {0 1} test cmdAH-18.5 {Tcl_FileObjCmd: executable} {pcOnly testchmod} { # On pc, must be a .exe, .com, etc. set x [file exe gorp.file] makeFile foo gorp.exe lappend x [file exe gorp.exe] file delete gorp.exe set x } {0 1} test cmdAH-18.6 {Tcl_FileObjCmd: executable} {testchmod} { # Directories are always executable. file exe dir.file } 1 file delete -force dir.file file delete gorp.file file delete link.file # exists test cmdAH-19.1 {Tcl_FileObjCmd: exists} { list [catch {file exists a b} msg] $msg } {1 {wrong # args: should be "file exists name"}} test cmdAH-19.2 {Tcl_FileObjCmd: exists} {file exists gorp.file} 0 test cmdAH-19.3 {Tcl_FileObjCmd: exists} { file exists [file join dir.file gorp.file] } 0 catch { makeFile abcde gorp.file makeDirectory dir.file makeFile 12345 [file join dir.file gorp.file] } test cmdAH-19.4 {Tcl_FileObjCmd: exists} { file exists gorp.file } 1 test cmdAH-19.5 {Tcl_FileObjCmd: exists} { file exists [file join dir.file gorp.file] } 1 # nativename if {[info commands testsetplatform] == {}} { puts "This application hasn't been compiled with the \"testsetplatform\"" puts "command, so I can't test Tcl_FileObjCmd etc." } else { test cmdAH-19.6 {Tcl_FileObjCmd: nativename} { testsetplatform unix list [catch {file nativename a/b} msg] $msg [testsetplatform $platform] } {0 a/b {}} test cmdAH-19.7 {Tcl_FileObjCmd: nativename} { testsetplatform windows list [catch {file nativename a/b} msg] $msg [testsetplatform $platform] } {0 {a\b} {}} test cmdAH-19.8 {Tcl_FileObjCmd: nativename} { testsetplatform mac list [catch {file nativename a/b} msg] $msg [testsetplatform $platform] } {0 :a:b {}} } test cmdAH-19.9 {Tcl_FileObjCmd: ~ : exists} { file exists ~nOsUcHuSeR } 0 test cmdAH-19.10 {Tcl_FileObjCmd: ~ : nativename} { # should probably be 0 in fact... catch {file nativename ~nOsUcHuSeR} } 1 # The test below has to be done in /tmp rather than the current # directory in order to guarantee (?) a local file system: some # NFS file systems won't do the stuff below correctly. test cmdAH-19.11 {Tcl_FileObjCmd: exists} {unixOnly notRoot} { removeFile /tmp/tcl.foo.dir/file removeDirectory /tmp/tcl.foo.dir makeDirectory /tmp/tcl.foo.dir makeFile 12345 /tmp/tcl.foo.dir/file exec chmod 000 /tmp/tcl.foo.dir set result [file exists /tmp/tcl.foo.dir/file] exec chmod 775 /tmp/tcl.foo.dir removeFile /tmp/tcl.foo.dir/file removeDirectory /tmp/tcl.foo.dir set result } 0 # Stat related commands catch {testsetplatform $platform} file delete gorp.file makeFile "Test string" gorp.file catch {exec chmod 765 gorp.file} # atime set file [makeFile "data" touch.me] test cmdAH-20.1 {Tcl_FileObjCmd: atime} { list [catch {file atime a b c} msg] $msg } {1 {wrong # args: should be "file atime name ?time?"}} test cmdAH-20.2 {Tcl_FileObjCmd: atime} { catch {unset stat} file stat gorp.file stat list [expr {[file mtime gorp.file] == $stat(mtime)}] \ [expr {[file atime gorp.file] == $stat(atime)}] } {1 1} test cmdAH-20.3 {Tcl_FileObjCmd: atime} { string tolower [list [catch {file atime _bogus_} msg] \ $msg $errorCode] } {1 {could not read "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} test cmdAH-20.4 {Tcl_FileObjCmd: atime} { list [catch {file atime $file notint} msg] $msg } {1 {expected integer but got "notint"}} test cmdAH-20.5 {Tcl_FileObjCmd: atime touch} { if {[string equal $tcl_platform(platform) "windows"]} { set old [pwd] cd $::tcltest::temporaryDirectory if {![string equal "NTFS" [testvolumetype]]} { # Windows FAT doesn't understand atime, but NTFS does # May also fail for Windows on NFS mounted disks cd $old return 1 } cd $old } set atime [file atime $file] after 1100; # pause a sec to notice change in atime set newatime [clock seconds] expr {$newatime==[file atime $file $newatime]} } 1 # isdirectory test cmdAH-21.1 {Tcl_FileObjCmd: isdirectory} { list [catch {file isdirectory a b} msg] $msg } {1 {wrong # args: should be "file isdirectory name"}} test cmdAH-21.2 {Tcl_FileObjCmd: isdirectory} { file isdirectory gorp.file } 0 test cmdAH-21.3 {Tcl_FileObjCmd: isdirectory} { file isd dir.file } 1 # isfile test cmdAH-22.1 {Tcl_FileObjCmd: isfile} { list [catch {file isfile a b} msg] $msg } {1 {wrong # args: should be "file isfile name"}} test cmdAH-22.2 {Tcl_FileObjCmd: isfile} {file isfile gorp.file} 1 test cmdAH-22.3 {Tcl_FileObjCmd: isfile} {file isfile dir.file} 0 # lstat and readlink: don't run these tests everywhere, since not all # sites will have symbolic links catch {exec ln -s gorp.file link.file} test cmdAH-23.1 {Tcl_FileObjCmd: lstat} { list [catch {file lstat a} msg] $msg } {1 {wrong # args: should be "file lstat name varName"}} test cmdAH-23.2 {Tcl_FileObjCmd: lstat} { list [catch {file lstat a b c} msg] $msg } {1 {wrong # args: should be "file lstat name varName"}} test cmdAH-23.3 {Tcl_FileObjCmd: lstat} {unixOnly nonPortable} { catch {unset stat} file lstat link.file stat lsort [array names stat] } {atime ctime dev gid ino mode mtime nlink size type uid} test cmdAH-23.4 {Tcl_FileObjCmd: lstat} {unixOnly nonPortable} { catch {unset stat} file lstat link.file stat list $stat(nlink) [expr $stat(mode)&0777] $stat(type) } {1 511 link} test cmdAH-23.5 {Tcl_FileObjCmd: lstat errors} {nonPortable} { string tolower [list [catch {file lstat _bogus_ stat} msg] \ $msg $errorCode] } {1 {could not read "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} test cmdAH-23.6 {Tcl_FileObjCmd: lstat errors} { catch {unset x} set x 44 list [catch {file lstat gorp.file x} msg] $msg $errorCode } {1 {can't set "x(dev)": variable isn't array} NONE} catch {unset stat} # mkdir test cmdAH-23.7 {Tcl_FileObjCmd: mkdir} { catch {file delete -force a} file mkdir a set res [file isdirectory a] file delete a set res } {1} test cmdAH-23.8 {Tcl_FileObjCmd: mkdir} { catch {file delete -force a} file mkdir a/b set res [file isdirectory a/b] file delete -force a set res } {1} test cmdAH-23.9 {Tcl_FileObjCmd: mkdir} { catch {file delete -force a} file mkdir a/b/c set res [file isdirectory a/b/c] file delete -force a set res } {1} test cmdAH-23.10 {Tcl_FileObjCmd: mkdir} { catch {file delete -force a} catch {file delete -force b} file mkdir a/b b/a/c set res [list [file isdirectory a/b] [file isdirectory b/a/c]] file delete -force a file delete -force b set res } {1 1} # mtime set file [makeFile "data" touch.me] test cmdAH-24.1 {Tcl_FileObjCmd: mtime} { list [catch {file mtime a b c} msg] $msg } {1 {wrong # args: should be "file mtime name ?time?"}} test cmdAH-24.2 {Tcl_FileObjCmd: mtime} { set old [file mtime gorp.file] after 2000 set f [open gorp.file w] puts $f "More text" close $f set new [file mtime gorp.file] expr {($new > $old) && ($new <= ($old+5))} } {1} test cmdAH-24.3 {Tcl_FileObjCmd: mtime} { catch {unset stat} file stat gorp.file stat list [expr {[file mtime gorp.file] == $stat(mtime)}] \ [expr {[file atime gorp.file] == $stat(atime)}] } {1 1} test cmdAH-24.4 {Tcl_FileObjCmd: mtime} { string tolower [list [catch {file mtime _bogus_} msg] $msg \ $errorCode] } {1 {could not read "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} test cmdAH-24.5 {Tcl_FileObjCmd: mtime} { # Under Unix, use a file in /tmp to avoid clock skew due to NFS. # On other platforms, just use a file in the local directory. if {[string equal $tcl_platform(platform) "unix"]} { set name /tmp/tcl.test } else { set name tf } # Make sure that a new file's time is correct. 10 seconds variance # is allowed used due to slow networks or clock skew on a network drive. file delete -force $name close [open $name w] set a [expr abs([clock seconds]-[file mtime $name])<10] file delete $name set a } {1} test cmdAH-24.7 {Tcl_FileObjCmd: mtime} { list [catch {file mtime $file notint} msg] $msg } {1 {expected integer but got "notint"}} test cmdAH-24.8 {Tcl_FileObjCmd: mtime touch} { set mtime [file mtime $file] after 1100; # pause a sec to notice change in mtime set newmtime [clock seconds] expr {$newmtime==[file mtime $file $newmtime]} } 1 # owned test cmdAH-25.1 {Tcl_FileObjCmd: owned} { list [catch {file owned a b} msg] $msg } {1 {wrong # args: should be "file owned name"}} test cmdAH-25.2 {Tcl_FileObjCmd: owned} { file owned gorp.file } 1 test cmdAH-25.3 {Tcl_FileObjCmd: owned} {unixOnly notRoot} { file owned / } 0 # readlink test cmdAH-26.1 {Tcl_FileObjCmd: readlink} { list [catch {file readlink a b} msg] $msg } {1 {wrong # args: should be "file readlink name"}} test cmdAH-26.2 {Tcl_FileObjCmd: readlink} {unixOnly nonPortable} { file readlink link.file } gorp.file test cmdAH-26.3 {Tcl_FileObjCmd: readlink errors} {unixOnly nonPortable} { list [catch {file readlink _bogus_} msg] [string tolower $msg] \ [string tolower $errorCode] } {1 {could not readlink "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} test cmdAH-26.4 {Tcl_FileObjCmd: readlink errors} {macOnly nonPortable} { list [catch {file readlink _bogus_} msg] [string tolower $msg] \ [string tolower $errorCode] } {1 {could not readlink "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} test cmdAH-26.5 {Tcl_FileObjCmd: readlink errors} {pcOnly nonPortable} { list [catch {file readlink _bogus_} msg] [string tolower $msg] \ [string tolower $errorCode] } {1 {could not readlink "_bogus_": invalid argument} {posix einval {invalid argument}}} # size test cmdAH-27.1 {Tcl_FileObjCmd: size} { list [catch {file size a b} msg] $msg } {1 {wrong # args: should be "file size name"}} test cmdAH-27.2 {Tcl_FileObjCmd: size} { set oldsize [file size gorp.file] set f [open gorp.file a] fconfigure $f -translation lf -eofchar {} puts $f "More text" close $f expr {[file size gorp.file] - $oldsize} } {10} test cmdAH-27.3 {Tcl_FileObjCmd: size} { string tolower [list [catch {file size _bogus_} msg] $msg \ $errorCode] } {1 {could not read "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} # stat catch {testsetplatform $platform} makeFile "Test string" gorp.file catch {exec chmod 765 gorp.file} test cmdAH-28.1 {Tcl_FileObjCmd: stat} { list [catch {file stat _bogus_} msg] $msg $errorCode } {1 {wrong # args: should be "file stat name varName"} NONE} test cmdAH-28.2 {Tcl_FileObjCmd: stat} { list [catch {file stat _bogus_ a b} msg] $msg $errorCode } {1 {wrong # args: should be "file stat name varName"} NONE} test cmdAH-28.3 {Tcl_FileObjCmd: stat} { catch {unset stat} file stat gorp.file stat lsort [array names stat] } {atime ctime dev gid ino mode mtime nlink size type uid} test cmdAH-28.4 {Tcl_FileObjCmd: stat} { catch {unset stat} file stat gorp.file stat list $stat(nlink) $stat(size) $stat(type) } {1 12 file} test cmdAH-28.5 {Tcl_FileObjCmd: stat} {unixOnly} { catch {unset stat} file stat gorp.file stat expr $stat(mode)&0777 } {501} test cmdAH-28.6 {Tcl_FileObjCmd: stat} { string tolower [list [catch {file stat _bogus_ stat} msg] \ $msg $errorCode] } {1 {could not read "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} test cmdAH-28.7 {Tcl_FileObjCmd: stat} { catch {unset x} set x 44 list [catch {file stat gorp.file x} msg] $msg $errorCode } {1 {can't set "x(dev)": variable isn't array} NONE} test cmdAH-28.8 {Tcl_FileObjCmd: stat} { # Sign extension of purported unsigned short to int. close [open foo.test w] file stat foo.test stat set x [expr {$stat(mode) > 0}] file delete foo.test set x } 1 test cmdAH-28.9 {Tcl_FileObjCmd: stat} {pcOnly} { # stat of root directory was failing. # don't care about answer, just that test runs. # relative paths that resolve to root set old [pwd] cd c:/ file stat c: stat file stat c:. stat file stat . stat cd $old file stat / stat file stat c:/ stat file stat c:/. stat } {} test cmdAH-28.10 {Tcl_FileObjCmd: stat} {pcOnly nonPortable} { # stat of root directory was failing. # don't care about answer, just that test runs. file stat //pop/$env(USERNAME) stat file stat //pop/$env(USERNAME)/ stat file stat //pop/$env(USERNAME)/. stat } {} test cmdAH-28.11 {Tcl_FileObjCmd: stat} {pcOnly nonPortable} { # stat of network directory was returning id of current local drive. set old [pwd] cd c:/ file stat //pop/$env(USERNAME) stat cd $old expr {$stat(dev) == 2} } 0 test cmdAH-28.12 {Tcl_FileObjCmd: stat} { # stat(mode) with S_IFREG flag was returned as a negative number # if mode_t was a short instead of an unsigned short. close [open foo.test w] file stat foo.test stat file delete foo.test expr {$stat(mode) > 0} } 1 catch {unset stat} # type file delete link.file test cmdAH-29.1 {Tcl_FileObjCmd: type} { list [catch {file size a b} msg] $msg } {1 {wrong # args: should be "file size name"}} test cmdAH-29.2 {Tcl_FileObjCmd: type} { file type dir.file } directory test cmdAH-29.3 {Tcl_FileObjCmd: type} { file type gorp.file } file test cmdAH-29.4 {Tcl_FileObjCmd: type} {unixOnly nonPortable} { exec ln -s a/b/c link.file set result [file type link.file] file delete link.file set result } link test cmdAH-29.5 {Tcl_FileObjCmd: type} { string tolower [list [catch {file type _bogus_} msg] $msg $errorCode] } {1 {could not read "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} # Error conditions test cmdAH-30.1 {Tcl_FileObjCmd: error conditions} { list [catch {file gorp x} msg] $msg } {1 {bad option "gorp": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}} test cmdAH-30.2 {Tcl_FileObjCmd: error conditions} { list [catch {file ex x} msg] $msg } {1 {ambiguous option "ex": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}} test cmdAH-30.3 {Tcl_FileObjCmd: error conditions} { list [catch {file is x} msg] $msg } {1 {ambiguous option "is": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}} test cmdAH-30.4 {Tcl_FileObjCmd: error conditions} { list [catch {file z x} msg] $msg } {1 {bad option "z": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}} test cmdAH-30.5 {Tcl_FileObjCmd: error conditions} { list [catch {file read x} msg] $msg } {1 {ambiguous option "read": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}} test cmdAH-30.6 {Tcl_FileObjCmd: error conditions} { list [catch {file s x} msg] $msg } {1 {ambiguous option "s": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}} test cmdAH-30.7 {Tcl_FileObjCmd: error conditions} { list [catch {file t x} msg] $msg } {1 {ambiguous option "t": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}} test cmdAH-30.8 {Tcl_FileObjCmd: error conditions} { list [catch {file dirname ~woohgy} msg] $msg } {1 {user "woohgy" doesn't exist}} # channels # In testing 'file channels', we need to make sure that a channel # created in one interp isn't visible in another. interp create simpleInterp interp create -safe safeInterp interp c safeInterp expose file file test cmdAH-31.1 {Tcl_FileObjCmd: channels, too many args} { list [catch {file channels a b} msg] $msg } {1 {wrong # args: should be "file channels ?pattern?"}} test cmdAH-31.2 {Tcl_FileObjCmd: channels, too many args} { # Normal interps start out with only the standard channels lsort [simpleInterp eval [list file chan]] } [lsort {stderr stdout stdin}] test cmdAH-31.3 {Tcl_FileObjCmd: channels, globbing} { string equal [file channels] [file channels *] } {1} test cmdAH-31.4 {Tcl_FileObjCmd: channels, globbing} { lsort [file channels std*] } [lsort {stdout stderr stdin}] set newFileId [open gorp.file w] test cmdAH-31.5 {Tcl_FileObjCmd: channels} { set res [file channels $newFileId] string equal $newFileId $res } {1} test cmdAH-31.6 {Tcl_FileObjCmd: channels in other interp} { # Safe interps start out with no channels safeInterp eval [list file channels] } {} test cmdAH-31.7 {Tcl_FileObjCmd: channels in other interp} { list [catch {safeInterp eval [list puts $newFileId "hello"]} msg] $msg } [list 1 "can not find channel named \"$newFileId\""] interp share {} $newFileId safeInterp interp share {} stdout safeInterp test cmdAH-31.8 {Tcl_FileObjCmd: channels in other interp} { # $newFileId should now be visible in both interps list [file channels $newFileId] \ [safeInterp eval [list file channels $newFileId]] } [list $newFileId $newFileId] test cmdAH-31.9 {Tcl_FileObjCmd: channels in other interp} { lsort [safeInterp eval [list file channels]] } [lsort [list stdout $newFileId]] test cmdAH-31.10 {Tcl_FileObjCmd: channels in other interp} { # we can now write to $newFileId from slave safeInterp eval [list puts $newFileId "hello"] } {} interp transfer {} $newFileId safeInterp test cmdAH-31.11 {Tcl_FileObjCmd: channels in other interp} { # $newFileId should now be visible only in safeInterp list [file channels $newFileId] \ [safeInterp eval [list file channels $newFileId]] } [list {} $newFileId] test cmdAH-31.12 {Tcl_FileObjCmd: channels in other interp} { lsort [safeInterp eval [list file channels]] } [lsort [list stdout $newFileId]] test cmdAH-31.13 {Tcl_FileObjCmd: channels in other interp} { safeInterp eval [list close $newFileId] safeInterp eval [list file channels] } {stdout} # This shouldn't work, but just in case a test above failed... catch {close $newFileId} interp delete safeInterp interp delete simpleInterp # cleanup catch {testsetplatform $platform} catch {unset platform} # Tcl_ForObjCmd is tested in for.test catch {exec chmod 777 dir.file} file delete -force dir.file file delete gorp.file file delete link.file cd $cmdAHwd ::tcltest::cleanupTests return \ No newline at end of file diff --git a/tests/encoding.test b/tests/encoding.test new file mode 100644 index 0000000..65cc1d6 --- /dev/null +++ b/tests/encoding.test @@ -0,0 +1 @@ +# This file contains a collection of tests for tclEncoding.c # Sourcing this file into Tcl runs the tests and generates output for # errors. No output means no errors were found. # # Copyright (c) 1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id$ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } proc toutf {args} { global x lappend x "toutf $args" } proc fromutf {args} { global x lappend x "fromutf $args" } # Some tests require the testencoding command set ::tcltest::testConstraints(testencoding) \ [expr {[info commands testencoding] != {}}] # TclInitEncodingSubsystem is tested by the rest of this file # TclFinalizeEncodingSubsystem is not currently tested test encoding-1.1 {Tcl_GetEncoding: system encoding} {testencoding} { testencoding create foo toutf fromutf set old [encoding system] encoding system foo set x {} encoding convertto abcd encoding system $old testencoding delete foo set x } {{fromutf }} test encoding-1.2 {Tcl_GetEncoding: existing encoding} {testencoding} { testencoding create foo toutf fromutf set x {} encoding convertto foo abcd testencoding delete foo set x } {{fromutf }} test encoding-1.3 {Tcl_GetEncoding: load encoding} { list [encoding convertto jis0208 \u4e4e] \ [encoding convertfrom jis0208 8C] } "8C \u4e4e" test encoding-2.1 {Tcl_FreeEncoding: refcount == 0} { encoding convertto jis0208 \u4e4e } {8C} test encoding-2.2 {Tcl_FreeEncoding: refcount != 0} {testencoding} { set system [encoding system] set path [testencoding path] encoding system shiftjis ;# incr ref count testencoding path [list [pwd]] set x [encoding convertto shiftjis \u4e4e] ;# old one found encoding system identity lappend x [catch {encoding convertto shiftjis \u4e4e} msg] $msg encoding system identity testencoding path $path encoding system $system set x } "\u008c\u00c1 1 {unknown encoding \"shiftjis\"}" test encoding-3.1 {Tcl_GetEncodingName, NULL} { set old [encoding system] encoding system shiftjis set x [encoding system] encoding system $old set x } {shiftjis} test encoding-3.2 {Tcl_GetEncodingName, non-null} { set old [fconfigure stdout -encoding] fconfigure stdout -encoding jis0208 set x [fconfigure stdout -encoding] fconfigure stdout -encoding $old set x } {jis0208} test encoding-4.1 {Tcl_GetEncodingNames} {testencoding} { file mkdir tmp/encoding close [open tmp/encoding/junk.enc w] close [open tmp/encoding/junk2.enc w] cd tmp set path [testencoding path] testencoding path {} catch {unset encodings} catch {unset x} foreach encoding [encoding names] { set encodings($encoding) 1 } testencoding path [list [pwd]] foreach encoding [encoding names] { if {![info exists encodings($encoding)]} { lappend x $encoding } } testencoding path $path cd .. file delete -force tmp lsort $x } {junk junk2} test encoding-5.1 {Tcl_SetSystemEncoding} { set old [encoding system] encoding system jis0208 set x [encoding convertto \u4e4e] encoding system identity encoding system $old set x } {8C} test encoding-5.2 {Tcl_SetSystemEncoding: test ref count} { set old [encoding system] encoding system $old string compare $old [encoding system] } {0} test encoding-6.1 {Tcl_CreateEncoding: new} {testencoding} { testencoding create foo {toutf 1} {fromutf 2} set x {} encoding convertfrom foo abcd encoding convertto foo abcd testencoding delete foo set x } {{toutf 1} {fromutf 2}} test encoding-6.2 {Tcl_CreateEncoding: replace encoding} {testencoding} { testencoding create foo {toutf a} {fromutf b} set x {} encoding convertfrom foo abcd encoding convertto foo abcd testencoding delete foo set x } {{toutf a} {fromutf b}} test encoding-7.1 {Tcl_ExternalToUtfDString: small buffer} { encoding convertfrom jis0208 8c8c8c8c } "\u543e\u543e\u543e\u543e" test encoding-7.2 {Tcl_UtfToExternalDString: big buffer} { set a 8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C append a $a append a $a append a $a append a $a set x [encoding convertfrom jis0208 $a] list [string length $x] [string index $x 0] } "512 \u4e4e" test encoding-8.1 {Tcl_ExternalToUtf} {fsIsWritable} { set f [open dummy w] fconfigure $f -translation binary -encoding iso8859-1 puts -nonewline $f "ab\x8c\xc1g" close $f set f [open dummy r] fconfigure $f -translation binary -encoding shiftjis set x [read $f] close $f file delete dummy set x } "ab\u4e4eg" test encoding-9.1 {Tcl_UtfToExternalDString: small buffer} { encoding convertto jis0208 "\u543e\u543e\u543e\u543e" } {8c8c8c8c} test encoding-9.2 {Tcl_UtfToExternalDString: big buffer} { set a \u4e4e\u4e4e\u4e4e\u4e4e\u4e4e\u4e4e\u4e4e\u4e4e append a $a append a $a append a $a append a $a append a $a append a $a set x [encoding convertto jis0208 $a] list [string length $x] [string range $x 0 1] } "1024 8C" test encoding-10.1 {Tcl_UtfToExternal} {fsIsWritable} { set f [open dummy w] fconfigure $f -translation binary -encoding shiftjis puts -nonewline $f "ab\u4e4eg" close $f set f [open dummy r] fconfigure $f -translation binary -encoding iso8859-1 set x [read $f] close $f file delete dummy set x } "ab\x8c\xc1g" test encoding-11.1 {LoadEncodingFile: unknown encoding} {testencoding} { set system [encoding system] set path [testencoding path] encoding system iso8859-1 testencoding path {} set x [list [catch {encoding convertto jis0208 \u4e4e} msg] $msg] testencoding path $path encoding system $system lappend x [encoding convertto jis0208 \u4e4e] } {1 {unknown encoding "jis0208"} 8C} test encoding-11.2 {LoadEncodingFile: single-byte} { encoding convertfrom jis0201 \xa1 } "\uff61" test encoding-11.3 {LoadEncodingFile: double-byte} { encoding convertfrom jis0208 8C } "\u4e4e" test encoding-11.4 {LoadEncodingFile: multi-byte} { encoding convertfrom shiftjis \x8c\xc1 } "\u4e4e" test encoding-11.5 {LoadEncodingFile: escape file} { encoding convertto iso2022 \u4e4e } "\x1b(B\x1b$@8C" test encoding-11.6 {LoadEncodingFile: invalid file} {testencoding} { set system [encoding system] set path [testencoding path] encoding system identity testencoding path tmp file mkdir tmp/encoding set f [open tmp/encoding/splat.enc w] fconfigure $f -translation binary puts $f "abcdefghijklmnop" close $f set x [list [catch {encoding convertto splat \u4e4e} msg] $msg] file delete -force tmp catch {file delete encoding} testencoding path $path encoding system $system set x } {1 {invalid encoding file "splat"}} # OpenEncodingFile is fully tested by the rest of the tests in this file. test encoding-12.1 {LoadTableEncoding: normal encoding} { set x [encoding convertto iso8859-3 \u120] append x [encoding convertto iso8859-3 \ud5] append x [encoding convertfrom iso8859-3 \xd5] } "\xd5?\u120" test encoding-12.2 {LoadTableEncoding: single-byte encoding} { set x [encoding convertto iso8859-3 ab\u0120g] append x [encoding convertfrom iso8859-3 ab\xd5g] } "ab\xd5gab\u120g" test encoding-12.3 {LoadTableEncoding: multi-byte encoding} { set x [encoding convertto shiftjis ab\u4e4eg] append x [encoding convertfrom shiftjis ab\x8c\xc1g] } "ab\x8c\xc1gab\u4e4eg" test encoding-12.4 {LoadTableEncoding: double-byte encoding} { set x [encoding convertto jis0208 \u4e4e\u3b1] append x [encoding convertfrom jis0208 8C&A] } "8C&A\u4e4e\u3b1" test encoding-12.5 {LoadTableEncoding: symbol encoding} { set x [encoding convertto symbol \u3b3] append x [encoding convertto symbol \u67] append x [encoding convertfrom symbol \x67] } "\x67\x67\u3b3" test encoding-13.1 {LoadEscapeTable} { set x [encoding convertto iso2022 ab\u4e4e\u68d9g] } "\x1b(Bab\x1b$@8C\x1b$\(DD%\x1b(Bg" test encoding-14.1 {BinaryProc} { encoding convertto identity \x12\x34\x56\xff\x69 } "\x12\x34\x56\xc3\xbf\x69" test encoding-15.1 {UtfToUtfProc} { encoding convertto utf-8 \xa3 } "\xc2\xa3" test encoding-16.1 {UnicodeToUtfProc} { encoding convertfrom unicode NN } "\u4e4e" test encoding-17.1 {UtfToUnicodeProc} { } {} test encoding-18.1 {TableToUtfProc} { } {} test encoding-19.1 {TableFromUtfProc} { } {} test encoding-20.1 {TableFreefProc} { } {} test encoding-21.1 {EscapeToUtfProc} { } {} test encoding-22.1 {EscapeFromUtfProc} { } {} # EscapeFreeProc, GetTableEncoding, unilen # are fully tested by the rest of this file # cleanup ::tcltest::cleanupTests return \ No newline at end of file diff --git a/tests/fCmd.test b/tests/fCmd.test new file mode 100644 index 0000000..a352783 --- /dev/null +++ b/tests/fCmd.test @@ -0,0 +1 @@ +# 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) 1996-1997 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 testchmod [string equal testchmod [info commands testchmod]] # Several tests require need to match results against the unix username set user {} if {$tcl_platform(platform) == "unix"} { catch {set user [exec whoami]} if {$user == ""} { catch {regexp {^[^(]*\(([^)]*)\)} [exec id] dummy user} } if {$user == ""} { set user "root" } } proc createfile {file {string a}} { set f [open $file w] puts -nonewline $f $string close $f return $string } # # checkcontent -- # # Ensures that file "file" contains only the string "matchString" # returns 0 if the file does not exist, or has a different content # proc checkcontent {file matchString} { if {[catch { set f [open $file] set fileString [read $f] close $f }]} { return 0 } return [string match $matchString $fileString] } proc openup {path} { testchmod 777 $path if {[file isdirectory $path]} { catch { foreach p [glob -directory $path *] { openup $p } } } } proc cleanup {args} { foreach p [concat [list .] $args] { set x "" catch { set x [glob -directory $p tf* td*] } foreach file $x { if {[catch {file delete -force -- $file}]} { catch {openup $file} catch {file delete -force -- $file} } } } } proc contents {file} { set f [open $file r] set r [read $f] close $f set r } set ::tcltest::testConstraints(fileSharing) 0 set ::tcltest::testConstraints(notFileSharing) 1 if {$tcl_platform(platform) == "macintosh"} { catch {file delete -force foo.dir} file mkdir foo.dir if {[catch {file attributes foo.dir -readonly 1}] == 0} { set ::tcltest::testConstraints(fileSharing) 1 set ::tcltest::testConstraints(notFileSharing) 0 } file delete -force foo.dir } set ::tcltest::testConstraints(xdev) 0 if {$tcl_platform(platform) == "unix"} { if {[catch {set m1 [exec df .]; set m2 [exec df /tmp]}] == 0} { set m1 [string range $m1 0 [expr [string first " " $m1]-1]] set m2 [string range $m2 0 [expr [string first " " $m2]-1]] if {$m1 != "" && $m2 != "" && $m1 != $m2 && [file exists $m1] && [file exists $m2]} { set ::tcltest::testConstraints(xdev) 1 } } } set root [lindex [file split [pwd]] 0] # A really long file name # length of long is 1216 chars, which should be greater than any static # buffer or allowable filename. set long "abcdefghihjllmnopqrstuvwxyz01234567890" append long $long append long $long append long $long append long $long append long $long test fCmd-1.1 {TclFileRenameCmd} {notRoot fsIsWritable} { cleanup createfile tf1 file rename tf1 tf2 glob tf* } {tf2} test fCmd-2.1 {TclFileCopyCmd} {notRoot fsIsWritable} { cleanup createfile tf1 file copy tf1 tf2 lsort [glob tf*] } {tf1 tf2} test fCmd-3.1 {FileCopyRename: FileForceOption fails} {notRoot} { list [catch {file rename -xyz} msg] $msg } {1 {bad option "-xyz": should be -force or --}} test fCmd-3.2 {FileCopyRename: not enough args} {notRoot} { list [catch {file rename xyz} msg] $msg } {1 {wrong # args: should be "file rename ?options? source ?source ...? target"}} test fCmd-3.3 {FileCopyRename: Tcl_TranslateFileName fails} {notRoot} { list [catch {file rename xyz ~_totally_bogus_user} msg] $msg } {1 {user "_totally_bogus_user" doesn't exist}} test fCmd-3.4 {FileCopyRename: Tcl_TranslateFileName passes} {notRoot} { cleanup list [catch {file copy tf1 ~} msg] $msg } {1 {error copying "tf1": no such file or directory}} test fCmd-3.5 {FileCopyRename: target doesn't exist: stat(target) != 0} {notRoot} { cleanup list [catch {file rename tf1 tf2 tf3} msg] $msg } {1 {error renaming: target "tf3" is not a directory}} test fCmd-3.6 {FileCopyRename: target tf3 is not a dir: !S_ISDIR(target)} \ {notRoot fsIsWritable} { cleanup createfile tf3 list [catch {file rename tf1 tf2 tf3} msg] $msg } {1 {error renaming: target "tf3" is not a directory}} test fCmd-3.7 {FileCopyRename: target exists & is directory} \ {notRoot fsIsWritable} { cleanup file mkdir td1 createfile tf1 tf1 file rename tf1 td1 contents [file join td1 tf1] } {tf1} test fCmd-3.8 {FileCopyRename: too many arguments: argc - i > 2} {notRoot} { cleanup list [catch {file rename tf1 tf2 tf3} msg] $msg } {1 {error renaming: target "tf3" is not a directory}} test fCmd-3.9 {FileCopyRename: too many arguments: argc - i > 2} {notRoot} { cleanup list [catch {file copy -force -- tf1 tf2 tf3} msg] $msg } {1 {error copying: target "tf3" is not a directory}} test fCmd-3.10 {FileCopyRename: just 2 arguments} {notRoot fsIsWritable} { cleanup createfile tf1 tf1 file rename tf1 tf2 contents tf2 } {tf1} test fCmd-3.11 {FileCopyRename: just 2 arguments} {notRoot fsIsWritable} { cleanup createfile tf1 tf1 file rename -force -force -- tf1 tf2 contents tf2 } {tf1} test fCmd-3.12 {FileCopyRename: move each source: 1 source} \ {notRoot fsIsWritable} { cleanup createfile tf1 tf1 file mkdir td1 file rename tf1 td1 contents [file join td1 tf1] } {tf1} test fCmd-3.13 {FileCopyRename: move each source: multiple sources} \ {notRoot fsIsWritable} { cleanup createfile tf1 tf1 createfile tf2 tf2 createfile tf3 tf3 createfile tf4 tf4 file mkdir td1 file rename tf1 tf2 tf3 tf4 td1 list [contents [file join td1 tf1]] [contents [file join td1 tf2]] \ [contents [file join td1 tf3]] [contents [file join td1 tf4]] } {tf1 tf2 tf3 tf4} test fCmd-3.14 {FileCopyRename: FileBasename fails} {notRoot fsIsWritable} { cleanup file mkdir td1 list [catch {file rename ~_totally_bogus_user td1} msg] $msg } {1 {user "_totally_bogus_user" doesn't exist}} test fCmd-3.15 {FileCopyRename: source[0] == '\0'} \ {notRoot unixOrPc fsIsWritable} { cleanup file mkdir td1 list [catch {file rename / td1} msg] $msg } {1 {error renaming "/" to "td1": file already exists}} test fCmd-3.16 {FileCopyRename: break on first error} {notRoot fsIsWritable} { cleanup createfile tf1 createfile tf2 createfile tf3 createfile tf4 file mkdir td1 createfile [file join td1 tf3] list [catch {file rename tf1 tf2 tf3 tf4 td1} msg] $msg } [subst {1 {error renaming "tf3" to "[file join td1 tf3]": file already exists}}] test fCmd-4.1 {TclFileMakeDirsCmd: make each dir: 1 dir} \ {notRoot fsIsWritable} { cleanup file mkdir td1 glob td* } {td1} test fCmd-4.2 {TclFileMakeDirsCmd: make each dir: multiple dirs} \ {notRoot fsIsWritable} { cleanup file mkdir td1 td2 td3 lsort [glob td*] } {td1 td2 td3} test fCmd-4.3 {TclFileMakeDirsCmd: stops on first error} \ {notRoot fsIsWritable} { cleanup createfile tf1 catch {file mkdir td1 td2 tf1 td3 td4} glob td1 td2 tf1 td3 td4 } {td1 td2 tf1} test fCmd-4.4 {TclFileMakeDirsCmd: Tcl_TranslateFileName fails} {notRoot} { cleanup list [catch {file mkdir ~_totally_bogus_user} msg] $msg } {1 {user "_totally_bogus_user" doesn't exist}} test fCmd-4.5 {TclFileMakeDirsCmd: Tcl_SplitPath returns 0: *name == '\0'} \ {notRoot} { cleanup list [catch {file mkdir ""} msg] $msg } {1 {can't create directory "": no such file or directory}} test fCmd-4.6 {TclFileMakeDirsCmd: one level deep} {notRoot} { cleanup file mkdir td1 glob td1 } {td1} test fCmd-4.7 {TclFileMakeDirsCmd: multi levels deep} {notRoot} { cleanup file mkdir [file join td1 td2 td3 td4] glob td1 [file join td1 td2] } "td1 [file join td1 td2]" test fCmd-4.8 {TclFileMakeDirsCmd: already exist: lstat(target) == 0} {notRoot} { cleanup file mkdir td1 set x [file exist td1] file mkdir td1 list $x [file exist td1] } {1 1} test fCmd-4.9 {TclFileMakeDirsCmd: exists, not dir} {notRoot} { cleanup createfile tf1 list [catch {file mkdir tf1} msg] $msg } [subst {1 {can't create directory "[file join tf1]": file already exists}}] test fCmd-4.10 {TclFileMakeDirsCmd: exists, is dir} {notRoot} { cleanup file mkdir td1 set x [file exist td1] file mkdir td1 list $x [file exist td1] } {1 1} test fCmd-4.11 {TclFileMakeDirsCmd: doesn't exist: errno != ENOENT} \ {unixOnly notRoot testchmod} { cleanup file mkdir td1/td2/td3 testchmod 000 td1/td2 set msg [list [catch {file mkdir td1/td2/td3/td4} msg] $msg] testchmod 755 td1/td2 set msg } {1 {can't create directory "td1/td2/td3": permission denied}} test fCmd-4.12 {TclFileMakeDirsCmd: doesn't exist: errno != ENOENT} {macOnly} { cleanup list [catch {file mkdir nonexistentvolume:} msg] $msg } {1 {can't create directory "nonexistentvolume:": invalid argument}} test fCmd-4.13 {TclFileMakeDirsCmd: doesn't exist: errno == ENOENT} {notRoot} { cleanup set x [file exist td1] file mkdir td1 list $x [file exist td1] } {0 1} test fCmd-4.14 {TclFileMakeDirsCmd: TclpCreateDirectory fails} \ {unixOnly notRoot} { cleanup file delete -force foo file mkdir foo file attr foo -perm 040000 set result [list [catch {file mkdir foo/tf1} msg] $msg] file delete -force foo set result } {1 {can't create directory "foo/tf1": permission denied}} test fCmd-4.15 {TclFileMakeDirsCmd: TclpCreateDirectory fails} {macOnly} { list [catch {file mkdir ${root}:} msg] $msg } [subst {1 {can't create directory "${root}:": no such file or directory}}] test fCmd-4.16 {TclFileMakeDirsCmd: TclpCreateDirectory succeeds} {notRoot} { cleanup file mkdir tf1 file exists tf1 } {1} test fCmd-5.1 {TclFileDeleteCmd: FileForceOption fails} {notRoot} { list [catch {file delete -xyz} msg] $msg } {1 {bad option "-xyz": should be -force or --}} test fCmd-5.2 {TclFileDeleteCmd: not enough args} {notRoot} { list [catch {file delete -force -force} msg] $msg } {1 {wrong # args: should be "file delete ?options? file ?file ...?"}} test fCmd-5.3 {TclFileDeleteCmd: 1 file} {notRoot} { cleanup createfile tf1 createfile tf2 file mkdir td1 file delete tf2 glob tf* td* } {tf1 td1} test fCmd-5.4 {TclFileDeleteCmd: multiple files} {notRoot} { cleanup createfile tf1 createfile tf2 file mkdir td1 set x [list [file exist tf1] [file exist tf2] [file exist td1]] file delete tf1 td1 tf2 lappend x [file exist tf1] [file exist tf2] [file exist tf3] } {1 1 1 0 0 0} test fCmd-5.5 {TclFileDeleteCmd: stop at first error} {notRoot unixOrPc} { cleanup createfile tf1 createfile tf2 file mkdir td1 catch {file delete tf1 td1 $root tf2} list [file exist tf1] [file exist tf2] [file exist td1] } {0 1 0} test fCmd-5.6 {TclFileDeleteCmd: Tcl_TranslateFileName fails} {notRoot} { list [catch {file delete ~_totally_bogus_user} msg] $msg } {1 {user "_totally_bogus_user" doesn't exist}} test fCmd-5.7 {TclFileDeleteCmd: Tcl_TranslateFileName succeeds} {notRoot} { catch {file delete ~/tf1} createfile ~/tf1 file delete ~/tf1 } {} test fCmd-5.8 {TclFileDeleteCmd: file doesn't exist: lstat(name) != 0} {notRoot} { cleanup set x [file exist tf1] file delete tf1 list $x [file exist tf1] } {0 0} test fCmd-5.9 {TclFileDeleteCmd: is directory} {notRoot} { cleanup file mkdir td1 file delete td1 file exist td1 } {0} test fCmd-5.10 {TclFileDeleteCmd: TclpRemoveDirectory fails} {notRoot} { cleanup file mkdir td1/td2 list [catch {file delete td1} msg] $msg } {1 {error deleting "td1": directory not empty}} test fCmd-6.1 {CopyRenameOneFile: bad source} {notRoot} { # can't test this, because it's caught by FileCopyRename } {} test fCmd-6.2 {CopyRenameOneFile: bad target} {notRoot} { # can't test this, because it's caught by FileCopyRename } {} test fCmd-6.3 {CopyRenameOneFile: lstat(source) != 0} {notRoot} { cleanup list [catch {file rename tf1 tf2} msg] $msg } {1 {error renaming "tf1": no such file or directory}} test fCmd-6.4 {CopyRenameOneFile: lstat(source) == 0} {notRoot} { cleanup createfile tf1 file rename tf1 tf2 glob tf* } {tf2} test fCmd-6.5 {CopyRenameOneFile: lstat(target) != 0} {notRoot} { cleanup createfile tf1 file rename tf1 tf2 glob tf* } {tf2} test fCmd-6.6 {CopyRenameOneFile: errno != ENOENT} {unixOnly notRoot testchmod} { cleanup file mkdir td1 testchmod 000 td1 createfile tf1 set msg [list [catch {file rename tf1 td1} msg] $msg] testchmod 755 td1 set msg } {1 {error renaming "tf1" to "td1/tf1": permission denied}} test fCmd-6.7 {CopyRenameOneFile: errno != ENOENT} {95} { cleanup createfile tf1 list [catch {file rename tf1 $long} msg] $msg } [subst {1 {error renaming "tf1" to "$long": file name too long}}] test fCmd-6.8 {CopyRenameOneFile: errno != ENOENT} {macOnly} { cleanup createfile tf1 list [catch {file rename tf1 $long} msg] $msg } [subst {1 {error renaming "tf1" to "$long": file name too long}}] test fCmd-6.9 {CopyRenameOneFile: errno == ENOENT} {unixOnly notRoot} { cleanup createfile tf1 file rename tf1 tf2 glob tf* } {tf2} test fCmd-6.10 {CopyRenameOneFile: lstat(target) == 0} {notRoot} { cleanup createfile tf1 createfile tf2 list [catch {file rename tf1 tf2} msg] $msg } {1 {error renaming "tf1" to "tf2": file already exists}} test fCmd-6.11 {CopyRenameOneFile: force == 0} {notRoot} { cleanup createfile tf1 createfile tf2 list [catch {file rename tf1 tf2} msg] $msg } {1 {error renaming "tf1" to "tf2": file already exists}} test fCmd-6.12 {CopyRenameOneFile: force != 0} {notRoot} { cleanup createfile tf1 createfile tf2 file rename -force tf1 tf2 glob tf* } {tf2} test fCmd-6.13 {CopyRenameOneFile: source is dir, target is file} {notRoot} { cleanup file mkdir td1 file mkdir td2 createfile [file join td2 td1] list [catch {file rename -force td1 td2} msg] $msg } [subst {1 {can't overwrite file "[file join td2 td1]" with directory "td1"}}] test fCmd-6.14 {CopyRenameOneFile: source is file, target is dir} {notRoot} { cleanup createfile tf1 file mkdir [file join td1 tf1] list [catch {file rename -force tf1 td1} msg] $msg } [subst {1 {can't overwrite directory "[file join td1 tf1]" with file "tf1"}}] test fCmd-6.15 {CopyRenameOneFile: TclpRenameFile succeeds} {notRoot} { cleanup file mkdir [file join td1 td2] file mkdir td2 createfile [file join td2 tf1] file rename -force td2 td1 file exists [file join td1 td2 tf1] } {1} test fCmd-6.16 {CopyRenameOneFile: TclpCopyRenameOneFile fails} {notRoot} { cleanup file mkdir [file join td1 td2] createfile [file join td1 td2 tf1] file mkdir td2 list [catch {file rename -force td2 td1} msg] $msg } [subst {1 {error renaming "td2" to "[file join td1 td2]": file already exists}}] test fCmd-6.17 {CopyRenameOneFile: errno == EINVAL} {notRoot} { cleanup list [catch {file rename -force $root tf1} msg] $msg } [subst {1 {error renaming "$root" to "tf1": trying to rename a volume or move a directory into itself}}] test fCmd-6.18 {CopyRenameOneFile: errno != EXDEV} {notRoot} { cleanup file mkdir [file join td1 td2] createfile [file join td1 td2 tf1] file mkdir td2 list [catch {file rename -force td2 td1} msg] $msg } [subst {1 {error renaming "td2" to "[file join td1 td2]": file already exists}}] test fCmd-6.19 {CopyRenameOneFile: errno == EXDEV} {unixOnly notRoot} { cleanup /tmp createfile tf1 file rename tf1 /tmp glob tf* /tmp/tf1 } {/tmp/tf1} test fCmd-6.20 {CopyRenameOneFile: errno == EXDEV} {pcOnly} { catch {file delete -force c:/tcl8975@ d:/tcl8975@} file mkdir c:/tcl8975@ if [catch {file rename c:/tcl8975@ d:/}] { set msg d:/tcl8975@ } else { set msg [glob c:/tcl8975@ d:/tcl8975@] file delete -force d:/tcl8975@ } file delete -force c:/tcl8975@ set msg } {d:/tcl8975@} test fCmd-6.21 {CopyRenameOneFile: copy/rename: S_ISDIR(source)} \ {unixOnly notRoot} { cleanup /tmp file mkdir td1 file rename td1 /tmp glob td* /tmp/td* } {/tmp/td1} test fCmd-6.22 {CopyRenameOneFile: copy/rename: !S_ISDIR(source)} \ {unixOnly notRoot} { cleanup /tmp createfile tf1 file rename tf1 /tmp glob tf* /tmp/tf* } {/tmp/tf1} test fCmd-6.23 {CopyRenameOneFile: TclpCopyDirectory failed} \ {unixOnly notRoot xdev} { cleanup /tmp file mkdir td1/td2/td3 exec chmod 000 td1 set msg [list [catch {file rename td1 /tmp} msg] $msg] exec chmod 755 td1 set msg } {1 {error renaming "td1": permission denied}} test fCmd-6.24 {CopyRenameOneFile: error uses original name} \ {unixOnly notRoot} { cleanup file mkdir ~/td1/td2 exec chmod 000 [file join [file dirname ~] [file tail ~] td1] set msg [list [catch {file copy ~/td1 td1} msg] $msg] exec chmod 755 [file join [file dirname ~] [file tail ~] td1] file delete -force ~/td1 set msg } {1 {error copying "~/td1": permission denied}} test fCmd-6.25 {CopyRenameOneFile: error uses original name} \ {unixOnly notRoot} { cleanup file mkdir td2 file mkdir ~/td1 exec chmod 000 [file join [file dirname ~] [file tail ~] td1] set msg [list [catch {file copy td2 ~/td1} msg] $msg] exec chmod 755 [file join [file dirname ~] [file tail ~] td1] file delete -force ~/td1 set msg } {1 {error copying "td2" to "~/td1/td2": permission denied}} test fCmd-6.26 {CopyRenameOneFile: doesn't use original name} \ {unixOnly notRoot} { cleanup file mkdir ~/td1/td2 exec chmod 000 [file join [file dirname ~] [file tail ~] td1 td2] set msg [list [catch {file copy ~/td1 td1} msg] $msg] exec chmod 755 [file join [file dirname ~] [file tail ~] td1 td2] file delete -force ~/td1 set msg } "1 {error copying \"~/td1\" to \"td1\": \"[file join [file dirname ~] [file tail ~] td1 td2]\": permission denied}" test fCmd-6.27 {CopyRenameOneFile: TclpCopyDirectory failed} \ {unixOnly notRoot xdev} { cleanup /tmp file mkdir td1/td2/td3 file mkdir /tmp/td1 createfile /tmp/td1/tf1 list [catch {file rename -force td1 /tmp} msg] $msg } {1 {error renaming "td1" to "/tmp/td1": file already exists}} test fCmd-6.28 {CopyRenameOneFile: TclpCopyDirectory failed} \ {unixOnly notRoot xdev} { cleanup /tmp file mkdir td1/td2/td3 exec chmod 000 td1/td2/td3 set msg [list [catch {file rename td1 /tmp} msg] $msg] exec chmod 755 td1/td2/td3 set msg } {1 {error renaming "td1" to "/tmp/td1": "td1/td2/td3": permission denied}} test fCmd-6.29 {CopyRenameOneFile: TclpCopyDirectory passed} \ {unixOnly notRoot xdev} { cleanup /tmp file mkdir td1/td2/td3 file rename td1 /tmp glob td* /tmp/td1/t* } {/tmp/td1/td2} test fCmd-6.30 {CopyRenameOneFile: TclpRemoveDirectory failed} \ {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 fCmd-6.31 {CopyRenameOneFile: TclpDeleteFile passed} \ {unixOnly notRoot xdev} { catch {cleanup /tmp} file mkdir /tmp/td1 createfile /tmp/td1/tf1 file rename /tmp/td1/tf1 tf1 list [file exists /tmp/td1/tf1] [file exists tf1] } {0 1} test fCmd-6.32 {CopyRenameOneFile: copy} {notRoot} { cleanup list [catch {file copy tf1 tf2} msg] $msg } {1 {error copying "tf1": no such file or directory}} catch {cleanup /tmp} test fCmd-7.1 {FileForceOption: none} {notRoot} { cleanup file mkdir [file join tf1 tf2] list [catch {file delete tf1} msg] $msg } {1 {error deleting "tf1": directory not empty}} test fCmd-7.2 {FileForceOption: -force} {notRoot} { cleanup file mkdir [file join tf1 tf2] file delete -force tf1 } {} test fCmd-7.3 {FileForceOption: --} {notRoot} { createfile -tf1 file delete -- -tf1 } {} test fCmd-7.4 {FileForceOption: bad option} {notRoot} { createfile -tf1 set msg [list [catch {file delete -tf1} msg] $msg] file delete -- -tf1 set msg } {1 {bad option "-tf1": should be -force or --}} test fCmd-7.5 {FileForceOption: multiple times through loop} {notRoot} { createfile -- createfile -force file delete -force -force -- -- -force list [catch {glob -- -- -force} msg] $msg } {1 {no files matched glob patterns "-- -force"}} test fCmd-8.1 {FileBasename: basename of ~user: argc == 1 && *path == ~} \ {unixOnly notRoot knownBug} { # Labelled knownBug because it is dangerous [Bug: 3881] file mkdir td1 file attr td1 -perm 040000 set result [list [catch {file rename ~$user td1} msg] $msg] file delete -force td1 set result } "1 {error renaming \"~$user\" to \"td1/[file tail ~$user]\": permission denied}" test fCmd-8.2 {FileBasename: basename of ~user: argc == 1 && *path == ~} \ {unixOnly notRoot} { file tail ~$user } "$user" test fCmd-9.1 {file rename: comprehensive: EACCES} {unixOnly notRoot} { cleanup file mkdir td1 file mkdir td2 file attr td2 -perm 040000 set result [list [catch {file rename td1 td2/} msg] $msg] file delete -force td2 file delete -force td1 set result } {1 {error renaming "td1" to "td2/td1": permission denied}} test fCmd-9.2 {file rename: comprehensive: source doesn't exist} {notRoot} { cleanup list [catch {file rename tf1 tf2} msg] $msg } {1 {error renaming "tf1": no such file or directory}} test fCmd-9.3 {file rename: comprehensive: file to new name} {notRoot testchmod} { cleanup createfile tf1 createfile tf2 testchmod 444 tf2 file rename tf1 tf3 file rename tf2 tf4 list [lsort [glob tf*]] [file writable tf3] [file writable tf4] } {{tf3 tf4} 1 0} test fCmd-9.4 {file rename: comprehensive: dir to new name} {unixOrPc notRoot testchmod} { cleanup file mkdir td1 td2 testchmod 555 td2 file rename td1 td3 file rename td2 td4 list [lsort [glob td*]] [file writable td3] [file writable td4] } {{td3 td4} 1 0} test fCmd-9.5 {file rename: comprehensive: file to self} {notRoot testchmod} { cleanup createfile tf1 tf1 createfile tf2 tf2 testchmod 444 tf2 file rename -force tf1 tf1 file rename -force tf2 tf2 list [contents tf1] [contents tf2] [file writable tf1] [file writable tf2] } {tf1 tf2 1 0} test fCmd-9.6 {file rename: comprehensive: dir to self} {notRoot unixOrPc testchmod} { cleanup file mkdir td1 file mkdir td2 testchmod 555 td2 file rename -force td1 . file rename -force td2 . list [lsort [glob td*]] [file writable td1] [file writable td2] } {{td1 td2} 1 0} test fCmd-9.7 {file rename: comprehensive: file to existing file} {notRoot testchmod} { cleanup createfile tf1 createfile tf2 createfile tfs1 createfile tfs2 createfile tfs3 createfile tfs4 createfile tfd1 createfile tfd2 createfile tfd3 createfile tfd4 testchmod 444 tfs3 testchmod 444 tfs4 testchmod 444 tfd2 testchmod 444 tfd4 set msg [list [catch {file rename tf1 tf2} msg] $msg] file rename -force tfs1 tfd1 file rename -force tfs2 tfd2 file rename -force tfs3 tfd3 file rename -force tfs4 tfd4 list [lsort [glob tf*]] $msg [file writable tfd1] [file writable tfd2] [file writable tfd3] [file writable tfd4] } {{tf1 tf2 tfd1 tfd2 tfd3 tfd4} {1 {error renaming "tf1" to "tf2": file already exists}} 1 1 0 0} test fCmd-9.8 {file rename: comprehensive: dir to empty dir} {notRoot testchmod} { # Under unix, you can rename a read-only directory, but you can't # move it into another directory. cleanup file mkdir td1 file mkdir [file join td2 td1] file mkdir tds1 file mkdir tds2 file mkdir tds3 file mkdir tds4 file mkdir [file join tdd1 tds1] file mkdir [file join tdd2 tds2] file mkdir [file join tdd3 tds3] file mkdir [file join tdd4 tds4] if {$tcl_platform(platform) != "unix" && $tcl_platform(platform) != "macintosh"} { testchmod 555 tds3 testchmod 555 tds4 } if {$tcl_platform(platform) != "macintosh"} { testchmod 555 [file join tdd2 tds2] testchmod 555 [file join tdd4 tds4] } set msg [list [catch {file rename td1 td2} msg] $msg] file rename -force tds1 tdd1 file rename -force tds2 tdd2 file rename -force tds3 tdd3 file rename -force tds4 tdd4 if {$tcl_platform(platform) != "unix" && $tcl_platform(platform) != "macintosh"} { set w3 [file writable [file join tdd3 tds3]] set w4 [file writable [file join tdd4 tds4]] } else { set w3 0 set w4 0 } list [lsort [glob td*]] $msg [file writable [file join tdd1 tds1]] \ [file writable [file join tdd2 tds2]] $w3 $w4 } [subst {{td1 td2 tdd1 tdd2 tdd3 tdd4} {1 {error renaming "td1" to "[file join td2 td1]": file already exists}} 1 1 0 0}] test fCmd-9.9 {file rename: comprehensive: dir to non-empty dir} {notRoot testchmod} { cleanup file mkdir tds1 file mkdir tds2 file mkdir [file join tdd1 tds1 xxx] file mkdir [file join tdd2 tds2 xxx] if {$tcl_platform(platform) != "unix" && $tcl_platform(platform) != "macintosh"} { testchmod 555 tds2 } set a1 [list [catch {file rename -force tds1 tdd1} msg] $msg] set a2 [list [catch {file rename -force tds2 tdd2} msg] $msg] if {$tcl_platform(platform) != "unix" && $tcl_platform(platform) != "macintosh"} { set w2 [file writable tds2] } else { set w2 0 } list [lsort [glob td*]] $a1 $a2 [file writable tds1] $w2 } [subst {{tdd1 tdd2 tds1 tds2} {1 {error renaming "tds1" to "[file join tdd1 tds1]": file already exists}} {1 {error renaming "tds2" to "[file join tdd2 tds2]": file already exists}} 1 0}] test fCmd-9.10 {file rename: comprehensive: file to new name and dir} {notRoot testchmod} { cleanup createfile tf1 createfile tf2 file mkdir td1 testchmod 444 tf2 file rename tf1 [file join td1 tf3] file rename tf2 [file join td1 tf4] list [catch {glob tf*}] [lsort [glob -directory td1 t*]] \ [file writable [file join td1 tf3]] [file writable [file join td1 tf4]] } [subst {1 {[file join td1 tf3] [file join td1 tf4]} 1 0}] test fCmd-9.11 {file rename: comprehensive: dir to new name and dir} {notRoot testchmod} { cleanup file mkdir td1 file mkdir td2 file mkdir td3 if {$tcl_platform(platform) != "unix" && $tcl_platform(platform) != "macintosh"} { testchmod 555 td2 } file rename td1 [file join td3 td3] file rename td2 [file join td3 td4] if {$tcl_platform(platform) != "unix" && $tcl_platform(platform) != "macintosh"} { set w4 [file writable [file join td3 td4]] } else { set w4 0 } list [lsort [glob td*]] [lsort [glob -directory td3 t*]] \ [file writable [file join td3 td3]] $w4 } [subst {td3 {[file join td3 td3] [file join td3 td4]} 1 0}] test fCmd-9.12 {file rename: comprehensive: target exists} {notRoot testchmod} { cleanup file mkdir [file join td1 td2] [file join td2 td1] if {$tcl_platform(platform) != "macintosh"} { testchmod 555 [file join td2 td1] } file mkdir [file join td3 td4] [file join td4 td3] file rename -force td3 td4 set msg [list [file exists td3] [file exists [file join td4 td3 td4]] \ [catch {file rename td1 td2} msg] $msg] if {$tcl_platform(platform) != "macintosh"} { testchmod 755 [file join td2 td1] } set msg } [subst {0 1 1 {error renaming "td1" to "[file join td2 td1]": file already exists}}] test fCmd-9.13 {file rename: comprehensive: can't overwrite target} {notRoot} { cleanup file mkdir [file join td1 td2] [file join td2 td1 td4] list [catch {file rename -force td1 td2} msg] $msg } [subst {1 {error renaming "td1" to "[file join td2 td1]": file already exists}}] test fCmd-9.14 {file rename: comprehensive: dir into self} {notRoot} { cleanup file mkdir td1 list [glob td*] [list [catch {file rename td1 td1} msg] $msg] } [subst {td1 {1 {error renaming "td1" to "[file join td1 td1]": trying to rename a volume or move a directory into itself}}}] test fCmd-9.15 {file rename: comprehensive: source and target incompatible} \ {notRoot} { cleanup file mkdir td1 createfile tf1 list [catch {file rename -force td1 tf1} msg] $msg } {1 {can't overwrite file "tf1" with directory "td1"}} test fCmd-9.16 {file rename: comprehensive: source and target incompatible} \ {notRoot} { cleanup file mkdir td1/tf1 createfile tf1 list [catch {file rename -force tf1 td1} msg] $msg } [subst {1 {can't overwrite directory "[file join td1 tf1]" with file "tf1"}}] test fCmd-10.1 {file copy: comprehensive: source doesn't exist} {notRoot} { cleanup list [catch {file copy tf1 tf2} msg] $msg } {1 {error copying "tf1": no such file or directory}} test fCmd-10.2 {file copy: comprehensive: file to new name} {notRoot testchmod} { cleanup createfile tf1 tf1 createfile tf2 tf2 testchmod 444 tf2 file copy tf1 tf3 file copy tf2 tf4 list [lsort [glob tf*]] [contents tf3] [contents tf4] [file writable tf3] [file writable tf4] } {{tf1 tf2 tf3 tf4} tf1 tf2 1 0} test fCmd-10.3 {file copy: comprehensive: dir to new name} {notRoot unixOrPc testchmod} { cleanup file mkdir [file join td1 tdx] file mkdir [file join td2 tdy] testchmod 555 td2 file copy td1 td3 file copy td2 td4 set msg [list [lsort [glob td*]] [glob -directory td3 t*] \ [glob -directory td4 t*] [file writable td3] [file writable td4]] if {$tcl_platform(platform) != "macintosh"} { testchmod 755 td2 testchmod 755 td4 } set msg } [subst {{td1 td2 td3 td4} [file join td3 tdx] [file join td4 tdy] 1 0}] test fCmd-10.4 {file copy: comprehensive: file to existing file} {notRoot testchmod} { cleanup createfile tf1 createfile tf2 createfile tfs1 createfile tfs2 createfile tfs3 createfile tfs4 createfile tfd1 createfile tfd2 createfile tfd3 createfile tfd4 testchmod 444 tfs3 testchmod 444 tfs4 testchmod 444 tfd2 testchmod 444 tfd4 set msg [list [catch {file copy tf1 tf2} msg] $msg] file copy -force tfs1 tfd1 file copy -force tfs2 tfd2 file copy -force tfs3 tfd3 file copy -force tfs4 tfd4 list [lsort [glob tf*]] $msg [file writable tfd1] [file writable tfd2] [file writable tfd3] [file writable tfd4] } {{tf1 tf2 tfd1 tfd2 tfd3 tfd4 tfs1 tfs2 tfs3 tfs4} {1 {error copying "tf1" to "tf2": file already exists}} 1 1 0 0} test fCmd-10.5 {file copy: comprehensive: dir to empty dir} {notRoot testchmod} { cleanup file mkdir td1 file mkdir [file join td2 td1] file mkdir tds1 file mkdir tds2 file mkdir tds3 file mkdir tds4 file mkdir [file join tdd1 tds1] file mkdir [file join tdd2 tds2] file mkdir [file join tdd3 tds3] file mkdir [file join tdd4 tds4] if {$tcl_platform(platform) != "macintosh"} { testchmod 555 tds3 testchmod 555 tds4 testchmod 555 [file join tdd2 tds2] testchmod 555 [file join tdd4 tds4] } set a1 [list [catch {file copy td1 td2} msg] $msg] set a2 [list [catch {file copy -force tds1 tdd1} msg] $msg] set a3 [catch {file copy -force tds2 tdd2}] set a4 [catch {file copy -force tds3 tdd3}] set a5 [catch {file copy -force tds4 tdd4}] list [lsort [glob td*]] $a1 $a2 $a3 $a4 $a5 } [subst {{td1 td2 tdd1 tdd2 tdd3 tdd4 tds1 tds2 tds3 tds4} {1 {error copying "td1" to "[file join td2 td1]": file already exists}} {1 {error copying "tds1" to "[file join tdd1 tds1]": file already exists}} 1 1 1}] test fCmd-10.6 {file copy: comprehensive: dir to non-empty dir} \ {notRoot unixOrPc testchmod} { cleanup file mkdir tds1 file mkdir tds2 file mkdir [file join tdd1 tds1 xxx] file mkdir [file join tdd2 tds2 xxx] testchmod 555 tds2 set a1 [list [catch {file copy -force tds1 tdd1} msg] $msg] set a2 [list [catch {file copy -force tds2 tdd2} msg] $msg] list [lsort [glob td*]] $a1 $a2 [file writable tds1] [file writable tds2] } [subst {{tdd1 tdd2 tds1 tds2} {1 {error copying "tds1" to "[file join tdd1 tds1]": file already exists}} {1 {error copying "tds2" to "[file join tdd2 tds2]": file already exists}} 1 0}] test fCmd-10.7 {file rename: comprehensive: file to new name and dir} {notRoot testchmod} { cleanup createfile tf1 createfile tf2 file mkdir td1 testchmod 444 tf2 file copy tf1 [file join td1 tf3] file copy tf2 [file join td1 tf4] list [lsort [glob tf*]] [lsort [glob -directory td1 t*]] \ [file writable [file join td1 tf3]] [file writable [file join td1 tf4]] } [subst {{tf1 tf2} {[file join td1 tf3] [file join td1 tf4]} 1 0}] test fCmd-10.8 {file rename: comprehensive: dir to new name and dir} \ {notRoot unixOrPc testchmod} { cleanup file mkdir td1 file mkdir td2 file mkdir td3 testchmod 555 td2 file copy td1 [file join td3 td3] file copy td2 [file join td3 td4] list [lsort [glob td*]] [lsort [glob -directory td3 t*]] \ [file writable [file join td3 td3]] [file writable [file join td3 td4]] } [subst {{td1 td2 td3} {[file join td3 td3] [file join td3 td4]} 1 0}] test fCmd-10.9 {file copy: comprehensive: source and target incompatible} \ {notRoot} { cleanup file mkdir td1 createfile tf1 list [catch {file copy -force td1 tf1} msg] $msg } {1 {can't overwrite file "tf1" with directory "td1"}} test fCmd-10.10 {file copy: comprehensive: source and target incompatible} \ {notRoot} { cleanup file mkdir [file join td1 tf1] createfile tf1 list [catch {file copy -force tf1 td1} msg] $msg } [subst {1 {can't overwrite directory "[file join td1 tf1]" with file "tf1"}}] cleanup # old tests test fCmd-11.1 {TclFileRenameCmd: -- option } {notRoot} { catch {file delete -force -- -tfa1} set s [createfile -tfa1] file rename -- -tfa1 tfa2 set result [expr [checkcontent tfa2 $s] && ![file exists -tfa1]] file delete tfa2 set result } {1} test fCmd-11.2 {TclFileRenameCmd: bad option } {notRoot} { catch {file delete -force -- tfa1} set s [createfile tfa1] set r1 [catch {file rename -x tfa1 tfa2}] set result [expr $r1 && [checkcontent tfa1 $s] && ![file exists tfa2]] file delete tfa1 set result } {1} test fCmd-11.3 {TclFileRenameCmd: bad \# args} { catch {file rename -- } } {1} test fCmd-11.4 {TclFileRenameCmd: target filename translation failing} {notRoot} { global env set temp $env(HOME) unset env(HOME) set result [catch {file rename tfa ~/foobar }] set env(HOME) $temp set result } {1} test fCmd-11.5 {TclFileRenameCmd: > 1 source & target is not a dir} {notRoot} { catch {file delete -force -- tfa1 tfa2 tfa3} createfile tfa1 createfile tfa2 createfile tfa3 set result [catch {file rename tfa1 tfa2 tfa3}] file delete tfa1 tfa2 tfa3 set result } {1} test fCmd-11.6 {TclFileRenameCmd: : single file into directory} {notRoot} { catch {file delete -force -- tfa1 tfad} set s [createfile tfa1] file mkdir tfad file rename tfa1 tfad set result [expr [checkcontent tfad/tfa1 $s] && ![file exists tfa1]] file delete -force tfad set result } {1} test fCmd-11.7 {TclFileRenameCmd: : multiple files into directory} {notRoot} { catch {file delete -force -- tfa1 tfa2 tfad} set s1 [createfile tfa1 ] set s2 [createfile tfa2 ] file mkdir tfad file rename tfa1 tfa2 tfad set r1 [checkcontent tfad/tfa1 $s1] set r2 [checkcontent tfad/tfa2 $s2] set result [expr $r1 && $r2 && ![file exists tfa1] && ![file exists tfa2]] file delete -force tfad set result } {1} test fCmd-11.8 {TclFileRenameCmd: error renaming file to directory} {notRoot} { catch {file delete -force -- tfa tfad} set s [createfile tfa ] file mkdir tfad file mkdir tfad/tfa set r1 [catch {file rename tfa tfad}] set r2 [checkcontent tfa $s] set r3 [file isdir tfad] set result [expr $r1 && $r2 && $r3 ] file delete -force tfa tfad set result } {1} # # Coverage tests for renamefile() ; # test fCmd-12.1 {renamefile: source filename translation failing} {notRoot} { global env set temp $env(HOME) unset env(HOME) set result [catch {file rename ~/tfa1 tfa2}] set env(HOME) $temp set result } {1} test fCmd-12.2 {renamefile: src filename translation failing} {notRoot} { global env set temp $env(HOME) unset env(HOME) set s [createfile tfa1] file mkdir tfad set result [catch {file rename tfa1 ~/tfa2 tfad}] set env(HOME) $temp file delete -force tfad set result } {1} test fCmd-12.3 {renamefile: stat failing on source} {notRoot} { catch {file delete -force -- tfa1 tfa2} set r1 [catch {file rename tfa1 tfa2}] expr {$r1 && ![file exists tfa1] && ![file exists tfa2]} } {1} test fCmd-12.4 {renamefile: error renaming file to directory} {notRoot} { catch {file delete -force -- tfa tfad} set s1 [createfile tfa ] file mkdir tfad file mkdir tfad/tfa set r1 [catch {file rename tfa tfad}] set r2 [checkcontent tfa $s1] set r3 [file isdir tfad/tfa] set result [expr $r1 && $r2 && $r3] file delete -force tfa tfad set result } {1} test fCmd-12.5 {renamefile: error renaming directory to file} {notRoot} { catch {file delete -force -- tfa tfad} file mkdir tfa file mkdir tfad set s [createfile tfad/tfa] set r1 [catch {file rename tfa tfad}] set r2 [checkcontent tfad/tfa $s] set r3 [file isdir tfad] set r4 [file isdir tfa] set result [expr $r1 && $r2 && $r3 && $r4 ] file delete -force tfa tfad set result } {1} test fCmd-12.6 {renamefile: TclRenameFile succeeding} {notRoot} { catch {file delete -force -- tfa1 tfa2} set s [createfile tfa1] file rename tfa1 tfa2 set result [expr [checkcontent tfa2 $s] && ![file exists tfa1]] file delete tfa2 set result } {1} test fCmd-12.7 {renamefile: renaming directory into offspring} {notRoot} { catch {file delete -force -- tfad} file mkdir tfad file mkdir tfad/dir set result [catch {file rename tfad tfad/dir}] file delete -force tfad set result } {1} test fCmd-12.8 {renamefile: generic error} {unixOnly notRoot} { catch {file delete -force -- tfa} file mkdir tfa file mkdir tfa/dir exec chmod 555 tfa set result [catch {file rename tfa/dir tfa2}] exec chmod 777 tfa file delete -force tfa set result } {1} test fCmd-12.9 {renamefile: moving a file across volumes} {unixOnly notRoot} { catch {file delete -force -- tfa /tmp/tfa} set s [createfile tfa ] file rename tfa /tmp set result [expr [checkcontent /tmp/tfa $s] && ![file exists tfa]] file delete /tmp/tfa set result } {1} test fCmd-12.10 {renamefile: moving a directory across volumes } \ {unixOnly notRoot} { catch {file delete -force -- tfad /tmp/tfad} file mkdir tfad set s [createfile tfad/a ] file rename tfad /tmp set restul [expr [checkcontent /tmp/tfad/a $s] && ![file exists tfad]] file delete -force /tmp/tfad set result } {1} # # Coverage tests for TclCopyFilesCmd() # test fCmd-13.1 {TclCopyFilesCmd: -force option} {notRoot} { catch {file delete -force -- tfa1} set s [createfile tfa1] file copy -force tfa1 tfa2 set result [expr [checkcontent tfa2 $s] && [checkcontent tfa1 $s]] file delete tfa1 tfa2 set result } {1} test fCmd-13.2 {TclCopyFilesCmd: -- option} {notRoot} { catch {file delete -force -- tfa1} set s [createfile -tfa1] file copy -- -tfa1 tfa2 set result [expr [checkcontent tfa2 $s] && [checkcontent -tfa1 $s]] file delete -- -tfa1 tfa2 set result } {1} test fCmd-13.3 {TclCopyFilesCmd: bad option} {notRoot} { catch {file delete -force -- tfa1} set s [createfile tfa1] set r1 [catch {file copy -x tfa1 tfa2}] set result [expr $r1 && [checkcontent tfa1 $s] && ![file exists tfa2]] file delete tfa1 set result } {1} test fCmd-13.4 {TclCopyFilesCmd: bad \# args} {notRoot} { catch {file copy -- } } {1} test fCmd-13.5 {TclCopyFilesCmd: target filename translation failing} { global env set temp $env(HOME) unset env(HOME) set result [catch {file copy tfa ~/foobar }] set env(HOME) $temp set result } {1} test fCmd-13.6 {TclCopyFilesCmd: > 1 source & target is not a dir} {notRoot} { catch {file delete -force -- tfa1 tfa2 tfa3} createfile tfa1 createfile tfa2 createfile tfa3 set result [catch {file copy tfa1 tfa2 tfa3}] file delete tfa1 tfa2 tfa3 set result } {1} test fCmd-13.7 {TclCopyFilesCmd: single file into directory} {notRoot} { catch {file delete -force -- tfa1 tfad} set s [createfile tfa1] file mkdir tfad file copy tfa1 tfad set result [expr [checkcontent tfad/tfa1 $s] && [checkcontent tfa1 $s]] file delete -force tfad tfa1 set result } {1} test fCmd-13.8 {TclCopyFilesCmd: multiple files into directory} {notRoot} { catch {file delete -force -- tfa1 tfa2 tfad} set s1 [createfile tfa1 ] set s2 [createfile tfa2 ] file mkdir tfad file copy tfa1 tfa2 tfad set r1 [checkcontent tfad/tfa1 $s1] set r2 [checkcontent tfad/tfa2 $s2] set r3 [checkcontent tfa1 $s1] set r4 [checkcontent tfa2 $s2] set result [expr $r1 && $r2 && $r3 && $r4 ] file delete -force tfad tfa1 tfa2 set result } {1} test fCmd-13.9 {TclCopyFilesCmd: error copying file to directory} {notRoot} { catch {file delete -force -- tfa tfad} set s [createfile tfa ] file mkdir tfad file mkdir tfad/tfa set r1 [catch {file copy tfa tfad}] set r2 [expr [checkcontent tfa $s] && [file isdir tfad/tfa]] set r3 [file isdir tfad] set result [expr $r1 && $r2 && $r3 ] file delete -force tfa tfad set result } {1} # # Coverage tests for copyfile() # test fCmd-14.1 {copyfile: source filename translation failing} {notRoot} { global env set temp $env(HOME) unset env(HOME) set result [catch {file copy ~/tfa1 tfa2}] set env(HOME) $temp set result } {1} test fCmd-14.2 {copyfile: dst filename translation failing} {notRoot} { global env set temp $env(HOME) unset env(HOME) set s [createfile tfa1] file mkdir tfad set r1 [catch {file copy tfa1 ~/tfa2 tfad}] set result [expr $r1 && [checkcontent tfad/tfa1 $s]] set env(HOME) $temp file delete -force tfa1 tfad set result } {1} test fCmd-14.3 {copyfile: stat failing on source} {notRoot} { catch {file delete -force -- tfa1 tfa2} set r1 [catch {file copy tfa1 tfa2}] expr $r1 && ![file exists tfa1] && ![file exists tfa2] } {1} test fCmd-14.4 {copyfile: error copying file to directory} {notRoot} { catch {file delete -force -- tfa tfad} set s1 [createfile tfa ] file mkdir tfad file mkdir tfad/tfa set r1 [catch {file copy tfa tfad}] set r2 [checkcontent tfa $s1] set r3 [file isdir tfad] set r4 [file isdir tfad/tfa] set result [expr $r1 && $r2 && $r3 && $r4 ] file delete -force tfa tfad set result } {1} test fCmd-14.5 {copyfile: error copying directory to file} {notRoot} { catch {file delete -force -- tfa tfad} file mkdir tfa file mkdir tfad set s [createfile tfad/tfa] set r1 [catch {file copy tfa tfad}] set r2 [checkcontent tfad/tfa $s] set r3 [file isdir tfad] set r4 [file isdir tfa] set result [expr $r1 && $r2 && $r3 && $r4 ] file delete -force tfa tfad set result } {1} test fCmd-14.6 {copyfile: copy file succeeding} {notRoot} { catch {file delete -force -- tfa tfa2} set s [createfile tfa] file copy tfa tfa2 set result [expr [checkcontent tfa $s] && [checkcontent tfa2 $s]] file delete tfa tfa2 set result } {1} test fCmd-14.7 {copyfile: copy directory succeeding} {notRoot} { catch {file delete -force -- tfa tfa2} file mkdir tfa set s [createfile tfa/file] file copy tfa tfa2 set result [expr [checkcontent tfa/file $s] && [checkcontent tfa2/file $s]] file delete -force tfa tfa2 set result } {1} test fCmd-14.8 {copyfile: copy directory failing} {unixOnly notRoot} { catch {file delete -force -- tfa} file mkdir tfa/dir/a/b/c exec chmod 000 tfa/dir set r1 [catch {file copy tfa tfa2}] exec chmod 777 tfa/dir set result $r1 file delete -force tfa tfa2 set result } {1} # # Coverage tests for TclMkdirCmd() # test fCmd-15.1 {TclMakeDirsCmd: target filename translation failing} {notRoot} { global env set temp $env(HOME) unset env(HOME) set result [catch {file mkdir ~/tfa}] set env(HOME) $temp set result } {1} # # Can Tcl_SplitPath return argc == 0? If so them we need a # test for that code. # test fCmd-15.2 {TclMakeDirsCmd - one directory } {notRoot} { catch {file delete -force -- tfa} file mkdir tfa set result [file isdirectory tfa] file delete tfa set result } {1} test fCmd-15.3 {TclMakeDirsCmd: - two directories} {notRoot} { catch {file delete -force -- tfa1 tfa2} file mkdir tfa1 tfa2 set result [expr [file isdirectory tfa1] && [file isdirectory tfa2]] file delete tfa1 tfa2 set result } {1} test fCmd-15.4 {TclMakeDirsCmd - stat failing} {unixOnly notRoot} { catch {file delete -force -- tfa} file mkdir tfa createfile tfa/file exec chmod 000 tfa set result [catch {file mkdir tfa/file}] exec chmod 777 tfa file delete -force tfa set result } {1} test fCmd-15.5 {TclMakeDirsCmd: - making a directory several levels deep} \ {notRoot} { catch {file delete -force -- tfa} file mkdir tfa/a/b/c set result [file isdir tfa/a/b/c] file delete -force tfa set result } {1} test fCmd-15.6 {TclMakeDirsCmd: - trying to overwrite a file} {notRoot} { catch {file delete -force -- tfa} set s [createfile tfa] set r1 [catch {file mkdir tfa}] set r2 [file isdir tfa] set r3 [file exists tfa] set result [expr $r1 && !$r2 && $r3 && [checkcontent tfa $s]] file delete tfa set result } {1} test fCmd-15.7 {TclMakeDirsCmd - making several directories} {notRoot} { catch {file delete -force -- tfa1 tfa2} file mkdir tfa1 tfa2/a/b/c set result [expr [file isdir tfa1] && [file isdir tfa2/a/b/c]] file delete -force tfa1 tfa2 set result } {1} test fCmd-15.8 {TclFileMakeDirsCmd: trying to create an existing dir} {notRoot} { file mkdir tfa file mkdir tfa set result [file isdir tfa] file delete tfa set result } {1} # Coverage tests for TclDeleteFilesCommand() test fCmd-16.1 { test the -- argument } {notRoot} { catch {file delete -force -- tfa} createfile tfa file delete -- tfa file exists tfa } {0} test fCmd-16.2 { test the -force and -- arguments } {notRoot} { catch {file delete -force -- tfa} createfile tfa file delete -force -- tfa file exists tfa } {0} test fCmd-16.3 { test bad option } {notRoot} { catch {file delete -force -- tfa} createfile tfa set result [catch {file delete -dog tfa}] file delete tfa set result } {1} test fCmd-16.4 { test not enough args } {notRoot} { catch {file delete} } {1} test fCmd-16.5 { test not enough args with options } {notRoot} { catch {file delete --} } {1} test fCmd-16.6 {delete: source filename translation failing} {notRoot} { global env set temp $env(HOME) unset env(HOME) set result [catch {file delete ~/tfa}] set env(HOME) $temp set result } {1} test fCmd-16.7 {remove a non-empty directory without -force } {notRoot} { catch {file delete -force -- tfa} file mkdir tfa createfile tfa/a set result [catch {file delete tfa }] file delete -force tfa set result } {1} test fCmd-16.8 {remove a normal file } {notRoot} { catch {file delete -force -- tfa} file mkdir tfa createfile tfa/a set result [catch {file delete tfa }] file delete -force tfa set result } {1} test fCmd-16.9 {error while deleting file } {unixOnly notRoot} { catch {file delete -force -- tfa} file mkdir tfa createfile tfa/a exec chmod 555 tfa set result [catch {file delete tfa/a }] ####### ####### If any directory in a tree that is being removed does not ####### have write permission, the process will fail! ####### This is also the case with "rm -rf" ####### exec chmod 777 tfa file delete -force tfa set result } {1} test fCmd-16.10 {deleting multiple files} {notRoot} { catch {file delete -force -- tfa1 tfa2} createfile tfa1 createfile tfa2 file delete tfa1 tfa2 expr ![file exists tfa1] && ![file exists tfa2] } {1} test fCmd-16.11 { TclFileDeleteCmd: removing a nonexistant file} {notRoot} { catch {file delete -force -- tfa} file delete tfa set result 1 } {1} # More coverage tests for mkpath() test fCmd-17.1 {mkdir stat failing on target but not ENOENT} {unixOnly notRoot} { catch {file delete -force -- tfa1} file mkdir tfa1 exec chmod 555 tfa1 set result [catch {file mkdir tfa1/tfa2}] exec chmod 777 tfa1 file delete -force tfa1 set result } {1} test fCmd-17.2 {mkdir several levels deep - relative } {notRoot} { catch {file delete -force -- tfa} file mkdir tfa/a/b set result [file isdir tfa/a/b ] file delete tfa/a/b tfa/a tfa set result } {1} test fCmd-17.3 {mkdir several levels deep - absolute } {notRoot} { catch {file delete -force -- tfa} set f [file join [pwd] tfa a ] file mkdir $f set result [file isdir $f ] file delete $f [file join [pwd] tfa] set result } {1} # # Functionality tests for TclFileRenameCmd() # test fCmd-18.1 {TclFileRenameCmd: rename (first form) in the same directory} \ {notRoot} { catch {file delete -force -- tfad} file mkdir tfad/dir cd tfad/dir set s [createfile foo ] file rename foo bar file rename bar ./foo file rename ./foo bar file rename ./bar ./foo file rename foo ../dir/bar file rename ../dir/bar ./foo file rename ../../tfad/dir/foo ../../tfad/dir/bar file rename [file join [pwd] bar] foo file rename foo [file join [pwd] bar] set result [expr [checkcontent bar $s] && ![file exists foo]] cd ../.. file delete -force tfad set result } {1} test fCmd-18.2 {TclFileRenameCmd: single dir to nonexistant} {notRoot} { catch {file delete -force -- tfa1 tfa2} file mkdir tfa1 file rename tfa1 tfa2 set result [expr [file exists tfa2] && ![file exists tfa1]] file delete tfa2 set result } {1} test fCmd-18.3 {TclFileRenameCmd: mixed dirs and files into directory} {notRoot} { catch {file delete -force -- tfa1 tfad1 tfad2} set s [createfile tfa1 ] file mkdir tfad1 tfad2 file rename tfa1 tfad1 tfad2 set r1 [checkcontent tfad2/tfa1 $s] set r2 [file isdir tfad2/tfad1] set result [expr $r1 && $r2 && ![file exists tfa1] && ![file exists tfad1]] file delete tfad2/tfa1 file delete -force tfad2 set result } {1} test fCmd-18.4 {TclFileRenameCmd: attempt to replace non-dir with dir} {notRoot} { catch {file delete -force -- tfa tfad} set s [createfile tfa ] file mkdir tfad set r1 [catch {file rename tfad tfa}] set r2 [checkcontent tfa $s] set r3 [file isdir tfad] set result [expr $r1 && $r2 && $r3 ] file delete tfa tfad set result } {1} test fCmd-18.5 {TclFileRenameCmd: attempt to replace dir with non-dir} {notRoot} { catch {file delete -force -- tfa tfad} set s [createfile tfa ] file mkdir tfad/tfa set r1 [catch {file rename tfa tfad}] set r2 [checkcontent tfa $s] set r3 [file isdir tfad/tfa] set result [expr $r1 && $r2 && $r3 ] file delete -force tfa tfad set result } {1} # # On Windows there is no easy way to determine if two files are the same # test fCmd-18.6 {TclFileRenameCmd: rename a file to itself} {macOrUnix notRoot} { catch {file delete -force -- tfa} set s [createfile tfa] set r1 [catch {file rename tfa tfa}] set result [expr $r1 && [checkcontent tfa $s]] file delete tfa set result } {1} test fCmd-18.7 {TclFileRenameCmd: rename dir on top of another empty dir w/o -force} \ {notRoot} { catch {file delete -force -- tfa tfad} file mkdir tfa tfad/tfa set r1 [catch {file rename tfa tfad}] set result [expr $r1 && [file isdir tfa]] file delete -force tfa tfad set result } {1} test fCmd-18.8 {TclFileRenameCmd: rename dir on top of another empty dir w/ -force} \ {notRoot} { catch {file delete -force -- tfa tfad} file mkdir tfa tfad/tfa file rename -force tfa tfad set result [expr ![file isdir tfa]] file delete -force tfad set result } {1} test fCmd-18.9 {TclFileRenameCmd: rename dir on top of a non-empty dir w/o -force} \ {notRoot} { catch {file delete -force -- tfa tfad} file mkdir tfa tfad/tfa/file set r1 [catch {file rename tfa tfad}] set result [expr $r1 && [file isdir tfa] && [file isdir tfad/tfa/file]] file delete -force tfa tfad set result } {1} test fCmd-18.10 {TclFileRenameCmd: rename dir on top of a non-empty dir w/ -force} \ {notRoot} { catch {file delete -force -- tfa tfad} file mkdir tfa tfad/tfa/file set r1 [catch {file rename -force tfa tfad}] set result [expr $r1 && [file isdir tfa] && [file isdir tfad/tfa/file]] file delete -force tfa tfad set result } {1} test fCmd-18.11 {TclFileRenameCmd: rename a non-existant file} {notRoot} { catch {file delete -force -- tfa1} set r1 [catch {file rename tfa1 tfa2}] set result [expr $r1 && ![file exists tfa1] && ![file exists tfa2]] } {1} test fCmd-18.12 {TclFileRenameCmd : rename a symbolic link to file} \ {unixOnly notRoot} { catch {file delete -force -- tfa1 tfa2 tfa3} set s [createfile tfa1] exec ln -s tfa1 tfa2 file rename tfa2 tfa3 set t [file type tfa3] set result [expr { $t == "link" }] file delete tfa1 tfa3 set result } {1} test fCmd-18.13 {TclFileRenameCmd : rename a symbolic link to dir} \ {unixOnly notRoot} { catch {file delete -force -- tfa1 tfa2 tfa3} file mkdir tfa1 exec ln -s tfa1 tfa2 file rename tfa2 tfa3 set t [file type tfa3] set result [expr { $t == "link" }] file delete tfa1 tfa3 set result } {1} test fCmd-18.14 {TclFileRenameCmd : rename a path with sym link} \ {unixOnly notRoot} { catch {file delete -force -- tfa1 tfa2 tfa3} file mkdir tfa1/a/b/c/d file mkdir tfa2 set f [file join [pwd] tfa1/a/b] set f2 [file join [pwd] {tfa2/b alias}] exec ln -s $f $f2 file rename {tfa2/b alias/c} tfa3 set r1 [file isdir tfa3] set r2 [file exists tfa1/a/b/c] set result [expr $r1 && !$r2] file delete -force tfa1 tfa2 tfa3 set result } {1} test fCmd-18.15 {TclFileRenameCmd : rename a file to a symlink dir} \ {unixOnly notRoot} { catch {file delete -force -- tfa1 tfa2 tfalink} file mkdir tfa1 set s [createfile tfa2] exec ln -s tfa1 tfalink file rename tfa2 tfalink set result [checkcontent tfa1/tfa2 $s ] file delete -force tfa1 tfalink set result } {1} test fCmd-18.16 {TclFileRenameCmd: rename a dangling symlink} {unixOnly notRoot} { catch {file delete -force -- tfa1 tfalink} file mkdir tfa1 exec ln -s tfa1 tfalink file delete tfa1 file rename tfalink tfa2 set result [expr [string compare [file type tfa2] "link"] == 0] file delete tfa2 set result } {1} # # Coverage tests for TclUnixRmdir # test fCmd-19.1 { remove empty directory } {notRoot} { catch {file delete -force -- tfa} file mkdir tfa file delete tfa file exists tfa } {0} test fCmd-19.2 { rmdir error besides EEXIST} {unixOnly notRoot} { catch {file delete -force -- tfa} file mkdir tfa file mkdir tfa/a exec chmod 555 tfa set result [catch {file delete tfa/a}] exec chmod 777 tfa file delete -force tfa set result } {1} test fCmd-19.3 { recursive remove } {notRoot} { catch {file delete -force -- tfa} file mkdir tfa file mkdir tfa/a file delete -force tfa file exists tfa } {0} # # TclUnixDeleteFile and TraversalDelete are covered by tests from the # TclDeleteFilesCmd suite # # # # Coverage tests for TraverseUnixTree(), called from TclDeleteFilesCmd # test fCmd-20.1 {TraverseUnixTree : failure opening a subdirectory directory } \ {unixOnly notRoot} { catch {file delete -force -- tfa} file mkdir tfa file mkdir tfa/a exec chmod 000 tfa/a set result [catch {file delete -force tfa}] exec chmod 777 tfa/a file delete -force tfa set result } {1} # # Feature testing for TclCopyFilesCmd # test fCmd-21.1 {copy : single file to nonexistant } {notRoot} { catch {file delete -force -- tfa1 tfa2} set s [createfile tfa1] file copy tfa1 tfa2 set result [expr [checkcontent tfa2 $s] && [checkcontent tfa1 $s]] file delete tfa1 tfa2 set result } {1} test fCmd-21.2 {copy : single dir to nonexistant } {notRoot} { catch {file delete -force -- tfa1 tfa2} file mkdir tfa1 file copy tfa1 tfa2 set result [expr [file isdir tfa2] && [file isdir tfa1]] file delete tfa1 tfa2 set result } {1} test fCmd-21.3 {copy : single file into directory } {notRoot} { catch {file delete -force -- tfa1 tfad} set s [createfile tfa1] file mkdir tfad file copy tfa1 tfad set result [expr [checkcontent tfad/tfa1 $s] && [checkcontent tfa1 $s]] file delete -force tfa1 tfad set result } {1} test fCmd-21.4 {copy : more than one source and target is not a directory} \ {notRoot} { catch {file delete -force -- tfa1 tfa2 tfa3} createfile tfa1 createfile tfa2 createfile tfa3 set result [catch {file copy tfa1 tfa2 tfa3}] file delete tfa1 tfa2 tfa3 set result } {1} test fCmd-21.5 {copy : multiple files into directory } {notRoot} { catch {file delete -force -- tfa1 tfa2 tfad} set s1 [createfile tfa1 ] set s2 [createfile tfa2 ] file mkdir tfad file copy tfa1 tfa2 tfad set r1 [checkcontent tfad/tfa1 $s1] set r2 [checkcontent tfad/tfa2 $s2] set r3 [checkcontent tfa1 $s1] set r4 [checkcontent tfa2 $s2] set result [expr $r1 && $r2 && $r3 && $r4] file delete -force tfa1 tfa2 tfad set result } {1} test fCmd-21.6 {copy: mixed dirs and files into directory} \ {notRoot notFileSharing} { catch {file delete -force -- tfa1 tfad1 tfad2} set s [createfile tfa1 ] file mkdir tfad1 tfad2 file copy tfa1 tfad1 tfad2 set r1 [checkcontent [file join tfad2 tfa1] $s] set r2 [file isdir [file join tfad2 tfad1]] set r3 [checkcontent tfa1 $s] set result [expr $r1 && $r2 && $r3 && [file isdir tfad1]] file delete -force tfa1 tfad1 tfad2 set result } {1} test fCmd-21.7 {TclCopyFilesCmd: copy a dangling link} {unixOnly notRoot} { file mkdir tfad1 exec ln -s tfad1 tfalink file delete tfad1 file copy tfalink tfalink2 set result [string match [file type tfalink2] link] file delete tfalink tfalink2 set result } {1} test fCmd-21.8 {TclCopyFilesCmd : copy a link } {unixOnly notRoot} { file mkdir tfad1 exec ln -s tfad1 tfalink file copy tfalink tfalink2 set r1 [file type tfalink] set r2 [file type tfalink2] set r3 [file isdir tfad1] set result [expr {("$r1" == "link" ) && ("$r2" == "link" ) && $r3}] file delete tfad1 tfalink tfalink2 set result } {1} test fCmd-21.9 {TclCopyFilesCmd: copy dir with a link in it} {unixOnly notRoot} { file mkdir tfad1 exec ln -s "[pwd]/tfad1" tfad1/tfalink file copy tfad1 tfad2 set result [string match [file type tfad2/tfalink] link] file delete -force tfad1 tfad2 set result } {1} test fCmd-21.10 {TclFileCopyCmd: copy dir on top of another empty dir w/o -force} \ {notRoot} { catch {file delete -force -- tfa tfad} file mkdir tfa [file join tfad tfa] set r1 [catch {file copy tfa tfad}] set result [expr $r1 && [file isdir tfa]] file delete -force tfa tfad set result } {1} test fCmd-21.11 {TclFileCopyCmd: copy dir on top of a dir w/o -force} {notRoot} { catch {file delete -force -- tfa tfad} file mkdir tfa [file join tfad tfa file] set r1 [catch {file copy tfa tfad}] set result [expr $r1 && [file isdir tfa] && [file isdir [file join tfad tfa file]]] file delete -force tfa tfad set result } {1} test fCmd-21.12 {TclFileCopyCmd: copy dir on top of a non-empty dir w/ -force} \ {notRoot} { catch {file delete -force -- tfa tfad} file mkdir tfa [file join tfad tfa file] set r1 [catch {file copy -force tfa tfad}] set result [expr $r1 && [file isdir tfa] && [file isdir [file join tfad tfa file]]] file delete -force tfa tfad set result } {1} # # Coverage testing for TclpRenameFile # test fCmd-22.1 {TclpRenameFile: rename and overwrite in a single dir} {notRoot} { catch {file delete -force -- tfa1 tfa2} set s [createfile tfa1] set s2 [createfile tfa2 q] set r1 [catch {rename tfa1 tfa2}] file rename -force tfa1 tfa2 set result [expr $r1 && [checkcontent tfa2 $s]] file delete [glob tfa1 tfa2] set result } {1} test fCmd-22.2 {TclpRenameFile: attempt to overwrite itself} {macOrUnix notRoot} { catch {file delete -force -- tfa1} set s [createfile tfa1] file rename -force tfa1 tfa1 set result [checkcontent tfa1 $s] file delete tfa1 set result } {1} test fCmd-22.3 { TclpRenameFile : rename dir to existing dir } {notRoot} { catch {file delete -force -- d1 tfad} file mkdir d1 [file join tfad d1] set r1 [catch {file rename d1 tfad}] set result [expr $r1 && [file isdir d1] && [file isdir [file join tfad d1]]] file delete -force d1 tfad set result } {1} test fCmd-22.4 {TclpRenameFile: rename dir to dir several levels deep} {notRoot} { catch {file delete -force -- d1 tfad} file mkdir d1 [file join tfad a b c] file rename d1 [file join tfad a b c d1] set result [expr ![file isdir d1] && [file isdir [file join tfad a b c d1]]] file delete -force [glob d1 tfad] set result } {1} # # TclMacCopyFile needs to be redone. # test fCmd-22.5 {TclMacCopyFile: copy and overwrite in a single dir} {notRoot} { catch {file delete -force -- tfa1 tfa2} set s [createfile tfa1] set s2 [createfile tfa2 q] set r1 [catch {file copy tfa1 tfa2}] file copy -force tfa1 tfa2 set result [expr $r1 && [checkcontent tfa2 $s] && [checkcontent tfa1 $s]] file delete tfa1 tfa2 set result } {1} # # TclMacMkdir - basic cases are covered elsewhere. # Error cases are not covered. # # # TclMacRmdir # Error cases are not covered. # test fCmd-23.1 {TclMacRmdir: trying to remove a nonempty directory} {notRoot} { catch {file delete -force -- tfad} file mkdir [file join tfad dir] set result [catch {file delete tfad}] file delete -force tfad set result } {1} # # TclMacDeleteFile # Error cases are not covered. # test fCmd-24.1 {TclMacDeleteFile: deleting a normal file} {notRoot} { catch {file delete -force -- tfa1} createfile tfa1 file delete tfa1 file exists tfa1 } {0} # # TclMacCopyDirectory # Error cases are not covered. # test fCmd-25.1 { TclMacCopyDirectory : copying a normal directory} \ {notRoot notFileSharing} { catch {file delete -force -- tfad1 tfad2} file mkdir [file join tfad1 a b c] file copy tfad1 tfad2 set result [expr [file isdir [file join tfad1 a b c]] && [file isdir [file join tfad2 a b c]]] file delete -force tfad1 tfad2 set result } {1} test fCmd-25.2 { TclMacCopyDirectory : copying a short path normal directory} \ {notRoot notFileSharing} { catch {file delete -force -- tfad1 tfad2} file mkdir tfad1 file copy tfad1 tfad2 set result [expr [file isdir tfad1] && [file isdir tfad2]] file delete tfad1 tfad2 set result } {1} test fCmd-25.3 { TclMacCopyDirectory : copying dirs between different dirs} \ {notRoot notFileSharing} { catch {file delete -force -- tfad1 tfad2} file mkdir [file join tfad1 x y z] file mkdir [file join tfad2 dir] file copy tfad1 [file join tfad2 dir] set result [expr [file isdir [file join tfad1 x y z]] && [file isdir [file join tfad2 dir tfad1 x y z]]] file delete -force tfad1 tfad2 set result } {1} # # Functionality tests for TclDeleteFilesCmd # test fCmd-26.1 { TclDeleteFilesCmd : delete symlink} {unixOnly notRoot} { catch {file delete -force -- tfad1 tfad2} file mkdir tfad1 exec ln -s tfad1 tfalink file delete tfalink set r1 [file isdir tfad1] set r2 [file exists tfalink] set result [expr $r1 && !$r2] file delete tfad1 set result } {1} test fCmd-26.2 { TclDeleteFilesCmd : delete dir with symlink} {unixOnly notRoot} { catch {file delete -force -- tfad1 tfad2} file mkdir tfad1 file mkdir tfad2 exec ln -s tfad1 [file join tfad2 link] file delete -force tfad2 set r1 [file isdir tfad1] set r2 [file exists tfad2] set result [expr $r1 && !$r2] file delete tfad1 set result } {1} test fCmd-26.3 { TclDeleteFilesCmd : delete dangling symlink} {unixOnly notRoot} { catch {file delete -force -- tfad1 tfad2} file mkdir tfad1 exec ln -s tfad1 tfad2 file delete tfad1 file delete tfad2 set r1 [file exists tfad1] set r2 [file exists tfad2] set result [expr !$r1 && !$r2] set result } {1} test fCmd-27.2 {TclFileAttrsCmd - Tcl_TranslateFileName fails} {testsetplatform} { set platform [testgetplatform] testsetplatform unix list [catch {file attributes ~_totally_bogus_user} msg] $msg [testsetplatform $platform] } {1 {user "_totally_bogus_user" doesn't exist} {}} test fCmd-27.3 {TclFileAttrsCmd - all attributes} { catch {file delete -force -- foo.tmp} createfile foo.tmp list [catch {file attributes foo.tmp} msg] [expr {[llength $msg] > 0}] [file delete -force -- foo.tmp] } {0 1 {}} test fCmd-27.4 {TclFileAttrsCmd - getting one option} { catch {file delete -force -- foo.tmp} createfile foo.tmp set attrs [file attributes foo.tmp] list [catch {eval file attributes foo.tmp [lindex $attrs 0]}] [file delete -force -- foo.tmp] } {0 {}} # Find a group that exists on this Unix system, or else skip tests that # require Unix groups. if {$tcl_platform(platform) == "unix"} { set ::tcltest::testConstraints(foundGroup) 0 catch { set groupList [exec groups] set group [lindex $groupList 0] set ::tcltest::testConstraints(foundGroup) 1 } } else { set ::tcltest::testConstraints(foundGroup) 1 } test fCmd-27.5 {TclFileAttrsCmd - setting one option} {foundGroup} { catch {file delete -force -- foo.tmp} createfile foo.tmp set attrs [file attributes foo.tmp] list [catch {eval file attributes foo.tmp [lrange $attrs 0 1]} msg] $msg [file delete -force -- foo.tmp] } {0 {} {}} test fCmd-27.6 {TclFileAttrsCmd - setting more than one option} {foundGroup} { catch {file delete -force -- foo.tmp} createfile foo.tmp set attrs [file attributes foo.tmp] list [catch {eval file attributes foo.tmp [lrange $attrs 0 3]} msg] $msg [file delete -force -- foo.tmp] } {0 {} {}} # cleanup cleanup ::tcltest::cleanupTests return \ No newline at end of file diff --git a/tests/fileName.test b/tests/fileName.test new file mode 100644 index 0000000..500c633 --- /dev/null +++ b/tests/fileName.test @@ -0,0 +1,1596 @@ +# This file tests the filename manipulation routines. +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1995-1996 Sun Microsystems, Inc. +# Copyright (c) 1999 by Scriptics Corporation. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id$ + +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 diff --git a/tests/macFCmd.test b/tests/macFCmd.test new file mode 100644 index 0000000..c35da90 --- /dev/null +++ b/tests/macFCmd.test @@ -0,0 +1,209 @@ +# This file tests the tclfCmd.c file. +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1997 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id$ +# + +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 + + + + + + + + + + + + diff --git a/tests/unixFCmd.test b/tests/unixFCmd.test new file mode 100644 index 0000000..aae1027 --- /dev/null +++ b/tests/unixFCmd.test @@ -0,0 +1,328 @@ +# This file tests the tclUnixFCmd.c file. +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id$ + +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 + + + + + + + + + + + + diff --git a/tests/unixFile.test b/tests/unixFile.test new file mode 100644 index 0000000..697be69 --- /dev/null +++ b/tests/unixFile.test @@ -0,0 +1,78 @@ +# This file contains tests for the routines in the file tclUnixFile.c +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1998-1999 by Scriptics Corporation. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id$ + +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 + + + + + + + + + + + + diff --git a/tests/vfs.test b/tests/vfs.test new file mode 100644 index 0000000..959194a --- /dev/null +++ b/tests/vfs.test @@ -0,0 +1,31 @@ +# Commands covered: vfs::filesystem +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 2001 by Vince Darley. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# + +if {[lsearch [namespace children] ::tcltest] == -1} { + package require tcltest + namespace import ::tcltest::* +} + +package require vfs + +test vfs-1.1 {mount unmount} { + vfs::filesystem mount foo bar + set res [list [catch {vfs::filesystem unmount foo bar} err]] + lappend res $err + vfs::filesystem unmount foo + unset err + set res +} {1 {wrong # args: should be "vfs::filesystem unmount path"}} + +# cleanup +::tcltest::cleanupTests +return diff --git a/tests/winFCmd.test b/tests/winFCmd.test new file mode 100644 index 0000000..a8a1869 --- /dev/null +++ b/tests/winFCmd.test @@ -0,0 +1,981 @@ +# This file tests the tclWinFCmd.c file. +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1996-1997 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id$ +# + +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 + + + + + + + + + + + + diff --git a/tests/winFile.test b/tests/winFile.test new file mode 100644 index 0000000..b507f7a --- /dev/null +++ b/tests/winFile.test @@ -0,0 +1 @@ +# This file tests the tclWinFile.c file. # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id$ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } test winFile-1.1 {TclpGetUserHome} {pcOnly} { list [catch {glob ~nosuchuser} msg] $msg } {1 {user "nosuchuser" doesn't exist}} test winFile-1.2 {TclpGetUserHome} {nt nonPortable} { # The administrator account should always exist. catch {glob ~administrator} } {0} test winFile-1.2 {TclpGetUserHome} {95} { # Find some user in system.ini and then see if they have a home. set f [open $::env(windir)/system.ini] set x 0 while {![eof $f]} { set line [gets $f] if {$line == "\[Password Lists]"} { gets $f set name [lindex [split [gets $f] =] 0] if {$name != ""} { set x [catch {glob ~$name}] break } } } close $f set x } {0} test winFile-1.3 {TclpGetUserHome} {nt nonPortable} { catch {glob ~stanton@workgroup} } {0} test winFile-2.1 {TclpMatchFiles: case sensitivity} {pcOnly fsIsWritable} { makeFile {} GlobCapS set result [list [glob -nocomplain GlobC*] [glob -nocomplain globc*]] removeFile GlobCapS set result } {GlobCapS GlobCapS} test winFile-2.2 {TclpMatchFiles: case sensitivity} {pcOnly fsIsWritable} { makeFile {} globlower set result [list [glob -nocomplain globl*] [glob -nocomplain gLOBl*]] removeFile globlower set result } {globlower globlower} # cleanup ::tcltest::cleanupTests return \ No newline at end of file diff --git a/win/makefile.vc b/win/makefile.vc new file mode 100644 index 0000000..be5d797 --- /dev/null +++ b/win/makefile.vc @@ -0,0 +1,143 @@ +# Makefile.vc +# +# This makefile is suitable for use with # Microsoft Visual C++ 2.x and 4.0. +# +# This makefile was hacked from Sun's 'example.zip' +# Copyright (c) 1996 Sun Microsystems, Inc. +# Copyright 1997 Tom Poindexter. +# Copyright 2001 Vince Darley. +# +MACHINE = IX86 + +VFS_VERSION = 1.0 +DLL_VERSION = 10 + +PROJECT = vfs$(DLL_VERSION) + +# +# Project directories -- these may need to be customized for your site +# +# ROOT -- location of the example files. +# TOOLS32 -- location of VC++ compiler installation. +# TCL -- location where Tcl is installed. +# TCLLIB -- define the Tcl lib (with correct version) + +# note that the tcl vclibs should have been unpacked in $(TCL)\lib !! + +ROOT = .. +WINDIR = $(ROOT)\win +GENERICDIR = $(ROOT)\generic +TOOLS32 = C:\Progra~1\devstudio\vc +TOOLS32_rc = C:\Progra~1\devstudio\sharedide + +cc32 = "$(TOOLS32)\bin\cl.exe" +link32 = "$(TOOLS32)\bin\link.exe" +libpath32 = /LIBPATH:"$(TOOLS32)\lib" +lib32 = "$(TOOLS32)\bin\lib.exe" + +rc32 = "$(TOOLS32_rc)\bin\rc.exe" +include32 = -I"$(TOOLS32)\include" + +# point TCL and TCLLIB to your tcl distribution + +TCL = c:\progra~1\tcl +TCLLIB = $(TCL)\lib\tclstub84.lib + +# comment the following line to compile with symbols +NODEBUG=1 + +###################################################################### +# Link flags +###################################################################### + +!IF "$(NODEBUG)" == "1" +ldebug = /RELEASE +!ELSE +ldebug = -debug:full -debugtype:cv +!ENDIF + +# declarations common to all linker options +lflags = /NODEFAULTLIB /NOLOGO /MACHINE:$(MACHINE) $(libpath32) + +# declarations for use on Intel i386, i486, and Pentium systems +!IF "$(MACHINE)" == "IX86" +DLLENTRY = @12 +dlllflags = $(lflags) -entry:_DllMainCRTStartup$(DLLENTRY) -dll +!ELSE IF "$(MACHINE)" == "IA64" +DLLENTRY = @12 +dlllflags = $(lflags) -dll +!ELSE +dlllflags = $(lflags) -entry:_DllMainCRTStartup$(DLLENTRY) -dll +!ENDIF + +conlflags = $(lflags) -subsystem:console -entry:mainCRTStartup +guilflags = $(lflags) -subsystem:windows -entry:WinMainCRTStartup + +!IF "$(MACHINE)" == "PPC" +libc = libc$(DBGX).lib +libcdll = crtdll$(DBGX).lib +!ELSE +libc = libc$(DBGX).lib oldnames.lib +libcdll = msvcrt$(DBGX).lib oldnames.lib +!ENDIF + +baselibs = kernel32.lib $(optlibs) advapi32.lib user32.lib +winlibs = $(baselibs) gdi32.lib comdlg32.lib winspool.lib + +guilibs = $(libc) $(winlibs) +conlibs = $(libc) $(baselibs) +guilibsdll = $(libcdll) $(winlibs) +conlibsdll = $(libcdll) $(baselibs) + +VFSOBJS = \ + $(WINDIR)\vfs.obj + +# +# Visual C++ tools +# + +PATH=$(COMMON32)/bin;$(TOOLS32)\bin;$(PATH) + +cc32 = $(TOOLS32)\bin\cl -I$(TOOLS32)\include +CP = copy +RM = del + +INCLUDES = \ + -I../../tcl8.4/generic \ + -I../../tcl8.4/windows \ + -I$(TOOLS32)/include \ + -I../generic + +DEFINES = -nologo $(DEBUGDEFINES) -DUSE_TCL_STUBS -DVERSION=\"1.0\" + +# +# Global makefile settings +# + +DLLOBJS = \ + $(WINDIR)\vfs.obj + +# Targets + +all: $(PROJECT).dll + + +$(PROJECT).dll: $(DLLOBJS) + $(link32) $(ldebug) $(dlllflags) $(TCLLIB) \ + $(guilibsdll) -out:$(PROJECT).dll $(DLLOBJS) + +# Implicit Targets + +#.c.obj: +# $(cc32) $(cdebug) $(cflags) $(cvarsdll) $(INCLUDES) \ +# $(DEFINES) -Fo$(WINDIR)\ $< + +$(WINDIR)\vfs.obj: $(GENERICDIR)\vfs.c + $(cc32) $(cdebug) $(cflags) $(cvarsdll) $(INCLUDES) \ + $(DEFINES) -Fo$(WINDIR)\ $? + +clean: + -$(RM) $(WINDIR)\*.obj + -$(RM) $(PROJECT).dll + -$(RM) $(PROJECT).lib + -$(RM) $(PROJECT).exp diff --git a/win/vfs.exp b/win/vfs.exp new file mode 100644 index 0000000..3247651 Binary files /dev/null and b/win/vfs.exp differ diff --git a/win/vfs.lib b/win/vfs.lib new file mode 100644 index 0000000..c640c63 Binary files /dev/null and b/win/vfs.lib differ diff --git a/win/vfs10.exp b/win/vfs10.exp new file mode 100644 index 0000000..40ba216 Binary files /dev/null and b/win/vfs10.exp differ diff --git a/win/vfs10.lib b/win/vfs10.lib new file mode 100644 index 0000000..80d9961 Binary files /dev/null and b/win/vfs10.lib differ