diff options
-rw-r--r-- | doc/tclsh.1 | 9 | ||||
-rw-r--r-- | doc/zvfs.n | 114 | ||||
-rw-r--r-- | generic/tclBootVfs.h | 24 | ||||
-rwxr-xr-x | generic/tclZipVfs.c | 1720 | ||||
-rw-r--r-- | generic/tclZipVfsBoot.c | 86 | ||||
-rw-r--r-- | library/zvfstools/pkgIndex.tcl | 1 | ||||
-rw-r--r-- | library/zvfstools/zvfstools.tcl | 325 | ||||
-rw-r--r-- | tools/mkVfs.tcl | 93 | ||||
-rw-r--r-- | tools/mkzip.tcl | 5 | ||||
-rw-r--r-- | unix/Makefile.in | 67 | ||||
-rw-r--r-- | unix/tclAppInit.c | 21 | ||||
-rw-r--r-- | unix/tclKitInit.c | 86 | ||||
-rw-r--r-- | win/Makefile.in | 59 | ||||
-rw-r--r-- | win/makefile.bc | 14 | ||||
-rw-r--r-- | win/makefile.vc | 24 | ||||
-rw-r--r-- | win/tclAppInit.c | 22 | ||||
-rw-r--r-- | win/tclKitInit.c | 325 | ||||
-rw-r--r-- | win/tclkit.exe.manifest.in | 51 | ||||
-rw-r--r-- | win/tclkit.rc | 82 |
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" |