summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--doc/tclsh.19
-rw-r--r--doc/zvfs.n114
-rw-r--r--generic/tclBootVfs.h24
-rwxr-xr-xgeneric/tclZipVfs.c1720
-rw-r--r--generic/tclZipVfsBoot.c86
-rw-r--r--library/zvfstools/pkgIndex.tcl1
-rw-r--r--library/zvfstools/zvfstools.tcl325
-rw-r--r--tools/mkVfs.tcl93
-rw-r--r--tools/mkzip.tcl5
-rw-r--r--unix/Makefile.in67
-rw-r--r--unix/tclAppInit.c21
-rw-r--r--unix/tclKitInit.c86
-rw-r--r--win/Makefile.in59
-rw-r--r--win/makefile.bc14
-rw-r--r--win/makefile.vc24
-rw-r--r--win/tclAppInit.c22
-rw-r--r--win/tclKitInit.c325
-rw-r--r--win/tclkit.exe.manifest.in51
-rw-r--r--win/tclkit.rc82
19 files changed, 3114 insertions, 14 deletions
diff --git a/doc/tclsh.1 b/doc/tclsh.1
index 6ed5eb6..25d97c5 100644
--- a/doc/tclsh.1
+++ b/doc/tclsh.1
@@ -143,6 +143,15 @@ incomplete commands.
.SH "STANDARD CHANNELS"
.PP
See \fBTcl_StandardChannels\fR for more explanations.
+.SH ZIPVFS
+.PP
+When a zipfile is concatenated to the end of a \fBtclsh\fR, on
+startup the contents of the zip archive will be mounted as the
+virtual file system /zvfs. If a top level directory tcl8.6 is
+present in the zip archive, it will become the directory loaded
+as env(TCL_LIBRARY). If a file named \fBmain.tcl\fR is present
+in the top level directory of the zip archive, it will be sourced
+instead of the shell's normal command line handing.
.SH "SEE ALSO"
auto_path(n), encoding(n), env(n), fconfigure(n)
.SH KEYWORDS
diff --git a/doc/zvfs.n b/doc/zvfs.n
new file mode 100644
index 0000000..f2ad9aa
--- /dev/null
+++ b/doc/zvfs.n
@@ -0,0 +1,114 @@
+'\"
+'\" Copyright (c) 2014 Sean Woods
+'\"
+'\" See the file "license.terms" for information on usage and redistribution
+'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+'\"
+.TH zvfs n 0.1 Zvfs "Zvfs Commands"
+.so man.macros
+.BS
+'\" Note: do not modify the .SH NAME line immediately below!
+.SH NAME
+zvfs \- Mount and work with ZIP files within Tcl
+.SH SYNOPSIS
+.nf
+\fBpackage require zvfs \fR?\fB0.1\fR?
+.sp
+\fB::zvfs::add\fR ?\fB\-fconfigure \fIoptpairs...\fR? \fIarchive file1\fR ?\fIfile2 ...\fR?
+\fB::zvfs::append\fR \fIarchive\fR ?\fIsource destination\fR? ?\fIsource destination...\fR?
+\fB::zvfs::dump\fR \fIzipfile\fR
+\fB::zvfs::exists\fR \fIfilename\fR
+\fB::zvfs::info\fR \fIfile\fR
+\fB::zvfs::list\fR ?\fB\-glob\fR|\fB\-regexp\fR? ?\fIpattern\fR?
+\fB::zvfs::mount ?\fIarchive\fR? ?\fImountpoint\fR?
+\fB::zvfs::start\fR \fIzipfile\fR
+\fB::zvfs::unmount \fIarchive\fR
+.fi
+.BE
+.SH DESCRIPTION
+.PP
+The \fBzvfs\fR package provides tcl with the ability to manipulate
+the contents of a zip file archive as a virtual file system.
+.TP
+\fB::zvfs::mount ?\fIarchive\fR? ?\fImountpoint\fR?
+.
+The \fB::zvfs::mount\fR procedure mounts a zipfile as a VFS.
+After this command
+executes, files contained in the ZIP archive, \fIarchive\fR, will appear to Tcl to be
+regular files at the mount point.
+.RS
+.PP
+With no \fImountpoint\fR, returns the mount point for \fIarchive\fR. With no \fIarchive\fR,
+return all archive/mount pairs. If \fImountpoint\fR is specified as an empty
+string, mount on file path.
+.RE
+.TP
+\fB::zvfs::unmount \fIarchive\fR
+.
+Unmounts a previously mounted zip, \fIarchive\fR.
+.TP
+\fB::zvfs::append\fR \fIarchive\fR ?\fIsource destination\fR? ?\fIsource destination...\fR?
+.
+This command reads \fIsource\fR files and appends them (using the name
+\fIdestination\fR) to the zip archive named \fIarchive\fR. A new zip archive is created
+if it does not already exist. If \fIarchive\fR refers to a file which exists but
+is not a zip archive, then this command turns \fIarchive\fR into a zip archive by
+appending the necessary records and the table of contents. Treat all files
+as binary.
+.RS
+.PP
+Note: No duplicate checking is done, so multiple occurances of the same file is
+allowed.
+.RE
+.TP
+\fB::zvfs::add\fR ?\fB\-fconfigure \fIoptpairs...\fR? \fIarchive file1\fR ?\fIfile2 ...\fR?
+.
+This command is similar to \fBzvfs::append\fR in that it adds files to the zip archive
+named \fIarchive\fR, however file names are relative the current directory. In
+addition, \fBfconfigure\fR is used to apply option pairs to set upon opening of
+each file. Otherwise, default translation is allowed for those file
+extensions listed in the \fB::zvfs::auto_ext\fR variable. Binary translation will be
+used for unknown extensions.
+.RS
+.PP
+NOTE: Use
+.QW "\fB\-fconfigure {}\fR"
+to use auto translation for all.
+.RE
+.TP
+\fB::zvfs::exists\fR \fIfilename\fR
+.
+Return TRUE if the given filename exists in the mounted ZVFS and FALSE if it does
+not.
+.TP
+\fB::zvfs::info\fR \fIfile\fR
+.
+Return information about the given file in the mounted 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.
+.RS
+.PP
+Note: querying the mount point gives the start of zip data offset in (4),
+which can be used to truncate the zip info off an executable.
+.RE
+.TP
+\fB::zvfs::list\fR ?\fB\-glob\fR|\fB\-regexp\fR? ?\fIpattern\fR?
+.
+Return a list of all files in the mounted ZVFS. The order of the names in the list
+is arbitrary.
+.TP
+\fB::zvfs::dump\fR \fIzipfile\fR
+.
+Describe the contents of a zip.
+.TP
+\fB::zvfs::start\fR \fIzipfile\fR
+.
+This command strips returns the offset of zip data.
+.SH "SEE ALSO"
+tclsh(1), file(n), zlib(n)
+.SH "KEYWORDS"
+compress, filesystem, zip
+'\" Local Variables:
+'\" mode: nroff
+'\" End:
diff --git a/generic/tclBootVfs.h b/generic/tclBootVfs.h
new file mode 100644
index 0000000..1cb7c23
--- /dev/null
+++ b/generic/tclBootVfs.h
@@ -0,0 +1,24 @@
+#include <tcl.h>
+#include "tclInt.h"
+#include "tclFileSystem.h"
+
+#ifndef MODULE_SCOPE
+# define MODULE_SCOPE extern
+#endif
+
+#define TCLVFSBOOT_INIT "main.tcl"
+#define TCLVFSBOOT_MOUNT "/zvfs"
+
+/* Make sure the stubbed variants of those are never used. */
+#undef Tcl_ObjSetVar2
+#undef Tcl_NewStringObj
+#undef Tk_Init
+#undef Tk_MainEx
+#undef Tk_SafeInit
+
+MODULE_SCOPE int Tcl_Zvfs_Boot(const char *,const char *,const char *);
+MODULE_SCOPE int Zvfs_Init(Tcl_Interp *);
+MODULE_SCOPE int Zvfs_SafeInit(Tcl_Interp *);
+MODULE_SCOPE int Tclkit_Packages_Init(Tcl_Interp *);
+
+
diff --git a/generic/tclZipVfs.c b/generic/tclZipVfs.c
new file mode 100755
index 0000000..80230c3
--- /dev/null
+++ b/generic/tclZipVfs.c
@@ -0,0 +1,1720 @@
+/*
+** Copyright (c) 2000 D. Richard Hipp
+**
+** 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.
+**
+** 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.
+**
+** Modified to use Tcl VFS hooks by Peter MacDonald
+** peter@pdqi.com
+** http://pdqi.com
+**
+** @(#) $Id: zvfs.c,v 1.1.1.1 2002/01/27 17:44:02 cvs Exp $
+**
+** Revison Date Author Description
+** ------- ------------- ----------------- ----------------------------------------------
+** Jan 8, 2006 Dennis R. LaBelle Modified to support encrypted files
+**
+** Dec 16, 2009 Dennis R. LaBelle Corrected Tobe_FSMatchInDirectoryProc() for
+** proper operation of glob command on ZVFS files
+** under TCL 8.5.
+** Oct 19, 2014 Sean D. Woods Corrected Tobe_FSMatchInDirectoryProc() to work around
+** issues resolving global file paths under Windows.
+** Wrapped FreeWrap specific calls inside of macros.
+** Wrapped calls that implement encryption inside of macros. (The supporting
+** library for this is part of Zip, and not distributed with Tcl.)
+** Reconciled this edition of Zvfs with parallel work on the Odie project.
+*/
+
+#include <ctype.h>
+#include <zlib.h>
+#include <errno.h>
+#include <string.h>
+#include <sys/stat.h>
+#include <time.h>
+#include <stdlib.h>
+#include "tcl.h"
+
+TCL_DECLARE_MUTEX(ArchiveFileAccess)
+
+#undef ZIPVFSCRYPT
+#ifdef ZIPVFSCRYPT
+/* Some modifications to support encrypted files */
+#define update_keys zp_update_keys
+#define init_keys zp_init_keys
+#define decrypt_byte zp_decrypt_byte
+
+/* some prototype definitions */
+extern void init_keys(char *pwd);
+extern int update_keys(int c);
+extern unsigned char decrypt_byte();
+extern char *getPwdKey(char *keybuf);
+extern const unsigned long *crc_32_tab;
+#endif
+
+/* End of modifications to support encrypted files. */
+
+/*
+** Size of the decompression input buffer
+*/
+#define COMPR_BUF_SIZE 32768
+static int openarch = 0; /* Set to 1 when opening archive. */
+#ifdef __WIN32__
+static int maptolower=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.".
+*/
+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 */
+ char *firstMount; /* The path to to the first mounted file. */
+} local;
+
+/*
+** 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 */
+} ZvfsArchive;
+
+/*
+** 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 */
+ int isdir; /* Set to 1 if directory */
+ int depth; /* Number of slashes in path. */
+ int timestamp; /* Modification time */
+ int permissions; /* File permissions. */
+ 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 */
+ /* The following would be used for writable zips. */
+ int nExtra; /* Extra space in the TOC header */
+ int isSpecial; /* Not really a file in the ZIP archive */
+ int dosTime; /* Modification time (DOS format) */
+ int dosDate; /* Modification date (DOS format) */
+ int iCRC; /* Cyclic Redundancy Check of the data */
+} 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.
+*/
+#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))
+
+
+/* Convert DOS time to unix time. */
+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);
+}
+
+/* Return count of char ch in str */
+int strchrcnt(char *str, char ch) {
+ int cnt=0;
+ char *cp=str;
+ while ((cp=strchr(cp,ch))) { cp++; cnt++; }
+ return cnt;
+}
+
+/*
+** 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 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;
+
+#ifdef __WIN32__
+ if (isalpha(zTail[0]) && zTail[1] == ':') {
+ zTail += 2;
+ }
+ if (zTail[0] == '\\') {
+ zRoot = "";
+ zTail++;
+ }
+#endif
+ if (zTail[0] == '/') {
+ zRoot = "";
+ zTail++;
+ }
+ zPath = Tcl_Alloc(strlen(zRoot) + strlen(zTail) + 2);
+ if (zTail[0]) {
+ sprintf(zPath, "%s/%s", zRoot, zTail);
+ } else {
+ strcpy(zPath, zRoot);
+ }
+ for (i=j=0 ; (c = zPath[i]) != 0 ; i++) {
+#ifdef __WIN32__
+ if (isupper(c)) {
+ 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 (c3 == '.' && (zPath[i+3] == '.' || zPath[i+3] == 0)) {
+ i += 2;
+ while (j > 0 && zPath[j-1] != '/') {
+ j--;
+ }
+ continue;
+ }
+ }
+ }
+ zPath[j++] = c;
+ }
+ if (j == 0) {
+ zPath[j++] = '/';
+ }
+ /* if (j>1 && zPath[j-1] == '/') j--; */
+ zPath[j] = 0;
+ return zPath;
+}
+/*
+ * Construct an absolute pathname where memory is obtained from Tcl_Alloc that
+ * means the same file as the pathname given.
+ */
+static char *
+AbsolutePath(
+ const char *zRelative)
+{
+ Tcl_DString pwd;
+ char *zResult;
+ int len;
+
+ Tcl_DStringInit(&pwd);
+ if (zRelative[0] == '~' && zRelative[1] == '/') {
+ /* TODO: do this for all paths??? */
+ if (Tcl_TranslateFileName(0, zRelative, &pwd) != NULL) {
+ zResult = CanonicalPath("", Tcl_DStringValue(&pwd));
+ goto done;
+ }
+ } else if (zRelative[0] != '/') {
+#ifdef __WIN32__
+ if (!(zRelative[0]=='\\' || (zRelative[0] && zRelative[1] == ':'))) {
+ /*Tcl_GetCwd(0, &pwd); */
+ }
+#else
+ Tcl_GetCwd(0, &pwd);
+#endif
+ }
+
+ zResult = CanonicalPath(Tcl_DStringValue(&pwd), zRelative);
+ done:
+ Tcl_DStringFree(&pwd);
+ len = strlen(zResult);
+ if (len > 0 && zResult[len-1] == '/') {
+ zResult[len-1] = 0;
+ }
+ return zResult;
+}
+
+/*
+** 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 */
+ const char *zArchive, /* The ZIP archive file */
+ const char *zMountPoint /* Mount contents at this directory */
+) {
+ Tcl_Channel chan; /* Used for reading the ZIP archive file */
+ char *zArchiveName = 0; /* A copy of zArchive */
+ char *zTrueName = 0; /* A copy of zMountPoint */
+ 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 */
+ unsigned int startZip;
+
+ if (!local.isInit) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * If null archive name, return all current mounts.
+ */
+
+ if (!zArchive) {
+ Tcl_DString dStr;
+
+ Tcl_DStringInit(&dStr);
+ pEntry = Tcl_FirstHashEntry(&local.archiveHash,&zSearch);
+ while (pEntry) {
+ pArchive = Tcl_GetHashValue(pEntry);
+ if (pArchive) {
+ Tcl_DStringAppendElement(&dStr, pArchive->zName);
+ Tcl_DStringAppendElement(&dStr, pArchive->zMountPoint);
+ }
+ pEntry = Tcl_NextHashEntry(&zSearch);
+ }
+ Tcl_DStringResult(interp, &dStr);
+ return TCL_OK;
+ }
+
+ /*
+ * If null mount, return mount point.
+ */
+
+ /*TODO: cleanup allocations of Absolute() path.*/
+ if (!zMountPoint) {
+ zTrueName = AbsolutePath(zArchive);
+ pEntry = Tcl_FindHashEntry(&local.archiveHash, zTrueName);
+ if (pEntry) {
+ pArchive = Tcl_GetHashValue(pEntry);
+ if (pArchive && interp) {
+ Tcl_AppendResult(interp, pArchive->zMountPoint, 0);
+ }
+ }
+ Tcl_Free((char *)zTrueName);
+ return TCL_OK;
+ }
+ Tcl_MutexLock(&ArchiveFileAccess);
+ chan = Tcl_OpenFileChannel(interp, zArchive, "r", 0);
+ if (!chan) {
+ Tcl_MutexUnlock(&ArchiveFileAccess);
+ return TCL_ERROR;
+ }
+ if (Tcl_SetChannelOption(interp, chan, "-translation", "binary") != TCL_OK){
+ goto closeReleaseDie;
+ }
+ if (Tcl_SetChannelOption(interp, chan, "-encoding", "binary") != TCL_OK) {
+ goto closeReleaseDie;
+ }
+
+ /*
+ * Read the "End Of Central Directory" record from the end of the ZIP
+ * archive.
+ */
+
+ iPos = Tcl_Seek(chan, -22, SEEK_END);
+ Tcl_Read(chan, (char *) zBuf, 22);
+ if (memcmp(zBuf, "\120\113\05\06", 4)) {
+ if(interp) Tcl_AppendResult(interp, "not a ZIP archive", NULL);
+ goto closeReleaseDie;
+ }
+
+ /*
+ * Construct the archive record.
+ */
+
+ zArchiveName = AbsolutePath(zArchive);
+ pEntry = Tcl_CreateHashEntry(&local.archiveHash, zArchiveName, &isNew);
+ if (!isNew) {
+ pArchive = Tcl_GetHashValue(pEntry);
+ if (interp) {
+ Tcl_AppendResult(interp, "already mounted at ", pArchive->zMountPoint,0);
+ }
+ goto closeReleaseDie;
+ }
+
+ /*
+ * Empty string is the special case of mounting on itself.
+ */
+
+ if (!*zMountPoint) {
+ zMountPoint = zTrueName = AbsolutePath(zArchive);
+ }
+
+ pArchive = (void *) 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);
+ startZip = iPos;
+
+ while (1) {
+ int lenName; /* Length of the next filename */
+ int lenExtra=0; /* Length of "extra" data for next file */
+ int iData; /* Offset to start of file data */
+ int dosTime;
+ int dosDate;
+ int isdir;
+ ZvfsFile *pZvfs; /* A new virtual file */
+ char *zFullPath; /* Full pathname of the virtual file */
+ char zName[1024]; /* Space to hold the filename */
+
+ if (nFile-- <= 0) {
+ isdir = 1;
+ zFullPath = CanonicalPath(zMountPoint, "");
+ iData = startZip;
+ goto addentry;
+ }
+
+ /*
+ * 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, (char *) zBuf, 46);
+ if (memcmp(zBuf, "\120\113\01\02", 4)) {
+ if(interp) {
+ Tcl_AppendResult(interp, "ill-formed central directory entry",NULL);
+ }
+ if (zTrueName) {
+ Tcl_Free(zTrueName);
+ }
+ 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;
+ }
+
+ /*
+ * Construct an entry in local.fileHash for this virtual file.
+ */
+
+ Tcl_Read(chan, zName, lenName);
+ isdir = 0;
+ if (lenName > 0 && zName[lenName-1] == '/') {
+ lenName--;
+ isdir = 2;
+ }
+ zName[lenName] = 0;
+ zFullPath = CanonicalPath(zMountPoint, zName);
+ addentry:
+ pZvfs = (void *) Tcl_Alloc(sizeof(*pZvfs));
+ pZvfs->zName = zFullPath;
+ pZvfs->pArchive = pArchive;
+ pZvfs->isdir = isdir;
+ pZvfs->depth = strchrcnt(zFullPath, '/');
+ pZvfs->iOffset = iData;
+ if (iData < startZip) {
+ startZip = iData;
+ }
+ dosDate = INT16(zBuf, 14);
+ dosTime = INT16(zBuf, 12);
+ pZvfs->timestamp = DosTimeDate(dosDate, dosTime);
+ pZvfs->nByte = INT32(zBuf, 24);
+ pZvfs->nByteCompr = INT32(zBuf, 20);
+ pZvfs->pNext = pArchive->pFiles;
+ pZvfs->permissions = 0xffff & (INT32(zBuf, 38) >> 16);
+ pArchive->pFiles = pZvfs;
+ pEntry = Tcl_CreateHashEntry(&local.fileHash, zFullPath, &isNew);
+ if (isNew) {
+ pZvfs->pNextName = 0;
+ } else {
+ ZvfsFile *pOld = Tcl_GetHashValue(pEntry);
+ pOld->pPrevName = pZvfs;
+ pZvfs->pNextName = pOld;
+ }
+ pZvfs->pPrevName = 0;
+ Tcl_SetHashValue(pEntry, pZvfs);
+
+ if (nFile < 0) {
+ break;
+ }
+
+ /*
+ * 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);
+ if (zTrueName) {
+ Tcl_Free(zTrueName);
+ }
+ Tcl_MutexUnlock(&ArchiveFileAccess);
+ return TCL_OK;
+
+closeReleaseDie:
+ Tcl_Close(interp, chan);
+ Tcl_MutexUnlock(&ArchiveFileAccess);
+ return TCL_ERROR;
+}
+
+/*
+** 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;
+ Tcl_Free(zTrueName);
+ return pFile;
+}
+
+/*
+** Unmount all the files in the given ZIP archive.
+*/
+static int Zvfs_Unmount(
+ const 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 0;
+ }
+ Tcl_MutexLock(&ArchiveFileAccess);
+ 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) {
+ Tcl_Panic("This should never happen");
+ } else if (pFile->pNextName) {
+ Tcl_SetHashValue(pEntry, pFile->pNextName);
+ } else {
+ Tcl_DeleteHashEntry(pEntry);
+ }
+ }
+ Tcl_Free(pFile->zName);
+ Tcl_Free((void *) pFile);
+ }
+ Tcl_MutexUnlock(&ArchiveFileAccess);
+ return 1;
+}
+
+/*
+ * 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.
+ *
+ * With no mount-point, return mount point for archive. With no archive,
+ * return all archive/mount pairs. If mount-point is specified as an empty
+ * string, mount on file path.
+ */
+static int
+ZvfsMountObjCmd(
+ ClientData clientData, /* 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 */
+{
+ /*TODO: Convert to Tcl_Obj API!*/
+ if (objc > 3) {
+ Tcl_AppendResult(interp, "wrong # args: should be \"", Tcl_GetString(objv[0]),
+ " ? ZIP-FILE ? MOUNT-POINT ? ?\"", 0);
+ return TCL_ERROR;
+ }
+ return Zvfs_Mount(interp, objc>1?Tcl_GetString(objv[1]):NULL, objc>2?Tcl_GetString(objv[2]):NULL);
+}
+
+/*
+ * zvfs::unmount Zip-archive-name
+ *
+ * Undo the effects of zvfs::mount.
+ */
+static int
+ZvfsUnmountObjCmd(
+ ClientData clientData, /* 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 */
+{
+ ZvfsArchive *pArchive; /* The ZIP archive being mounted */
+ Tcl_HashEntry *pEntry; /* Hash table entry */
+ Tcl_HashSearch zSearch; /* Search all mount points */
+ char *zFilename;
+ if (objc != 2) {
+ Tcl_AppendResult(interp, "wrong # args: should be \"", Tcl_GetString(objv[0]),
+ " ZIP-FILE\"", 0);
+ return TCL_ERROR;
+ }
+ if (!local.isInit) {
+ return TCL_ERROR;
+ }
+ zFilename=Tcl_GetString(objv[1]);
+ if (Zvfs_Unmount(zFilename)) {
+ return TCL_OK;
+ }
+ pEntry = Tcl_FirstHashEntry(&local.archiveHash,&zSearch);
+ while (pEntry) {
+ pArchive = Tcl_GetHashValue(pEntry);
+ if (pArchive && pArchive->zMountPoint[0]
+ && (strcmp(pArchive->zMountPoint, zFilename) == 0)) {
+ if (Zvfs_Unmount(pArchive->zName)) {
+ return TCL_OK;
+ }
+ break;
+ }
+ pEntry = Tcl_NextHashEntry(&zSearch);
+ }
+
+ Tcl_AppendResult(interp, "unknown zvfs mount point or file: ", zFilename,
+ NULL);
+ return TCL_ERROR;
+}
+
+/*
+ * zvfs::exists filename
+ *
+ * Return TRUE if the given filename exists in the ZVFS and FALSE if it does
+ * not.
+ */
+static int
+ZvfsExistsObjCmd(
+ ClientData clientData, /* 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_GetString(objv[1]);
+ Tcl_SetBooleanObj(Tcl_GetObjResult(interp), ZvfsLookup(zFilename)!=0);
+ return TCL_OK;
+}
+
+/*
+ * 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.
+ *
+ * Note: querying the mount point gives the start of zip data offset in (4),
+ * which can be used to truncate the zip info off an executable.
+ */
+static int
+ZvfsInfoObjCmd(
+ ClientData clientData, /* 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_GetString(objv[1]);
+ 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;
+}
+
+/*
+ * zvfs::list
+ *
+ * Return a list of all files in the ZVFS. The order of the names in the list
+ * is arbitrary.
+ */
+static int
+ZvfsListObjCmd(
+ ClientData clientData, /* 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_GetString(objv[1]);
+ }
+
+ /*
+ * Do the listing.
+ */
+
+ 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;
+}
+
+/*
+** 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 long nByte; /* number of bytes of uncompressed data */
+ unsigned long nByteCompr; /* number of bytes of unread compressed data */
+ unsigned long nData; /* total number of bytes of compressed data */
+ unsigned long readSoFar; /* position of next byte to be read from the channel */
+ long startOfData; /* File position of start of data in ZIP archive */
+ Tcl_Channel chan; /* Open file handle to the archive file */
+ unsigned char *zBuf; /* buffer used by the decompressor */
+ unsigned char *uBuf; /* pointer to the uncompressed, unencrypted data */
+ z_stream stream; /* state of the decompressor */
+ int isEncrypted; /* file is encrypted */
+ int isCompressed; /* True data is compressed */
+} 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 a second time when Tcl_Exit runs. This will lead to a
+** core dump.
+*/
+static void vfsExit(void *pArg){
+ ZvfsChannelInfo *pInfo = (ZvfsChannelInfo*)pArg;
+ pInfo->chan = 0;
+}
+
+/*
+** This routine is called when the ZVFS channel is closed
+*/
+static int vfsClose(
+ ClientData instanceData, /* A ZvfsChannelInfo structure */
+ Tcl_Interp *interp /* The TCL interpreter */
+){
+ ZvfsChannelInfo* pInfo = (ZvfsChannelInfo*)instanceData;
+
+ if( pInfo->zBuf ){
+ Tcl_Free((char *)pInfo->zBuf);
+ Tcl_Free((char *)pInfo->uBuf);
+ inflateEnd(&pInfo->stream);
+ }
+ if( pInfo->chan ){
+ Tcl_Close(interp, pInfo->chan);
+ Tcl_DeleteExitHandler(vfsExit, pInfo);
+ }
+ Tcl_MutexUnlock(&ArchiveFileAccess);
+ Tcl_Free((char*)pInfo);
+ return TCL_OK;
+}
+
+static int vfsInput (
+ ClientData instanceData, /* The channel to read from */
+ char *buf, /* Buffer to fill */
+ int toRead, /* Requested number of bytes */
+ int *pErrorCode /* Location of error flag */
+){ /* The TCL I/O system calls this function to actually read information
+ * from a ZVFS file.
+ */
+ ZvfsChannelInfo* pInfo = (ZvfsChannelInfo*) instanceData;
+ unsigned long nextpos;
+
+ nextpos = pInfo->readSoFar + toRead;
+ if (nextpos > pInfo->nByte) {
+ toRead = pInfo->nByte - pInfo->readSoFar;
+ nextpos = pInfo->nByte;
+ }
+ if( toRead == 0 )
+ return 0;
+
+ memcpy(buf, pInfo->uBuf + pInfo->readSoFar, toRead);
+
+ pInfo->readSoFar = nextpos;
+ *pErrorCode = 0;
+
+ return toRead;
+}
+
+
+static int vfsRead (
+ ClientData instanceData, /* The channel to read from */
+ char *buf, /* Buffer to fill */
+ int toRead, /* Requested number of bytes */
+ int *pErrorCode /* Location of error flag */
+ ){ /* Read and decompress all data for the associated file into the specified buffer */
+ ZvfsChannelInfo* pInfo = (ZvfsChannelInfo*) instanceData;
+ int len;
+#ifdef ZIPVFSCRYPT
+ unsigned char encryptHdr[12];
+ int C;
+ int temp;
+ int i;
+ char pwdbuf[20];
+#endif
+
+ if( (unsigned long)toRead > pInfo->nByte ){
+ toRead = pInfo->nByte;
+ }
+ if( toRead == 0 ){
+ return 0;
+ }
+ if (pInfo->isEncrypted) {
+#ifdef ZIPVFSCRYPT
+
+ /* Make preparations to decrypt the data. */
+
+ /* Read and decrypt the encryption header. */
+ crc_32_tab = get_crc_table();
+ init_keys(getPwdKey(pwdbuf));
+ len = Tcl_Read(pInfo->chan, encryptHdr, sizeof(encryptHdr));
+ if (len == sizeof(encryptHdr)) {
+ for (i = 0; i < sizeof(encryptHdr); ++i) {
+ C = encryptHdr[i] ^ decrypt_byte();
+ update_keys(C);
+ }
+
+ }
+#endif
+
+ }
+ if( pInfo->isCompressed ){
+ int err = Z_OK;
+ z_stream *stream = &pInfo->stream;
+ stream->next_out = (unsigned char *)buf;
+ stream->avail_out = toRead;
+ while (stream->avail_out) {
+ if (!stream->avail_in) {
+ len = pInfo->nByteCompr;
+ if (len > COMPR_BUF_SIZE) {
+ len = COMPR_BUF_SIZE;
+ }
+ len = Tcl_Read(pInfo->chan, (char *)pInfo->zBuf, len);
+#ifdef ZIPVFSCRYPT
+
+ if (pInfo->isEncrypted) {
+ /* Decrypt the bytes we have just read. */
+ for (i = 0; i < len; ++i) {
+ C = pInfo->zBuf[i];
+ temp = C ^ decrypt_byte();
+ update_keys(temp);
+ pInfo->zBuf[i] = temp;
+ }
+ }
+#endif
+ 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;
+ }
+ }else{
+ toRead = Tcl_Read(pInfo->chan, buf, toRead);
+#ifdef ZIPVFSCRYPT
+ if (pInfo->isEncrypted) {
+ /* Decrypt the bytes we have just read. */
+ for (i = 0; i < toRead; ++i) {
+ C = buf[i];
+ temp = C ^ decrypt_byte();
+ update_keys(temp);
+ buf[i] = temp;
+ }
+ }
+#endif
+ }
+ pInfo->nByte = toRead;
+ pInfo->readSoFar = 0;
+ *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(
+ ClientData instanceData, /* The channel to write to */
+ CONST char *buf, /* Data to be stored. */
+ int toWrite, /* Number of bytes to write. */
+ int *pErrorCode /* Location of error flag. */
+){
+ *pErrorCode = EINVAL;
+ return -1;
+}
+
+static int vfsSeek(
+ 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 */
+){ /* Move the file pointer so that the next byte read will be "offset". */
+
+ ZvfsChannelInfo* pInfo = (ZvfsChannelInfo*) instanceData;
+
+ switch( mode ){
+ case SEEK_CUR: {
+ offset += pInfo->readSoFar;
+ break;
+ }
+ case SEEK_END: {
+ offset += pInfo->nByte - 1;
+ break;
+ }
+ default: {
+ /* Do nothing */
+ break;
+ }
+ }
+/* Don't seek past end of data */
+if (pInfo->nByte < (unsigned long)offset)
+ return -1;
+
+/* Don't seek before the start of data */
+if (offset < 0)
+ return -1;
+
+pInfo->readSoFar = (unsigned long)offset;
+return pInfo->readSoFar;
+}
+
+/*
+** Handle events on the channel. ZVFS files do not generate events,
+** so this is a no-op.
+*/
+static void vfsWatchChannel(
+ ClientData instanceData, /* Channel to watch */
+ int mask /* Events of interest */
+){
+ 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(
+ ClientData instanceData, /* Channel to query */
+ int direction, /* Direction of interest */
+ ClientData* handlePtr /* Space to the handle into */
+){
+ 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. */
+};
+
+/*
+** 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];
+ int errCode;
+
+ pFile = ZvfsLookup(zFilename);
+ if( pFile==0 ) {
+ return NULL;
+ }
+ openarch = 1;
+
+ Tcl_MutexLock(&ArchiveFileAccess);
+ chan = Tcl_OpenFileChannel(interp, pFile->pArchive->zName, "r", 0);
+ openarch = 0;
+
+ if (local.firstMount == NULL) {
+ local.firstMount = pFile->pArchive->zName;
+ }
+ if( chan==0 ){
+ Tcl_MutexUnlock(&ArchiveFileAccess);
+ return 0;
+ }
+ if( Tcl_SetChannelOption(interp, chan, "-translation", "binary")
+ || Tcl_SetChannelOption(interp, chan, "-encoding", "binary")
+ ){
+ /* this should never happen */
+ goto closeReleaseDie;
+ }
+ Tcl_Seek(chan, pFile->iOffset, SEEK_SET);
+ Tcl_Read(chan, (char *)zBuf, 30);
+ if( memcmp(zBuf, "\120\113\03\04", 4) ){
+ if( interp ){
+ Tcl_AppendResult(interp, "local header mismatch: ", NULL);
+ }
+ goto closeReleaseDie;
+ }
+ pInfo = (ZvfsChannelInfo*)Tcl_Alloc( sizeof(*pInfo) );
+ pInfo->chan = chan;
+ Tcl_CreateExitHandler(vfsExit, pInfo);
+#ifdef ZIPVFSCRYPT
+ pInfo->isEncrypted = zBuf[6] & 1;
+ if (pFile->pArchive->zName == local.firstMount) {
+ /* FreeWrap specific.
+ We are opening a file from the executable.
+ All such files must be encrypted.
+ */
+ if (!pInfo->isEncrypted) {
+ /* The file is not encrypted.
+ Someone must have tampered with the application.
+ Let's exit the program.
+ */
+ printf("This application has an unauthorized modification. Exiting immediately\n");
+ exit(-10);
+ }
+ }
+#endif
+ pInfo->isCompressed = INT16(zBuf, 8);
+ if (pInfo->isCompressed ){
+ z_stream *stream = &pInfo->stream;
+ pInfo->zBuf = (void *)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);
+
+ pInfo->uBuf = (void *)Tcl_Alloc(pInfo->nByte);
+ /* Read and decompress the file contents */
+ if (pInfo->uBuf) {
+ pInfo->uBuf[0] = 0;
+ vfsRead(pInfo, (char *)pInfo->uBuf, pInfo->nByte, &errCode);
+ pInfo->readSoFar = 0;
+ }
+
+ return chan;
+
+closeReleaseDie:
+ Tcl_Close(interp, chan);
+ Tcl_MutexUnlock(&ArchiveFileAccess);
+ return NULL;
+
+}
+
+Tcl_Channel Tobe_FSOpenFileChannelProc
+ _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *pathPtr,
+ int mode, int permissions)) {
+ int len;
+ /* if (mode != O_RDONLY) return NULL; */
+ return ZvfsFileOpen(interp, Tcl_GetStringFromObj(pathPtr,&len), 0,
+ permissions);
+}
+
+/*
+** This routine does a stat() system call for a ZVFS file.
+*/
+int Tobe_FSStatProc _ANSI_ARGS_((Tcl_Obj *pathPtr, Tcl_StatBuf *buf)) {
+ char *path=Tcl_GetString(pathPtr);
+ ZvfsFile *pFile;
+
+ pFile = ZvfsLookup(path);
+ if (pFile == 0) {
+ return -1;
+ }
+ memset(buf, 0, sizeof(*buf));
+ if (pFile->isdir) {
+ buf->st_mode = 040555;
+ } else {
+ buf->st_mode = (0100000|pFile->permissions);
+ }
+ buf->st_ino = 0;
+ buf->st_size = pFile->nByte;
+ buf->st_mtime = pFile->timestamp;
+ buf->st_ctime = pFile->timestamp;
+ buf->st_atime = pFile->timestamp;
+ return 0;
+}
+
+/*
+** This routine does an access() system call for a ZVFS file.
+*/
+int Tobe_FSAccessProc _ANSI_ARGS_((Tcl_Obj *pathPtr, int mode)) {
+ char *path=Tcl_GetString(pathPtr);
+ ZvfsFile *pFile;
+
+ if (mode & 3) {
+ return -1;
+ }
+ pFile = ZvfsLookup(path);
+ if (pFile == 0) {
+ return -1;
+ }
+ return 0;
+}
+
+Tcl_Obj* Tobe_FSFilesystemSeparatorProc(Tcl_Obj *pathPtr) {
+ return Tcl_NewStringObj("/",-1);;
+}
+
+/* Function to process a
+* 'Tobe_FSMatchInDirectory()'. If not
+* implemented, then glob and recursive
+* copy functionality will be lacking in
+* the filesystem. */
+int Tobe_FSMatchInDirectoryProc (
+ Tcl_Interp* interp,
+ Tcl_Obj *result,
+ Tcl_Obj *pathPtr,
+ const char *pattern,
+ Tcl_GlobTypeData * types
+) {
+ Tcl_HashEntry *pEntry;
+ Tcl_HashSearch sSearch;
+ int scnt=0, pathlen=0, patternlen=0, dirglob=0, fileglob=0, mntglob=0;
+ int nullpattern=(pattern == NULL || (*pattern=='\0'));
+ char *zPattern = NULL;
+ char *zp=NULL;
+
+ if(types && types->type) {
+ dirglob = (types->type&TCL_GLOB_TYPE_DIR);
+ fileglob = (types->type & TCL_GLOB_TYPE_FILE);
+ mntglob = (types->type&TCL_GLOB_TYPE_MOUNT);
+ }
+ if(!nullpattern) {
+ patternlen=strlen(pattern);
+ }
+ if(pathPtr) {
+ zp=Tcl_GetStringFromObj(pathPtr,&pathlen);
+#ifdef __WIN32__
+ if (isalpha(zp[0]) && zp[1]==':') {
+ zp+=2;
+ }
+#endif
+ }
+ if(mntglob) { return TCL_OK; }
+ if (mntglob) {
+ /* Look for a directory mount */
+ Tcl_HashEntry *pEntry; /* Hash table entry */
+ Tcl_HashSearch zSearch; /* Search all mount points */
+ ZvfsArchive *pArchive; /* The ZIP archive being mounted */
+ char mountpt[200];
+ int i=1;
+ mountpt[0]='/';
+ if(pathPtr) {
+ for(i=1;i<pathlen && i<200;i++) {
+ if(zp[i]=='/' || zp[i]=='\0') break;
+ mountpt[i]=zp[i];
+ }
+ }
+ mountpt[i]='\0';
+ for(
+ pEntry=Tcl_FirstHashEntry(&local.archiveHash,&zSearch);
+ pEntry;
+ pEntry=Tcl_NextHashEntry(&zSearch)
+ ) {
+ pArchive = Tcl_GetHashValue(pEntry);
+ if (pArchive) {
+ char *z = pArchive->zMountPoint;
+ Tcl_Obj *pTail=NULL;
+ int match=0;
+ match=(strcmp(mountpt, z)==0);
+ if(!match) continue;
+ pTail=Tcl_NewStringObj(z, -1);
+ Tcl_ListObjAppendElement(interp, result, pTail);
+ //Tcl_DecrRefCount(pTail);
+ }
+ }
+ } else {
+ int idx=0;
+ if(!zp && nullpattern) {
+ zPattern=NULL;
+ } else {
+ Tcl_DString dTempPath;
+ Tcl_DStringInit(&dTempPath);
+ zPattern=(char*)Tcl_Alloc(pathlen+patternlen+3);
+ memset(zPattern,0,pathlen+patternlen+3);
+ if(zp) {
+ Tcl_DStringAppend(&dTempPath,zp,-1);
+ }
+ if (zp && !nullpattern) {
+ if (pathlen > 1 || zPattern[0] != '/') {
+ Tcl_DStringAppend(&dTempPath,"/",-1);
+ idx++;
+ }
+ }
+ if (!nullpattern) {
+ Tcl_DStringAppend(&dTempPath,pattern,patternlen);
+ }
+ zPattern=strdup(Tcl_DStringValue(&dTempPath));
+ Tcl_DStringFree(&dTempPath);
+ scnt = strchrcnt(zPattern, '/');
+ }
+ for (
+ pEntry = Tcl_FirstHashEntry(&local.fileHash, &sSearch);
+ pEntry;
+ pEntry = Tcl_NextHashEntry(&sSearch)
+ ){
+ ZvfsFile *pFile = Tcl_GetHashValue(pEntry);
+ if(pFile) {
+ char *z = pFile->zName;
+ Tcl_Obj *pTail=NULL;
+ int match=0;
+ if (dirglob && !pFile->isdir) continue;
+ if (fileglob && pFile->isdir) continue;
+ if(scnt != pFile->depth) continue;
+ match=Tcl_StringCaseMatch(z, zPattern, 0);
+ if(!match) continue;
+ pTail=Tcl_NewStringObj(z, -1);
+ Tcl_ListObjAppendElement(interp, result, pTail);
+ }
+ }
+ }
+
+ if (zPattern) {
+ free(zPattern);
+ }
+ return TCL_OK;
+}
+
+/* Function to check whether a path is in
+* this filesystem. This is the most
+* important filesystem procedure. */
+int Tobe_FSPathInFilesystemProc _ANSI_ARGS_((Tcl_Obj *pathPtr,
+ ClientData *clientDataPtr)) {
+ ZvfsFile *zFile;
+ char *path = Tcl_GetString(pathPtr);
+
+ if (openarch) {
+ return -1;
+ }
+ zFile = ZvfsLookup(path);
+ if (zFile != NULL && strcmp(path, zFile->pArchive->zName)) {
+ return TCL_OK;
+ }
+ return -1;
+}
+
+Tcl_Obj *Tobe_FSListVolumesProc _ANSI_ARGS_((void)) {
+ Tcl_HashEntry *pEntry; /* Hash table entry */
+ Tcl_HashSearch zSearch; /* Search all mount points */
+ ZvfsArchive *pArchive; /* The ZIP archive being mounted */
+ Tcl_Obj *pVols=0, *pVol;
+ char mountpt[200];
+
+ pEntry=Tcl_FirstHashEntry(&local.archiveHash,&zSearch);
+ while (pEntry) {
+ pArchive = Tcl_GetHashValue(pEntry);
+ if (pArchive) {
+ if (!pVols) {
+ pVols=Tcl_NewListObj(0,0);
+ Tcl_IncrRefCount(pVols);
+ }
+ sprintf(mountpt, "zvfs:%s", pArchive->zMountPoint);
+ pVol=Tcl_NewStringObj(mountpt,-1);
+ Tcl_IncrRefCount(pVol);
+ Tcl_ListObjAppendElement(NULL, pVols,pVol);
+ /* Tcl_AppendResult(interp,pArchive->zMountPoint," ",pArchive->zName," ",0);*/
+ }
+ pEntry=Tcl_NextHashEntry(&zSearch);
+ }
+ return pVols;
+}
+
+int Tobe_FSChdirProc _ANSI_ARGS_((Tcl_Obj *pathPtr)) {
+ /* Someday, we should actually check if this is a valid path. */
+ return TCL_OK;
+}
+
+const char * const*
+Tobe_FSFileAttrStringsProc(
+ Tcl_Obj *pathPtr,
+ Tcl_Obj** objPtrRef)
+{
+ char *path = Tcl_GetString(pathPtr);
+#ifdef __WIN32__
+ static const char *attrs[] = {
+ "uncompsize", "compsize", "offset", "mount", "archive","-archive", "-hidden", "-readonly", "-system", "-shortname", 0
+ };
+#else
+ static const char *attrs[] = {
+ "uncompsize", "compsize", "offset", "mount", "archive","-group", "-owner", "-permissions", 0
+ };
+#endif
+ if (ZvfsLookup(path) == 0) {
+ return NULL;
+ }
+ return attrs;
+}
+
+int Tobe_FSFileAttrsGetProc _ANSI_ARGS_((Tcl_Interp *interp,
+ int index, Tcl_Obj *pathPtr,
+ Tcl_Obj **objPtrRef)) {
+ char *zFilename;
+ ZvfsFile *pFile;
+ zFilename = Tcl_GetString(pathPtr);
+ pFile = ZvfsLookup(zFilename);
+ if(!pFile)
+ return TCL_ERROR;
+ switch (index) {
+ case 0:
+ *objPtrRef=Tcl_NewIntObj(pFile->nByteCompr);
+ return TCL_OK;
+ case 1:
+ *objPtrRef= Tcl_NewIntObj(pFile->nByte);
+ return TCL_OK;
+ case 2:
+ *objPtrRef= Tcl_NewIntObj(pFile->nByte);
+ return TCL_OK;
+ case 3:
+ *objPtrRef= Tcl_NewStringObj(pFile->pArchive->zMountPoint,-1);
+ return TCL_OK;
+ case 4:
+ *objPtrRef= Tcl_NewStringObj(pFile->pArchive->zName,-1);
+ return TCL_OK;
+#ifdef __WIN32__
+ case 5: /* -archive */
+ *objPtrRef = Tcl_NewStringObj("0", -1); break;
+ case 6: /* -hidden */
+ *objPtrRef = Tcl_NewStringObj("0", -1); break;
+ case 7: /* -readonly */
+ *objPtrRef = Tcl_NewStringObj("", -1); break;
+ case 8: /* -system */
+ *objPtrRef = Tcl_NewStringObj("", -1); break;
+ case 9: /* -shortname */
+ *objPtrRef = Tcl_NewStringObj("", -1);
+#else
+ case 5: /* -group */
+ *objPtrRef = Tcl_NewStringObj("", -1); break;
+ case 6: /* -owner */
+ *objPtrRef = Tcl_NewStringObj("", -1); break;
+ case 7: /* -permissions */ {
+ char buf[32];
+ sprintf(buf, "%03o", pFile->permissions);
+ *objPtrRef = Tcl_NewStringObj(buf, -1); break;
+ }
+#endif
+ default:
+ return TCL_ERROR;
+ }
+ return TCL_OK;
+}
+int Tobe_FSFileAttrsSetProc _ANSI_ARGS_((Tcl_Interp *interp,
+ int index, Tcl_Obj *pathPtr,
+ Tcl_Obj *objPtr)) { return TCL_ERROR; }
+
+Tcl_Obj* Tobe_FSFilesystemPathTypeProc
+ _ANSI_ARGS_((Tcl_Obj *pathPtr)) {
+ return Tcl_NewStringObj("zip",-1);
+}
+
+/****************************************************/
+
+static Tcl_Filesystem Tobe_Filesystem = {
+ "zvfs", /* The name of the filesystem. */
+ sizeof(Tcl_Filesystem), /* Length of this structure, so future
+ * binary compatibility can be assured. */
+ TCL_FILESYSTEM_VERSION_1,
+ /* Version of the filesystem type. */
+ Tobe_FSPathInFilesystemProc,
+ /* Function to check whether a path is in
+ * this filesystem. This is the most
+ * important filesystem procedure. */
+ NULL,
+ /* Function to duplicate internal fs rep. May
+ * be NULL (but then fs is less efficient). */
+ NULL,
+ /* Function to free internal fs rep. Must
+ * be implemented, if internal representations
+ * need freeing, otherwise it can be NULL. */
+ NULL,
+ /* Function to convert internal representation
+ * to a normalized path. Only required if
+ * the fs creates pure path objects with no
+ * string/path representation. */
+ NULL,
+ /* Function to create a filesystem-specific
+ * internal representation. May be NULL
+ * if paths have no internal representation,
+ * or if the Tobe_FSPathInFilesystemProc
+ * for this filesystem always immediately
+ * creates an internal representation for
+ * paths it accepts. */
+ NULL,
+ /* Tobe_FSNormalizePathProc (Not needed)
+ * Function to normalize a path. Should
+ * be implemented for all filesystems
+ * which can have multiple string
+ * representations for the same path
+ * object. */
+ Tobe_FSFilesystemPathTypeProc,
+ /* Function to determine the type of a
+ * path in this filesystem. May be NULL. */
+ Tobe_FSFilesystemSeparatorProc,
+ /* Function to return the separator
+ * character(s) for this filesystem. Must
+ * be implemented. */
+ Tobe_FSStatProc,
+ /*
+ * Function to process a 'Tobe_FSStat()'
+ * call. Must be implemented for any
+ * reasonable filesystem.
+ */
+ Tobe_FSAccessProc,
+ /*
+ * Function to process a 'Tobe_FSAccess()'
+ * call. Must be implemented for any
+ * reasonable filesystem.
+ */
+ Tobe_FSOpenFileChannelProc,
+ /*
+ * Function to process a
+ * 'Tobe_FSOpenFileChannel()' call. Must be
+ * implemented for any reasonable
+ * filesystem.
+ */
+ Tobe_FSMatchInDirectoryProc,
+ /* Function to process a
+ * 'Tobe_FSMatchInDirectory()'. If not
+ * implemented, then glob and recursive
+ * copy functionality will be lacking in
+ * the filesystem. */
+ NULL,
+ /* Function to process a
+ * 'Tobe_FSUtime()' call. Required to
+ * allow setting (not reading) of times
+ * with 'file mtime', 'file atime' and
+ * the open-r/open-w/fcopy implementation
+ * of 'file copy'. */
+ NULL,
+ /* Function to process a
+ * 'Tobe_FSLink()' call. Should be
+ * implemented only if the filesystem supports
+ * links. */
+ Tobe_FSListVolumesProc,
+ /* Function to list any filesystem volumes
+ * added by this filesystem. Should be
+ * implemented only if the filesystem adds
+ * volumes at the head of the filesystem. */
+ Tobe_FSFileAttrStringsProc,
+ /* Function to list all attributes strings
+ * which are valid for this filesystem.
+ * If not implemented the filesystem will
+ * not support the 'file attributes' command.
+ * This allows arbitrary additional information
+ * to be attached to files in the filesystem. */
+ Tobe_FSFileAttrsGetProc,
+ /* Function to process a
+ * 'Tobe_FSFileAttrsGet()' call, used by
+ * 'file attributes'. */
+ Tobe_FSFileAttrsSetProc,
+ /* Function to process a
+ * 'Tobe_FSFileAttrsSet()' call, used by
+ * 'file attributes'. */
+ NULL,
+ /* Function to process a
+ * 'Tobe_FSCreateDirectory()' call. Should
+ * be implemented unless the FS is
+ * read-only. */
+ NULL,
+ /* Function to process a
+ * 'Tobe_FSRemoveDirectory()' call. Should
+ * be implemented unless the FS is
+ * read-only. */
+ NULL,
+ /* Function to process a
+ * 'Tobe_FSDeleteFile()' call. Should
+ * be implemented unless the FS is
+ * read-only. */
+ NULL,
+ /* Function to process a
+ * 'Tobe_FSCopyFile()' call. If not
+ * implemented Tcl will fall back
+ * on open-r, open-w and fcopy as
+ * a copying mechanism. */
+ NULL,
+ /* Function to process a
+ * 'Tobe_FSRenameFile()' call. If not
+ * implemented, Tcl will fall back on
+ * a copy and delete mechanism. */
+ NULL,
+ /* Function to process a
+ * 'Tobe_FSCopyDirectory()' call. If
+ * not implemented, Tcl will fall back
+ * on a recursive create-dir, file copy
+ * mechanism. */
+ NULL,
+ /* Function to process a
+ * 'Tobe_FSLoadFile()' call. If not
+ * implemented, Tcl will fall back on
+ * a copy to native-temp followed by a
+ * Tobe_FSLoadFile on that temporary copy. */
+ NULL,
+ /* Function to unload a previously
+ * successfully loaded file. If load was
+ * implemented, then this should also be
+ * implemented, if there is any cleanup
+ * action required. */
+ NULL,
+ /*
+ * Function to process a 'Tobe_FSGetCwd()'
+ * call. Most filesystems need not
+ * implement this. It will usually only be
+ * called once, if 'getcwd' is called
+ * before 'chdir'. May be NULL.
+ */
+ NULL,
+ /*
+ * Function to process a 'Tobe_FSChdir()'
+ * call. If filesystems do not implement
+ * this, it will be emulated by a series of
+ * directory access checks. Otherwise,
+ * virtual filesystems which do implement
+ * it need only respond with a positive
+ * return result if the dirName is a valid
+ * directory in their filesystem. They
+ * need not remember the result, since that
+ * will be automatically remembered for use
+ * by GetCwd. Real filesystems should
+ * carry out the correct action (i.e. call
+ * the correct system 'chdir' api). If not
+ * implemented, then 'cd' and 'pwd' will
+ * fail inside the filesystem.
+ */
+};
+
+void (*Zvfs_PostInit)(Tcl_Interp *)=0;
+
+int Zvfs_Common_Init(Tcl_Interp *interp) {
+ if( !local.isInit ){
+ /* One-time initialization of the ZVFS */
+ Tcl_FSRegister(0, &Tobe_Filesystem);
+ Tcl_InitHashTable(&local.fileHash, TCL_STRING_KEYS);
+ Tcl_InitHashTable(&local.archiveHash, TCL_STRING_KEYS);
+ local.isInit = 1;
+ }
+ return TCL_OK;
+}
+
+int Zvfs_Init(Tcl_Interp *interp){
+#ifdef USE_TCL_STUBS
+ if( Tcl_InitStubs(interp,"8.0",0)==0 ){
+ return TCL_ERROR;
+ }
+#endif
+ Tcl_PkgProvide(interp, "zvfs", "1.0");
+ Zvfs_Common_Init(interp);
+ Tcl_CreateObjCommand(interp, "zvfs::mount", ZvfsMountObjCmd, 0, 0);
+ Tcl_CreateObjCommand(interp, "zvfs::unmount", ZvfsUnmountObjCmd, 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);
+ if (Zvfs_PostInit) Zvfs_PostInit(interp);
+ return TCL_OK;
+}
+
+int Zvfs_SafeInit(Tcl_Interp *interp){
+#ifdef USE_TCL_STUBS
+ if( Tcl_InitStubs(interp,"8.0",0)==0 ){
+ return TCL_ERROR;
+ }
+#endif
+ Zvfs_Common_Init(interp);
+ Tcl_PkgProvide(interp, "zvfs", "1.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);
+ if (Zvfs_PostInit) Zvfs_PostInit(interp);
+ return TCL_OK;
+}
+
diff --git a/generic/tclZipVfsBoot.c b/generic/tclZipVfsBoot.c
new file mode 100644
index 0000000..06b21b3
--- /dev/null
+++ b/generic/tclZipVfsBoot.c
@@ -0,0 +1,86 @@
+#include <tcl.h>
+#include "tclInt.h"
+#include "tclFileSystem.h"
+
+int Zvfs_Common_Init(Tcl_Interp *);
+int Zvfs_Mount(Tcl_Interp *,CONST char *,CONST char *);
+
+
+/*
+** Boot a shell, mount the executable's VFS, detect main.tcl
+*/
+int Tcl_Zvfs_Boot(const char *archive,const char *vfsmountpoint,const char *initscript) {
+ Zvfs_Common_Init(NULL);
+ if(!vfsmountpoint) {
+ vfsmountpoint="/zvfs";
+ }
+ if(!initscript) {
+ initscript="main.tcl";
+ }
+ /* We have to initialize the virtual filesystem before calling
+ ** Tcl_Init(). Otherwise, Tcl_Init() will not be able to find
+ ** its startup script files.
+ */
+ if(!Zvfs_Mount(NULL, archive, vfsmountpoint)) {
+ Tcl_DString filepath;
+ Tcl_DString preinit;
+
+ Tcl_Obj *vfsinitscript;
+ Tcl_Obj *vfstcllib;
+ Tcl_Obj *vfstklib;
+ Tcl_Obj *vfspreinit;
+ Tcl_DStringInit(&filepath);
+ Tcl_DStringInit(&preinit);
+
+ Tcl_DStringInit(&filepath);
+ Tcl_DStringAppend(&filepath,vfsmountpoint,-1);
+ Tcl_DStringAppend(&filepath,"/",-1);
+ Tcl_DStringAppend(&filepath,initscript,-1);
+ vfsinitscript=Tcl_NewStringObj(Tcl_DStringValue(&filepath),-1);
+ Tcl_DStringFree(&filepath);
+
+ Tcl_DStringInit(&filepath);
+ Tcl_DStringAppend(&filepath,vfsmountpoint,-1);
+ Tcl_DStringAppend(&filepath,"/boot/tcl",-1);
+ vfstcllib=Tcl_NewStringObj(Tcl_DStringValue(&filepath),-1);
+ Tcl_DStringFree(&filepath);
+
+ Tcl_DStringInit(&filepath);
+ Tcl_DStringAppend(&filepath,vfsmountpoint,-1);
+ Tcl_DStringAppend(&filepath,"/boot/tk",-1);
+ vfstklib=Tcl_NewStringObj(Tcl_DStringValue(&filepath),-1);
+ Tcl_DStringFree(&filepath);
+
+ Tcl_IncrRefCount(vfsinitscript);
+ Tcl_IncrRefCount(vfstcllib);
+ Tcl_IncrRefCount(vfstklib);
+
+ if(Tcl_FSAccess(vfsinitscript,F_OK)==0) {
+ /* Startup script should be set before calling Tcl_AppInit */
+ Tcl_SetStartupScript(vfsinitscript,NULL);
+ }
+ /* Record the mountpoint for scripts to refer back to */
+ Tcl_DStringAppend(&preinit,"\nset ::tcl_boot_vfs ",-1);
+ Tcl_DStringAppendElement(&preinit,vfsmountpoint);
+ Tcl_DStringAppend(&preinit,"\nset ::SRCDIR ",-1);
+ Tcl_DStringAppendElement(&preinit,vfsmountpoint);
+
+ if(Tcl_FSAccess(vfstcllib,F_OK)==0) {
+ Tcl_DStringAppend(&preinit,"\nset tcl_library ",-1);
+ Tcl_DStringAppendElement(&preinit,Tcl_GetString(vfstcllib));
+ }
+ if(Tcl_FSAccess(vfstklib,F_OK)==0) {
+ Tcl_DStringAppend(&preinit,"\nset tk_library ",-1);
+ Tcl_DStringAppendElement(&preinit,Tcl_GetString(vfstklib));
+ }
+ vfspreinit=Tcl_NewStringObj(Tcl_DStringValue(&preinit),-1);
+ /* NOTE: We never decr this refcount, lest the contents of the script be deallocated */
+ Tcl_IncrRefCount(vfspreinit);
+ TclSetPreInitScript(Tcl_GetString(vfspreinit));
+
+ Tcl_DecrRefCount(vfsinitscript);
+ Tcl_DecrRefCount(vfstcllib);
+ Tcl_DecrRefCount(vfstklib);
+ }
+ return TCL_OK;
+}
diff --git a/library/zvfstools/pkgIndex.tcl b/library/zvfstools/pkgIndex.tcl
new file mode 100644
index 0000000..824d5b3
--- /dev/null
+++ b/library/zvfstools/pkgIndex.tcl
@@ -0,0 +1 @@
+package ifneeded zvfstools 0.1 [list source [file join $dir zvfstools.tcl]]
diff --git a/library/zvfstools/zvfstools.tcl b/library/zvfstools/zvfstools.tcl
new file mode 100644
index 0000000..274d5a1
--- /dev/null
+++ b/library/zvfstools/zvfstools.tcl
@@ -0,0 +1,325 @@
+# -*- tcl -*-
+# ### ### ### ######### ######### #########
+## Copyright (c) 2008-2009 ActiveState Software Inc.
+## Andreas Kupries
+## Copyright (C) 2009 Pat Thoyts <patthoyts@users.sourceforge.net>
+## Copyright (C) 2014 Sean Woods <yoda@etoyoc.com>
+##
+## BSD License
+##
+# Package providing commands for:
+# * the generation of a zip archive,
+# * building a zip archive from a file system
+# * building a file system from a zip archive
+
+package require Tcl 8.6
+# Cop
+#
+# Create ZIP archives in Tcl.
+#
+# Create a zipkit using mkzip filename.zkit -zipkit -directory xyz.vfs
+# or a zipfile using mkzip filename.zip -directory dirname -exclude "*~"
+#
+
+namespace eval ::zvfs {}
+
+proc ::zvfs::setbinary chan {
+ fconfigure $chan \
+ -encoding binary \
+ -translation binary \
+ -eofchar {}
+
+}
+
+# zip::timet_to_dos
+#
+# Convert a unix timestamp into a DOS timestamp for ZIP times.
+#
+# DOS timestamps are 32 bits split into bit regions as follows:
+# 24 16 8 0
+# +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+
+# |Y|Y|Y|Y|Y|Y|Y|m| |m|m|m|d|d|d|d|d| |h|h|h|h|h|m|m|m| |m|m|m|s|s|s|s|s|
+# +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+
+#
+proc ::zvfs::timet_to_dos {time_t} {
+ set s [clock format $time_t -format {%Y %m %e %k %M %S}]
+ scan $s {%d %d %d %d %d %d} year month day hour min sec
+ expr {(($year-1980) << 25) | ($month << 21) | ($day << 16)
+ | ($hour << 11) | ($min << 5) | ($sec >> 1)}
+}
+
+# zip::pop --
+#
+# Pop an element from a list
+#
+proc ::zvfs::pop {varname {nth 0}} {
+ upvar $varname args
+ set r [lindex $args $nth]
+ set args [lreplace $args $nth $nth]
+ return $r
+}
+
+# zip::walk --
+#
+# Walk a directory tree rooted at 'path'. The excludes list can be
+# a set of glob expressions to match against files and to avoid.
+# The match arg is internal.
+# eg: walk library {CVS/* *~ .#*} to exclude CVS and emacs cruft.
+#
+proc ::zvfs::walk {base {excludes ""} {match *} {path {}}} {
+ set result {}
+ set imatch [file join $path $match]
+ set files [glob -nocomplain -tails -types f -directory $base $imatch]
+ foreach file $files {
+ set excluded 0
+ foreach glob $excludes {
+ if {[string match $glob $file]} {
+ set excluded 1
+ break
+ }
+ }
+ if {!$excluded} {lappend result $file}
+ }
+ foreach dir [glob -nocomplain -tails -types d -directory $base $imatch] {
+ lappend result $dir
+ set subdir [walk $base $excludes $match $dir]
+ if {[llength $subdir]>0} {
+ set result [concat $result [list $dir] $subdir]
+ }
+ }
+ return $result
+}
+
+# zvfs::add_file_to_archive --
+#
+# Add a single file to a zip archive. The zipchan channel should
+# already be open and binary. You may provide a comment for the
+# file The return value is the central directory record that
+# will need to be used when finalizing the zip archive.
+#
+# FIX ME: should handle the current offset for non-seekable channels
+#
+proc ::zvfs::add_file_to_archive {zipchan base path {comment ""}} {
+ set fullpath [file join $base $path]
+ set mtime [timet_to_dos [file mtime $fullpath]]
+ if {[file isdirectory $fullpath]} {
+ append path /
+ }
+ set utfpath [encoding convertto utf-8 $path]
+ set utfcomment [encoding convertto utf-8 $comment]
+ set flags [expr {(1<<11)}] ;# utf-8 comment and path
+ set method 0 ;# store 0, deflate 8
+ set attr 0 ;# text or binary (default binary)
+ set version 20 ;# minumum version req'd to extract
+ set extra ""
+ set crc 0
+ set size 0
+ set csize 0
+ set data ""
+ set seekable [expr {[tell $zipchan] != -1}]
+ if {[file isdirectory $fullpath]} {
+ set attrex 0x41ff0010 ;# 0o040777 (drwxrwxrwx)
+ } elseif {[file executable $fullpath]} {
+ set attrex 0x81ff0080 ;# 0o100777 (-rwxrwxrwx)
+ } else {
+ set attrex 0x81b60020 ;# 0o100666 (-rw-rw-rw-)
+ if {[file extension $fullpath] in {".tcl" ".txt" ".c"}} {
+ set attr 1 ;# text
+ }
+ }
+
+ if {[file isfile $fullpath]} {
+ set size [file size $fullpath]
+ if {!$seekable} {set flags [expr {$flags | (1 << 3)}]}
+ }
+
+ set offset [tell $zipchan]
+ set local [binary format a4sssiiiiss PK\03\04 \
+ $version $flags $method $mtime $crc $csize $size \
+ [string length $utfpath] [string length $extra]]
+ append local $utfpath $extra
+ puts -nonewline $zipchan $local
+
+ if {[file isfile $fullpath]} {
+ # If the file is under 2MB then zip in one chunk, otherwize we use
+ # streaming to avoid requiring excess memory. This helps to prevent
+ # storing re-compressed data that may be larger than the source when
+ # handling PNG or JPEG or nested ZIP files.
+ if {$size < 0x00200000} {
+ set fin [::open $fullpath rb]
+ setbinary $fin
+ set data [::read $fin]
+ set crc [::zlib crc32 $data]
+ set cdata [::zlib deflate $data]
+ if {[string length $cdata] < $size} {
+ set method 8
+ set data $cdata
+ }
+ close $fin
+ set csize [string length $data]
+ puts -nonewline $zipchan $data
+ } else {
+ set method 8
+ set fin [::open $fullpath rb]
+ setbinary $fin
+ set zlib [::zlib stream deflate]
+ while {![eof $fin]} {
+ set data [read $fin 4096]
+ set crc [zlib crc32 $data $crc]
+ $zlib put $data
+ if {[string length [set zdata [$zlib get]]]} {
+ incr csize [string length $zdata]
+ puts -nonewline $zipchan $zdata
+ }
+ }
+ close $fin
+ $zlib finalize
+ set zdata [$zlib get]
+ incr csize [string length $zdata]
+ puts -nonewline $zipchan $zdata
+ $zlib close
+ }
+
+ if {$seekable} {
+ # update the header if the output is seekable
+ set local [binary format a4sssiiii PK\03\04 \
+ $version $flags $method $mtime $crc $csize $size]
+ set current [tell $zipchan]
+ seek $zipchan $offset
+ puts -nonewline $zipchan $local
+ seek $zipchan $current
+ } else {
+ # Write a data descriptor record
+ set ddesc [binary format a4iii PK\7\8 $crc $csize $size]
+ puts -nonewline $zipchan $ddesc
+ }
+ }
+
+ set hdr [binary format a4ssssiiiisssssii PK\01\02 0x0317 \
+ $version $flags $method $mtime $crc $csize $size \
+ [string length $utfpath] [string length $extra]\
+ [string length $utfcomment] 0 $attr $attrex $offset]
+ append hdr $utfpath $extra $utfcomment
+ return $hdr
+}
+
+# zvfs::mkzip --
+#
+# Create a zip archive in 'filename'. If a file already exists it will be
+# overwritten by a new file. If '-directory' is used, the new zip archive
+# will be rooted in the provided directory.
+# -runtime can be used to specify a prefix file. For instance,
+# zip myzip -runtime unzipsfx.exe -directory subdir
+# will create a self-extracting zip archive from the subdir/ folder.
+# The -comment parameter specifies an optional comment for the archive.
+#
+# eg: zip my.zip -directory Subdir -runtime unzipsfx.exe *.txt
+#
+proc ::zvfs::mkzip {filename args} {
+ array set opts {
+ -zipkit 0 -runtime "" -comment "" -directory ""
+ -exclude {CVS/* */CVS/* *~ ".#*" "*/.#*"}
+ }
+
+ while {[string match -* [set option [lindex $args 0]]]} {
+ switch -exact -- $option {
+ -zipkit { set opts(-zipkit) 1 }
+ -comment { set opts(-comment) [encoding convertto utf-8 [pop args 1]] }
+ -runtime { set opts(-runtime) [pop args 1] }
+ -directory {set opts(-directory) [file normalize [pop args 1]] }
+ -exclude {set opts(-exclude) [pop args 1] }
+ -- { pop args ; break }
+ default {
+ break
+ }
+ }
+ pop args
+ }
+
+ set zf [::open $filename wb]
+ setbinary $zf
+ if {$opts(-runtime) ne ""} {
+ set rt [::open $opts(-runtime) rb]
+ setbinary $rt
+ fcopy $rt $zf
+ close $rt
+ } elseif {$opts(-zipkit)} {
+ set zkd {#!/usr/bin/env tclsh
+# This is a zip-based Tcl Module
+if {![package vsatisfies [package provide zvfs] 1.0]} {
+ package require vfs::zip
+ vfs::zip::Mount [info script] [info script]
+} else {
+ zvfs::mount [info script] [info script]
+}
+# Load any CLIP file present
+if {[file exists [file join [info script] pkgIndex.tcl]] } {
+ set dir [info script]
+ source [file join [info script] pkgIndex.tcl]
+}
+# Run any main.tcl present
+if {[file exists [file join [info script] main.tcl]] } {
+ source [file join [info script] main.tcl]
+}
+ }
+ append zkd \x1A
+ puts -nonewline $zf $zkd
+ }
+
+ set count 0
+ set cd ""
+
+ if {$opts(-directory) ne ""} {
+ set paths [walk $opts(-directory) $opts(-exclude)]
+ } else {
+ set paths [glob -nocomplain {*}$args]
+ }
+ foreach path $paths {
+ append cd [add_file_to_archive $zf $opts(-directory) $path]
+ incr count
+ }
+ set cdoffset [tell $zf]
+ set endrec [binary format a4ssssiis PK\05\06 0 0 \
+ $count $count [string length $cd] $cdoffset\
+ [string length $opts(-comment)]]
+ append endrec $opts(-comment)
+ puts -nonewline $zf $cd
+ puts -nonewline $zf $endrec
+ close $zf
+
+ return
+}
+
+###
+# Decode routines
+###
+proc ::zvfs::copy_file {zipbase destbase file} {
+ set l [string length $zipbase]
+ set relname [string trimleft [string range $file $l end] /]
+ if {[file isdirectory $file]} {
+ foreach sfile [glob -nocomplain $file/*] {
+ file mkdir [file join $destbase $relname]
+ copy_file $zipbase $destbase $sfile
+ }
+ return
+ }
+ file copy -force $file [file join $destbase $relname]
+}
+
+# ### ### ### ######### ######### #########
+## Convenience command, decode and copy to dir
+## This routine relies on zvfs::mount, so we only load
+## it when the zvfs package is present
+##
+proc ::zvfs::unzip {in out} {
+ package require zvfs 1.0
+ set root /ziptmp#[incr ::zvfs::count]
+ zvfs::mount $in $root
+ set out [file normalize $out]
+ foreach file [glob $root/*] {
+ copy_file $root $out $file
+ }
+ zvfs::unmount $in
+ return
+}
+package provide zvfstools 0.1
diff --git a/tools/mkVfs.tcl b/tools/mkVfs.tcl
new file mode 100644
index 0000000..bc6f3aa
--- /dev/null
+++ b/tools/mkVfs.tcl
@@ -0,0 +1,93 @@
+proc cat fname {
+ set fname [open $fname r]
+ set data [read $fname]
+ close $fname
+ return $data
+}
+
+proc pkgIndexDir {root fout d1} {
+
+ puts [format {%*sIndexing %s} [expr {4 * [info level]}] {} \
+ [file tail $d1]]
+ set idx [string length $root]
+ foreach ftail [glob -directory $d1 -nocomplain -tails *] {
+ set f [file join $d1 $ftail]
+ if {[file isdirectory $f] && [string compare CVS $ftail]} {
+ pkgIndexDir $root $fout $f
+ } elseif {[file tail $f] eq "pkgIndex.tcl"} {
+ puts $fout "set dir \${VFSROOT}[string range $d1 $idx end]"
+ puts $fout [cat $f]
+ }
+ }
+}
+
+###
+# Script to build the VFS file system
+###
+proc copyDir {d1 d2} {
+
+ puts [format {%*sCreating %s} [expr {4 * [info level]}] {} \
+ [file tail $d2]]
+
+ file delete -force -- $d2
+ file mkdir $d2
+
+ foreach ftail [glob -directory $d1 -nocomplain -tails *] {
+ set f [file join $d1 $ftail]
+ if {[file isdirectory $f] && [string compare CVS $ftail]} {
+ copyDir $f [file join $d2 $ftail]
+ } elseif {[file isfile $f]} {
+ file copy -force $f [file join $d2 $ftail]
+ if {$::tcl_platform(platform) eq {unix}} {
+ file attributes [file join $d2 $ftail] -permissions 0644
+ } else {
+ file attributes [file join $d2 $ftail] -readonly 1
+ }
+ }
+ }
+
+ if {$::tcl_platform(platform) eq {unix}} {
+ file attributes $d2 -permissions 0755
+ } else {
+ file attributes $d2 -readonly 1
+ }
+}
+
+if {[llength $argv] < 3} {
+ puts "Usage: VFS_ROOT TCLSRC_ROOT PLATFORM"
+ exit 1
+}
+set TCL_SCRIPT_DIR [lindex $argv 0]
+set TCLSRC_ROOT [lindex $argv 1]
+set PLATFORM [lindex $argv 2]
+
+puts "Building [file tail $TCL_SCRIPT_DIR] for $PLATFORM"
+copyDir ${TCLSRC_ROOT}/library ${TCL_SCRIPT_DIR}
+
+if {$PLATFORM == "windows"} {
+ set ddedll [glob -nocomplain ${TCLSRC_ROOT}/win/tcldde*.dll]
+ puts "DDE DLL $ddedll"
+ if {$ddedll != {}} {
+ file copy $ddedll ${TCL_SCRIPT_DIR}/dde
+ }
+ set regdll [glob -nocomplain ${TCLSRC_ROOT}/win/tclreg*.dll]
+ puts "REG DLL $ddedll"
+ if {$regdll != {}} {
+ file copy $regdll ${TCL_SCRIPT_DIR}/reg
+ }
+} else {
+ # Remove the dde and reg package paths
+ file delete -force ${TCL_SCRIPT_DIR}/dde
+ file delete -force ${TCL_SCRIPT_DIR}/reg
+}
+
+# For the following packages, cat their pkgIndex files to tclIndex
+file attributes ${TCL_SCRIPT_DIR}/tclIndex -readonly 0
+set fout [open ${TCL_SCRIPT_DIR}/tclIndex a]
+puts $fout {#
+# MANIFEST OF INCLUDED PACKAGES
+#
+set VFSROOT $dir
+}
+pkgIndexDir ${TCL_SCRIPT_DIR} $fout ${TCL_SCRIPT_DIR}
+close $fout
diff --git a/tools/mkzip.tcl b/tools/mkzip.tcl
new file mode 100644
index 0000000..ba10908
--- /dev/null
+++ b/tools/mkzip.tcl
@@ -0,0 +1,5 @@
+###
+# Wrapper to allow access to Tcl's zvfs::mkzip command from Makefiles
+###
+source [file join [file dirname [file normalize [info script]]] .. library zvfstools zvfstools.tcl]
+zvfs::mkzip {*}$argv
diff --git a/unix/Makefile.in b/unix/Makefile.in
index 311fdb2..0819197 100644
--- a/unix/Makefile.in
+++ b/unix/Makefile.in
@@ -109,6 +109,7 @@ CFLAGS = @CFLAGS_DEFAULT@ @CFLAGS@
LDFLAGS_DEBUG = @LDFLAGS_DEBUG@
LDFLAGS_OPTIMIZE = @LDFLAGS_OPTIMIZE@
LDFLAGS = @LDFLAGS_DEFAULT@ @LDFLAGS@
+SHARED_BUILD = @TCL_SHARED_BUILD@
# To disable ANSI-C procedure prototypes reverse the comment characters on the
# following lines:
@@ -167,6 +168,13 @@ INSTALL_DATA_DIR = ${INSTALL} -d -m 755
# Do not use SHELL_ENV for NATIVE_TCLSH unless it is the tclsh being built.
EXE_SUFFIX = @EXEEXT@
TCL_EXE = tclsh${EXE_SUFFIX}
+ifeq ($(SHARED_BUILD),0)
+TCLZSH_BASE = tclzshs
+else
+TCLZSH_BASE = tclzshd
+endif
+TCLZSH_EXE = ${TCLZSH_BASE}${EXE_SUFFIX}
+
TCLTEST_EXE = tcltest${EXE_SUFFIX}
NATIVE_TCLSH = @TCLSH_PROG@
@@ -359,6 +367,8 @@ ZLIB_OBJS = Zadler32.o Zcompress.o Zcrc32.o Zdeflate.o Zinfback.o \
TCL_OBJS = ${GENERIC_OBJS} ${UNIX_OBJS} ${NOTIFY_OBJS} ${COMPAT_OBJS} \
${OO_OBJS} @DL_OBJS@ @PLAT_OBJS@
+TCLZSH_OBJS = tclZipShInit.o tclZipVfs.o tclZipVfsBoot.o
+
OBJS = ${TCL_OBJS} ${TOMMATH_OBJS} @DTRACE_OBJ@ @ZLIB_OBJS@
TCL_DECLS = \
@@ -614,7 +624,7 @@ SRCS = $(GENERIC_SRCS) $(TOMMATH_SRCS) $(UNIX_SRCS) $(NOTIFY_SRCS) \
all: binaries libraries doc packages
-binaries: ${LIB_FILE} ${TCL_EXE}
+binaries: ${LIB_FILE} ${TCL_EXE} ${TCLZSH_EXE}
libraries:
@@ -632,7 +642,7 @@ ${STUB_LIB_FILE}: ${STUB_LIB_OBJS}
fi
rm -f $@
@MAKE_STUB_LIB@
-
+
# Make target which outputs the list of the .o contained in the Tcl lib useful
# to build a single big shared library containing Tcl and other extensions.
# Used for the Tcl Plugin. -- dl
@@ -647,10 +657,42 @@ ${TCL_EXE}: ${TCLSH_OBJS} ${TCL_LIB_FILE} ${TCL_STUB_LIB_FILE}
${CC} ${CFLAGS} ${LDFLAGS} ${TCLSH_OBJS} \
@TCL_BUILD_LIB_SPEC@ ${TCL_STUB_LIB_FILE} ${LIBS} @EXTRA_TCLSH_LIBS@ \
${CC_SEARCH_FLAGS} -o ${TCL_EXE}
-
+
# Must be empty so it doesn't conflict with rule for ${TCL_EXE} above
${NATIVE_TCLSH}:
+# Rather than force an install, pack the files we need into a
+# file system under our control
+tclzsh.vfs:
+ @echo "Building VFS File system in tclzsh.vfs"
+ @$(TCL_EXE) "$(TOP_DIR)/tools/mkVfs.tcl" \
+ "$(UNIX_DIR)/tclzsh.vfs/boot/tcl" "$(TOP_DIR)" unix
+
+tclzsh: ${TCLZSH_EXE}
+
+${TCLZSH_BASE}_bare: ${TCLZSH_OBJS} ${TCL_LIB_FILE} ${TCL_STUB_LIB_FILE}
+ ${CC} ${CFLAGS} ${LDFLAGS} \
+ ${TCLZSH_OBJS} \
+ @TCL_BUILD_LIB_SPEC@ \
+ ${LIBS} @EXTRA_TCLSH_LIBS@ \
+ ${CC_SEARCH_FLAGS} -o ${TCLZSH_BASE}_bare
+
+# Builds an executable linked to the Tcl dynamic library
+${TCLZSH_EXE}: ${TCLZSH_BASE}_bare tclzsh.vfs
+ @$(TCL_EXE) ../tools/mkzip.tcl ${TCLZSH_EXE} \
+ -runtime ${TCLZSH_BASE}_bare \
+ -directory tclzsh.vfs
+ chmod a+x ${TCLZSH_EXE}
+
+# Builds an executable directly from the Tcl sources
+tclzsh-static: ${TCLZSH_OBJS} ${OBJS} ${ZLIB_OBJS} null.zip tclzsh.vfs
+ ${CC} ${CFLAGS} ${LDFLAGS} \
+ ${TCLZSH_OBJS} ${OBJS} ${ZLIB_OBJS} \
+ ${LIBS} @EXTRA_TCLSH_LIBS@ \
+ ${CC_SEARCH_FLAGS} -o ${TCLZSH_EXE}
+ cat null.zip >> ${TCLZSH_EXE}
+ cd tclzsh.vfs ; zip -rAq ${UNIX_DIR}/${TCLZSH_EXE} .
+
Makefile: $(UNIX_DIR)/Makefile.in $(DLTEST_DIR)/Makefile.in
$(SHELL) config.status
#tclConfig.h: $(UNIX_DIR)/tclConfig.h.in
@@ -658,7 +700,9 @@ Makefile: $(UNIX_DIR)/Makefile.in $(DLTEST_DIR)/Makefile.in
clean: clean-packages
rm -f *.a *.o libtcl* core errs *~ \#* TAGS *.E a.out \
- errors ${TCL_EXE} ${TCLTEST_EXE} lib.exp Tcl @DTRACE_HDR@
+ errors ${TCL_EXE} ${TCLTEST_EXE} lib.exp Tcl @DTRACE_HDR@ \
+ ${TCLZSH_EXE} tclzsh*
+ rm -rf tclzsh.vfs null.zip
cd dltest ; $(MAKE) clean
distclean: distclean-packages clean
@@ -802,6 +846,8 @@ install-binaries: binaries
@chmod 555 "$(DLL_INSTALL_DIR)/$(LIB_FILE)"
@echo "Installing ${TCL_EXE} as $(BIN_INSTALL_DIR)/tclsh$(VERSION)${EXE_SUFFIX}"
@$(INSTALL_PROGRAM) ${TCL_EXE} "$(BIN_INSTALL_DIR)/tclsh$(VERSION)${EXE_SUFFIX}"
+ @echo "Installing ${TCLZSH_EXE} as $(BIN_INSTALL_DIR)/${TCLZSH_BASE}$(VERSION)${EXE_SUFFIX}"
+ @$(INSTALL_PROGRAM) ${TCLZSH_EXE} "$(BIN_INSTALL_DIR)/${TCLZSH_BASE}$(VERSION)${EXE_SUFFIX}"
@echo "Installing tclConfig.sh to $(CONFIG_INSTALL_DIR)/"
@$(INSTALL_DATA) tclConfig.sh "$(CONFIG_INSTALL_DIR)/tclConfig.sh"
@echo "Installing tclooConfig.sh to $(CONFIG_INSTALL_DIR)/"
@@ -1024,7 +1070,11 @@ xtTestInit.o: $(UNIX_DIR)/tclAppInit.c ${TCL_EXE}
@if test -f tclAppInit.sav ; then \
mv tclAppInit.sav tclAppInit.o; \
fi;
-
+
+tclZipShInit.o: $(UNIX_DIR)/tclAppInit.c ${TCL_EXE}
+ $(CC) -c $(APP_CC_SWITCHES) \
+ -DTCL_ZIPVFS $(UNIX_DIR)/tclAppInit.c -o tclZipShInit.o
+
# Object files used on all Unix systems:
REGHDRS=$(GENERIC_DIR)/regex.h $(GENERIC_DIR)/regguts.h \
@@ -1323,6 +1373,12 @@ tclUtf.o: $(GENERIC_DIR)/tclUtf.c $(GENERIC_DIR)/tclUniData.c
tclVar.o: $(GENERIC_DIR)/tclVar.c
$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclVar.c
+tclZipVfs.o: $(GENERIC_DIR)/tclZipVfs.c
+ $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclZipVfs.c
+
+tclZipVfsBoot.o: $(GENERIC_DIR)/tclZipVfsBoot.c
+ $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclZipVfsBoot.c
+
tclZlib.o: $(GENERIC_DIR)/tclZlib.c
$(CC) -c $(CC_SWITCHES) $(ZLIB_INCLUDE) $(GENERIC_DIR)/tclZlib.c
@@ -2125,6 +2181,7 @@ BUILD_HTML = \
.PHONY: install-tzdata install-msgs
.PHONY: packages configure-packages test-packages clean-packages
.PHONY: dist-packages distclean-packages install-packages
+.PHONY: tclzsh-static tclzsh
#--------------------------------------------------------------------------
# DO NOT DELETE THIS LINE -- make depend depends on it.
diff --git a/unix/tclAppInit.c b/unix/tclAppInit.c
index 9bbc88b..1be1ce3 100644
--- a/unix/tclAppInit.c
+++ b/unix/tclAppInit.c
@@ -40,7 +40,12 @@ extern Tcl_PackageInitProc Tclxttest_Init;
#endif
MODULE_SCOPE int TCL_LOCAL_APPINIT(Tcl_Interp *);
MODULE_SCOPE int main(int, char **);
+#ifdef TCL_ZIPVFS
+ MODULE_SCOPE int Tcl_Zvfs_Boot(const char *,const char *,const char *);
+ MODULE_SCOPE int Zvfs_Init(Tcl_Interp *);
+ MODULE_SCOPE int Zvfs_SafeInit(Tcl_Interp *);
+#endif /* TCL_ZIPVFS */
/*
* The following #if block allows you to change how Tcl finds the startup
* script, prime the library or encoding paths, fiddle with the argv, etc.,
@@ -80,7 +85,13 @@ main(
#ifdef TCL_LOCAL_MAIN_HOOK
TCL_LOCAL_MAIN_HOOK(&argc, &argv);
#endif
-
+#ifdef TCL_ZIPVFS
+ #define TCLKIT_INIT "main.tcl"
+ #define TCLKIT_VFSMOUNT "/zvfs"
+ Tcl_FindExecutable(argv[0]);
+ CONST char *cp=Tcl_GetNameOfExecutable();
+ Tcl_Zvfs_Boot(cp,TCLKIT_VFSMOUNT,TCLKIT_INIT);
+#endif
Tcl_Main(argc, argv, TCL_LOCAL_APPINIT);
return 0; /* Needed only to prevent compiler warning. */
}
@@ -111,7 +122,13 @@ Tcl_AppInit(
if ((Tcl_Init)(interp) == TCL_ERROR) {
return TCL_ERROR;
}
-
+#ifdef TCL_ZIPVFS
+ /* Load the ZipVfs package */
+ Tcl_StaticPackage(interp, "zvfs", Zvfs_Init, Zvfs_SafeInit);
+ if(Zvfs_Init(interp) == TCL_ERROR) {
+ return TCL_ERROR;
+ }
+#endif
#ifdef TCL_XT_TEST
if (Tclxttest_Init(interp) == TCL_ERROR) {
return TCL_ERROR;
diff --git a/unix/tclKitInit.c b/unix/tclKitInit.c
new file mode 100644
index 0000000..96861de
--- /dev/null
+++ b/unix/tclKitInit.c
@@ -0,0 +1,86 @@
+/*
+** This file implements the main routine for a standalone Tcl/Tk shell.
+*/
+#include <tcl.h>
+#include "tclInt.h"
+#define TCLKIT_INIT "main.tcl"
+#define TCLKIT_VFSMOUNT "/zvfs"
+
+#define TCL_LOCAL_APPINIT Tclkit_AppInit
+MODULE_SCOPE int TCL_LOCAL_APPINIT(Tcl_Interp *);
+MODULE_SCOPE int main(int, char **);
+
+/*
+** This routine runs first.
+*/
+int main(int argc, char **argv){
+ Tcl_FindExecutable(argv[0]);
+ Tcl_SetStartupScript(Tcl_NewStringObj("noop",-1),NULL);
+ Tcl_Main(argc,argv,&Tclkit_AppInit);
+ return TCL_OK;
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tclkit_AppInit --
+ *
+ * This procedure performs application-specific initialization. Most
+ * applications, especially those that incorporate additional packages,
+ * will have their own version of this procedure.
+ *
+ * Results:
+ * Returns a standard Tcl completion code, and leaves an error message in
+ * the interp's result if an error occurs.
+ *
+ * Side effects:
+ * Depends on the startup script.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tclkit_AppInit(
+ Tcl_Interp *interp) /* Interpreter for application. */
+{
+ Tcl_Zvfs_Boot(interp,TCLKIT_VFSMOUNT,TCLKIT_INIT);
+
+ if ((Tcl_Init)(interp) == TCL_ERROR) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Call the init procedures for included packages. Each call should look
+ * like this:
+ *
+ * if (Mod_Init(interp) == TCL_ERROR) {
+ * return TCL_ERROR;
+ * }
+ *
+ * where "Mod" is the name of the module. (Dynamically-loadable packages
+ * should have the same entry-point name.)
+ */
+
+ /*
+ * Call Tcl_CreateCommand for application-specific commands, if they
+ * weren't already created by the init procedures called above.
+ */
+
+ /*
+ * Specify a user-specific startup file to invoke if the application is
+ * run interactively. Typically the startup file is "~/.apprc" where "app"
+ * is the name of the application. If this line is deleted then no
+ * user-specific startup file will be run under any conditions.
+ */
+
+#ifdef DJGPP
+ (Tcl_ObjSetVar2)(interp, Tcl_NewStringObj("tcl_rcFileName", -1), NULL,
+ Tcl_NewStringObj("~/tclsh.rc", -1), TCL_GLOBAL_ONLY);
+#else
+ (Tcl_ObjSetVar2)(interp, Tcl_NewStringObj("tcl_rcFileName", -1), NULL,
+ Tcl_NewStringObj("~/.tclshrc", -1), TCL_GLOBAL_ONLY);
+#endif
+
+ return TCL_OK;
+} \ No newline at end of file
diff --git a/win/Makefile.in b/win/Makefile.in
index 325b365..0b34570 100644
--- a/win/Makefile.in
+++ b/win/Makefile.in
@@ -103,6 +103,10 @@ COMPAT_DIR = $(TOP_DIR)/compat
PKGS_DIR = $(TOP_DIR)/pkgs
ZLIB_DIR = $(COMPAT_DIR)/zlib
+VFS_SCRIPT_INSTALL_DIR = $(WIN_DIR)/tclvfs.zip/tcl$(VERSION)
+VFS_PKG_INSTALL_DIR = $(WIN_DIR)/tclvfs.zip/lib
+
+
# Converts a POSIX path to a Windows native path.
CYGPATH = @CYGPATH@
@@ -145,6 +149,7 @@ SHARED_LIBRARIES = $(TCL_DLL_FILE) @ZLIB_DLL_FILE@
STATIC_LIBRARIES = $(TCL_LIB_FILE)
TCLSH = tclsh$(VER)${EXESUFFIX}
+TCLZSH = tclzsh$(VER)${EXESUFFIX}
CAT32 = cat32$(EXEEXT)
MAN2TCL = man2tcl$(EXEEXT)
@@ -296,7 +301,7 @@ GENERIC_OBJS = \
tclUtil.$(OBJEXT) \
tclVar.$(OBJEXT) \
tclZlib.$(OBJEXT)
-
+
TOMMATH_OBJS = \
bncore.${OBJEXT} \
bn_reverse.${OBJEXT} \
@@ -406,6 +411,8 @@ ZLIB_OBJS = \
TCL_OBJS = ${GENERIC_OBJS} $(TOMMATH_OBJS) ${WIN_OBJS} @ZLIB_OBJS@
+TCLZSH_OBJS = tclZipShInit.$(OBJEXT) tclZipVfs.$(OBJEXT) tclZipVfsBoot.$(OBJEXT)
+
TCL_DOCS = "$(ROOT_DIR_NATIVE)"/doc/*.[13n]
all: binaries libraries doc packages
@@ -423,6 +430,42 @@ $(TCLSH): $(TCLSH_OBJS) @LIBRARIES@ $(TCL_STUB_LIB_FILE) tclsh.$(RES)
tclsh.$(RES) $(CC_EXENAME) $(LDFLAGS_CONSOLE)
@VC_MANIFEST_EMBED_EXE@
+tclzsh: $(TCLZSH)
+
+null.zip:
+ touch .empty
+ zip -q null.zip .empty
+
+# Rather than force an install, pack the files we need into a
+# file system under our control
+tclzsh.vfs: $(TCLSH) $(DDE_DLL_FILE) $(REG_DLL_FILE)
+ @echo "Building VFS File system in tclzsh.vfs"
+ @$(TCL_EXE) "$(ROOT_DIR)/tools/mkVfs.tcl" \
+ "$(WIN_DIR)/tclzsh.vfs/boot/tcl" "$(ROOT_DIR)" windows
+
+tclzsh_bare: $(TCLZSH_OBJS) @LIBRARIES@ $(TCL_STUB_LIB_FILE) tclsh.$(RES)
+ $(CC) $(CFLAGS) $(TCLZSH_OBJS) $(TCL_LIB_FILE) $(TCL_STUB_LIB_FILE) $(LIBS) \
+ tclsh.$(RES) $(CC_EXENAME) $(LDFLAGS_CONSOLE)
+ @VC_MANIFEST_EMBED_EXE@
+
+$(TCLZSH): tclzsh_bare tclzsh.vfs
+ ./${TCLZSH_BASE}_bare ../tools/mkzip.tcl ${TCLZSH_EXE} \
+ -runtime ${TCLZSH_BASE}_bare \
+ -directory tclzsh.vfs
+ chmod a+x ${TCLZSH_EXE}
+
+# Builds an executable directly from the Tcl sources
+tclzsh-direct: $(TCLZSH_OBJS) ${GENERIC_OBJS} $(TOMMATH_OBJS) ${WIN_OBJS} ${ZLIB_OBJS} @LIBRARIES@ $(TCL_STUB_LIB_FILE) tclsh.$(RES) null.zip tclzsh.vfs
+ rm *.$(OBJEXT)
+ $(CC) $(CFLAGS) -DSTATIC_BUILD -UUSE_STUBS $(TCLZSH_OBJS) \
+ ${GENERIC_OBJS} $(TOMMATH_OBJS) ${WIN_OBJS} ${ZLIB_OBJS} \
+ $(LIBS) \
+ tclsh.$(RES) $(CC_EXENAME) $(LDFLAGS_CONSOLE)
+ @VC_MANIFEST_EMBED_EXE@
+ rm *.$(OBJEXT)
+ cat null.zip >> $(TCLZSH)
+ cd tclzsh.vfs ; zip -rAq $(WIN_DIR)/$(TCLZSH) .
+
cat32.$(OBJEXT): cat.c
$(CC) -c $(CC_SWITCHES) @DEPARG@ $(CC_OBJNAME)
@@ -486,6 +529,9 @@ testMain.${OBJEXT}: tclAppInit.c
tclMain2.${OBJEXT}: tclMain.c
$(CC) -c $(CC_SWITCHES) -DBUILD_tcl -DTCL_ASCII_MAIN @DEPARG@ $(CC_OBJNAME)
+tclZipShInit.${OBJEXT}: tclAppInit.c
+ $(CC) -c $(CC_SWITCHES) -DTCL_ZIPVFS @DEPARG@ $(CC_OBJNAME)
+
# TIP #59, embedding of configuration information into the binary library.
#
# Part of Tcl's configuration information are the paths where it was installed
@@ -570,7 +616,7 @@ install-binaries: binaries
else true; \
fi; \
done;
- @for i in $(TCL_DLL_FILE) $(ZLIB_DLL_FILE) $(TCLSH); \
+ @for i in $(TCL_DLL_FILE) $(ZLIB_DLL_FILE) $(TCLSH) $(TCLZSH); \
do \
if [ -f $$i ]; then \
echo "Installing $$i to $(BIN_INSTALL_DIR)/"; \
@@ -735,8 +781,9 @@ cleanhelp:
clean: cleanhelp clean-packages
$(RM) *.lib *.a *.exp *.dll *.$(RES) *.${OBJEXT} *~ \#* TAGS a.out
- $(RM) $(TCLSH) $(CAT32)
- $(RM) *.pch *.ilk *.pdb
+ $(RM) $(TCLSH) $(CAT32) $(TCLZSH) null.zip
+ $(RM) *.pch *.ilk *.pdb tclzsh*
+ $(RMDIR) tclzsh.vfs
distclean: distclean-packages clean
$(RM) Makefile config.status config.cache config.log tclConfig.sh \
@@ -868,6 +915,8 @@ html-tk: $(TCLSH)
.PHONY: install-doc install-private-headers test test-tcl runtest shell
.PHONY: gdb depend cleanhelp clean distclean packages install-packages
.PHONY: test-packages clean-packages distclean-packages genstubs html
-.PHONY: html-tcl html-tk
+.PHONY: html-tcl html-tk tclzsh
+.PHONY: tclzsh-direct tclzsh-dynamic tclzsh-kitlib
+
# DO NOT DELETE THIS LINE -- make depend depends on it.
diff --git a/win/makefile.bc b/win/makefile.bc
index f5196b6..3f4ae52 100644
--- a/win/makefile.bc
+++ b/win/makefile.bc
@@ -159,6 +159,7 @@ TCLPLUGINDLLNAME = $(NAMEPREFIX)$(VERSION)p$(DBGX).dll
TCLPLUGINDLL = $(OUTDIR)\$(TCLPLUGINDLLNAME)
TCLSH = $(OUTDIR)\$(NAMEPREFIX)sh$(VERSION)$(DBGX).exe
TCLSHP = $(OUTDIR)\$(NAMEPREFIX)shp$(VERSION)$(DBGX).exe
+TCLKIT = $(OUTDIR)\$(NAMEPREFIX)kit$(VERSION)$(DBGX).exe
TCLREGDLLNAME = $(NAMEPREFIX)reg$(REGVERSION)$(DBGX).dll
TCLREGDLL = $(OUTDIR)\$(TCLREGDLLNAME)
TCLDDEDLLNAME = $(NAMEPREFIX)dde$(DDEVERSION)$(DBGX).dll
@@ -177,6 +178,10 @@ INCLUDE_INSTALL_DIR = $(INSTALLDIR)\include
TCLSHOBJS = \
$(TMPDIR)\tclAppInit.obj
+TCLKITOBJS = \
+ $(TMP_DIR)\tclZipVfs.obj \
+ $(TMPDIR)\tclKitInit.obj
+
TCLTESTOBJS = \
$(TMPDIR)\tclTest.obj \
$(TMPDIR)\tclTestObj.obj \
@@ -392,6 +397,11 @@ $(TCLTEST): $(TCLTESTOBJS) $(TCLLIB) $(TMPDIR)\$(NAMEPREFIX)sh.res
$(TCLTESTOBJS), $@, -x, $(LNLIBS) $(TCLLIB),, $(TMPDIR)\$(NAMEPREFIX)sh.res
!
+$(TCLKIT): $(TCLKITOBJS) $(TCLLIB) $(TMPDIR)\$(NAMEPREFIX)sh.res
+ $(link32) $(ldebug) -S:2400000 $(LNFLAGS) $(LNFLAGS_CONS) $(TOOLS32)\lib\c0x32 @&&!
+ $(TCLSHOBJS), $@, -x, $(LNLIBS) $(TCLLIB),, $(TMPDIR)\$(NAMEPREFIX)sh.res
+!
+
$(TCLDDEDLL): $(TMPDIR)\tclWinDde.obj $(TCLSTUBLIB)
$(link32) $(ldebug) $(LNFLAGS) $(LNFLAGS_DLL) $(TOOLS32)\lib\c0d32 \
$(TMPDIR)\tclWinDde.obj, $@, -x, $(LNLIBS) $(TCLSTUBLIB),, \
@@ -512,6 +522,10 @@ $(TMP_DIR)\tclPkgConfig.obj: $(GENERICDIR)\tclPkgConfig.c
$(TMPDIR)\tclAppInit.obj : $(WINDIR)\tclAppInit.c
$(cc32) $(TCL_CFLAGS) -o$(TMPDIR)\$@ $?
+$(TMPDIR)\tclKitInit.obj : $(WINDIR)\tclAppInit.c
+ $(cc32) $(TCL_CFLAGS) -DDTCL_ZIPVFS -o$(TMPDIR)\$@ $?
+
+
# The following objects should be built using the stub interfaces
# tclWinReg: Produces errors in ANSI mode
diff --git a/win/makefile.vc b/win/makefile.vc
index 8c65bd0..2e27275 100644
--- a/win/makefile.vc
+++ b/win/makefile.vc
@@ -209,6 +209,9 @@ TCLSTUBLIB = $(OUT_DIR)\$(TCLSTUBLIBNAME)
TCLSHNAME = $(PROJECT)sh$(VERSION)$(SUFX).exe
TCLSH = $(OUT_DIR)\$(TCLSHNAME)
+TCLKITNAME = $(PROJECT)kit$(VERSION)$(SUFX).exe
+TCLKIT = $(OUT_DIR)\$(TCLSHNAME)
+
TCLREGLIBNAME = $(PROJECT)reg$(REGVERSION)$(SUFX:t=).$(EXT)
TCLREGLIB = $(OUT_DIR)\$(TCLREGLIBNAME)
@@ -244,6 +247,18 @@ TCLSHOBJS = \
!endif
$(TMP_DIR)\tclsh.res
+TCLKITOBJS = \
+ $(TMP_DIR)\tclKitInit.obj \
+ $(TMP_DIR)\tclZipVfs.obj \
+!if !$(STATIC_BUILD)
+!if $(TCL_USE_STATIC_PACKAGES)
+ $(TMP_DIR)\tclWinReg.obj \
+ $(TMP_DIR)\tclWinDde.obj \
+!endif
+!endif
+ $(TMP_DIR)\tclsh.res
+
+
TCLTESTOBJS = \
$(TMP_DIR)\tclTest.obj \
$(TMP_DIR)\tclTestObj.obj \
@@ -932,6 +947,9 @@ $(TMP_DIR)\tclTestObj.obj: $(GENERICDIR)\tclTestObj.c
$(TMP_DIR)\tclWinTest.obj: $(WINDIR)\tclWinTest.c
$(cc32) $(TCL_CFLAGS) -Fo$@ $?
+$(TMP_DIR)\tclZipVfs.obj: $(GENERICDIR)\tclZipVfs.c
+ $(cc32) $(TCL_CFLAGS) -I$(COMPATDIR)\zlib -DBUILD_tcl -Fo$@ $?
+
$(TMP_DIR)\tclZlib.obj: $(GENERICDIR)\tclZlib.c
$(cc32) $(TCL_CFLAGS) -I$(COMPATDIR)\zlib -DBUILD_tcl -Fo$@ $?
@@ -954,6 +972,12 @@ $(TMP_DIR)\tclAppInit.obj: $(WINDIR)\tclAppInit.c
-DTCL_USE_STATIC_PACKAGES=$(TCL_USE_STATIC_PACKAGES) \
-Fo$@ $?
+$(TMP_DIR)\tclKitInit.obj: $(WINDIR)\tclAppInit.c
+ $(cc32) $(TCL_CFLAGS) \
+ -DTCL_USE_STATIC_PACKAGES=$(TCL_USE_STATIC_PACKAGES) \
+ -DTCL_ZIPVFS \
+ -Fo$@ $?
+
### The following objects should be built using the stub interfaces
### *ALL* extensions need to built with -DTCL_THREADS=1
diff --git a/win/tclAppInit.c b/win/tclAppInit.c
index a6c1a67..7fd4c32 100644
--- a/win/tclAppInit.c
+++ b/win/tclAppInit.c
@@ -27,6 +27,12 @@ extern Tcl_PackageInitProc Tcltest_Init;
extern Tcl_PackageInitProc Tcltest_SafeInit;
#endif /* TCL_TEST */
+#ifdef TCL_ZIPVFS
+ MODULE_SCOPE int Tcl_Zvfs_Boot(const char *,const char *,const char *);
+ MODULE_SCOPE int Zvfs_Init(Tcl_Interp *);
+ MODULE_SCOPE int Zvfs_SafeInit(Tcl_Interp *);
+#endif /* TCL_ZIPVFS */
+
#if defined(STATIC_BUILD) && TCL_USE_STATIC_PACKAGES
extern Tcl_PackageInitProc Registry_Init;
extern Tcl_PackageInitProc Dde_Init;
@@ -123,7 +129,13 @@ _tmain(
#ifdef TCL_LOCAL_MAIN_HOOK
TCL_LOCAL_MAIN_HOOK(&argc, &argv);
#endif
-
+#ifdef TCL_ZIPVFS
+ #define TCLKIT_INIT "main.tcl"
+ #define TCLKIT_VFSMOUNT "/zvfs"
+ Tcl_FindExecutable(argv[0]);
+ CONST char *cp=Tcl_GetNameOfExecutable();
+ Tcl_Zvfs_Boot(cp,TCLKIT_VFSMOUNT,TCLKIT_INIT);
+#endif
Tcl_Main(argc, argv, TCL_LOCAL_APPINIT);
return 0; /* Needed only to prevent compiler warning. */
}
@@ -154,7 +166,13 @@ Tcl_AppInit(
if ((Tcl_Init)(interp) == TCL_ERROR) {
return TCL_ERROR;
}
-
+#ifdef TCL_ZIPVFS
+ /* Load the ZipVfs package */
+ Tcl_StaticPackage(interp, "zvfs", Zvfs_Init, Zvfs_SafeInit);
+ if(Zvfs_Init(interp) == TCL_ERROR) {
+ return TCL_ERROR;
+ }
+#endif
#if defined(STATIC_BUILD) && TCL_USE_STATIC_PACKAGES
if (Registry_Init(interp) == TCL_ERROR) {
return TCL_ERROR;
diff --git a/win/tclKitInit.c b/win/tclKitInit.c
new file mode 100644
index 0000000..9531ab5
--- /dev/null
+++ b/win/tclKitInit.c
@@ -0,0 +1,325 @@
+/*
+ * tclAppInit.c --
+ *
+ * Provides a default version of the main program and TclKit_AppInit
+ * procedure for tclsh and other Tcl-based applications (without Tk).
+ * Note that this program must be built in Win32 console mode to work
+ * properly.
+ *
+ * Copyright (c) 1993 The Regents of the University of California.
+ * Copyright (c) 1994-1997 Sun Microsystems, Inc.
+ * Copyright (c) 1998-1999 Scriptics Corporation.
+ *
+ * See the file "license.terms" for information on usage and redistribution of
+ * this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ */
+
+#include "tclWinInt.h"
+
+#define WIN32_LEAN_AND_MEAN
+#include <windows.h>
+#undef WIN32_LEAN_AND_MEAN
+#include <locale.h>
+#include <stdlib.h>
+#include <tchar.h>
+
+extern Tcl_PackageInitProc Registry_Init;
+extern Tcl_PackageInitProc Dde_Init;
+extern Tcl_PackageInitProc Dde_SafeInit;
+
+#ifdef TCL_BROKEN_MAINARGS
+int _CRT_glob = 0;
+static void setargv(int *argcPtr, TCHAR ***argvPtr);
+#endif /* TCL_BROKEN_MAINARGS */
+
+/*
+ * The following #if block allows you to change the AppInit function by using
+ * a #define of TCL_LOCAL_APPINIT instead of rewriting this entire file. The
+ * #if checks for that #define and uses TclKit_AppInit if it does not exist.
+ */
+#define TCLKIT_INIT "main.tcl"
+#define TCLKIT_VFSMOUNT "/zvfs"
+#ifndef TCL_LOCAL_APPINIT
+#define TCL_LOCAL_APPINIT TclKit_AppInit
+#endif
+#ifndef MODULE_SCOPE
+# define MODULE_SCOPE extern
+#endif
+MODULE_SCOPE int TCL_LOCAL_APPINIT(Tcl_Interp *);
+
+/*
+ * The following #if block allows you to change how Tcl finds the startup
+ * script, prime the library or encoding paths, fiddle with the argv, etc.,
+ * without needing to rewrite Tcl_Main()
+ */
+
+#ifdef TCL_LOCAL_MAIN_HOOK
+MODULE_SCOPE int TCL_LOCAL_MAIN_HOOK(int *argc, TCHAR ***argv);
+#endif
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * main --
+ *
+ * This is the main program for the application.
+ *
+ * Results:
+ * None: Tcl_Main never returns here, so this procedure never returns
+ * either.
+ *
+ * Side effects:
+ * Just about anything, since from here we call arbitrary Tcl code.
+ *
+ *----------------------------------------------------------------------
+ */
+
+#ifdef TCL_BROKEN_MAINARGS
+int
+main(
+ int argc, /* Number of command-line arguments. */
+ char *dummy[]) /* Not used. */
+{
+ TCHAR **argv;
+#else
+int
+_tmain(
+ int argc, /* Number of command-line arguments. */
+ TCHAR *argv[]) /* Values of command-line arguments. */
+{
+#endif
+ TCHAR *p;
+
+ /*
+ * Set up the default locale to be standard "C" locale so parsing is
+ * performed correctly.
+ */
+
+ setlocale(LC_ALL, "C");
+
+#ifdef TCL_BROKEN_MAINARGS
+ /*
+ * Get our args from the c-runtime. Ignore command line.
+ */
+
+ setargv(&argc, &argv);
+#endif
+
+ /*
+ * Forward slashes substituted for backslashes.
+ */
+
+ for (p = argv[0]; *p != '\0'; p++) {
+ if (*p == '\\') {
+ *p = '/';
+ }
+ }
+
+#ifdef TCL_LOCAL_MAIN_HOOK
+ TCL_LOCAL_MAIN_HOOK(&argc, &argv);
+#endif
+ /* This voodoo ensures that Tcl_Main does not eat the first argument */
+ Tcl_FindExecutable(argv[0]);
+ Tcl_SetStartupScript(Tcl_NewStringObj("noop",-1),NULL);
+ Tcl_Main(argc, argv, TCL_LOCAL_APPINIT);
+ return 0; /* Needed only to prevent compiler warning. */
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclKit_AppInit --
+ *
+ * This procedure performs application-specific initialization. Most
+ * applications, especially those that incorporate additional packages,
+ * will have their own version of this procedure.
+ *
+ * Results:
+ * Returns a standard Tcl completion code, and leaves an error message in
+ * the interp's result if an error occurs.
+ *
+ * Side effects:
+ * Depends on the startup script.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclKit_AppInit(
+ Tcl_Interp *interp) /* Interpreter for application. */
+{
+ Tcl_Zvfs_Boot(interp,TCLKIT_VFSMOUNT,TCLKIT_INIT);
+ if ((Tcl_Init)(interp) == TCL_ERROR) {
+ return TCL_ERROR;
+ }
+
+// if (Registry_Init(interp) == TCL_ERROR) {
+// return TCL_ERROR;
+// }
+// Tcl_StaticPackage(interp, "registry", Registry_Init, NULL);
+//
+// if (Dde_Init(interp) == TCL_ERROR) {
+// return TCL_ERROR;
+// }
+// Tcl_StaticPackage(interp, "dde", Dde_Init, Dde_SafeInit);
+
+ /*
+ * Call the init procedures for included packages. Each call should look
+ * like this:
+ *
+ * if (Mod_Init(interp) == TCL_ERROR) {
+ * return TCL_ERROR;
+ * }
+ *
+ * where "Mod" is the name of the module. (Dynamically-loadable packages
+ * should have the same entry-point name.)
+ */
+
+ /*
+ * Call Tcl_CreateCommand for application-specific commands, if they
+ * weren't already created by the init procedures called above.
+ */
+
+ /*
+ * Specify a user-specific startup file to invoke if the application is
+ * run interactively. Typically the startup file is "~/.apprc" where "app"
+ * is the name of the application. If this line is deleted then no
+ * user-specific startup file will be run under any conditions.
+ */
+
+ (Tcl_ObjSetVar2)(interp, Tcl_NewStringObj("tcl_rcFileName", -1), NULL,
+ Tcl_NewStringObj("~/tclshrc.tcl", -1), TCL_GLOBAL_ONLY);
+ return TCL_OK;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * setargv --
+ *
+ * Parse the Windows command line string into argc/argv. Done here
+ * because we don't trust the builtin argument parser in crt0. Windows
+ * applications are responsible for breaking their command line into
+ * arguments.
+ *
+ * 2N backslashes + quote -> N backslashes + begin quoted string
+ * 2N + 1 backslashes + quote -> literal
+ * N backslashes + non-quote -> literal
+ * quote + quote in a quoted string -> single quote
+ * quote + quote not in quoted string -> empty string
+ * quote -> begin quoted string
+ *
+ * Results:
+ * Fills argcPtr with the number of arguments and argvPtr with the array
+ * of arguments.
+ *
+ * Side effects:
+ * Memory allocated.
+ *
+ *--------------------------------------------------------------------------
+ */
+
+#ifdef TCL_BROKEN_MAINARGS
+static void
+setargv(
+ int *argcPtr, /* Filled with number of argument strings. */
+ TCHAR ***argvPtr) /* Filled with argument strings (malloc'd). */
+{
+ TCHAR *cmdLine, *p, *arg, *argSpace;
+ TCHAR **argv;
+ int argc, size, inquote, copy, slashes;
+
+ cmdLine = GetCommandLine();
+
+ /*
+ * Precompute an overly pessimistic guess at the number of arguments in
+ * the command line by counting non-space spans.
+ */
+
+ size = 2;
+ for (p = cmdLine; *p != '\0'; p++) {
+ if ((*p == ' ') || (*p == '\t')) { /* INTL: ISO space. */
+ size++;
+ while ((*p == ' ') || (*p == '\t')) { /* INTL: ISO space. */
+ p++;
+ }
+ if (*p == '\0') {
+ break;
+ }
+ }
+ }
+
+ /* Make sure we don't call ckalloc through the (not yet initialized) stub table */
+ #undef Tcl_Alloc
+ #undef Tcl_DbCkalloc
+
+ argSpace = ckalloc(size * sizeof(char *)
+ + (_tcslen(cmdLine) * sizeof(TCHAR)) + sizeof(TCHAR));
+ argv = (TCHAR **) argSpace;
+ argSpace += size * (sizeof(char *)/sizeof(TCHAR));
+ size--;
+
+ p = cmdLine;
+ for (argc = 0; argc < size; argc++) {
+ argv[argc] = arg = argSpace;
+ while ((*p == ' ') || (*p == '\t')) { /* INTL: ISO space. */
+ p++;
+ }
+ if (*p == '\0') {
+ break;
+ }
+
+ inquote = 0;
+ slashes = 0;
+ while (1) {
+ copy = 1;
+ while (*p == '\\') {
+ slashes++;
+ p++;
+ }
+ if (*p == '"') {
+ if ((slashes & 1) == 0) {
+ copy = 0;
+ if ((inquote) && (p[1] == '"')) {
+ p++;
+ copy = 1;
+ } else {
+ inquote = !inquote;
+ }
+ }
+ slashes >>= 1;
+ }
+
+ while (slashes) {
+ *arg = '\\';
+ arg++;
+ slashes--;
+ }
+
+ if ((*p == '\0') || (!inquote &&
+ ((*p == ' ') || (*p == '\t')))) { /* INTL: ISO space. */
+ break;
+ }
+ if (copy != 0) {
+ *arg = *p;
+ arg++;
+ }
+ p++;
+ }
+ *arg = '\0';
+ argSpace = arg + 1;
+ }
+ argv[argc] = NULL;
+
+ *argcPtr = argc;
+ *argvPtr = argv;
+}
+#endif /* TCL_BROKEN_MAINARGS */
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/win/tclkit.exe.manifest.in b/win/tclkit.exe.manifest.in
new file mode 100644
index 0000000..13c1d24
--- /dev/null
+++ b/win/tclkit.exe.manifest.in
@@ -0,0 +1,51 @@
+<?xml version="1.0" encoding="UTF-8" standalone="yes"?>
+<assembly xmlns="urn:schemas-microsoft-com:asm.v1" manifestVersion="1.0"
+ xmlns:asmv3="urn:schemas-microsoft-com:asm.v3">
+ <assemblyIdentity
+ version="@TCL_WIN_VERSION@"
+ processorArchitecture="@MACHINE@"
+ name="Tcl.tclsh"
+ type="win32"
+ />
+ <description>Tcl self-contained executable (tclkit)</description>
+ <trustInfo xmlns="urn:schemas-microsoft-com:asm.v3">
+ <security>
+ <requestedPrivileges>
+ <requestedExecutionLevel
+ level="asInvoker"
+ uiAccess="false"
+ />
+ </requestedPrivileges>
+ </security>
+ </trustInfo>
+ <compatibility xmlns="urn:schemas-microsoft-com:compatibility.v1">
+ <application>
+ <!-- Windows 8.1 -->
+ <supportedOS Id="{1f676c76-80e1-4239-95bb-83d0f6d0da78}"/>
+ <!-- Windows 8 -->
+ <supportedOS Id="{4a2f28e3-53b9-4441-ba9c-d69d4a4a6e38}"/>
+ <!-- Windows 7 -->
+ <supportedOS Id="{35138b9a-5d96-4fbd-8e2d-a2440225f93a}"/>
+ <!-- Windows Vista -->
+ <supportedOS Id="{e2011457-1546-43c5-a5fe-008deee3d3f0}"/>
+ </application>
+ </compatibility>
+ <asmv3:application>
+ <asmv3:windowsSettings
+ xmlns="http://schemas.microsoft.com/SMI/2005/WindowsSettings">
+ <dpiAware>true</dpiAware>
+ </asmv3:windowsSettings>
+ </asmv3:application>
+ <dependency>
+ <dependentAssembly>
+ <assemblyIdentity
+ type="win32"
+ name="Microsoft.Windows.Common-Controls"
+ version="6.0.0.0"
+ processorArchitecture="@MACHINE@"
+ publicKeyToken="6595b64144ccf1df"
+ language="*"
+ />
+ </dependentAssembly>
+ </dependency>
+</assembly>
diff --git a/win/tclkit.rc b/win/tclkit.rc
new file mode 100644
index 0000000..ebe37e1
--- /dev/null
+++ b/win/tclkit.rc
@@ -0,0 +1,82 @@
+//
+// Version Resource Script
+//
+
+#include <winver.h>
+#include <tcl.h>
+
+//
+// build-up the name suffix that defines the type of build this is.
+//
+#if TCL_THREADS
+#define SUFFIX_THREADS "t"
+#else
+#define SUFFIX_THREADS ""
+#endif
+
+#if STATIC_BUILD
+#define SUFFIX_STATIC "s"
+#else
+#define SUFFIX_STATIC ""
+#endif
+
+#if DEBUG && !UNCHECKED
+#define SUFFIX_DEBUG "g"
+#else
+#define SUFFIX_DEBUG ""
+#endif
+
+#define SUFFIX SUFFIX_THREADS SUFFIX_STATIC SUFFIX_DEBUG
+
+
+LANGUAGE 0x9, 0x1 /* LANG_ENGLISH, SUBLANG_DEFAULT */
+
+VS_VERSION_INFO VERSIONINFO
+ FILEVERSION TCL_MAJOR_VERSION,TCL_MINOR_VERSION,TCL_RELEASE_LEVEL,TCL_RELEASE_SERIAL
+ PRODUCTVERSION TCL_MAJOR_VERSION,TCL_MINOR_VERSION,TCL_RELEASE_LEVEL,TCL_RELEASE_SERIAL
+ FILEFLAGSMASK 0x3fL
+#ifdef DEBUG
+ FILEFLAGS VS_FF_DEBUG
+#else
+ FILEFLAGS 0x0L
+#endif
+ FILEOS VOS__WINDOWS32
+ FILETYPE VFT_APP
+ FILESUBTYPE 0x0L
+BEGIN
+ BLOCK "StringFileInfo"
+ BEGIN
+ BLOCK "040904b0"
+ BEGIN
+ VALUE "FileDescription", "Tclkit Application\0"
+ VALUE "OriginalFilename", "tclkit" STRINGIFY(TCL_MAJOR_VERSION) STRINGIFY(TCL_MINOR_VERSION) SUFFIX ".exe\0"
+ VALUE "CompanyName", "ActiveState Corporation\0"
+ VALUE "FileVersion", TCL_PATCH_LEVEL
+ VALUE "LegalCopyright", "Copyright \251 2000 by ActiveState Corporation, et al\0"
+ VALUE "ProductName", "Tcl " TCL_VERSION " for Windows\0"
+ VALUE "ProductVersion", TCL_PATCH_LEVEL
+ END
+ END
+ BLOCK "VarFileInfo"
+ BEGIN
+ VALUE "Translation", 0x409, 1200
+ END
+END
+
+//
+// Icon
+//
+
+tclsh ICON DISCARDABLE "tclsh.ico"
+
+//
+// This is needed for Windows 8.1 onwards.
+//
+
+#ifndef RT_MANIFEST
+#define RT_MANIFEST 24
+#endif
+#ifndef CREATEPROCESS_MANIFEST_RESOURCE_ID
+#define CREATEPROCESS_MANIFEST_RESOURCE_ID 1
+#endif
+CREATEPROCESS_MANIFEST_RESOURCE_ID RT_MANIFEST "tclkit.exe.manifest"
generated by cgit v0.12 at 2024-08-20 01:53:41 (GMT)