Index: doc/tclsh.1 ================================================================== --- doc/tclsh.1 +++ doc/tclsh.1 @@ -141,9 +141,18 @@ if \fBtcl_prompt2\fR is not set then no prompt is output for 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 application, argument, interpreter, prompt, script file, shell ADDED doc/zvfs.n Index: doc/zvfs.n ================================================================== --- /dev/null +++ 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: ADDED generic/tclBootVfs.h Index: generic/tclBootVfs.h ================================================================== --- /dev/null +++ generic/tclBootVfs.h @@ -0,0 +1,24 @@ +#include +#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 *); + + ADDED generic/tclZipVfs.c Index: generic/tclZipVfs.c ================================================================== --- /dev/null +++ generic/tclZipVfs.c @@ -0,0 +1,1732 @@ +/* +** 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 +#include +#include +#include +#include +#include +#include +#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 ( + 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 ( + 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 (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;izMountPoint; + 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 ( + 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 (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 (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 ( + 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 ( + Tcl_Interp *interp, + int index, + Tcl_Obj *pathPtr, + Tcl_Obj *objPtr) { return TCL_ERROR; } + +Tcl_Obj* Tobe_FSFilesystemPathTypeProc (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; +} + ADDED generic/tclZipVfsBoot.c Index: generic/tclZipVfsBoot.c ================================================================== --- /dev/null +++ generic/tclZipVfsBoot.c @@ -0,0 +1,86 @@ +#include +#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; +} ADDED library/zvfstools/pkgIndex.tcl Index: library/zvfstools/pkgIndex.tcl ================================================================== --- /dev/null +++ library/zvfstools/pkgIndex.tcl @@ -0,0 +1,1 @@ +package ifneeded zvfstools 0.1 [list source [file join $dir zvfstools.tcl]] ADDED library/zvfstools/zvfstools.tcl Index: library/zvfstools/zvfstools.tcl ================================================================== --- /dev/null +++ library/zvfstools/zvfstools.tcl @@ -0,0 +1,325 @@ +# -*- tcl -*- +# ### ### ### ######### ######### ######### +## Copyright (c) 2008-2009 ActiveState Software Inc. +## Andreas Kupries +## Copyright (C) 2009 Pat Thoyts +## Copyright (C) 2014 Sean Woods +## +## 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 ADDED tools/mkVfs.tcl Index: tools/mkVfs.tcl ================================================================== --- /dev/null +++ tools/mkVfs.tcl @@ -0,0 +1,99 @@ +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] +set TKDLL [lindex $argv 3] +set TKVER [lindex $argv 4] + +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 +} +if {$TKDLL ne {} && [file exists $TKDLL]} { + file copy $TKDLL ${TCL_SCRIPT_DIR} + puts $fout [list package ifneeded Tk $TKVER "load \$dir $TKDLL"] +} +pkgIndexDir ${TCL_SCRIPT_DIR} $fout ${TCL_SCRIPT_DIR} +close $fout ADDED tools/mkzip.tcl Index: tools/mkzip.tcl ================================================================== --- /dev/null +++ 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 Index: unix/Makefile.in ================================================================== --- unix/Makefile.in +++ unix/Makefile.in @@ -107,10 +107,11 @@ # Flags to pass to the linker 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: PROTO_FLAGS = #PROTO_FLAGS = -DNO_PROTOTYPE @@ -165,10 +166,12 @@ # it to be available on the PATH. This executable should *NOT* be required # just to do a normal build although it can be required to run make dist. # Do not use SHELL_ENV for NATIVE_TCLSH unless it is the tclsh being built. EXE_SUFFIX = @EXEEXT@ TCL_EXE = tclsh${EXE_SUFFIX} +BASEKIT_EXE = basekit${EXE_SUFFIX} + TCLTEST_EXE = tcltest${EXE_SUFFIX} NATIVE_TCLSH = @TCLSH_PROG@ # The symbols below provide support for dynamic loading and shared libraries. # See configure.in for a description of what the symbols mean. The values of @@ -280,11 +283,11 @@ LIBS = @TCL_LIBS@ DEPEND_SWITCHES = ${CFLAGS} -I${UNIX_DIR} -I${GENERIC_DIR} \ ${AC_FLAGS} ${PROTO_FLAGS} ${EXTRA_CFLAGS} @EXTRA_CC_SWITCHES@ -TCLSH_OBJS = tclAppInit.o +TCLSH_OBJS = tclAppInit.o tclZipVfs.o tclZipVfsBoot.o TCLTEST_OBJS = tclTestInit.o tclTest.o tclTestObj.o tclTestProcBodyObj.o \ tclThreadTest.o tclUnixTest.o XTTEST_OBJS = xtTestInit.o tclTest.o tclTestObj.o tclTestProcBodyObj.o \ @@ -612,11 +615,11 @@ # Start of rules #-------------------------------------------------------------------------- all: binaries libraries doc packages -binaries: ${LIB_FILE} ${TCL_EXE} +binaries: ${LIB_FILE} ${TCL_EXE} ${BASEKIT_EXE} libraries: doc: @@ -630,11 +633,11 @@ @if test "x${LIB_FILE}" = "xlibtcl${MAJOR_VERSION}.${MINOR_VERSION}.dll"; then \ (cd ${TOP_DIR}/win; ${MAKE} tcldde14.dll tclreg13.dll); \ 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 # The dependency on OBJS is not there because we just want the list of objects # here, not actually building them @@ -645,22 +648,45 @@ ${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 +basekit.vfs: + @echo "Building VFS File system in basekit.vfs" + @$(TCL_EXE) "$(TOP_DIR)/tools/mkVfs.tcl" \ + "$(UNIX_DIR)/basekit.vfs/boot/tcl" "$(TOP_DIR)" unix + +# Builds an executable directly from the Tcl sources +${BASEKIT_EXE}: ${TCLSH_OBJS} ${OBJS} ${ZLIB_OBJS} basekit.vfs + + ${CC} ${CFLAGS} ${LDFLAGS} \ + ${TCLSH_OBJS} ${OBJS} ${ZLIB_OBJS} \ + ${LIBS} @EXTRA_TCLSH_LIBS@ \ + ${CC_SEARCH_FLAGS} -o ${BASEKIT_EXE}_bare + @echo zipping... + @$(TCL_EXE) ../tools/mkzip.tcl ${BASEKIT_EXE} \ + -runtime ${BASEKIT_EXE}_bare \ + -directory basekit.vfs + chmod a+x ${BASEKIT_EXE} + Makefile: $(UNIX_DIR)/Makefile.in $(DLTEST_DIR)/Makefile.in $(SHELL) config.status #tclConfig.h: $(UNIX_DIR)/tclConfig.h.in # $(SHELL) config.status clean: clean-packages + rm -rf basekit.vfs null.zip 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@ \ + ${BASEKIT_EXE} basekit* cd dltest ; $(MAKE) clean distclean: distclean-packages clean rm -rf Makefile config.status config.cache config.log tclConfig.sh \ tclConfig.h *.plist Tcl.framework tcl.pc @@ -800,10 +826,13 @@ @echo "Installing $(LIB_FILE) to $(DLL_INSTALL_DIR)/" @@INSTALL_LIB@ @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 ${BASEKIT_EXE} as $(BIN_INSTALL_DIR)/${BASEKIT_EXE}$(VERSION)${EXE_SUFFIX}" + @$(INSTALL_PROGRAM) ${BASEKIT_EXE} "$(BIN_INSTALL_DIR)/${BASEKIT_EXE}$(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)/" @$(INSTALL_DATA) $(UNIX_DIR)/tclooConfig.sh \ "$(CONFIG_INSTALL_DIR)/tclooConfig.sh" @@ -1022,11 +1051,15 @@ rm -f xtTestInit.o mv tclAppInit.o xtTestInit.o @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 \ $(GENERIC_DIR)/regcustom.h TCLREHDRS=$(GENERIC_DIR)/tclRegexp.h @@ -1321,10 +1354,16 @@ $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclUtf.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 tclTest.o: $(GENERIC_DIR)/tclTest.c $(IOHDR) $(TCLREHDRS) $(CC) -c $(APP_CC_SWITCHES) $(GENERIC_DIR)/tclTest.c Index: unix/tclAppInit.c ================================================================== --- unix/tclAppInit.c +++ unix/tclAppInit.c @@ -38,10 +38,13 @@ #ifndef MODULE_SCOPE # define MODULE_SCOPE extern #endif MODULE_SCOPE int TCL_LOCAL_APPINIT(Tcl_Interp *); MODULE_SCOPE int main(int, char **); +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 *); /* * 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() @@ -78,11 +81,15 @@ #endif #ifdef TCL_LOCAL_MAIN_HOOK TCL_LOCAL_MAIN_HOOK(&argc, &argv); #endif - + #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); Tcl_Main(argc, argv, TCL_LOCAL_APPINIT); return 0; /* Needed only to prevent compiler warning. */ } /* @@ -109,11 +116,15 @@ Tcl_Interp *interp) /* Interpreter for application. */ { if ((Tcl_Init)(interp) == TCL_ERROR) { return TCL_ERROR; } - + /* Load the ZipVfs package */ + Tcl_StaticPackage(interp, "zvfs", Zvfs_Init, Zvfs_SafeInit); + if(Zvfs_Init(interp) == TCL_ERROR) { + return TCL_ERROR; + } #ifdef TCL_XT_TEST if (Tclxttest_Init(interp) == TCL_ERROR) { return TCL_ERROR; } #endif Index: win/Makefile.in ================================================================== --- win/Makefile.in +++ win/Makefile.in @@ -100,10 +100,14 @@ TOMMATH_DIR = $(TOP_DIR)/libtommath WIN_DIR = $(TOP_DIR)/win 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@ GENERIC_DIR_NATIVE = $(shell $(CYGPATH) '$(GENERIC_DIR)' | sed 's!\\!/!g') @@ -143,10 +147,11 @@ 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) # For cross-compiled builds, TCL_EXE is the name of a tclsh executable that is # available *BEFORE* running make for the first time. Certain build targets @@ -294,11 +299,11 @@ tclTrace.$(OBJEXT) \ tclUtf.$(OBJEXT) \ tclUtil.$(OBJEXT) \ tclVar.$(OBJEXT) \ tclZlib.$(OBJEXT) - + TOMMATH_OBJS = \ bncore.${OBJEXT} \ bn_reverse.${OBJEXT} \ bn_fast_s_mp_mul_digs.${OBJEXT} \ bn_fast_s_mp_sqr.${OBJEXT} \ @@ -404,10 +409,12 @@ uncompr.$(OBJEXT) \ zutil.$(OBJEXT) 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 tcltest: $(TCLSH) $(TEST_DLL_FILE) @@ -421,10 +428,46 @@ $(TCLSH): $(TCLSH_OBJS) @LIBRARIES@ $(TCL_STUB_LIB_FILE) tclsh.$(RES) $(CC) $(CFLAGS) $(TCLSH_OBJS) $(TCL_LIB_FILE) $(TCL_STUB_LIB_FILE) $(LIBS) \ 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) $(CAT32): cat32.$(OBJEXT) $(CC) $(CFLAGS) cat32.$(OBJEXT) $(CC_EXENAME) $(LIBS) $(LDFLAGS_CONSOLE) @@ -484,10 +527,13 @@ $(CC) -c $(CC_SWITCHES) -DTCL_TEST @DEPARG@ $(CC_OBJNAME) 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 # and where it will look for its libraries (which can be different). We derive # this information from the variables which can be overridden by the user. As @@ -568,11 +614,11 @@ echo "Making directory $(LIB_INSTALL_DIR)/$$i"; \ $(MKDIR) $(LIB_INSTALL_DIR)/$$i; \ 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)/"; \ $(COPY) $$i "$(BIN_INSTALL_DIR)"; \ fi; \ @@ -733,12 +779,13 @@ cleanhelp: $(RM) *.hlp *.cnt *.GID *.rtf man2tcl.exe 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 \ tcl.hpj config.status.lineno @@ -866,8 +913,10 @@ .PHONY: all tcltest binaries libraries doc gendate gentommath_h install .PHONY: install-binaries install-libraries install-tzdata install-msgs .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. Index: win/makefile.bc ================================================================== --- win/makefile.bc +++ win/makefile.bc @@ -157,10 +157,11 @@ TCLPLUGINLIB = $(OUTDIR)\$(NAMEPREFIX)$(VERSION)p$(DBGX).lib 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 TCLDDEDLL = $(OUTDIR)\$(TCLDDEDLLNAME) TCLTEST = $(OUTDIR)\$(NAMEPREFIX)test.exe @@ -175,10 +176,14 @@ INCLUDE_INSTALL_DIR = $(INSTALLDIR)\include TCLSHOBJS = \ $(TMPDIR)\tclAppInit.obj +TCLKITOBJS = \ + $(TMP_DIR)\tclZipVfs.obj \ + $(TMPDIR)\tclKitInit.obj + TCLTESTOBJS = \ $(TMPDIR)\tclTest.obj \ $(TMPDIR)\tclTestObj.obj \ $(TMPDIR)\tclTestProcBodyObj.obj \ $(TMPDIR)\tclThreadTest.obj \ @@ -389,10 +394,15 @@ $(TCLTEST): $(TCLTESTOBJS) $(TCLLIB) $(TMPDIR)\$(NAMEPREFIX)sh.res $(link32) $(ldebug) -S:2400000 $(LNFLAGS) $(LNFLAGS_CONS) $(TOOLS32)\lib\c0x32 @&&! $(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),, \ $(TMPDIR)\$(NAMEPREFIX).res @@ -509,10 +519,14 @@ -DCFG_RUNTIME_PREFIX=\"$(RUNTIME_PREFIX)\" \ -o$(TMPDIR)\$@ $? $(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 $(TMPDIR)\tclWinReg.obj : $(WINDIR)\tclWinReg.c Index: win/makefile.vc ================================================================== --- win/makefile.vc +++ win/makefile.vc @@ -206,10 +206,13 @@ TCLSTUBLIBNAME = $(STUBPREFIX)$(VERSION).lib 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) TCLDDELIBNAME = $(PROJECT)dde$(DDEVERSION)$(SUFX:t=).$(EXT) @@ -241,10 +244,22 @@ $(TMP_DIR)\tclWinReg.obj \ $(TMP_DIR)\tclWinDde.obj \ !endif !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 \ $(TMP_DIR)\tclTestProcBodyObj.obj \ @@ -930,10 +945,13 @@ $(cc32) $(TCL_CFLAGS) -Fo$@ $? $(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$@ $? $(TMP_DIR)\tclPkgConfig.obj: $(GENERICDIR)\tclPkgConfig.c $(cc32) -DBUILD_tcl $(TCL_CFLAGS) \ @@ -951,10 +969,16 @@ $(TMP_DIR)\tclAppInit.obj: $(WINDIR)\tclAppInit.c $(cc32) $(TCL_CFLAGS) \ -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 $(TMP_DIR)\tclWinReg.obj: $(WINDIR)\tclWinReg.c Index: win/tclAppInit.c ================================================================== --- win/tclAppInit.c +++ win/tclAppInit.c @@ -25,10 +25,16 @@ #ifdef TCL_TEST 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; extern Tcl_PackageInitProc Dde_SafeInit; #endif @@ -121,11 +127,17 @@ } #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. */ } /* @@ -152,11 +164,17 @@ Tcl_Interp *interp) /* Interpreter for application. */ { 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; } Tcl_StaticPackage(interp, "registry", Registry_Init, NULL); ADDED win/tclkit.exe.manifest.in Index: win/tclkit.exe.manifest.in ================================================================== --- /dev/null +++ win/tclkit.exe.manifest.in @@ -0,0 +1,51 @@ + + + + Tcl self-contained executable (tclkit) + + + + + + + + + + + + + + + + + + + + + + true + + + + + + + + ADDED win/tclkit.rc Index: win/tclkit.rc ================================================================== --- /dev/null +++ win/tclkit.rc @@ -0,0 +1,82 @@ +// +// Version Resource Script +// + +#include +#include + +// +// 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"