diff --git a/Makefile b/Makefile
index e454d66..124f8bb 100644
--- a/Makefile
+++ b/Makefile
@@ -183,6 +183,16 @@ ZIPOBJS = zipfile.o \
#--------------------------build
all : build
+ifdef USE_SYSTEM_LIBS
+build : dirs \
+ tktable tkcon xmlrpc blt \
+ tclxml tkimg tkmpeg html \
+ xpa iis checkdns $(SIGNAL) funtools \
+ ast wcssubs \
+ rice hcompress plio \
+ $(OPTDIR) \
+ saotk zip zvfs ds9
+else
build : dirs \
tcl tk \
tktable tkcon xmlrpc blt \
@@ -192,6 +202,7 @@ build : dirs \
rice hcompress plio \
$(OPTDIR) \
saotk zip zvfs ds9
+endif
doc : FORCE
@echo "Making Documentation..."
@@ -206,8 +217,8 @@ language: FORCE
grep 'msgcat::mc' src/*.tcl | tclsh8.5 util/mergedict.tcl fr iso8859-1
grep 'msgcat::mc' src/*.tcl | tclsh8.5 util/mergedict.tcl pt iso8859-1
grep 'msgcat::mc' src/*.tcl | tclsh8.5 util/mergedict.tcl cs iso8859-2
- grep 'msgcat::mc' src/*.tcl | tclsh8.5 util/mergedict.tcl ja euc-jp
- grep 'msgcat::mc' src/*.tcl | tclsh8.5 util/mergedict.tcl zh big5
+ grep 'msgcat::mc' src/*.tcl | tclsh8.5 util/mergedict.tcl ja utf-8
+ grep 'msgcat::mc' src/*.tcl | tclsh8.5 util/mergedict.tcl zh utf-8
#--------------------------items
@@ -257,18 +268,22 @@ dirs : FORCE
tcl : FORCE
@echo "Installing Tcl..."
cd $(TCLDIRDIR); CC='$(CC)' CFLAGS='$(OPTS)' LDFLAGS='$(LIBS)' ./configure --prefix $(root) $(TCLFLAGS) --disable-shared --cache-file=$(CACHE)
- cd $(TCLDIRDIR); $(MAKE) -j $(JOBS); $(MAKE) install
+ $(MAKE) -C $(TCLDIRDIR)
+ $(MAKE) -C $(TCLDIRDIR) install
tk : FORCE
@echo "Installing Tk..."
cd $(TKDIRDIR); CC='$(CC)' CFLAGS='$(OPTS)' LDFLAGS='$(LIBS)' ./configure --prefix $(root) $(TCLFLAGS) --disable-shared --cache-file=$(CACHE)
- cd $(TKDIRDIR); $(MAKE) -j $(JOBS); $(MAKE) install
+ $(MAKE) -C $(TKDIRDIR)
+ $(MAKE) -C $(TKDIRDIR) install
$(RM) -r lib/$(TKVER)/demos
tktable : FORCE
@echo "Installing TkTable..."
- cd $(TKTABLEDIR); CC='$(CC)' CFLAGS='$(OPTS)' LDFLAGS='$(LIBS)' ./configure --prefix $(root) $(TKTABLEFLAGS) --disable-shared --cache-file=$(CACHE)
- cd $(TKTABLEDIR); $(MAKE) -j $(JOBS) ; $(MAKE) install
+ cd $(TKTABLEDIR); CC='$(CC)' CFLAGS='$(OPTS)' LDFLAGS='$(LIBS)' ./configure --prefix $(root) $(TCL_CONFIG) $(TK_CONFIG) $(TKTABLEFLAGS) --disable-shared --cache-file=$(CACHE)
+ $(MAKE) -C $(TKTABLEDIR)
+ mkdir -p lib/Tktable2.10
+ cp $(TKTABLEDIR)/*.a lib/Tktable2.10
tkcon : FORCE
@echo "Installing TkCon..."
@@ -284,64 +299,73 @@ xmlrpc : FORCE
blt : FORCE
@echo "Installing BLT..."
- cd $(BLTDIR); CC='$(CC)' CFLAGS='$(OPTS)' LDFLAGS='$(LIBS)' ./configure --prefix $(root) --with-tcl=$(root)/$(TCLDIR) --with-tk=$(root)/$(TKDIR) $(BLTFLAGS) --disable-shared --cache-file=$(CACHE)
- cd $(BLTDIR)/src; $(MAKE) -j $(JOBS) build_static
+ cd $(BLTDIR); CC='$(CC)' CFLAGS='$(OPTS)' LDFLAGS='$(LIBS)' ./configure --prefix $(root) $(TCL_CONFIG) $(TK_CONFIG) $(BLTFLAGS) --disable-shared --cache-file=$(CACHE)
+ $(MAKE) -C $(BLTDIR)/src build_static
cp $(BLTDIR)/src/*.a lib/.
cd $(BLTDIR)/src; cp $(BLTINCL) ../../include/.
zlib : FORCE
@echo "Installing zlib..."
cd $(ZLIBDIR); CC='$(CC)' CFLAGS='$(OPTS)' LDFLAGS='$(LIBS)' ./configure --prefix $(root) --static
- cd $(ZLIBDIR); $(MAKE) -j $(JOBS) install
+ $(MAKE) -C $(ZLIBDIR) install
tclxml : FORCE
@echo "Installing TCLXML..."
cd $(TCLXMLDIR); CC='$(CC)' CFLAGS='$(OPTS)' LDFLAGS='$(LIBS)' ./configure --prefix $(root) --disable-shared --disable-threads --with-xml-static=1 $(TCLXMLFLAGS) --cache-file=$(CACHE)
- cd $(TCLXMLDIR); $(MAKE) -j $(JOBS) ; $(MAKE) install
+ $(MAKE) -C $(TCLXMLDIR)
+ mkdir -p lib/Tclxml3.2
+ cp $(TCLXMLDIR)/*.a lib/Tclxml3.2
tkimg : libtiff
@echo "Installing TKIMG..."
- cd $(TKIMGDIR); CC='$(CC)' CFLAGS='$(OPTS) -DPNG_NO_WRITE_gAMA' LDFLAGS='$(LIBS)' ./configure --prefix $(root) --with-tcl=$(root)/$(TCLDIRDIR) --with-tk=$(root)/$(TKDIRDIR) $(TKIMGFLAGS) --disable-shared --disable-threads --cache-file=$(LOCALCACHE)
- cd $(TKIMGDIR); $(MAKE) -j $(JOBS) all; $(MAKE) install
+ cd $(TKIMGDIR); CC='$(CC)' CFLAGS='$(OPTS) -DPNG_NO_WRITE_gAMA' LDFLAGS='$(LIBS)' ./configure --prefix $(root) $(TCL_CONFIG) $(TK_CONFIG) $(TKIMGFLAGS) --disable-shared --disable-threads --cache-file=$(LOCALCACHE)
+ $(MAKE) -C $(TKIMGDIR) all
+ mkdir -p lib/Img1.4
+ find $(TKIMGDIR) -name "*.a" | xargs -n1 -i cp {} lib/Img1.4
libtiff : FORCE
@echo "Installing LIBTIFF..."
cd $(TKIMGDIR)/compat/libtiff; CC='$(CC)' CFLAGS='$(OPTS)' CXX='$(CC)' CXXFLAGS='$(OPTS)' LDFLAGS='$(LIBS)' ./configure --prefix $(root) --disable-shared --cache-file=$(LOCALCACHE)
- cd $(TKIMGDIR)/compat/libtiff; $(MAKE) -j $(JOBS) ; $(MAKE) install
+ $(MAKE) -C $(TKIMGDIR)/compat/libtiff
+ $(MAKE) -C $(TKIMGDIR)/compat/libtiff install
tkmpeg : FORCE
@echo "Installing TKMPEG..."
- cd $(TKMPEGDIR); $(MAKE) -j $(JOBS)
- cd $(TKMPEGDIR); $(MAKE) install
+ $(MAKE) -C $(TKMPEGDIR)
+ $(MAKE) -C $(TKMPEGDIR) install
+# This needs a special make. Run only with TCL_CONFIG and ignore
+# cache file
html : FORCE
@echo "Installing HTMLWIDGET..."
- cd $(HTMLDIR); CC='$(CC)' CFLAGS='$(OPTS)' LDFLAGS='$(LIBS)' $(PREHTMLFLAGS) $(root)/htmlwidget/configure --prefix $(root) --with-tcl=$(root)/$(TCLDIR) --with-tk=$(root)/$(TKDIR) $(XFLAGS) --enable-shared=no --cache-file=$(CACHE)
- cd $(HTMLDIR); $(MAKE) headers libtkhtml.a
+ rm -f $(HTMLDIR)/config.cache
+ cd $(HTMLDIR); CC='$(CC)' CFLAGS='$(OPTS)' LDFLAGS='$(LIBS)' $(PREHTMLFLAGS) $(root)/htmlwidget/configure --prefix $(root) $(TCL_CONFIG) --enable-shared=no
+ $(MAKE) -C $(HTMLDIR) headers libtkhtml.a
cp $(HTMLDIR)/libtkhtml.a lib/.
xpa : FORCE
@echo "Installing XPA..."
cd $(XPADIR); CC='$(CC)' CFLAGS='$(OPTS)' LDFLAGS='$(LIBS)' ./configure --prefix $(root) --with-tcl=$(root)/$(TCLDIRDIR) $(XPAFLAGS) --disable-shared --cache-file=$(CACHE)
- cd $(XPADIR); $(MAKE) -j $(JOBS); $(MAKE) install
+ $(MAKE) -C $(XPADIR)
+ $(MAKE) -C $(XPADIR) install
cd bin; strip xpa*
iis : FORCE
@echo "Installing IIS..."
- cd $(IISDIR); $(MAKE) -j $(JOBS) install
+ $(MAKE) -C $(IISDIR) install
checkdns: FORCE
@echo "Installing CheckDNS..."
- cd $(CHECKDNSDIR); $(MAKE) -j $(JOBS) install
+ $(MAKE) -C $(CHECKDNSDIR) install
signal: FORCE
@echo "Installing Signal..."
- cd $(SIGNALDIR); $(MAKE) -j $(JOBS) install
+ $(MAKE) -C $(SIGNALDIR) install
funtools: FORCE
@echo "Installing Funtools..."
- cd $(FUNTOOLSDIR); CC='$(CC)' CFLAGS='$(OPTS)' LDFLAGS='$(LIBS)' ./configure --prefix $(root) --with-zlib=../../lib/libz.a --with-wcslib=../lib/libwcs.a --enable-mainlib $(FUNTOOLSFLAGS)
- cd $(FUNTOOLSDIR); $(MAKE) lib
+ cd $(FUNTOOLSDIR); CC='$(CC)' CFLAGS='$(OPTS)' LDFLAGS='$(LIBS)' ./configure --prefix $(root) --with-zlib=$(LIBDIR)/libz.a --with-wcslib=../lib/libwcs.a --enable-mainlib $(FUNTOOLSFLAGS)
+ $(MAKE) -C $(FUNTOOLSDIR) lib
cp $(FUNTOOLSDIR)/libfuntools.a lib/.
ast : FORCE
@@ -351,33 +375,33 @@ ast : FORCE
touch Makefile.in; sleep 1; \
touch configure; \
./configure --enable-shared=no --prefix=$(root) $(ASTFLAGS) CC='$(CC)' CFLAGS='$(OPTS) -I.'; \
- $(MAKE) -j $(JOBS) ast.h install-libLTLIBRARIES install-nodist_includeHEADERS install-includeHEADERS
+ $(MAKE) ast.h install-libLTLIBRARIES install-nodist_includeHEADERS install-includeHEADERS
wcssubs : FORCE
@echo "Installing WCSSUBS..."
- cd $(WCSSUBSDIR); $(MAKE) -j $(JOBS) install
+ $(MAKE) -C $(WCSSUBSDIR) install
rice : FORCE
@echo "Installing RICE..."
- cd $(RICEDIR); $(MAKE) -j $(JOBS) install
+ $(MAKE) -C $(RICEDIR) install
hcompress: FORCE
@echo "Installing HCOMPRESS..."
- cd $(HCOMPRESSDIR); $(MAKE) -j $(JOBS) install
+ $(MAKE) -C $(HCOMPRESSDIR) install
plio: FORCE
@echo "Installing PLIO..."
- cd $(PLIODIR); $(MAKE) -j $(JOBS) install
+ $(MAKE) -C $(PLIODIR) install
ifdef OPTDIR
$(OPTDIR) : FORCE
@echo "Installing $(OPTDIR)..."
- cd $(OPTDIR); $(MAKE) -j $(JOBS) install
+ $(MAKE) -C $(OPTDIR) install
endif
saotk : FORCE
@echo "Installing SAOTK..."
- cd $(SAOTKDIR); $(MAKE) -j $(JOBS) install
+ $(MAKE) -C $(SAOTKDIR) CCOPT='$(TKTCL_INCLUDE)' install
zip : FORCE
@echo "Installing ZIP..."
@@ -389,8 +413,8 @@ zip : FORCE
zvfs : FORCE
@echo "Installing ZVFS..."
- cd $(ZVFSDIR); $(MAKE)
- cd $(ZVFSDIR); $(MAKE) install
+ $(MAKE) -C $(ZVFSDIR) CCOPT='$(TKTCL_INCLUDE)'
+ $(MAKE) -C $(ZVFSDIR) install
#--------------------------clean
diff --git a/ds9/Makefile b/ds9/Makefile
index d21a188..c62dba8 100644
--- a/ds9/Makefile
+++ b/ds9/Makefile
@@ -4,10 +4,15 @@ include ../make.pkgs
#--------------------------defines
ZDIR = zipdir/zvfsmntpt
-FFILES = $(ZDIR)/$(TCLVER) \
- $(ZDIR)/tcl8 \
- $(ZDIR)/$(TKVER) \
- $(ZDIR)/$(BLTVER) \
+ifdef USE_SYSTEM_LIBS
+FFILES =
+else
+FFILES = $(ZDIR)/$(TCLVER) \
+ $(ZDIR)/tcl8 \
+ $(ZDIR)/$(TKVER)
+endif
+
+FFILES += $(ZDIR)/$(BLTVER) \
$(ZDIR)/$(TCLLIBVER) \
$(ZDIR)/$(TKCONVER) \
$(ZDIR)/$(XMLRPCVER) \
@@ -27,6 +32,10 @@ endif
# for unix, macosx
MAINDIR = ../$(TKDIR)/unix
MAIN = tkAppInit
+ifndef USE_SYSTEM_LIBS
+LIBSZ = ../lib/libzip.a ../lib/libz.a
+LIBSTK = ../lib/libtk8.5.a ../lib/libtcl8.5.a
+endif
LIBS = \
../lib/libsaotk.a \
@@ -55,18 +64,14 @@ LIBS = \
../lib/libast_pal.a \
../lib/libsaotk.a \
../lib/libwcs.a \
- ../lib/libzvfs.a \
- ../lib/libzip.a \
- ../lib/libz.a \
+ ../lib/libzvfs.a $(LIBSZ) \
../lib/libxpa.a \
../lib/libiis.a \
../lib/libcheckdns.a \
../lib/libsignal_ext.a \
../lib/libxxlib.a \
../lib/libBLTX30.a \
- ../lib/libBLTCore30.a \
- ../lib/libtk8.5.a \
- ../lib/libtcl8.5.a
+ ../lib/libBLTCore30.a $(LIBSTK)
# if windows, redefine
ifeq ($(OS),windows)
@@ -309,6 +314,9 @@ $(ZDIR)/$(XMLRPCVER) : zipdir ../lib/$(XMLRPCVER)
$(ZDIR)/src : zipdir ../src/*.tcl
$(RM) -r $@
cp -r ../src $(ZDIR)/.
+ifdef USE_SYSTEM_LIBS
+ cp ../src/ds9.syslib.tcl $(ZDIR)/src/ds9.tcl
+endif
$(ZDIR)/msgs : zipdir ../msgs/*
$(RM) -r $@
@@ -354,6 +362,15 @@ endif
#--------------------------linux
ifneq (,$(findstring linux,$(ARCH)))
+ifdef USE_SYSTEM_LIBS
+ds9Base : $(OBJS) $(LIBS)
+ $(RM) $@
+ $(CXX) ${OPTS} -Wl,--export-dynamic \
+ -o $@ $(OBJS) $(LIBS) \
+ -L$(X11LIB) -lX11 -lXext -lXft -lXrender -lXss \
+ -lxml2 -lfontconfig -lfreetype -ljbig -lzip -lz -ltk -ltcl \
+ -ldl -lpthread
+else
ds9Base : $(OBJS) $(LIBS)
$(RM) $@
rm -f libstdc++.a
@@ -367,6 +384,7 @@ ds9Base : $(OBJS) $(LIBS)
-ldl -lpthread
rm -f libstdc++.a
endif
+endif
#--------------------------darwin
--- a/htmlwidget/configure
+++ b/htmlwidget/configure
@@ -1374,7 +1374,7 @@ fi
fi
if test "$ok" = "0"; then
- tkconf=/usr/lib/tclConfig.sh
+ tkconf=$with_tcl/tclConfig.sh
ac_safe=`echo "$tkconf" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for $tkconf""... $ac_c" 1>&6
diff --git a/make.linux b/make.linux
index a5671e3..cbe453a 100644
--- a/make.linux
+++ b/make.linux
@@ -4,7 +4,7 @@ ARCH = linux
X11INCLUDE=/usr/X11R6/include
X11LIB = /usr/X11R6/lib
-XX = -O2
+XX = -g -O2
YY = -gstabs+ -fno-inline
ZZ =
@@ -13,19 +13,34 @@ ZZ =
# AA = -fPIC -DHAVE_SYS_UN_H -DHAVE_SYS_SHM_H
AA = -fPIC -DHAVE_SYS_UN_H -DHAVE_SYS_SHM_H -D_LARGEFILE64_SOURCE -D_FILE_OFFSET_BITS=64
-#OPTS = ${XX} ${ZZ}
-OPTS = ${YY} ${ZZ}
+OPTS = ${XX} ${ZZ}
+#OPTS = ${YY} ${ZZ}
NOPTS = ${YY} ${ZZ}
-#CXX = g++
-CXX = g++44
+CXX = g++
CXXOPT = ${OPTS} ${AA}
CXXNOPT = ${NOPTS} ${AA}
-#CC = gcc
-CC = gcc44
+CC = gcc
CCOPT = ${OPTS} ${AA}
CCNOPT = ${NOPTS} ${AA}
ZCAT = zcat
JOBS = 4
+LIBDIR=/usr/lib
+TCL_CONFIG = --with-tcl=/usr/lib \
+--with-tcllibdir=/usr/lib
+
+TK_CONFIG = --with-tk=/usr/lib \
+--with-tklibdir=/usr/lib
+
+TKTCL_INCLUDE=-I/usr/include/tcl-private/generic \
+-I/usr/include/tcl-private/unix \
+-I/usr/include/tk-private/generic \
+-I/usr/include/tk-private/unix \
+-DHAVE_UNISTD_H
+
+USE_SYSTEM_LIBS=1
+
+
+
diff --git a/make.linux64 b/make.linux64
index c6e80f5..3f486e8 100644
--- a/make.linux64
+++ b/make.linux64
@@ -4,24 +4,39 @@ ARCH = linux64
X11INCLUDE=/usr/include/X11
X11LIB = /usr/lib64
-XX = -O2
+XX = -g -O2
YY = -g -fno-inline
ZZ = -m64 -Wl,--hash-style=both
AA = -fPIC -DHAVE_SYS_UN_H -DHAVE_SYS_SHM_H -D_LARGEFILE64_SOURCE -D_FILE_OFFSET_BITS=64 -D__M64
-#OPTS = ${XX} ${ZZ}
-OPTS = ${YY} ${ZZ}
+OPTS = ${XX} ${ZZ}
+#OPTS = ${YY} ${ZZ}
NOPTS = ${YY} ${ZZ}
CXX = g++
CXXOPT = ${OPTS} ${AA}
CXXNOPT = ${NOPTS} ${AA}
CC = gcc
CCOPT = ${OPTS} ${AA}
CCNOPT = ${NOPTS} ${AA}
ZCAT = zcat
JOBS = 4
+LIBDIR=/usr/lib64
+TCL_CONFIG = --with-tcl=/usr/lib64 \
+--with-tcllibdir=/usr/lib64
+
+TK_CONFIG = --with-tk=/usr/lib64 \
+--with-tklibdir=/usr/lib64
+
+TKTCL_INCLUDE=-I/usr/include/tcl-private/generic \
+-I/usr/include/tcl-private/unix \
+-I/usr/include/tk-private/generic \
+-I/usr/include/tk-private/unix \
+-DHAVE_UNISTD_H
+
+USE_SYSTEM_LIBS=1
+
diff --git a/saotk/Makefile b/saotk/Makefile
index d865d0b..d024931 100644
--- a/saotk/Makefile
+++ b/saotk/Makefile
@@ -59,7 +59,7 @@ fitsy++ : FORCE
cd fitsy++; $(MAKE)
util : FORCE
- cd util; $(MAKE)
+ $(MAKE) -C util
clean : FORCE
cd frame; $(MAKE) clean
diff --git a/saotk/util/Makefile b/saotk/util/Makefile
index 592572c..99eef4b 100644
--- a/saotk/util/Makefile
+++ b/saotk/util/Makefile
@@ -5,7 +5,9 @@ CXXFLAGS = $(CXXOPT) -w \
-I. -I.. -I../widget -I../vector -I../frame -I../fitsy++ -I../list \
-I../../include -I$(X11INCLUDE) \
-I../../$(FUNTOOLSDIR)/util \
- -I../../$(ASTDIR)
+ -I../../$(ASTDIR)
+
+CFLAGS= $(CCOPT) $(CXXFLAGS)
SRC = attribute.C \
grf.C \
@@ -17,12 +19,14 @@ SRC = attribute.C \
ps.C \
smooth.C \
saotk.C \
- util.C
+ util.C \
+ tkCanvPsScaled.c
+
INCLS = smooth.h \
util.h
-OBJS = $(SRC:%.C=%.o)
+OBJS = $(SRC:%.C=%.o) $(SRC:%.c=%.o)
all : $(OBJS) TAGS
diff --git a/zvfs/Makefile b/zvfs/Makefile
index 0637a0c..fb17fe1 100644
--- a/zvfs/Makefile
+++ b/zvfs/Makefile
@@ -1,9 +1,8 @@
include ../make.include
include ../make.pkgs
-CFLAGS = $(CCOPT) -I. -I../include
-
-SRC = zvfs.c zip.c
+CFLAGS = $(CCOPT) -I. -I../include
+SRC = zvfs.c
OBJS = $(SRC:%.c=%.o)
@@ -13,16 +12,10 @@ all : $(LIB)
install : all
cp -f $(LIB) ../lib/.
-$(LIB) : update $(OBJS)
+$(LIB) : $(OBJS)
$(RM) $@
$(AR) -cr $@ $(OBJS)
-update : FORCE
- cp ../$(ZIPDIR)/zip.c .
-
-zip.o : zip.c
- $(CC) $(CFLAGS) -DUSE_ZIPMAIN -I../$(ZIPDIR) -o $@ -c $?
-
clean : FORCE
rm -f core *~ *#
diff --git a/zvfs/zvfs.c b/zvfs/zvfs.c
index 0aec622..81234b1 100644
--- a/zvfs/zvfs.c
+++ b/zvfs/zvfs.c
@@ -1,993 +1,1719 @@
/*
-** Copyright (c) 2000 D. Richard Hipp
+** By the overt act of typing this comment, the author of this code
+** releases it into the public domain. No claim of copyright is made.
+** In place of a legal notice, here is a blessing:
**
-** This program is free software; you can redistribute it and/or
-** modify it under the terms of the GNU General Public
-** License as published by the Free Software Foundation; either
-** version 2 of the License, or (at your option) any later version.
+** May you do good and not evil.
+** May you find forgiveness for yourself and forgive others.
+** May you share freely, never taking more than you give.
**
-** This program is distributed in the hope that it will be useful,
-** but WITHOUT ANY WARRANTY; without even the implied warranty of
-** MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-** General Public License for more details.
-**
-** You should have received a copy of the GNU General Public
-** License along with this library; if not, write to the
-** Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-** Boston, MA 02111-1307, USA.
-**
-** Author contact information:
-** drh@hwaci.com
-** http://www.hwaci.com/drh/
-**
-*************************************************************************
+***************************************************************************
** A ZIP archive virtual filesystem for Tcl.
**
** This package of routines enables Tcl to use a Zip file as
** a virtual file system. Each of the content files of the Zip
** archive appears as a real file to Tcl.
**
-** Well, almost... Actually, the virtual file system is limited
-** in a number of ways. The only things you can do are "stat"
-** and "read" file content files. You cannot "seek", nor "cd" and
-** the "glob" command doesn't work. But it turns out that "stat"
-** and "read" are sufficient for most purposes.
+** Converted to Tcl VFS by Peter MacDonald
+** peter@pdqi.com
+** http://pdqi.com
+**
**
-** @(#) $Id: zvfs.c,v 1.7 2006/03/14 22:12:35 joye Exp $
+** Modified by Damon Courtney to complete the VFS work.
+**
+** @(#) $Id: zvfs.c,v 1.1.1.1 2002/01/27 17:44:02 cvs Exp $
*/
-#include "tcl.h"
-#include <ctype.h>
-#include <zlib.h>
-#include <errno.h>
-#include <string.h>
-#include <sys/stat.h>
-
-#define DEBUG 0
+/* Modified by Joseph Wang (joequant@gmail.com) to check if
+ file is zip when looking at path and skipping if its
+ not a zip file */
+#include "tclInt.h"
+#include "tclPort.h"
+#include <zlib.h>
/*
-** Size of the decompression input buffer
-*/
+ * Size of the decompression input buffer
+ */
#define COMPR_BUF_SIZE 8192
-static int maptolower=0;
-
+#ifdef __WIN32__
+#define NOCASE_PATHS 1
+#else
+#define NOCASE_PATHS 0
+#endif
/*
-** All static variables are collected into a structure named "local".
-** That way, it is clear in the code when we are using a static
-** variable because its name begins with "local.".
-*/
+ * All static variables are collected into a structure named "local".
+ * That way, it is clear in the code when we are using a static
+ * variable because its name begins with "local.".
+ */
static struct {
- Tcl_HashTable fileHash; /* One entry for each file in the ZVFS. The
- ** The key is the virtual filename. The data
- ** an an instance of the ZvfsFile structure. */
- Tcl_HashTable archiveHash; /* One entry for each archive. Key is the name.
- ** data is the ZvfsArchive structure */
- int isInit; /* True after initialization */
- Tcl_Interp *interp;
+ Tcl_HashTable fileHash; /* One entry for each file in the ZVFS. The
+ * The key is the virtual filename. The data
+ * an an instance of the ZvfsFile structure.
+ */
+ Tcl_HashTable archiveHash; /* One entry for each archive.
+ * Key is the name.
+ * Data is the ZvfsArchive structure.
+ */
+ int isInit; /* True after initialization */
} local;
-
/*
-** Each ZIP archive file that is mounted is recorded as an instance
-** of this structure
-*/
+ * Each ZIP archive file that is mounted is recorded as an instance
+ * of this structure
+ */
typedef struct ZvfsArchive {
- char *zName; /* Name of the archive */
- char *zMountPoint; /* Where this archive is mounted */
- struct ZvfsFile *pFiles; /* List of files in that archive */
+ int refCount;
+ Tcl_Obj *zName; /* Name of the archive */
+ Tcl_Obj *zMountPoint; /* Where this archive is mounted */
} ZvfsArchive;
-
/*
-** Particulars about each virtual file are recorded in an instance
-** of the following structure.
-*/
+ * Particulars about each virtual file are recorded in an instance
+ * of the following structure.
+ */
typedef struct ZvfsFile {
- char *zName; /* The full pathname of the virtual file */
- ZvfsArchive *pArchive; /* The ZIP archive holding this file data */
- int iOffset; /* Offset into the ZIP archive of the data */
- int nByte; /* Uncompressed size of the virtual file */
- int nByteCompr; /* Compressed size of the virtual file */
- struct ZvfsFile *pNext; /* Next file in the same archive */
- struct ZvfsFile *pNextName; /* A doubly-linked list of files with the same */
- struct ZvfsFile *pPrevName; /* name. Only the first is in local.fileHash */
+ int refCount; /* Reference count */
+ Tcl_Obj *zName; /* The full pathname of the virtual file */
+ ZvfsArchive *pArchive; /* The ZIP archive holding this file data */
+ int iOffset; /* Offset into the ZIP archive of the data */
+ int nByte; /* Uncompressed size of the virtual file */
+ int nByteCompr; /* Compressed size of the virtual file */
+ int isdir; /* Set to 1 if directory */
+ int timestamp; /* Modification time */
+ int iCRC; /* Cyclic Redundancy Check of the data */
+ struct ZvfsFile *parent; /* Parent directory. */
+ Tcl_HashTable children; /* For directory entries, a hash table of
+ * all of the files in the directory.
+ */
} ZvfsFile;
-
-
/*
-** Macros to read 16-bit and 32-bit big-endian integers into the
-** native format of this local processor. B is an array of
-** characters and the integer begins at the N-th character of
-** the array.
-*/
+ * Whenever a ZVFS file is opened, an instance of this structure is
+ * attached to the open channel where it will be available to the
+ * ZVFS I/O routines below. All state information about an open
+ * ZVFS file is held in this structure.
+ */
+typedef struct ZvfsChannelInfo {
+ unsigned int nByte; /* number of bytes of read uncompressed data */
+ unsigned int nByteCompr; /* number of bytes of unread compressed data */
+ unsigned int nData; /* total number of bytes of compressed data */
+ int readSoFar; /* Number of bytes read so far */
+ long startOfData; /* File position of data in ZIP archive */
+ int isCompressed; /* True data is compressed */
+ Tcl_Channel chan; /* Open to the archive file */
+ unsigned char *zBuf; /* buffer used by the decompressor */
+ z_stream stream; /* state of the decompressor */
+} ZvfsChannelInfo;
+/* The attributes defined for each file in the archive.
+ * These are accessed via the 'file attributes' command in Tcl.
+ */
+static CONST char *ZvfsAttrs[] = {
+ "-archive", "-compressedsize", "-crc", "-mount", "-offset",
+ "-uncompressedsize", (char *)NULL
+};
+enum {
+ ZVFS_ATTR_ARCHIVE, ZVFS_ATTR_COMPSIZE, ZVFS_ATTR_CRC,
+ ZVFS_ATTR_MOUNT, ZVFS_ATTR_OFFSET, ZVFS_ATTR_UNCOMPSIZE
+};
+/* Forward declarations for the callbacks to the Tcl filesystem. */
+static Tcl_FSPathInFilesystemProc PathInFilesystem;
+static Tcl_FSDupInternalRepProc DupInternalRep;
+static Tcl_FSFreeInternalRepProc FreeInternalRep;
+static Tcl_FSInternalToNormalizedProc InternalToNormalized;
+static Tcl_FSFilesystemPathTypeProc FilesystemPathType;
+static Tcl_FSFilesystemSeparatorProc FilesystemSeparator;
+static Tcl_FSStatProc Stat;
+static Tcl_FSAccessProc Access;
+static Tcl_FSOpenFileChannelProc OpenFileChannel;
+static Tcl_FSMatchInDirectoryProc MatchInDirectory;
+static Tcl_FSListVolumesProc ListVolumes;
+static Tcl_FSFileAttrStringsProc FileAttrStrings;
+static Tcl_FSFileAttrsGetProc FileAttrsGet;
+static Tcl_FSFileAttrsSetProc FileAttrsSet;
+static Tcl_FSChdirProc Chdir;
+static Tcl_Filesystem zvfsFilesystem = {
+ "zvfs",
+ sizeof(Tcl_Filesystem),
+ TCL_FILESYSTEM_VERSION_1,
+ &PathInFilesystem,
+ &DupInternalRep,
+ &FreeInternalRep,
+ &InternalToNormalized,
+ NULL, /* &CreateInternalRep, */
+ NULL, /* &NormalizePath, */
+ &FilesystemPathType,
+ &FilesystemSeparator,
+ &Stat,
+ &Access,
+ &OpenFileChannel,
+ &MatchInDirectory,
+ NULL, /* &Utime, */
+ NULL, /* &Link, */
+ &ListVolumes,
+ &FileAttrStrings,
+ &FileAttrsGet,
+ &FileAttrsSet,
+ NULL, /* &CreateDirectory, */
+ NULL, /* &RemoveDirectory, */
+ NULL, /* &DeleteFile, */
+ NULL, /* &CopyFile, */
+ NULL, /* &RenameFile, */
+ NULL, /* &CopyDirectory, */
+ NULL, /* &Lstat, */
+ NULL, /* &LoadFile, */
+ NULL, /* &GetCwd, */
+ &Chdir
+};
+/*
+ * Forward declarations describing the channel type structure for
+ * opening and reading files inside of an archive.
+ */
+static Tcl_DriverCloseProc DriverClose;
+static Tcl_DriverInputProc DriverInput;
+static Tcl_DriverOutputProc DriverOutput;
+static Tcl_DriverSeekProc DriverSeek;
+static Tcl_DriverWatchProc DriverWatch;
+static Tcl_DriverGetHandleProc DriverGetHandle;
+static Tcl_ChannelType vfsChannelType = {
+ "zvfs", /* Type name. */
+ TCL_CHANNEL_VERSION_2, /* Set blocking/nonblocking behaviour. NULL'able */
+ DriverClose, /* Close channel, clean instance data */
+ DriverInput, /* Handle read request */
+ DriverOutput, /* Handle write request */
+ DriverSeek, /* Move location of access point. NULL'able */
+ NULL, /* Set options. NULL'able */
+ NULL, /* Get options. NULL'able */
+ DriverWatch, /* Initialize notifier */
+ DriverGetHandle /* Get OS handle from the channel. */
+};
+/*
+ * Macros to read 16-bit and 32-bit big-endian integers into the
+ * native format of this local processor. B is an array of
+ * characters and the integer begins at the N-th character of
+ * the array.
+ */
#define INT16(B, N) (B[N] + (B[N+1]<<8))
#define INT32(B, N) (INT16(B,N) + (B[N+2]<<16) + (B[N+3]<<24))
-
-
/*
-** Concatenate zTail onto zRoot to form a pathname. zRoot will begin
-** with "/". After concatenation, simplify the pathname be removing
-** unnecessary ".." and "." directories. Under windows, make all
-** characters lower case.
-**
-** Resulting pathname is returned. Space to hold the returned path is
-** obtained form Tcl_Alloc() and should be freed by the calling function.
-
-static char *CanonicalPath(const char *zRoot, const char *zTail){
- char *zPath;
- int i, j, c;
-
+ *----------------------------------------------------------------------
+ *
+ * DosTimeDate --
+ *
+ * Convert DOS date and time from a zip archive into clock seconds.
+ *
+ * Results:
+ * Clock seconds
+ *
+ *----------------------------------------------------------------------
+ */
+static time_t
+DosTimeDate( int dosDate, int dosTime )
+{
+ time_t now;
+ struct tm *tm;
+ now=time(NULL);
+ tm = localtime(&now);
+ tm->tm_year=(((dosDate&0xfe00)>>9) + 80);
+ tm->tm_mon=((dosDate&0x1e0)>>5)-1;
+ tm->tm_mday=(dosDate & 0x1f);
+ tm->tm_hour=(dosTime&0xf800)>>11;
+ tm->tm_min=(dosTime&0x7e)>>5;
+ tm->tm_sec=(dosTime&0x1f);
+ return mktime(tm);
+}
+/*
+ *----------------------------------------------------------------------
+ *
+ * StrDup --
+ *
+ * Create a copy of the given string and lower it if necessary.
+ *
+ * Results:
+ * Pointer to the new string. Space to hold the returned
+ * string is obtained from Tcl_Alloc() and should be freed
+ * by the calling function.
+ *
+ *----------------------------------------------------------------------
+ */
+char *
+StrDup( char *str, int lower )
+{
+ int i, c, len;
+ char *newstr;
+ len = strlen(str);
+ newstr = Tcl_Alloc( len + 1 );
+ memcpy( newstr, str, len );
+ newstr[len] = '\0';
+ if( lower ) {
+ for( i = 0; (c = newstr[i]) != 0; ++i )
+ {
+ if( isupper(c) ) {
+ newstr[i] = tolower(c);
+ }
+ }
+ }
+ return newstr;
+}
+/*
+ *----------------------------------------------------------------------
+ *
+ * CanonicalPath --
+ *
+ * Concatenate zTail onto zRoot to form a pathname. After
+ * concatenation, simplify the pathname by removing ".." and
+ * "." directories.
+ *
+ * Results:
+ * Pointer to the new pathname. Space to hold the returned
+ * path is obtained from Tcl_Alloc() and should be freed by
+ * the calling function.
+ *
+ *----------------------------------------------------------------------
+ */
+static char *
+CanonicalPath( const char *zRoot, const char *zTail )
+{
+ char *zPath;
+ int i, j, c;
+ int len = strlen(zRoot) + strlen(zTail) + 2;
#ifdef __WIN32__
- if( isalpha(zTail[0]) && zTail[1]==':' ){ zTail += 2; }
- if( zTail[0]=='\\' ){ zRoot = ""; zTail++; }
+ if( isalpha(zTail[0]) && zTail[1]==':' ){ zTail += 2; }
+ if( zTail[0]=='\\' ){ zRoot = ""; zTail++; }
+ if( zTail[0]=='\\' ){ zRoot = "/"; zTail++; } // account for UNC style path
#endif
- if( zTail[0]=='/' ){ zRoot = ""; zTail++; }
- zPath = Tcl_Alloc( strlen(zRoot) + strlen(zTail) + 2 );
- if( zPath==0 ) return 0;
- sprintf(zPath, "%s/%s", zRoot, zTail);
- for(i=j=0; (c = zPath[i])!=0; i++){
+ if( zTail[0]=='/' ){ zRoot = ""; zTail++; }
+ if( zTail[0]=='/' ){ zRoot = "/"; zTail++; } // account for UNC style path
+ zPath = Tcl_Alloc( len );
+ if( !zPath ) return NULL;
+ sprintf( zPath, "%s/%s", zRoot, zTail );
+ for( i = j = 0; (c = zPath[i]) != 0; i++ )
+ {
#ifdef __WIN32__
- if( isupper(c) ) { if (maptolower) c = tolower(c); }
- else if( c=='\\' ) c = '/';
-#endif
- if( c=='/' ){
- int c2 = zPath[i+1];
- if( c2=='/' ) continue;
- if( c2=='.' ){
- int c3 = zPath[i+2];
- if( c3=='/' || c3==0 ){
- i++;
- continue;
+ if( c == '\\' ) {
+ c = '/';
}
- if( c3=='.' && (zPath[i+3]=='.' || zPath[i+3]==0) ){
- i += 2;
- while( j>0 && zPath[j-1]!='/' ){ j--; }
- continue;
+#endif
+ if( c == '/' ) {
+ int c2 = zPath[i+1];
+ if( c2 == '/' ) continue;
+ if( c2 == '.' ) {
+ int c3 = zPath[i+2];
+ if( c3 == '/' || c3 == 0 ) {
+ i++;
+ continue;
+ }
+ if( c3 == '.' && (zPath[i+3] == '.' || zPath[i+3] == 0) ) {
+ i += 2;
+ while( j > 0 && zPath[j-1] != '/' ) { j--; }
+ continue;
+ }
+ }
}
- }
+ zPath[j++] = c;
}
- zPath[j++] = c;
- }
- if( j==0 ){ zPath[j++] = '/'; }
- zPath[j] = 0;
- return zPath;
-}
-*/
-static char *CanonicalPath(const char *zRoot, const char *zTail)
-{
- int argc = 2;
- const char *argv[2];
- char *rr,*zPath;
-
- Tcl_DString pwd;
- Tcl_DStringInit(&pwd);
-
- argv[0] = zRoot;
- argv[1] = zTail;
-
- Tcl_JoinPath(argc, argv, &pwd);
- rr = Tcl_DStringValue(&pwd);
- zPath = Tcl_Alloc(strlen(rr)+1);
- strcpy(zPath,rr);
- Tcl_DStringFree(&pwd);
-
- return zPath;
+ if( j == 0 ) {
+ zPath[j++] = '/';
+ }
+ zPath[j] = 0;
+ return zPath;
}
-
-/*
-** Construct an absolute pathname is memory obtained from Tcl_Alloc
-** that means the same file as the pathname given.
-*/
/*
-static char *AbsolutePath(const char *zRelative){
- Tcl_DString pwd;
- char *zResult;
- Tcl_DStringInit(&pwd);
- if( zRelative[0]!='/' ){
+ *----------------------------------------------------------------------
+ *
+ * AbsolutePath --
+ *
+ * Construct an absolute pathname from the given pathname. On
+ * Windows, all backslash (\) characters are converted to
+ * forward slash (/), and if NOCASE_PATHS is true, all letters
+ * are converted to lowercase. The drive letter, if present, is
+ * preserved.
+ *
+ * Results:
+ * Pointer to the new pathname. Space to hold the returned
+ * path is obtained from Tcl_Alloc() and should be freed by
+ * the calling function.
+ *
+ *----------------------------------------------------------------------
+ */
+static char *
+AbsolutePath( const char *z )
+{
+ int len;
+ char *zResult;
+ if( *z != '/'
+#ifdef __WIN32__
+ && *z != '\\' && (!isalpha(*z) || z[1] != ':' )
+#endif
+ ) {
+ /* Case 1: "z" is a relative path, so prepend the current
+ * working directory in order to generate an absolute path.
+ */
+ Tcl_Obj *pwd = Tcl_FSGetCwd(NULL);
+ zResult = CanonicalPath( Tcl_GetString(pwd), z );
+ Tcl_DecrRefCount(pwd);
+ } else {
+ /* Case 2: "z" is an absolute path already, so we
+ * just need to make a copy of it.
+ */
+ zResult = StrDup( (char *)z, 0);
+ }
+ /* If we're on Windows, we want to convert all backslashes to
+ * forward slashes. If NOCASE_PATHS is true, we want to also
+ * lower the alpha characters in the path.
+ */
+#if NOCASE_PATHS || defined(__WIN32__)
+ {
+ int i, c;
+ for( i = 0; (c = zResult[i]) != 0; i++ )
+ {
+#if NOCASE_PATHS
+ if( isupper(c) ) {
+ zResult[i] = tolower(c);
+ }
+#endif
#ifdef __WIN32__
- if( zRelative[0]!='\\' )
+ if( c == '\\' ) {
+ zResult[i] = '/';
+ }
#endif
- Tcl_GetCwd(0, &pwd);
- }
- zResult = CanonicalPath( Tcl_DStringValue(&pwd), zRelative);
- Tcl_DStringFree(&pwd);
- return zResult;
+ }
+ }
+#endif /* NOCASE_PATHS || defined(__WIN32__) */
+ len = strlen(zResult);
+ /* Strip the trailing / from any directory. */
+ if( zResult[len-1] == '/' ) {
+ zResult[len-1] = 0;
+ }
+ return zResult;
}
-*/
-static char *AbsolutePath(const char *zRelative)
+/*
+ *----------------------------------------------------------------------
+ *
+ * AddPathToArchive --
+ *
+ * Add the given pathname to the given archive. zName is usually
+ * the pathname pulled from the file header in a zip archive. We
+ * concatenate it onto the archive's mount point to obtain a full
+ * path before adding it to our hash table.
+ *
+ * All parent directories of the given path will be created and
+ * added to the hash table.
+ *
+ * Results:
+ * Pointer to the new file structure or to the old file structure
+ * if it already existed. newPath will be true if this path is
+ * new to this archive or false if we already had it.
+ *
+ *----------------------------------------------------------------------
+ */
+static ZvfsFile *
+AddPathToArchive( ZvfsArchive *pArchive, char *zName, int *newPath )
{
- Tcl_Obj *rr,*aa;
- const char* zz;
- int ll;
- char* zResult;
-
- rr = Tcl_NewStringObj(zRelative, strlen(zRelative));
- Tcl_IncrRefCount(rr);
- aa = Tcl_FSGetNormalizedPath(local.interp, rr);
- Tcl_IncrRefCount(aa);
- zz = Tcl_GetStringFromObj(aa,&ll);
- zResult = Tcl_Alloc(ll+1);
- strcpy(zResult,zz);
-
- Tcl_DecrRefCount(rr);
- Tcl_DecrRefCount(aa);
-
- return zResult;
+ int i, len, isNew;
+ char *zFullPath, *izFullPath;
+ char *zParentPath, *izParentPath;
+ Tcl_HashEntry *pEntry;
+ Tcl_Obj *nameObj, *pathObj, *listObj;
+ ZvfsFile *pZvfs, *parent = NULL;
+ zFullPath = CanonicalPath( Tcl_GetString(pArchive->zMountPoint), zName );
+ izFullPath = zFullPath;
+ pathObj = Tcl_NewStringObj( zFullPath, -1 );
+ Tcl_IncrRefCount( pathObj );
+ listObj = Tcl_FSSplitPath( pathObj, &len );
+ Tcl_IncrRefCount( listObj );
+ Tcl_DecrRefCount( pathObj );
+ /* Walk through all the parent directories of this
+ * file and add them all to our archive. This is
+ * because some zip files don't store directory
+ * entries in the archive, but we need to know all
+ * of the directories to create the proper filesystem.
+ */
+ for( i = 1; i < len; ++i )
+ {
+ pathObj = Tcl_FSJoinPath( listObj, i );
+ izParentPath = zParentPath = Tcl_GetString(pathObj);
+#if NOCASE_PATHS
+ izParentPath = StrDup( zParentPath, 1 );
+#endif
+ pEntry = Tcl_CreateHashEntry( &local.fileHash, izParentPath, &isNew );
+#if NOCASE_PATHS
+ Tcl_Free( izParentPath );
+#endif
+ if( !isNew ) {
+ /* We already have this directory in our archive. */
+ parent = Tcl_GetHashValue( pEntry );
+ continue;
+ }
+ Tcl_ListObjIndex( NULL, listObj, i-1, &nameObj );
+ Tcl_IncrRefCount(nameObj);
+ /* We don't have this directory in our archive yet. Add it. */
+ pZvfs = (ZvfsFile*)Tcl_Alloc( sizeof(*pZvfs) );
+ pZvfs->refCount = 1;
+ pZvfs->zName = nameObj;
+ pZvfs->pArchive = pArchive;
+ pZvfs->isdir = 1;
+ pZvfs->iOffset = 0;
+ pZvfs->timestamp = 0;
+ pZvfs->iCRC = 0;
+ pZvfs->nByteCompr = 0;
+ pZvfs->nByte = 0;
+ pZvfs->parent = parent;
+ Tcl_InitHashTable( &pZvfs->children, TCL_STRING_KEYS );
+ Tcl_SetHashValue( pEntry, pZvfs );
+ if( parent ) {
+ /* Add this directory to its parent's list of children. */
+ pEntry = Tcl_CreateHashEntry(&parent->children,zParentPath,&isNew);
+ if( isNew ) {
+ Tcl_SetHashValue( pEntry, pZvfs );
+ }
+ }
+ parent = pZvfs;
+ }
+ /* Check to see if we already have this file in our archive. */
+#if NOCASE_PATHS
+ izFullPath = StrDup( zFullPath, 1 );
+#endif
+ pEntry = Tcl_CreateHashEntry(&local.fileHash, izFullPath, newPath);
+#if NOCASE_PATHS
+ Tcl_Free( izFullPath );
+#endif
+ if( *newPath ) {
+ /* We don't have this file in our archive. Add it. */
+ Tcl_ListObjIndex( NULL, listObj, len-1, &nameObj );
+ Tcl_IncrRefCount(nameObj);
+ pZvfs = (ZvfsFile*)Tcl_Alloc( sizeof(*pZvfs) );
+ pZvfs->refCount = 1;
+ pZvfs->zName = nameObj;
+ pZvfs->pArchive = pArchive;
+ Tcl_SetHashValue( pEntry, pZvfs );
+ /* Add this path to its parent's list of children. */
+ pEntry = Tcl_CreateHashEntry(&parent->children, zFullPath, &isNew);
+ if( isNew ) {
+ Tcl_SetHashValue( pEntry, pZvfs );
+ }
+ } else {
+ /* We already have this file. Set the pointer and return. */
+ pZvfs = Tcl_GetHashValue( pEntry );
+ }
+ Tcl_DecrRefCount(listObj);
+ Tcl_Free(zFullPath);
+ return pZvfs;
}
-
/*
-** Read a ZIP archive and make entries in the virutal file hash table for all
-** content files of that ZIP archive. Also initialize the ZVFS if this
-** routine has not been previously called.
-*/
-int Zvfs_Mount(
- Tcl_Interp *interp, /* Leave error messages in this interpreter */
- char *zArchive, /* The ZIP archive file */
- char *zMountPoint /* Mount contents at this directory */
-){
- Tcl_Channel chan; /* Used for reading the ZIP archive file */
- char *zArchiveName = 0; /* A copy of zArchive */
- int nFile; /* Number of files in the archive */
- int iPos; /* Current position in the archive file */
- ZvfsArchive *pArchive; /* The ZIP archive being mounted */
- Tcl_HashEntry *pEntry; /* Hash table entry */
- int isNew; /* Flag to tell use when a hash entry is new */
- unsigned char zBuf[100]; /* Space into which to read from the ZIP archive */
- Tcl_HashSearch zSearch; /* Search all mount points */
-
- if( !local.isInit ) return TCL_ERROR;
- if (!zArchive) {
- pEntry=Tcl_FirstHashEntry(&local.archiveHash,&zSearch);
- while (pEntry) {
- if (pArchive = Tcl_GetHashValue(pEntry)) {
- Tcl_AppendResult(interp,pArchive->zMountPoint," ",pArchive->zName," ",0);
- }
- pEntry=Tcl_NextHashEntry(&zSearch);
+ *----------------------------------------------------------------------
+ *
+ * Zvfs_Mount --
+ *
+ * Read a zip archive and make entries in the file hash table for
+ * all of the files in the archive. If Zvfs has not been initialized,
+ * it will be initialized here before mounting the archive.
+ *
+ * Results:
+ * Standard Tcl result.
+ *
+ *----------------------------------------------------------------------
+ */
+int
+Zvfs_Mount(
+ Tcl_Interp *interp, /* Leave error messages in this interpreter */
+ CONST char *zArchive, /* The ZIP archive file */
+ CONST char *zMountPoint /* Mount contents at this directory */
+) {
+ Tcl_Channel chan = NULL; /* Used for reading the ZIP archive file */
+ char *zArchiveName = 0; /* A copy of zArchive */
+ char *zFullMountPoint = 0; /* Absolute path to the mount point */
+ int nFile; /* Number of files in the archive */
+ int iPos; /* Current position in the archive file */
+ int code = TCL_ERROR; /* Return code */
+ int update = 1; /* Whether to update the mounts */
+ ZvfsArchive *pArchive; /* The ZIP archive being mounted */
+ Tcl_HashEntry *pEntry; /* Hash table entry */
+ int isNew; /* Flag to tell use when a hash entry is new */
+ unsigned char zBuf[100]; /* Buffer to read from the ZIP archive */
+ ZvfsFile *pZvfs; /* A new virtual file */
+ Tcl_Obj *hashKeyObj = NULL;
+ Tcl_Obj *resultObj = Tcl_GetObjResult(interp);
+ Tcl_Obj *readObj = Tcl_NewObj();
+ Tcl_IncrRefCount(readObj);
+ if( !local.isInit ) {
+ if( Zvfs_Init( interp ) == TCL_ERROR ) {
+ Tcl_SetStringObj( resultObj, "failed to initialize zvfs", -1 );
+ return TCL_ERROR;
+ }
}
- return TCL_OK;
- }
- if (!zMountPoint) {
- pEntry = Tcl_FindHashEntry(&local.archiveHash,AbsolutePath(zArchive));
- if (pEntry) {
- if (pArchive = Tcl_GetHashValue(pEntry)) {
- Tcl_AppendResult(interp, pArchive->zMountPoint, 0);
- }
+ /* If zArchive is NULL, set the result to a list of all
+ * mounted files.
+ */
+ if( !zArchive ) {
+ Tcl_HashSearch zSearch;
+ for( pEntry = Tcl_FirstHashEntry( &local.archiveHash,&zSearch );
+ pEntry; pEntry = Tcl_NextHashEntry(&zSearch) )
+ {
+ if( (pArchive = Tcl_GetHashValue(pEntry)) ) {
+ Tcl_ListObjAppendElement( interp, resultObj,
+ Tcl_DuplicateObj(pArchive->zName) );
+ }
+ }
+ code = TCL_OK;
+ update = 0;
+ goto done;
}
- return TCL_OK;
- }
- chan = Tcl_OpenFileChannel(interp, zArchive, "r", 0);
- if (!chan) {
- return TCL_ERROR;
- }
- if (Tcl_SetChannelOption(interp, chan, "-translation", "binary") != TCL_OK){
- return TCL_ERROR;
- }
- if (Tcl_SetChannelOption(interp, chan, "-encoding", "binary") != TCL_OK) {
- return TCL_ERROR;
- }
-
- /* Read the "End Of Central Directory" record from the end of the
- ** ZIP archive.
- */
- iPos = Tcl_Seek(chan, -22, SEEK_END);
- Tcl_Read(chan, zBuf, 22);
- if (memcmp(zBuf, "\120\113\05\06", 4)) {
- Tcl_AppendResult(interp, "not a ZIP archive", NULL);
- return TCL_ERROR;
- }
-
- /* Construct the archive record
- */
- zArchiveName = AbsolutePath(zArchive);
- pEntry = Tcl_CreateHashEntry(&local.archiveHash, zArchiveName, &isNew);
- if( !isNew ){
- pArchive = Tcl_GetHashValue(pEntry);
- Tcl_AppendResult(interp, "already mounted at ", pArchive->zMountPoint, 0);
- Tcl_Free(zArchiveName);
- Tcl_Close(interp, chan);
- return TCL_ERROR;
- }
- pArchive = (ZvfsArchive*)Tcl_Alloc(sizeof(*pArchive) + strlen(zMountPoint)+1);
- pArchive->zName = zArchiveName;
- pArchive->zMountPoint = (char*)&pArchive[1];
- strcpy(pArchive->zMountPoint, zMountPoint);
- pArchive->pFiles = 0;
- Tcl_SetHashValue(pEntry, pArchive);
-
- /* Compute the starting location of the directory for the ZIP archive
- ** in iPos then seek to that location.
- */
- nFile = INT16(zBuf,8);
- iPos -= INT32(zBuf,12);
- Tcl_Seek(chan, iPos, SEEK_SET);
-
- while( nFile-- > 0 ){
- int lenName; /* Length of the next filename */
- int lenExtra; /* Length of "extra" data for next file */
- int iData; /* Offset to start of file data */
- ZvfsFile *pZvfs; /* A new virtual file */
- char *zFullPath; /* Full pathname of the virtual file */
- char zName[1024]; /* Space to hold the filename */
-
- /* Read the next directory entry. Extract the size of the filename,
- ** the size of the "extra" information, and the offset into the archive
- ** file of the file data.
- */
- Tcl_Read(chan, zBuf, 46);
- if (memcmp(zBuf, "\120\113\01\02", 4)) {
- Tcl_AppendResult(interp, "ill-formed central directory entry", NULL);
- return TCL_ERROR;
- }
- lenName = INT16(zBuf,28);
- lenExtra = INT16(zBuf,30) + INT16(zBuf,32);
- iData = INT32(zBuf,42);
-
- /* If the virtual filename is too big to fit in zName[], then skip
- ** this file
- */
- if( lenName >= sizeof(zName) ){
- Tcl_Seek(chan, lenName + lenExtra, SEEK_CUR);
- continue;
+ /* If zMountPoint is NULL, set the result to the mount point
+ * for the specified archive file.
+ */
+ if( !zMountPoint ) {
+ int found = 0;
+ Tcl_HashSearch zSearch;
+ zArchiveName = AbsolutePath( zArchive );
+ for( pEntry = Tcl_FirstHashEntry(&local.archiveHash,&zSearch);
+ pEntry; pEntry = Tcl_NextHashEntry(&zSearch) )
+ {
+ pArchive = Tcl_GetHashValue(pEntry);
+ if ( !strcmp( Tcl_GetString(pArchive->zName), zArchiveName ) ) {
+ ++found;
+ Tcl_SetStringObj( resultObj,
+ Tcl_GetString(pArchive->zMountPoint), -1 );
+ break;
+ }
+ }
+ if( !found ) {
+ Tcl_SetStringObj( resultObj, "archive not mounted by zvfs", -1 );
+ }
+ code = found ? TCL_OK : TCL_ERROR;
+ update = 0;
+ goto done;
}
-
- /* Construct an entry in local.fileHash for this virtual file.
- */
- Tcl_Read(chan, zName, lenName);
- zName[lenName] = 0;
- zFullPath = CanonicalPath(zMountPoint, zName);
- if (DEBUG)
- printf("Mount: %s %s \n",zName, zFullPath);
- pZvfs = (ZvfsFile*)Tcl_Alloc( sizeof(*pZvfs) );
- pZvfs->zName = zFullPath;
- pZvfs->pArchive = pArchive;
- pZvfs->iOffset = iData;
- pZvfs->nByte = INT32(zBuf, 24);
- pZvfs->nByteCompr = INT32(zBuf, 20);
- pZvfs->pNext = pArchive->pFiles;
- pArchive->pFiles = pZvfs;
- pEntry = Tcl_CreateHashEntry(&local.fileHash, zFullPath, &isNew);
- if( isNew ){
- pZvfs->pNextName = 0;
- }else{
- ZvfsFile *pOld = (ZvfsFile*)Tcl_GetHashValue(pEntry);
- pOld->pPrevName = pZvfs;
- pZvfs->pNextName = pOld;
- }
- pZvfs->pPrevName = 0;
- Tcl_SetHashValue(pEntry, (ClientData) pZvfs);
-
- /* Skip over the extra information so that the next read will be from
- ** the beginning of the next directory entry.
- */
- Tcl_Seek(chan, lenExtra, SEEK_CUR);
- }
- Tcl_Close(interp, chan);
- return TCL_OK;
-}
-
-/*
-** Locate the ZvfsFile structure that corresponds to the file named.
-** Return NULL if there is no such ZvfsFile.
-*/
-static ZvfsFile *ZvfsLookup(char *zFilename){
- char *zTrueName;
- Tcl_HashEntry *pEntry;
- ZvfsFile *pFile;
-
- if( local.isInit==0 ) return 0;
- zTrueName = AbsolutePath(zFilename);
- pEntry = Tcl_FindHashEntry(&local.fileHash, zTrueName);
- pFile = pEntry ? Tcl_GetHashValue(pEntry) : 0;
- if (DEBUG)
- printf("%s %s %d\n",zFilename, zTrueName, pFile);
- Tcl_Free(zTrueName);
- return pFile;
+ if( !(chan = Tcl_OpenFileChannel(interp, zArchive, "r", 0)) ) {
+ goto done;
+ }
+ if(Tcl_SetChannelOption(interp, chan, "-translation", "binary") != TCL_OK) {
+ goto done;
+ }
+ /* Read the "End Of Central Directory" record from the end of the
+ * ZIP archive.
+ */
+ iPos = Tcl_Seek( chan, -22, SEEK_END );
+ Tcl_Read( chan, zBuf, 22 );
+ if( memcmp(zBuf, "\120\113\05\06", 4) ) {
+ Tcl_SetStringObj( resultObj, "bad end of central directory record", -1);
+ goto done;
+ }
+ zArchiveName = AbsolutePath( zArchive );
+ zFullMountPoint = AbsolutePath( zMountPoint );
+ hashKeyObj = Tcl_NewObj();
+ Tcl_IncrRefCount(hashKeyObj);
+ Tcl_AppendStringsToObj( hashKeyObj, zArchiveName, ":", zFullMountPoint,
+ (char *)NULL );
+ pEntry = Tcl_CreateHashEntry( &local.archiveHash,
+ Tcl_GetString(hashKeyObj), &isNew );
+ if( !isNew ) {
+ /* This archive is already mounted. Set the result to
+ * the current mount point and return.
+ */
+ pArchive = Tcl_GetHashValue(pEntry);
+ code = TCL_OK;
+ update = 0;
+ goto done;
+ }
+ pArchive = (ZvfsArchive*)Tcl_Alloc(sizeof(*pArchive));
+ pArchive->refCount = 1;
+ pArchive->zName = Tcl_NewStringObj(zArchiveName,-1);
+ pArchive->zMountPoint = Tcl_NewStringObj(zFullMountPoint,-1);
+ Tcl_SetHashValue(pEntry, pArchive);
+ /* Add the root mount point to our list of archive files as a directory. */
+ pEntry = Tcl_CreateHashEntry(&local.fileHash, zFullMountPoint, &isNew);
+ if( isNew ) {
+ pZvfs = (ZvfsFile*)Tcl_Alloc( sizeof(*pZvfs) );
+ pZvfs->refCount = 1;
+ pZvfs->zName = Tcl_NewStringObj(zFullMountPoint,-1);
+ pZvfs->pArchive = pArchive;
+ pZvfs->isdir = 1;
+ pZvfs->iOffset = 0;
+ pZvfs->timestamp = 0;
+ pZvfs->iCRC = 0;
+ pZvfs->nByteCompr = 0;
+ pZvfs->nByte = 0;
+ pZvfs->parent = NULL;
+ Tcl_InitHashTable( &pZvfs->children, TCL_STRING_KEYS );
+ Tcl_SetHashValue( pEntry, pZvfs );
+ }
+ /* Compute the starting location of the directory for the
+ * ZIP archive in iPos then seek to that location.
+ */
+ nFile = INT16(zBuf,8);
+ iPos -= INT32(zBuf,12);
+ Tcl_Seek( chan, iPos, SEEK_SET );
+ while( nFile-- > 0 )
+ {
+ int isdir = 0;
+ int iData; /* Offset to start of file data */
+ int lenName; /* Length of the next filename */
+ int lenExtra; /* Length of "extra" data for next file */
+ int attributes; /* DOS attributes */
+ char *zName;
+ char *zFullPath; /* Full pathname of the virtual file */
+ char *izFullPath; /* Lowercase full pathname */
+ ZvfsFile *parent;
+ /* Read the next directory entry. Extract the size of the filename,
+ * the size of the "extra" information, and the offset into the archive
+ * file of the file data.
+ */
+ Tcl_Read( chan, zBuf, 46 );
+ if( memcmp(zBuf, "\120\113\01\02", 4) ) {
+ Zvfs_Unmount( interp, zArchiveName );
+ Tcl_SetStringObj( resultObj, "bad central file record", -1 );
+ goto done;
+ }
+ lenName = INT16(zBuf,28);
+ lenExtra = INT16(zBuf,30) + INT16(zBuf,32);
+ iData = INT32(zBuf,42);
+ /* Construct an entry in local.fileHash for this virtual file. */
+ Tcl_ReadChars( chan, readObj, lenName, 0 );
+ zName = Tcl_GetString(readObj);
+ if( zName[--lenName] == '/' ) {
+ isdir = 1;
+ Tcl_SetObjLength( readObj, lenName );
+ }
+ pZvfs = AddPathToArchive( pArchive, zName, &isNew );
+ pZvfs->isdir = isdir;
+ pZvfs->iOffset = iData;
+ pZvfs->timestamp = DosTimeDate(INT16(zBuf, 14), INT16(zBuf, 12));
+ pZvfs->iCRC = INT32(zBuf, 16);
+ pZvfs->nByteCompr = INT32(zBuf, 20);
+ pZvfs->nByte = INT32(zBuf, 24);
+ /* If this is a directory we want to initialize the
+ * hash table to store its children if it has any.
+ */
+ if( isNew && isdir ) {
+ Tcl_InitHashTable( &pZvfs->children, TCL_STRING_KEYS );
+ }
+ /* Skip over the extra information so that the next read
+ * will be from the beginning of the next directory entry.
+ */
+ Tcl_Seek( chan, lenExtra, SEEK_CUR );
+ }
+ code = TCL_OK;
+done:
+ if( chan ) Tcl_Close( interp, chan );
+ if( readObj ) Tcl_DecrRefCount(readObj);
+ if( hashKeyObj ) Tcl_DecrRefCount(hashKeyObj);
+ if( zArchiveName ) Tcl_Free(zArchiveName);
+ if( zFullMountPoint ) Tcl_Free(zFullMountPoint);
+ if( code == TCL_OK && update ) {
+ Tcl_FSMountsChanged( &zvfsFilesystem );
+ Tcl_SetStringObj( resultObj, zMountPoint, -1 );
+ }
+ return code;
}
-
/*
-** Unmount all the files in the given ZIP archive.
-*/
-static void Zvfs_Unmount(char *zArchive){
- char *zArchiveName;
- ZvfsArchive *pArchive;
- ZvfsFile *pFile, *pNextFile;
- Tcl_HashEntry *pEntry;
-
- zArchiveName = AbsolutePath(zArchive);
- pEntry = Tcl_FindHashEntry(&local.archiveHash, zArchiveName);
- Tcl_Free(zArchiveName);
- if( pEntry==0 ) return;
- pArchive = Tcl_GetHashValue(pEntry);
- Tcl_DeleteHashEntry(pEntry);
- Tcl_Free(pArchive->zName);
- for(pFile=pArchive->pFiles; pFile; pFile=pNextFile){
- pNextFile = pFile->pNext;
- if( pFile->pNextName ){
- pFile->pNextName->pPrevName = pFile->pPrevName;
- }
- if( pFile->pPrevName ){
- pFile->pPrevName->pNextName = pFile->pNextName;
- }else{
- pEntry = Tcl_FindHashEntry(&local.fileHash, pFile->zName);
- if( pEntry==0 ){
- /* This should never happen */
- }else if( pFile->pNextName ){
- Tcl_SetHashValue(pEntry, pFile->pNextName);
- }else{
+ *----------------------------------------------------------------------
+ *
+ * Zvfs_Unmount --
+ *
+ * Unmount all the files in the given zip archive. All the
+ * entries in the file hash table for the archive are deleted
+ * as well as the entry in the archive hash table.
+ *
+ * Any memory associated with the entries will be freed as well.
+ *
+ * Results:
+ * Standard Tcl result.
+ *
+ *----------------------------------------------------------------------
+ */
+int
+Zvfs_Unmount( Tcl_Interp *interp, CONST char *zMountPoint )
+{
+ int found = 0;
+ ZvfsFile *pFile;
+ ZvfsArchive *pArchive;
+ Tcl_HashEntry *pEntry;
+ Tcl_HashSearch zSearch;
+ Tcl_HashEntry *fEntry;
+ Tcl_HashSearch fSearch;
+ for( pEntry = Tcl_FirstHashEntry( &local.archiveHash, &zSearch );
+ pEntry; pEntry = Tcl_NextHashEntry(&zSearch) )
+ {
+ pArchive = Tcl_GetHashValue(pEntry);
+ if( !Tcl_StringCaseMatch( zMountPoint,
+ Tcl_GetString(pArchive->zMountPoint), NOCASE_PATHS ) ) continue;
+ found++;
+ for( fEntry = Tcl_FirstHashEntry( &local.fileHash, &fSearch );
+ fEntry; fEntry = Tcl_NextHashEntry(&fSearch) )
+ {
+ pFile = Tcl_GetHashValue(fEntry);
+ if( pFile->pArchive == pArchive ) {
+ FreeInternalRep( (ClientData)pFile );
+ Tcl_DeleteHashEntry(fEntry);
+ }
+ }
Tcl_DeleteHashEntry(pEntry);
- }
+ Tcl_DecrRefCount(pArchive->zName);
+ Tcl_DecrRefCount(pArchive->zMountPoint);
+ Tcl_Free( (char *)pArchive );
}
- Tcl_Free(pFile->zName);
- Tcl_Free((char*)pFile);
- }
-}
-
-/*
-** zvfs::mount Zip-archive-name mount-point
-**
-** Create a new mount point on the given ZIP archive. After this
-** command executes, files contained in the ZIP archive will appear
-** to Tcl to be regular files at the mount point.
-*/
-static int ZvfsMountCmd(
- void *NotUsed, /* Client data for this command */
- Tcl_Interp *interp, /* The interpreter used to report errors */
- int argc, /* Number of arguments */
- char **argv /* Values of all arguments */
-){
- if( argc>3 ){
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " ? ZIP-FILE ? MOUNT-POINT ? ?\"", 0);
- return TCL_ERROR;
- }
- return Zvfs_Mount(interp, argc>1?argv[1]:0, argc>2?argv[2]:0);
-}
-
-/*
-** zvfs::unmount Zip-archive-name
-**
-** Undo the effects of zvfs::mount.
-*/
-static int ZvfsUnmountCmd(
- void *NotUsed, /* Client data for this command */
- Tcl_Interp *interp, /* The interpreter used to report errors */
- int argc, /* Number of arguments */
- char **argv /* Values of all arguments */
-){
- if( argc!=2 ){
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " ZIP-FILE\"", 0);
- return TCL_ERROR;
- }
- Zvfs_Unmount(argv[1]);
- return TCL_OK;
+ if( !found ) {
+ if( interp ) {
+ Tcl_AppendStringsToObj( Tcl_GetObjResult(interp),
+ zMountPoint, " is not a zvfs mount", (char *)NULL );
+ }
+ return TCL_ERROR;
+ }
+ Tcl_FSMountsChanged( &zvfsFilesystem );
+ return TCL_OK;
}
-
/*
-** zvfs::exists filename
-**
-** Return TRUE if the given filename exists in the ZVFS and FALSE if
-** it does not.
-*/
-static int ZvfsExistsObjCmd(
- void *NotUsed, /* Client data for this command */
- Tcl_Interp *interp, /* The interpreter used to report errors */
- int objc, /* Number of arguments */
- Tcl_Obj *const* objv /* Values of all arguments */
-){
- char *zFilename;
- if( objc!=2 ){
- Tcl_WrongNumArgs(interp, 1, objv, "FILENAME");
- return TCL_ERROR;
- }
- zFilename = Tcl_GetStringFromObj(objv[1], 0);
- if (DEBUG)
- printf("ZvfsExistsObjCmd: ");
- Tcl_SetBooleanObj( Tcl_GetObjResult(interp), ZvfsLookup(zFilename)!=0);
- return TCL_OK;
+ *----------------------------------------------------------------------
+ *
+ * ZvfsLookup --
+ *
+ * Part of the "zvfs" Tcl_Filesystem.
+ * Look into the file hash table for a given path and see if
+ * it belongs to our filesystem.
+ *
+ * Results:
+ * Pointer to the file structure or NULL if it was not found.
+ *
+ *----------------------------------------------------------------------
+ */
+static ZvfsFile *
+ZvfsLookup( Tcl_Obj *pathPtr )
+{
+ char *zTrueName;
+ Tcl_HashEntry *pEntry;
+ zTrueName = AbsolutePath( Tcl_GetString(pathPtr) );
+ pEntry = Tcl_FindHashEntry( &local.fileHash, zTrueName );
+ Tcl_Free(zTrueName);
+ return pEntry ? Tcl_GetHashValue(pEntry) : NULL;
}
-
/*
-** zvfs::info filename
-**
-** Return information about the given file in the ZVFS. The information
-** consists of (1) the name of the ZIP archive that contains the file,
-** (2) the size of the file after decompressions, (3) the compressed
-** size of the file, and (4) the offset of the compressed data in the archive.
-*/
-static int ZvfsInfoObjCmd(
- void *NotUsed, /* Client data for this command */
- Tcl_Interp *interp, /* The interpreter used to report errors */
- int objc, /* Number of arguments */
- Tcl_Obj *const* objv /* Values of all arguments */
-){
- char *zFilename;
- ZvfsFile *pFile;
- if( objc!=2 ){
- Tcl_WrongNumArgs(interp, 1, objv, "FILENAME");
- return TCL_ERROR;
- }
- zFilename = Tcl_GetStringFromObj(objv[1], 0);
- if (DEBUG)
- printf("ZvfsInfoObjCmd: ");
- pFile = ZvfsLookup(zFilename);
- if( pFile ){
- Tcl_Obj *pResult = Tcl_GetObjResult(interp);
- Tcl_ListObjAppendElement(interp, pResult,
- Tcl_NewStringObj(pFile->pArchive->zName, -1));
- Tcl_ListObjAppendElement(interp, pResult, Tcl_NewIntObj(pFile->nByte));
- Tcl_ListObjAppendElement(interp, pResult, Tcl_NewIntObj(pFile->nByteCompr));
- Tcl_ListObjAppendElement(interp, pResult, Tcl_NewIntObj(pFile->iOffset));
- }
- return TCL_OK;
+ *----------------------------------------------------------------------
+ *
+ * GetZvfsFile --
+ *
+ * Part of the "zvfs" Tcl_Filesystem.
+ * For a given pathPtr, return the internal representation
+ * of the path for our filesystem.
+ *
+ * Results:
+ * Pointer to the file structure or NULL if it was not found.
+ *
+ *----------------------------------------------------------------------
+ */
+static ZvfsFile *
+GetZvfsFile( Tcl_Obj *pathPtr )
+{
+ ZvfsFile *pFile = (ZvfsFile *)Tcl_FSGetInternalRep(pathPtr,&zvfsFilesystem);
+ return pFile == NULL || pFile->pArchive->refCount == 0 ? NULL : pFile;
}
/*
-** zvfs::list
-**
-** Return a list of all files in the ZVFS. The order of the names
-** in the list is arbitrary.
-*/
-static int ZvfsListObjCmd(
- void *NotUsed, /* Client data for this command */
- Tcl_Interp *interp, /* The interpreter used to report errors */
- int objc, /* Number of arguments */
- Tcl_Obj *const* objv /* Values of all arguments */
-){
- char *zPattern = 0;
- Tcl_RegExp pRegexp = 0;
- Tcl_HashEntry *pEntry;
- Tcl_HashSearch sSearch;
- Tcl_Obj *pResult = Tcl_GetObjResult(interp);
-
- if( objc>3 ){
- Tcl_WrongNumArgs(interp, 1, objv, "?(-glob|-regexp)? ?PATTERN?");
- return TCL_ERROR;
- }
- if( local.isInit==0 ) return TCL_OK;
- if( objc==3 ){
- int n;
- char *zSwitch = Tcl_GetStringFromObj(objv[1], &n);
- if( n>=2 && strncmp(zSwitch,"-glob",n)==0 ){
- zPattern = Tcl_GetString(objv[2]);
- }else if( n>=2 && strncmp(zSwitch,"-regexp",n)==0 ){
- pRegexp = Tcl_RegExpCompile(interp, Tcl_GetString(objv[2]));
- if( pRegexp==0 ) return TCL_ERROR;
- }else{
- Tcl_AppendResult(interp, "unknown option: ", zSwitch, 0);
- return TCL_ERROR;
- }
- }else if( objc==2 ){
- zPattern = Tcl_GetStringFromObj(objv[1], 0);
- }
- if( zPattern ){
- for(pEntry = Tcl_FirstHashEntry(&local.fileHash, &sSearch);
- pEntry;
- pEntry = Tcl_NextHashEntry(&sSearch)
- ){
- ZvfsFile *pFile = Tcl_GetHashValue(pEntry);
- char *z = pFile->zName;
- if( Tcl_StringCaseMatch(z, zPattern,1) ){
- Tcl_ListObjAppendElement(interp, pResult, Tcl_NewStringObj(z, -1));
- }
- }
- }else if( pRegexp ){
- for(pEntry = Tcl_FirstHashEntry(&local.fileHash, &sSearch);
- pEntry;
- pEntry = Tcl_NextHashEntry(&sSearch)
- ){
- ZvfsFile *pFile = Tcl_GetHashValue(pEntry);
- char *z = pFile->zName;
- if( Tcl_RegExpExec(interp, pRegexp, z, z) ){
- Tcl_ListObjAppendElement(interp, pResult, Tcl_NewStringObj(z, -1));
- }
- }
- }else{
- for(pEntry = Tcl_FirstHashEntry(&local.fileHash, &sSearch);
- pEntry;
- pEntry = Tcl_NextHashEntry(&sSearch)
- ){
- ZvfsFile *pFile = Tcl_GetHashValue(pEntry);
- char *z = pFile->zName;
- Tcl_ListObjAppendElement(interp, pResult, Tcl_NewStringObj(z, -1));
- }
- }
- return TCL_OK;
+ *----------------------------------------------------------------------
+ *
+ * ZvfsFileMatchesType --
+ *
+ * Part of the "zvfs" Tcl_Filesystem.
+ * See if the given ZvfsFile matches the type data given.
+ *
+ * Results:
+ * 1 if true, 0 if false
+ *
+ *----------------------------------------------------------------------
+ */
+static int
+ZvfsFileMatchesType( ZvfsFile *pFile, Tcl_GlobTypeData *types )
+{
+ if( types ) {
+ if( types->type & TCL_GLOB_TYPE_FILE && pFile->isdir ) {
+ return 0;
+ }
+ if( types->type & (TCL_GLOB_TYPE_DIR | TCL_GLOB_TYPE_MOUNT)
+ && !pFile->isdir ) {
+ return 0;
+ }
+ if( types->type & TCL_GLOB_TYPE_MOUNT && pFile->parent ) {
+ return 0;
+ }
+ }
+ return 1;
}
-
-/*
-** Whenever a ZVFS file is opened, an instance of this structure is
-** attached to the open channel where it will be available to the
-** ZVFS I/O routines below. All state information about an open
-** ZVFS file is held in this structure.
-*/
-typedef struct ZvfsChannelInfo {
- unsigned int nByte; /* number of bytes of read uncompressed data */
- unsigned int nByteCompr; /* number of bytes of unread compressed data */
- unsigned int nData; /* total number of bytes of compressed data */
- int readSoFar; /* Number of bytes read so far */
- long startOfData; /* File position of start of data in ZIP archive */
- int isCompressed; /* True data is compressed */
- Tcl_Channel chan; /* Open to the archive file */
- unsigned char *zBuf; /* buffer used by the decompressor */
- z_stream stream; /* state of the decompressor */
-} ZvfsChannelInfo;
-
-
/*
-** This routine is called as an exit handler. If we do not set
-** ZvfsChannelInfo.chan to NULL, then Tcl_Close() will be called on
-** that channel twice when Tcl_Exit runs. This will lead to a
-** core dump.
-*/
-static void vfsExit(void *pArg){
- ZvfsChannelInfo *pInfo = (ZvfsChannelInfo*)pArg;
- pInfo->chan = 0;
+ *----------------------------------------------------------------------
+ *
+ * DriverExit --
+ *
+ * This function is called as an exit handler for the channel
+ * driver. If we do not set pInfo.chan to NULL, Tcl_Close()
+ * will be called twice on that channel when Tcl_Exit runs.
+ * This will lead to a core dump
+ *
+ * Results:
+ * None
+ *
+ *----------------------------------------------------------------------
+ */
+static void
+DriverExit( void *pArg )
+{
+ ZvfsChannelInfo *pInfo = (ZvfsChannelInfo*)pArg;
+ pInfo->chan = 0;
}
-
/*
-** This routine is called when the ZVFS channel is closed
-*/
-static int vfsClose(
+ *----------------------------------------------------------------------
+ *
+ * DriverClose --
+ *
+ * Called when a channel is closed.
+ *
+ * Results:
+ * Returns TCL_OK.
+ *
+ *----------------------------------------------------------------------
+ */
+static int
+DriverClose(
ClientData instanceData, /* A ZvfsChannelInfo structure */
Tcl_Interp *interp /* The TCL interpreter */
-){
- ZvfsChannelInfo* pInfo = (ZvfsChannelInfo*)instanceData;
-
- if( pInfo->zBuf ){
- Tcl_Free(pInfo->zBuf);
- inflateEnd(&pInfo->stream);
- }
- if( pInfo->chan ){
- Tcl_Close(interp, pInfo->chan);
- Tcl_DeleteExitHandler(vfsExit, pInfo);
- }
- Tcl_Free((char*)pInfo);
- return TCL_OK;
+) {
+ ZvfsChannelInfo* pInfo = (ZvfsChannelInfo*)instanceData;
+ if( pInfo->zBuf ){
+ Tcl_Free(pInfo->zBuf);
+ inflateEnd(&pInfo->stream);
+ }
+ if( pInfo->chan ){
+ Tcl_Close(interp, pInfo->chan);
+ Tcl_DeleteExitHandler(DriverExit, pInfo);
+ }
+ Tcl_Free((char*)pInfo);
+ return TCL_OK;
}
-
/*
-** The TCL I/O system calls this function to actually read information
-** from a ZVFS file.
-*/
-static int vfsInput (
+ *----------------------------------------------------------------------
+ *
+ * DriverInput --
+ *
+ * The Tcl channel system calls this function on each read
+ * from a channel. The channel is opened into the actual
+ * archive file, but the data is read from the individual
+ * file entry inside the zip archive.
+ *
+ * Results:
+ * Number of bytes read.
+ *
+ *----------------------------------------------------------------------
+ */
+static int
+DriverInput (
ClientData instanceData, /* The channel to read from */
char *buf, /* Buffer to fill */
int toRead, /* Requested number of bytes */
int *pErrorCode /* Location of error flag */
-){
- ZvfsChannelInfo* pInfo = (ZvfsChannelInfo*) instanceData;
-
- if( toRead > pInfo->nByte ){
- toRead = pInfo->nByte;
- }
- if( toRead == 0 ){
- return 0;
- }
- if( pInfo->isCompressed ){
- int err = Z_OK;
- z_stream *stream = &pInfo->stream;
- stream->next_out = buf;
- stream->avail_out = toRead;
- while (stream->avail_out) {
- if (!stream->avail_in) {
- int len = pInfo->nByteCompr;
- if (len > COMPR_BUF_SIZE) {
- len = COMPR_BUF_SIZE;
+) {
+ ZvfsChannelInfo* pInfo = (ZvfsChannelInfo*) instanceData;
+ if( toRead > pInfo->nByte ) {
+ toRead = pInfo->nByte;
+ }
+ if( toRead == 0 ) {
+ return 0;
+ }
+ if( pInfo->isCompressed ) {
+ int err = Z_OK;
+ z_stream *stream = &pInfo->stream;
+ stream->next_out = buf;
+ stream->avail_out = toRead;
+ while (stream->avail_out) {
+ if (!stream->avail_in) {
+ int len = pInfo->nByteCompr;
+ if (len > COMPR_BUF_SIZE) {
+ len = COMPR_BUF_SIZE;
+ }
+ len = Tcl_Read(pInfo->chan, pInfo->zBuf, len);
+ pInfo->nByteCompr -= len;
+ stream->next_in = pInfo->zBuf;
+ stream->avail_in = len;
+ }
+ err = inflate(stream, Z_NO_FLUSH);
+ if (err) break;
}
- len = Tcl_Read(pInfo->chan, pInfo->zBuf, len);
- pInfo->nByteCompr -= len;
- stream->next_in = pInfo->zBuf;
- stream->avail_in = len;
- }
- err = inflate(stream, Z_NO_FLUSH);
- if (err) break;
- }
- if (err == Z_STREAM_END) {
- if ((stream->avail_out != 0)) {
- *pErrorCode = err; /* premature end */
- return -1;
- }
- }else if( err ){
- *pErrorCode = err; /* some other zlib error */
- return -1;
+ if (err == Z_STREAM_END) {
+ if ((stream->avail_out != 0)) {
+ *pErrorCode = err; /* premature end */
+ return -1;
+ }
+ } else if( err ) {
+ *pErrorCode = err; /* some other zlib error */
+ return -1;
+ }
+ } else {
+ toRead = Tcl_Read(pInfo->chan, buf, toRead);
}
- }else{
- toRead = Tcl_Read(pInfo->chan, buf, toRead);
- }
- pInfo->nByte -= toRead;
- pInfo->readSoFar += toRead;
- *pErrorCode = 0;
- return toRead;
+ pInfo->nByte -= toRead;
+ pInfo->readSoFar += toRead;
+ *pErrorCode = 0;
+ return toRead;
}
-
/*
-** Write to a ZVFS file. ZVFS files are always read-only, so this routine
-** always returns an error.
-*/
-static int vfsOutput(
+ *----------------------------------------------------------------------
+ *
+ * DriverOutput --
+ *
+ * Called to write to a file. Since this is a read-only file
+ * system, this function will always return an error.
+ *
+ * Results:
+ * Returns -1.
+ *
+ *----------------------------------------------------------------------
+ */
+static int
+DriverOutput(
ClientData instanceData, /* The channel to write to */
- char *buf, /* Data to be stored. */
+ CONST char *buf, /* Data to be stored. */
int toWrite, /* Number of bytes to write. */
int *pErrorCode /* Location of error flag. */
-){
- *pErrorCode = EINVAL;
- return -1;
+) {
+ *pErrorCode = EINVAL;
+ return -1;
}
-
/*
-** Move the file pointer so that the next byte read will be "offset".
-*/
-static int vfsSeek(
+ *----------------------------------------------------------------------
+ *
+ * DriverSeek --
+ *
+ * Seek along the open channel to another point.
+ *
+ * Results:
+ * Offset into the file.
+ *
+ *----------------------------------------------------------------------
+ */
+static int
+DriverSeek(
ClientData instanceData, /* The file structure */
long offset, /* Offset to seek to */
int mode, /* One of SEEK_CUR, SEEK_SET or SEEK_END */
int *pErrorCode /* Write the error code here */
){
- ZvfsChannelInfo* pInfo = (ZvfsChannelInfo*) instanceData;
-
- switch( mode ){
- case SEEK_CUR: {
- offset += pInfo->readSoFar;
- break;
- }
- case SEEK_END: {
- offset += pInfo->readSoFar + pInfo->nByte;
- break;
- }
- default: {
- /* Do nothing */
- break;
- }
- }
- if( !pInfo->isCompressed ){
- Tcl_Seek(pInfo->chan, offset + pInfo->startOfData, SEEK_SET);
- }else{
- if( offset<pInfo->readSoFar ){
- z_stream *stream = &pInfo->stream;
- inflateEnd(stream);
- stream->zalloc = (alloc_func)0;
- stream->zfree = (free_func)0;
- stream->opaque = (voidpf)0;
- stream->avail_in = 2;
- stream->next_in = pInfo->zBuf;
- pInfo->zBuf[0] = 0x78;
- pInfo->zBuf[1] = 0x01;
- inflateInit(&pInfo->stream);
- Tcl_Seek(pInfo->chan, pInfo->startOfData, SEEK_SET);
- pInfo->nByte += pInfo->readSoFar;
- pInfo->nByteCompr = pInfo->nData;
- pInfo->readSoFar = 0;
- }
- while( pInfo->readSoFar < offset ){
- int toRead, errCode;
- char zDiscard[100];
- toRead = offset - pInfo->readSoFar;
- if( toRead>sizeof(zDiscard) ) toRead = sizeof(zDiscard);
- vfsInput(instanceData, zDiscard, toRead, &errCode);
- }
- }
- return pInfo->readSoFar;
+ ZvfsChannelInfo* pInfo = (ZvfsChannelInfo*) instanceData;
+ switch( mode ) {
+ case SEEK_CUR:
+ offset += pInfo->readSoFar;
+ break;
+ case SEEK_END:
+ offset += pInfo->readSoFar + pInfo->nByte;
+ break;
+ default:
+ /* Do nothing */
+ break;
+ }
+ if( !pInfo->isCompressed ){
+ /* dont seek behind end of data */
+ if (pInfo->nData < (unsigned long)offset) {
+ return -1;
+ }
+ /* do the job, save and check the result */
+ offset = Tcl_Seek(pInfo->chan, offset + pInfo->startOfData, SEEK_SET);
+ if (offset == -1) {
+ return -1;
+ }
+ /* adjust the counters (use real offset) */
+ pInfo->readSoFar = offset - pInfo->startOfData;
+ pInfo->nByte = pInfo->nData - pInfo->readSoFar;
+ } else {
+ if( offset<pInfo->readSoFar ) {
+ z_stream *stream = &pInfo->stream;
+ inflateEnd(stream);
+ stream->zalloc = (alloc_func)0;
+ stream->zfree = (free_func)0;
+ stream->opaque = (voidpf)0;
+ stream->avail_in = 2;
+ stream->next_in = pInfo->zBuf;
+ pInfo->zBuf[0] = 0x78;
+ pInfo->zBuf[1] = 0x01;
+ inflateInit(&pInfo->stream);
+ Tcl_Seek(pInfo->chan, pInfo->startOfData, SEEK_SET);
+ pInfo->nByte += pInfo->readSoFar;
+ pInfo->nByteCompr = pInfo->nData;
+ pInfo->readSoFar = 0;
+ }
+ while( pInfo->readSoFar < offset )
+ {
+ int toRead, errCode;
+ char zDiscard[100];
+ toRead = offset - pInfo->readSoFar;
+ if( toRead>sizeof(zDiscard) ) toRead = sizeof(zDiscard);
+ DriverInput(instanceData, zDiscard, toRead, &errCode);
+ }
+ }
+ return pInfo->readSoFar;
}
-
/*
-** Handle events on the channel. ZVFS files do not generate events,
-** so this is a no-op.
-*/
-static void vfsWatchChannel(
+ *----------------------------------------------------------------------
+ *
+ * DriverWatch --
+ *
+ * Called to handle events on the channel. Since zvfs files
+ * don't generate events, this is a no-op.
+ *
+ * Results:
+ * None
+ *
+ *----------------------------------------------------------------------
+ */
+static void
+DriverWatch(
ClientData instanceData, /* Channel to watch */
int mask /* Events of interest */
-){
- return;
+) {
+ return;
}
-
/*
-** Called to retrieve the underlying file handle for this ZVFS file.
-** As the ZVFS file has no underlying file handle, this is a no-op.
-*/
-static int vfsGetFile(
+ *----------------------------------------------------------------------
+ *
+ * DriverGetHandle --
+ *
+ * Retrieve a device-specific handle from the given channel.
+ * Since we don't have a device-specific handle, this is a no-op.
+ *
+ * Results:
+ * Returns TCL_ERROR.
+ *
+ *----------------------------------------------------------------------
+ */
+static int
+DriverGetHandle(
ClientData instanceData, /* Channel to query */
int direction, /* Direction of interest */
ClientData* handlePtr /* Space to the handle into */
-){
- return TCL_ERROR;
+) {
+ return TCL_ERROR;
}
-
/*
-** This structure describes the channel type structure for
-** access to the ZVFS.
-*/
-static Tcl_ChannelType vfsChannelType = {
- "vfs", /* Type name. */
- NULL, /* Set blocking/nonblocking behaviour. NULL'able */
- vfsClose, /* Close channel, clean instance data */
- vfsInput, /* Handle read request */
- vfsOutput, /* Handle write request */
- vfsSeek, /* Move location of access point. NULL'able */
- NULL, /* Set options. NULL'able */
- NULL, /* Get options. NULL'able */
- vfsWatchChannel, /* Initialize notifier */
- vfsGetFile /* Get OS handle from the channel. */
-};
+ *----------------------------------------------------------------------
+ *
+ * PathInFilesystem --
+ *
+ * Part of the "zvfs" Tcl_Filesystem.
+ * Check to see if the given path is part of our filesystem.
+ * We check the file hash table for the path, and if we find
+ * it, set clientDataPtr to the ZvfsFile pointer so that Tcl
+ * will cache it for later.
+ *
+ * Results:
+ * TCL_OK on success, or -1 on failure
+ *
+ *----------------------------------------------------------------------
+ */
+static int
+PathInFilesystem( Tcl_Obj *pathPtr, ClientData *clientDataPtr )
+{
+ ZvfsFile *pFile = ZvfsLookup(pathPtr);
+ unsigned char zBuf[50];
+ int chan, bytes_read;
+ if( !pFile ) {
+ return -1;
+ }
+ if(!(chan = open(Tcl_GetString(pFile->pArchive->zName),
+ O_RDONLY))) {
+ return -1;
+ }
-/*
-** This routine attempts to do an open of a file. Check to see
-** if the file is located in the ZVFS. If so, then open a channel
-** for reading the file. If not, return NULL.
-*/
-static Tcl_Channel ZvfsFileOpen(
- Tcl_Interp *interp, /* The TCL interpreter doing the open */
- char *zFilename, /* Name of the file to open */
- char *modeString, /* Mode string for the open (ignored) */
- int permissions /* Permissions for a newly created file (ignored) */
-){
- ZvfsFile *pFile;
- ZvfsChannelInfo *pInfo;
- Tcl_Channel chan;
- static int count = 1;
- char zName[50];
- unsigned char zBuf[50];
+ lseek(chan, pFile->iOffset, SEEK_SET);
+ bytes_read = read(chan, zBuf, 4);
+ close( chan );
+ if( bytes_read < 4 ||
+ memcmp(zBuf, "\120\113\03\04", 4) ){
+ return -1;
+ }
- if (DEBUG)
- printf("ZvfsFileOpen: ");
- pFile = ZvfsLookup(zFilename);
- if( pFile==0 ) return NULL;
- chan = Tcl_OpenFileChannel(interp, pFile->pArchive->zName, "r", 0);
- if( chan==0 ){
- return 0;
- }
- if( Tcl_SetChannelOption(interp, chan, "-translation", "binary")
- || Tcl_SetChannelOption(interp, chan, "-encoding", "binary")
- ){
- /* this should never happen */
- Tcl_Close(0, chan);
+ *clientDataPtr = DupInternalRep((ClientData)pFile);
+ return TCL_OK;
+}
+/*
+ *----------------------------------------------------------------------
+ *
+ * DupInternalRep --
+ *
+ * Part of the "zvfs" Tcl_Filesystem.
+ * Duplicate the ZvfsFile "native" rep of a path.
+ *
+ * Results:
+ * Returns clientData, with refcount incremented.
+ *
+ *----------------------------------------------------------------------
+ */
+static ClientData
+DupInternalRep( ClientData clientData )
+{
+ ZvfsFile *pFile = (ZvfsFile *)clientData;
+ pFile->refCount++;
+ return (ClientData)pFile;
+}
+/*
+ *----------------------------------------------------------------------
+ *
+ * FreeInternalRep --
+ *
+ * Part of the "zvfs" Tcl_Filesystem.
+ * Free one reference to the ZvfsFile "native" rep of a path.
+ * When all references are gone, free the struct.
+ *
+ * Side effects:
+ * May free memory.
+ *
+ *----------------------------------------------------------------------
+ */
+static void
+FreeInternalRep( ClientData clientData )
+{
+ ZvfsFile *pFile = (ZvfsFile *)clientData;
+ if (--pFile->refCount <= 0) {
+ if( pFile->isdir ) {
+ /* Delete the hash table containing the children
+ * of this directory. We don't need to free the
+ * data for each entry in the table because they're
+ * just pointers to the ZvfsFiles, and those will
+ * be freed below.
+ */
+ Tcl_DeleteHashTable( &pFile->children );
+ }
+ Tcl_DecrRefCount(pFile->zName);
+ Tcl_Free((char *)pFile);
+ }
+}
+/*
+ *----------------------------------------------------------------------
+ *
+ * InternalToNormalized --
+ *
+ * Part of the "zvfs" Tcl_Filesystem.
+ * From a ZvfsFile representation, produce the path string rep.
+ *
+ * Results:
+ * Returns a Tcl_Obj holding the string rep.
+ *
+ *----------------------------------------------------------------------
+ */
+static Tcl_Obj *
+InternalToNormalized( ClientData clientData )
+{
+ ZvfsFile *pFile = (ZvfsFile *)clientData;
+ if( !pFile->parent ) {
+ return Tcl_DuplicateObj( pFile->zName );
+ } else {
+ return Tcl_FSJoinToPath( pFile->parent->zName, 1, &pFile->zName );
+ }
+}
+/*
+ *----------------------------------------------------------------------
+ *
+ * FilesystemPathType --
+ *
+ * Part of the "zvfs" Tcl_Filesystem.
+ * Used for informational purposes only. Return a Tcl_Obj
+ * which describes the "type" of path this is. For our
+ * little filesystem, they're all "zip".
+ *
+ * Results:
+ * Tcl_Obj with 0 refCount
+ *
+ *----------------------------------------------------------------------
+ */
+static Tcl_Obj *
+FilesystemPathType( Tcl_Obj *pathPtr )
+{
+ return Tcl_NewStringObj( "zip", -1 );
+}
+/*
+ *----------------------------------------------------------------------
+ *
+ * FileSystemSeparator --
+ *
+ * Part of the "zvfs" Tcl_Filesystem.
+ * Return a Tcl_Obj describing the separator character for
+ * our filesystem. We like things the old-fashioned way,
+ * so we'll just use /.
+ *
+ * Results:
+ * Tcl_Obj with 0 refCount
+ *
+ *----------------------------------------------------------------------
+ */
+static Tcl_Obj *
+FilesystemSeparator( Tcl_Obj *pathPtr )
+{
+ return Tcl_NewStringObj( "/", -1 );
+}
+/*
+ *----------------------------------------------------------------------
+ *
+ * Stat --
+ *
+ * Part of the "zvfs" Tcl_Filesystem.
+ * Does a stat() system call for a zvfs file. Fill the stat
+ * buf with as much information as we have.
+ *
+ * Results:
+ * 0 on success, -1 on failure.
+ *
+ *----------------------------------------------------------------------
+ */
+static int
+Stat( Tcl_Obj *pathPtr, Tcl_StatBuf *buf )
+{
+ ZvfsFile *pFile;
+ if( !(pFile = GetZvfsFile(pathPtr)) ) {
+ return -1;
+ }
+ memset(buf, 0, sizeof(*buf));
+ if (pFile->isdir) {
+ buf->st_mode = 040555;
+ } else {
+ buf->st_mode = 0100555;
+ }
+ buf->st_size = pFile->nByte;
+ buf->st_mtime = pFile->timestamp;
+ buf->st_ctime = pFile->timestamp;
+ buf->st_atime = pFile->timestamp;
return 0;
- }
- Tcl_Seek(chan, pFile->iOffset, SEEK_SET);
- Tcl_Read(chan, zBuf, 30);
- if( memcmp(zBuf, "\120\113\03\04", 4) ){
- if( interp ){
- Tcl_AppendResult(interp, "local header mismatch: ", NULL);
- }
- Tcl_Close(interp, chan);
+}
+/*
+ *----------------------------------------------------------------------
+ *
+ * Access --
+ *
+ * Part of the "zvfs" Tcl_Filesystem.
+ * Does an access() system call for a zvfs file.
+ *
+ * Results:
+ * 0 on success, -1 on failure.
+ *
+ *----------------------------------------------------------------------
+ */
+static int
+Access( Tcl_Obj *pathPtr, int mode )
+{
+ if( mode & 3 || !GetZvfsFile(pathPtr) ) return -1;
return 0;
- }
- pInfo = (ZvfsChannelInfo*)Tcl_Alloc( sizeof(*pInfo) );
- pInfo->chan = chan;
- Tcl_CreateExitHandler(vfsExit, pInfo);
- pInfo->isCompressed = INT16(zBuf, 8);
- if( pInfo->isCompressed ){
- z_stream *stream = &pInfo->stream;
- pInfo->zBuf = Tcl_Alloc(COMPR_BUF_SIZE);
- stream->zalloc = (alloc_func)0;
- stream->zfree = (free_func)0;
- stream->opaque = (voidpf)0;
- stream->avail_in = 2;
- stream->next_in = pInfo->zBuf;
- pInfo->zBuf[0] = 0x78;
- pInfo->zBuf[1] = 0x01;
- inflateInit(&pInfo->stream);
- }else{
- pInfo->zBuf = 0;
- }
- pInfo->nByte = INT32(zBuf,22);
- pInfo->nByteCompr = pInfo->nData = INT32(zBuf,18);
- pInfo->readSoFar = 0;
- Tcl_Seek(chan, INT16(zBuf,26)+INT16(zBuf,28), SEEK_CUR);
- pInfo->startOfData = Tcl_Tell(chan);
- sprintf(zName,"vfs_%x_%x",((int)pFile)>>12,count++);
- chan = Tcl_CreateChannel(&vfsChannelType, zName,
- (ClientData)pInfo, TCL_READABLE);
- return chan;
}
-
/*
-** This routine does a stat() system call for a ZVFS file.
-*/
-static int ZvfsFileStat(char *path, struct stat *buf){
- ZvfsFile *pFile;
-
- if (DEBUG)
- printf("ZvfsFileStat: ");
- pFile = ZvfsLookup(path);
- if( pFile==0 ){
- return -1;
- }
- memset(buf, 0, sizeof(*buf));
- buf->st_mode = 0400;
- buf->st_size = pFile->nByte;
- return 0;
+ *----------------------------------------------------------------------
+ *
+ * OpenFileChannel --
+ *
+ * Part of the "zvfs" Tcl_Filesystem.
+ * Called when Tcl wants to open a file inside a zvfs file system.
+ * We actually open the zip file back up and seek to the offset
+ * of the given file. The channel driver will take care of the
+ * rest.
+ *
+ * Results:
+ * New channel on success, NULL on failure.
+ *
+ *----------------------------------------------------------------------
+ */
+static Tcl_Channel
+OpenFileChannel( Tcl_Interp *interp, Tcl_Obj *pathPtr,
+ int mode, int permissions )
+{
+ ZvfsFile *pFile;
+ ZvfsChannelInfo *pInfo;
+ Tcl_Channel chan;
+ static int count = 1;
+ char zName[50];
+ unsigned char zBuf[50];
+ if( !(pFile = GetZvfsFile(pathPtr)) ) {
+ return NULL;
+ }
+ if(!(chan = Tcl_OpenFileChannel(interp,
+ Tcl_GetString(pFile->pArchive->zName), "r", 0))) {
+ return NULL;
+ }
+ if( Tcl_SetChannelOption(interp, chan, "-translation", "binary") ) {
+ /* this should never happen */
+ Tcl_Close( NULL, chan );
+ return NULL;
+ }
+ Tcl_Seek(chan, pFile->iOffset, SEEK_SET);
+ Tcl_Read(chan, zBuf, 30);
+ if( memcmp(zBuf, "\120\113\03\04", 4) ){
+ if( interp ) {
+ Tcl_SetStringObj( Tcl_GetObjResult(interp),
+ "bad central file record", -1 );
+ }
+ Tcl_Close( interp, chan );
+ return NULL;
+ }
+ pInfo = (ZvfsChannelInfo*)Tcl_Alloc( sizeof(*pInfo) );
+ pInfo->chan = chan;
+ Tcl_CreateExitHandler(DriverExit, pInfo);
+ pInfo->isCompressed = INT16(zBuf, 8);
+ if( pInfo->isCompressed ) {
+ z_stream *stream = &pInfo->stream;
+ pInfo->zBuf = Tcl_Alloc(COMPR_BUF_SIZE);
+ stream->zalloc = (alloc_func)0;
+ stream->zfree = (free_func)0;
+ stream->opaque = (voidpf)0;
+ stream->avail_in = 2;
+ stream->next_in = pInfo->zBuf;
+ pInfo->zBuf[0] = 0x78;
+ pInfo->zBuf[1] = 0x01;
+ inflateInit(&pInfo->stream);
+ } else {
+ pInfo->zBuf = 0;
+ }
+ pInfo->nByte = INT32(zBuf,22);
+ pInfo->nByteCompr = pInfo->nData = INT32(zBuf,18);
+ pInfo->readSoFar = 0;
+ Tcl_Seek( chan, INT16(zBuf,26) + INT16(zBuf,28), SEEK_CUR );
+ pInfo->startOfData = Tcl_Tell(chan);
+ sprintf( zName, "zvfs%x%x", ((int)pFile)>>12, count++ );
+ return Tcl_CreateChannel( &vfsChannelType, zName,
+ (ClientData)pInfo, TCL_READABLE );
}
-
/*
-** This routine does an access() system call for a ZVFS file.
-*/
-static int ZvfsFileAccess(char *path, int mode){
- ZvfsFile *pFile;
-
- if( mode & 3 ){
- return -1;
- }
- if (DEBUG)
- printf("ZvfsFileAccess: ");
- pFile = ZvfsLookup(path);
- if( pFile==0 ){
- return -1;
- }
- return 0;
+ *----------------------------------------------------------------------
+ *
+ * MatchInDirectory --
+ *
+ * Part of the "zvfs" Tcl_Filesystem.
+ * Called when Tcl is globbing around through the filesystem.
+ * This function can be called when Tcl is looking for mount
+ * points or when it is looking for files within a mount point
+ * that it has already determined belongs to us.
+ *
+ * Any matching file in our filesystem is appended to the
+ * result pointer.
+ *
+ * Results:
+ * Standard Tcl result
+ *
+ *----------------------------------------------------------------------
+ */
+/* Function to process a 'MatchInDirectory()'.
+ * If not implemented, then glob and recursive
+ * copy functionality will be lacking in the filesystem.
+ */
+static int
+MatchInDirectory(
+ Tcl_Interp* interp,
+ Tcl_Obj *result,
+ Tcl_Obj *pathPtr,
+ CONST char *pattern,
+ Tcl_GlobTypeData *types
+) {
+ ZvfsFile *pFile;
+ Tcl_HashEntry *pEntry;
+ Tcl_HashSearch sSearch;
+ if( types && types->type & TCL_GLOB_TYPE_MOUNT ) {
+ /* Tcl is looking for a list of our mount points that
+ * match the given pattern. This is so that Tcl can
+ * append vfs mounted directories to a list of actual
+ * filesystem directories.
+ */
+ char *path, *zPattern;
+ ZvfsArchive *pArchive;
+ Tcl_Obj *patternObj = Tcl_NewObj();
+ path = AbsolutePath( Tcl_GetString(pathPtr) );
+ Tcl_AppendStringsToObj( patternObj, path, "/", pattern, (char *)NULL );
+ Tcl_Free(path);
+ zPattern = Tcl_GetString( patternObj );
+ for( pEntry = Tcl_FirstHashEntry( &local.archiveHash, &sSearch );
+ pEntry; pEntry = Tcl_NextHashEntry( &sSearch ) )
+ {
+ pArchive = Tcl_GetHashValue(pEntry);
+ if( Tcl_StringCaseMatch( Tcl_GetString(pArchive->zMountPoint),
+ zPattern, NOCASE_PATHS ) ) {
+ Tcl_ListObjAppendElement( NULL, result,
+ Tcl_DuplicateObj(pArchive->zMountPoint) );
+ }
+ }
+ Tcl_DecrRefCount(patternObj);
+ return TCL_OK;
+ }
+ if( !(pFile = GetZvfsFile(pathPtr)) ) {
+ Tcl_SetStringObj( Tcl_GetObjResult(interp), "stale file handle", -1 );
+ return TCL_ERROR;
+ }
+ if( !pattern ) {
+ /* If pattern is null, Tcl is actually just checking to
+ * see if this file exists in our filesystem. Check to
+ * make sure the path matches any type data and then
+ * append it to the result and return.
+ */
+ if( ZvfsFileMatchesType( pFile, types ) ) {
+ Tcl_ListObjAppendElement( NULL, result, pathPtr );
+ }
+ return TCL_OK;
+ }
+ /* We've determined that the requested path is in our filesystem,
+ * so now we want to walk through the children of the directory
+ * and find any that match the given pattern and type. Any we
+ * find will be appended to the result.
+ */
+ for( pEntry = Tcl_FirstHashEntry(&pFile->children, &sSearch);
+ pEntry; pEntry = Tcl_NextHashEntry(&sSearch) )
+ {
+ char *zName;
+ pFile = Tcl_GetHashValue(pEntry);
+ zName = Tcl_GetString(pFile->zName);
+ if( ZvfsFileMatchesType( pFile, types )
+ && Tcl_StringCaseMatch(zName, pattern, NOCASE_PATHS) ) {
+ Tcl_ListObjAppendElement( NULL, result,
+ Tcl_FSJoinToPath(pathPtr, 1, &pFile->zName ) );
+ }
+ }
+ return TCL_OK;
}
-
/*
-** This TCL procedure can be used to copy a file. The built-in
-** "file copy" command of TCL bypasses the I/O system and does not
-** work with zvfs. You have to use a procedure like the following
-** instead.
-*/
-static char zFileCopy[] =
-"proc zvfs::filecopy {from to {outtype binary}} {\n"
-" set f [open $from r]\n"
-" if {[catch {\n"
-" fconfigure $f -translation binary\n"
-" set t [open $to w]\n"
-" } msg]} {\n"
-" close $f\n"
-" error $msg\n"
-" }\n"
-" if {[catch {\n"
-" fconfigure $t -translation $outtype\n"
-" set size [file size $from]\n"
-" for {set i 0} {$i<$size} {incr i 40960} {\n"
-" puts -nonewline $t [read $f 40960]\n"
-" }\n"
-" } msg]} {\n"
-" close $f\n"
-" close $t\n"
-" error $msg\n"
-" }\n"
-" close $f\n"
-" close $t\n"
-"}\n"
-;
-
-
-void (*Zvfs_PostInit)(Tcl_Interp *)=0;
-
+ *----------------------------------------------------------------------
+ *
+ * ListVolumes --
+ *
+ * Part of the "zvfs" Tcl_Filesystem.
+ * Called when Tcl is looking for a list of open volumes
+ * for our filesystem. The mountpoint for each open archive
+ * is appended to a list object.
+ *
+ * Results:
+ * A Tcl_Obj with 0 refCount
+ *
+ *----------------------------------------------------------------------
+ */
+static Tcl_Obj *
+ListVolumes(void)
+{
+ Tcl_HashEntry *pEntry; /* Hash table entry */
+ Tcl_HashSearch zSearch; /* Search all mount points */
+ ZvfsArchive *pArchive; /* The ZIP archive being mounted */
+ Tcl_Obj *pVols = Tcl_NewObj();
+
+ for( pEntry = Tcl_FirstHashEntry(&local.archiveHash,&zSearch);
+ pEntry; pEntry = Tcl_NextHashEntry(&zSearch) )
+ {
+ pArchive = Tcl_GetHashValue(pEntry);
+ Tcl_ListObjAppendElement( NULL, pVols,
+ Tcl_DuplicateObj(pArchive->zMountPoint) );
+ }
+ return pVols;
+}
/*
-** Initialize the ZVFS system.
-*/
-int Zvfs_doInit(Tcl_Interp *interp, int safe){
-#ifdef USE_TCL_STUBS
- if( Tcl_InitStubs(interp,"8.0",0)==0 ){
+ *----------------------------------------------------------------------
+ *
+ * FileAttrStrings --
+ *
+ * Part of the "zvfs" Tcl_Filesystem.
+ * Return an array of strings for all of the possible
+ * attributes for a file in zvfs.
+ *
+ * Results:
+ * Pointer to ZvfsAttrs
+ *
+ *----------------------------------------------------------------------
+ */
+static CONST char **
+FileAttrStrings( Tcl_Obj *pathPtr, Tcl_Obj** objPtrRef )
+{
+ return ZvfsAttrs;
+}
+/*
+ *----------------------------------------------------------------------
+ *
+ * FileAttrsGet --
+ *
+ * Part of the "zvfs" Tcl_Filesystem.
+ * Called for a "file attributes" command from Tcl
+ * to return the attributes for a file in our filesystem.
+ *
+ * objPtrRef will point to a 0 refCount Tcl_Obj on success.
+ *
+ * Results:
+ * Standard Tcl result
+ *
+ *----------------------------------------------------------------------
+ */
+static int
+FileAttrsGet( Tcl_Interp *interp, int index,
+ Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef )
+{
+ char *zFilename;
+ ZvfsFile *pFile;
+ zFilename = Tcl_GetString(pathPtr);
+ if( !(pFile = GetZvfsFile(pathPtr)) ) {
+ return TCL_ERROR;
+ }
+ switch(index) {
+ case ZVFS_ATTR_ARCHIVE:
+ *objPtrRef= Tcl_DuplicateObj(pFile->pArchive->zName);
+ return TCL_OK;
+ case ZVFS_ATTR_COMPSIZE:
+ *objPtrRef=Tcl_NewIntObj(pFile->nByteCompr);
+ return TCL_OK;
+ case ZVFS_ATTR_CRC:
+ *objPtrRef=Tcl_NewIntObj(pFile->iCRC);
+ return TCL_OK;
+ case ZVFS_ATTR_MOUNT:
+ *objPtrRef= Tcl_DuplicateObj(pFile->pArchive->zMountPoint);
+ return TCL_OK;
+ case ZVFS_ATTR_OFFSET:
+ *objPtrRef= Tcl_NewIntObj(pFile->nByte);
+ return TCL_OK;
+ case ZVFS_ATTR_UNCOMPSIZE:
+ *objPtrRef= Tcl_NewIntObj(pFile->nByte);
+ return TCL_OK;
+ default:
+ return TCL_ERROR;
+ }
+ return TCL_OK;
+}
+/*
+ *----------------------------------------------------------------------
+ *
+ * FileAttrsSet --
+ *
+ * Part of the "zvfs" Tcl_Filesystem.
+ * Called to set the value of an attribute for the
+ * given file. Since we're a read-only filesystem, this
+ * always returns an error.
+ *
+ * Results:
+ * Returns TCL_ERROR
+ *
+ *----------------------------------------------------------------------
+ */
+static int
+FileAttrsSet( Tcl_Interp *interp, int index,
+ Tcl_Obj *pathPtr, Tcl_Obj *objPtr )
+{
return TCL_ERROR;
- }
-#endif
- Tcl_PkgProvide(interp, "zvfs", "1.0");
- if (!safe) {
- Tcl_CreateCommand(interp, "zvfs::mount", ZvfsMountCmd, 0, 0);
- Tcl_CreateCommand(interp, "zvfs::unmount", ZvfsUnmountCmd, 0, 0);
- }
- Tcl_CreateObjCommand(interp, "zvfs::exists", ZvfsExistsObjCmd, 0, 0);
- Tcl_CreateObjCommand(interp, "zvfs::info", ZvfsInfoObjCmd, 0, 0);
- Tcl_CreateObjCommand(interp, "zvfs::list", ZvfsListObjCmd, 0, 0);
- Tcl_GlobalEval(interp, zFileCopy);
- if( !local.isInit ){
- /* One-time initialization of the ZVFS */
- extern void TclAccessInsertProc();
- extern void TclStatInsertProc();
- extern void TclOpenFileChannelInsertProc();
- Tcl_InitHashTable(&local.fileHash, TCL_STRING_KEYS);
- Tcl_InitHashTable(&local.archiveHash, TCL_STRING_KEYS);
- TclAccessInsertProc(ZvfsFileAccess);
- TclStatInsertProc(ZvfsFileStat);
- TclOpenFileChannelInsertProc(ZvfsFileOpen);
- local.isInit = 1;
- local.interp = interp;
- }
- if (Zvfs_PostInit) Zvfs_PostInit(interp);
- return TCL_OK;
}
-
-int Zvfs_Init(Tcl_Interp *interp){
- return Zvfs_doInit(interp,0);
+/*
+ *----------------------------------------------------------------------
+ *
+ * Chdir --
+ *
+ * Part of the "zvfs" Tcl_Filesystem.
+ * Handles a chdir() call for the filesystem. Tcl has
+ * already determined that the directory belongs to us,
+ * so we just need to check and make sure that the path
+ * is actually a directory in our filesystem and not a
+ * regular file.
+ *
+ * Results:
+ * 0 on success, -1 on failure.
+ *
+ *----------------------------------------------------------------------
+ */
+static int
+Chdir( Tcl_Obj *pathPtr )
+{
+ ZvfsFile *zFile = GetZvfsFile(pathPtr);
+ if( !zFile || !zFile->isdir ) return -1;
+ return 0;
}
-
-int Zvfs_SafeInit(Tcl_Interp *interp){
- return Zvfs_doInit(interp,1);
+/*
+ *----------------------------------------------------------------------
+ *
+ * MountObjCmd --
+ *
+ * This function implements the [zvfs::mount] command.
+ *
+ * zvfs::mount ?zipFile? ?mountPoint?
+ *
+ * Creates a new mount point to the given zip archive.
+ * All files in the zip archive will be added to the
+ * virtual filesystem and be available to Tcl as regular
+ * files and directories.
+ *
+ * Results:
+ * Standard Tcl result
+ *
+ *----------------------------------------------------------------------
+ */
+static int
+MountObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *CONST objv[]
+) {
+ char *zipFile = NULL, *mountPoint = NULL;
+ if( objc > 3 ) {
+ Tcl_WrongNumArgs( interp, 1, objv, "?zipFile? ?mountPoint?" );
+ return TCL_ERROR;
+ }
+ if( objc > 1 ) {
+ zipFile = Tcl_GetString( objv[1] );
+ }
+ if( objc > 2 ) {
+ mountPoint = Tcl_GetString( objv[2] );
+ }
+ return Zvfs_Mount( interp, zipFile, mountPoint );
+}
+/*
+ *----------------------------------------------------------------------
+ *
+ * UnmountObjCmd --
+ *
+ * This function implements the [zvfs::unmount] command.
+ *
+ * zvfs::unmount mountPoint
+ *
+ * Unmount the given mountPoint if it is mounted in our
+ * filesystem.
+ *
+ * Results:
+ * 0 on success, -1 on failure.
+ *
+ *----------------------------------------------------------------------
+ */
+static int
+UnmountObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *CONST objv[]
+) {
+ if( objc != 2 ) {
+ Tcl_WrongNumArgs( interp, objc, objv, "mountPoint" );
+ return TCL_ERROR;
+ }
+ return Zvfs_Unmount( interp, Tcl_GetString(objv[1]) );
+}
+/*
+ *----------------------------------------------------------------------
+ *
+ * Zvfs_Init, Zvfs_SafeInit --
+ *
+ * Initialize the zvfs package.
+ *
+ * Safe interpreters do not receive the ability to mount and
+ * unmount zip files.
+ *
+ * Results:
+ * Standard Tcl result
+ *
+ *----------------------------------------------------------------------
+ */
+int
+Zvfs_SafeInit( Tcl_Interp *interp )
+{
+#ifdef USE_TCL_STUBS
+ if( Tcl_InitStubs( interp, "8.0", 0 ) == TCL_ERROR ) return TCL_ERROR;
+#endif
+ if( !local.isInit ) {
+ /* Register the filesystem and initialize the hash tables. */
+ Tcl_FSRegister( 0, &zvfsFilesystem );
+ Tcl_InitHashTable( &local.fileHash, TCL_STRING_KEYS );
+ Tcl_InitHashTable( &local.archiveHash, TCL_STRING_KEYS );
+ local.isInit = 1;
+ }
+ Tcl_PkgProvide( interp, "zvfs", "1.0" );
+ return TCL_OK;
+}
+int
+Zvfs_Init( Tcl_Interp *interp )
+{
+ if( Zvfs_SafeInit( interp ) == TCL_ERROR ) return TCL_ERROR;
+ if( !Tcl_IsSafe(interp) ) {
+ Tcl_CreateObjCommand(interp, "zvfs::mount", MountObjCmd, 0, 0);
+ Tcl_CreateObjCommand(interp, "zvfs::unmount", UnmountObjCmd, 0, 0);
+ }
+ return TCL_OK;
}
diff --git a/saotk/util/tkCanvPsScaled.c b/saotk/util/tkCanvPsScaled.c
new file mode 100644
index 0000000..6214c20
--- /dev/null
+++ b/saotk/util/tkCanvPsScaled.c
@@ -0,0 +1,686 @@
+/*
+ * tkCanvPs.c --
+ *
+ * This module provides Postscript output support for canvases, including
+ * the "postscript" widget command plus a few utility functions used for
+ * generating Postscript.
+ *
+ * Copyright (c) 1991-1994 The Regents of the University of California.
+ * Copyright (c) 1994-1997 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: tkCanvPs.c,v 1.2 2011/07/26 21:07:34 joye Exp $
+ */
+/*
+ * This contains an override for saotk that allows scaling */
+
+#include "tkInt.h"
+#include "tkCanvas.h"
+
+/*** waj ***/
+float psScale =1;
+/*** waj ***/
+
+/*
+ * See tkCanvas.h for key data structures used to implement canvases.
+ */
+
+
+/*
+ * One of the following structures is created to keep track of Postscript
+ * output being generated. It consists mostly of information provided on the
+ * widget command line.
+ */
+
+typedef struct TkPostscriptInfo {
+ Tk_Window tkwin; /* The canvas being printed. */
+ int x, y, width, height; /* Area to print, in canvas pixel
+ * coordinates. */
+ int x2, y2; /* x+width and y+height. */
+ char *pageXString; /* String value of "-pagex" option or NULL. */
+ char *pageYString; /* String value of "-pagey" option or NULL. */
+ double pageX, pageY; /* Postscript coordinates (in points)
+ * corresponding to pageXString and
+ * pageYString. Don't forget that y-values
+ * grow upwards for Postscript! */
+ char *pageWidthString; /* Printed width of output. */
+ char *pageHeightString; /* Printed height of output. */
+ double scale; /* Scale factor for conversion: each pixel
+ * maps into this many points. */
+ Tk_Anchor pageAnchor; /* How to anchor bbox on Postscript page. */
+ int rotate; /* Non-zero means output should be rotated on
+ * page (landscape mode). */
+ char *fontVar; /* If non-NULL, gives name of global variable
+ * containing font mapping information.
+ * Malloc'ed. */
+ char *colorVar; /* If non-NULL, give name of global variable
+ * containing color mapping information.
+ * Malloc'ed. */
+ char *colorMode; /* Mode for handling colors: "monochrome",
+ * "gray", or "color". Malloc'ed. */
+ int colorLevel; /* Numeric value corresponding to colorMode: 0
+ * for mono, 1 for gray, 2 for color. */
+ char *fileName; /* Name of file in which to write Postscript;
+ * NULL means return Postscript info as
+ * result. Malloc'ed. */
+ char *channelName; /* If -channel is specified, the name of the
+ * channel to use. */
+ Tcl_Channel chan; /* Open channel corresponding to fileName. */
+ Tcl_HashTable fontTable; /* Hash table containing names of all font
+ * families used in output. The hash table
+ * values are not used. */
+ int prepass; /* Non-zero means that we're currently in the
+ * pre-pass that collects font information, so
+ * the Postscript generated isn't relevant. */
+ int prolog; /* Non-zero means output should contain the
+ * prolog definitions in the header. */
+} TkPostscriptInfo;
+
+/*
+ * The table below provides a template that's used to process arguments to the
+ * canvas "postscript" command and fill in TkPostscriptInfo structures.
+ */
+
+static Tk_ConfigSpec configSpecs[] = {
+ {TK_CONFIG_STRING, "-colormap", NULL, NULL,
+ "", Tk_Offset(TkPostscriptInfo, colorVar), 0},
+ {TK_CONFIG_STRING, "-colormode", NULL, NULL,
+ "", Tk_Offset(TkPostscriptInfo, colorMode), 0},
+ {TK_CONFIG_STRING, "-file", NULL, NULL,
+ "", Tk_Offset(TkPostscriptInfo, fileName), 0},
+ {TK_CONFIG_STRING, "-channel", NULL, NULL,
+ "", Tk_Offset(TkPostscriptInfo, channelName), 0},
+ {TK_CONFIG_STRING, "-fontmap", NULL, NULL,
+ "", Tk_Offset(TkPostscriptInfo, fontVar), 0},
+ {TK_CONFIG_PIXELS, "-height", NULL, NULL,
+ "", Tk_Offset(TkPostscriptInfo, height), 0},
+ {TK_CONFIG_ANCHOR, "-pageanchor", NULL, NULL,
+ "", Tk_Offset(TkPostscriptInfo, pageAnchor), 0},
+ {TK_CONFIG_STRING, "-pageheight", NULL, NULL,
+ "", Tk_Offset(TkPostscriptInfo, pageHeightString), 0},
+ {TK_CONFIG_STRING, "-pagewidth", NULL, NULL,
+ "", Tk_Offset(TkPostscriptInfo, pageWidthString), 0},
+ {TK_CONFIG_STRING, "-pagex", NULL, NULL,
+ "", Tk_Offset(TkPostscriptInfo, pageXString), 0},
+ {TK_CONFIG_STRING, "-pagey", NULL, NULL,
+ "", Tk_Offset(TkPostscriptInfo, pageYString), 0},
+ {TK_CONFIG_BOOLEAN, "-prolog", NULL, NULL,
+ "", Tk_Offset(TkPostscriptInfo, prolog), 0},
+ {TK_CONFIG_BOOLEAN, "-rotate", NULL, NULL,
+ "", Tk_Offset(TkPostscriptInfo, rotate), 0},
+ {TK_CONFIG_PIXELS, "-width", NULL, NULL,
+ "", Tk_Offset(TkPostscriptInfo, width), 0},
+ {TK_CONFIG_PIXELS, "-x", NULL, NULL,
+ "", Tk_Offset(TkPostscriptInfo, x), 0},
+ {TK_CONFIG_PIXELS, "-y", NULL, NULL,
+ "", Tk_Offset(TkPostscriptInfo, y), 0},
+ {TK_CONFIG_END, NULL, NULL, NULL, NULL, 0, 0}
+};
+
+/*
+ * Forward declarations for functions defined later in this file:
+ */
+
+static int GetPostscriptPoints(Tcl_Interp *interp,
+ char *string, double *doublePtr);
+
+/*
+ *--------------------------------------------------------------
+ *
+ * TkCanvPostscriptCmd --
+ *
+ * This function is invoked to process the "postscript" options of the
+ * widget command for canvas widgets. See the user documentation for
+ * details on what it does.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *--------------------------------------------------------------
+ */
+
+ /* ARGSUSED */
+int
+TkCanvPostscriptCmd(
+ TkCanvas *canvasPtr, /* Information about canvas widget. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int argc, /* Number of arguments. */
+ CONST char **argv) /* Argument strings. Caller has already parsed
+ * this command enough to know that argv[1] is
+ * "postscript". */
+{
+ TkPostscriptInfo psInfo, *psInfoPtr = &psInfo;
+ Tk_PostscriptInfo oldInfoPtr;
+ int result;
+ Tk_Item *itemPtr;
+#define STRING_LENGTH 400
+ char string[STRING_LENGTH+1];
+ CONST char *p;
+ time_t now;
+ size_t length;
+ Tk_Window tkwin = canvasPtr->tkwin;
+ Tcl_HashSearch search;
+ Tcl_HashEntry *hPtr;
+ Tcl_DString buffer;
+ char psenccmd[] = "::tk::ensure_psenc_is_loaded";
+ int deltaX = 0, deltaY = 0; /* Offset of lower-left corner of area to be
+ * marked up, measured in canvas units from
+ * the positioning point on the page (reflects
+ * anchor position). Initial values needed
+ * only to stop compiler warnings. */
+
+ /*
+ * Initialize the data structure describing Postscript generation, then
+ * process all the arguments to fill the data structure in.
+ */
+
+ result = Tcl_EvalEx(interp,psenccmd,-1,TCL_EVAL_GLOBAL);
+ if (result != TCL_OK) {
+ return result;
+ }
+ oldInfoPtr = canvasPtr->psInfo;
+ canvasPtr->psInfo = (Tk_PostscriptInfo) psInfoPtr;
+ psInfo.tkwin = canvasPtr->tkwin;
+ psInfo.x = canvasPtr->xOrigin;
+ psInfo.y = canvasPtr->yOrigin;
+ psInfo.width = -1;
+ psInfo.height = -1;
+ psInfo.pageXString = NULL;
+ psInfo.pageYString = NULL;
+ psInfo.pageX = 72*4.25;
+ psInfo.pageY = 72*5.5;
+ psInfo.pageWidthString = NULL;
+ psInfo.pageHeightString = NULL;
+ psInfo.scale = 1.0;
+ psInfo.pageAnchor = TK_ANCHOR_CENTER;
+ psInfo.rotate = 0;
+ psInfo.fontVar = NULL;
+ psInfo.colorVar = NULL;
+ psInfo.colorMode = NULL;
+ psInfo.colorLevel = 0;
+ psInfo.fileName = NULL;
+ psInfo.channelName = NULL;
+ psInfo.chan = NULL;
+ psInfo.prepass = 0;
+ psInfo.prolog = 1;
+ Tcl_InitHashTable(&psInfo.fontTable, TCL_STRING_KEYS);
+ result = Tk_ConfigureWidget(interp, tkwin, configSpecs, argc-2, argv+2,
+ (char *) &psInfo, TK_CONFIG_ARGV_ONLY);
+ if (result != TCL_OK) {
+ goto cleanup;
+ }
+
+ if (psInfo.width == -1) {
+ psInfo.width = Tk_Width(tkwin);
+ }
+ if (psInfo.height == -1) {
+ psInfo.height = Tk_Height(tkwin);
+ }
+ psInfo.x2 = psInfo.x + psInfo.width;
+ psInfo.y2 = psInfo.y + psInfo.height;
+
+ if (psInfo.pageXString != NULL) {
+ if (GetPostscriptPoints(interp, psInfo.pageXString,
+ &psInfo.pageX) != TCL_OK) {
+ goto cleanup;
+ }
+ }
+ if (psInfo.pageYString != NULL) {
+ if (GetPostscriptPoints(interp, psInfo.pageYString,
+ &psInfo.pageY) != TCL_OK) {
+ goto cleanup;
+ }
+ }
+ if (psInfo.pageWidthString != NULL) {
+ if (GetPostscriptPoints(interp, psInfo.pageWidthString,
+ &psInfo.scale) != TCL_OK) {
+ goto cleanup;
+ }
+ psInfo.scale /= psInfo.width;
+ } else if (psInfo.pageHeightString != NULL) {
+ if (GetPostscriptPoints(interp, psInfo.pageHeightString,
+ &psInfo.scale) != TCL_OK) {
+ goto cleanup;
+ }
+ psInfo.scale /= psInfo.height;
+ } else {
+ psInfo.scale = (72.0/25.4)*WidthMMOfScreen(Tk_Screen(tkwin));
+ psInfo.scale /= WidthOfScreen(Tk_Screen(tkwin));
+ }
+ switch (psInfo.pageAnchor) {
+ case TK_ANCHOR_NW:
+ case TK_ANCHOR_W:
+ case TK_ANCHOR_SW:
+ deltaX = 0;
+ break;
+ case TK_ANCHOR_N:
+ case TK_ANCHOR_CENTER:
+ case TK_ANCHOR_S:
+ deltaX = -psInfo.width/2;
+ break;
+ case TK_ANCHOR_NE:
+ case TK_ANCHOR_E:
+ case TK_ANCHOR_SE:
+ deltaX = -psInfo.width;
+ break;
+ }
+ switch (psInfo.pageAnchor) {
+ case TK_ANCHOR_NW:
+ case TK_ANCHOR_N:
+ case TK_ANCHOR_NE:
+ deltaY = - psInfo.height;
+ break;
+ case TK_ANCHOR_W:
+ case TK_ANCHOR_CENTER:
+ case TK_ANCHOR_E:
+ deltaY = -psInfo.height/2;
+ break;
+ case TK_ANCHOR_SW:
+ case TK_ANCHOR_S:
+ case TK_ANCHOR_SE:
+ deltaY = 0;
+ break;
+ }
+
+ if (psInfo.colorMode == NULL) {
+ psInfo.colorLevel = 2;
+ } else {
+ length = strlen(psInfo.colorMode);
+ if (strncmp(psInfo.colorMode, "monochrome", length) == 0) {
+ psInfo.colorLevel = 0;
+ } else if (strncmp(psInfo.colorMode, "gray", length) == 0) {
+ psInfo.colorLevel = 1;
+ } else if (strncmp(psInfo.colorMode, "color", length) == 0) {
+ psInfo.colorLevel = 2;
+ } else {
+ Tcl_AppendResult(interp, "bad color mode \"", psInfo.colorMode,
+ "\": must be monochrome, gray, or color", NULL);
+ goto cleanup;
+ }
+ }
+
+ if (psInfo.fileName != NULL) {
+ /*
+ * Check that -file and -channel are not both specified.
+ */
+
+ if (psInfo.channelName != NULL) {
+ Tcl_AppendResult(interp, "can't specify both -file",
+ " and -channel", NULL);
+ result = TCL_ERROR;
+ goto cleanup;
+ }
+
+ /*
+ * Check that we are not in a safe interpreter. If we are, disallow
+ * the -file specification.
+ */
+
+ if (Tcl_IsSafe(interp)) {
+ Tcl_AppendResult(interp, "can't specify -file in a",
+ " safe interpreter", NULL);
+ result = TCL_ERROR;
+ goto cleanup;
+ }
+
+ p = Tcl_TranslateFileName(interp, psInfo.fileName, &buffer);
+ if (p == NULL) {
+ goto cleanup;
+ }
+ psInfo.chan = Tcl_OpenFileChannel(interp, p, "w", 0666);
+ Tcl_DStringFree(&buffer);
+ if (psInfo.chan == NULL) {
+ goto cleanup;
+ }
+ }
+
+ if (psInfo.channelName != NULL) {
+ int mode;
+
+ /*
+ * Check that the channel is found in this interpreter and that it is
+ * open for writing.
+ */
+
+ psInfo.chan = Tcl_GetChannel(interp, psInfo.channelName, &mode);
+ if (psInfo.chan == (Tcl_Channel) NULL) {
+ result = TCL_ERROR;
+ goto cleanup;
+ }
+ if ((mode & TCL_WRITABLE) == 0) {
+ Tcl_AppendResult(interp, "channel \"", psInfo.channelName,
+ "\" wasn't opened for writing", NULL);
+ result = TCL_ERROR;
+ goto cleanup;
+ }
+ }
+
+ /*
+ * Make a pre-pass over all of the items, generating Postscript and then
+ * throwing it away. The purpose of this pass is just to collect
+ * information about all the fonts in use, so that we can output font
+ * information in the proper form required by the Document Structuring
+ * Conventions.
+ */
+
+ psInfo.prepass = 1;
+ for (itemPtr = canvasPtr->firstItemPtr; itemPtr != NULL;
+ itemPtr = itemPtr->nextPtr) {
+ if ((itemPtr->x1 >= psInfo.x2) || (itemPtr->x2 < psInfo.x)
+ || (itemPtr->y1 >= psInfo.y2) || (itemPtr->y2 < psInfo.y)) {
+ continue;
+ }
+ if (itemPtr->typePtr->postscriptProc == NULL) {
+ continue;
+ }
+ result = (*itemPtr->typePtr->postscriptProc)(interp,
+ (Tk_Canvas) canvasPtr, itemPtr, 1);
+ Tcl_ResetResult(interp);
+ if (result != TCL_OK) {
+ /*
+ * An error just occurred. Just skip out of this loop. There's no
+ * need to report the error now; it can be reported later (errors
+ * can happen later that don't happen now, so we still have to
+ * check for errors later anyway).
+ */
+ break;
+ }
+ }
+ psInfo.prepass = 0;
+
+ /*
+ * Generate the header and prolog for the Postscript.
+ */
+
+ if (psInfo.prolog) {
+ Tcl_AppendResult(interp, "%!PS-Adobe-3.0 EPSF-3.0\n",
+ "%%Creator: Tk Canvas Widget\n", NULL);
+#ifdef HAVE_PW_GECOS
+ if (!Tcl_IsSafe(interp)) {
+ struct passwd *pwPtr = getpwuid(getuid()); /* INTL: Native. */
+
+ Tcl_AppendResult(interp, "%%For: ",
+ (pwPtr != NULL) ? pwPtr->pw_gecos : "Unknown", "\n", NULL);
+ endpwent();
+ }
+#endif /* HAVE_PW_GECOS */
+ Tcl_AppendResult(interp, "%%Title: Window ", Tk_PathName(tkwin), "\n",
+ NULL);
+ time(&now);
+ Tcl_AppendResult(interp, "%%CreationDate: ",
+ ctime(&now), NULL); /* INTL: Native. */
+ if (!psInfo.rotate) {
+ sprintf(string, "%d %d %d %d",
+ (int) (psInfo.pageX + psInfo.scale*deltaX),
+ (int) (psInfo.pageY + psInfo.scale*deltaY),
+ (int) (psInfo.pageX + psInfo.scale*(deltaX + psInfo.width)
+ + 1.0),
+ (int) (psInfo.pageY + psInfo.scale*(deltaY + psInfo.height)
+ + 1.0));
+ } else {
+ sprintf(string, "%d %d %d %d",
+ (int) (psInfo.pageX - psInfo.scale*(deltaY+psInfo.height)),
+ (int) (psInfo.pageY + psInfo.scale*deltaX),
+ (int) (psInfo.pageX - psInfo.scale*deltaY + 1.0),
+ (int) (psInfo.pageY + psInfo.scale*(deltaX + psInfo.width)
+ + 1.0));
+ }
+ Tcl_AppendResult(interp, "%%BoundingBox: ", string, "\n", NULL);
+ Tcl_AppendResult(interp, "%%Pages: 1\n",
+ "%%DocumentData: Clean7Bit\n", NULL);
+ Tcl_AppendResult(interp, "%%Orientation: ",
+ psInfo.rotate ? "Landscape\n" : "Portrait\n", NULL);
+ p = "%%DocumentNeededResources: font ";
+ for (hPtr = Tcl_FirstHashEntry(&psInfo.fontTable, &search);
+ hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
+ Tcl_AppendResult(interp, p,
+ Tcl_GetHashKey(&psInfo.fontTable, hPtr), "\n", NULL);
+ p = "%%+ font ";
+ }
+ Tcl_AppendResult(interp, "%%EndComments\n\n", NULL);
+
+ /*
+ * Insert the prolog
+ */
+
+ Tcl_AppendResult(interp, Tcl_GetVar(interp,"::tk::ps_preamable",
+ TCL_GLOBAL_ONLY), NULL);
+
+ if (psInfo.chan != NULL) {
+ Tcl_Write(psInfo.chan, Tcl_GetStringResult(interp), -1);
+ Tcl_ResetResult(canvasPtr->interp);
+ }
+
+ /*
+ * Document setup: set the color level and include fonts.
+ */
+
+ sprintf(string, "/CL %d def\n", psInfo.colorLevel);
+ Tcl_AppendResult(interp, "%%BeginSetup\n", string, NULL);
+ for (hPtr = Tcl_FirstHashEntry(&psInfo.fontTable, &search);
+ hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
+ Tcl_AppendResult(interp, "%%IncludeResource: font ",
+ Tcl_GetHashKey(&psInfo.fontTable, hPtr), "\n", NULL);
+ }
+ Tcl_AppendResult(interp, "%%EndSetup\n\n", NULL);
+
+ /*
+ * Page setup: move to page positioning point, rotate if needed, set
+ * scale factor, offset for proper anchor position, and set clip
+ * region.
+ */
+
+ Tcl_AppendResult(interp, "%%Page: 1 1\n", "save\n", NULL);
+ sprintf(string, "%.1f %.1f translate\n", psInfo.pageX, psInfo.pageY);
+ Tcl_AppendResult(interp, string, NULL);
+ if (psInfo.rotate) {
+ Tcl_AppendResult(interp, "90 rotate\n", NULL);
+ }
+ sprintf(string, "%.4g %.4g scale\n", psInfo.scale, psInfo.scale);
+ Tcl_AppendResult(interp, string, NULL);
+ sprintf(string, "%d %d translate\n", deltaX - psInfo.x, deltaY);
+ Tcl_AppendResult(interp, string, NULL);
+ sprintf(string,
+ "%d %.15g moveto %d %.15g lineto %d %.15g lineto %d %.15g",
+ psInfo.x, Tk_PostscriptY((double)psInfo.y,
+ (Tk_PostscriptInfo)psInfoPtr),
+ psInfo.x2, Tk_PostscriptY((double)psInfo.y,
+ (Tk_PostscriptInfo)psInfoPtr),
+ psInfo.x2, Tk_PostscriptY((double)psInfo.y2,
+ (Tk_PostscriptInfo)psInfoPtr),
+ psInfo.x, Tk_PostscriptY((double)psInfo.y2,
+ (Tk_PostscriptInfo)psInfoPtr));
+ Tcl_AppendResult(interp, string,
+ " lineto closepath clip newpath\n", NULL);
+ }
+ /*** waj ***/
+ sprintf(string, "%g %g translate\n",
+ (Tk_PostscriptY((double) psInfo.x, (Tk_PostscriptInfo) &psInfo) -
+ Tk_PostscriptY((double) psInfo.x2, (Tk_PostscriptInfo) &psInfo))
+ *(1.-psScale)/2.,
+ (Tk_PostscriptY((double) psInfo.y, (Tk_PostscriptInfo) &psInfo) -
+ Tk_PostscriptY((double) psInfo.y2, (Tk_PostscriptInfo) &psInfo))
+ *(1.-psScale)/2.);
+ Tcl_AppendResult(interp, string, (char *) NULL);
+
+ sprintf(string, "%.4g %.4g scale\n", psScale, psScale);
+ Tcl_AppendResult(interp, string, (char *) NULL);
+ /*** waj ***/
+ if (psInfo.chan != NULL) {
+ Tcl_Write(psInfo.chan, Tcl_GetStringResult(interp), -1);
+ Tcl_ResetResult(canvasPtr->interp);
+ }
+
+ /*
+ * Iterate through all the items, having each relevant one draw itself.
+ * Quit if any of the items returns an error.
+ */
+
+ result = TCL_OK;
+ for (itemPtr = canvasPtr->firstItemPtr; itemPtr != NULL;
+ itemPtr = itemPtr->nextPtr) {
+ if ((itemPtr->x1 >= psInfo.x2) || (itemPtr->x2 < psInfo.x)
+ || (itemPtr->y1 >= psInfo.y2) || (itemPtr->y2 < psInfo.y)) {
+ continue;
+ }
+ if (itemPtr->typePtr->postscriptProc == NULL) {
+ continue;
+ }
+ if (itemPtr->state == TK_STATE_HIDDEN) {
+ continue;
+ }
+ Tcl_AppendResult(interp, "gsave\n", NULL);
+ result = (*itemPtr->typePtr->postscriptProc)(interp,
+ (Tk_Canvas) canvasPtr, itemPtr, 0);
+ if (result != TCL_OK) {
+ char msg[64 + TCL_INTEGER_SPACE];
+
+ sprintf(msg, "\n (generating Postscript for item %d)",
+ itemPtr->id);
+ Tcl_AddErrorInfo(interp, msg);
+ goto cleanup;
+ }
+ Tcl_AppendResult(interp, "grestore\n", NULL);
+ if (psInfo.chan != NULL) {
+ Tcl_Write(psInfo.chan, Tcl_GetStringResult(interp), -1);
+ Tcl_ResetResult(interp);
+ }
+ }
+
+ /*
+ * Output page-end information, such as commands to print the page and
+ * document trailer stuff.
+ */
+
+ if (psInfo.prolog) {
+ Tcl_AppendResult(interp, "restore showpage\n\n",
+ "%%Trailer\nend\n%%EOF\n", NULL);
+ }
+ if (psInfo.chan != NULL) {
+ Tcl_Write(psInfo.chan, Tcl_GetStringResult(interp), -1);
+ Tcl_ResetResult(canvasPtr->interp);
+ }
+
+ /*
+ * Clean up psInfo to release malloc'ed stuff.
+ */
+
+ cleanup:
+ if (psInfo.pageXString != NULL) {
+ ckfree(psInfo.pageXString);
+ }
+ if (psInfo.pageYString != NULL) {
+ ckfree(psInfo.pageYString);
+ }
+ if (psInfo.pageWidthString != NULL) {
+ ckfree(psInfo.pageWidthString);
+ }
+ if (psInfo.pageHeightString != NULL) {
+ ckfree(psInfo.pageHeightString);
+ }
+ if (psInfo.fontVar != NULL) {
+ ckfree(psInfo.fontVar);
+ }
+ if (psInfo.colorVar != NULL) {
+ ckfree(psInfo.colorVar);
+ }
+ if (psInfo.colorMode != NULL) {
+ ckfree(psInfo.colorMode);
+ }
+ if (psInfo.fileName != NULL) {
+ ckfree(psInfo.fileName);
+ }
+ if ((psInfo.chan != NULL) && (psInfo.channelName == NULL)) {
+ Tcl_Close(interp, psInfo.chan);
+ }
+ if (psInfo.channelName != NULL) {
+ ckfree(psInfo.channelName);
+ }
+ Tcl_DeleteHashTable(&psInfo.fontTable);
+ canvasPtr->psInfo = (Tk_PostscriptInfo) oldInfoPtr;
+ return result;
+}
+
+/*
+ *--------------------------------------------------------------
+ *
+ * GetPostscriptPoints --
+ *
+ * Given a string, returns the number of Postscript points corresponding
+ * to that string.
+ *
+ * Results:
+ * The return value is a standard Tcl return result. If TCL_OK is
+ * returned, then everything went well and the screen distance is stored
+ * at *doublePtr; otherwise TCL_ERROR is returned and an error message is
+ * left in the interp's result.
+ *
+ * Side effects:
+ * None.
+ *
+ *--------------------------------------------------------------
+ */
+
+static int
+GetPostscriptPoints(
+ Tcl_Interp *interp, /* Use this for error reporting. */
+ char *string, /* String describing a screen distance. */
+ double *doublePtr) /* Place to store converted result. */
+{
+ char *end;
+ double d;
+
+ d = strtod(string, &end);
+ if (end == string) {
+ goto error;
+ }
+ while ((*end != '\0') && isspace(UCHAR(*end))) {
+ end++;
+ }
+ switch (*end) {
+ case 'c':
+ d *= 72.0/2.54;
+ end++;
+ break;
+ case 'i':
+ d *= 72.0;
+ end++;
+ break;
+ case 'm':
+ d *= 72.0/25.4;
+ end++;
+ break;
+ case 0:
+ break;
+ case 'p':
+ end++;
+ break;
+ default:
+ goto error;
+ }
+ while ((*end != '\0') && isspace(UCHAR(*end))) {
+ end++;
+ }
+ if (*end != 0) {
+ goto error;
+ }
+ *doublePtr = d;
+ return TCL_OK;
+
+ error:
+ Tcl_AppendResult(interp, "bad distance \"", string, "\"", NULL);
+ return TCL_ERROR;
+}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
distrib
>
Mageia
>
5
>
i586
>
media
>
core-release-src
>
by-pkgid
>
918679fe6222375f87819ff3fade72d3
>
files
>
1
