From 824b71f9590840c9ff84285235c46b111cee31a5 Mon Sep 17 00:00:00 2001 From: hypnotoad Date: Wed, 14 Sep 2016 13:33:32 +0000 Subject: Beginning work in earnest on Tip#430 and Tip#453 Renamed zipfs.c to tclZipfs.c. Eliminated tclZipfs.h. Removed the bootstrap introduced by Odie/Androwish. With zipfs in the core one only needs to specify the TclPreInitScript The project at least builds on OSX. Working on Windows under MSYS/MinGW next Added a local snapshot of practcl. --- generic/tclBasic.c | 3 + generic/tclIOUtil.c | 34 - generic/tclInt.h | 4 + generic/tclZipfs.c | 3915 ++++++++++++++++++++++++++++++++++++++ generic/tclZipfs.h | 48 - generic/zipfs.c | 4229 ------------------------------------------ library/practcl/pkgIndex.tcl | 11 + library/practcl/practcl.tcl | 4000 +++++++++++++++++++++++++++++++++++++++ unix/Makefile.in | 8 +- unix/tclAppInit.c | 18 +- win/Makefile.in | 15 +- win/makefile.vc | 2 +- win/tclAppInit.c | 17 +- 13 files changed, 7954 insertions(+), 4350 deletions(-) create mode 100644 generic/tclZipfs.c delete mode 100644 generic/tclZipfs.h delete mode 100644 generic/zipfs.c create mode 100644 library/practcl/pkgIndex.tcl create mode 100644 library/practcl/practcl.tcl diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 53023d8..3550d93 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -982,6 +982,9 @@ Tcl_CreateInterp(void) if (TclZlibInit(interp) != TCL_OK) { Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp))); } + if (TclZipfsInit(interp) != TCL_OK) { + Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp))); + } #endif TOP_CB(iPtr) = NULL; diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index e8fce01..397c3b1 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -190,8 +190,6 @@ const Tcl_Filesystem tclNativeFilesystem = { TclpObjChdir }; -MODULE_SCOPE Tcl_Filesystem zipfsFilesystem; - /* * Define the tail of the linked list. Note that for unconventional uses of * Tcl without a native filesystem, we may in the future wish to modify the @@ -1412,22 +1410,6 @@ TclFSNormalizeToUniquePath( Claim(); for (fsRecPtr=firstFsRecPtr; fsRecPtr!=NULL; fsRecPtr=fsRecPtr->nextPtr) { - if (fsRecPtr->fsPtr == &zipfsFilesystem) { - ClientData clientData = NULL; - /* - * Allow mounted zipfs filesystem to overtake entire normalisation. - * This is needed on unix for mounts on symlinks right below root. - */ - - if (fsRecPtr->fsPtr->pathInFilesystemProc != NULL) { - if (fsRecPtr->fsPtr->pathInFilesystemProc(pathPtr, - &clientData)!=-1) { - TclFSSetPathDetails(pathPtr, fsRecPtr->fsPtr, clientData); - break; - } - } - continue; - } if (fsRecPtr->fsPtr != &tclNativeFilesystem) { continue; } @@ -1452,9 +1434,6 @@ TclFSNormalizeToUniquePath( if (fsRecPtr->fsPtr == &tclNativeFilesystem) { continue; } - if (fsRecPtr->fsPtr == &zipfsFilesystem) { - continue; - } if (fsRecPtr->fsPtr->normalizePathProc != NULL) { startAt = fsRecPtr->fsPtr->normalizePathProc(interp, pathPtr, @@ -2935,19 +2914,6 @@ Tcl_FSChdir( } fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); - - if ((fsPtr != NULL) && (fsPtr != &tclNativeFilesystem)) { - /* - * Watch out for tilde substitution. - * Only valid in native filesystem. - */ - char *name = Tcl_GetString(pathPtr); - - if ((name != NULL) && (*name == '~')) { - fsPtr = &tclNativeFilesystem; - } - } - if (fsPtr != NULL) { if (fsPtr->chdirProc != NULL) { /* diff --git a/generic/tclInt.h b/generic/tclInt.h index da1b5c5..aaffd34 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3177,6 +3177,10 @@ MODULE_SCOPE Tcl_WideInt TclpGetWideClicks(void); MODULE_SCOPE double TclpWideClicksToNanoseconds(Tcl_WideInt clicks); #endif MODULE_SCOPE int TclZlibInit(Tcl_Interp *interp); +MODULE_SCOPE int TclZipfsInit(Tcl_Interp *interp); +MODULE_SCOPE int TclZipfsMount(Tcl_Interp *interp, const char *zipname, + const char *mntpt, const char *passwd); +MODULE_SCOPE int TclZipfsUnmount(Tcl_Interp *interp, const char *zipname); MODULE_SCOPE void * TclpThreadCreateKey(void); MODULE_SCOPE void TclpThreadDeleteKey(void *keyPtr); MODULE_SCOPE void TclpThreadSetMasterTSD(void *tsdKeyPtr, void *ptr); diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c new file mode 100644 index 0000000..01d46c6 --- /dev/null +++ b/generic/tclZipfs.c @@ -0,0 +1,3915 @@ +/* + * tclZipfs.c -- + * + * Implementation of the ZIP filesystem used in TIP 430 + * Adapted from the implentation for AndroWish. + * + * Coptright (c) 2016 Sean Woods + * Copyright (c) 2013-2015 Christian Werner + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +#include "tclInt.h" +#include "tclFileSystem.h" + +#if !defined(_WIN32) && !defined(_WIN64) +#include +#endif +#include +#include +#include +#include +#include +#include + +#ifdef HAVE_ZLIB +#include "zlib.h" +#include "zcrypt.h" + +#define ZIPFS_VOLUME "zipfs:/" +#define ZIPFS_VOLUME_LEN 7 + +/* + * Various constants and offsets found in ZIP archive files + */ + +#define ZIP_SIG_LEN 4 + +/* Local header of ZIP archive member (at very beginning of each member). */ +#define ZIP_LOCAL_HEADER_SIG 0x04034b50 +#define ZIP_LOCAL_HEADER_LEN 30 +#define ZIP_LOCAL_SIG_OFFS 0 +#define ZIP_LOCAL_VERSION_OFFS 4 +#define ZIP_LOCAL_FLAGS_OFFS 6 +#define ZIP_LOCAL_COMPMETH_OFFS 8 +#define ZIP_LOCAL_MTIME_OFFS 10 +#define ZIP_LOCAL_MDATE_OFFS 12 +#define ZIP_LOCAL_CRC32_OFFS 14 +#define ZIP_LOCAL_COMPLEN_OFFS 18 +#define ZIP_LOCAL_UNCOMPLEN_OFFS 22 +#define ZIP_LOCAL_PATHLEN_OFFS 26 +#define ZIP_LOCAL_EXTRALEN_OFFS 28 + +/* Central header of ZIP archive member at end of ZIP file. */ +#define ZIP_CENTRAL_HEADER_SIG 0x02014b50 +#define ZIP_CENTRAL_HEADER_LEN 46 +#define ZIP_CENTRAL_SIG_OFFS 0 +#define ZIP_CENTRAL_VERSIONMADE_OFFS 4 +#define ZIP_CENTRAL_VERSION_OFFS 6 +#define ZIP_CENTRAL_FLAGS_OFFS 8 +#define ZIP_CENTRAL_COMPMETH_OFFS 10 +#define ZIP_CENTRAL_MTIME_OFFS 12 +#define ZIP_CENTRAL_MDATE_OFFS 14 +#define ZIP_CENTRAL_CRC32_OFFS 16 +#define ZIP_CENTRAL_COMPLEN_OFFS 20 +#define ZIP_CENTRAL_UNCOMPLEN_OFFS 24 +#define ZIP_CENTRAL_PATHLEN_OFFS 28 +#define ZIP_CENTRAL_EXTRALEN_OFFS 30 +#define ZIP_CENTRAL_FCOMMENTLEN_OFFS 32 +#define ZIP_CENTRAL_DISKFILE_OFFS 34 +#define ZIP_CENTRAL_IATTR_OFFS 36 +#define ZIP_CENTRAL_EATTR_OFFS 38 +#define ZIP_CENTRAL_LOCALHDR_OFFS 42 + +/* Central end signature at very end of ZIP file. */ +#define ZIP_CENTRAL_END_SIG 0x06054b50 +#define ZIP_CENTRAL_END_LEN 22 +#define ZIP_CENTRAL_END_SIG_OFFS 0 +#define ZIP_CENTRAL_DISKNO_OFFS 4 +#define ZIP_CENTRAL_DISKDIR_OFFS 6 +#define ZIP_CENTRAL_ENTS_OFFS 8 +#define ZIP_CENTRAL_TOTALENTS_OFFS 10 +#define ZIP_CENTRAL_DIRSIZE_OFFS 12 +#define ZIP_CENTRAL_DIRSTART_OFFS 16 +#define ZIP_CENTRAL_COMMENTLEN_OFFS 20 + +#define ZIP_MIN_VERSION 20 +#define ZIP_COMPMETH_STORED 0 +#define ZIP_COMPMETH_DEFLATED 8 + +#define ZIP_PASSWORD_END_SIG 0x5a5a4b50 + +/* + * Macros to read and write 16 and 32 bit integers from/to ZIP archives. + */ + +#define zip_read_int(p) \ + ((p)[0] | ((p)[1] << 8) | ((p)[2] << 16) | ((p)[3] << 24)) +#define zip_read_short(p) \ + ((p)[0] | ((p)[1] << 8)) + +#define zip_write_int(p, v) \ + (p)[0] = (v) & 0xff; (p)[1] = ((v) >> 8) & 0xff; \ + (p)[2] = ((v) >> 16) & 0xff; (p)[3] = ((v) >> 24) & 0xff; +#define zip_write_short(p, v) \ + (p)[0] = (v) & 0xff; (p)[1] = ((v) >> 8) & 0xff; + +/* + * Windows drive letters. + */ + +#if defined(_WIN32) || defined(_WIN64) +#define HAS_DRIVES 1 +static const char drvletters[] = + "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"; +#else +#define HAS_DRIVES 0 +#endif + +/* + * Mutex to protect localtime(3) when no reentrant version available. + */ + +#if !defined(_WIN32) && !defined(_WIN64) +#ifndef HAVE_LOCALTIME_R +#ifdef TCL_THREADS +TCL_DECLARE_MUTEX(localtimeMutex) +#endif +#endif +#endif + +/* + * In-core description of mounted ZIP archive file. + */ + +typedef struct ZipFile { + char *name; /* Archive name */ + Tcl_Channel chan; /* Channel handle or NULL */ + unsigned char *data; /* Memory mapped or malloc'ed file */ + long length; /* Length of memory mapped file */ + unsigned char *tofree; /* Non-NULL if malloc'ed file */ + int nfiles; /* Number of files in archive */ + int baseoffs; /* Archive start */ + int baseoffsp; /* Password start */ + int centoffs; /* Archive directory start */ + char pwbuf[264]; /* Password buffer */ +#if defined(_WIN32) || defined(_WIN64) + HANDLE mh; +#endif + int nopen; /* Number of open files on archive */ + struct ZipEntry *entries; /* List of files in archive */ + struct ZipEntry *topents; /* List of top-level dirs in archive */ +#if HAS_DRIVES + int mntdrv; /* Drive letter of mount point */ +#endif + int mntptlen; /* Length of mount point */ + char mntpt[1]; /* Mount point */ +} ZipFile; + +/* + * In-core description of file contained in mounted ZIP archive. + */ + +typedef struct ZipEntry { + char *name; /* The full pathname of the virtual file */ + ZipFile *zipfile; /* The ZIP file holding this virtual file */ + long offset; /* Data offset into memory mapped ZIP file */ + int nbyte; /* Uncompressed size of the virtual file */ + int nbytecompr; /* Compressed size of the virtual file */ + int cmeth; /* Compress method */ + int isdir; /* Set to 1 if directory */ + int depth; /* Number of slashes in path. */ + int crc32; /* CRC-32 */ + int timestamp; /* Modification time */ + int isenc; /* True if data is encrypted */ + unsigned char *data; /* File data if written */ + struct ZipEntry *next; /* Next file in the same archive */ + struct ZipEntry *tnext; /* Next top-level dir in archive */ +} ZipEntry; + +/* + * File channel for file contained in mounted ZIP archive. + */ + +typedef struct ZipChannel { + ZipFile *zipfile; /* The ZIP file holding this channel */ + ZipEntry *zipentry; /* Pointer back to virtual file */ + unsigned long nmax; /* Max. size for write */ + unsigned long nbyte; /* Number of bytes of uncompressed data */ + unsigned long nread; /* Pos of next byte to be read from the channel */ + unsigned char *ubuf; /* Pointer to the uncompressed data */ + int iscompr; /* True if data is compressed */ + int isdir; /* Set to 1 if directory */ + int isenc; /* True if data is encrypted */ + int iswr; /* True if open for writing */ + unsigned long keys[3]; /* Key for decryption */ +} ZipChannel; + +/* + * Global variables. + * + * Most are kept in single ZipFS struct. When build with threading + * support this struct is protected by the ZipFSMutex (see below). + * + * The "fileHash" component is the process wide global table of all known + * ZIP archive members in all mounted ZIP archives. + * + * The "zipHash" components is the process wide global table of all mounted + * ZIP archive files. + */ + +static struct { + int initialized; /* True when initialized */ + int lock; /* RW lock, see below */ + int waiters; /* RW lock, see below */ + int wrmax; /* Maximum write size of a file */ + int idCount; /* Counter for channel names */ + Tcl_HashTable fileHash; /* File name to ZipEntry mapping */ + Tcl_HashTable zipHash; /* Mount to ZipFile mapping */ +} ZipFS = { + 0, 0, 0, 0, 0, +}; + +/* + * For password rotation. + */ + +static const char pwrot[16] = { + 0x00, 0x80, 0x40, 0xc0, 0x20, 0xa0, 0x60, 0xe0, + 0x10, 0x90, 0x50, 0xd0, 0x30, 0xb0, 0x70, 0xf0 +}; + +/* + * Table to compute CRC32. + */ + +static const unsigned int crc32tab[256] = { + 0x00000000, 0x77073096, 0xee0e612c, 0x990951ba, 0x076dc419, + 0x706af48f, 0xe963a535, 0x9e6495a3, 0x0edb8832, 0x79dcb8a4, + 0xe0d5e91e, 0x97d2d988, 0x09b64c2b, 0x7eb17cbd, 0xe7b82d07, + 0x90bf1d91, 0x1db71064, 0x6ab020f2, 0xf3b97148, 0x84be41de, + 0x1adad47d, 0x6ddde4eb, 0xf4d4b551, 0x83d385c7, 0x136c9856, + 0x646ba8c0, 0xfd62f97a, 0x8a65c9ec, 0x14015c4f, 0x63066cd9, + 0xfa0f3d63, 0x8d080df5, 0x3b6e20c8, 0x4c69105e, 0xd56041e4, + 0xa2677172, 0x3c03e4d1, 0x4b04d447, 0xd20d85fd, 0xa50ab56b, + 0x35b5a8fa, 0x42b2986c, 0xdbbbc9d6, 0xacbcf940, 0x32d86ce3, + 0x45df5c75, 0xdcd60dcf, 0xabd13d59, 0x26d930ac, 0x51de003a, + 0xc8d75180, 0xbfd06116, 0x21b4f4b5, 0x56b3c423, 0xcfba9599, + 0xb8bda50f, 0x2802b89e, 0x5f058808, 0xc60cd9b2, 0xb10be924, + 0x2f6f7c87, 0x58684c11, 0xc1611dab, 0xb6662d3d, 0x76dc4190, + 0x01db7106, 0x98d220bc, 0xefd5102a, 0x71b18589, 0x06b6b51f, + 0x9fbfe4a5, 0xe8b8d433, 0x7807c9a2, 0x0f00f934, 0x9609a88e, + 0xe10e9818, 0x7f6a0dbb, 0x086d3d2d, 0x91646c97, 0xe6635c01, + 0x6b6b51f4, 0x1c6c6162, 0x856530d8, 0xf262004e, 0x6c0695ed, + 0x1b01a57b, 0x8208f4c1, 0xf50fc457, 0x65b0d9c6, 0x12b7e950, + 0x8bbeb8ea, 0xfcb9887c, 0x62dd1ddf, 0x15da2d49, 0x8cd37cf3, + 0xfbd44c65, 0x4db26158, 0x3ab551ce, 0xa3bc0074, 0xd4bb30e2, + 0x4adfa541, 0x3dd895d7, 0xa4d1c46d, 0xd3d6f4fb, 0x4369e96a, + 0x346ed9fc, 0xad678846, 0xda60b8d0, 0x44042d73, 0x33031de5, + 0xaa0a4c5f, 0xdd0d7cc9, 0x5005713c, 0x270241aa, 0xbe0b1010, + 0xc90c2086, 0x5768b525, 0x206f85b3, 0xb966d409, 0xce61e49f, + 0x5edef90e, 0x29d9c998, 0xb0d09822, 0xc7d7a8b4, 0x59b33d17, + 0x2eb40d81, 0xb7bd5c3b, 0xc0ba6cad, 0xedb88320, 0x9abfb3b6, + 0x03b6e20c, 0x74b1d29a, 0xead54739, 0x9dd277af, 0x04db2615, + 0x73dc1683, 0xe3630b12, 0x94643b84, 0x0d6d6a3e, 0x7a6a5aa8, + 0xe40ecf0b, 0x9309ff9d, 0x0a00ae27, 0x7d079eb1, 0xf00f9344, + 0x8708a3d2, 0x1e01f268, 0x6906c2fe, 0xf762575d, 0x806567cb, + 0x196c3671, 0x6e6b06e7, 0xfed41b76, 0x89d32be0, 0x10da7a5a, + 0x67dd4acc, 0xf9b9df6f, 0x8ebeeff9, 0x17b7be43, 0x60b08ed5, + 0xd6d6a3e8, 0xa1d1937e, 0x38d8c2c4, 0x4fdff252, 0xd1bb67f1, + 0xa6bc5767, 0x3fb506dd, 0x48b2364b, 0xd80d2bda, 0xaf0a1b4c, + 0x36034af6, 0x41047a60, 0xdf60efc3, 0xa867df55, 0x316e8eef, + 0x4669be79, 0xcb61b38c, 0xbc66831a, 0x256fd2a0, 0x5268e236, + 0xcc0c7795, 0xbb0b4703, 0x220216b9, 0x5505262f, 0xc5ba3bbe, + 0xb2bd0b28, 0x2bb45a92, 0x5cb36a04, 0xc2d7ffa7, 0xb5d0cf31, + 0x2cd99e8b, 0x5bdeae1d, 0x9b64c2b0, 0xec63f226, 0x756aa39c, + 0x026d930a, 0x9c0906a9, 0xeb0e363f, 0x72076785, 0x05005713, + 0x95bf4a82, 0xe2b87a14, 0x7bb12bae, 0x0cb61b38, 0x92d28e9b, + 0xe5d5be0d, 0x7cdcefb7, 0x0bdbdf21, 0x86d3d2d4, 0xf1d4e242, + 0x68ddb3f8, 0x1fda836e, 0x81be16cd, 0xf6b9265b, 0x6fb077e1, + 0x18b74777, 0x88085ae6, 0xff0f6a70, 0x66063bca, 0x11010b5c, + 0x8f659eff, 0xf862ae69, 0x616bffd3, 0x166ccf45, 0xa00ae278, + 0xd70dd2ee, 0x4e048354, 0x3903b3c2, 0xa7672661, 0xd06016f7, + 0x4969474d, 0x3e6e77db, 0xaed16a4a, 0xd9d65adc, 0x40df0b66, + 0x37d83bf0, 0xa9bcae53, 0xdebb9ec5, 0x47b2cf7f, 0x30b5ffe9, + 0xbdbdf21c, 0xcabac28a, 0x53b39330, 0x24b4a3a6, 0xbad03605, + 0xcdd70693, 0x54de5729, 0x23d967bf, 0xb3667a2e, 0xc4614ab8, + 0x5d681b02, 0x2a6f2b94, 0xb40bbe37, 0xc30c8ea1, 0x5a05df1b, + 0x2d02ef8d, +}; + +/* + *------------------------------------------------------------------------- + * + * ReadLock, WriteLock, Unlock -- + * + * POSIX like rwlock functions to support multiple readers + * and single writer on internal structs. + * + * Limitations: + * - a read lock cannot be promoted to a write lock + * - a write lock may not be nested + * + *------------------------------------------------------------------------- + */ + +TCL_DECLARE_MUTEX(ZipFSMutex) + +#ifdef TCL_THREADS + +static Tcl_Condition ZipFSCond; + +static void +ReadLock(void) +{ + Tcl_MutexLock(&ZipFSMutex); + while (ZipFS.lock < 0) { + ZipFS.waiters++; + Tcl_ConditionWait(&ZipFSCond, &ZipFSMutex, NULL); + ZipFS.waiters--; + } + ZipFS.lock++; + Tcl_MutexUnlock(&ZipFSMutex); +} + +static void +WriteLock(void) +{ + Tcl_MutexLock(&ZipFSMutex); + while (ZipFS.lock != 0) { + ZipFS.waiters++; + Tcl_ConditionWait(&ZipFSCond, &ZipFSMutex, NULL); + ZipFS.waiters--; + } + ZipFS.lock = -1; + Tcl_MutexUnlock(&ZipFSMutex); +} + +static void +Unlock(void) +{ + Tcl_MutexLock(&ZipFSMutex); + if (ZipFS.lock > 0) { + --ZipFS.lock; + } else if (ZipFS.lock < 0) { + ZipFS.lock = 0; + } + if ((ZipFS.lock == 0) && (ZipFS.waiters > 0)) { + Tcl_ConditionNotify(&ZipFSCond); + } + Tcl_MutexUnlock(&ZipFSMutex); +} + +#else + +#define ReadLock() do {} while (0) +#define WriteLock() do {} while (0) +#define Unlock() do {} while (0) + +#endif + +/* + *------------------------------------------------------------------------- + * + * DosTimeDate, ToDosTime, ToDosDate -- + * + * Functions to perform conversions between DOS time stamps + * and POSIX time_t. + * + *------------------------------------------------------------------------- + */ + +static time_t +DosTimeDate(int dosDate, int dosTime) +{ + struct tm tm; + time_t ret; + + memset(&tm, 0, sizeof (tm)); + 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) << 1; + ret = mktime(&tm); + if (ret == (time_t) -1) { + /* fallback to 1980-01-01T00:00:00+00:00 (DOS epoch) */ + ret = (time_t) 315532800; + } + return ret; +} + +static int +ToDosTime(time_t when) +{ + struct tm *tmp, tm; + +#ifdef TCL_THREADS +#if defined(_WIN32) || defined(_WIN64) + /* Win32 uses thread local storage */ + tmp = localtime(&when); + tm = *tmp; +#else +#ifdef HAVE_LOCALTIME_R + tmp = &tm; + localtime_r(&when, tmp); +#else + Tcl_MutexLock(&localtimeMutex); + tmp = localtime(&when); + tm = *tmp; + Tcl_MutexUnlock(&localtimeMutex); +#endif +#endif +#else + tmp = localtime(&when); + tm = *tmp; +#endif + return (tm.tm_hour << 11) | (tm.tm_min << 5) | (tm.tm_sec >> 1); +} + +static int +ToDosDate(time_t when) +{ + struct tm *tmp, tm; + +#ifdef TCL_THREADS +#if defined(_WIN32) || defined(_WIN64) + /* Win32 uses thread local storage */ + tmp = localtime(&when); + tm = *tmp; +#else +#ifdef HAVE_LOCALTIME_R + tmp = &tm; + localtime_r(&when, tmp); +#else + Tcl_MutexLock(&localtimeMutex); + tmp = localtime(&when); + tm = *tmp; + Tcl_MutexUnlock(&localtimeMutex); +#endif +#endif +#else + tmp = localtime(&when); + tm = *tmp; +#endif + return ((tm.tm_year - 80) << 9) | ((tm.tm_mon + 1) << 5) | tm.tm_mday; +} + +/* + *------------------------------------------------------------------------- + * + * CountSlashes -- + * + * This function counts the number of slashes in a pathname string. + * + * Results: + * Number of slashes found in string. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static int +CountSlashes(const char *string) +{ + int count = 0; + const char *p = string; + + while (*p != '\0') { + if (*p == '/') { + count++; + } + p++; + } + return count; +} + +/* + *------------------------------------------------------------------------- + * + * CanonicalPath -- + * + * This function computes the canonical path from a directory + * and file name components into the specified Tcl_DString. + * + * Results: + * Returns the pointer to the canonical path contained in the + * specified Tcl_DString. + * + * Side effects: + * Modifies the specified Tcl_DString. + * + *------------------------------------------------------------------------- + */ + +static char * +CanonicalPath(const char *root, const char *tail, Tcl_DString *dsPtr,int ZIPFSPATH) +{ + char *path; + char *result; + int i, j, c, isunc = 0, isvfs=0, n=0; +#if HAS_DRIVES + int zipfspath=1; + if ((tail[0] != '\0') && (strchr(drvletters, tail[0]) != NULL) && + (tail[1] == ':')) { + tail += 2; + zipfspath=0; + } + /* UNC style path */ + if (tail[0] == '\\') { + root = ""; + ++tail; + zipfspath=0; + } + if (tail[0] == '\\') { + root = "/"; + ++tail; + zipfspath=0; + } + if(zipfspath) { +#endif + /* UNC style path */ + if(root && strncmp(root,ZIPFS_VOLUME,ZIPFS_VOLUME_LEN)==0) { + isvfs=1; + } else if (tail && strncmp(tail,ZIPFS_VOLUME,ZIPFS_VOLUME_LEN) == 0) { + isvfs=2; + } + if(isvfs!=1) { + if ((root[0] == '/') && (root[1] == '/')) { + isunc = 1; + } + } +#if HAS_DRIVES + } +#endif + if(isvfs!=2) { + if (tail[0] == '/') { + if(isvfs!=1) { + root = ""; + } + ++tail; + isunc = 0; + } + if (tail[0] == '/') { + if(isvfs!=1) { + root = "/"; + } + ++tail; + isunc = 1; + } + } + i = strlen(root); + j = strlen(tail); + if(isvfs==1) { + if(i>ZIPFS_VOLUME_LEN) { + Tcl_DStringSetLength(dsPtr, i + j + 1); + path = Tcl_DStringValue(dsPtr); + memcpy(path, root, i); + path[i++] = '/'; + memcpy(path + i, tail, j); + } else { + Tcl_DStringSetLength(dsPtr, i + j); + path = Tcl_DStringValue(dsPtr); + memcpy(path, root, i); + memcpy(path + i, tail, j); + } + } else if(isvfs==2) { + Tcl_DStringSetLength(dsPtr, j); + path = Tcl_DStringValue(dsPtr); + memcpy(path, tail, j); + } else { + if (ZIPFSPATH) { + Tcl_DStringSetLength(dsPtr, i + j + ZIPFS_VOLUME_LEN); + path = Tcl_DStringValue(dsPtr); + memcpy(path, ZIPFS_VOLUME, ZIPFS_VOLUME_LEN); + memcpy(path + ZIPFS_VOLUME_LEN + i , tail, j); + } else { + Tcl_DStringSetLength(dsPtr, i + j + 1); + path = Tcl_DStringValue(dsPtr); + memcpy(path, root, i); + path[i++] = '/'; + memcpy(path + i, tail, j); + } + } +#if HAS_DRIVES + for (i = 0; path[i] != '\0'; i++) { + if (path[i] == '\\') { + path[i] = '/'; + } + } +#endif + if(ZIPFSPATH) { + n=ZIPFS_VOLUME_LEN; + } else { + n=0; + } + for (i = j = n; (c = path[i]) != '\0'; i++) { + if (c == '/') { + int c2 = path[i + 1]; + if (c2 == '/') { + continue; + } + if (c2 == '.') { + int c3 = path[i + 2]; + if ((c3 == '/') || (c3 == '\0')) { + i++; + continue; + } + if ((c3 == '.') && + ((path[i + 3] == '/') || (path [i + 3] == '\0'))) { + i += 2; + while ((j > 0) && (path[j - 1] != '/')) { + j--; + } + if (j > isunc) { + --j; + while ((j > 1 + isunc) && (path[j - 2] == '/')) { + j--; + } + } + continue; + } + } + } + path[j++] = c; + } + if (j == 0) { + path[j++] = '/'; + } + path[j] = 0; + Tcl_DStringSetLength(dsPtr, j); + result=Tcl_DStringValue(dsPtr); + return result; +} + + + +/* + *------------------------------------------------------------------------- + * + * AbsolutePath -- + * + * This function computes the absolute path from a given + * (relative) path name into the specified Tcl_DString. + * + * Results: + * Returns the pointer to the absolute path contained in the + * specified Tcl_DString. + * + * Side effects: + * Modifies the specified Tcl_DString. + * + *------------------------------------------------------------------------- + */ + +static char * +AbsolutePath(const char *path, + Tcl_DString *dsPtr, + int ZIPFSPATH) +{ + char *result; + if (*path == '~') { + Tcl_DStringAppend(dsPtr, path, -1); + return Tcl_DStringValue(dsPtr); + } + if (*path != '/') { + Tcl_DString pwd; + + /* relative path */ + Tcl_DStringInit(&pwd); + Tcl_GetCwd(NULL, &pwd); + result = Tcl_DStringValue(&pwd); + result = CanonicalPath(result, path, dsPtr,ZIPFSPATH); + Tcl_DStringFree(&pwd); + } else { + /* absolute path */ + result = CanonicalPath("", path, dsPtr,ZIPFSPATH); + } + return result; +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSLookup -- + * + * This function returns the ZIP entry struct corresponding to + * the ZIP archive member of the given file name. + * + * Results: + * Returns the pointer to ZIP entry struct or NULL if the + * the given file name could not be found in the global list + * of ZIP archive members. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static ZipEntry * +ZipFSLookup(char *filename) +{ + char *realname; + + Tcl_HashEntry *hPtr; + ZipEntry *z; + Tcl_DString ds; + Tcl_DStringInit(&ds); + realname = AbsolutePath(filename, &ds, 1); + hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, realname); + z = hPtr ? (ZipEntry *) Tcl_GetHashValue(hPtr) : NULL; + Tcl_DStringFree(&ds); + return z; +} + +#ifdef NEVER_USED + +/* + *------------------------------------------------------------------------- + * + * ZipFSLookupMount -- + * + * This function returns an indication if the given file name + * corresponds to a mounted ZIP archive file. + * + * Results: + * Returns true, if the given file name is a mounted ZIP archive file. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSLookupMount(char *filename) +{ + char *realname; + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + ZipFile *zf; + Tcl_DString ds; + int match = 0; + Tcl_DStringInit(&ds); + realname = AbsolutePath(filename, &ds, 1); + hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); + while (hPtr != NULL) { + if ((zf = (ZipFile *) Tcl_GetHashValue(hPtr)) != NULL) { + if (strcmp(zf->mntpt, realname) == 0) { + match = 1; + break; + } + } + hPtr = Tcl_NextHashEntry(&search); + } + Tcl_DStringFree(&ds); + return match; +} +#endif + +/* + *------------------------------------------------------------------------- + * + * ZipFSCloseArchive -- + * + * This function closes a mounted ZIP archive file. + * + * Results: + * None. + * + * Side effects: + * A memory mapped ZIP archive is unmapped, allocated memory is + * released. + * + *------------------------------------------------------------------------- + */ + +static void +ZipFSCloseArchive(Tcl_Interp *interp, ZipFile *zf) +{ +#if defined(_WIN32) || defined(_WIN64) + if ((zf->data != NULL) && (zf->tofree == NULL)) { + UnmapViewOfFile(zf->data); + zf->data = NULL; + } + if (zf->mh != INVALID_HANDLE_VALUE) { + CloseHandle(zf->mh); + } +#else + if ((zf->data != MAP_FAILED) && (zf->tofree == NULL)) { + munmap(zf->data, zf->length); + zf->data = MAP_FAILED; + } +#endif + if (zf->tofree != NULL) { + Tcl_Free((char *) zf->tofree); + zf->tofree = NULL; + } + Tcl_Close(interp, zf->chan); + zf->chan = NULL; +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSOpenArchive -- + * + * This function opens a ZIP archive file for reading. An attempt + * is made to memory map that file. Otherwise it is read into + * an allocated memory buffer. The ZIP archive header is verified + * and must be valid for the function to succeed. When "needZip" + * is zero an embedded ZIP archive in an executable file is accepted. + * + * Results: + * TCL_OK on success, TCL_ERROR otherwise with an error message + * placed into the given "interp" if it is not NULL. + * + * Side effects: + * ZIP archive is memory mapped or read into allocated memory, + * the given ZipFile struct is filled with information about + * the ZIP archive file. + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSOpenArchive(Tcl_Interp *interp, const char *zipname, int needZip, + ZipFile *zf) +{ + int i; + ClientData handle; + unsigned char *p, *q; + +#if defined(_WIN32) || defined(_WIN64) + zf->data = NULL; + zf->mh = INVALID_HANDLE_VALUE; +#else + zf->data = MAP_FAILED; +#endif + zf->length = 0; + zf->nfiles = 0; + zf->baseoffs = zf->baseoffsp = 0; + zf->tofree = NULL; + zf->pwbuf[0] = 0; + zf->chan = Tcl_OpenFileChannel(interp, zipname, "r", 0); + if (zf->chan == NULL) { + return TCL_ERROR; + } + if (Tcl_GetChannelHandle(zf->chan, TCL_READABLE, &handle) != TCL_OK) { + if (Tcl_SetChannelOption(interp, zf->chan, "-translation", "binary") + != TCL_OK) { + goto error; + } + if (Tcl_SetChannelOption(interp, zf->chan, "-encoding", "binary") + != TCL_OK) { + goto error; + } + zf->length = Tcl_Seek(zf->chan, 0, SEEK_END); + if ((zf->length <= 0) || (zf->length > 64 * 1024 * 1024)) { + if (interp) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("illegal file size", -1)); + } + goto error; + } + Tcl_Seek(zf->chan, 0, SEEK_SET); + zf->tofree = zf->data = (unsigned char *) Tcl_AttemptAlloc(zf->length); + if (zf->tofree == NULL) { + if (interp) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("out of memory", -1)); + } + goto error; + } + i = Tcl_Read(zf->chan, (char *) zf->data, zf->length); + if (i != zf->length) { + if (interp) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("file read error", -1)); + } + goto error; + } + Tcl_Close(interp, zf->chan); + zf->chan = NULL; + } else { +#if defined(_WIN32) || defined(_WIN64) + zf->length = GetFileSize((HANDLE) handle, 0); + if ((zf->length == INVALID_FILE_SIZE) || + (zf->length < ZIP_CENTRAL_END_LEN)) { + if (interp != NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("invalid file size", -1)); + } + goto error; + } + zf->mh = CreateFileMapping((HANDLE) handle, 0, PAGE_READONLY, 0, + zf->length, 0); + if (zf->mh == INVALID_HANDLE_VALUE) { + if (interp != NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("file mapping failed", -1)); + } + goto error; + } + zf->data = MapViewOfFile(zf->mh, FILE_MAP_READ, 0, 0, zf->length); + if (zf->data == NULL) { + if (interp != NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("file mapping failed", -1)); + } + goto error; + } +#else + zf->length = lseek((int) (long) handle, 0, SEEK_END); + if ((zf->length == -1) || (zf->length < ZIP_CENTRAL_END_LEN)) { + if (interp != NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("invalid file size", -1)); + } + goto error; + } + lseek((int) (long) handle, 0, SEEK_SET); + zf->data = (unsigned char *) mmap(0, zf->length, PROT_READ, + MAP_FILE | MAP_PRIVATE, + (int) (long) handle, 0); + if (zf->data == MAP_FAILED) { + if (interp != NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("file mapping failed", -1)); + } + goto error; + } +#endif + } + p = zf->data + zf->length - ZIP_CENTRAL_END_LEN; + while (p >= zf->data) { + if (*p == (ZIP_CENTRAL_END_SIG & 0xFF)) { + if (zip_read_int(p) == ZIP_CENTRAL_END_SIG) { + break; + } + p -= ZIP_SIG_LEN; + } else { + --p; + } + } + if (p < zf->data) { + if (!needZip) { + zf->baseoffs = zf->baseoffsp = zf->length; + return TCL_OK; + } + if (interp != NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("wrong end signature", -1)); + } + goto error; + } + zf->nfiles = zip_read_short(p + ZIP_CENTRAL_ENTS_OFFS); + if (zf->nfiles == 0) { + if (!needZip) { + zf->baseoffs = zf->baseoffsp = zf->length; + return TCL_OK; + } + if (interp != NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("empty archive", -1)); + } + goto error; + } + q = zf->data + zip_read_int(p + ZIP_CENTRAL_DIRSTART_OFFS); + p -= zip_read_int(p + ZIP_CENTRAL_DIRSIZE_OFFS); + if ((p < zf->data) || (p > (zf->data + zf->length)) || + (q < zf->data) || (q > (zf->data + zf->length))) { + if (!needZip) { + zf->baseoffs = zf->baseoffsp = zf->length; + return TCL_OK; + } + if (interp != NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("archive directory not found", -1)); + } + goto error; + } + zf->baseoffs = zf->baseoffsp = p - q; + zf->centoffs = p - zf->data; + q = p; + for (i = 0; i < zf->nfiles; i++) { + int pathlen, comlen, extra; + + if ((q + ZIP_CENTRAL_HEADER_LEN) > (zf->data + zf->length)) { + if (interp != NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("wrong header length", -1)); + } + goto error; + } + if (zip_read_int(q) != ZIP_CENTRAL_HEADER_SIG) { + if (interp != NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("wrong header signature", -1)); + } + goto error; + } + pathlen = zip_read_short(q + ZIP_CENTRAL_PATHLEN_OFFS); + comlen = zip_read_short(q + ZIP_CENTRAL_FCOMMENTLEN_OFFS); + extra = zip_read_short(q + ZIP_CENTRAL_EXTRALEN_OFFS); + q += pathlen + comlen + extra + ZIP_CENTRAL_HEADER_LEN; + } + q = zf->data + zf->baseoffs; + if ((zf->baseoffs >= 6) && + (zip_read_int(q - 4) == ZIP_PASSWORD_END_SIG)) { + i = q[-5]; + if (q - 5 - i > zf->data) { + zf->pwbuf[0] = i; + memcpy(zf->pwbuf + 1, q - 5 - i, i); + zf->baseoffsp -= i ? (5 + i) : 0; + } + } + return TCL_OK; + +error: + ZipFSCloseArchive(interp, zf); + return TCL_ERROR; +} + +/* + *------------------------------------------------------------------------- + * + * TclZipfsMount -- + * + * This procedure is invoked to mount a given ZIP archive file on + * a given mountpoint with optional ZIP password. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * A ZIP archive file is read, analyzed and mounted, resources are + * allocated. + * + *------------------------------------------------------------------------- + */ + +int +TclZipfsMount(Tcl_Interp *interp, const char *zipname, const char *mntpt, + const char *passwd) +{ + char *realname, *p; + int i, pwlen, isNew; + ZipFile *zf, zf0; + ZipEntry *z; + Tcl_HashEntry *hPtr; + Tcl_DString ds, dsm, fpBuf; + unsigned char *q; + + ReadLock(); + if (!ZipFS.initialized) { + if (interp != NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("not initialized", -1)); + } + Unlock(); + return TCL_ERROR; + } + if (zipname == NULL) { + Tcl_HashSearch search; + int ret = TCL_OK; + + i = 0; + hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); + while (hPtr != NULL) { + if ((zf = (ZipFile *) Tcl_GetHashValue(hPtr)) != NULL) { + if (interp != NULL) { + Tcl_AppendElement(interp, zf->mntpt); + Tcl_AppendElement(interp, zf->name); + } + ++i; + } + hPtr = Tcl_NextHashEntry(&search); + } + if (interp == NULL) { + ret = (i > 0) ? TCL_OK : TCL_BREAK; + } + Unlock(); + return ret; + } + if (mntpt == NULL) { + if (interp == NULL) { + Unlock(); + return TCL_OK; + } + Tcl_DStringInit(&ds); + p = AbsolutePath(zipname, &ds, 0); + hPtr = Tcl_FindHashEntry(&ZipFS.zipHash, p); + if (hPtr != NULL) { + if ((zf = Tcl_GetHashValue(hPtr)) != NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj(zf->mntpt, zf->mntptlen)); + } + } + Unlock(); + Tcl_DStringFree(&ds); + return TCL_OK; + } + Unlock(); + pwlen = 0; + if (passwd != NULL) { + pwlen = strlen(passwd); + if ((pwlen > 255) || (strchr(passwd, 0xff) != NULL)) { + if (interp) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("illegal password", -1)); + } + return TCL_ERROR; + } + } + if (ZipFSOpenArchive(interp, zipname, 1, &zf0) != TCL_OK) { + return TCL_ERROR; + } + Tcl_DStringInit(&ds); + realname = AbsolutePath(zipname, &ds, 0); + /* + * Mount point can come from Tcl_GetNameOfExecutable() + * which sometimes is a relative or otherwise denormalized path. + * But an absolute name is needed as mount point here. + */ + Tcl_DStringInit(&dsm); + mntpt = CanonicalPath("", mntpt, &dsm, 1); + WriteLock(); + hPtr = Tcl_CreateHashEntry(&ZipFS.zipHash, realname, &isNew); + Tcl_DStringSetLength(&ds, 0); + if (!isNew) { + zf = (ZipFile *) Tcl_GetHashValue(hPtr); + if (interp != NULL) { + Tcl_AppendResult(interp, "already mounted on \"", zf->mntptlen ? + zf->mntpt : "/", "\"", (char *) NULL); + } + Unlock(); + Tcl_DStringFree(&ds); + Tcl_DStringFree(&dsm); + ZipFSCloseArchive(interp, &zf0); + return TCL_ERROR; + } + if (strcmp(mntpt, "/") == 0) { + mntpt = ""; + } + zf = (ZipFile *) Tcl_AttemptAlloc(sizeof (*zf) + strlen(mntpt) + 1); + if (zf == NULL) { + if (interp != NULL) { + Tcl_AppendResult(interp, "out of memory", (char *) NULL); + } + Unlock(); + Tcl_DStringFree(&ds); + Tcl_DStringFree(&dsm); + ZipFSCloseArchive(interp, &zf0); + return TCL_ERROR; + } + *zf = zf0; + zf->name = Tcl_GetHashKey(&ZipFS.zipHash, hPtr); + strcpy(zf->mntpt, mntpt); + zf->mntptlen = strlen(zf->mntpt); + zf->entries = NULL; + zf->topents = NULL; + zf->nopen = 0; + Tcl_SetHashValue(hPtr, (ClientData) zf); + if ((zf->pwbuf[0] == 0) && pwlen) { + int k = 0; + i = pwlen; + zf->pwbuf[k++] = i; + while (i > 0) { + zf->pwbuf[k] = (passwd[i - 1] & 0x0f) | + pwrot[(passwd[i - 1] >> 4) & 0x0f]; + k++; + i--; + } + zf->pwbuf[k] = '\0'; + } + if (mntpt[0] != '\0') { + z = (ZipEntry *) Tcl_Alloc(sizeof (*z)); + z->name = NULL; + z->tnext = NULL; + z->depth = CountSlashes(mntpt); + z->zipfile = zf; + z->isdir = 1; + z->isenc = 0; + z->offset = zf->baseoffs; + z->crc32 = 0; + z->timestamp = 0; + z->nbyte = z->nbytecompr = 0; + z->cmeth = ZIP_COMPMETH_STORED; + z->data = NULL; + hPtr = Tcl_CreateHashEntry(&ZipFS.fileHash, mntpt, &isNew); + if (!isNew) { + /* skip it */ + Tcl_Free((char *) z); + } else { + Tcl_SetHashValue(hPtr, (ClientData) z); + z->name = Tcl_GetHashKey(&ZipFS.fileHash, hPtr); + z->next = zf->entries; + zf->entries = z; + } + } + q = zf->data + zf->centoffs; + Tcl_DStringInit(&fpBuf); + for (i = 0; i < zf->nfiles; i++) { + int pathlen, comlen, extra, isdir = 0, dosTime, dosDate, nbcompr, offs; + unsigned char *lq, *gq = NULL; + char *fullpath, *path; + + pathlen = zip_read_short(q + ZIP_CENTRAL_PATHLEN_OFFS); + comlen = zip_read_short(q + ZIP_CENTRAL_FCOMMENTLEN_OFFS); + extra = zip_read_short(q + ZIP_CENTRAL_EXTRALEN_OFFS); + Tcl_DStringSetLength(&ds, 0); + Tcl_DStringAppend(&ds, (char *) q + ZIP_CENTRAL_HEADER_LEN, pathlen); + path = Tcl_DStringValue(&ds); + if ((pathlen > 0) && (path[pathlen - 1] == '/')) { + Tcl_DStringSetLength(&ds, pathlen - 1); + path = Tcl_DStringValue(&ds); + isdir = 1; + } + if ((strcmp(path, ".") == 0) || (strcmp(path, "..") == 0)) { + goto nextent; + } + lq = zf->data + zf->baseoffs + + zip_read_int(q + ZIP_CENTRAL_LOCALHDR_OFFS); + if ((lq < zf->data) || (lq > (zf->data + zf->length))) { + goto nextent; + } + nbcompr = zip_read_int(lq + ZIP_LOCAL_COMPLEN_OFFS); + if (!isdir && (nbcompr == 0) && + (zip_read_int(lq + ZIP_LOCAL_UNCOMPLEN_OFFS) == 0) && + (zip_read_int(lq + ZIP_LOCAL_CRC32_OFFS) == 0)) { + gq = q; + nbcompr = zip_read_int(gq + ZIP_CENTRAL_COMPLEN_OFFS); + } + offs = (lq - zf->data) + + ZIP_LOCAL_HEADER_LEN + + zip_read_short(lq + ZIP_LOCAL_PATHLEN_OFFS) + + zip_read_short(lq + ZIP_LOCAL_EXTRALEN_OFFS); + if ((offs + nbcompr) > zf->length) { + goto nextent; + } + if (!isdir && (mntpt[0] == '\0') && !CountSlashes(path)) { +#ifdef ANDROID + /* + * When mounting the ZIP archive on the root directory try + * to remap top level regular files of the archive to + * /assets/.root/... since this directory should not be + * in a valid APK due to the leading dot in the file name + * component. This trick should make the files + * AndroidManifest.xml, resources.arsc, and classes.dex + * visible to Tcl. + */ + Tcl_DString ds2; + + Tcl_DStringInit(&ds2); + Tcl_DStringAppend(&ds2, "assets/.root/", -1); + Tcl_DStringAppend(&ds2, path, -1); + hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, Tcl_DStringValue(&ds2)); + if (hPtr != NULL) { + /* should not happen but skip it anyway */ + Tcl_DStringFree(&ds2); + goto nextent; + } + Tcl_DStringSetLength(&ds, 0); + Tcl_DStringAppend(&ds, Tcl_DStringValue(&ds2), + Tcl_DStringLength(&ds2)); + path = Tcl_DStringValue(&ds); + Tcl_DStringFree(&ds2); +#else + /* + * Regular files skipped when mounting on root. + */ + goto nextent; +#endif + } + Tcl_DStringSetLength(&fpBuf, 0); + fullpath = CanonicalPath(mntpt, path, &fpBuf, 1); + z = (ZipEntry *) Tcl_Alloc(sizeof (*z)); + z->name = NULL; + z->tnext = NULL; + z->depth = CountSlashes(fullpath); + z->zipfile = zf; + z->isdir = isdir; + z->isenc = (zip_read_short(lq + ZIP_LOCAL_FLAGS_OFFS) & 1) + && (nbcompr > 12); + z->offset = offs; + if (gq != NULL) { + z->crc32 = zip_read_int(gq + ZIP_CENTRAL_CRC32_OFFS); + dosDate = zip_read_short(gq + ZIP_CENTRAL_MDATE_OFFS); + dosTime = zip_read_short(gq + ZIP_CENTRAL_MTIME_OFFS); + z->timestamp = DosTimeDate(dosDate, dosTime); + z->nbyte = zip_read_int(gq + ZIP_CENTRAL_UNCOMPLEN_OFFS); + z->cmeth = zip_read_short(gq + ZIP_CENTRAL_COMPMETH_OFFS); + } else { + z->crc32 = zip_read_int(lq + ZIP_LOCAL_CRC32_OFFS); + dosDate = zip_read_short(lq + ZIP_LOCAL_MDATE_OFFS); + dosTime = zip_read_short(lq + ZIP_LOCAL_MTIME_OFFS); + z->timestamp = DosTimeDate(dosDate, dosTime); + z->nbyte = zip_read_int(lq + ZIP_LOCAL_UNCOMPLEN_OFFS); + z->cmeth = zip_read_short(lq + ZIP_LOCAL_COMPMETH_OFFS); + } + z->nbytecompr = nbcompr; + z->data = NULL; + hPtr = Tcl_CreateHashEntry(&ZipFS.fileHash, fullpath, &isNew); + if (!isNew) { + /* should not happen but skip it anyway */ + Tcl_Free((char *) z); + } else { + Tcl_SetHashValue(hPtr, (ClientData) z); + z->name = Tcl_GetHashKey(&ZipFS.fileHash, hPtr); + z->next = zf->entries; + zf->entries = z; + if (isdir && (mntpt[0] == '\0') && (z->depth == 1)) { + z->tnext = zf->topents; + zf->topents = z; + } + if (!z->isdir && (z->depth > 1)) { + char *dir, *end; + ZipEntry *zd; + + Tcl_DStringSetLength(&ds, strlen(z->name) + 8); + Tcl_DStringSetLength(&ds, 0); + Tcl_DStringAppend(&ds, z->name, -1); + dir = Tcl_DStringValue(&ds); + end = strrchr(dir, '/'); + while ((end != NULL) && (end != dir)) { + Tcl_DStringSetLength(&ds, end - dir); + hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, dir); + if (hPtr != NULL) { + break; + } + zd = (ZipEntry *) Tcl_Alloc(sizeof (*zd)); + zd->name = NULL; + zd->tnext = NULL; + zd->depth = CountSlashes(dir); + zd->zipfile = zf; + zd->isdir = 1; + zd->isenc = 0; + zd->offset = z->offset; + zd->crc32 = 0; + zd->timestamp = z->timestamp; + zd->nbyte = zd->nbytecompr = 0; + zd->cmeth = ZIP_COMPMETH_STORED; + zd->data = NULL; + hPtr = Tcl_CreateHashEntry(&ZipFS.fileHash, dir, &isNew); + if (!isNew) { + /* should not happen but skip it anyway */ + Tcl_Free((char *) zd); + } else { + Tcl_SetHashValue(hPtr, (ClientData) zd); + zd->name = Tcl_GetHashKey(&ZipFS.fileHash, hPtr); + zd->next = zf->entries; + zf->entries = zd; + if ((mntpt[0] == '\0') && (zd->depth == 1)) { + zd->tnext = zf->topents; + zf->topents = zd; + } + } + end = strrchr(dir, '/'); + } + } + } +nextent: + q += pathlen + comlen + extra + ZIP_CENTRAL_HEADER_LEN; + } + Unlock(); + Tcl_DStringFree(&fpBuf); + Tcl_DStringFree(&ds); + Tcl_DStringFree(&dsm); + Tcl_FSMountsChanged(NULL); + return TCL_OK; +} + +/* + *------------------------------------------------------------------------- + * + * TclZipfsUnmount -- + * + * This procedure is invoked to unmount a given ZIP archive. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * A mounted ZIP archive file is unmounted, resources are free'd. + * + *------------------------------------------------------------------------- + */ + +int +TclZipfsUnmount(Tcl_Interp *interp, const char *zipname) +{ + char *realname; + ZipFile *zf; + ZipEntry *z, *znext; + Tcl_HashEntry *hPtr; + Tcl_DString ds; + int ret = TCL_OK, unmounted = 0; + + Tcl_DStringInit(&ds); + realname = AbsolutePath(zipname, &ds, 0); + WriteLock(); + if (!ZipFS.initialized) { + goto done; + } + hPtr = Tcl_FindHashEntry(&ZipFS.zipHash, realname); + if (hPtr == NULL) { + /* don't report error */ + goto done; + } + zf = (ZipFile *) Tcl_GetHashValue(hPtr); + if (zf->nopen > 0) { + if (interp != NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("filesystem is busy", -1)); + } + ret = TCL_ERROR; + goto done; + } + Tcl_DeleteHashEntry(hPtr); + for (z = zf->entries; z; z = znext) { + znext = z->next; + hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, z->name); + if (hPtr) { + Tcl_DeleteHashEntry(hPtr); + } + if (z->data != NULL) { + Tcl_Free((char *) z->data); + } + Tcl_Free((char *) z); + } + ZipFSCloseArchive(interp, zf); + Tcl_Free((char *) zf); + unmounted = 1; +done: + Unlock(); + Tcl_DStringFree(&ds); + if (unmounted) { + Tcl_FSMountsChanged(NULL); + } + return ret; +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSMountObjCmd -- + * + * This procedure is invoked to process the "zipfs::mount" command. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * A ZIP archive file is mounted, resources are allocated. + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSMountObjCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]) +{ + if (objc > 4) { + Tcl_WrongNumArgs(interp, 1, objv, + "?zipfile? ?mountpoint? ?password?"); + return TCL_ERROR; + } + return TclZipfsMount(interp, (objc > 1) ? Tcl_GetString(objv[1]) : NULL, + (objc > 2) ? Tcl_GetString(objv[2]) : NULL, + (objc > 3) ? Tcl_GetString(objv[3]) : NULL); +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSUnmountObjCmd -- + * + * This procedure is invoked to process the "zipfs::unmount" command. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * A mounted ZIP archive file is unmounted, resources are free'd. + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSUnmountObjCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]) +{ + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "zipfile"); + return TCL_ERROR; + } + return TclZipfsUnmount(interp, Tcl_GetString(objv[1])); +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSMkKeyObjCmd -- + * + * This procedure is invoked to process the "zipfs::mkkey" command. + * It produces a rotated password to be embedded into an image file. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSMkKeyObjCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]) +{ + int len, i = 0; + char *pw, pwbuf[264]; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "password"); + return TCL_ERROR; + } + pw = Tcl_GetString(objv[1]); + len = strlen(pw); + if (len == 0) { + return TCL_OK; + } + if ((len > 255) || (strchr(pw, 0xff) != NULL)) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("illegal password", -1)); + return TCL_ERROR; + } + while (len > 0) { + int ch = pw[len - 1]; + + pwbuf[i] = (ch & 0x0f) | pwrot[(ch >> 4) & 0x0f]; + i++; + len--; + } + pwbuf[i] = i; + ++i; + pwbuf[i++] = (char) ZIP_PASSWORD_END_SIG; + pwbuf[i++] = (char) (ZIP_PASSWORD_END_SIG >> 8); + pwbuf[i++] = (char) (ZIP_PASSWORD_END_SIG >> 16); + pwbuf[i++] = (char) (ZIP_PASSWORD_END_SIG >> 24); + pwbuf[i] = '\0'; + Tcl_AppendResult(interp, pwbuf, (char *) NULL); + return TCL_OK; +} + +/* + *------------------------------------------------------------------------- + * + * ZipAddFile -- + * + * This procedure is used by ZipFSMkZipOrImgCmd() to add a single + * file to the output ZIP archive file being written. A ZipEntry + * struct about the input file is added to the given fileHash table + * for later creation of the central ZIP directory. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Input file is read and (compressed and) written to the output + * ZIP archive file. + * + *------------------------------------------------------------------------- + */ + +static int +ZipAddFile(Tcl_Interp *interp, const char *path, const char *name, + Tcl_Channel out, const char *passwd, + char *buf, int bufsize, Tcl_HashTable *fileHash) +{ + Tcl_Channel in; + Tcl_HashEntry *hPtr; + ZipEntry *z; + z_stream stream; + const char *zpath; + int nbyte, nbytecompr, len, crc, flush, pos[3], zpathlen, olen; + int mtime = 0, isNew, align = 0, cmeth; + unsigned long keys[3], keys0[3]; + char obuf[4096]; + + zpath = name; + while (zpath != NULL && zpath[0] == '/') { + zpath++; + } + if ((zpath == NULL) || (zpath[0] == '\0')) { + return TCL_OK; + } + zpathlen = strlen(zpath); + if (zpathlen + ZIP_CENTRAL_HEADER_LEN > bufsize) { + Tcl_AppendResult(interp, "path too long for \"", path, "\"", + (char *) NULL); + return TCL_ERROR; + } + in = Tcl_OpenFileChannel(interp, path, "r", 0); + if ((in == NULL) || + (Tcl_SetChannelOption(interp, in, "-translation", "binary") + != TCL_OK) || + (Tcl_SetChannelOption(interp, in, "-encoding", "binary") + != TCL_OK)) { +#if defined(_WIN32) || defined(_WIN64) + /* hopefully a directory */ + if (strcmp("permission denied", Tcl_PosixError(interp)) == 0) { + Tcl_Close(interp, in); + return TCL_OK; + } +#endif + Tcl_Close(interp, in); + return TCL_ERROR; + } else { + Tcl_Obj *pathObj = Tcl_NewStringObj(path, -1); + Tcl_StatBuf statBuf; + + Tcl_IncrRefCount(pathObj); + if (Tcl_FSStat(pathObj, &statBuf) != -1) { + mtime = statBuf.st_mtime; + } + Tcl_DecrRefCount(pathObj); + } + Tcl_ResetResult(interp); + crc = 0; + nbyte = nbytecompr = 0; + while ((len = Tcl_Read(in, buf, bufsize)) > 0) { + crc = crc32(crc, (unsigned char *) buf, len); + nbyte += len; + } + if (len == -1) { + if (nbyte == 0) { + if (strcmp("illegal operation on a directory", + Tcl_PosixError(interp)) == 0) { + Tcl_Close(interp, in); + return TCL_OK; + } + } + Tcl_AppendResult(interp, "read error on \"", path, "\"", + (char *) NULL); + Tcl_Close(interp, in); + return TCL_ERROR; + } + if (Tcl_Seek(in, 0, SEEK_SET) == -1) { + Tcl_AppendResult(interp, "seek error on \"", path, "\"", + (char *) NULL); + Tcl_Close(interp, in); + return TCL_ERROR; + } + pos[0] = Tcl_Tell(out); + memset(buf, '\0', ZIP_LOCAL_HEADER_LEN); + memcpy(buf + ZIP_LOCAL_HEADER_LEN, zpath, zpathlen); + len = zpathlen + ZIP_LOCAL_HEADER_LEN; + if (Tcl_Write(out, buf, len) != len) { +wrerr: + Tcl_AppendResult(interp, "write error", (char *) NULL); + Tcl_Close(interp, in); + return TCL_ERROR; + } + if ((len + pos[0]) & 3) { + char abuf[8]; + + /* + * Align payload to next 4-byte boundary using a dummy extra + * entry similar to the zipalign tool from Android's SDK. + */ + align = 4 + ((len + pos[0]) & 3); + zip_write_short(abuf, 0xffff); + zip_write_short(abuf + 2, align - 4); + zip_write_int(abuf + 4, 0x03020100); + if (Tcl_Write(out, abuf, align) != align) { + goto wrerr; + } + } + if (passwd != NULL) { + int i, ch, tmp; + unsigned char kvbuf[24]; + Tcl_Obj *ret; + + init_keys(passwd, keys, crc32tab); + for (i = 0; i < 12 - 2; i++) { + if (Tcl_EvalEx(interp, "expr int(rand() * 256) % 256", -1, 0) != TCL_OK) { + Tcl_AppendResult(interp, "PRNG error", (char *) NULL); + Tcl_Close(interp, in); + return TCL_ERROR; + } + ret = Tcl_GetObjResult(interp); + if (Tcl_GetIntFromObj(interp, ret, &ch) != TCL_OK) { + Tcl_Close(interp, in); + return TCL_ERROR; + } + kvbuf[i + 12] = (unsigned char) zencode(keys, crc32tab, ch, tmp); + } + Tcl_ResetResult(interp); + init_keys(passwd, keys, crc32tab); + for (i = 0; i < 12 - 2; i++) { + kvbuf[i] = (unsigned char) zencode(keys, crc32tab, + kvbuf[i + 12], tmp); + } + kvbuf[i++] = (unsigned char) zencode(keys, crc32tab, crc >> 16, tmp); + kvbuf[i++] = (unsigned char) zencode(keys, crc32tab, crc >> 24, tmp); + len = Tcl_Write(out, (char *) kvbuf, 12); + memset(kvbuf, 0, 24); + if (len != 12) { + Tcl_AppendResult(interp, "write error", (char *) NULL); + Tcl_Close(interp, in); + return TCL_ERROR; + } + memcpy(keys0, keys, sizeof (keys0)); + nbytecompr += 12; + } + Tcl_Flush(out); + pos[2] = Tcl_Tell(out); + cmeth = ZIP_COMPMETH_DEFLATED; + memset(&stream, 0, sizeof (stream)); + stream.zalloc = Z_NULL; + stream.zfree = Z_NULL; + stream.opaque = Z_NULL; + if (deflateInit2(&stream, 9, Z_DEFLATED, -15, 8, Z_DEFAULT_STRATEGY) + != Z_OK) { + Tcl_AppendResult(interp, "compression init error on \"", path, "\"", + (char *) NULL); + Tcl_Close(interp, in); + return TCL_ERROR; + } + do { + len = Tcl_Read(in, buf, bufsize); + if (len == -1) { + Tcl_AppendResult(interp, "read error on \"", path, "\"", + (char *) NULL); + deflateEnd(&stream); + Tcl_Close(interp, in); + return TCL_ERROR; + } + stream.avail_in = len; + stream.next_in = (unsigned char *) buf; + flush = Tcl_Eof(in) ? Z_FINISH : Z_NO_FLUSH; + do { + stream.avail_out = sizeof (obuf); + stream.next_out = (unsigned char *) obuf; + len = deflate(&stream, flush); + if (len == Z_STREAM_ERROR) { + Tcl_AppendResult(interp, "deflate error on \"", path, "\"", + (char *) NULL); + deflateEnd(&stream); + Tcl_Close(interp, in); + return TCL_ERROR; + } + olen = sizeof (obuf) - stream.avail_out; + if (passwd != NULL) { + int i, tmp; + + for (i = 0; i < olen; i++) { + obuf[i] = (char) zencode(keys, crc32tab, obuf[i], tmp); + } + } + if (olen && (Tcl_Write(out, obuf, olen) != olen)) { + Tcl_AppendResult(interp, "write error", (char *) NULL); + deflateEnd(&stream); + Tcl_Close(interp, in); + return TCL_ERROR; + } + nbytecompr += olen; + } while (stream.avail_out == 0); + } while (flush != Z_FINISH); + deflateEnd(&stream); + Tcl_Flush(out); + pos[1] = Tcl_Tell(out); + if (nbyte - nbytecompr <= 0) { + /* + * Compressed file larger than input, + * write it again uncompressed. + */ + if ((int) Tcl_Seek(in, 0, SEEK_SET) != 0) { + goto seekErr; + } + if ((int) Tcl_Seek(out, pos[2], SEEK_SET) != pos[2]) { +seekErr: + Tcl_Close(interp, in); + Tcl_AppendResult(interp, "seek error", (char *) NULL); + return TCL_ERROR; + } + nbytecompr = (passwd != NULL) ? 12 : 0; + while (1) { + len = Tcl_Read(in, buf, bufsize); + if (len == -1) { + Tcl_AppendResult(interp, "read error on \"", path, "\"", + (char *) NULL); + Tcl_Close(interp, in); + return TCL_ERROR; + } else if (len == 0) { + break; + } + if (passwd != NULL) { + int i, tmp; + + for (i = 0; i < len; i++) { + buf[i] = (char) zencode(keys0, crc32tab, buf[i], tmp); + } + } + if (Tcl_Write(out, buf, len) != len) { + Tcl_AppendResult(interp, "write error", (char *) NULL); + Tcl_Close(interp, in); + return TCL_ERROR; + } + nbytecompr += len; + } + cmeth = ZIP_COMPMETH_STORED; + Tcl_Flush(out); + pos[1] = Tcl_Tell(out); + Tcl_TruncateChannel(out, pos[1]); + } + Tcl_Close(interp, in); + + z = (ZipEntry *) Tcl_Alloc(sizeof (*z)); + z->name = NULL; + z->tnext = NULL; + z->depth = 0; + z->zipfile = NULL; + z->isdir = 0; + z->isenc = (passwd != NULL) ? 1 : 0; + z->offset = pos[0]; + z->crc32 = crc; + z->timestamp = mtime; + z->nbyte = nbyte; + z->nbytecompr = nbytecompr; + z->cmeth = cmeth; + z->data = NULL; + hPtr = Tcl_CreateHashEntry(fileHash, zpath, &isNew); + if (!isNew) { + Tcl_AppendResult(interp, "non-unique path name \"", path, "\"", + (char *) NULL); + Tcl_Free((char *) z); + return TCL_ERROR; + } else { + Tcl_SetHashValue(hPtr, (ClientData) z); + z->name = Tcl_GetHashKey(fileHash, hPtr); + z->next = NULL; + } + + /* + * Write final local header information. + */ + zip_write_int(buf + ZIP_LOCAL_SIG_OFFS, ZIP_LOCAL_HEADER_SIG); + zip_write_short(buf + ZIP_LOCAL_VERSION_OFFS, ZIP_MIN_VERSION); + zip_write_short(buf + ZIP_LOCAL_FLAGS_OFFS, z->isenc); + zip_write_short(buf + ZIP_LOCAL_COMPMETH_OFFS, z->cmeth); + zip_write_short(buf + ZIP_LOCAL_MTIME_OFFS, ToDosTime(z->timestamp)); + zip_write_short(buf + ZIP_LOCAL_MDATE_OFFS, ToDosDate(z->timestamp)); + zip_write_int(buf + ZIP_LOCAL_CRC32_OFFS, z->crc32); + zip_write_int(buf + ZIP_LOCAL_COMPLEN_OFFS, z->nbytecompr); + zip_write_int(buf + ZIP_LOCAL_UNCOMPLEN_OFFS, z->nbyte); + zip_write_short(buf + ZIP_LOCAL_PATHLEN_OFFS, zpathlen); + zip_write_short(buf + ZIP_LOCAL_EXTRALEN_OFFS, align); + if ((int) Tcl_Seek(out, pos[0], SEEK_SET) != pos[0]) { + Tcl_DeleteHashEntry(hPtr); + Tcl_Free((char *) z); + Tcl_AppendResult(interp, "seek error", (char *) NULL); + return TCL_ERROR; + } + if (Tcl_Write(out, buf, ZIP_LOCAL_HEADER_LEN) != ZIP_LOCAL_HEADER_LEN) { + Tcl_DeleteHashEntry(hPtr); + Tcl_Free((char *) z); + Tcl_AppendResult(interp, "write error", (char *) NULL); + return TCL_ERROR; + } + Tcl_Flush(out); + if ((int) Tcl_Seek(out, pos[1], SEEK_SET) != pos[1]) { + Tcl_DeleteHashEntry(hPtr); + Tcl_Free((char *) z); + Tcl_AppendResult(interp, "seek error", (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSMkZipOrImgObjCmd -- + * + * This procedure is creates a new ZIP archive file or image file + * given output filename, input directory of files to be archived, + * optional password, and optional image to be prepended to the + * output ZIP archive file. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * A new ZIP archive file or image file is written. + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSMkZipOrImgObjCmd(ClientData clientData, Tcl_Interp *interp, + int isImg, int isList, int objc, Tcl_Obj *const objv[]) +{ + Tcl_Channel out; + int len = 0, pwlen = 0, slen = 0, i, count, ret = TCL_ERROR, lobjc, pos[3]; + Tcl_Obj **lobjv, *list = NULL; + ZipEntry *z; + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + Tcl_HashTable fileHash; + char *strip = NULL, *pw = NULL, pwbuf[264], buf[4096]; + + if (isList) { + if ((objc < 3) || (objc > (isImg ? 5 : 4))) { + Tcl_WrongNumArgs(interp, 1, objv, isImg ? + "outfile inlist ?password infile?" : + "outfile inlist ?password?"); + return TCL_ERROR; + } + } else { + if ((objc < 3) || (objc > (isImg ? 6 : 5))) { + Tcl_WrongNumArgs(interp, 1, objv, isImg ? + "outfile indir ?strip? ?password? ?infile?" : + "outfile indir ?strip? ?password?"); + return TCL_ERROR; + } + } + pwbuf[0] = 0; + if (objc > (isList ? 3 : 4)) { + pw = Tcl_GetString(objv[isList ? 3 : 4]); + pwlen = strlen(pw); + if ((pwlen > 255) || (strchr(pw, 0xff) != NULL)) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("illegal password", -1)); + return TCL_ERROR; + } + } + if (isList) { + list = objv[2]; + Tcl_IncrRefCount(list); + } else { + Tcl_Obj *cmd[3]; + + cmd[1] = Tcl_NewStringObj("::zipfs::find", -1); + cmd[2] = objv[2]; + cmd[0] = Tcl_NewListObj(2, cmd + 1); + Tcl_IncrRefCount(cmd[0]); + if (Tcl_EvalObjEx(interp, cmd[0], TCL_EVAL_DIRECT) != TCL_OK) { + Tcl_DecrRefCount(cmd[0]); + return TCL_ERROR; + } + Tcl_DecrRefCount(cmd[0]); + list = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(list); + } + if (Tcl_ListObjGetElements(interp, list, &lobjc, &lobjv) != TCL_OK) { + Tcl_DecrRefCount(list); + return TCL_ERROR; + } + if (isList && (lobjc % 2)) { + Tcl_DecrRefCount(list); + Tcl_SetObjResult(interp, + Tcl_NewStringObj("need even number of elements", -1)); + return TCL_ERROR; + } + if (lobjc == 0) { + Tcl_DecrRefCount(list); + Tcl_SetObjResult(interp, Tcl_NewStringObj("empty archive", -1)); + return TCL_ERROR; + } + out = Tcl_OpenFileChannel(interp, Tcl_GetString(objv[1]), "w", 0755); + if ((out == NULL) || + (Tcl_SetChannelOption(interp, out, "-translation", "binary") + != TCL_OK) || + (Tcl_SetChannelOption(interp, out, "-encoding", "binary") + != TCL_OK)) { + Tcl_DecrRefCount(list); + Tcl_Close(interp, out); + return TCL_ERROR; + } + if (isImg) { + ZipFile zf0; + const char *imgName; + + if (isList) { + imgName = (objc > 4) ? Tcl_GetString(objv[4]) : + Tcl_GetNameOfExecutable(); + } else { + imgName = (objc > 5) ? Tcl_GetString(objv[5]) : + Tcl_GetNameOfExecutable(); + } + if (ZipFSOpenArchive(interp, imgName, 0, &zf0) != TCL_OK) { + Tcl_DecrRefCount(list); + Tcl_Close(interp, out); + return TCL_ERROR; + } + if ((pw != NULL) && pwlen) { + i = 0; + len = pwlen; + while (len > 0) { + int ch = pw[len - 1]; + + pwbuf[i] = (ch & 0x0f) | pwrot[(ch >> 4) & 0x0f]; + i++; + len--; + } + pwbuf[i] = i; + ++i; + pwbuf[i++] = (char) ZIP_PASSWORD_END_SIG; + pwbuf[i++] = (char) (ZIP_PASSWORD_END_SIG >> 8); + pwbuf[i++] = (char) (ZIP_PASSWORD_END_SIG >> 16); + pwbuf[i++] = (char) (ZIP_PASSWORD_END_SIG >> 24); + pwbuf[i] = '\0'; + } + i = Tcl_Write(out, (char *) zf0.data, zf0.baseoffsp); + if (i != zf0.baseoffsp) { + Tcl_DecrRefCount(list); + Tcl_SetObjResult(interp, Tcl_NewStringObj("write error", -1)); + Tcl_Close(interp, out); + ZipFSCloseArchive(interp, &zf0); + return TCL_ERROR; + } + ZipFSCloseArchive(interp, &zf0); + len = strlen(pwbuf); + if (len > 0) { + i = Tcl_Write(out, pwbuf, len); + if (i != len) { + Tcl_DecrRefCount(list); + Tcl_SetObjResult(interp, Tcl_NewStringObj("write error", -1)); + Tcl_Close(interp, out); + return TCL_ERROR; + } + } + memset(pwbuf, 0, sizeof (pwbuf)); + Tcl_Flush(out); + } + Tcl_InitHashTable(&fileHash, TCL_STRING_KEYS); + pos[0] = Tcl_Tell(out); + if (!isList && (objc > 3)) { + strip = Tcl_GetString(objv[3]); + slen = strlen(strip); + } + for (i = 0; i < lobjc; i += (isList ? 2 : 1)) { + const char *path, *name; + + path = Tcl_GetString(lobjv[i]); + if (isList) { + name = Tcl_GetString(lobjv[i + 1]); + } else { + name = path; + if (slen > 0) { + len = strlen(name); + if ((len <= slen) || (strncmp(strip, name, slen) != 0)) { + continue; + } + name += slen; + } + } + while (name[0] == '/') { + ++name; + } + if (name[0] == '\0') { + continue; + } + if (ZipAddFile(interp, path, name, out, pw, buf, sizeof (buf), + &fileHash) != TCL_OK) { + goto done; + } + } + pos[1] = Tcl_Tell(out); + count = 0; + for (i = 0; i < lobjc; i += (isList ? 2 : 1)) { + const char *path, *name; + + path = Tcl_GetString(lobjv[i]); + if (isList) { + name = Tcl_GetString(lobjv[i + 1]); + } else { + name = path; + if (slen > 0) { + len = strlen(name); + if ((len <= slen) || (strncmp(strip, name, slen) != 0)) { + continue; + } + name += slen; + } + } + while (name[0] == '/') { + ++name; + } + if (name[0] == '\0') { + continue; + } + hPtr = Tcl_FindHashEntry(&fileHash, name); + if (hPtr == NULL) { + continue; + } + z = (ZipEntry *) Tcl_GetHashValue(hPtr); + len = strlen(z->name); + zip_write_int(buf + ZIP_CENTRAL_SIG_OFFS, ZIP_CENTRAL_HEADER_SIG); + zip_write_short(buf + ZIP_CENTRAL_VERSIONMADE_OFFS, ZIP_MIN_VERSION); + zip_write_short(buf + ZIP_CENTRAL_VERSION_OFFS, ZIP_MIN_VERSION); + zip_write_short(buf + ZIP_CENTRAL_FLAGS_OFFS, z->isenc ? 1 : 0); + zip_write_short(buf + ZIP_CENTRAL_COMPMETH_OFFS, z->cmeth); + zip_write_short(buf + ZIP_CENTRAL_MTIME_OFFS, ToDosTime(z->timestamp)); + zip_write_short(buf + ZIP_CENTRAL_MDATE_OFFS, ToDosDate(z->timestamp)); + zip_write_int(buf + ZIP_CENTRAL_CRC32_OFFS, z->crc32); + zip_write_int(buf + ZIP_CENTRAL_COMPLEN_OFFS, z->nbytecompr); + zip_write_int(buf + ZIP_CENTRAL_UNCOMPLEN_OFFS, z->nbyte); + zip_write_short(buf + ZIP_CENTRAL_PATHLEN_OFFS, len); + zip_write_short(buf + ZIP_CENTRAL_EXTRALEN_OFFS, 0); + zip_write_short(buf + ZIP_CENTRAL_FCOMMENTLEN_OFFS, 0); + zip_write_short(buf + ZIP_CENTRAL_DISKFILE_OFFS, 0); + zip_write_short(buf + ZIP_CENTRAL_IATTR_OFFS, 0); + zip_write_int(buf + ZIP_CENTRAL_EATTR_OFFS, 0); + zip_write_int(buf + ZIP_CENTRAL_LOCALHDR_OFFS, z->offset - pos[0]); + if ((Tcl_Write(out, buf, ZIP_CENTRAL_HEADER_LEN) != + ZIP_CENTRAL_HEADER_LEN) || + (Tcl_Write(out, z->name, len) != len)) { + Tcl_SetObjResult(interp, Tcl_NewStringObj("write error", -1)); + goto done; + } + count++; + } + Tcl_Flush(out); + pos[2] = Tcl_Tell(out); + zip_write_int(buf + ZIP_CENTRAL_END_SIG_OFFS, ZIP_CENTRAL_END_SIG); + zip_write_short(buf + ZIP_CENTRAL_DISKNO_OFFS, 0); + zip_write_short(buf + ZIP_CENTRAL_DISKDIR_OFFS, 0); + zip_write_short(buf + ZIP_CENTRAL_ENTS_OFFS, count); + zip_write_short(buf + ZIP_CENTRAL_TOTALENTS_OFFS, count); + zip_write_int(buf + ZIP_CENTRAL_DIRSIZE_OFFS, pos[2] - pos[1]); + zip_write_int(buf + ZIP_CENTRAL_DIRSTART_OFFS, pos[1] - pos[0]); + zip_write_short(buf + ZIP_CENTRAL_COMMENTLEN_OFFS, 0); + if (Tcl_Write(out, buf, ZIP_CENTRAL_END_LEN) != ZIP_CENTRAL_END_LEN) { + Tcl_SetObjResult(interp, Tcl_NewStringObj("write error", -1)); + goto done; + } + Tcl_Flush(out); + ret = TCL_OK; +done: + if (ret == TCL_OK) { + ret = Tcl_Close(interp, out); + } else { + Tcl_Close(interp, out); + } + Tcl_DecrRefCount(list); + hPtr = Tcl_FirstHashEntry(&fileHash, &search); + while (hPtr != NULL) { + z = (ZipEntry *) Tcl_GetHashValue(hPtr); + Tcl_Free((char *) z); + Tcl_DeleteHashEntry(hPtr); + hPtr = Tcl_FirstHashEntry(&fileHash, &search); + } + Tcl_DeleteHashTable(&fileHash); + return ret; +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSMkZipObjCmd -- + * + * This procedure is invoked to process the "zipfs::mkzip" command. + * See description of ZipFSMkZipOrImgCmd(). + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See description of ZipFSMkZipOrImgCmd(). + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSMkZipObjCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]) +{ + return ZipFSMkZipOrImgObjCmd(clientData, interp, 0, 0, objc, objv); +} + +static int +ZipFSLMkZipObjCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]) +{ + return ZipFSMkZipOrImgObjCmd(clientData, interp, 0, 1, objc, objv); +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSMkImgObjCmd -- + * + * This procedure is invoked to process the "zipfs::mkimg" command. + * See description of ZipFSMkZipOrImgCmd(). + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See description of ZipFSMkZipOrImgCmd(). + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSMkImgObjCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]) +{ + return ZipFSMkZipOrImgObjCmd(clientData, interp, 1, 0, objc, objv); +} + +static int +ZipFSLMkImgObjCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]) +{ + return ZipFSMkZipOrImgObjCmd(clientData, interp, 1, 1, objc, objv); +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSExistsObjCmd -- + * + * This procedure is invoked to process the "zipfs::exists" command. + * It tests for the existence of a file in the ZIP filesystem and + * places a boolean into the interp's result. + * + * Results: + * Always TCL_OK. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSCanonicalObjCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]) +{ + char *mntpoint=NULL; + char *filename=NULL; + char *result; + Tcl_DString dPath; + + if (objc != 2 && objc != 3 && objc!=4) { + Tcl_WrongNumArgs(interp, 1, objv, "?mntpnt? filename ?ZIPFS?"); + return TCL_ERROR; + } + Tcl_DStringInit(&dPath); + if(objc==2) { + filename = Tcl_GetString(objv[1]); + result=CanonicalPath("",filename,&dPath,1); + } else if (objc==3) { + mntpoint = Tcl_GetString(objv[1]); + filename = Tcl_GetString(objv[2]); + result=CanonicalPath(mntpoint,filename,&dPath,1); + } else { + int zipfs=0; + if(Tcl_GetBooleanFromObj(interp,objv[3],&zipfs)) { + return TCL_ERROR; + } + mntpoint = Tcl_GetString(objv[1]); + filename = Tcl_GetString(objv[2]); + result=CanonicalPath(mntpoint,filename,&dPath,zipfs); + } + Tcl_SetObjResult(interp,Tcl_NewStringObj(result,-1)); + return TCL_OK; +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSExistsObjCmd -- + * + * This procedure is invoked to process the "zipfs::exists" command. + * It tests for the existence of a file in the ZIP filesystem and + * places a boolean into the interp's result. + * + * Results: + * Always TCL_OK. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSExistsObjCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]) +{ + char *filename; + int exists; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "filename"); + return TCL_ERROR; + } + filename = Tcl_GetStringFromObj(objv[1], 0); + ReadLock(); + exists = ZipFSLookup(filename) != NULL; + Unlock(); + Tcl_SetObjResult(interp,Tcl_NewBooleanObj(exists)); + return TCL_OK; +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSInfoObjCmd -- + * + * This procedure is invoked to process the "zipfs::info" command. + * On success, it returns a Tcl list made up of name of ZIP archive + * file, size uncompressed, size compressed, and archive offset of + * a file in the ZIP filesystem. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSInfoObjCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]) +{ + char *filename; + ZipEntry *z; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "filename"); + return TCL_ERROR; + } + filename = Tcl_GetStringFromObj(objv[1], 0); + ReadLock(); + z = ZipFSLookup(filename); + if (z != NULL) { + Tcl_Obj *result = Tcl_GetObjResult(interp); + + Tcl_ListObjAppendElement(interp, result, + Tcl_NewStringObj(z->zipfile->name, -1)); + Tcl_ListObjAppendElement(interp, result, Tcl_NewIntObj(z->nbyte)); + Tcl_ListObjAppendElement(interp, result, Tcl_NewIntObj(z->nbytecompr)); + Tcl_ListObjAppendElement(interp, result, Tcl_NewIntObj(z->offset)); + } + Unlock(); + return TCL_OK; +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSListObjCmd -- + * + * This procedure is invoked to process the "zipfs::list" command. + * On success, it returns a Tcl list of files of the ZIP filesystem + * which match a search pattern (glob or regexp). + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSListObjCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]) +{ + char *pattern = NULL; + Tcl_RegExp regexp = NULL; + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + Tcl_Obj *result = Tcl_GetObjResult(interp); + + if (objc > 3) { + Tcl_WrongNumArgs(interp, 1, objv, "?(-glob|-regexp)? ?pattern?"); + return TCL_ERROR; + } + if (objc == 3) { + int n; + char *what = Tcl_GetStringFromObj(objv[1], &n); + + if ((n >= 2) && (strncmp(what, "-glob", n) == 0)) { + pattern = Tcl_GetString(objv[2]); + } else if ((n >= 2) && (strncmp(what, "-regexp", n) == 0)) { + regexp = Tcl_RegExpCompile(interp, Tcl_GetString(objv[2])); + if (regexp == NULL) { + return TCL_ERROR; + } + } else { + Tcl_AppendResult(interp, "unknown option \"", what, + "\"", (char *) NULL); + return TCL_ERROR; + } + } else if (objc == 2) { + pattern = Tcl_GetStringFromObj(objv[1], 0); + } + ReadLock(); + if (pattern != NULL) { + for (hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + ZipEntry *z = (ZipEntry *) Tcl_GetHashValue(hPtr); + + if (Tcl_StringMatch(z->name, pattern)) { + Tcl_ListObjAppendElement(interp, result, + Tcl_NewStringObj(z->name, -1)); + } + } + } else if (regexp != NULL) { + for (hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + ZipEntry *z = (ZipEntry *) Tcl_GetHashValue(hPtr); + + if (Tcl_RegExpExec(interp, regexp, z->name, z->name)) { + Tcl_ListObjAppendElement(interp, result, + Tcl_NewStringObj(z->name, -1)); + } + } + } else { + for (hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + ZipEntry *z = (ZipEntry *) Tcl_GetHashValue(hPtr); + + Tcl_ListObjAppendElement(interp, result, + Tcl_NewStringObj(z->name, -1)); + } + } + Unlock(); + return TCL_OK; +} + +/* + *------------------------------------------------------------------------- + * + * ZipChannelClose -- + * + * This function is called to close a channel. + * + * Results: + * Always TCL_OK. + * + * Side effects: + * Resources are free'd. + * + *------------------------------------------------------------------------- + */ + +static int +ZipChannelClose(ClientData instanceData, Tcl_Interp *interp) +{ + ZipChannel *info = (ZipChannel *) instanceData; + + if (info->iscompr && (info->ubuf != NULL)) { + Tcl_Free((char *) info->ubuf); + info->ubuf = NULL; + } + if (info->isenc) { + info->isenc = 0; + memset(info->keys, 0, sizeof (info->keys)); + } + if (info->iswr) { + ZipEntry *z = info->zipentry; + unsigned char *newdata; + + newdata = (unsigned char *) + Tcl_AttemptRealloc((char *) info->ubuf, info->nread); + if (newdata != NULL) { + if (z->data != NULL) { + Tcl_Free((char *) z->data); + } + z->data = newdata; + z->nbyte = z->nbytecompr = info->nbyte; + z->cmeth = ZIP_COMPMETH_STORED; + z->timestamp = time(NULL); + z->isdir = 0; + z->isenc = 0; + z->offset = 0; + z->crc32 = 0; + } else { + Tcl_Free((char *) info->ubuf); + } + } + WriteLock(); + info->zipfile->nopen--; + Unlock(); + Tcl_Free((char *) info); + return TCL_OK; +} + +/* + *------------------------------------------------------------------------- + * + * ZipChannelRead -- + * + * This function is called to read data from channel. + * + * Results: + * Number of bytes read or -1 on error with error number set. + * + * Side effects: + * Data is read and file pointer is advanced. + * + *------------------------------------------------------------------------- + */ + +static int +ZipChannelRead(ClientData instanceData, char *buf, int toRead, int *errloc) +{ + ZipChannel *info = (ZipChannel *) instanceData; + unsigned long nextpos; + + if (info->isdir) { + *errloc = EISDIR; + return -1; + } + nextpos = info->nread + toRead; + if (nextpos > info->nbyte) { + toRead = info->nbyte - info->nread; + nextpos = info->nbyte; + } + if (toRead == 0) { + return 0; + } + if (info->isenc) { + int i, ch; + + for (i = 0; i < toRead; i++) { + ch = info->ubuf[i + info->nread]; + buf[i] = zdecode(info->keys, crc32tab, ch); + } + } else { + memcpy(buf, info->ubuf + info->nread, toRead); + } + info->nread = nextpos; + *errloc = 0; + return toRead; +} + +/* + *------------------------------------------------------------------------- + * + * ZipChannelWrite -- + * + * This function is called to write data into channel. + * + * Results: + * Number of bytes written or -1 on error with error number set. + * + * Side effects: + * Data is written and file pointer is advanced. + * + *------------------------------------------------------------------------- + */ + +static int +ZipChannelWrite(ClientData instanceData, const char *buf, + int toWrite, int *errloc) +{ + ZipChannel *info = (ZipChannel *) instanceData; + unsigned long nextpos; + + if (!info->iswr) { + *errloc = EINVAL; + return -1; + } + nextpos = info->nread + toWrite; + if (nextpos > info->nmax) { + toWrite = info->nmax - info->nread; + nextpos = info->nmax; + } + if (toWrite == 0) { + return 0; + } + memcpy(info->ubuf + info->nread, buf, toWrite); + info->nread = nextpos; + if (info->nread > info->nbyte) { + info->nbyte = info->nread; + } + *errloc = 0; + return toWrite; +} + +/* + *------------------------------------------------------------------------- + * + * ZipChannelSeek -- + * + * This function is called to position file pointer of channel. + * + * Results: + * New file position or -1 on error with error number set. + * + * Side effects: + * File pointer is repositioned according to offset and mode. + * + *------------------------------------------------------------------------- + */ + +static int +ZipChannelSeek(ClientData instanceData, long offset, int mode, int *errloc) +{ + ZipChannel *info = (ZipChannel *) instanceData; + + if (info->isdir) { + *errloc = EINVAL; + return -1; + } + switch (mode) { + case SEEK_CUR: + offset += info->nread; + break; + case SEEK_END: + offset += info->nbyte; + break; + case SEEK_SET: + break; + default: + *errloc = EINVAL; + return -1; + } + if (offset < 0) { + *errloc = EINVAL; + return -1; + } + if (info->iswr) { + if ((unsigned long) offset > info->nmax) { + *errloc = EINVAL; + return -1; + } + if ((unsigned long) offset > info->nbyte) { + info->nbyte = offset; + } + } else if ((unsigned long) offset > info->nbyte) { + *errloc = EINVAL; + return -1; + } + info->nread = (unsigned long) offset; + return info->nread; +} + +/* + *------------------------------------------------------------------------- + * + * ZipChannelWatchChannel -- + * + * This function is called for event notifications on channel. + * + * Results: + * None. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static void +ZipChannelWatchChannel(ClientData instanceData, int mask) +{ + return; +} + +/* + *------------------------------------------------------------------------- + * + * ZipChannelGetFile -- + * + * This function is called to retrieve OS handle for channel. + * + * Results: + * Always TCL_ERROR since there's never an OS handle for a + * file within a ZIP archive. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static int +ZipChannelGetFile(ClientData instanceData, int direction, + ClientData *handlePtr) +{ + return TCL_ERROR; +} + +/* + * The channel type/driver definition used for ZIP archive members. + */ + +static Tcl_ChannelType ZipChannelType = { + "zip", /* Type name. */ +#ifdef TCL_CHANNEL_VERSION_4 + TCL_CHANNEL_VERSION_4, + ZipChannelClose, /* Close channel, clean instance data */ + ZipChannelRead, /* Handle read request */ + ZipChannelWrite, /* Handle write request */ + ZipChannelSeek, /* Move location of access point, NULL'able */ + NULL, /* Set options, NULL'able */ + NULL, /* Get options, NULL'able */ + ZipChannelWatchChannel, /* Initialize notifier */ + ZipChannelGetFile, /* Get OS handle from the channel */ + NULL, /* 2nd version of close channel, NULL'able */ + NULL, /* Set blocking mode for raw channel, NULL'able */ + NULL, /* Function to flush channel, NULL'able */ + NULL, /* Function to handle event, NULL'able */ + NULL, /* Wide seek function, NULL'able */ + NULL, /* Thread action function, NULL'able */ +#else + NULL, /* Set blocking/nonblocking behaviour, NULL'able */ + ZipChannelClose, /* Close channel, clean instance data */ + ZipChannelRead, /* Handle read request */ + ZipChannelWrite, /* Handle write request */ + ZipChannelSeek, /* Move location of access point, NULL'able */ + NULL, /* Set options, NULL'able */ + NULL, /* Get options, NULL'able */ + ZipChannelWatchChannel, /* Initialize notifier */ + ZipChannelGetFile, /* Get OS handle from the channel */ +#endif +}; + +/* + *------------------------------------------------------------------------- + * + * ZipChannelOpen -- + * + * This function opens a Tcl_Channel on a file from a mounted ZIP + * archive according to given open mode. + * + * Results: + * Tcl_Channel on success, or NULL on error. + * + * Side effects: + * Memory is allocated, the file from the ZIP archive is uncompressed. + * + *------------------------------------------------------------------------- + */ + +static Tcl_Channel +ZipChannelOpen(Tcl_Interp *interp, char *filename, int mode, int permissions) +{ + ZipEntry *z; + ZipChannel *info; + int i, ch, trunc, wr, flags = 0; + char cname[128]; + + if ((mode & O_APPEND) || + ((ZipFS.wrmax <= 0) && (mode & (O_WRONLY | O_RDWR)))) { + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj("unsupported open mode", -1)); + } + return NULL; + } + WriteLock(); + z = ZipFSLookup(filename); + if (z == NULL) { + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj("file not found", -1)); + } + goto error; + } + trunc = (mode & O_TRUNC) != 0; + wr = (mode & (O_WRONLY | O_RDWR)) != 0; + if ((z->cmeth != ZIP_COMPMETH_STORED) && + (z->cmeth != ZIP_COMPMETH_DEFLATED)) { + if (interp != NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("unsupported compression method", -1)); + } + goto error; + } + if (wr && z->isdir) { + if (interp != NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("unsupported file type", -1)); + } + goto error; + } + if (!trunc) { + flags |= TCL_READABLE; + if (z->isenc && (z->zipfile->pwbuf[0] == 0)) { + if (interp != NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("decryption failed", -1)); + } + goto error; + } else if (wr && (z->data == NULL) && (z->nbyte > ZipFS.wrmax)) { + if (interp != NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("file too large", -1)); + } + goto error; + } + } else { + flags = TCL_WRITABLE; + } + info = (ZipChannel *) Tcl_AttemptAlloc(sizeof (*info)); + if (info == NULL) { + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj("out of memory", -1)); + } + goto error; + } + info->zipfile = z->zipfile; + info->zipentry = z; + info->nread = 0; + if (wr) { + flags |= TCL_WRITABLE; + info->iswr = 1; + info->isdir = 0; + info->nmax = ZipFS.wrmax; + info->iscompr = 0; + info->isenc = 0; + info->ubuf = (unsigned char *) Tcl_AttemptAlloc(info->nmax); + if (info->ubuf == NULL) { +merror0: + if (info->ubuf != NULL) { + Tcl_Free((char *) info->ubuf); + } + Tcl_Free((char *) info); + if (interp != NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("out of memory", -1)); + } + goto error; + } + memset(info->ubuf, 0, info->nmax); + if (trunc) { + info->nbyte = 0; + } else { + if (z->data != NULL) { + unsigned int j = z->nbyte; + + if (j > info->nmax) { + j = info->nmax; + } + memcpy(info->ubuf, z->data, j); + info->nbyte = j; + } else { + unsigned char *zbuf = z->zipfile->data + z->offset; + + if (z->isenc) { + int len = z->zipfile->pwbuf[0]; + char pwbuf[260]; + + for (i = 0; i < len; i++) { + ch = z->zipfile->pwbuf[len - i]; + pwbuf[i] = (ch & 0x0f) | pwrot[(ch >> 4) & 0x0f]; + } + pwbuf[i] = '\0'; + init_keys(pwbuf, info->keys, crc32tab); + memset(pwbuf, 0, sizeof (pwbuf)); + for (i = 0; i < 12; i++) { + ch = info->ubuf[i]; + zdecode(info->keys, crc32tab, ch); + } + zbuf += i; + } + if (z->cmeth == ZIP_COMPMETH_DEFLATED) { + z_stream stream; + int err; + unsigned char *cbuf = NULL; + + memset(&stream, 0, sizeof (stream)); + stream.zalloc = Z_NULL; + stream.zfree = Z_NULL; + stream.opaque = Z_NULL; + stream.avail_in = z->nbytecompr; + if (z->isenc) { + unsigned int j; + + stream.avail_in -= 12; + cbuf = (unsigned char *) + Tcl_AttemptAlloc(stream.avail_in); + if (cbuf == NULL) { + goto merror0; + } + for (j = 0; j < stream.avail_in; j++) { + ch = info->ubuf[j]; + cbuf[j] = zdecode(info->keys, crc32tab, ch); + } + stream.next_in = cbuf; + } else { + stream.next_in = zbuf; + } + stream.next_out = info->ubuf; + stream.avail_out = info->nmax; + if (inflateInit2(&stream, -15) != Z_OK) { + goto cerror0; + } + err = inflate(&stream, Z_SYNC_FLUSH); + inflateEnd(&stream); + if ((err == Z_STREAM_END) || + ((err == Z_OK) && (stream.avail_in == 0))) { + if (cbuf != NULL) { + memset(info->keys, 0, sizeof (info->keys)); + Tcl_Free((char *) cbuf); + } + goto wrapchan; + } +cerror0: + if (cbuf != NULL) { + memset(info->keys, 0, sizeof (info->keys)); + Tcl_Free((char *) cbuf); + } + if (info->ubuf != NULL) { + Tcl_Free((char *) info->ubuf); + } + Tcl_Free((char *) info); + if (interp != NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("decompression error", -1)); + } + goto error; + } else if (z->isenc) { + for (i = 0; i < z->nbyte - 12; i++) { + ch = zbuf[i]; + info->ubuf[i] = zdecode(info->keys, crc32tab, ch); + } + } else { + memcpy(info->ubuf, zbuf, z->nbyte); + } + memset(info->keys, 0, sizeof (info->keys)); + goto wrapchan; + } + } + } else if (z->data != NULL) { + flags |= TCL_READABLE; + info->iswr = 0; + info->iscompr = 0; + info->isdir = 0; + info->isenc = 0; + info->nbyte = z->nbyte; + info->nmax = 0; + info->ubuf = z->data; + } else { + flags |= TCL_READABLE; + info->iswr = 0; + info->iscompr = z->cmeth == ZIP_COMPMETH_DEFLATED; + info->ubuf = z->zipfile->data + z->offset; + info->isdir = z->isdir; + info->isenc = z->isenc; + info->nbyte = z->nbyte; + info->nmax = 0; + if (info->isenc) { + int len = z->zipfile->pwbuf[0]; + char pwbuf[260]; + + for (i = 0; i < len; i++) { + ch = z->zipfile->pwbuf[len - i]; + pwbuf[i] = (ch & 0x0f) | pwrot[(ch >> 4) & 0x0f]; + } + pwbuf[i] = '\0'; + init_keys(pwbuf, info->keys, crc32tab); + memset(pwbuf, 0, sizeof (pwbuf)); + for (i = 0; i < 12; i++) { + ch = info->ubuf[i]; + zdecode(info->keys, crc32tab, ch); + } + info->ubuf += i; + } + if (info->iscompr) { + z_stream stream; + int err; + unsigned char *ubuf = NULL; + unsigned int j; + + memset(&stream, 0, sizeof (stream)); + stream.zalloc = Z_NULL; + stream.zfree = Z_NULL; + stream.opaque = Z_NULL; + stream.avail_in = z->nbytecompr; + if (info->isenc) { + stream.avail_in -= 12; + ubuf = (unsigned char *) Tcl_AttemptAlloc(stream.avail_in); + if (ubuf == NULL) { + info->ubuf = NULL; + goto merror; + } + for (j = 0; j < stream.avail_in; j++) { + ch = info->ubuf[j]; + ubuf[j] = zdecode(info->keys, crc32tab, ch); + } + stream.next_in = ubuf; + } else { + stream.next_in = info->ubuf; + } + stream.next_out = info->ubuf = + (unsigned char *) Tcl_AttemptAlloc(info->nbyte); + if (info->ubuf == NULL) { +merror: + if (ubuf != NULL) { + info->isenc = 0; + memset(info->keys, 0, sizeof (info->keys)); + Tcl_Free((char *) ubuf); + } + Tcl_Free((char *) info); + if (interp != NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("out of memory", -1)); + } + goto error; + } + stream.avail_out = info->nbyte; + if (inflateInit2(&stream, -15) != Z_OK) { + goto cerror; + } + err = inflate(&stream, Z_SYNC_FLUSH); + inflateEnd(&stream); + if ((err == Z_STREAM_END) || + ((err == Z_OK) && (stream.avail_in == 0))) { + if (ubuf != NULL) { + info->isenc = 0; + memset(info->keys, 0, sizeof (info->keys)); + Tcl_Free((char *) ubuf); + } + goto wrapchan; + } +cerror: + if (ubuf != NULL) { + info->isenc = 0; + memset(info->keys, 0, sizeof (info->keys)); + Tcl_Free((char *) ubuf); + } + if (info->ubuf != NULL) { + Tcl_Free((char *) info->ubuf); + } + Tcl_Free((char *) info); + if (interp != NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("decompression error", -1)); + } + goto error; + } + } +wrapchan: + sprintf(cname, "zipfs_%lx_%d", (unsigned long) z->offset, ZipFS.idCount++); + z->zipfile->nopen++; + Unlock(); + return Tcl_CreateChannel(&ZipChannelType, cname, (ClientData) info, flags); + +error: + Unlock(); + return NULL; +} + +/* + *------------------------------------------------------------------------- + * + * ZipEntryStat -- + * + * This function implements the ZIP filesystem specific version + * of the library version of stat. + * + * Results: + * See stat documentation. + * + * Side effects: + * See stat documentation. + * + *------------------------------------------------------------------------- + */ + +static int +ZipEntryStat(char *path, Tcl_StatBuf *buf) +{ + ZipEntry *z; + int ret = -1; + + ReadLock(); + z = ZipFSLookup(path); + if (z == NULL) { + goto done; + } + memset(buf, 0, sizeof (Tcl_StatBuf)); + if (z->isdir) { + buf->st_mode = S_IFDIR | 0555; + } else { + buf->st_mode = S_IFREG | 0555; + } + buf->st_size = z->nbyte; + buf->st_mtime = z->timestamp; + buf->st_ctime = z->timestamp; + buf->st_atime = z->timestamp; + ret = 0; +done: + Unlock(); + return ret; +} + +/* + *------------------------------------------------------------------------- + * + * ZipEntryAccess -- + * + * This function implements the ZIP filesystem specific version + * of the library version of access. + * + * Results: + * See access documentation. + * + * Side effects: + * See access documentation. + * + *------------------------------------------------------------------------- + */ + +static int +ZipEntryAccess(char *path, int mode) +{ + ZipEntry *z; + + if (mode & 3) { + return -1; + } + ReadLock(); + z = ZipFSLookup(path); + Unlock(); + return (z != NULL) ? 0 : -1; +} + +/* + *------------------------------------------------------------------------- + * + * Zip_FSOpenFileChannelProc -- + * + * Results: + * + * Side effects: + * + *------------------------------------------------------------------------- + */ + +static Tcl_Channel +Zip_FSOpenFileChannelProc(Tcl_Interp *interp, Tcl_Obj *pathPtr, + int mode, int permissions) +{ + int len; + + return ZipChannelOpen(interp, Tcl_GetStringFromObj(pathPtr, &len), + mode, permissions); +} + +/* + *------------------------------------------------------------------------- + * + * Zip_FSStatProc -- + * + * This function implements the ZIP filesystem specific version + * of the library version of stat. + * + * Results: + * See stat documentation. + * + * Side effects: + * See stat documentation. + * + *------------------------------------------------------------------------- + */ + +static int +Zip_FSStatProc(Tcl_Obj *pathPtr, Tcl_StatBuf *buf) +{ + int len; + + return ZipEntryStat(Tcl_GetStringFromObj(pathPtr, &len), buf); +} + +/* + *------------------------------------------------------------------------- + * + * Zip_FSAccessProc -- + * + * This function implements the ZIP filesystem specific version + * of the library version of access. + * + * Results: + * See access documentation. + * + * Side effects: + * See access documentation. + * + *------------------------------------------------------------------------- + */ + +static int +Zip_FSAccessProc(Tcl_Obj *pathPtr, int mode) +{ + int len; + + return ZipEntryAccess(Tcl_GetStringFromObj(pathPtr, &len), mode); +} + +/* + *------------------------------------------------------------------------- + * + * Zip_FSFilesystemSeparatorProc -- + * + * This function returns the separator to be used for a given path. The + * object returned should have a refCount of zero + * + * Results: + * A Tcl object, with a refCount of zero. If the caller needs to retain a + * reference to the object, it should call Tcl_IncrRefCount, and should + * otherwise free the object. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static Tcl_Obj * +Zip_FSFilesystemSeparatorProc(Tcl_Obj *pathPtr) +{ + return Tcl_NewStringObj("/", -1); +} + +/* + *------------------------------------------------------------------------- + * + * Zip_FSMatchInDirectoryProc -- + * + * This routine is used by the globbing code to search a directory for + * all files which match a given pattern. + * + * Results: + * The return value is a standard Tcl result indicating whether an + * error occurred in globbing. Errors are left in interp, good + * results are lappend'ed to resultPtr (which must be a valid object). + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ +static int +Zip_FSMatchInDirectoryProc(Tcl_Interp* interp, Tcl_Obj *result, + Tcl_Obj *pathPtr, const char *pattern, + Tcl_GlobTypeData *types) +{ + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + int scnt, len, l, dirOnly = -1, prefixLen, strip = 0; + char *pat, *prefix, *path; + Tcl_DString ds, dsPref; + if (types != NULL) { + dirOnly = (types->type & TCL_GLOB_TYPE_DIR) == TCL_GLOB_TYPE_DIR; + } + Tcl_DStringInit(&ds); + Tcl_DStringInit(&dsPref); + prefix = Tcl_GetStringFromObj(pathPtr, &prefixLen); + Tcl_DStringAppend(&dsPref, prefix, prefixLen); + prefix = Tcl_DStringValue(&dsPref); + path = AbsolutePath(prefix, &ds, 1); + len = Tcl_DStringLength(&ds); + if (strcmp(prefix, path) == 0) { + prefix = NULL; + } else { + strip = len + 1; + } + if (prefix != NULL) { + Tcl_DStringAppend(&dsPref, "/", 1); + prefixLen++; + prefix = Tcl_DStringValue(&dsPref); + } + ReadLock(); + if ((types != NULL) && (types->type == TCL_GLOB_TYPE_MOUNT)) { + l = CountSlashes(path); + if (path[len - 1] == '/') { + len--; + } else { + l++; + } + if ((pattern == NULL) || (pattern[0] == '\0')) { + pattern = "*"; + } + hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); + while (hPtr != NULL) { + ZipFile *zf = (ZipFile *) Tcl_GetHashValue(hPtr); + + if (zf->mntptlen == 0) { + ZipEntry *z = zf->topents; + while (z != NULL) { + int lenz = strlen(z->name); + if ((lenz > len + 1) && + (strncmp(z->name, path, len) == 0) && + (z->name[len] == '/') && + (CountSlashes(z->name) == l) && + Tcl_StringCaseMatch(z->name + len + 1, pattern, 0)) { + if (prefix != NULL) { + Tcl_DStringAppend(&dsPref, z->name, lenz); + Tcl_ListObjAppendElement(NULL, result, + Tcl_NewStringObj(Tcl_DStringValue(&dsPref), + Tcl_DStringLength(&dsPref))); + Tcl_DStringSetLength(&dsPref, prefixLen); + } else { + Tcl_ListObjAppendElement(NULL, result, + Tcl_NewStringObj(z->name, lenz)); + } + } + z = z->tnext; + } + } else if ((zf->mntptlen > len + 1) && + (strncmp(zf->mntpt, path, len) == 0) && + (zf->mntpt[len] == '/') && + (CountSlashes(zf->mntpt) == l) && + Tcl_StringCaseMatch(zf->mntpt + len + 1, pattern, 0)) { + if (prefix != NULL) { + Tcl_DStringAppend(&dsPref, zf->mntpt, zf->mntptlen); + Tcl_ListObjAppendElement(NULL, result, + Tcl_NewStringObj(Tcl_DStringValue(&dsPref), + Tcl_DStringLength(&dsPref))); + Tcl_DStringSetLength(&dsPref, prefixLen); + } else { + Tcl_ListObjAppendElement(NULL, result, + Tcl_NewStringObj(zf->mntpt, zf->mntptlen)); + } + } + hPtr = Tcl_NextHashEntry(&search); + } + goto end; + } + if ((pattern == NULL) || (pattern[0] == '\0')) { + hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, path); + if (hPtr != NULL) { + ZipEntry *z = (ZipEntry *) Tcl_GetHashValue(hPtr); + + if ((dirOnly < 0) || + (!dirOnly && !z->isdir) || + (dirOnly && z->isdir)) { + if (prefix != NULL) { + Tcl_DStringAppend(&dsPref, z->name, -1); + Tcl_ListObjAppendElement(NULL, result, + Tcl_NewStringObj(Tcl_DStringValue(&dsPref), + Tcl_DStringLength(&dsPref))); + Tcl_DStringSetLength(&dsPref, prefixLen); + } else { + Tcl_ListObjAppendElement(NULL, result, + Tcl_NewStringObj(z->name, -1)); + } + } + } + goto end; + } + l = strlen(pattern); + pat = Tcl_Alloc(len + l + 2); + memcpy(pat, path, len); + while ((len > 1) && (pat[len - 1] == '/')) { + --len; + } + if ((len > 1) || (pat[0] != '/')) { + pat[len] = '/'; + ++len; + } + memcpy(pat + len, pattern, l + 1); + scnt = CountSlashes(pat); + for (hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + ZipEntry *z = (ZipEntry *) Tcl_GetHashValue(hPtr); + if ((dirOnly >= 0) && + ((dirOnly && !z->isdir) || (!dirOnly && z->isdir))) { + continue; + } + if ((z->depth == scnt) && Tcl_StringCaseMatch(z->name, pat, 0)) { + if (prefix != NULL) { + Tcl_DStringAppend(&dsPref, z->name + strip, -1); + Tcl_ListObjAppendElement(NULL, result, + Tcl_NewStringObj(Tcl_DStringValue(&dsPref), + Tcl_DStringLength(&dsPref))); + Tcl_DStringSetLength(&dsPref, prefixLen); + } else { + Tcl_ListObjAppendElement(NULL, result, + Tcl_NewStringObj(z->name + strip, -1)); + } + } + } + Tcl_Free(pat); +end: + Unlock(); + Tcl_DStringFree(&dsPref); + Tcl_DStringFree(&ds); + return TCL_OK; +} + +/* + *------------------------------------------------------------------------- + * + * Zip_FSPathInFilesystemProc -- + * + * This function determines if the given path object is in the + * ZIP filesystem. + * + * Results: + * TCL_OK when the path object is in the ZIP filesystem, -1 otherwise. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static int +Zip_FSPathInFilesystemProc(Tcl_Obj *pathPtr, ClientData *clientDataPtr) +{ + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + ZipFile *zf; + int ret = -1, len; + char *path; + Tcl_DString ds; + + path = Tcl_GetStringFromObj(pathPtr, &len); + if(strncmp(path,ZIPFS_VOLUME,ZIPFS_VOLUME_LEN)!=0) { + return -1; + } + + Tcl_DStringInit(&ds); + path = CanonicalPath("",path, &ds, 1); + len = Tcl_DStringLength(&ds); + ReadLock(); + hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, path); + if (hPtr != NULL) { + ret = TCL_OK; + goto endloop; + } + hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); + while (hPtr != NULL) { + zf = (ZipFile *) Tcl_GetHashValue(hPtr); + if (zf->mntptlen == 0) { + ZipEntry *z = zf->topents; + while (z != NULL) { + int lenz = strlen(z->name); + + if ((len >= lenz) && + (strncmp(path, z->name, lenz) == 0)) { + ret = TCL_OK; + goto endloop; + } + z = z->tnext; + } + } else if ((len >= zf->mntptlen) && + (strncmp(path, zf->mntpt, zf->mntptlen) == 0)) { + ret = TCL_OK; + goto endloop; + } + hPtr = Tcl_NextHashEntry(&search); + } +endloop: + Unlock(); + Tcl_DStringFree(&ds); + return ret; +} + +/* + *------------------------------------------------------------------------- + * + * Zip_FSListVolumesProc -- + * + * Lists the currently mounted ZIP filesystem volumes. + * + * Results: + * The list of volumes. + * + * Side effects: + * None + * + *------------------------------------------------------------------------- + */ +static Tcl_Obj * +Zip_FSListVolumesProc(void) { + return Tcl_NewStringObj(ZIPFS_VOLUME, -1); +} + +/* + *------------------------------------------------------------------------- + * + * Zip_FSFileAttrStringsProc -- + * + * This function implements the ZIP filesystem dependent 'file attributes' + * subcommand, for listing the set of possible attribute strings. + * + * Results: + * An array of strings + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static const char *const * +Zip_FSFileAttrStringsProc(Tcl_Obj *pathPtr, Tcl_Obj** objPtrRef) +{ + static const char *const attrs[] = { + "-uncompsize", + "-compsize", + "-offset", + "-mount", + "-archive", + "-permissions", + NULL, + }; + + return attrs; +} + +/* + *------------------------------------------------------------------------- + * + * Zip_FSFileAttrsGetProc -- + * + * This function implements the ZIP filesystem specific + * 'file attributes' subcommand, for 'get' operations. + * + * Results: + * Standard Tcl return code. The object placed in objPtrRef (if TCL_OK + * was returned) is likely to have a refCount of zero. Either way we must + * either store it somewhere (e.g. the Tcl result), or Incr/Decr its + * refCount to ensure it is properly freed. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static int +Zip_FSFileAttrsGetProc(Tcl_Interp *interp, int index, Tcl_Obj *pathPtr, + Tcl_Obj **objPtrRef) +{ + int len, ret = TCL_OK; + char *path; + ZipEntry *z; + + path = Tcl_GetStringFromObj(pathPtr, &len); + ReadLock(); + z = ZipFSLookup(path); + if (z == NULL) { + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj("file not found", -1)); + } + ret = TCL_ERROR; + goto done; + } + switch (index) { + case 0: + *objPtrRef = Tcl_NewIntObj(z->nbyte); + goto done; + case 1: + *objPtrRef= Tcl_NewIntObj(z->nbytecompr); + goto done; + case 2: + *objPtrRef= Tcl_NewLongObj(z->offset); + goto done; + case 3: + *objPtrRef= Tcl_NewStringObj(z->zipfile->mntpt, -1); + goto done; + case 4: + *objPtrRef= Tcl_NewStringObj(z->zipfile->name, -1); + goto done; + case 5: + *objPtrRef= Tcl_NewStringObj("0555", -1); + goto done; + } + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj("unknown attribute", -1)); + } + ret = TCL_ERROR; +done: + Unlock(); + return ret; +} + +/* + *------------------------------------------------------------------------- + * + * Zip_FSFileAttrsSetProc -- + * + * This function implements the ZIP filesystem specific + * 'file attributes' subcommand, for 'set' operations. + * + * Results: + * Standard Tcl return code. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static int +Zip_FSFileAttrsSetProc(Tcl_Interp *interp, int index, Tcl_Obj *pathPtr, + Tcl_Obj *objPtr) +{ + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj("unsupported operation", -1)); + } + return TCL_ERROR; +} + +/* + *------------------------------------------------------------------------- + * + * Zip_FSFilesystemPathTypeProc -- + * + * Results: + * + * Side effects: + * + *------------------------------------------------------------------------- + */ + +static Tcl_Obj * +Zip_FSFilesystemPathTypeProc(Tcl_Obj *pathPtr) +{ + return Tcl_NewStringObj("zip", -1); +} + + +/* + *------------------------------------------------------------------------- + * + * Zip_FSLoadFile -- + * + * This functions deals with loading native object code. If + * the given path object refers to a file within the ZIP + * filesystem, an approriate error code is returned to delegate + * loading to the caller (by copying the file to temp store + * and loading from there). As fallback when the file refers + * to the ZIP file system but is not present, it is looked up + * relative to the executable and loaded from there when available. + * + * Results: + * TCL_OK on success, -1 otherwise with error number set. + * + * Side effects: + * Loads native code into the process address space. + * + *------------------------------------------------------------------------- + */ + +static int +Zip_FSLoadFile(Tcl_Interp *interp, Tcl_Obj *path, Tcl_LoadHandle *loadHandle, + Tcl_FSUnloadFileProc **unloadProcPtr, int flags) +{ + Tcl_FSLoadFileProc2 *loadFileProc; +#ifdef ANDROID + /* + * Force loadFileProc to native implementation since the + * package manger already extracted the shared libraries + * from the APK at install time. + */ + + loadFileProc = (Tcl_FSLoadFileProc2 *) tclNativeFilesystem.loadFileProc; + if (loadFileProc != NULL) { + return loadFileProc(interp, path, loadHandle, unloadProcPtr, flags); + } + Tcl_SetErrno(ENOENT); + return -1; +#else + Tcl_Obj *altPath = NULL; + int ret = -1; + + if (Tcl_FSAccess(path, R_OK) == 0) { + /* + * EXDEV should trigger loading by copying to temp store. + */ + Tcl_SetErrno(EXDEV); + return ret; + } else { + Tcl_Obj *objs[2] = { NULL, NULL }; + + objs[1] = TclPathPart(interp, path, TCL_PATH_DIRNAME); + if ((objs[1] != NULL) && (Zip_FSAccessProc(objs[1], R_OK) == 0)) { + const char *execName = Tcl_GetNameOfExecutable(); + + /* + * Shared object is not in ZIP but its path prefix is, + * thus try to load from directory where the executable + * came from. + */ + TclDecrRefCount(objs[1]); + objs[1] = TclPathPart(interp, path, TCL_PATH_TAIL); + /* + * Get directory name of executable manually to deal + * with cases where [file dirname [info nameofexecutable]] + * is equal to [info nameofexecutable] due to VFS effects. + */ + if (execName != NULL) { + const char *p = strrchr(execName, '/'); + + if (p > execName + 1) { + --p; + objs[0] = Tcl_NewStringObj(execName, p - execName); + } + } + if (objs[0] == NULL) { + objs[0] = TclPathPart(interp, TclGetObjNameOfExecutable(), + TCL_PATH_DIRNAME); + } + if (objs[0] != NULL) { + altPath = TclJoinPath(2, objs); + if (altPath != NULL) { + Tcl_IncrRefCount(altPath); + if (Tcl_FSAccess(altPath, R_OK) == 0) { + path = altPath; + } + } + } + } + if (objs[0] != NULL) { + Tcl_DecrRefCount(objs[0]); + } + if (objs[1] != NULL) { + Tcl_DecrRefCount(objs[1]); + } + } + loadFileProc = (Tcl_FSLoadFileProc2 *) tclNativeFilesystem.loadFileProc; + if (loadFileProc != NULL) { + ret = loadFileProc(interp, path, loadHandle, unloadProcPtr, flags); + } else { + Tcl_SetErrno(ENOENT); + } + if (altPath != NULL) { + Tcl_DecrRefCount(altPath); + } + return ret; +#endif +} + + +/* + * Define the ZIP filesystem dispatch table. + */ + +MODULE_SCOPE const Tcl_Filesystem zipfsFilesystem; + +const Tcl_Filesystem zipfsFilesystem = { + "zipfs", + sizeof (Tcl_Filesystem), + TCL_FILESYSTEM_VERSION_2, + Zip_FSPathInFilesystemProc, + NULL, /* dupInternalRepProc */ + NULL, /* freeInternalRepProc */ + NULL, /* internalToNormalizedProc */ + NULL, /* createInternalRepProc */ + NULL, /* normalizePathProc */ + Zip_FSFilesystemPathTypeProc, + Zip_FSFilesystemSeparatorProc, + Zip_FSStatProc, + Zip_FSAccessProc, + Zip_FSOpenFileChannelProc, + Zip_FSMatchInDirectoryProc, + NULL, /* utimeProc */ + NULL, /* linkProc */ + Zip_FSListVolumesProc, + Zip_FSFileAttrStringsProc, + Zip_FSFileAttrsGetProc, + Zip_FSFileAttrsSetProc, + NULL, /* createDirectoryProc */ + NULL, /* removeDirectoryProc */ + NULL, /* deleteFileProc */ + NULL, /* copyFileProc */ + NULL, /* renameFileProc */ + NULL, /* copyDirectoryProc */ + NULL, /* lstatProc */ + (Tcl_FSLoadFileProc *) Zip_FSLoadFile, + NULL, /* getCwdProc */ + NULL, /* chdirProc*/ +}; + +#endif /* HAVE_ZLIB */ + + + +/* + *------------------------------------------------------------------------- + * + * TclZipfsInit -- + * + * Perform per interpreter initialization of this module. + * + * Results: + * The return value is a standard Tcl result. + * + * Side effects: + * Initializes this module if not already initialized, and adds + * module related commands to the given interpreter. + * + *------------------------------------------------------------------------- + */ + +int +TclZipfsInit(Tcl_Interp *interp) +{ +#ifdef HAVE_ZLIB + /* one-time initialization */ + WriteLock(); + if (!ZipFS.initialized) { +#ifdef TCL_THREADS + static const Tcl_Time t = { 0, 0 }; + /* + * Inflate condition variable. + */ + Tcl_MutexLock(&ZipFSMutex); + Tcl_ConditionWait(&ZipFSCond, &ZipFSMutex, &t); + Tcl_MutexUnlock(&ZipFSMutex); +#endif + Tcl_FSRegister(NULL, &zipfsFilesystem); + Tcl_InitHashTable(&ZipFS.fileHash, TCL_STRING_KEYS); + Tcl_InitHashTable(&ZipFS.zipHash, TCL_STRING_KEYS); + ZipFS.initialized = ZipFS.idCount = 1; + } + Unlock(); + if(interp != NULL) { + static const EnsembleImplMap initMap[] = { + {"mount", ZipFSMountObjCmd, NULL, NULL, NULL, 0}, + {"unmount", ZipFSUnmountObjCmd, NULL, NULL, NULL, 0}, + {"mkkey", ZipFSMkKeyObjCmd, NULL, NULL, NULL, 0}, + {"mkimg", ZipFSMkImgObjCmd, NULL, NULL, NULL, 0}, + {"mkzip", ZipFSMkZipObjCmd, NULL, NULL, NULL, 0}, + {"lmkimg", ZipFSLMkImgObjCmd, NULL, NULL, NULL, 0}, + {"lmkzip", ZipFSLMkZipObjCmd, NULL, NULL, NULL, 0}, + {"exists", ZipFSExistsObjCmd, NULL, NULL, NULL, 1}, + {"info", ZipFSInfoObjCmd, NULL, NULL, NULL, 1}, + {"list", ZipFSListObjCmd, NULL, NULL, NULL, 1}, + {"canonical", ZipFSCanonicalObjCmd, NULL, NULL, NULL, 1}, + {NULL, NULL, NULL, NULL, NULL, 0} + }; + static const char findproc[] = + "namespace eval zipfs {}\n" + "proc ::zipfs::find dir {\n" + " set result {}\n" + " if {[catch {glob -directory $dir -tails -nocomplain * .*} list]} {\n" + " return $result\n" + " }\n" + " foreach file $list {\n" + " if {$file eq \".\" || $file eq \"..\"} {\n" + " continue\n" + " }\n" + " set file [file join $dir $file]\n" + " lappend result $file\n" + " foreach file [::zipfs::find $file] {\n" + " lappend result $file\n" + " }\n" + " }\n" + " return [lsort $result]\n" + "}\n"; + Tcl_EvalEx(interp, findproc, -1, TCL_EVAL_GLOBAL); + Tcl_LinkVar(interp, "::zipfs::wrmax", (char *) &ZipFS.wrmax, + TCL_LINK_INT); + TclMakeEnsemble(interp, "zipfs", initMap); + Tcl_PkgProvide(interp, "zipfs", "1.0"); + } + return TCL_OK; +#else + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj("no zlib available", -1)); + } + return TCL_ERROR; +#endif +} + + +#ifndef HAVE_ZLIB + +/* + *------------------------------------------------------------------------- + * + * TclZipfsMount, TclZipfsUnmount -- + * + * Dummy version when no ZLIB support available. + * + *------------------------------------------------------------------------- + */ + +int +TclZipfsMount(Tcl_Interp *interp, const char *zipname, const char *mntpt, + const char *passwd) +{ + return TclZipFsInit(interp, 1); +} + +int +TclZipfsUnmount(Tcl_Interp *interp, const char *zipname) +{ + return TclZipFsInit(interp, 1); +} + +#endif + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclZipfs.h b/generic/tclZipfs.h deleted file mode 100644 index 01c9e96..0000000 --- a/generic/tclZipfs.h +++ /dev/null @@ -1,48 +0,0 @@ -/* - * tclZipfs.h -- - * - * This header file describes the interface of the ZIPFS filesystem - * - * Copyright (c) 2013-2015 Christian Werner - * - * See the file "license.terms" for information on usage and redistribution of - * this file, and for a DISCLAIMER OF ALL WARRANTIES. - */ - -#ifndef _ZIPFS_H -#define _ZIPFS_H - -#include "tcl.h" - -#ifdef __cplusplus -extern "C" { -#endif - -#ifndef ZIPFSAPI -# define ZIPFSAPI extern -#endif - -#ifdef BUILD_tcl -# undef ZIPFSAPI -# define ZIPFSAPI DLLEXPORT -#endif - -ZIPFSAPI int Tclzipfs_Mount(Tcl_Interp *interp, const char *zipname, - const char *mntpt, const char *passwd); -ZIPFSAPI int Tclzipfs_Unmount(Tcl_Interp *interp, const char *zipname); -ZIPFSAPI int Tclzipfs_Init(Tcl_Interp *interp); -ZIPFSAPI int Tclzipfs_SafeInit(Tcl_Interp *interp); - -#ifdef __cplusplus -} -#endif - -#endif /* _ZIPFS_H */ - -/* - * Local Variables: - * mode: c - * c-basic-offset: 4 - * fill-column: 78 - * End: - */ diff --git a/generic/zipfs.c b/generic/zipfs.c deleted file mode 100644 index 70a8d6e..0000000 --- a/generic/zipfs.c +++ /dev/null @@ -1,4229 +0,0 @@ -/* - * zipfs.c -- - * - * Implementation of the ZIP filesystem used in AndroWish. - * - * Copyright (c) 2013-2015 Christian Werner - * - * See the file "license.terms" for information on usage and redistribution of - * this file, and for a DISCLAIMER OF ALL WARRANTIES. - */ - -#include "tclInt.h" -#include "tclFileSystem.h" -#include "tclZipfs.h" - -#if !defined(_WIN32) && !defined(_WIN64) -#include -#endif -#include -#include -#include -#include -#include -#include - -#ifdef HAVE_ZLIB -#include "zlib.h" -#include "zcrypt.h" - -/* - * Various constants and offsets found in ZIP archive files. - */ - -#define ZIP_SIG_LEN 4 - -/* Local header of ZIP archive member (at very beginning of each member). */ -#define ZIP_LOCAL_HEADER_SIG 0x04034b50 -#define ZIP_LOCAL_HEADER_LEN 30 -#define ZIP_LOCAL_SIG_OFFS 0 -#define ZIP_LOCAL_VERSION_OFFS 4 -#define ZIP_LOCAL_FLAGS_OFFS 6 -#define ZIP_LOCAL_COMPMETH_OFFS 8 -#define ZIP_LOCAL_MTIME_OFFS 10 -#define ZIP_LOCAL_MDATE_OFFS 12 -#define ZIP_LOCAL_CRC32_OFFS 14 -#define ZIP_LOCAL_COMPLEN_OFFS 18 -#define ZIP_LOCAL_UNCOMPLEN_OFFS 22 -#define ZIP_LOCAL_PATHLEN_OFFS 26 -#define ZIP_LOCAL_EXTRALEN_OFFS 28 - -/* Central header of ZIP archive member at end of ZIP file. */ -#define ZIP_CENTRAL_HEADER_SIG 0x02014b50 -#define ZIP_CENTRAL_HEADER_LEN 46 -#define ZIP_CENTRAL_SIG_OFFS 0 -#define ZIP_CENTRAL_VERSIONMADE_OFFS 4 -#define ZIP_CENTRAL_VERSION_OFFS 6 -#define ZIP_CENTRAL_FLAGS_OFFS 8 -#define ZIP_CENTRAL_COMPMETH_OFFS 10 -#define ZIP_CENTRAL_MTIME_OFFS 12 -#define ZIP_CENTRAL_MDATE_OFFS 14 -#define ZIP_CENTRAL_CRC32_OFFS 16 -#define ZIP_CENTRAL_COMPLEN_OFFS 20 -#define ZIP_CENTRAL_UNCOMPLEN_OFFS 24 -#define ZIP_CENTRAL_PATHLEN_OFFS 28 -#define ZIP_CENTRAL_EXTRALEN_OFFS 30 -#define ZIP_CENTRAL_FCOMMENTLEN_OFFS 32 -#define ZIP_CENTRAL_DISKFILE_OFFS 34 -#define ZIP_CENTRAL_IATTR_OFFS 36 -#define ZIP_CENTRAL_EATTR_OFFS 38 -#define ZIP_CENTRAL_LOCALHDR_OFFS 42 - -/* Central end signature at very end of ZIP file. */ -#define ZIP_CENTRAL_END_SIG 0x06054b50 -#define ZIP_CENTRAL_END_LEN 22 -#define ZIP_CENTRAL_END_SIG_OFFS 0 -#define ZIP_CENTRAL_DISKNO_OFFS 4 -#define ZIP_CENTRAL_DISKDIR_OFFS 6 -#define ZIP_CENTRAL_ENTS_OFFS 8 -#define ZIP_CENTRAL_TOTALENTS_OFFS 10 -#define ZIP_CENTRAL_DIRSIZE_OFFS 12 -#define ZIP_CENTRAL_DIRSTART_OFFS 16 -#define ZIP_CENTRAL_COMMENTLEN_OFFS 20 - -#define ZIP_MIN_VERSION 20 -#define ZIP_COMPMETH_STORED 0 -#define ZIP_COMPMETH_DEFLATED 8 - -#define ZIP_PASSWORD_END_SIG 0x5a5a4b50 - -/* - * Macros to read and write 16 and 32 bit integers from/to ZIP archives. - */ - -#define zip_read_int(p) \ - ((p)[0] | ((p)[1] << 8) | ((p)[2] << 16) | ((p)[3] << 24)) -#define zip_read_short(p) \ - ((p)[0] | ((p)[1] << 8)) - -#define zip_write_int(p, v) \ - (p)[0] = (v) & 0xff; (p)[1] = ((v) >> 8) & 0xff; \ - (p)[2] = ((v) >> 16) & 0xff; (p)[3] = ((v) >> 24) & 0xff; -#define zip_write_short(p, v) \ - (p)[0] = (v) & 0xff; (p)[1] = ((v) >> 8) & 0xff; - -/* - * Windows drive letters. - */ - -#if defined(_WIN32) || defined(_WIN64) -#define HAS_DRIVES 1 -static const char drvletters[] = - "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"; -#else -#define HAS_DRIVES 0 -#endif - -/* - * Mutex to protect localtime(3) when no reentrant version available. - */ - -#if !defined(_WIN32) && !defined(_WIN64) -#ifndef HAVE_LOCALTIME_R -#ifdef TCL_THREADS -TCL_DECLARE_MUTEX(localtimeMutex) -#endif -#endif -#endif - -/* - * In-core description of mounted ZIP archive file. - */ - -typedef struct ZipFile { - char *name; /* Archive name */ - Tcl_Channel chan; /* Channel handle or NULL */ - unsigned char *data; /* Memory mapped or malloc'ed file */ - long length; /* Length of memory mapped file */ - unsigned char *tofree; /* Non-NULL if malloc'ed file */ - int nfiles; /* Number of files in archive */ - int baseoffs; /* Archive start */ - int baseoffsp; /* Password start */ - int centoffs; /* Archive directory start */ - char pwbuf[264]; /* Password buffer */ -#if defined(_WIN32) || defined(_WIN64) - HANDLE mh; -#endif - int nopen; /* Number of open files on archive */ - struct ZipEntry *entries; /* List of files in archive */ - struct ZipEntry *topents; /* List of top-level dirs in archive */ -#if HAS_DRIVES - int mntdrv; /* Drive letter of mount point */ -#endif - int mntptlen; /* Length of mount point */ - char mntpt[1]; /* Mount point */ -} ZipFile; - -/* - * In-core description of file contained in mounted ZIP archive. - */ - -typedef struct ZipEntry { - char *name; /* The full pathname of the virtual file */ - ZipFile *zipfile; /* The ZIP file holding this virtual file */ - long offset; /* Data offset into memory mapped ZIP file */ - int nbyte; /* Uncompressed size of the virtual file */ - int nbytecompr; /* Compressed size of the virtual file */ - int cmeth; /* Compress method */ - int isdir; /* Set to 1 if directory */ - int depth; /* Number of slashes in path. */ - int crc32; /* CRC-32 */ - int timestamp; /* Modification time */ - int isenc; /* True if data is encrypted */ - unsigned char *data; /* File data if written */ - struct ZipEntry *next; /* Next file in the same archive */ - struct ZipEntry *tnext; /* Next top-level dir in archive */ -} ZipEntry; - -/* - * File channel for file contained in mounted ZIP archive. - */ - -typedef struct ZipChannel { - ZipFile *zipfile; /* The ZIP file holding this channel */ - ZipEntry *zipentry; /* Pointer back to virtual file */ - unsigned long nmax; /* Max. size for write */ - unsigned long nbyte; /* Number of bytes of uncompressed data */ - unsigned long nread; /* Pos of next byte to be read from the channel */ - unsigned char *ubuf; /* Pointer to the uncompressed data */ - int iscompr; /* True if data is compressed */ - int isdir; /* Set to 1 if directory */ - int isenc; /* True if data is encrypted */ - int iswr; /* True if open for writing */ - unsigned long keys[3]; /* Key for decryption */ -} ZipChannel; - -/* - * Global variables. - * - * Most are kept in single ZipFS struct. When build with threading - * support this struct is protected by the ZipFSMutex (see below). - * - * The "fileHash" component is the process wide global table of all known - * ZIP archive members in all mounted ZIP archives. - * - * The "zipHash" components is the process wide global table of all mounted - * ZIP archive files. - */ - -static struct { - int initialized; /* True when initialized */ - int lock; /* RW lock, see below */ - int waiters; /* RW lock, see below */ - int wrmax; /* Maximum write size of a file */ - int idCount; /* Counter for channel names */ - Tcl_HashTable fileHash; /* File name to ZipEntry mapping */ - Tcl_HashTable zipHash; /* Mount to ZipFile mapping */ -} ZipFS = { - 0, 0, 0, 0, 0, -}; - -/* - * For password rotation. - */ - -static const char pwrot[16] = { - 0x00, 0x80, 0x40, 0xc0, 0x20, 0xa0, 0x60, 0xe0, - 0x10, 0x90, 0x50, 0xd0, 0x30, 0xb0, 0x70, 0xf0 -}; - -/* - * Table to compute CRC32. - */ - -static const unsigned int crc32tab[256] = { - 0x00000000, 0x77073096, 0xee0e612c, 0x990951ba, 0x076dc419, - 0x706af48f, 0xe963a535, 0x9e6495a3, 0x0edb8832, 0x79dcb8a4, - 0xe0d5e91e, 0x97d2d988, 0x09b64c2b, 0x7eb17cbd, 0xe7b82d07, - 0x90bf1d91, 0x1db71064, 0x6ab020f2, 0xf3b97148, 0x84be41de, - 0x1adad47d, 0x6ddde4eb, 0xf4d4b551, 0x83d385c7, 0x136c9856, - 0x646ba8c0, 0xfd62f97a, 0x8a65c9ec, 0x14015c4f, 0x63066cd9, - 0xfa0f3d63, 0x8d080df5, 0x3b6e20c8, 0x4c69105e, 0xd56041e4, - 0xa2677172, 0x3c03e4d1, 0x4b04d447, 0xd20d85fd, 0xa50ab56b, - 0x35b5a8fa, 0x42b2986c, 0xdbbbc9d6, 0xacbcf940, 0x32d86ce3, - 0x45df5c75, 0xdcd60dcf, 0xabd13d59, 0x26d930ac, 0x51de003a, - 0xc8d75180, 0xbfd06116, 0x21b4f4b5, 0x56b3c423, 0xcfba9599, - 0xb8bda50f, 0x2802b89e, 0x5f058808, 0xc60cd9b2, 0xb10be924, - 0x2f6f7c87, 0x58684c11, 0xc1611dab, 0xb6662d3d, 0x76dc4190, - 0x01db7106, 0x98d220bc, 0xefd5102a, 0x71b18589, 0x06b6b51f, - 0x9fbfe4a5, 0xe8b8d433, 0x7807c9a2, 0x0f00f934, 0x9609a88e, - 0xe10e9818, 0x7f6a0dbb, 0x086d3d2d, 0x91646c97, 0xe6635c01, - 0x6b6b51f4, 0x1c6c6162, 0x856530d8, 0xf262004e, 0x6c0695ed, - 0x1b01a57b, 0x8208f4c1, 0xf50fc457, 0x65b0d9c6, 0x12b7e950, - 0x8bbeb8ea, 0xfcb9887c, 0x62dd1ddf, 0x15da2d49, 0x8cd37cf3, - 0xfbd44c65, 0x4db26158, 0x3ab551ce, 0xa3bc0074, 0xd4bb30e2, - 0x4adfa541, 0x3dd895d7, 0xa4d1c46d, 0xd3d6f4fb, 0x4369e96a, - 0x346ed9fc, 0xad678846, 0xda60b8d0, 0x44042d73, 0x33031de5, - 0xaa0a4c5f, 0xdd0d7cc9, 0x5005713c, 0x270241aa, 0xbe0b1010, - 0xc90c2086, 0x5768b525, 0x206f85b3, 0xb966d409, 0xce61e49f, - 0x5edef90e, 0x29d9c998, 0xb0d09822, 0xc7d7a8b4, 0x59b33d17, - 0x2eb40d81, 0xb7bd5c3b, 0xc0ba6cad, 0xedb88320, 0x9abfb3b6, - 0x03b6e20c, 0x74b1d29a, 0xead54739, 0x9dd277af, 0x04db2615, - 0x73dc1683, 0xe3630b12, 0x94643b84, 0x0d6d6a3e, 0x7a6a5aa8, - 0xe40ecf0b, 0x9309ff9d, 0x0a00ae27, 0x7d079eb1, 0xf00f9344, - 0x8708a3d2, 0x1e01f268, 0x6906c2fe, 0xf762575d, 0x806567cb, - 0x196c3671, 0x6e6b06e7, 0xfed41b76, 0x89d32be0, 0x10da7a5a, - 0x67dd4acc, 0xf9b9df6f, 0x8ebeeff9, 0x17b7be43, 0x60b08ed5, - 0xd6d6a3e8, 0xa1d1937e, 0x38d8c2c4, 0x4fdff252, 0xd1bb67f1, - 0xa6bc5767, 0x3fb506dd, 0x48b2364b, 0xd80d2bda, 0xaf0a1b4c, - 0x36034af6, 0x41047a60, 0xdf60efc3, 0xa867df55, 0x316e8eef, - 0x4669be79, 0xcb61b38c, 0xbc66831a, 0x256fd2a0, 0x5268e236, - 0xcc0c7795, 0xbb0b4703, 0x220216b9, 0x5505262f, 0xc5ba3bbe, - 0xb2bd0b28, 0x2bb45a92, 0x5cb36a04, 0xc2d7ffa7, 0xb5d0cf31, - 0x2cd99e8b, 0x5bdeae1d, 0x9b64c2b0, 0xec63f226, 0x756aa39c, - 0x026d930a, 0x9c0906a9, 0xeb0e363f, 0x72076785, 0x05005713, - 0x95bf4a82, 0xe2b87a14, 0x7bb12bae, 0x0cb61b38, 0x92d28e9b, - 0xe5d5be0d, 0x7cdcefb7, 0x0bdbdf21, 0x86d3d2d4, 0xf1d4e242, - 0x68ddb3f8, 0x1fda836e, 0x81be16cd, 0xf6b9265b, 0x6fb077e1, - 0x18b74777, 0x88085ae6, 0xff0f6a70, 0x66063bca, 0x11010b5c, - 0x8f659eff, 0xf862ae69, 0x616bffd3, 0x166ccf45, 0xa00ae278, - 0xd70dd2ee, 0x4e048354, 0x3903b3c2, 0xa7672661, 0xd06016f7, - 0x4969474d, 0x3e6e77db, 0xaed16a4a, 0xd9d65adc, 0x40df0b66, - 0x37d83bf0, 0xa9bcae53, 0xdebb9ec5, 0x47b2cf7f, 0x30b5ffe9, - 0xbdbdf21c, 0xcabac28a, 0x53b39330, 0x24b4a3a6, 0xbad03605, - 0xcdd70693, 0x54de5729, 0x23d967bf, 0xb3667a2e, 0xc4614ab8, - 0x5d681b02, 0x2a6f2b94, 0xb40bbe37, 0xc30c8ea1, 0x5a05df1b, - 0x2d02ef8d, -}; - -/* - *------------------------------------------------------------------------- - * - * ReadLock, WriteLock, Unlock -- - * - * POSIX like rwlock functions to support multiple readers - * and single writer on internal structs. - * - * Limitations: - * - a read lock cannot be promoted to a write lock - * - a write lock may not be nested - * - *------------------------------------------------------------------------- - */ - -TCL_DECLARE_MUTEX(ZipFSMutex) - -#ifdef TCL_THREADS - -static Tcl_Condition ZipFSCond; - -static void -ReadLock(void) -{ - Tcl_MutexLock(&ZipFSMutex); - while (ZipFS.lock < 0) { - ZipFS.waiters++; - Tcl_ConditionWait(&ZipFSCond, &ZipFSMutex, NULL); - ZipFS.waiters--; - } - ZipFS.lock++; - Tcl_MutexUnlock(&ZipFSMutex); -} - -static void -WriteLock(void) -{ - Tcl_MutexLock(&ZipFSMutex); - while (ZipFS.lock != 0) { - ZipFS.waiters++; - Tcl_ConditionWait(&ZipFSCond, &ZipFSMutex, NULL); - ZipFS.waiters--; - } - ZipFS.lock = -1; - Tcl_MutexUnlock(&ZipFSMutex); -} - -static void -Unlock(void) -{ - Tcl_MutexLock(&ZipFSMutex); - if (ZipFS.lock > 0) { - --ZipFS.lock; - } else if (ZipFS.lock < 0) { - ZipFS.lock = 0; - } - if ((ZipFS.lock == 0) && (ZipFS.waiters > 0)) { - Tcl_ConditionNotify(&ZipFSCond); - } - Tcl_MutexUnlock(&ZipFSMutex); -} - -#else - -#define ReadLock() do {} while (0) -#define WriteLock() do {} while (0) -#define Unlock() do {} while (0) - -#endif - -/* - *------------------------------------------------------------------------- - * - * DosTimeDate, ToDosTime, ToDosDate -- - * - * Functions to perform conversions between DOS time stamps - * and POSIX time_t. - * - *------------------------------------------------------------------------- - */ - -static time_t -DosTimeDate(int dosDate, int dosTime) -{ - struct tm tm; - time_t ret; - - memset(&tm, 0, sizeof (tm)); - 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) << 1; - ret = mktime(&tm); - if (ret == (time_t) -1) { - /* fallback to 1980-01-01T00:00:00+00:00 (DOS epoch) */ - ret = (time_t) 315532800; - } - return ret; -} - -static int -ToDosTime(time_t when) -{ - struct tm *tmp, tm; - -#ifdef TCL_THREADS -#if defined(_WIN32) || defined(_WIN64) - /* Win32 uses thread local storage */ - tmp = localtime(&when); - tm = *tmp; -#else -#ifdef HAVE_LOCALTIME_R - tmp = &tm; - localtime_r(&when, tmp); -#else - Tcl_MutexLock(&localtimeMutex); - tmp = localtime(&when); - tm = *tmp; - Tcl_MutexUnlock(&localtimeMutex); -#endif -#endif -#else - tmp = localtime(&when); - tm = *tmp; -#endif - return (tm.tm_hour << 11) | (tm.tm_min << 5) | (tm.tm_sec >> 1); -} - -static int -ToDosDate(time_t when) -{ - struct tm *tmp, tm; - -#ifdef TCL_THREADS -#if defined(_WIN32) || defined(_WIN64) - /* Win32 uses thread local storage */ - tmp = localtime(&when); - tm = *tmp; -#else -#ifdef HAVE_LOCALTIME_R - tmp = &tm; - localtime_r(&when, tmp); -#else - Tcl_MutexLock(&localtimeMutex); - tmp = localtime(&when); - tm = *tmp; - Tcl_MutexUnlock(&localtimeMutex); -#endif -#endif -#else - tmp = localtime(&when); - tm = *tmp; -#endif - return ((tm.tm_year - 80) << 9) | ((tm.tm_mon + 1) << 5) | tm.tm_mday; -} - -/* - *------------------------------------------------------------------------- - * - * CountSlashes -- - * - * This function counts the number of slashes in a pathname string. - * - * Results: - * Number of slashes found in string. - * - * Side effects: - * None. - * - *------------------------------------------------------------------------- - */ - -static int -CountSlashes(const char *string) -{ - int count = 0; - const char *p = string; - - while (*p != '\0') { - if (*p == '/') { - count++; - } - p++; - } - return count; -} - -/* - *------------------------------------------------------------------------- - * - * CanonicalPath -- - * - * This function computes the canonical path from a directory - * and file name components into the specified Tcl_DString. - * - * Results: - * Returns the pointer to the canonical path contained in the - * specified Tcl_DString. - * - * Side effects: - * Modifies the specified Tcl_DString. - * - *------------------------------------------------------------------------- - */ - -static char * -CanonicalPath(const char *root, const char *tail, Tcl_DString *dsPtr) -{ - char *path; - int i, j, c, isunc = 0; - -#if HAS_DRIVES - if ((tail[0] != '\0') && (strchr(drvletters, tail[0]) != NULL) && - (tail[1] == ':')) { - tail += 2; - } - /* UNC style path */ - if (tail[0] == '\\') { - root = ""; - ++tail; - } - if (tail[0] == '\\') { - root = "/"; - ++tail; - } -#endif - /* UNC style path */ - if ((root[0] == '/') && (root[1] == '/')) { - isunc = 1; - } - if (tail[0] == '/') { - root = ""; - ++tail; - isunc = 0; - } - if (tail[0] == '/') { - root = "/"; - ++tail; - isunc = 1; - } - i = strlen(root); - j = strlen(tail); - Tcl_DStringSetLength(dsPtr, i + j + 1); - path = Tcl_DStringValue(dsPtr); - memcpy(path, root, i); - path[i++] = '/'; - memcpy(path + i, tail, j); -#if HAS_DRIVES - for (i = 0; path[i] != '\0'; i++) { - if (path[i] == '\\') { - path[i] = '/'; - } - } -#endif - for (i = j = 0; (c = path[i]) != '\0'; i++) { - if (c == '/') { - int c2 = path[i + 1]; - - if (c2 == '/') { - continue; - } - if (c2 == '.') { - int c3 = path[i + 2]; - - if ((c3 == '/') || (c3 == '\0')) { - i++; - continue; - } - if ((c3 == '.') && - ((path[i + 3] == '/') || (path [i + 3] == '\0'))) { - i += 2; - while ((j > 0) && (path[j - 1] != '/')) { - j--; - } - if (j > isunc) { - --j; - while ((j > 1 + isunc) && (path[j - 2] == '/')) { - j--; - } - } - continue; - } - } - } - path[j++] = c; - } - if (j == 0) { - path[j++] = '/'; - } - path[j] = 0; - Tcl_DStringSetLength(dsPtr, j); - return Tcl_DStringValue(dsPtr); -} - -/* - *------------------------------------------------------------------------- - * - * AbsolutePath -- - * - * This function computes the absolute path from a given - * (relative) path name into the specified Tcl_DString. - * - * Results: - * Returns the pointer to the absolute path contained in the - * specified Tcl_DString. - * - * Side effects: - * Modifies the specified Tcl_DString. - * - *------------------------------------------------------------------------- - */ - -static char * -AbsolutePath(const char *path, -#if HAS_DRIVES - int *drvPtr, -#endif - Tcl_DString *dsPtr) -{ - char *result; - -#if HAS_DRIVES - if (drvPtr != NULL) { - *drvPtr = 0; - } -#endif - if (*path == '~') { - Tcl_DStringAppend(dsPtr, path, -1); - return Tcl_DStringValue(dsPtr); - } - if ((*path != '/') -#if HAS_DRIVES - && (*path != '\\') && - (((*path != '\0') && (strchr(drvletters, *path) == NULL)) || - (path[1] != ':')) -#endif - ) { - Tcl_DString pwd; - - /* relative path */ - Tcl_DStringInit(&pwd); - Tcl_GetCwd(NULL, &pwd); - result = Tcl_DStringValue(&pwd); -#if HAS_DRIVES - if ((result[0] != '\0') && (strchr(drvletters, result[0]) != NULL) && - (result[1] == ':')) { - if (drvPtr != NULL) { - drvPtr[0] = result[0]; - if ((drvPtr[0] >= 'a') && (drvPtr[0] <= 'z')) { - drvPtr[0] -= 'a' - 'A'; - } - } - result += 2; - } -#endif - result = CanonicalPath(result, path, dsPtr); - Tcl_DStringFree(&pwd); - } else { - /* absolute path */ -#if HAS_DRIVES - if ((path[0] != '\0') && (strchr(drvletters, path[0]) != NULL) && - (path[1] == ':')) { - if (drvPtr != NULL) { - drvPtr[0] = path[0]; - if ((drvPtr[0] >= 'a') && (drvPtr[0] <= 'z')) { - drvPtr[0] -= 'a' - 'A'; - } - } - } -#endif - result = CanonicalPath("", path, dsPtr); - } - return result; -} - -/* - *------------------------------------------------------------------------- - * - * ZipFSLookup -- - * - * This function returns the ZIP entry struct corresponding to - * the ZIP archive member of the given file name. - * - * Results: - * Returns the pointer to ZIP entry struct or NULL if the - * the given file name could not be found in the global list - * of ZIP archive members. - * - * Side effects: - * None. - * - *------------------------------------------------------------------------- - */ - -static ZipEntry * -ZipFSLookup(char *filename) -{ - char *realname; - Tcl_HashEntry *hPtr; - ZipEntry *z; - Tcl_DString ds; -#if HAS_DRIVES - int drive = 0; -#endif - - Tcl_DStringInit(&ds); -#if HAS_DRIVES - realname = AbsolutePath(filename, &drive, &ds); -#else - realname = AbsolutePath(filename, &ds); -#endif - hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, realname); - z = hPtr ? (ZipEntry *) Tcl_GetHashValue(hPtr) : NULL; - Tcl_DStringFree(&ds); -#if HAS_DRIVES - if ((z != NULL) && drive && (drive != z->zipfile->mntdrv)) { - z = NULL; - } -#endif - return z; -} - -#ifdef NEVER_USED - -/* - *------------------------------------------------------------------------- - * - * ZipFSLookupMount -- - * - * This function returns an indication if the given file name - * corresponds to a mounted ZIP archive file. - * - * Results: - * Returns true, if the given file name is a mounted ZIP archive file. - * - * Side effects: - * None. - * - *------------------------------------------------------------------------- - */ - -static int -ZipFSLookupMount(char *filename) -{ - char *realname; - Tcl_HashEntry *hPtr; - Tcl_HashSearch search; - ZipFile *zf; - Tcl_DString ds; - int match = 0; -#if HAS_DRIVES - int drive = 0; -#endif - - Tcl_DStringInit(&ds); -#if HAS_DRIVES - realname = AbsolutePath(filename, &drive, &ds); -#else - realname = AbsolutePath(filename, &ds); -#endif - hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); - while (hPtr != NULL) { - if ((zf = (ZipFile *) Tcl_GetHashValue(hPtr)) != NULL) { -#if HAS_DRIVES - if (drive && (drive != zf->mntdrv)) { - hPtr = Tcl_NextHashEntry(&search); - continue; - } -#endif - if (strcmp(zf->mntpt, realname) == 0) { - match = 1; - break; - } - } - hPtr = Tcl_NextHashEntry(&search); - } - Tcl_DStringFree(&ds); - return match; -} -#endif - -/* - *------------------------------------------------------------------------- - * - * ZipFSCloseArchive -- - * - * This function closes a mounted ZIP archive file. - * - * Results: - * None. - * - * Side effects: - * A memory mapped ZIP archive is unmapped, allocated memory is - * released. - * - *------------------------------------------------------------------------- - */ - -static void -ZipFSCloseArchive(Tcl_Interp *interp, ZipFile *zf) -{ -#if defined(_WIN32) || defined(_WIN64) - if ((zf->data != NULL) && (zf->tofree == NULL)) { - UnmapViewOfFile(zf->data); - zf->data = NULL; - } - if (zf->mh != INVALID_HANDLE_VALUE) { - CloseHandle(zf->mh); - } -#else - if ((zf->data != MAP_FAILED) && (zf->tofree == NULL)) { - munmap(zf->data, zf->length); - zf->data = MAP_FAILED; - } -#endif - if (zf->tofree != NULL) { - Tcl_Free((char *) zf->tofree); - zf->tofree = NULL; - } - Tcl_Close(interp, zf->chan); - zf->chan = NULL; -} - -/* - *------------------------------------------------------------------------- - * - * ZipFSOpenArchive -- - * - * This function opens a ZIP archive file for reading. An attempt - * is made to memory map that file. Otherwise it is read into - * an allocated memory buffer. The ZIP archive header is verified - * and must be valid for the function to succeed. When "needZip" - * is zero an embedded ZIP archive in an executable file is accepted. - * - * Results: - * TCL_OK on success, TCL_ERROR otherwise with an error message - * placed into the given "interp" if it is not NULL. - * - * Side effects: - * ZIP archive is memory mapped or read into allocated memory, - * the given ZipFile struct is filled with information about - * the ZIP archive file. - * - *------------------------------------------------------------------------- - */ - -static int -ZipFSOpenArchive(Tcl_Interp *interp, const char *zipname, int needZip, - ZipFile *zf) -{ - int i; - ClientData handle; - unsigned char *p, *q; - -#if defined(_WIN32) || defined(_WIN64) - zf->data = NULL; - zf->mh = INVALID_HANDLE_VALUE; -#else - zf->data = MAP_FAILED; -#endif - zf->length = 0; - zf->nfiles = 0; - zf->baseoffs = zf->baseoffsp = 0; - zf->tofree = NULL; - zf->pwbuf[0] = 0; - zf->chan = Tcl_OpenFileChannel(interp, zipname, "r", 0); - if (zf->chan == NULL) { - return TCL_ERROR; - } - if (Tcl_GetChannelHandle(zf->chan, TCL_READABLE, &handle) != TCL_OK) { - if (Tcl_SetChannelOption(interp, zf->chan, "-translation", "binary") - != TCL_OK) { - goto error; - } - if (Tcl_SetChannelOption(interp, zf->chan, "-encoding", "binary") - != TCL_OK) { - goto error; - } - zf->length = Tcl_Seek(zf->chan, 0, SEEK_END); - if ((zf->length <= 0) || (zf->length > 64 * 1024 * 1024)) { - if (interp) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("illegal file size", -1)); - } - goto error; - } - Tcl_Seek(zf->chan, 0, SEEK_SET); - zf->tofree = zf->data = (unsigned char *) Tcl_AttemptAlloc(zf->length); - if (zf->tofree == NULL) { - if (interp) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("out of memory", -1)); - } - goto error; - } - i = Tcl_Read(zf->chan, (char *) zf->data, zf->length); - if (i != zf->length) { - if (interp) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("file read error", -1)); - } - goto error; - } - Tcl_Close(interp, zf->chan); - zf->chan = NULL; - } else { -#if defined(_WIN32) || defined(_WIN64) - zf->length = GetFileSize((HANDLE) handle, 0); - if ((zf->length == INVALID_FILE_SIZE) || - (zf->length < ZIP_CENTRAL_END_LEN)) { - if (interp != NULL) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("invalid file size", -1)); - } - goto error; - } - zf->mh = CreateFileMapping((HANDLE) handle, 0, PAGE_READONLY, 0, - zf->length, 0); - if (zf->mh == INVALID_HANDLE_VALUE) { - if (interp != NULL) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("file mapping failed", -1)); - } - goto error; - } - zf->data = MapViewOfFile(zf->mh, FILE_MAP_READ, 0, 0, zf->length); - if (zf->data == NULL) { - if (interp != NULL) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("file mapping failed", -1)); - } - goto error; - } -#else - zf->length = lseek((int) (long) handle, 0, SEEK_END); - if ((zf->length == -1) || (zf->length < ZIP_CENTRAL_END_LEN)) { - if (interp != NULL) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("invalid file size", -1)); - } - goto error; - } - lseek((int) (long) handle, 0, SEEK_SET); - zf->data = (unsigned char *) mmap(0, zf->length, PROT_READ, - MAP_FILE | MAP_PRIVATE, - (int) (long) handle, 0); - if (zf->data == MAP_FAILED) { - if (interp != NULL) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("file mapping failed", -1)); - } - goto error; - } -#endif - } - p = zf->data + zf->length - ZIP_CENTRAL_END_LEN; - while (p >= zf->data) { - if (*p == (ZIP_CENTRAL_END_SIG & 0xFF)) { - if (zip_read_int(p) == ZIP_CENTRAL_END_SIG) { - break; - } - p -= ZIP_SIG_LEN; - } else { - --p; - } - } - if (p < zf->data) { - if (!needZip) { - zf->baseoffs = zf->baseoffsp = zf->length; - return TCL_OK; - } - if (interp != NULL) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("wrong end signature", -1)); - } - goto error; - } - zf->nfiles = zip_read_short(p + ZIP_CENTRAL_ENTS_OFFS); - if (zf->nfiles == 0) { - if (!needZip) { - zf->baseoffs = zf->baseoffsp = zf->length; - return TCL_OK; - } - if (interp != NULL) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("empty archive", -1)); - } - goto error; - } - q = zf->data + zip_read_int(p + ZIP_CENTRAL_DIRSTART_OFFS); - p -= zip_read_int(p + ZIP_CENTRAL_DIRSIZE_OFFS); - if ((p < zf->data) || (p > (zf->data + zf->length)) || - (q < zf->data) || (q > (zf->data + zf->length))) { - if (!needZip) { - zf->baseoffs = zf->baseoffsp = zf->length; - return TCL_OK; - } - if (interp != NULL) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("archive directory not found", -1)); - } - goto error; - } - zf->baseoffs = zf->baseoffsp = p - q; - zf->centoffs = p - zf->data; - q = p; - for (i = 0; i < zf->nfiles; i++) { - int pathlen, comlen, extra; - - if ((q + ZIP_CENTRAL_HEADER_LEN) > (zf->data + zf->length)) { - if (interp != NULL) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("wrong header length", -1)); - } - goto error; - } - if (zip_read_int(q) != ZIP_CENTRAL_HEADER_SIG) { - if (interp != NULL) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("wrong header signature", -1)); - } - goto error; - } - pathlen = zip_read_short(q + ZIP_CENTRAL_PATHLEN_OFFS); - comlen = zip_read_short(q + ZIP_CENTRAL_FCOMMENTLEN_OFFS); - extra = zip_read_short(q + ZIP_CENTRAL_EXTRALEN_OFFS); - q += pathlen + comlen + extra + ZIP_CENTRAL_HEADER_LEN; - } - q = zf->data + zf->baseoffs; - if ((zf->baseoffs >= 6) && - (zip_read_int(q - 4) == ZIP_PASSWORD_END_SIG)) { - i = q[-5]; - if (q - 5 - i > zf->data) { - zf->pwbuf[0] = i; - memcpy(zf->pwbuf + 1, q - 5 - i, i); - zf->baseoffsp -= i ? (5 + i) : 0; - } - } - return TCL_OK; - -error: - ZipFSCloseArchive(interp, zf); - return TCL_ERROR; -} - -/* - *------------------------------------------------------------------------- - * - * Tclzipfs_Mount -- - * - * This procedure is invoked to mount a given ZIP archive file on - * a given mountpoint with optional ZIP password. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * A ZIP archive file is read, analyzed and mounted, resources are - * allocated. - * - *------------------------------------------------------------------------- - */ - -int -Tclzipfs_Mount(Tcl_Interp *interp, const char *zipname, const char *mntpt, - const char *passwd) -{ - char *realname, *p; - int i, pwlen, isNew; - ZipFile *zf, zf0; - ZipEntry *z; - Tcl_HashEntry *hPtr; - Tcl_DString ds, dsm, fpBuf; - unsigned char *q; -#if HAS_DRIVES - int drive = 0; -#endif - - ReadLock(); - if (!ZipFS.initialized) { - if (interp != NULL) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("not initialized", -1)); - } - Unlock(); - return TCL_ERROR; - } - if (zipname == NULL) { - Tcl_HashSearch search; - int ret = TCL_OK; - - i = 0; - hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); - while (hPtr != NULL) { - if ((zf = (ZipFile *) Tcl_GetHashValue(hPtr)) != NULL) { - if (interp != NULL) { - Tcl_AppendElement(interp, zf->mntpt); - Tcl_AppendElement(interp, zf->name); - } - ++i; - } - hPtr = Tcl_NextHashEntry(&search); - } - if (interp == NULL) { - ret = (i > 0) ? TCL_OK : TCL_BREAK; - } - Unlock(); - return ret; - } - if (mntpt == NULL) { - if (interp == NULL) { - Unlock(); - return TCL_OK; - } - Tcl_DStringInit(&ds); -#if HAS_DRIVES - p = AbsolutePath(zipname, &drive, &ds); -#else - p = AbsolutePath(zipname, &ds); -#endif - hPtr = Tcl_FindHashEntry(&ZipFS.zipHash, p); - if (hPtr != NULL) { - if ((zf = Tcl_GetHashValue(hPtr)) != NULL) { -#if HAS_DRIVES - if (drive == zf->mntdrv) { - Tcl_Obj *string; - char drvbuf[3]; - - drvbuf[0] = zf->mntdrv; - drvbuf[1] = ':'; - drvbuf[2] = '\0'; - string = Tcl_NewStringObj(drvbuf, 2); - Tcl_AppendToObj(string, zf->mntpt, zf->mntptlen); - Tcl_SetObjResult(interp, string); - } -#else - Tcl_SetObjResult(interp, - Tcl_NewStringObj(zf->mntpt, zf->mntptlen)); -#endif - } - } - Unlock(); - Tcl_DStringFree(&ds); - return TCL_OK; - } - Unlock(); - pwlen = 0; - if (passwd != NULL) { - pwlen = strlen(passwd); - if ((pwlen > 255) || (strchr(passwd, 0xff) != NULL)) { - if (interp) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("illegal password", -1)); - } - return TCL_ERROR; - } - } - if (ZipFSOpenArchive(interp, zipname, 1, &zf0) != TCL_OK) { - return TCL_ERROR; - } - Tcl_DStringInit(&ds); -#if HAS_DRIVES - realname = AbsolutePath(zipname, NULL, &ds); -#else - realname = AbsolutePath(zipname, &ds); -#endif - /* - * Mount point can come from Tcl_GetNameOfExecutable() - * which sometimes is a relative or otherwise denormalized path. - * But an absolute name is needed as mount point here. - */ - Tcl_DStringInit(&dsm); -#if HAS_DRIVES - mntpt = AbsolutePath(mntpt, &drive, &dsm); -#else - mntpt = AbsolutePath(mntpt, &dsm); -#endif - WriteLock(); - hPtr = Tcl_CreateHashEntry(&ZipFS.zipHash, realname, &isNew); - Tcl_DStringSetLength(&ds, 0); - if (!isNew) { - zf = (ZipFile *) Tcl_GetHashValue(hPtr); - if (interp != NULL) { - Tcl_AppendResult(interp, "already mounted on \"", zf->mntptlen ? - zf->mntpt : "/", "\"", (char *) NULL); - } - Unlock(); - Tcl_DStringFree(&ds); - Tcl_DStringFree(&dsm); - ZipFSCloseArchive(interp, &zf0); - return TCL_ERROR; - } - if (strcmp(mntpt, "/") == 0) { - mntpt = ""; - } - zf = (ZipFile *) Tcl_AttemptAlloc(sizeof (*zf) + strlen(mntpt) + 1); - if (zf == NULL) { - if (interp != NULL) { - Tcl_AppendResult(interp, "out of memory", (char *) NULL); - } - Unlock(); - Tcl_DStringFree(&ds); - Tcl_DStringFree(&dsm); - ZipFSCloseArchive(interp, &zf0); - return TCL_ERROR; - } - *zf = zf0; - zf->name = Tcl_GetHashKey(&ZipFS.zipHash, hPtr); - strcpy(zf->mntpt, mntpt); - zf->mntptlen = strlen(zf->mntpt); -#if HAS_DRIVES - for (p = zf->mntpt; *p != '\0'; p++) { - if (*p == '\\') { - *p = '/'; - } - } - zf->mntdrv = drive; -#endif - zf->entries = NULL; - zf->topents = NULL; - zf->nopen = 0; - Tcl_SetHashValue(hPtr, (ClientData) zf); - if ((zf->pwbuf[0] == 0) && pwlen) { - int k = 0; - - i = pwlen; - zf->pwbuf[k++] = i; - while (i > 0) { - zf->pwbuf[k] = (passwd[i - 1] & 0x0f) | - pwrot[(passwd[i - 1] >> 4) & 0x0f]; - k++; - i--; - } - zf->pwbuf[k] = '\0'; - } - if (mntpt[0] != '\0') { - z = (ZipEntry *) Tcl_Alloc(sizeof (*z)); - z->name = NULL; - z->tnext = NULL; - z->depth = CountSlashes(mntpt); - z->zipfile = zf; - z->isdir = 1; - z->isenc = 0; - z->offset = zf->baseoffs; - z->crc32 = 0; - z->timestamp = 0; - z->nbyte = z->nbytecompr = 0; - z->cmeth = ZIP_COMPMETH_STORED; - z->data = NULL; - hPtr = Tcl_CreateHashEntry(&ZipFS.fileHash, mntpt, &isNew); - if (!isNew) { - /* skip it */ - Tcl_Free((char *) z); - } else { - Tcl_SetHashValue(hPtr, (ClientData) z); - z->name = Tcl_GetHashKey(&ZipFS.fileHash, hPtr); - z->next = zf->entries; - zf->entries = z; - } - } - q = zf->data + zf->centoffs; - Tcl_DStringInit(&fpBuf); - for (i = 0; i < zf->nfiles; i++) { - int pathlen, comlen, extra, isdir = 0, dosTime, dosDate, nbcompr, offs; - unsigned char *lq, *gq = NULL; - char *fullpath, *path; - - pathlen = zip_read_short(q + ZIP_CENTRAL_PATHLEN_OFFS); - comlen = zip_read_short(q + ZIP_CENTRAL_FCOMMENTLEN_OFFS); - extra = zip_read_short(q + ZIP_CENTRAL_EXTRALEN_OFFS); - Tcl_DStringSetLength(&ds, 0); - Tcl_DStringAppend(&ds, (char *) q + ZIP_CENTRAL_HEADER_LEN, pathlen); - path = Tcl_DStringValue(&ds); - if ((pathlen > 0) && (path[pathlen - 1] == '/')) { - Tcl_DStringSetLength(&ds, pathlen - 1); - path = Tcl_DStringValue(&ds); - isdir = 1; - } - if ((strcmp(path, ".") == 0) || (strcmp(path, "..") == 0)) { - goto nextent; - } - lq = zf->data + zf->baseoffs + - zip_read_int(q + ZIP_CENTRAL_LOCALHDR_OFFS); - if ((lq < zf->data) || (lq > (zf->data + zf->length))) { - goto nextent; - } - nbcompr = zip_read_int(lq + ZIP_LOCAL_COMPLEN_OFFS); - if (!isdir && (nbcompr == 0) && - (zip_read_int(lq + ZIP_LOCAL_UNCOMPLEN_OFFS) == 0) && - (zip_read_int(lq + ZIP_LOCAL_CRC32_OFFS) == 0)) { - gq = q; - nbcompr = zip_read_int(gq + ZIP_CENTRAL_COMPLEN_OFFS); - } - offs = (lq - zf->data) - + ZIP_LOCAL_HEADER_LEN - + zip_read_short(lq + ZIP_LOCAL_PATHLEN_OFFS) - + zip_read_short(lq + ZIP_LOCAL_EXTRALEN_OFFS); - if ((offs + nbcompr) > zf->length) { - goto nextent; - } - if (!isdir && (mntpt[0] == '\0') && !CountSlashes(path)) { -#ifdef ANDROID - /* - * When mounting the ZIP archive on the root directory try - * to remap top level regular files of the archive to - * /assets/.root/... since this directory should not be - * in a valid APK due to the leading dot in the file name - * component. This trick should make the files - * AndroidManifest.xml, resources.arsc, and classes.dex - * visible to Tcl. - */ - Tcl_DString ds2; - - Tcl_DStringInit(&ds2); - Tcl_DStringAppend(&ds2, "assets/.root/", -1); - Tcl_DStringAppend(&ds2, path, -1); - hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, Tcl_DStringValue(&ds2)); - if (hPtr != NULL) { - /* should not happen but skip it anyway */ - Tcl_DStringFree(&ds2); - goto nextent; - } - Tcl_DStringSetLength(&ds, 0); - Tcl_DStringAppend(&ds, Tcl_DStringValue(&ds2), - Tcl_DStringLength(&ds2)); - path = Tcl_DStringValue(&ds); - Tcl_DStringFree(&ds2); -#else - /* - * Regular files skipped when mounting on root. - */ - goto nextent; -#endif - } - Tcl_DStringSetLength(&fpBuf, 0); - fullpath = CanonicalPath(mntpt, path, &fpBuf); - z = (ZipEntry *) Tcl_Alloc(sizeof (*z)); - z->name = NULL; - z->tnext = NULL; - z->depth = CountSlashes(fullpath); - z->zipfile = zf; - z->isdir = isdir; - z->isenc = (zip_read_short(lq + ZIP_LOCAL_FLAGS_OFFS) & 1) - && (nbcompr > 12); - z->offset = offs; - if (gq != NULL) { - z->crc32 = zip_read_int(gq + ZIP_CENTRAL_CRC32_OFFS); - dosDate = zip_read_short(gq + ZIP_CENTRAL_MDATE_OFFS); - dosTime = zip_read_short(gq + ZIP_CENTRAL_MTIME_OFFS); - z->timestamp = DosTimeDate(dosDate, dosTime); - z->nbyte = zip_read_int(gq + ZIP_CENTRAL_UNCOMPLEN_OFFS); - z->cmeth = zip_read_short(gq + ZIP_CENTRAL_COMPMETH_OFFS); - } else { - z->crc32 = zip_read_int(lq + ZIP_LOCAL_CRC32_OFFS); - dosDate = zip_read_short(lq + ZIP_LOCAL_MDATE_OFFS); - dosTime = zip_read_short(lq + ZIP_LOCAL_MTIME_OFFS); - z->timestamp = DosTimeDate(dosDate, dosTime); - z->nbyte = zip_read_int(lq + ZIP_LOCAL_UNCOMPLEN_OFFS); - z->cmeth = zip_read_short(lq + ZIP_LOCAL_COMPMETH_OFFS); - } - z->nbytecompr = nbcompr; - z->data = NULL; - hPtr = Tcl_CreateHashEntry(&ZipFS.fileHash, fullpath, &isNew); - if (!isNew) { - /* should not happen but skip it anyway */ - Tcl_Free((char *) z); - } else { - Tcl_SetHashValue(hPtr, (ClientData) z); - z->name = Tcl_GetHashKey(&ZipFS.fileHash, hPtr); - z->next = zf->entries; - zf->entries = z; - if (isdir && (mntpt[0] == '\0') && (z->depth == 1)) { - z->tnext = zf->topents; - zf->topents = z; - } - if (!z->isdir && (z->depth > 1)) { - char *dir, *end; - ZipEntry *zd; - - Tcl_DStringSetLength(&ds, strlen(z->name) + 8); - Tcl_DStringSetLength(&ds, 0); - Tcl_DStringAppend(&ds, z->name, -1); - dir = Tcl_DStringValue(&ds); - end = strrchr(dir, '/'); - while ((end != NULL) && (end != dir)) { - Tcl_DStringSetLength(&ds, end - dir); - hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, dir); - if (hPtr != NULL) { - break; - } - zd = (ZipEntry *) Tcl_Alloc(sizeof (*zd)); - zd->name = NULL; - zd->tnext = NULL; - zd->depth = CountSlashes(dir); - zd->zipfile = zf; - zd->isdir = 1; - zd->isenc = 0; - zd->offset = z->offset; - zd->crc32 = 0; - zd->timestamp = z->timestamp; - zd->nbyte = zd->nbytecompr = 0; - zd->cmeth = ZIP_COMPMETH_STORED; - zd->data = NULL; - hPtr = Tcl_CreateHashEntry(&ZipFS.fileHash, dir, &isNew); - if (!isNew) { - /* should not happen but skip it anyway */ - Tcl_Free((char *) zd); - } else { - Tcl_SetHashValue(hPtr, (ClientData) zd); - zd->name = Tcl_GetHashKey(&ZipFS.fileHash, hPtr); - zd->next = zf->entries; - zf->entries = zd; - if ((mntpt[0] == '\0') && (zd->depth == 1)) { - zd->tnext = zf->topents; - zf->topents = zd; - } - } - end = strrchr(dir, '/'); - } - } - } -nextent: - q += pathlen + comlen + extra + ZIP_CENTRAL_HEADER_LEN; - } - Unlock(); - Tcl_DStringFree(&fpBuf); - Tcl_DStringFree(&ds); - Tcl_DStringFree(&dsm); - Tcl_FSMountsChanged(NULL); - return TCL_OK; -} - -/* - *------------------------------------------------------------------------- - * - * Tclzipfs_Unmount -- - * - * This procedure is invoked to unmount a given ZIP archive. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * A mounted ZIP archive file is unmounted, resources are free'd. - * - *------------------------------------------------------------------------- - */ - -int -Tclzipfs_Unmount(Tcl_Interp *interp, const char *zipname) -{ - char *realname; - ZipFile *zf; - ZipEntry *z, *znext; - Tcl_HashEntry *hPtr; - Tcl_DString ds; - int ret = TCL_OK, unmounted = 0; -#if HAS_DRIVES - int drive = 0; -#endif - - Tcl_DStringInit(&ds); -#if HAS_DRIVES - realname = AbsolutePath(zipname, &drive, &ds); -#else - realname = AbsolutePath(zipname, &ds); -#endif - WriteLock(); - if (!ZipFS.initialized) { - goto done; - } - hPtr = Tcl_FindHashEntry(&ZipFS.zipHash, realname); - if (hPtr == NULL) { - /* don't report error */ - goto done; - } - zf = (ZipFile *) Tcl_GetHashValue(hPtr); -#if HAS_DRIVES - if (drive != zf->mntdrv) { - /* don't report error */ - goto done; - } -#endif - if (zf->nopen > 0) { - if (interp != NULL) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("filesystem is busy", -1)); - } - ret = TCL_ERROR; - goto done; - } - Tcl_DeleteHashEntry(hPtr); - for (z = zf->entries; z; z = znext) { - znext = z->next; - hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, z->name); - if (hPtr) { - Tcl_DeleteHashEntry(hPtr); - } - if (z->data != NULL) { - Tcl_Free((char *) z->data); - } - Tcl_Free((char *) z); - } - ZipFSCloseArchive(interp, zf); - Tcl_Free((char *) zf); - unmounted = 1; -done: - Unlock(); - Tcl_DStringFree(&ds); - if (unmounted) { - Tcl_FSMountsChanged(NULL); - } - return ret; -} - -/* - *------------------------------------------------------------------------- - * - * ZipFSMountObjCmd -- - * - * This procedure is invoked to process the "zipfs::mount" command. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * A ZIP archive file is mounted, resources are allocated. - * - *------------------------------------------------------------------------- - */ - -static int -ZipFSMountObjCmd(ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]) -{ - if (objc > 4) { - Tcl_WrongNumArgs(interp, 1, objv, - "?zipfile? ?mountpoint? ?password?"); - return TCL_ERROR; - } - return Tclzipfs_Mount(interp, (objc > 1) ? Tcl_GetString(objv[1]) : NULL, - (objc > 2) ? Tcl_GetString(objv[2]) : NULL, - (objc > 3) ? Tcl_GetString(objv[3]) : NULL); -} - -/* - *------------------------------------------------------------------------- - * - * ZipFSUnmountObjCmd -- - * - * This procedure is invoked to process the "zipfs::unmount" command. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * A mounted ZIP archive file is unmounted, resources are free'd. - * - *------------------------------------------------------------------------- - */ - -static int -ZipFSUnmountObjCmd(ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]) -{ - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "zipfile"); - return TCL_ERROR; - } - return Tclzipfs_Unmount(interp, Tcl_GetString(objv[1])); -} - -/* - *------------------------------------------------------------------------- - * - * ZipFSMkKeyObjCmd -- - * - * This procedure is invoked to process the "zipfs::mkkey" command. - * It produces a rotated password to be embedded into an image file. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *------------------------------------------------------------------------- - */ - -static int -ZipFSMkKeyObjCmd(ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]) -{ - int len, i = 0; - char *pw, pwbuf[264]; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "password"); - return TCL_ERROR; - } - pw = Tcl_GetString(objv[1]); - len = strlen(pw); - if (len == 0) { - return TCL_OK; - } - if ((len > 255) || (strchr(pw, 0xff) != NULL)) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("illegal password", -1)); - return TCL_ERROR; - } - while (len > 0) { - int ch = pw[len - 1]; - - pwbuf[i] = (ch & 0x0f) | pwrot[(ch >> 4) & 0x0f]; - i++; - len--; - } - pwbuf[i] = i; - ++i; - pwbuf[i++] = (char) ZIP_PASSWORD_END_SIG; - pwbuf[i++] = (char) (ZIP_PASSWORD_END_SIG >> 8); - pwbuf[i++] = (char) (ZIP_PASSWORD_END_SIG >> 16); - pwbuf[i++] = (char) (ZIP_PASSWORD_END_SIG >> 24); - pwbuf[i] = '\0'; - Tcl_AppendResult(interp, pwbuf, (char *) NULL); - return TCL_OK; -} - -/* - *------------------------------------------------------------------------- - * - * ZipAddFile -- - * - * This procedure is used by ZipFSMkZipOrImgCmd() to add a single - * file to the output ZIP archive file being written. A ZipEntry - * struct about the input file is added to the given fileHash table - * for later creation of the central ZIP directory. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * Input file is read and (compressed and) written to the output - * ZIP archive file. - * - *------------------------------------------------------------------------- - */ - -static int -ZipAddFile(Tcl_Interp *interp, const char *path, const char *name, - Tcl_Channel out, const char *passwd, - char *buf, int bufsize, Tcl_HashTable *fileHash) -{ - Tcl_Channel in; - Tcl_HashEntry *hPtr; - ZipEntry *z; - z_stream stream; - const char *zpath; - int nbyte, nbytecompr, len, crc, flush, pos[3], zpathlen, olen; - int mtime = 0, isNew, align = 0, cmeth; - unsigned long keys[3], keys0[3]; - char obuf[4096]; - - zpath = name; - while (zpath != NULL && zpath[0] == '/') { - zpath++; - } - if ((zpath == NULL) || (zpath[0] == '\0')) { - return TCL_OK; - } - zpathlen = strlen(zpath); - if (zpathlen + ZIP_CENTRAL_HEADER_LEN > bufsize) { - Tcl_AppendResult(interp, "path too long for \"", path, "\"", - (char *) NULL); - return TCL_ERROR; - } - in = Tcl_OpenFileChannel(interp, path, "r", 0); - if ((in == NULL) || - (Tcl_SetChannelOption(interp, in, "-translation", "binary") - != TCL_OK) || - (Tcl_SetChannelOption(interp, in, "-encoding", "binary") - != TCL_OK)) { -#if defined(_WIN32) || defined(_WIN64) - /* hopefully a directory */ - if (strcmp("permission denied", Tcl_PosixError(interp)) == 0) { - Tcl_Close(interp, in); - return TCL_OK; - } -#endif - Tcl_Close(interp, in); - return TCL_ERROR; - } else { - Tcl_Obj *pathObj = Tcl_NewStringObj(path, -1); - Tcl_StatBuf statBuf; - - Tcl_IncrRefCount(pathObj); - if (Tcl_FSStat(pathObj, &statBuf) != -1) { - mtime = statBuf.st_mtime; - } - Tcl_DecrRefCount(pathObj); - } - Tcl_ResetResult(interp); - crc = 0; - nbyte = nbytecompr = 0; - while ((len = Tcl_Read(in, buf, bufsize)) > 0) { - crc = crc32(crc, (unsigned char *) buf, len); - nbyte += len; - } - if (len == -1) { - if (nbyte == 0) { - if (strcmp("illegal operation on a directory", - Tcl_PosixError(interp)) == 0) { - Tcl_Close(interp, in); - return TCL_OK; - } - } - Tcl_AppendResult(interp, "read error on \"", path, "\"", - (char *) NULL); - Tcl_Close(interp, in); - return TCL_ERROR; - } - if (Tcl_Seek(in, 0, SEEK_SET) == -1) { - Tcl_AppendResult(interp, "seek error on \"", path, "\"", - (char *) NULL); - Tcl_Close(interp, in); - return TCL_ERROR; - } - pos[0] = Tcl_Tell(out); - memset(buf, '\0', ZIP_LOCAL_HEADER_LEN); - memcpy(buf + ZIP_LOCAL_HEADER_LEN, zpath, zpathlen); - len = zpathlen + ZIP_LOCAL_HEADER_LEN; - if (Tcl_Write(out, buf, len) != len) { -wrerr: - Tcl_AppendResult(interp, "write error", (char *) NULL); - Tcl_Close(interp, in); - return TCL_ERROR; - } - if ((len + pos[0]) & 3) { - char abuf[8]; - - /* - * Align payload to next 4-byte boundary using a dummy extra - * entry similar to the zipalign tool from Android's SDK. - */ - align = 4 + ((len + pos[0]) & 3); - zip_write_short(abuf, 0xffff); - zip_write_short(abuf + 2, align - 4); - zip_write_int(abuf + 4, 0x03020100); - if (Tcl_Write(out, abuf, align) != align) { - goto wrerr; - } - } - if (passwd != NULL) { - int i, ch, tmp; - unsigned char kvbuf[24]; - Tcl_Obj *ret; - - init_keys(passwd, keys, crc32tab); - for (i = 0; i < 12 - 2; i++) { - if (Tcl_EvalEx(interp, "expr int(rand() * 256) % 256", -1, 0) != TCL_OK) { - Tcl_AppendResult(interp, "PRNG error", (char *) NULL); - Tcl_Close(interp, in); - return TCL_ERROR; - } - ret = Tcl_GetObjResult(interp); - if (Tcl_GetIntFromObj(interp, ret, &ch) != TCL_OK) { - Tcl_Close(interp, in); - return TCL_ERROR; - } - kvbuf[i + 12] = (unsigned char) zencode(keys, crc32tab, ch, tmp); - } - Tcl_ResetResult(interp); - init_keys(passwd, keys, crc32tab); - for (i = 0; i < 12 - 2; i++) { - kvbuf[i] = (unsigned char) zencode(keys, crc32tab, - kvbuf[i + 12], tmp); - } - kvbuf[i++] = (unsigned char) zencode(keys, crc32tab, crc >> 16, tmp); - kvbuf[i++] = (unsigned char) zencode(keys, crc32tab, crc >> 24, tmp); - len = Tcl_Write(out, (char *) kvbuf, 12); - memset(kvbuf, 0, 24); - if (len != 12) { - Tcl_AppendResult(interp, "write error", (char *) NULL); - Tcl_Close(interp, in); - return TCL_ERROR; - } - memcpy(keys0, keys, sizeof (keys0)); - nbytecompr += 12; - } - Tcl_Flush(out); - pos[2] = Tcl_Tell(out); - cmeth = ZIP_COMPMETH_DEFLATED; - memset(&stream, 0, sizeof (stream)); - stream.zalloc = Z_NULL; - stream.zfree = Z_NULL; - stream.opaque = Z_NULL; - if (deflateInit2(&stream, 9, Z_DEFLATED, -15, 8, Z_DEFAULT_STRATEGY) - != Z_OK) { - Tcl_AppendResult(interp, "compression init error on \"", path, "\"", - (char *) NULL); - Tcl_Close(interp, in); - return TCL_ERROR; - } - do { - len = Tcl_Read(in, buf, bufsize); - if (len == -1) { - Tcl_AppendResult(interp, "read error on \"", path, "\"", - (char *) NULL); - deflateEnd(&stream); - Tcl_Close(interp, in); - return TCL_ERROR; - } - stream.avail_in = len; - stream.next_in = (unsigned char *) buf; - flush = Tcl_Eof(in) ? Z_FINISH : Z_NO_FLUSH; - do { - stream.avail_out = sizeof (obuf); - stream.next_out = (unsigned char *) obuf; - len = deflate(&stream, flush); - if (len == Z_STREAM_ERROR) { - Tcl_AppendResult(interp, "deflate error on \"", path, "\"", - (char *) NULL); - deflateEnd(&stream); - Tcl_Close(interp, in); - return TCL_ERROR; - } - olen = sizeof (obuf) - stream.avail_out; - if (passwd != NULL) { - int i, tmp; - - for (i = 0; i < olen; i++) { - obuf[i] = (char) zencode(keys, crc32tab, obuf[i], tmp); - } - } - if (olen && (Tcl_Write(out, obuf, olen) != olen)) { - Tcl_AppendResult(interp, "write error", (char *) NULL); - deflateEnd(&stream); - Tcl_Close(interp, in); - return TCL_ERROR; - } - nbytecompr += olen; - } while (stream.avail_out == 0); - } while (flush != Z_FINISH); - deflateEnd(&stream); - Tcl_Flush(out); - pos[1] = Tcl_Tell(out); - if (nbyte - nbytecompr <= 0) { - /* - * Compressed file larger than input, - * write it again uncompressed. - */ - if ((int) Tcl_Seek(in, 0, SEEK_SET) != 0) { - goto seekErr; - } - if ((int) Tcl_Seek(out, pos[2], SEEK_SET) != pos[2]) { -seekErr: - Tcl_Close(interp, in); - Tcl_AppendResult(interp, "seek error", (char *) NULL); - return TCL_ERROR; - } - nbytecompr = (passwd != NULL) ? 12 : 0; - while (1) { - len = Tcl_Read(in, buf, bufsize); - if (len == -1) { - Tcl_AppendResult(interp, "read error on \"", path, "\"", - (char *) NULL); - Tcl_Close(interp, in); - return TCL_ERROR; - } else if (len == 0) { - break; - } - if (passwd != NULL) { - int i, tmp; - - for (i = 0; i < len; i++) { - buf[i] = (char) zencode(keys0, crc32tab, buf[i], tmp); - } - } - if (Tcl_Write(out, buf, len) != len) { - Tcl_AppendResult(interp, "write error", (char *) NULL); - Tcl_Close(interp, in); - return TCL_ERROR; - } - nbytecompr += len; - } - cmeth = ZIP_COMPMETH_STORED; - Tcl_Flush(out); - pos[1] = Tcl_Tell(out); - Tcl_TruncateChannel(out, pos[1]); - } - Tcl_Close(interp, in); - - z = (ZipEntry *) Tcl_Alloc(sizeof (*z)); - z->name = NULL; - z->tnext = NULL; - z->depth = 0; - z->zipfile = NULL; - z->isdir = 0; - z->isenc = (passwd != NULL) ? 1 : 0; - z->offset = pos[0]; - z->crc32 = crc; - z->timestamp = mtime; - z->nbyte = nbyte; - z->nbytecompr = nbytecompr; - z->cmeth = cmeth; - z->data = NULL; - hPtr = Tcl_CreateHashEntry(fileHash, zpath, &isNew); - if (!isNew) { - Tcl_AppendResult(interp, "non-unique path name \"", path, "\"", - (char *) NULL); - Tcl_Free((char *) z); - return TCL_ERROR; - } else { - Tcl_SetHashValue(hPtr, (ClientData) z); - z->name = Tcl_GetHashKey(fileHash, hPtr); - z->next = NULL; - } - - /* - * Write final local header information. - */ - zip_write_int(buf + ZIP_LOCAL_SIG_OFFS, ZIP_LOCAL_HEADER_SIG); - zip_write_short(buf + ZIP_LOCAL_VERSION_OFFS, ZIP_MIN_VERSION); - zip_write_short(buf + ZIP_LOCAL_FLAGS_OFFS, z->isenc); - zip_write_short(buf + ZIP_LOCAL_COMPMETH_OFFS, z->cmeth); - zip_write_short(buf + ZIP_LOCAL_MTIME_OFFS, ToDosTime(z->timestamp)); - zip_write_short(buf + ZIP_LOCAL_MDATE_OFFS, ToDosDate(z->timestamp)); - zip_write_int(buf + ZIP_LOCAL_CRC32_OFFS, z->crc32); - zip_write_int(buf + ZIP_LOCAL_COMPLEN_OFFS, z->nbytecompr); - zip_write_int(buf + ZIP_LOCAL_UNCOMPLEN_OFFS, z->nbyte); - zip_write_short(buf + ZIP_LOCAL_PATHLEN_OFFS, zpathlen); - zip_write_short(buf + ZIP_LOCAL_EXTRALEN_OFFS, align); - if ((int) Tcl_Seek(out, pos[0], SEEK_SET) != pos[0]) { - Tcl_DeleteHashEntry(hPtr); - Tcl_Free((char *) z); - Tcl_AppendResult(interp, "seek error", (char *) NULL); - return TCL_ERROR; - } - if (Tcl_Write(out, buf, ZIP_LOCAL_HEADER_LEN) != ZIP_LOCAL_HEADER_LEN) { - Tcl_DeleteHashEntry(hPtr); - Tcl_Free((char *) z); - Tcl_AppendResult(interp, "write error", (char *) NULL); - return TCL_ERROR; - } - Tcl_Flush(out); - if ((int) Tcl_Seek(out, pos[1], SEEK_SET) != pos[1]) { - Tcl_DeleteHashEntry(hPtr); - Tcl_Free((char *) z); - Tcl_AppendResult(interp, "seek error", (char *) NULL); - return TCL_ERROR; - } - return TCL_OK; -} - -/* - *------------------------------------------------------------------------- - * - * ZipFSMkZipOrImgObjCmd -- - * - * This procedure is creates a new ZIP archive file or image file - * given output filename, input directory of files to be archived, - * optional password, and optional image to be prepended to the - * output ZIP archive file. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * A new ZIP archive file or image file is written. - * - *------------------------------------------------------------------------- - */ - -static int -ZipFSMkZipOrImgObjCmd(ClientData clientData, Tcl_Interp *interp, - int isImg, int isList, int objc, Tcl_Obj *const objv[]) -{ - Tcl_Channel out; - int len = 0, pwlen = 0, slen = 0, i, count, ret = TCL_ERROR, lobjc, pos[3]; - Tcl_Obj **lobjv, *list = NULL; - ZipEntry *z; - Tcl_HashEntry *hPtr; - Tcl_HashSearch search; - Tcl_HashTable fileHash; - char *strip = NULL, *pw = NULL, pwbuf[264], buf[4096]; - - if (isList) { - if ((objc < 3) || (objc > (isImg ? 5 : 4))) { - Tcl_WrongNumArgs(interp, 1, objv, isImg ? - "outfile inlist ?password infile?" : - "outfile inlist ?password?"); - return TCL_ERROR; - } - } else { - if ((objc < 3) || (objc > (isImg ? 6 : 5))) { - Tcl_WrongNumArgs(interp, 1, objv, isImg ? - "outfile indir ?strip? ?password? ?infile?" : - "outfile indir ?strip? ?password?"); - return TCL_ERROR; - } - } - pwbuf[0] = 0; - if (objc > (isList ? 3 : 4)) { - pw = Tcl_GetString(objv[isList ? 3 : 4]); - pwlen = strlen(pw); - if ((pwlen > 255) || (strchr(pw, 0xff) != NULL)) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("illegal password", -1)); - return TCL_ERROR; - } - } - if (isList) { - list = objv[2]; - Tcl_IncrRefCount(list); - } else { - Tcl_Obj *cmd[3]; - - cmd[1] = Tcl_NewStringObj("::zipfs::find", -1); - cmd[2] = objv[2]; - cmd[0] = Tcl_NewListObj(2, cmd + 1); - Tcl_IncrRefCount(cmd[0]); - if (Tcl_EvalObjEx(interp, cmd[0], TCL_EVAL_DIRECT) != TCL_OK) { - Tcl_DecrRefCount(cmd[0]); - return TCL_ERROR; - } - Tcl_DecrRefCount(cmd[0]); - list = Tcl_GetObjResult(interp); - Tcl_IncrRefCount(list); - } - if (Tcl_ListObjGetElements(interp, list, &lobjc, &lobjv) != TCL_OK) { - Tcl_DecrRefCount(list); - return TCL_ERROR; - } - if (isList && (lobjc % 2)) { - Tcl_DecrRefCount(list); - Tcl_SetObjResult(interp, - Tcl_NewStringObj("need even number of elements", -1)); - return TCL_ERROR; - } - if (lobjc == 0) { - Tcl_DecrRefCount(list); - Tcl_SetObjResult(interp, Tcl_NewStringObj("empty archive", -1)); - return TCL_ERROR; - } - out = Tcl_OpenFileChannel(interp, Tcl_GetString(objv[1]), "w", 0755); - if ((out == NULL) || - (Tcl_SetChannelOption(interp, out, "-translation", "binary") - != TCL_OK) || - (Tcl_SetChannelOption(interp, out, "-encoding", "binary") - != TCL_OK)) { - Tcl_DecrRefCount(list); - Tcl_Close(interp, out); - return TCL_ERROR; - } - if (isImg) { - ZipFile zf0; - const char *imgName; - - if (isList) { - imgName = (objc > 4) ? Tcl_GetString(objv[4]) : - Tcl_GetNameOfExecutable(); - } else { - imgName = (objc > 5) ? Tcl_GetString(objv[5]) : - Tcl_GetNameOfExecutable(); - } - if (ZipFSOpenArchive(interp, imgName, 0, &zf0) != TCL_OK) { - Tcl_DecrRefCount(list); - Tcl_Close(interp, out); - return TCL_ERROR; - } - if ((pw != NULL) && pwlen) { - i = 0; - len = pwlen; - while (len > 0) { - int ch = pw[len - 1]; - - pwbuf[i] = (ch & 0x0f) | pwrot[(ch >> 4) & 0x0f]; - i++; - len--; - } - pwbuf[i] = i; - ++i; - pwbuf[i++] = (char) ZIP_PASSWORD_END_SIG; - pwbuf[i++] = (char) (ZIP_PASSWORD_END_SIG >> 8); - pwbuf[i++] = (char) (ZIP_PASSWORD_END_SIG >> 16); - pwbuf[i++] = (char) (ZIP_PASSWORD_END_SIG >> 24); - pwbuf[i] = '\0'; - } - i = Tcl_Write(out, (char *) zf0.data, zf0.baseoffsp); - if (i != zf0.baseoffsp) { - Tcl_DecrRefCount(list); - Tcl_SetObjResult(interp, Tcl_NewStringObj("write error", -1)); - Tcl_Close(interp, out); - ZipFSCloseArchive(interp, &zf0); - return TCL_ERROR; - } - ZipFSCloseArchive(interp, &zf0); - len = strlen(pwbuf); - if (len > 0) { - i = Tcl_Write(out, pwbuf, len); - if (i != len) { - Tcl_DecrRefCount(list); - Tcl_SetObjResult(interp, Tcl_NewStringObj("write error", -1)); - Tcl_Close(interp, out); - return TCL_ERROR; - } - } - memset(pwbuf, 0, sizeof (pwbuf)); - Tcl_Flush(out); - } - Tcl_InitHashTable(&fileHash, TCL_STRING_KEYS); - pos[0] = Tcl_Tell(out); - if (!isList && (objc > 3)) { - strip = Tcl_GetString(objv[3]); - slen = strlen(strip); - } - for (i = 0; i < lobjc; i += (isList ? 2 : 1)) { - const char *path, *name; - - path = Tcl_GetString(lobjv[i]); - if (isList) { - name = Tcl_GetString(lobjv[i + 1]); - } else { - name = path; - if (slen > 0) { - len = strlen(name); - if ((len <= slen) || (strncmp(strip, name, slen) != 0)) { - continue; - } - name += slen; - } - } - while (name[0] == '/') { - ++name; - } - if (name[0] == '\0') { - continue; - } - if (ZipAddFile(interp, path, name, out, pw, buf, sizeof (buf), - &fileHash) != TCL_OK) { - goto done; - } - } - pos[1] = Tcl_Tell(out); - count = 0; - for (i = 0; i < lobjc; i += (isList ? 2 : 1)) { - const char *path, *name; - - path = Tcl_GetString(lobjv[i]); - if (isList) { - name = Tcl_GetString(lobjv[i + 1]); - } else { - name = path; - if (slen > 0) { - len = strlen(name); - if ((len <= slen) || (strncmp(strip, name, slen) != 0)) { - continue; - } - name += slen; - } - } - while (name[0] == '/') { - ++name; - } - if (name[0] == '\0') { - continue; - } - hPtr = Tcl_FindHashEntry(&fileHash, name); - if (hPtr == NULL) { - continue; - } - z = (ZipEntry *) Tcl_GetHashValue(hPtr); - len = strlen(z->name); - zip_write_int(buf + ZIP_CENTRAL_SIG_OFFS, ZIP_CENTRAL_HEADER_SIG); - zip_write_short(buf + ZIP_CENTRAL_VERSIONMADE_OFFS, ZIP_MIN_VERSION); - zip_write_short(buf + ZIP_CENTRAL_VERSION_OFFS, ZIP_MIN_VERSION); - zip_write_short(buf + ZIP_CENTRAL_FLAGS_OFFS, z->isenc ? 1 : 0); - zip_write_short(buf + ZIP_CENTRAL_COMPMETH_OFFS, z->cmeth); - zip_write_short(buf + ZIP_CENTRAL_MTIME_OFFS, ToDosTime(z->timestamp)); - zip_write_short(buf + ZIP_CENTRAL_MDATE_OFFS, ToDosDate(z->timestamp)); - zip_write_int(buf + ZIP_CENTRAL_CRC32_OFFS, z->crc32); - zip_write_int(buf + ZIP_CENTRAL_COMPLEN_OFFS, z->nbytecompr); - zip_write_int(buf + ZIP_CENTRAL_UNCOMPLEN_OFFS, z->nbyte); - zip_write_short(buf + ZIP_CENTRAL_PATHLEN_OFFS, len); - zip_write_short(buf + ZIP_CENTRAL_EXTRALEN_OFFS, 0); - zip_write_short(buf + ZIP_CENTRAL_FCOMMENTLEN_OFFS, 0); - zip_write_short(buf + ZIP_CENTRAL_DISKFILE_OFFS, 0); - zip_write_short(buf + ZIP_CENTRAL_IATTR_OFFS, 0); - zip_write_int(buf + ZIP_CENTRAL_EATTR_OFFS, 0); - zip_write_int(buf + ZIP_CENTRAL_LOCALHDR_OFFS, z->offset - pos[0]); - if ((Tcl_Write(out, buf, ZIP_CENTRAL_HEADER_LEN) != - ZIP_CENTRAL_HEADER_LEN) || - (Tcl_Write(out, z->name, len) != len)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj("write error", -1)); - goto done; - } - count++; - } - Tcl_Flush(out); - pos[2] = Tcl_Tell(out); - zip_write_int(buf + ZIP_CENTRAL_END_SIG_OFFS, ZIP_CENTRAL_END_SIG); - zip_write_short(buf + ZIP_CENTRAL_DISKNO_OFFS, 0); - zip_write_short(buf + ZIP_CENTRAL_DISKDIR_OFFS, 0); - zip_write_short(buf + ZIP_CENTRAL_ENTS_OFFS, count); - zip_write_short(buf + ZIP_CENTRAL_TOTALENTS_OFFS, count); - zip_write_int(buf + ZIP_CENTRAL_DIRSIZE_OFFS, pos[2] - pos[1]); - zip_write_int(buf + ZIP_CENTRAL_DIRSTART_OFFS, pos[1] - pos[0]); - zip_write_short(buf + ZIP_CENTRAL_COMMENTLEN_OFFS, 0); - if (Tcl_Write(out, buf, ZIP_CENTRAL_END_LEN) != ZIP_CENTRAL_END_LEN) { - Tcl_SetObjResult(interp, Tcl_NewStringObj("write error", -1)); - goto done; - } - Tcl_Flush(out); - ret = TCL_OK; -done: - if (ret == TCL_OK) { - ret = Tcl_Close(interp, out); - } else { - Tcl_Close(interp, out); - } - Tcl_DecrRefCount(list); - hPtr = Tcl_FirstHashEntry(&fileHash, &search); - while (hPtr != NULL) { - z = (ZipEntry *) Tcl_GetHashValue(hPtr); - Tcl_Free((char *) z); - Tcl_DeleteHashEntry(hPtr); - hPtr = Tcl_FirstHashEntry(&fileHash, &search); - } - Tcl_DeleteHashTable(&fileHash); - return ret; -} - -/* - *------------------------------------------------------------------------- - * - * ZipFSMkZipObjCmd -- - * - * This procedure is invoked to process the "zipfs::mkzip" command. - * See description of ZipFSMkZipOrImgCmd(). - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See description of ZipFSMkZipOrImgCmd(). - * - *------------------------------------------------------------------------- - */ - -static int -ZipFSMkZipObjCmd(ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]) -{ - return ZipFSMkZipOrImgObjCmd(clientData, interp, 0, 0, objc, objv); -} - -static int -ZipFSLMkZipObjCmd(ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]) -{ - return ZipFSMkZipOrImgObjCmd(clientData, interp, 0, 1, objc, objv); -} - -/* - *------------------------------------------------------------------------- - * - * ZipFSMkImgObjCmd -- - * - * This procedure is invoked to process the "zipfs::mkimg" command. - * See description of ZipFSMkZipOrImgCmd(). - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See description of ZipFSMkZipOrImgCmd(). - * - *------------------------------------------------------------------------- - */ - -static int -ZipFSMkImgObjCmd(ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]) -{ - return ZipFSMkZipOrImgObjCmd(clientData, interp, 1, 0, objc, objv); -} - -static int -ZipFSLMkImgObjCmd(ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]) -{ - return ZipFSMkZipOrImgObjCmd(clientData, interp, 1, 1, objc, objv); -} - -/* - *------------------------------------------------------------------------- - * - * ZipFSExistsObjCmd -- - * - * This procedure is invoked to process the "zipfs::exists" command. - * It tests for the existence of a file in the ZIP filesystem and - * places a boolean into the interp's result. - * - * Results: - * Always TCL_OK. - * - * Side effects: - * None. - * - *------------------------------------------------------------------------- - */ - -static int -ZipFSExistsObjCmd(ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]) -{ - char *filename; - int exists; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "filename"); - return TCL_ERROR; - } - filename = Tcl_GetStringFromObj(objv[1], 0); - ReadLock(); - exists = ZipFSLookup(filename) != NULL; - Unlock(); - Tcl_SetBooleanObj(Tcl_GetObjResult(interp), exists); - return TCL_OK; -} - -/* - *------------------------------------------------------------------------- - * - * ZipFSInfoObjCmd -- - * - * This procedure is invoked to process the "zipfs::info" command. - * On success, it returns a Tcl list made up of name of ZIP archive - * file, size uncompressed, size compressed, and archive offset of - * a file in the ZIP filesystem. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *------------------------------------------------------------------------- - */ - -static int -ZipFSInfoObjCmd(ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]) -{ - char *filename; - ZipEntry *z; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "filename"); - return TCL_ERROR; - } - filename = Tcl_GetStringFromObj(objv[1], 0); - ReadLock(); - z = ZipFSLookup(filename); - if (z != NULL) { - Tcl_Obj *result = Tcl_GetObjResult(interp); - - Tcl_ListObjAppendElement(interp, result, - Tcl_NewStringObj(z->zipfile->name, -1)); - Tcl_ListObjAppendElement(interp, result, Tcl_NewIntObj(z->nbyte)); - Tcl_ListObjAppendElement(interp, result, Tcl_NewIntObj(z->nbytecompr)); - Tcl_ListObjAppendElement(interp, result, Tcl_NewIntObj(z->offset)); - } - Unlock(); - return TCL_OK; -} - -/* - *------------------------------------------------------------------------- - * - * ZipFSListObjCmd -- - * - * This procedure is invoked to process the "zipfs::list" command. - * On success, it returns a Tcl list of files of the ZIP filesystem - * which match a search pattern (glob or regexp). - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *------------------------------------------------------------------------- - */ - -static int -ZipFSListObjCmd(ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]) -{ - char *pattern = NULL; - Tcl_RegExp regexp = NULL; - Tcl_HashEntry *hPtr; - Tcl_HashSearch search; - Tcl_Obj *result = Tcl_GetObjResult(interp); - - if (objc > 3) { - Tcl_WrongNumArgs(interp, 1, objv, "?(-glob|-regexp)? ?pattern?"); - return TCL_ERROR; - } - if (objc == 3) { - int n; - char *what = Tcl_GetStringFromObj(objv[1], &n); - - if ((n >= 2) && (strncmp(what, "-glob", n) == 0)) { - pattern = Tcl_GetString(objv[2]); - } else if ((n >= 2) && (strncmp(what, "-regexp", n) == 0)) { - regexp = Tcl_RegExpCompile(interp, Tcl_GetString(objv[2])); - if (regexp == NULL) { - return TCL_ERROR; - } - } else { - Tcl_AppendResult(interp, "unknown option \"", what, - "\"", (char *) NULL); - return TCL_ERROR; - } - } else if (objc == 2) { - pattern = Tcl_GetStringFromObj(objv[1], 0); - } - ReadLock(); - if (pattern != NULL) { - for (hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search); - hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { - ZipEntry *z = (ZipEntry *) Tcl_GetHashValue(hPtr); - - if (Tcl_StringMatch(z->name, pattern)) { - Tcl_ListObjAppendElement(interp, result, - Tcl_NewStringObj(z->name, -1)); - } - } - } else if (regexp != NULL) { - for (hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search); - hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { - ZipEntry *z = (ZipEntry *) Tcl_GetHashValue(hPtr); - - if (Tcl_RegExpExec(interp, regexp, z->name, z->name)) { - Tcl_ListObjAppendElement(interp, result, - Tcl_NewStringObj(z->name, -1)); - } - } - } else { - for (hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search); - hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { - ZipEntry *z = (ZipEntry *) Tcl_GetHashValue(hPtr); - - Tcl_ListObjAppendElement(interp, result, - Tcl_NewStringObj(z->name, -1)); - } - } - Unlock(); - return TCL_OK; -} - -/* - *------------------------------------------------------------------------- - * - * ZipChannelClose -- - * - * This function is called to close a channel. - * - * Results: - * Always TCL_OK. - * - * Side effects: - * Resources are free'd. - * - *------------------------------------------------------------------------- - */ - -static int -ZipChannelClose(ClientData instanceData, Tcl_Interp *interp) -{ - ZipChannel *info = (ZipChannel *) instanceData; - - if (info->iscompr && (info->ubuf != NULL)) { - Tcl_Free((char *) info->ubuf); - info->ubuf = NULL; - } - if (info->isenc) { - info->isenc = 0; - memset(info->keys, 0, sizeof (info->keys)); - } - if (info->iswr) { - ZipEntry *z = info->zipentry; - unsigned char *newdata; - - newdata = (unsigned char *) - Tcl_AttemptRealloc((char *) info->ubuf, info->nread); - if (newdata != NULL) { - if (z->data != NULL) { - Tcl_Free((char *) z->data); - } - z->data = newdata; - z->nbyte = z->nbytecompr = info->nbyte; - z->cmeth = ZIP_COMPMETH_STORED; - z->timestamp = time(NULL); - z->isdir = 0; - z->isenc = 0; - z->offset = 0; - z->crc32 = 0; - } else { - Tcl_Free((char *) info->ubuf); - } - } - WriteLock(); - info->zipfile->nopen--; - Unlock(); - Tcl_Free((char *) info); - return TCL_OK; -} - -/* - *------------------------------------------------------------------------- - * - * ZipChannelRead -- - * - * This function is called to read data from channel. - * - * Results: - * Number of bytes read or -1 on error with error number set. - * - * Side effects: - * Data is read and file pointer is advanced. - * - *------------------------------------------------------------------------- - */ - -static int -ZipChannelRead(ClientData instanceData, char *buf, int toRead, int *errloc) -{ - ZipChannel *info = (ZipChannel *) instanceData; - unsigned long nextpos; - - if (info->isdir) { - *errloc = EISDIR; - return -1; - } - nextpos = info->nread + toRead; - if (nextpos > info->nbyte) { - toRead = info->nbyte - info->nread; - nextpos = info->nbyte; - } - if (toRead == 0) { - return 0; - } - if (info->isenc) { - int i, ch; - - for (i = 0; i < toRead; i++) { - ch = info->ubuf[i + info->nread]; - buf[i] = zdecode(info->keys, crc32tab, ch); - } - } else { - memcpy(buf, info->ubuf + info->nread, toRead); - } - info->nread = nextpos; - *errloc = 0; - return toRead; -} - -/* - *------------------------------------------------------------------------- - * - * ZipChannelWrite -- - * - * This function is called to write data into channel. - * - * Results: - * Number of bytes written or -1 on error with error number set. - * - * Side effects: - * Data is written and file pointer is advanced. - * - *------------------------------------------------------------------------- - */ - -static int -ZipChannelWrite(ClientData instanceData, const char *buf, - int toWrite, int *errloc) -{ - ZipChannel *info = (ZipChannel *) instanceData; - unsigned long nextpos; - - if (!info->iswr) { - *errloc = EINVAL; - return -1; - } - nextpos = info->nread + toWrite; - if (nextpos > info->nmax) { - toWrite = info->nmax - info->nread; - nextpos = info->nmax; - } - if (toWrite == 0) { - return 0; - } - memcpy(info->ubuf + info->nread, buf, toWrite); - info->nread = nextpos; - if (info->nread > info->nbyte) { - info->nbyte = info->nread; - } - *errloc = 0; - return toWrite; -} - -/* - *------------------------------------------------------------------------- - * - * ZipChannelSeek -- - * - * This function is called to position file pointer of channel. - * - * Results: - * New file position or -1 on error with error number set. - * - * Side effects: - * File pointer is repositioned according to offset and mode. - * - *------------------------------------------------------------------------- - */ - -static int -ZipChannelSeek(ClientData instanceData, long offset, int mode, int *errloc) -{ - ZipChannel *info = (ZipChannel *) instanceData; - - if (info->isdir) { - *errloc = EINVAL; - return -1; - } - switch (mode) { - case SEEK_CUR: - offset += info->nread; - break; - case SEEK_END: - offset += info->nbyte; - break; - case SEEK_SET: - break; - default: - *errloc = EINVAL; - return -1; - } - if (offset < 0) { - *errloc = EINVAL; - return -1; - } - if (info->iswr) { - if ((unsigned long) offset > info->nmax) { - *errloc = EINVAL; - return -1; - } - if ((unsigned long) offset > info->nbyte) { - info->nbyte = offset; - } - } else if ((unsigned long) offset > info->nbyte) { - *errloc = EINVAL; - return -1; - } - info->nread = (unsigned long) offset; - return info->nread; -} - -/* - *------------------------------------------------------------------------- - * - * ZipChannelWatchChannel -- - * - * This function is called for event notifications on channel. - * - * Results: - * None. - * - * Side effects: - * None. - * - *------------------------------------------------------------------------- - */ - -static void -ZipChannelWatchChannel(ClientData instanceData, int mask) -{ - return; -} - -/* - *------------------------------------------------------------------------- - * - * ZipChannelGetFile -- - * - * This function is called to retrieve OS handle for channel. - * - * Results: - * Always TCL_ERROR since there's never an OS handle for a - * file within a ZIP archive. - * - * Side effects: - * None. - * - *------------------------------------------------------------------------- - */ - -static int -ZipChannelGetFile(ClientData instanceData, int direction, - ClientData *handlePtr) -{ - return TCL_ERROR; -} - -/* - * The channel type/driver definition used for ZIP archive members. - */ - -static Tcl_ChannelType ZipChannelType = { - "zip", /* Type name. */ -#ifdef TCL_CHANNEL_VERSION_4 - TCL_CHANNEL_VERSION_4, - ZipChannelClose, /* Close channel, clean instance data */ - ZipChannelRead, /* Handle read request */ - ZipChannelWrite, /* Handle write request */ - ZipChannelSeek, /* Move location of access point, NULL'able */ - NULL, /* Set options, NULL'able */ - NULL, /* Get options, NULL'able */ - ZipChannelWatchChannel, /* Initialize notifier */ - ZipChannelGetFile, /* Get OS handle from the channel */ - NULL, /* 2nd version of close channel, NULL'able */ - NULL, /* Set blocking mode for raw channel, NULL'able */ - NULL, /* Function to flush channel, NULL'able */ - NULL, /* Function to handle event, NULL'able */ - NULL, /* Wide seek function, NULL'able */ - NULL, /* Thread action function, NULL'able */ -#else - NULL, /* Set blocking/nonblocking behaviour, NULL'able */ - ZipChannelClose, /* Close channel, clean instance data */ - ZipChannelRead, /* Handle read request */ - ZipChannelWrite, /* Handle write request */ - ZipChannelSeek, /* Move location of access point, NULL'able */ - NULL, /* Set options, NULL'able */ - NULL, /* Get options, NULL'able */ - ZipChannelWatchChannel, /* Initialize notifier */ - ZipChannelGetFile, /* Get OS handle from the channel */ -#endif -}; - -/* - *------------------------------------------------------------------------- - * - * ZipChannelOpen -- - * - * This function opens a Tcl_Channel on a file from a mounted ZIP - * archive according to given open mode. - * - * Results: - * Tcl_Channel on success, or NULL on error. - * - * Side effects: - * Memory is allocated, the file from the ZIP archive is uncompressed. - * - *------------------------------------------------------------------------- - */ - -static Tcl_Channel -ZipChannelOpen(Tcl_Interp *interp, char *filename, int mode, int permissions) -{ - ZipEntry *z; - ZipChannel *info; - int i, ch, trunc, wr, flags = 0; - char cname[128]; - - if ((mode & O_APPEND) || - ((ZipFS.wrmax <= 0) && (mode & (O_WRONLY | O_RDWR)))) { - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj("unsupported open mode", -1)); - } - return NULL; - } - WriteLock(); - z = ZipFSLookup(filename); - if (z == NULL) { - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj("file not found", -1)); - } - goto error; - } - trunc = (mode & O_TRUNC) != 0; - wr = (mode & (O_WRONLY | O_RDWR)) != 0; - if ((z->cmeth != ZIP_COMPMETH_STORED) && - (z->cmeth != ZIP_COMPMETH_DEFLATED)) { - if (interp != NULL) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("unsupported compression method", -1)); - } - goto error; - } - if (wr && z->isdir) { - if (interp != NULL) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("unsupported file type", -1)); - } - goto error; - } - if (!trunc) { - flags |= TCL_READABLE; - if (z->isenc && (z->zipfile->pwbuf[0] == 0)) { - if (interp != NULL) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("decryption failed", -1)); - } - goto error; - } else if (wr && (z->data == NULL) && (z->nbyte > ZipFS.wrmax)) { - if (interp != NULL) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("file too large", -1)); - } - goto error; - } - } else { - flags = TCL_WRITABLE; - } - info = (ZipChannel *) Tcl_AttemptAlloc(sizeof (*info)); - if (info == NULL) { - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj("out of memory", -1)); - } - goto error; - } - info->zipfile = z->zipfile; - info->zipentry = z; - info->nread = 0; - if (wr) { - flags |= TCL_WRITABLE; - info->iswr = 1; - info->isdir = 0; - info->nmax = ZipFS.wrmax; - info->iscompr = 0; - info->isenc = 0; - info->ubuf = (unsigned char *) Tcl_AttemptAlloc(info->nmax); - if (info->ubuf == NULL) { -merror0: - if (info->ubuf != NULL) { - Tcl_Free((char *) info->ubuf); - } - Tcl_Free((char *) info); - if (interp != NULL) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("out of memory", -1)); - } - goto error; - } - memset(info->ubuf, 0, info->nmax); - if (trunc) { - info->nbyte = 0; - } else { - if (z->data != NULL) { - unsigned int j = z->nbyte; - - if (j > info->nmax) { - j = info->nmax; - } - memcpy(info->ubuf, z->data, j); - info->nbyte = j; - } else { - unsigned char *zbuf = z->zipfile->data + z->offset; - - if (z->isenc) { - int len = z->zipfile->pwbuf[0]; - char pwbuf[260]; - - for (i = 0; i < len; i++) { - ch = z->zipfile->pwbuf[len - i]; - pwbuf[i] = (ch & 0x0f) | pwrot[(ch >> 4) & 0x0f]; - } - pwbuf[i] = '\0'; - init_keys(pwbuf, info->keys, crc32tab); - memset(pwbuf, 0, sizeof (pwbuf)); - for (i = 0; i < 12; i++) { - ch = info->ubuf[i]; - zdecode(info->keys, crc32tab, ch); - } - zbuf += i; - } - if (z->cmeth == ZIP_COMPMETH_DEFLATED) { - z_stream stream; - int err; - unsigned char *cbuf = NULL; - - memset(&stream, 0, sizeof (stream)); - stream.zalloc = Z_NULL; - stream.zfree = Z_NULL; - stream.opaque = Z_NULL; - stream.avail_in = z->nbytecompr; - if (z->isenc) { - unsigned int j; - - stream.avail_in -= 12; - cbuf = (unsigned char *) - Tcl_AttemptAlloc(stream.avail_in); - if (cbuf == NULL) { - goto merror0; - } - for (j = 0; j < stream.avail_in; j++) { - ch = info->ubuf[j]; - cbuf[j] = zdecode(info->keys, crc32tab, ch); - } - stream.next_in = cbuf; - } else { - stream.next_in = zbuf; - } - stream.next_out = info->ubuf; - stream.avail_out = info->nmax; - if (inflateInit2(&stream, -15) != Z_OK) { - goto cerror0; - } - err = inflate(&stream, Z_SYNC_FLUSH); - inflateEnd(&stream); - if ((err == Z_STREAM_END) || - ((err == Z_OK) && (stream.avail_in == 0))) { - if (cbuf != NULL) { - memset(info->keys, 0, sizeof (info->keys)); - Tcl_Free((char *) cbuf); - } - goto wrapchan; - } -cerror0: - if (cbuf != NULL) { - memset(info->keys, 0, sizeof (info->keys)); - Tcl_Free((char *) cbuf); - } - if (info->ubuf != NULL) { - Tcl_Free((char *) info->ubuf); - } - Tcl_Free((char *) info); - if (interp != NULL) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("decompression error", -1)); - } - goto error; - } else if (z->isenc) { - for (i = 0; i < z->nbyte - 12; i++) { - ch = zbuf[i]; - info->ubuf[i] = zdecode(info->keys, crc32tab, ch); - } - } else { - memcpy(info->ubuf, zbuf, z->nbyte); - } - memset(info->keys, 0, sizeof (info->keys)); - goto wrapchan; - } - } - } else if (z->data != NULL) { - flags |= TCL_READABLE; - info->iswr = 0; - info->iscompr = 0; - info->isdir = 0; - info->isenc = 0; - info->nbyte = z->nbyte; - info->nmax = 0; - info->ubuf = z->data; - } else { - flags |= TCL_READABLE; - info->iswr = 0; - info->iscompr = z->cmeth == ZIP_COMPMETH_DEFLATED; - info->ubuf = z->zipfile->data + z->offset; - info->isdir = z->isdir; - info->isenc = z->isenc; - info->nbyte = z->nbyte; - info->nmax = 0; - if (info->isenc) { - int len = z->zipfile->pwbuf[0]; - char pwbuf[260]; - - for (i = 0; i < len; i++) { - ch = z->zipfile->pwbuf[len - i]; - pwbuf[i] = (ch & 0x0f) | pwrot[(ch >> 4) & 0x0f]; - } - pwbuf[i] = '\0'; - init_keys(pwbuf, info->keys, crc32tab); - memset(pwbuf, 0, sizeof (pwbuf)); - for (i = 0; i < 12; i++) { - ch = info->ubuf[i]; - zdecode(info->keys, crc32tab, ch); - } - info->ubuf += i; - } - if (info->iscompr) { - z_stream stream; - int err; - unsigned char *ubuf = NULL; - unsigned int j; - - memset(&stream, 0, sizeof (stream)); - stream.zalloc = Z_NULL; - stream.zfree = Z_NULL; - stream.opaque = Z_NULL; - stream.avail_in = z->nbytecompr; - if (info->isenc) { - stream.avail_in -= 12; - ubuf = (unsigned char *) Tcl_AttemptAlloc(stream.avail_in); - if (ubuf == NULL) { - info->ubuf = NULL; - goto merror; - } - for (j = 0; j < stream.avail_in; j++) { - ch = info->ubuf[j]; - ubuf[j] = zdecode(info->keys, crc32tab, ch); - } - stream.next_in = ubuf; - } else { - stream.next_in = info->ubuf; - } - stream.next_out = info->ubuf = - (unsigned char *) Tcl_AttemptAlloc(info->nbyte); - if (info->ubuf == NULL) { -merror: - if (ubuf != NULL) { - info->isenc = 0; - memset(info->keys, 0, sizeof (info->keys)); - Tcl_Free((char *) ubuf); - } - Tcl_Free((char *) info); - if (interp != NULL) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("out of memory", -1)); - } - goto error; - } - stream.avail_out = info->nbyte; - if (inflateInit2(&stream, -15) != Z_OK) { - goto cerror; - } - err = inflate(&stream, Z_SYNC_FLUSH); - inflateEnd(&stream); - if ((err == Z_STREAM_END) || - ((err == Z_OK) && (stream.avail_in == 0))) { - if (ubuf != NULL) { - info->isenc = 0; - memset(info->keys, 0, sizeof (info->keys)); - Tcl_Free((char *) ubuf); - } - goto wrapchan; - } -cerror: - if (ubuf != NULL) { - info->isenc = 0; - memset(info->keys, 0, sizeof (info->keys)); - Tcl_Free((char *) ubuf); - } - if (info->ubuf != NULL) { - Tcl_Free((char *) info->ubuf); - } - Tcl_Free((char *) info); - if (interp != NULL) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("decompression error", -1)); - } - goto error; - } - } -wrapchan: - sprintf(cname, "zipfs_%lx_%d", (unsigned long) z->offset, ZipFS.idCount++); - z->zipfile->nopen++; - Unlock(); - return Tcl_CreateChannel(&ZipChannelType, cname, (ClientData) info, flags); - -error: - Unlock(); - return NULL; -} - -/* - *------------------------------------------------------------------------- - * - * ZipEntryStat -- - * - * This function implements the ZIP filesystem specific version - * of the library version of stat. - * - * Results: - * See stat documentation. - * - * Side effects: - * See stat documentation. - * - *------------------------------------------------------------------------- - */ - -static int -ZipEntryStat(char *path, Tcl_StatBuf *buf) -{ - ZipEntry *z; - int ret = -1; - - ReadLock(); - z = ZipFSLookup(path); - if (z == NULL) { - goto done; - } - memset(buf, 0, sizeof (Tcl_StatBuf)); - if (z->isdir) { - buf->st_mode = S_IFDIR | 0555; - } else { - buf->st_mode = S_IFREG | 0555; - } - buf->st_size = z->nbyte; - buf->st_mtime = z->timestamp; - buf->st_ctime = z->timestamp; - buf->st_atime = z->timestamp; - ret = 0; -done: - Unlock(); - return ret; -} - -/* - *------------------------------------------------------------------------- - * - * ZipEntryAccess -- - * - * This function implements the ZIP filesystem specific version - * of the library version of access. - * - * Results: - * See access documentation. - * - * Side effects: - * See access documentation. - * - *------------------------------------------------------------------------- - */ - -static int -ZipEntryAccess(char *path, int mode) -{ - ZipEntry *z; - - if (mode & 3) { - return -1; - } - ReadLock(); - z = ZipFSLookup(path); - Unlock(); - return (z != NULL) ? 0 : -1; -} - -/* - *------------------------------------------------------------------------- - * - * Zip_FSOpenFileChannelProc -- - * - * Results: - * - * Side effects: - * - *------------------------------------------------------------------------- - */ - -static Tcl_Channel -Zip_FSOpenFileChannelProc(Tcl_Interp *interp, Tcl_Obj *pathPtr, - int mode, int permissions) -{ - int len; - - return ZipChannelOpen(interp, Tcl_GetStringFromObj(pathPtr, &len), - mode, permissions); -} - -/* - *------------------------------------------------------------------------- - * - * Zip_FSStatProc -- - * - * This function implements the ZIP filesystem specific version - * of the library version of stat. - * - * Results: - * See stat documentation. - * - * Side effects: - * See stat documentation. - * - *------------------------------------------------------------------------- - */ - -static int -Zip_FSStatProc(Tcl_Obj *pathPtr, Tcl_StatBuf *buf) -{ - int len; - - return ZipEntryStat(Tcl_GetStringFromObj(pathPtr, &len), buf); -} - -/* - *------------------------------------------------------------------------- - * - * Zip_FSAccessProc -- - * - * This function implements the ZIP filesystem specific version - * of the library version of access. - * - * Results: - * See access documentation. - * - * Side effects: - * See access documentation. - * - *------------------------------------------------------------------------- - */ - -static int -Zip_FSAccessProc(Tcl_Obj *pathPtr, int mode) -{ - int len; - - return ZipEntryAccess(Tcl_GetStringFromObj(pathPtr, &len), mode); -} - -/* - *------------------------------------------------------------------------- - * - * Zip_FSFilesystemSeparatorProc -- - * - * This function returns the separator to be used for a given path. The - * object returned should have a refCount of zero - * - * Results: - * A Tcl object, with a refCount of zero. If the caller needs to retain a - * reference to the object, it should call Tcl_IncrRefCount, and should - * otherwise free the object. - * - * Side effects: - * None. - * - *------------------------------------------------------------------------- - */ - -static Tcl_Obj * -Zip_FSFilesystemSeparatorProc(Tcl_Obj *pathPtr) -{ - return Tcl_NewStringObj("/", -1); -} - -/* - *------------------------------------------------------------------------- - * - * Zip_FSMatchInDirectoryProc -- - * - * This routine is used by the globbing code to search a directory for - * all files which match a given pattern. - * - * Results: - * The return value is a standard Tcl result indicating whether an - * error occurred in globbing. Errors are left in interp, good - * results are lappend'ed to resultPtr (which must be a valid object). - * - * Side effects: - * None. - * - *------------------------------------------------------------------------- - */ - -static int -Zip_FSMatchInDirectoryProc(Tcl_Interp* interp, Tcl_Obj *result, - Tcl_Obj *pathPtr, const char *pattern, - Tcl_GlobTypeData *types) -{ - Tcl_HashEntry *hPtr; - Tcl_HashSearch search; - int scnt, len, l, dirOnly = -1, prefixLen, strip = 0; - char *pat, *prefix, *path; -#if HAS_DRIVES - char drivePrefix[3]; -#endif - Tcl_DString ds, dsPref; - -#if HAS_DRIVES - if ((pattern != NULL) && (pattern[0] != '\0') && - (strchr(drvletters, pattern[0]) != NULL) && (pattern[1] == ':')) { - pattern += 2; - } -#endif - if (types != NULL) { - dirOnly = (types->type & TCL_GLOB_TYPE_DIR) == TCL_GLOB_TYPE_DIR; - } - Tcl_DStringInit(&ds); - Tcl_DStringInit(&dsPref); - prefix = Tcl_GetStringFromObj(pathPtr, &prefixLen); - Tcl_DStringAppend(&dsPref, prefix, prefixLen); - prefix = Tcl_DStringValue(&dsPref); -#if HAS_DRIVES - path = AbsolutePath(prefix, NULL, &ds); -#else - path = AbsolutePath(prefix, &ds); -#endif - len = Tcl_DStringLength(&ds); - if (strcmp(prefix, path) == 0) { - prefix = NULL; - } else { -#if HAS_DRIVES - if ((strchr(drvletters, prefix[0]) != NULL) && (prefix[1] == ':')) { - if (strcmp(prefix + 2, path) == 0) { - strncpy(drivePrefix, prefix, 3); - drivePrefix[2] = '\0'; - prefix = drivePrefix; - } - } else { - strip = len + 1; - } -#else - strip = len + 1; -#endif - } - if (prefix != NULL) { -#if HAS_DRIVES - if (prefix == drivePrefix) { - Tcl_DStringSetLength(&dsPref, 0); - Tcl_DStringAppend(&dsPref, drivePrefix, -1); - prefixLen = Tcl_DStringLength(&dsPref); - } else { - Tcl_DStringAppend(&dsPref, "/", 1); - prefixLen++; - } - prefix = Tcl_DStringValue(&dsPref); -#else - Tcl_DStringAppend(&dsPref, "/", 1); - prefixLen++; - prefix = Tcl_DStringValue(&dsPref); -#endif - } - ReadLock(); - if ((types != NULL) && (types->type == TCL_GLOB_TYPE_MOUNT)) { - l = CountSlashes(path); - if (path[len - 1] == '/') { - len--; - } else { - l++; - } - if ((pattern == NULL) || (pattern[0] == '\0')) { - pattern = "*"; - } - hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); - while (hPtr != NULL) { - ZipFile *zf = (ZipFile *) Tcl_GetHashValue(hPtr); - - if (zf->mntptlen == 0) { - ZipEntry *z = zf->topents; - - while (z != NULL) { - int lenz = strlen(z->name); - - if ((lenz > len + 1) && - (strncmp(z->name, path, len) == 0) && - (z->name[len] == '/') && - (CountSlashes(z->name) == l) && - Tcl_StringCaseMatch(z->name + len + 1, pattern, 0)) { - if (prefix != NULL) { - Tcl_DStringAppend(&dsPref, z->name, lenz); - Tcl_ListObjAppendElement(NULL, result, - Tcl_NewStringObj(Tcl_DStringValue(&dsPref), - Tcl_DStringLength(&dsPref))); - Tcl_DStringSetLength(&dsPref, prefixLen); - } else { - Tcl_ListObjAppendElement(NULL, result, - Tcl_NewStringObj(z->name, lenz)); - } - } - z = z->tnext; - } - } else if ((zf->mntptlen > len + 1) && - (strncmp(zf->mntpt, path, len) == 0) && - (zf->mntpt[len] == '/') && - (CountSlashes(zf->mntpt) == l) && - Tcl_StringCaseMatch(zf->mntpt + len + 1, pattern, 0)) { - if (prefix != NULL) { - Tcl_DStringAppend(&dsPref, zf->mntpt, zf->mntptlen); - Tcl_ListObjAppendElement(NULL, result, - Tcl_NewStringObj(Tcl_DStringValue(&dsPref), - Tcl_DStringLength(&dsPref))); - Tcl_DStringSetLength(&dsPref, prefixLen); - } else { - Tcl_ListObjAppendElement(NULL, result, - Tcl_NewStringObj(zf->mntpt, zf->mntptlen)); - } - } - hPtr = Tcl_NextHashEntry(&search); - } - goto end; - } - if ((pattern == NULL) || (pattern[0] == '\0')) { - hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, path); - if (hPtr != NULL) { - ZipEntry *z = (ZipEntry *) Tcl_GetHashValue(hPtr); - - if ((dirOnly < 0) || - (!dirOnly && !z->isdir) || - (dirOnly && z->isdir)) { - if (prefix != NULL) { - Tcl_DStringAppend(&dsPref, z->name, -1); - Tcl_ListObjAppendElement(NULL, result, - Tcl_NewStringObj(Tcl_DStringValue(&dsPref), - Tcl_DStringLength(&dsPref))); - Tcl_DStringSetLength(&dsPref, prefixLen); - } else { - Tcl_ListObjAppendElement(NULL, result, - Tcl_NewStringObj(z->name, -1)); - } - } - } - goto end; - } - l = strlen(pattern); - pat = Tcl_Alloc(len + l + 2); - memcpy(pat, path, len); - while ((len > 1) && (pat[len - 1] == '/')) { - --len; - } - if ((len > 1) || (pat[0] != '/')) { - pat[len] = '/'; - ++len; - } - memcpy(pat + len, pattern, l + 1); - scnt = CountSlashes(pat); - for (hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search); - hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { - ZipEntry *z = (ZipEntry *) Tcl_GetHashValue(hPtr); - - if ((dirOnly >= 0) && - ((dirOnly && !z->isdir) || (!dirOnly && z->isdir))) { - continue; - } - if ((z->depth == scnt) && Tcl_StringCaseMatch(z->name, pat, 0)) { - if (prefix != NULL) { - Tcl_DStringAppend(&dsPref, z->name + strip, -1); - Tcl_ListObjAppendElement(NULL, result, - Tcl_NewStringObj(Tcl_DStringValue(&dsPref), - Tcl_DStringLength(&dsPref))); - Tcl_DStringSetLength(&dsPref, prefixLen); - } else { - Tcl_ListObjAppendElement(NULL, result, - Tcl_NewStringObj(z->name + strip, -1)); - } - } - } - Tcl_Free(pat); -end: - Unlock(); - Tcl_DStringFree(&dsPref); - Tcl_DStringFree(&ds); - return TCL_OK; -} - -/* - *------------------------------------------------------------------------- - * - * Zip_FSNormalizePathProc -- - * - * Function to normalize given path object. - * - * Results: - * Length of final absolute path name. - * - * Side effects: - * Path object gets converted to an absolute path. - * - *------------------------------------------------------------------------- - */ - -static int -Zip_FSNormalizePathProc(Tcl_Interp *interp, Tcl_Obj *pathPtr, - int nextCheckpoint) -{ - char *path; - Tcl_DString ds; - int len; - - path = Tcl_GetStringFromObj(pathPtr, &len); - Tcl_DStringInit(&ds); -#if HAS_DRIVES - path = AbsolutePath(path, NULL, &ds); -#else - path = AbsolutePath(path, &ds); -#endif - nextCheckpoint = Tcl_DStringLength(&ds); - Tcl_SetStringObj(pathPtr, Tcl_DStringValue(&ds), - Tcl_DStringLength(&ds)); - Tcl_DStringFree(&ds); - return nextCheckpoint; -} - -/* - *------------------------------------------------------------------------- - * - * Zip_FSPathInFilesystemProc -- - * - * This function determines if the given path object is in the - * ZIP filesystem. - * - * Results: - * TCL_OK when the path object is in the ZIP filesystem, -1 otherwise. - * - * Side effects: - * None. - * - *------------------------------------------------------------------------- - */ - -static int -Zip_FSPathInFilesystemProc(Tcl_Obj *pathPtr, ClientData *clientDataPtr) -{ - Tcl_HashEntry *hPtr; - Tcl_HashSearch search; - ZipFile *zf; - int ret = -1, len; - char *path; - Tcl_DString ds; -#if HAS_DRIVES - int drive = 0; -#endif - - path = Tcl_GetStringFromObj(pathPtr, &len); - Tcl_DStringInit(&ds); -#if HAS_DRIVES - path = AbsolutePath(path, &drive, &ds); -#else - path = AbsolutePath(path, &ds); -#endif - len = Tcl_DStringLength(&ds); -#if HAS_DRIVES - if (len && (strchr(drvletters, path[0]) != NULL) && (path[1] == ':')) { - path += 2; - len -= 2; - } -#endif - ReadLock(); - hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, path); - if (hPtr != NULL) { -#if HAS_DRIVES - ZipEntry *z = (ZipEntry *) Tcl_GetHashValue(hPtr); - if (drive == z->zipfile->mntdrv) { - ret = TCL_OK; - goto endloop; - } -#else - ret = TCL_OK; - goto endloop; -#endif - } - hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); - while (hPtr != NULL) { - zf = (ZipFile *) Tcl_GetHashValue(hPtr); -#if HAS_DRIVES - if (drive != zf->mntdrv) { - hPtr = Tcl_NextHashEntry(&search); - continue; - } -#endif - if (zf->mntptlen == 0) { - ZipEntry *z = zf->topents; - - while (z != NULL) { - int lenz = strlen(z->name); - - if ((len >= lenz) && - (strncmp(path, z->name, lenz) == 0)) { - ret = TCL_OK; - goto endloop; - } - z = z->tnext; - } - } else if ((len >= zf->mntptlen) && - (strncmp(path, zf->mntpt, zf->mntptlen) == 0)) { - ret = TCL_OK; - goto endloop; - } - hPtr = Tcl_NextHashEntry(&search); - } -endloop: - Unlock(); - Tcl_DStringFree(&ds); - return ret; -} - -/* - *------------------------------------------------------------------------- - * - * Zip_FSListVolumesProc -- - * - * Lists the currently mounted ZIP filesystem volumes. - * - * Results: - * The list of volumes. - * - * Side effects: - * None - * - *------------------------------------------------------------------------- - */ - -static Tcl_Obj * -Zip_FSListVolumesProc(void) -{ - Tcl_HashEntry *hPtr; - Tcl_HashSearch search; - ZipFile *zf; - Tcl_Obj *vols = Tcl_NewObj(), *vol; - - ReadLock(); - hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); - while (hPtr != NULL) { - zf = (ZipFile *) Tcl_GetHashValue(hPtr); -#if HAS_DRIVES - vol = Tcl_ObjPrintf("%c:%s", zf->mntdrv, - zf->mntpt[0] ? zf->mntpt : "/"); -#else - if (zf->mntpt[0]) { - vol = Tcl_NewStringObj(zf->mntpt, zf->mntptlen); - } else { - vol = Tcl_NewStringObj("/", 1); - } -#endif - Tcl_ListObjAppendElement(NULL, vols, vol); - hPtr = Tcl_NextHashEntry(&search); - } - Unlock(); - Tcl_IncrRefCount(vols); - return vols; -} - -/* - *------------------------------------------------------------------------- - * - * Zip_FSChdirProc -- - * - * If the path object refers to a directory within the ZIP - * filesystem the current directory is set to this directory. - * - * Results: - * TCL_OK on success, -1 on error with error number set. - * - * Side effects: - * The global cwdPathPtr may change value. - * - *------------------------------------------------------------------------- - */ - -static int -Zip_FSChdirProc(Tcl_Obj *pathPtr) -{ - int len; - char *path; - Tcl_DString ds; - ZipEntry *z; - int ret = TCL_OK; -#if HAS_DRIVES - int drive = 0; -#endif - - path = Tcl_GetStringFromObj(pathPtr, &len); - Tcl_DStringInit(&ds); -#if HAS_DRIVES - path = AbsolutePath(path, &drive, &ds); -#else - path = AbsolutePath(path, &ds); -#endif - ReadLock(); - z = ZipFSLookup(path); - if ((z == NULL) || !z->isdir) { - Tcl_SetErrno(ENOENT); - ret = -1; - } -#if HAS_DRIVES - if ((z != NULL) && (drive != z->zipfile->mntdrv)) { - Tcl_SetErrno(ENOENT); - ret = -1; - } -#endif - Unlock(); - Tcl_DStringFree(&ds); - return ret; -} - -/* - *------------------------------------------------------------------------- - * - * Zip_FSFileAttrStringsProc -- - * - * This function implements the ZIP filesystem dependent 'file attributes' - * subcommand, for listing the set of possible attribute strings. - * - * Results: - * An array of strings - * - * Side effects: - * None. - * - *------------------------------------------------------------------------- - */ - -static const char *const * -Zip_FSFileAttrStringsProc(Tcl_Obj *pathPtr, Tcl_Obj** objPtrRef) -{ - static const char *const attrs[] = { - "-uncompsize", - "-compsize", - "-offset", - "-mount", - "-archive", - "-permissions", - NULL, - }; - - return attrs; -} - -/* - *------------------------------------------------------------------------- - * - * Zip_FSFileAttrsGetProc -- - * - * This function implements the ZIP filesystem specific - * 'file attributes' subcommand, for 'get' operations. - * - * Results: - * Standard Tcl return code. The object placed in objPtrRef (if TCL_OK - * was returned) is likely to have a refCount of zero. Either way we must - * either store it somewhere (e.g. the Tcl result), or Incr/Decr its - * refCount to ensure it is properly freed. - * - * Side effects: - * None. - * - *------------------------------------------------------------------------- - */ - -static int -Zip_FSFileAttrsGetProc(Tcl_Interp *interp, int index, Tcl_Obj *pathPtr, - Tcl_Obj **objPtrRef) -{ - int len, ret = TCL_OK; - char *path; - ZipEntry *z; - - path = Tcl_GetStringFromObj(pathPtr, &len); - ReadLock(); - z = ZipFSLookup(path); - if (z == NULL) { - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj("file not found", -1)); - } - ret = TCL_ERROR; - goto done; - } - switch (index) { - case 0: - *objPtrRef = Tcl_NewIntObj(z->nbyte); - goto done; - case 1: - *objPtrRef= Tcl_NewIntObj(z->nbytecompr); - goto done; - case 2: - *objPtrRef= Tcl_NewLongObj(z->offset); - goto done; - case 3: - *objPtrRef= Tcl_NewStringObj(z->zipfile->mntpt, -1); - goto done; - case 4: - *objPtrRef= Tcl_NewStringObj(z->zipfile->name, -1); - goto done; - case 5: - *objPtrRef= Tcl_NewStringObj("0555", -1); - goto done; - } - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj("unknown attribute", -1)); - } - ret = TCL_ERROR; -done: - Unlock(); - return ret; -} - -/* - *------------------------------------------------------------------------- - * - * Zip_FSFileAttrsSetProc -- - * - * This function implements the ZIP filesystem specific - * 'file attributes' subcommand, for 'set' operations. - * - * Results: - * Standard Tcl return code. - * - * Side effects: - * None. - * - *------------------------------------------------------------------------- - */ - -static int -Zip_FSFileAttrsSetProc(Tcl_Interp *interp, int index, Tcl_Obj *pathPtr, - Tcl_Obj *objPtr) -{ - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj("unsupported operation", -1)); - } - return TCL_ERROR; -} - -/* - *------------------------------------------------------------------------- - * - * Zip_FSFilesystemPathTypeProc -- - * - * Results: - * - * Side effects: - * - *------------------------------------------------------------------------- - */ - -static Tcl_Obj * -Zip_FSFilesystemPathTypeProc(Tcl_Obj *pathPtr) -{ - return Tcl_NewStringObj("zip", -1); -} - - -/* - *------------------------------------------------------------------------- - * - * Zip_FSLoadFile -- - * - * This functions deals with loading native object code. If - * the given path object refers to a file within the ZIP - * filesystem, an approriate error code is returned to delegate - * loading to the caller (by copying the file to temp store - * and loading from there). As fallback when the file refers - * to the ZIP file system but is not present, it is looked up - * relative to the executable and loaded from there when available. - * - * Results: - * TCL_OK on success, -1 otherwise with error number set. - * - * Side effects: - * Loads native code into the process address space. - * - *------------------------------------------------------------------------- - */ - -static int -Zip_FSLoadFile(Tcl_Interp *interp, Tcl_Obj *path, Tcl_LoadHandle *loadHandle, - Tcl_FSUnloadFileProc **unloadProcPtr, int flags) -{ - Tcl_FSLoadFileProc2 *loadFileProc; -#ifdef ANDROID - /* - * Force loadFileProc to native implementation since the - * package manger already extracted the shared libraries - * from the APK at install time. - */ - - loadFileProc = (Tcl_FSLoadFileProc2 *) tclNativeFilesystem.loadFileProc; - if (loadFileProc != NULL) { - return loadFileProc(interp, path, loadHandle, unloadProcPtr, flags); - } - Tcl_SetErrno(ENOENT); - return -1; -#else - Tcl_Obj *altPath = NULL; - int ret = -1; - - if (Tcl_FSAccess(path, R_OK) == 0) { - /* - * EXDEV should trigger loading by copying to temp store. - */ - Tcl_SetErrno(EXDEV); - return ret; - } else { - Tcl_Obj *objs[2] = { NULL, NULL }; - - objs[1] = TclPathPart(interp, path, TCL_PATH_DIRNAME); - if ((objs[1] != NULL) && (Zip_FSAccessProc(objs[1], R_OK) == 0)) { - const char *execName = Tcl_GetNameOfExecutable(); - - /* - * Shared object is not in ZIP but its path prefix is, - * thus try to load from directory where the executable - * came from. - */ - TclDecrRefCount(objs[1]); - objs[1] = TclPathPart(interp, path, TCL_PATH_TAIL); - /* - * Get directory name of executable manually to deal - * with cases where [file dirname [info nameofexecutable]] - * is equal to [info nameofexecutable] due to VFS effects. - */ - if (execName != NULL) { - const char *p = strrchr(execName, '/'); - - if (p > execName + 1) { - --p; - objs[0] = Tcl_NewStringObj(execName, p - execName); - } - } - if (objs[0] == NULL) { - objs[0] = TclPathPart(interp, TclGetObjNameOfExecutable(), - TCL_PATH_DIRNAME); - } - if (objs[0] != NULL) { - altPath = TclJoinPath(2, objs); - if (altPath != NULL) { - Tcl_IncrRefCount(altPath); - if (Tcl_FSAccess(altPath, R_OK) == 0) { - path = altPath; - } - } - } - } - if (objs[0] != NULL) { - Tcl_DecrRefCount(objs[0]); - } - if (objs[1] != NULL) { - Tcl_DecrRefCount(objs[1]); - } - } - loadFileProc = (Tcl_FSLoadFileProc2 *) tclNativeFilesystem.loadFileProc; - if (loadFileProc != NULL) { - ret = loadFileProc(interp, path, loadHandle, unloadProcPtr, flags); - } else { - Tcl_SetErrno(ENOENT); - } - if (altPath != NULL) { - Tcl_DecrRefCount(altPath); - } - return ret; -#endif -} - - -/* - * Define the ZIP filesystem dispatch table. - */ - -MODULE_SCOPE const Tcl_Filesystem zipfsFilesystem; - -const Tcl_Filesystem zipfsFilesystem = { - "zipfs", - sizeof (Tcl_Filesystem), - TCL_FILESYSTEM_VERSION_2, - Zip_FSPathInFilesystemProc, - NULL, /* dupInternalRepProc */ - NULL, /* freeInternalRepProc */ - NULL, /* internalToNormalizedProc */ - NULL, /* createInternalRepProc */ - Zip_FSNormalizePathProc, - Zip_FSFilesystemPathTypeProc, - Zip_FSFilesystemSeparatorProc, - Zip_FSStatProc, - Zip_FSAccessProc, - Zip_FSOpenFileChannelProc, - Zip_FSMatchInDirectoryProc, - NULL, /* utimeProc */ - NULL, /* linkProc */ - Zip_FSListVolumesProc, - Zip_FSFileAttrStringsProc, - Zip_FSFileAttrsGetProc, - Zip_FSFileAttrsSetProc, - NULL, /* createDirectoryProc */ - NULL, /* removeDirectoryProc */ - NULL, /* deleteFileProc */ - NULL, /* copyFileProc */ - NULL, /* renameFileProc */ - NULL, /* copyDirectoryProc */ - NULL, /* lstatProc */ - (Tcl_FSLoadFileProc *) Zip_FSLoadFile, - NULL, /* getCwdProc */ - Zip_FSChdirProc, -}; - -#endif /* HAVE_ZLIB */ - - - -Zipfs_one_time_init(Tcl_Interp *interp) { - /* one-time initialization */ - WriteLock(); - if (!ZipFS.initialized) { -#ifdef TCL_THREADS - static const Tcl_Time t = { 0, 0 }; - - /* - * Inflate condition variable. - */ - Tcl_MutexLock(&ZipFSMutex); - Tcl_ConditionWait(&ZipFSCond, &ZipFSMutex, &t); - Tcl_MutexUnlock(&ZipFSMutex); -#endif - Tcl_FSRegister(NULL, &zipfsFilesystem); - Tcl_InitHashTable(&ZipFS.fileHash, TCL_STRING_KEYS); - Tcl_InitHashTable(&ZipFS.zipHash, TCL_STRING_KEYS); - ZipFS.initialized = ZipFS.idCount = 1; - if(interp) { - Tcl_StaticPackage(interp, "zipfs", Tclzipfs_Init, Tclzipfs_SafeInit); - } - } - Unlock(); -} -/* - *------------------------------------------------------------------------- - * - * Zipfs_doInit -- - * - * Perform per interpreter initialization of this module. - * - * Results: - * The return value is a standard Tcl result. - * - * Side effects: - * Initializes this module if not already initialized, and adds - * module related commands to the given interpreter. - * - *------------------------------------------------------------------------- - */ - -static int -Zipfs_doInit(Tcl_Interp *interp, int safe) -{ -#ifdef HAVE_ZLIB - static const EnsembleImplMap initMap[] = { - {"mount", ZipFSMountObjCmd, NULL, NULL, NULL, 0}, - {"unmount", ZipFSUnmountObjCmd, NULL, NULL, NULL, 0}, - {"mkkey", ZipFSMkKeyObjCmd, NULL, NULL, NULL, 0}, - {"mkimg", ZipFSMkImgObjCmd, NULL, NULL, NULL, 0}, - {"mkzip", ZipFSMkZipObjCmd, NULL, NULL, NULL, 0}, - {"lmkimg", ZipFSLMkImgObjCmd, NULL, NULL, NULL, 0}, - {"lmkzip", ZipFSLMkZipObjCmd, NULL, NULL, NULL, 0}, - {"exists", ZipFSExistsObjCmd, NULL, NULL, NULL, 0}, - {"info", ZipFSInfoObjCmd, NULL, NULL, NULL, 0}, - {"list", ZipFSListObjCmd, NULL, NULL, NULL, 0}, - {NULL, NULL, NULL, NULL, NULL, 0} - }; - - static const EnsembleImplMap initSafeMap[] = { - {"exists", ZipFSExistsObjCmd, NULL, NULL, NULL, 0}, - {"info", ZipFSInfoObjCmd, NULL, NULL, NULL, 0}, - {"list", ZipFSListObjCmd, NULL, NULL, NULL, 0}, - {NULL, NULL, NULL, NULL, NULL, 0} - }; - - static const char findproc[] = - "namespace eval zipfs {}\n" - "proc ::zipfs::find dir {\n" - " set result {}\n" - " if {[catch {glob -directory $dir -tails -nocomplain * .*} list]} {\n" - " return $result\n" - " }\n" - " foreach file $list {\n" - " if {$file eq \".\" || $file eq \"..\"} {\n" - " continue\n" - " }\n" - " set file [file join $dir $file]\n" - " lappend result $file\n" - " foreach file [::zipfs::find $file] {\n" - " lappend result $file\n" - " }\n" - " }\n" - " return [lsort $result]\n" - "}\n"; - Zipfs_one_time_init(interp); - if (!safe) { - Tcl_EvalEx(interp, findproc, -1, TCL_EVAL_GLOBAL); - Tcl_LinkVar(interp, "::zipfs::wrmax", (char *) &ZipFS.wrmax, - TCL_LINK_INT); - } - TclMakeEnsemble(interp, "zipfs", safe ? initSafeMap : initMap); - - Tcl_PkgProvide(interp, "zipfs", "1.0"); - - return TCL_OK; -#else - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj("no zlib available", -1)); - } - return TCL_ERROR; -#endif -} - -/* - *------------------------------------------------------------------------- - * - * Tclzipfs_Init, Tclzipfs_SafeInit -- - * - * These functions are invoked to perform per interpreter initialization - * of this module. - * - * Results: - * The return value is a standard Tcl result. - * - * Side effects: - * Initializes this module if not already initialized, and adds - * module related commands to the given interpreter. - * - *------------------------------------------------------------------------- - */ - -int -Tclzipfs_Init(Tcl_Interp *interp) -{ - return Zipfs_doInit(interp, 0); -} - -int -Tclzipfs_SafeInit(Tcl_Interp *interp) -{ - return Zipfs_doInit(interp, 1); -} - -#ifndef HAVE_ZLIB - -/* - *------------------------------------------------------------------------- - * - * Tclzipfs_Mount, Tclzipfs_Unmount -- - * - * Dummy version when no ZLIB support available. - * - *------------------------------------------------------------------------- - */ - -int -Tclzipfs_Mount(Tcl_Interp *interp, const char *zipname, const char *mntpt, - const char *passwd) -{ - return Zipfs_doInit(interp, 1); -} - -int -Tclzipfs_Unmount(Tcl_Interp *interp, const char *zipname) -{ - return Zipfs_doInit(interp, 1); -} - -#endif - -/* -** Boot a shell, mount the executable's VFS, detect main.tcl -*/ -int Tcl_Zvfs_Boot(const char *archive,const char *vfsmountpoint,const char *initscript,const char *passwd) { - #ifdef HAVE_ZLIB - Zipfs_one_time_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(!Tclzipfs_Mount(NULL, archive, vfsmountpoint,passwd)) { - 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); - } - #endif - return TCL_OK; -} - -/* - * Local Variables: - * mode: c - * c-basic-offset: 4 - * fill-column: 78 - * End: - */ diff --git a/library/practcl/pkgIndex.tcl b/library/practcl/pkgIndex.tcl new file mode 100644 index 0000000..1e378e8 --- /dev/null +++ b/library/practcl/pkgIndex.tcl @@ -0,0 +1,11 @@ +# Tcl package index file, version 1.1 +# This file is generated by the "pkg_mkIndex" command +# and sourced either when an application starts up or +# by a "package unknown" script. It invokes the +# "package ifneeded" command to set up package-related +# information so that packages will be loaded automatically +# in response to "package require" commands. When this +# script is sourced, the variable $dir must contain the +# full path name of this file's directory. + +package ifneeded practcl 0.5 [list source [file join $dir practcl.tcl]] diff --git a/library/practcl/practcl.tcl b/library/practcl/practcl.tcl new file mode 100644 index 0000000..3b4b04e --- /dev/null +++ b/library/practcl/practcl.tcl @@ -0,0 +1,4000 @@ +### +# Practcl +# An object oriented templating system for stamping out Tcl API calls to C +### +puts [list LOADED practcl.tcl from [info script]] +package require TclOO +proc ::debug args { + #puts $args + ::practcl::cputs ::DEBUG_INFO $args +} + +### +# Drop in a static copy of Tcl +### +proc ::doexec args { + puts [list {*}$args] + exec {*}$args >&@ stdout +} + +proc ::dotclexec args { + puts [list [info nameofexecutable] {*}$args] + exec [info nameofexecutable] {*}$args >&@ stdout +} + +proc ::domake {path args} { + set PWD [pwd] + cd $path + puts [list *** $path ***] + puts [list make {*}$args] + exec make {*}$args >&@ stdout + cd $PWD +} + +proc ::domake.tcl {path args} { + set PWD [pwd] + cd $path + puts [list *** $path ***] + puts [list make.tcl {*}$args] + exec [info nameofexecutable] make.tcl {*}$args >&@ stdout + cd $PWD +} + +proc ::fossil {path args} { + set PWD [pwd] + cd $path + puts [list {*}$args] + exec fossil {*}$args >&@ stdout + cd $PWD +} + + +proc ::fossil_status {dir} { + if {[info exists ::fosdat($dir)]} { + return $::fosdat($dir) + } + set result { +tags experimental +version {} + } + set pwd [pwd] + cd $dir + set info [exec fossil status] + cd $pwd + foreach line [split $info \n] { + if {[lindex $line 0] eq "checkout:"} { + set hash [lindex $line end-3] + set maxdate [lrange $line end-2 end-1] + dict set result hash $hash + dict set result maxdate $maxdate + regsub -all {[^0-9]} $maxdate {} isodate + dict set result isodate $isodate + } + if {[lindex $line 0] eq "tags:"} { + set tags [lrange $line 1 end] + dict set result tags $tags + break + } + } + set ::fosdat($dir) $result + return $result +} +### +# Seek out Tcllib if it's available +### +set tcllib_path {} +foreach path {.. ../.. ../../..} { + foreach path [glob -nocomplain [file join [file normalize $path] tcllib* modules]] { + set tclib_path $path + lappend ::auto_path $path + break + } + if {$tcllib_path ne {}} break +} + + +### +# Build utility functions +### +namespace eval ::practcl {} + +proc ::practcl::os {} { + if {[info exists ::project(TEACUP_OS)] && $::project(TEACUP_OS) ni {"@TEACUP_OS@" {}}} { + return $::project(TEACUP_OS) + } + set info [::practcl::config.tcl $::project(builddir)] + if {[dict exists $info TEACUP_OS]} { + return [dict get $info TEACUP_OS] + } + return unknown +} + +### +# Detect local platform +### +proc ::practcl::config.tcl {path} { + dict set result buildpath $path + set result {} + if {[file exists [file join $path config.tcl]]} { + set fin [open [file join $path config.tcl] r] + set bufline {} + set rawcount 0 + set linecount 0 + while {[gets $fin thisline]>=0} { + incr rawcount + append bufline \n $thisline + if {![info complete $bufline]} continue + set line [string trimleft $bufline] + set bufline {} + if {[string index [string trimleft $line] 0] eq "#"} continue + incr linecount + set key [lindex $line 0] + set value [lindex $line 1] + dict set result $key $value + } + dict set result sandbox [file dirname [dict get $result srcdir]] + dict set result download [file join [dict get $result sandbox] download] + dict set result teapot [file join [dict get $result sandbox] teapot] + set result [::practcl::de_shell $result] + } + # If data is available from autoconf, defer to that + if {[dict exists $result TEACUP_OS] && [dict get $result TEACUP_OS] ni {"@TEACUP_OS@" {}}} { + return $result + } + # If autoconf hasn't run yet, assume we are not cross compiling + # and defer to local checks + dict set result TEACUP_PROFILE unknown + dict set result TEACUP_OS unknown + dict set result EXEEXT {} + if {$::tcl_platform(platform) eq "windows"} { + set system "windows" + set arch ix86 + dict set result TEACUP_PROFILE win32-ix86 + dict set result TEACUP_OS windows + dict set result EXEEXT .exe + } else { + set system [exec uname -s]-[exec uname -r] + set arch unknown + dict set result TEACUP_OS generic + } + dict set result TEA_PLATFORM $system + dict set result TEA_SYSTEM $system + switch -glob $system { + Linux* { + dict set result TEACUP_OS linux + set arch [exec uname -m] + dict set result TEACUP_PROFILE "linux-glibc2.3-$arch" + } + GNU* { + set arch [exec uname -m] + dict set result TEACUP_OS "gnu" + } + NetBSD-Debian { + set arch [exec uname -m] + dict set result TEACUP_OS "netbsd-debian" + } + OpenBSD-* { + set arch [exec arch -s] + dict set result TEACUP_OS "openbsd" + } + Darwin* { + set arch [exec uname -m] + dict set result TEACUP_OS "macosx" + if {$arch eq "x86_64"} { + dict set result TEACUP_PROFILE "macosx10.5-i386-x86_84" + } else { + dict set result TEACUP_PROFILE "macosx-universal" + } + } + OpenBSD* { + set arch [exec arch -s] + dict set result TEACUP_OS "openbsd" + } + } + if {$arch eq "unknown"} { + catch {set arch [exec uname -m]} + } + switch -glob $arch { + i*86 { + set arch "ix86" + } + amd64 { + set arch "x86_64" + } + } + dict set result TEACUP_ARCH $arch + if {[dict get $result TEACUP_PROFILE] eq "unknown"} { + dict set result TEACUP_PROFILE [dict get $result TEACUP_OS]-$arch + } + return $result +} + + +### +# Convert an MSYS path to a windows native path +### +if {$::tcl_platform(platform) eq "windows"} { +proc ::practcl::msys_to_tclpath msyspath { + return [exec sh -c "cd $msyspath ; pwd -W"] +} +} else { +proc ::practcl::msys_to_tclpath msyspath { + return [file normalize $msyspath] +} +} + +### +# Bits stolen from fileutil +### +proc ::practcl::cat fname { + set fname [open $fname r] + set data [read $fname] + close $fname + return $data +} + +proc ::practcl::file_lexnormalize {sp} { + set spx [file split $sp] + + # Resolution of embedded relative modifiers (., and ..). + + if { + ([lsearch -exact $spx . ] < 0) && + ([lsearch -exact $spx ..] < 0) + } { + # Quick path out if there are no relative modifiers + return $sp + } + + set absolute [expr {![string equal [file pathtype $sp] relative]}] + # A volumerelative path counts as absolute for our purposes. + + set sp $spx + set np {} + set noskip 1 + + while {[llength $sp]} { + set ele [lindex $sp 0] + set sp [lrange $sp 1 end] + set islast [expr {[llength $sp] == 0}] + + if {[string equal $ele ".."]} { + if { + ($absolute && ([llength $np] > 1)) || + (!$absolute && ([llength $np] >= 1)) + } { + # .. : Remove the previous element added to the + # new path, if there actually is enough to remove. + set np [lrange $np 0 end-1] + } + } elseif {[string equal $ele "."]} { + # Ignore .'s, they stay at the current location + continue + } else { + # A regular element. + lappend np $ele + } + } + if {[llength $np] > 0} { + return [eval [linsert $np 0 file join]] + # 8.5: return [file join {*}$np] + } + return {} +} + +proc ::practcl::file_relative {base dst} { + # Ensure that the link to directory 'dst' is properly done relative to + # the directory 'base'. + + if {![string equal [file pathtype $base] [file pathtype $dst]]} { + return -code error "Unable to compute relation for paths of different pathtypes: [file pathtype $base] vs. [file pathtype $dst], ($base vs. $dst)" + } + + set base [file_lexnormalize [file join [pwd] $base]] + set dst [file_lexnormalize [file join [pwd] $dst]] + + set save $dst + set base [file split $base] + set dst [file split $dst] + + while {[string equal [lindex $dst 0] [lindex $base 0]]} { + set dst [lrange $dst 1 end] + set base [lrange $base 1 end] + if {![llength $dst]} {break} + } + + set dstlen [llength $dst] + set baselen [llength $base] + + if {($dstlen == 0) && ($baselen == 0)} { + # Cases: + # (a) base == dst + + set dst . + } else { + # Cases: + # (b) base is: base/sub = sub + # dst is: base = {} + + # (c) base is: base = {} + # dst is: base/sub = sub + + while {$baselen > 0} { + set dst [linsert $dst 0 ..] + incr baselen -1 + } + # 8.5: set dst [file join {*}$dst] + set dst [eval [linsert $dst 0 file join]] + } + + return $dst +} + +### +# Unpack the source of a fossil project into a designated location +### +proc ::practcl::fossil_sandbox {pkg args} { + if {[llength $args]==1} { + set info [lindex $args 0] + } else { + set info $args + } + set result $info + if {[dict exists $info srcroot]} { + set srcroot [dict get $info srcroot] + } elseif {[dict exists $info sandbox]} { + set srcroot [file join [dict get $info sandbox] $pkg] + } else { + set srcroot [file join $::CWD .. $pkg] + } + dict set result srcroot $srcroot + puts [list fossil_sandbox $pkg $srcroot] + if {[dict exists $info download]} { + ### + # Source is actually a zip archive + ### + set download [dict get $info download] + if {[file exists [file join $download $pkg.zip]]} { + if {![info exists $srcroot]} { + package require zipfile::decode + ::zipfile::decode::unzipfile [file join $download $pkg.zip] $srcroot + } + return + } + } + variable fossil_dbs + if {![::info exists fossil_dbs]} { + # Get a list of local fossil databases + set fossil_dbs [exec fossil all list] + } + set CWD [pwd] + if {![dict exists $info tag]} { + set tag trunk + } else { + set tag [dict get $info tag] + } + dict set result tag $tag + + try { + if {[file exists [file join $srcroot .fslckout]]} { + if {[dict exists $info update] && [dict get $info update]==1} { + catch { + puts "FOSSIL UPDATE" + cd $srcroot + doexec fossil update $tag + } + } + } elseif {[file exists [file join $srcroot _FOSSIL_]]} { + if {[dict exists $info update] && [dict get $info update]==1} { + catch { + puts "FOSSIL UPDATE" + cd $srcroot + doexec fossil update $tag + } + } + } else { + puts "OPEN AND UNPACK" + set fosdb {} + foreach line [split $fossil_dbs \n] { + set line [string trim $line] + if {[file rootname [file tail $line]] eq $pkg} { + set fosdb $line + break + } + } + if {$fosdb eq {}} { + file mkdir [file join $download fossil] + set fosdb [file join $download fossil $pkg.fos] + set cloned 0 + if {[dict exists $info localmirror]} { + set localmirror [dict get $info localmirror] + catch { + doexec fossil clone $localmirror/$pkg $fosdb + set cloned 1 + } + } + if {!$cloned && [dict exists $info fossil_url]} { + set localmirror [dict get $info fossil_url] + catch { + doexec fossil clone $localmirror/$pkg $fosdb + set cloned 1 + } + } + if {!$cloned} { + doexec fossil clone http://fossil.etoyoc.com/fossil/$pkg $fosdb + } + } + file mkdir $srcroot + cd $srcroot + puts "FOSSIL OPEN [pwd]" + doexec fossil open $fosdb $tag + } + } on error {result opts} { + puts [list ERR [dict get $opts -errorinfo]] + return {*}$opts + } finally { + cd $CWD + } + return $result +} + +### +# topic: e71f3f61c348d56292011eec83e95f0aacc1c618 +# description: Converts a XXX.sh file into a series of Tcl variables +### +proc ::practcl::read_sh_subst {line info} { + regsub -all {\x28} $line \x7B line + regsub -all {\x29} $line \x7D line + + #set line [string map $key [string trim $line]] + foreach {field value} $info { + catch {set $field $value} + } + if [catch {subst $line} result] { + return {} + } + set result [string trim $result] + return [string trim $result '] +} + +### +# topic: 03567140cca33c814664c7439570f669b9ab88e6 +### +proc ::practcl::read_sh_file {filename {localdat {}}} { + set fin [open $filename r] + set result {} + if {$localdat eq {}} { + set top 1 + set local [array get ::env] + dict set local EXE {} + } else { + set top 0 + set local $localdat + } + while {[gets $fin line] >= 0} { + set line [string trim $line] + if {[string index $line 0] eq "#"} continue + if {$line eq {}} continue + catch { + if {[string range $line 0 6] eq "export "} { + set eq [string first "=" $line] + set field [string trim [string range $line 6 [expr {$eq - 1}]]] + set value [read_sh_subst [string range $line [expr {$eq+1}] end] $local] + dict set result $field [read_sh_subst $value $local] + dict set local $field $value + } elseif {[string range $line 0 7] eq "include "} { + set subfile [read_sh_subst [string range $line 7 end] $local] + foreach {field value} [read_sh_file $subfile $local] { + dict set result $field $value + } + } else { + set eq [string first "=" $line] + if {$eq > 0} { + set field [read_sh_subst [string range $line 0 [expr {$eq - 1}]] $local] + set value [string trim [string range $line [expr {$eq+1}] end] '] + #set value [read_sh_subst [string range $line [expr {$eq+1}] end] $local] + dict set local $field $value + dict set result $field $value + } + } + } err opts + if {[dict get $opts -code] != 0} { + #puts $opts + puts "Error reading line:\n$line\nerr: $err\n***" + return $err {*}$opts + } + } + return $result +} + +### +# A simpler form of read_sh_file tailored +# to pulling data from (tcl|tk)Config.sh +### +proc ::practcl::read_Config.sh filename { + set fin [open $filename r] + set result {} + set linecount 0 + while {[gets $fin line] >= 0} { + set line [string trim $line] + if {[string index $line 0] eq "#"} continue + if {$line eq {}} continue + catch { + set eq [string first "=" $line] + if {$eq > 0} { + set field [string range $line 0 [expr {$eq - 1}]] + set value [string trim [string range $line [expr {$eq+1}] end] '] + #set value [read_sh_subst [string range $line [expr {$eq+1}] end] $local] + dict set result $field $value + incr $linecount + } + } err opts + if {[dict get $opts -code] != 0} { + #puts $opts + puts "Error reading line:\n$line\nerr: $err\n***" + return $err {*}$opts + } + } + return $result +} + +### +# A simpler form of read_sh_file tailored +# to pulling data from a Makefile +### +proc ::practcl::read_Makefile filename { + set fin [open $filename r] + set result {} + while {[gets $fin line] >= 0} { + set line [string trim $line] + if {[string index $line 0] eq "#"} continue + if {$line eq {}} continue + catch { + set eq [string first "=" $line] + if {$eq > 0} { + set field [string trim [string range $line 0 [expr {$eq - 1}]]] + set value [string trim [string trim [string range $line [expr {$eq+1}] end] ']] + switch $field { + PKG_LIB_FILE { + dict set result libfile $value + } + srcdir { + if {$value eq "."} { + dict set result srcdir [file dirname $filename] + } else { + dict set result srcdir $value + } + } + PACKAGE_NAME { + dict set result name $value + } + PACKAGE_VERSION { + dict set result version $value + } + LIBS { + dict set result PRACTCL_LIBS $value + } + PKG_LIB_FILE { + dict set result libfile $value + } + } + } + } err opts + if {[dict get $opts -code] != 0} { + #puts $opts + puts "Error reading line:\n$line\nerr: $err\n***" + return $err {*}$opts + } + # the Compile field is about where most TEA files start getting silly + if {$field eq "compile"} { + break + } + } + return $result +} + +## Append arguments to a buffer +# The command works like puts in that each call will also insert +# a line feed. Unlike puts, blank links in the interstitial are +# suppressed +proc ::practcl::cputs {varname args} { + upvar 1 $varname buffer + if {[llength $args]==1 && [string length [string trim [lindex $args 0]]] == 0} { + + } + if {[info exist buffer]} { + if {[string index $buffer end] ne "\n"} { + append buffer \n + } + } else { + set buffer \n + } + # Trim leading \n's + append buffer [string trimleft [lindex $args 0] \n] {*}[lrange $args 1 end] +} + + +proc ::practcl::tcl_to_c {body} { + set result {} + foreach rawline [split $body \n] { + set line [string map [list \" \\\" \\ \\\\] $rawline] + cputs result "\n \"$line\\n\" \\" + } + return [string trimright $result \\] +} + + +proc ::practcl::_tagblock {text {style tcl} {note {}}} { + if {[string length [string trim $text]]==0} { + return {} + } + set output {} + switch $style { + tcl { + ::practcl::cputs output "# BEGIN $note" + } + c { + ::practcl::cputs output "/* BEGIN $note */" + } + default { + ::practcl::cputs output "# BEGIN $note" + } + } + ::practcl::cputs output $text + switch $style { + tcl { + ::practcl::cputs output "# END $note" + } + c { + ::practcl::cputs output "/* END $note */" + } + default { + ::practcl::cputs output "# END $note" + } + } + return $output +} + +proc ::practcl::_isdirectory name { + return [file isdirectory $name] +} + +### +# Return true if the pkgindex file contains +# any statement other than "package ifneeded" +# and/or if any package ifneeded loads a DLL +### +proc ::practcl::_pkgindex_directory {path} { + set buffer {} + set pkgidxfile [file join $path pkgIndex.tcl] + if {![file exists $pkgidxfile]} { + # No pkgIndex file, read the source + foreach file [glob -nocomplain $path/*.tm] { + set file [file normalize $file] + set fname [file rootname [file tail $file]] + ### + # We used to be able to ... Assume the package is correct in the filename + # No hunt for a "package provides" + ### + set package [lindex [split $fname -] 0] + set version [lindex [split $fname -] 1] + ### + # Read the file, and override assumptions as needed + ### + set fin [open $file r] + set dat [read $fin] + close $fin + # Look for a teapot style Package statement + foreach line [split $dat \n] { + set line [string trim $line] + if { [string range $line 0 9] != "# Package " } continue + set package [lindex $line 2] + set version [lindex $line 3] + break + } + # Look for a package provide statement + foreach line [split $dat \n] { + set line [string trim $line] + if { [string range $line 0 14] != "package provide" } continue + set package [lindex $line 2] + set version [lindex $line 3] + break + } + append buffer "package ifneeded $package $version \[list source \[file join \$dir [file tail $file]\]\]" \n + } + foreach file [glob -nocomplain $path/*.tcl] { + if { [file tail $file] == "version_info.tcl" } continue + set fin [open $file r] + set dat [read $fin] + close $fin + if {![regexp "package provide" $dat]} continue + set fname [file rootname [file tail $file]] + # Look for a package provide statement + foreach line [split $dat \n] { + set line [string trim $line] + if { [string range $line 0 14] != "package provide" } continue + set package [lindex $line 2] + set version [lindex $line 3] + if {[string index $package 0] in "\$ \["} continue + if {[string index $version 0] in "\$ \["} continue + append buffer "package ifneeded $package $version \[list source \[file join \$dir [file tail $file]\]\]" \n + break + } + } + return $buffer + } + set fin [open $pkgidxfile r] + set dat [read $fin] + close $fin + set thisline {} + foreach line [split $dat \n] { + append thisline $line \n + if {![info complete $thisline]} continue + set line [string trim $line] + if {[string length $line]==0} { + set thisline {} ; continue + } + if {[string index $line 0] eq "#"} { + set thisline {} ; continue + } + try { + # Ignore contditionals + if {[regexp "if.*catch.*package.*Tcl.*return" $thisline]} continue + if {[regexp "if.*package.*vsatisfies.*package.*provide.*return" $thisline]} continue + if {![regexp "package.*ifneeded" $thisline]} { + # This package index contains arbitrary code + # source instead of trying to add it to the master + # package index + return {source [file join $dir pkgIndex.tcl]} + } + append buffer $thisline \n + } on error {err opts} { + puts *** + puts "GOOF: $pkgidxfile" + puts $line + puts $err + puts [dict get $opts -errorinfo] + puts *** + } finally { + set thisline {} + } + } + return $buffer +} + + +proc ::practcl::_pkgindex_path_subdir {path} { + set result {} + foreach subpath [glob -nocomplain [file join $path *]] { + if {[file isdirectory $subpath]} { + lappend result $subpath {*}[_pkgindex_path_subdir $subpath] + } + } + return $result +} +### +# Index all paths given as though they will end up in the same +# virtual file system +### +proc ::practcl::pkgindex_path args { + set stack {} + set buffer { +lappend ::PATHSTACK $dir + } + foreach base $args { + set base [file normalize $base] + set paths [::practcl::_pkgindex_path_subdir $base] + set i [string length $base] + # Build a list of all of the paths + foreach path $paths { + if {$path eq $base} continue + set path_indexed($path) 0 + } + set path_indexed($base) 1 + set path_indexed([file join $base boot tcl]) 1 + #set path_index([file join $base boot tk]) 1 + + foreach path $paths { + if {$path_indexed($path)} continue + set thisdir [file_relative $base $path] + #set thisdir [string range $path $i+1 end] + set idxbuf [::practcl::_pkgindex_directory $path] + if {[string length $idxbuf]} { + incr path_indexed($path) + append buffer "set dir \[set PKGDIR \[file join \[lindex \$::PATHSTACK end\] $thisdir\]\]" \n + append buffer [string map {$dir $PKGDIR} [string trimright $idxbuf]] \n + } + } + } + append buffer { +set dir [lindex $::PATHSTACK end] +set ::PATHSTACK [lrange $::PATHSTACK 0 end-1] +} + return $buffer +} + +### +# topic: 64319f4600fb63c82b2258d908f9d066 +# description: Script to build the VFS file system +### +proc ::practcl::installDir {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]} { + installDir $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 + } +} + +proc ::practcl::copyDir {d1 d2} { + #puts [list $d1 -> $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] + } + } +} + +::oo::class create ::practcl::metaclass { + superclass ::oo::object + + method script script { + eval $script + } + + method source filename { + source $filename + } + + method initialize {} {} + + method define {submethod args} { + my variable define + switch $submethod { + dump { + return [array get define] + } + add { + set field [lindex $args 0] + if {![info exists define($field)]} { + set define($field) {} + } + foreach arg [lrange $args 1 end] { + if {$arg ni $define($field)} { + lappend define($field) $arg + } + } + return $define($field) + } + remove { + set field [lindex $args 0] + if {![info exists define($field)]} { + return + } + set rlist [lrange $args 1 end] + set olist $define($field) + set nlist {} + foreach arg $olist { + if {$arg in $rlist} continue + lappend nlist $arg + } + set define($field) $nlist + return $nlist + } + exists { + set field [lindex $args 0] + return [info exists define($field)] + } + getnull - + get - + cget { + set field [lindex $args 0] + if {[info exists define($field)]} { + return $define($field) + } + return [lindex $args 1] + } + set { + if {[llength $args]==1} { + set arglist [lindex $args 0] + } else { + set arglist $args + } + array set define $arglist + if {[dict exists $arglist class]} { + my select + } + } + default { + array $submethod define {*}$args + } + } + } + + method graft args { + my variable organs + if {[llength $args] == 1} { + error "Need two arguments" + } + set object {} + foreach {stub object} $args { + dict set organs $stub $object + oo::objdefine [self] forward <${stub}> $object + oo::objdefine [self] export <${stub}> + } + return $object + } + + method organ {{stub all}} { + my variable organs + if {![info exists organs]} { + return {} + } + if { $stub eq "all" } { + return $organs + } + if {[dict exists $organs $stub]} { + return [dict get $organs $stub] + } + } + + method link {command args} { + my variable links + switch $command { + object { + foreach obj $args { + foreach linktype [$obj linktype] { + my link add $linktype $obj + } + } + } + add { + ### + # Add a link to an object that was externally created + ### + if {[llength $args] ne 2} { error "Usage: link add LINKTYPE OBJECT"} + lassign $args linktype object + if {[info exists links($linktype)] && $object in $links($linktype)} { + return + } + lappend links($linktype) $object + } + remove { + set object [lindex $args 0] + if {[llength $args]==1} { + set ltype * + } else { + set ltype [lindex $args 1] + } + foreach {linktype elements} [array get links $ltype] { + if {$object in $elements} { + set nlist {} + foreach e $elements { + if { $object ne $e } { lappend nlist $e } + } + set links($linktype) $nlist + } + } + } + list { + if {[llength $args]==0} { + return [array get links] + } + if {[llength $args] != 1} { error "Usage: link list LINKTYPE"} + set linktype [lindex $args 0] + if {![info exists links($linktype)]} { + return {} + } + return $links($linktype) + } + dump { + return [array get links] + } + } + } + + method select {} { + my variable define + set class {} + if {[info exists define(class)]} { + if {[info command $define(class)] ne {}} { + set class $define(class) + } elseif {[info command ::practcl::$define(class)] ne {}} { + set class ::practcl::$define(class) + } else { + switch $define(class) { + default { + set class ::practcl::object + } + } + } + } + if {$class ne {}} { + ::oo::objdefine [self] class $class + } + if {[::info exists define(oodefine)]} { + ::oo::objdefine [self] $define(oodefine) + unset define(oodefine) + } + } +} + +proc ::practcl::trigger {args} { + foreach name $args { + if {[dict exists $::make_objects $name]} { + [dict get $::make_objects $name] triggers + } + } +} + +proc ::practcl::depends {args} { + foreach name $args { + if {[dict exists $::make_objects $name]} { + [dict get $::make_objects $name] check + } + } +} + +proc ::practcl::target {name info} { + set obj [::practcl::target_obj new $name $info] + dict set ::make_objects $name $obj + if {[dict exists $info aliases]} { + foreach item [dict get $info aliases] { + if {![dict exists $::make_objects $item]} { + dict set ::make_objects $item $obj + } + } + } + set ::make($name) 0 + set ::trigger($name) 0 + set filename [$obj define get filename] + if {$filename ne {}} { + set ::target($name) $filename + } +} + +### Batch Tasks + +namespace eval ::practcl::build {} + +## method DEFS +# This method populates 4 variables: +# name - The name of the package +# version - The version of the package +# defs - C flags passed to the compiler +# includedir - A list of paths to feed to the compiler for finding headers +# +proc ::practcl::build::DEFS {PROJECT DEFS namevar versionvar defsvar} { + upvar 1 $namevar name $versionvar version NAME NAME $defsvar defs + set name [string tolower [${PROJECT} define get name [${PROJECT} define get pkg_name]]] + set NAME [string toupper $name] + set version [${PROJECT} define get version [${PROJECT} define get pkg_vers]] + if {$version eq {}} { + set version 0.1a + } + set defs {} + append defs " -DPACKAGE_NAME=\"${name}\" -DPACKAGE_VERSION=\"${version}\"" + append defs " -DPACKAGE_TARNAME=\"${name}\" -DPACKAGE_STRING=\"${name}\x5c\x20${version}\"" + set NAME [string toupper $name] + set idx 0 + set count 0 + while {$idx>=0} { + set ndx [string first " -D" $DEFS $idx+1] + set item [string range $DEFS $idx $ndx] + set item [string trim $item] + set item [string trimleft $item -D] + if {[string range $item 0 7] eq "PACKAGE_"} { + set idx $ndx + continue + } + set eqidx [string first = $item ] + if {$eqidx < 0} { + append defs { } $item + set idx $ndx + continue + } + + set field [string range $item 0 [expr {$eqidx-1}]] + set value [string range $item [expr {$eqidx+1}] end] + set emap {} + lappend emap \x5c \x5c\x5c \x20 \x5c\x20 \x22 \x5c\x22 \x28 \x5c\x28 \x29 \x5c\x29 + if {[string is integer -strict $value]} { + append defs " -D${field}=$value" + } else { + append defs " -D${field}=[string map $emap $value]" + } + set idx $ndx + } + return $defs +} + +proc ::practcl::build::tclkit_main {PROJECT PKG_OBJS} { + ### + # Build static package list + ### + set statpkglist {} + dict set statpkglist Tk {autoload 0} + puts [list TCLKIT MAIN $PROJECT] + + foreach {ofile info} [${PROJECT} compile-products] { + puts [list * PROD $ofile $info] + if {![dict exists $info object]} continue + set cobj [dict get $info object] + foreach {pkg info} [$cobj static-packages] { + dict set statpkglist $pkg $info + } + } + foreach cobj [list {*}${PKG_OBJS} $PROJECT] { + puts [list * PROG $cobj] + foreach {pkg info} [$cobj static-packages] { + puts [list * PKG $pkg $info] + dict set statpkglist $pkg $info + } + } + + set result {} + $PROJECT include {} + $PROJECT include {"tclInt.h"} + $PROJECT include {"tclFileSystem.h"} + $PROJECT include {} + $PROJECT include {} + $PROJECT include {} + $PROJECT include {} + $PROJECT include {} + + $PROJECT code header { +#ifndef MODULE_SCOPE +# define MODULE_SCOPE extern +#endif + +/* +** Provide a dummy Tcl_InitStubs if we are using this as a static +** library. +*/ +#ifndef USE_TCL_STUBS +# undef Tcl_InitStubs +# define Tcl_InitStubs(a,b,c) TCL_VERSION +#endif +#define STATIC_BUILD 1 +#undef USE_TCL_STUBS + +/* 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 +} + + # Build an area of the file for #define directives and + # function declarations + set define {} + set mainhook [$PROJECT define get TCL_LOCAL_MAIN_HOOK Tclkit_MainHook] + set mainfunc [$PROJECT define get TCL_LOCAL_APPINIT Tclkit_AppInit] + set mainscript [$PROJECT define get main.tcl main.tcl] + set vfsroot [$PROJECT define get vfsroot zipfs:/app] + set vfs_main "${vfsroot}/${mainscript}" + set vfs_tcl_library "${vfsroot}/boot/tcl" + set vfs_tk_library "${vfsroot}/boot/tk" + + set map {} + foreach var { + vfsroot mainhook mainfunc vfs_main vfs_tcl_library vfs_tk_library + } { + dict set map %${var}% [set $var] + } + set preinitscript { +set ::odie(boot_vfs) {%vfsroot%} +set ::SRCDIR {%vfsroot%} +if {[file exists {%vfs_tcl_library%}]} { + set ::tcl_library {%vfs_tcl_library%} + set ::auto_path {} +} +if {[file exists {%vfs_tk_library%}]} { + set ::tk_library {%vfs_tk_library%} +} +} ; # Preinitscript + + set zvfsboot { +/* + * %mainhook% -- + * Performs the argument munging for the shell + */ + } + ::practcl::cputs zvfsboot { + CONST char *archive; + Tcl_FindExecutable(*argv[0]); + archive=Tcl_GetNameOfExecutable(); + + Tclzipfs_Init(NULL); + } + # We have to initialize the virtual filesystem before calling + # Tcl_Init(). Otherwise, Tcl_Init() will not be able to find + # its startup script files. + $PROJECT include {"tclZipfs.h"} + + ::practcl::cputs zvfsboot " if(!TclZipfsMount(NULL, archive, \"%vfsroot%\", NULL)) \x7B " + ::practcl::cputs zvfsboot { + Tcl_Obj *vfsinitscript; + vfsinitscript=Tcl_NewStringObj("%vfs_main%",-1); + Tcl_IncrRefCount(vfsinitscript); + if(Tcl_FSAccess(vfsinitscript,F_OK)==0) { + /* Startup script should be set before calling Tcl_AppInit */ + Tcl_SetStartupScript(vfsinitscript,NULL); + } + } + ::practcl::cputs zvfsboot " TclSetPreInitScript([::practcl::tcl_to_c $preinitscript])\;" + ::practcl::cputs zvfsboot " \x7D else \x7B" + ::practcl::cputs zvfsboot " TclSetPreInitScript([::practcl::tcl_to_c { +foreach path { + ../tcl +} { + set p [file join $path library init.tcl] + if {[file exists [file join $path library init.tcl]]} { + set ::tcl_library [file normalize [file join $path library]] + break + } +} +foreach path { + ../tk +} { + if {[file exists [file join $path library tk.tcl]]} { + set ::tk_library [file normalize [file join $path library]] + break + } +} +}])\;" + + ::practcl::cputs zvfsboot " \x7D" + + ::practcl::cputs zvfsboot " return TCL_OK;" + + if {[$PROJECT define get os] eq "windows"} { + set header {int %mainhook%(int *argc, TCHAR ***argv)} + } else { + set header {int %mainhook%(int *argc, char ***argv)} + } + $PROJECT c_function [string map $map $header] [string map $map $zvfsboot] + + practcl::cputs appinit "int %mainfunc%(Tcl_Interp *interp) \x7B" + + # Build AppInit() + set appinit {} + practcl::cputs appinit { + if ((Tcl_Init)(interp) == TCL_ERROR) { + return TCL_ERROR; + } +} + set main_init_script {} + + foreach {statpkg info} $statpkglist { + set initfunc {} + if {[dict exists $info initfunc]} { + set initfunc [dict get $info initfunc] + } + if {$initfunc eq {}} { + set initfunc [string totitle ${statpkg}]_Init + } + # We employ a NULL to prevent the package system from thinking the + # package is actually loaded into the interpreter + $PROJECT code header "extern Tcl_PackageInitProc $initfunc\;\n" + set script [list package ifneeded $statpkg [dict get $info version] [list ::load {} $statpkg]] + append main_init_script \n [list set ::kitpkg(${statpkg}) $script] + if {[dict get $info autoload]} { + ::practcl::cputs appinit " if(${initfunc}(interp)) return TCL_ERROR\;" + ::practcl::cputs appinit " Tcl_StaticPackage(interp,\"$statpkg\",$initfunc,NULL)\;" + } else { + ::practcl::cputs appinit "\n Tcl_StaticPackage(NULL,\"$statpkg\",$initfunc,NULL)\;" + append main_init_script \n $script + } + } + append main_init_script \n { +if {[file exists [file join $::SRCDIR packages.tcl]]} { + #In a wrapped exe, we don't go out to the environment + set dir $::SRCDIR + source [file join $::SRCDIR packages.tcl] +} +# 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. + } + append main_init_script \n [list set tcl_rcFileName [$PROJECT define get tcl_rcFileName ~/.tclshrc]] + practcl::cputs appinit " Tcl_Eval(interp,[::practcl::tcl_to_c $main_init_script]);" + practcl::cputs appinit { return TCL_OK;} + $PROJECT c_function [string map $map "int %mainfunc%(Tcl_Interp *interp)"] [string map $map $appinit] +} + +proc ::practcl::build::compile-sources {PROJECT COMPILE {CPPCOMPILE {}}} { + set EXTERN_OBJS {} + set OBJECTS {} + set result {} + set builddir [$PROJECT define get builddir] + file mkdir [file join $builddir objs] + set debug [$PROJECT define get debug 0] + if {$CPPCOMPILE eq {}} { + set CPPCOMPILE $COMPILE + } + set task [${PROJECT} compile-products] + ### + # Compile the C sources + ### + foreach {ofile info} $task { + dict set task $ofile done 0 + if {[dict exists $info external] && [dict get $info external]==1} { + dict set task $ofile external 1 + } else { + dict set task $ofile external 0 + } + if {[dict exists $info library]} { + dict set task $ofile done 1 + continue + } + # Products with no cfile aren't compiled + if {![dict exists $info cfile] || [set cfile [dict get $info cfile]] eq {}} { + dict set task $ofile done 1 + continue + } + set cfile [dict get $info cfile] + set ofilename [file join $builddir objs [file tail $ofile]] + if {$debug} { + set ofilename [file join $builddir objs [file rootname [file tail $ofile]].debug.o] + } + dict set task $ofile filename $ofilename + if {[file exists $ofilename] && [file mtime $ofilename]>[file mtime $cfile]} { + lappend result $ofilename + dict set task $ofile done 1 + continue + } + if {![dict exist $info command]} { + if {[file extension $cfile] in {.c++ .cpp}} { + set cmd $CPPCOMPILE + } else { + set cmd $COMPILE + } + if {[dict exists $info extra]} { + append cmd " [dict get $info extra]" + } + append cmd " -c $cfile" + append cmd " -o $ofilename" + dict set task $ofile command $cmd + } + } + set completed 0 + while {$completed==0} { + set completed 1 + foreach {ofile info} $task { + set waiting {} + if {[dict exists $info done] && [dict get $info done]} continue + if {[dict exists $info depend]} { + foreach file [dict get $info depend] { + if {[dict exists $task $file command] && [dict exists $task $file done] && [dict get $task $file done] != 1} { + set waiting $file + break + } + } + } + if {$waiting ne {}} { + set completed 0 + puts "$ofile waiting for $waiting" + continue + } + if {[dict exists $info command]} { + set cmd [dict get $info command] + puts "$cmd" + exec {*}$cmd >&@ stdout + } + lappend result [dict get $info filename] + dict set task $ofile done 1 + } + } + return $result +} + +proc ::practcl::de_shell {data} { + set values {} + foreach flag {DEFS TCL_DEFS TK_DEFS} { + if {[dict exists $data $flag]} { + set value {} + foreach item [dict get $data $flag] { + append value " " [string map {{ } {\ }} $item] + } + dict set values $flag $value + } + } + set map {} + lappend map {${PKG_OBJECTS}} %LIBRARY_OBJECTS% + lappend map {$(PKG_OBJECTS)} %LIBRARY_OBJECTS% + lappend map {${PKG_STUB_OBJECTS}} %LIBRARY_STUB_OBJECTS% + lappend map {$(PKG_STUB_OBJECTS)} %LIBRARY_STUB_OBJECTS% + + lappend map %LIBRARY_NAME% [dict get $data name] + lappend map %LIBRARY_VERSION% [dict get $data version] + lappend map %LIBRARY_VERSION_NODOTS% [string map {. {}} [dict get $data version]] + if {[dict exists $data libprefix]} { + lappend map %LIBRARY_PREFIX% [dict get $data libprefix] + } else { + lappend map %LIBRARY_PREFIX% [dict get $data prefix] + } + foreach flag [dict keys $data] { + if {$flag in {TCL_DEFS TK_DEFS DEFS}} continue + + dict set map "%${flag}%" [dict get $data $flag] + dict set map "\$\{${flag}\}" [dict get $data $flag] + dict set map "\$\(${flag}\)" [dict get $data $flag] + dict set values $flag [dict get $data $flag] + #dict set map "\$\{${flag}\}" $proj($flag) + } + set changed 1 + while {$changed} { + set changed 0 + foreach {field value} $values { + if {$field in {TCL_DEFS TK_DEFS DEFS}} continue + dict with values {} + set newval [string map $map $value] + if {$newval eq $value} continue + set changed 1 + dict set values $field $newval + } + } + return $values +} + +proc ::practcl::build::Makefile {path PROJECT} { + array set proj [$PROJECT define dump] + set path $proj(builddir) + cd $path + set includedir . + #lappend includedir [::practcl::file_relative $path $proj(TCL_INCLUDES)] + lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(TCL_SRC_DIR) generic]]] + lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(srcdir) generic]]] + foreach include [$PROJECT generate-include-directory] { + set cpath [::practcl::file_relative $path [file normalize $include]] + if {$cpath ni $includedir} { + lappend includedir $cpath + } + } + set INCLUDES "-I[join $includedir " -I"]" + set NAME [string toupper $proj(name)] + set result {} + set products {} + set libraries {} + set thisline {} + ::practcl::cputs result "${NAME}_DEFS = $proj(DEFS)\n" + ::practcl::cputs result "${NAME}_INCLUDES = -I\"[join $includedir "\" -I\""]\"\n" + ::practcl::cputs result "${NAME}_COMPILE = \$(CC) \$(CFLAGS) \$(PKG_CFLAGS) \$(${NAME}_DEFS) \$(${NAME}_INCLUDES) \$(INCLUDES) \$(AM_CPPFLAGS) \$(CPPFLAGS) \$(AM_CFLAGS)" + ::practcl::cputs result "${NAME}_CPPCOMPILE = \$(CXX) \$(CFLAGS) \$(PKG_CFLAGS) \$(${NAME}_DEFS) \$(${NAME}_INCLUDES) \$(INCLUDES) \$(AM_CPPFLAGS) \$(CPPFLAGS) \$(AM_CFLAGS)" + + foreach {ofile info} [$PROJECT compile-products] { + dict set products $ofile $info + if {[dict exists $info library]} { +lappend libraries $ofile +continue + } + if {[dict exists $info depend]} { + ::practcl::cputs result "\n${ofile}: [dict get $info depend]" + } else { + ::practcl::cputs result "\n${ofile}:" + } + set cfile [dict get $info cfile] + if {[file extension $cfile] in {.c++ .cpp}} { + set cmd "\t\$\(${NAME}_CPPCOMPILE\)" + } else { + set cmd "\t\$\(${NAME}_COMPILE\)" + } + if {[dict exists $info extra]} { + append cmd " [dict get $info extra]" + } + append cmd " -c [dict get $info cfile] -o \$@\n\t" + ::practcl::cputs result $cmd + } + + set map {} + lappend map %LIBRARY_NAME% $proj(name) + lappend map %LIBRARY_VERSION% $proj(version) + lappend map %LIBRARY_VERSION_NODOTS% [string map {. {}} $proj(version)] + lappend map %LIBRARY_PREFIX% [$PROJECT define getnull libprefix] + + if {[string is true [$PROJECT define get SHARED_BUILD]]} { + set outfile [$PROJECT define get libfile] + } else { + set outfile [$PROJECT shared_library] + } + $PROJECT define set shared_library $outfile + ::practcl::cputs result " +${NAME}_SHLIB = $outfile +${NAME}_OBJS = [dict keys $products] +" + + #lappend map %OUTFILE% {\[$]@} + lappend map %OUTFILE% $outfile + lappend map %LIBRARY_OBJECTS% "\$(${NAME}_OBJS)" + ::practcl::cputs result "$outfile: \$(${NAME}_OBJS)" + ::practcl::cputs result "\t[string map $map [$PROJECT define get PRACTCL_SHARED_LIB]]" + if {[$PROJECT define get PRACTCL_VC_MANIFEST_EMBED_DLL] ni {: {}}} { + ::practcl::cputs result "\t[string map $map [$PROJECT define get PRACTCL_VC_MANIFEST_EMBED_DLL]]" + } + ::practcl::cputs result {} + if {[string is true [$PROJECT define get SHARED_BUILD]]} { + #set outfile [$PROJECT static_library] + set outfile $proj(name).a + } else { + set outfile [$PROJECT define get libfile] + } + $PROJECT define set static_library $outfile + dict set map %OUTFILE% $outfile + ::practcl::cputs result "$outfile: \$(${NAME}_OBJS)" + ::practcl::cputs result "\t[string map $map [$PROJECT define get PRACTCL_STATIC_LIB]]" + ::practcl::cputs result {} + return $result +} + +### +# Produce a dynamic library +### +proc ::practcl::build::library {outfile PROJECT} { + array set proj [$PROJECT define dump] + set path $proj(builddir) + cd $path + set includedir . + #lappend includedir [::practcl::file_relative $path $proj(TCL_INCLUDES)] + lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(TCL_SRC_DIR) generic]]] + lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(srcdir) generic]]] + if {[$PROJECT define get tk 0]} { + lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(TK_SRC_DIR) generic]]] + lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(TK_SRC_DIR) ttk]]] + lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(TK_SRC_DIR) xlib]]] + lappend includedir [::practcl::file_relative $path [file normalize $proj(TK_BIN_DIR)]] + } + foreach include [$PROJECT generate-include-directory] { + set cpath [::practcl::file_relative $path [file normalize $include]] + if {$cpath ni $includedir} { + lappend includedir $cpath + } + } + ::practcl::build::DEFS $PROJECT $proj(DEFS) name version defs + set NAME [string toupper $name] + set debug [$PROJECT define get debug 0] + set os [$PROJECT define get os] + + set INCLUDES "-I[join $includedir " -I"]" + if {$debug} { + set COMPILE "$proj(CC) $proj(CFLAGS_DEBUG) -ggdb \ +$proj(CFLAGS_WARNING) $INCLUDES $defs" + + if {[info exists proc(CXX)]} { + set COMPILECPP "$proj(CXX) $defs $INCLUDES $proj(CFLAGS_DEBUG) -ggdb \ + $proj(DEFS) $proj(CFLAGS_WARNING)" + } else { + set COMPILECPP $COMPILE + } + } else { + set COMPILE "$proj(CC) $proj(CFLAGS) $defs $INCLUDES " + + if {[info exists proc(CXX)]} { + set COMPILECPP "$proj(CXX) $defs $INCLUDES $proj(CFLAGS) $proj(DEFS)" + } else { + set COMPILECPP $COMPILE + } + } + + set products [compile-sources $PROJECT $COMPILE $COMPILECPP] + + set map {} + lappend map %LIBRARY_NAME% $proj(name) + lappend map %LIBRARY_VERSION% $proj(version) + lappend map %LIBRARY_VERSION_NODOTS% [string map {. {}} $proj(version)] + lappend map %OUTFILE% $outfile + lappend map %LIBRARY_OBJECTS% $products + lappend map {${CFLAGS}} "$proj(CFLAGS_DEFAULT) $proj(CFLAGS_WARNING)" + + if {[string is true [$PROJECT define get SHARED_BUILD 1]]} { + set cmd [$PROJECT define get PRACTCL_SHARED_LIB] + append cmd " [$PROJECT define get PRACTCL_LIBS]" + set cmd [string map $map $cmd] + puts $cmd + exec {*}$cmd >&@ stdout + if {[$PROJECT define get PRACTCL_VC_MANIFEST_EMBED_DLL] ni {: {}}} { + set cmd [string map $map [$PROJECT define get PRACTCL_VC_MANIFEST_EMBED_DLL]] + puts $cmd + exec {*}$cmd >&@ stdout + } + } else { + set cmd [string map $map [$PROJECT define get PRACTCL_STATIC_LIB]] + puts $cmd + exec {*}$cmd >&@ stdout + } +} + +### +# Produce a static executable +### +proc ::practcl::build::static-tclsh {outfile PROJECT} { + puts " BUILDING STATIC TCLSH " + set TCLOBJ [$PROJECT project TCLCORE] + set TKOBJ [$PROJECT project TKCORE] + set ODIEOBJ [$PROJECT project odie] + + set PKG_OBJS {} + foreach item [$PROJECT link list package] { + if {[string is true [$item define get static]]} { + lappend PKG_OBJS $item + } + } + array set TCL [$TCLOBJ config.sh] + array set TK [$TKOBJ config.sh] + set path [file dirname $outfile] + cd $path + ### + # For a static Tcl shell, we need to build all local sources + # with the same DEFS flags as the tcl core was compiled with. + # The DEFS produced by a TEA extension aren't intended to operate + # with the internals of a staticly linked Tcl + ### + ::practcl::build::DEFS $PROJECT $TCL(defs) name version defs + set debug [$PROJECT define get debug 0] + set NAME [string toupper $name] + set result {} + set libraries {} + set thisline {} + set OBJECTS {} + set EXTERN_OBJS {} + foreach obj $PKG_OBJS { + $obj compile + set config($obj) [$obj config.sh] + } + set os [$PROJECT define get os] + set TCLSRCDIR [$TCLOBJ define get srcroot] + set TKSRCDIR [$TKOBJ define get srcroot] + + set includedir . + foreach include [$TCLOBJ generate-include-directory] { + set cpath [::practcl::file_relative $path [file normalize $include]] + if {$cpath ni $includedir} { + lappend includedir $cpath + } + } + lappend includedir [::practcl::file_relative $path [file normalize ../tcl/compat/zlib]] + foreach include [$PROJECT generate-include-directory] { + set cpath [::practcl::file_relative $path [file normalize $include]] + if {$cpath ni $includedir} { + lappend includedir $cpath + } + } + + set INCLUDES "-I[join $includedir " -I"]" + if {$debug} { + set COMPILE "$TCL(cc) $TCL(shlib_cflags) $TCL(cflags_debug) -ggdb \ +$TCL(cflags_warning) $TCL(extra_cflags) $INCLUDES" + } else { + set COMPILE "$TCL(cc) $TCL(shlib_cflags) $TCL(cflags_optimize) \ +$TCL(cflags_warning) $TCL(extra_cflags) $INCLUDES" + } + append COMPILE " " $defs + lappend OBJECTS {*}[compile-sources $PROJECT $COMPILE $COMPILE] + + if {[${PROJECT} define get platform] eq "windows"} { + set RSOBJ [file join $path build tclkit.res.o] + set RCSRC [${PROJECT} define get kit_resource_file] + if {$RCSRC eq {} || ![file exists $RCSRC]} { + set RCSRC [file join $TKSRCDIR win rc wish.rc] + } + set cmd [list windres -o $RSOBJ -DSTATIC_BUILD] + set TCLSRC [file normalize $TCLSRCDIR] + set TKSRC [file normalize $TKSRCDIR] + + lappend cmd --include [::practcl::file_relative $path [file join $TCLSRC generic]] \ + --include [::practcl::file_relative $path [file join $TKSRC generic]] \ + --include [::practcl::file_relative $path [file join $TKSRC win]] \ + --include [::practcl::file_relative $path [file join $TKSRC win rc]] + foreach item [${PROJECT} define get resource_include] { + lappend cmd --include [::practcl::file_relative $path [file normalize $item]] + } + lappend cmd $RCSRC + doexec {*}$cmd + + lappend OBJECTS $RSOBJ + set LDFLAGS_CONSOLE {-mconsole -pipe -static-libgcc} + set LDFLAGS_WINDOW {-mwindows -pipe -static-libgcc} + } else { + set LDFLAGS_CONSOLE {} + set LDFLAGS_WINDOW {} + } + puts "***" + if {$debug} { + set cmd "$TCL(cc) $TCL(shlib_cflags) $TCL(cflags_debug) \ +$TCL(cflags_warning) $TCL(extra_cflags) $INCLUDES" + } else { + set cmd "$TCL(cc) $TCL(shlib_cflags) $TCL(cflags_optimize) \ +$TCL(cflags_warning) $TCL(extra_cflags) $INCLUDES" + } + append cmd " $OBJECTS" + append cmd " $EXTERN_OBJS " + # On OSX it is impossibly to generate a completely static + # executable + if {[$PROJECT define get TEACUP_OS] ne "macosx"} { + append cmd " -static " + } + parray TCL + if {$debug} { + if {$os eq "windows"} { + append cmd " -L${TCL(src_dir)}/win -ltcl86g" + append cmd " -L${TK(src_dir)}/win -ltk86g" + } else { + append cmd " -L${TCL(src_dir)}/unix -ltcl86g" + append cmd " -L${TK(src_dir)}/unix -ltk86g" + } + } else { + append cmd " $TCL(build_lib_spec) $TK(build_lib_spec)" + } + foreach obj $PKG_OBJS { + append cmd " [$obj linker-products $config($obj)]" + } + append cmd " $TCL(libs) $TK(libs)" + foreach obj $PKG_OBJS { + append cmd " [$obj linker-external $config($obj)]" + } + if {$debug} { + if {$os eq "windows"} { + append cmd " -L${TCL(src_dir)}/win ${TCL(stub_lib_flag)}" + append cmd " -L${TK(src_dir)}/win ${TK(stub_lib_flag)}" + } else { + append cmd " -L${TCL(src_dir)}/unix ${TCL(stub_lib_flag)}" + append cmd " -L${TK(src_dir)}/unix ${TK(stub_lib_flag)}" + } + } else { + append cmd " $TCL(build_stub_lib_spec)" + append cmd " $TK(build_stub_lib_spec)" + } + append cmd " -o $outfile $LDFLAGS_CONSOLE" + puts "LINK: $cmd" + exec {*}$cmd >&@ stdout +} + +::oo::class create ::practcl::target_obj { + superclass ::practcl::metaclass + + constructor {name info} { + my variable define triggered domake + set triggered 0 + set domake 0 + set define(name) $name + set data [uplevel 2 [list subst $info]] + array set define $data + my select + my initialize + } + + method do {} { + my variable domake + return $domake + } + + method check {} { + my variable needs_make domake + if {$domake} { + return 1 + } + if {[info exists needs_make]} { + return $needs_make + } + set needs_make 0 + foreach item [my define get depends] { + if {![dict exists $::make_objects $item]} continue + set depobj [dict get $::make_objects $item] + if {$depobj eq [self]} { + puts "WARNING [self] depends on itself" + continue + } + if {[$depobj check]} { + set needs_make 1 + } + } + if {!$needs_make} { + set filename [my define get filename] + if {$filename ne {} && ![file exists $filename]} { + set needs_make 1 + } + } + return $needs_make + } + + method triggers {} { + my variable triggered domake define + if {$triggered} { + return $domake + } + set triggered 1 + foreach item [my define get depends] { + puts [list $item [dict exists $::make_objects $item]] + if {![dict exists $::make_objects $item]} continue + set depobj [dict get $::make_objects $item] + if {$depobj eq [self]} { + puts "WARNING [self] triggers itself" + continue + } else { + set r [$depobj check] + puts [list $depobj check $r] + if {$r} { + puts [list $depobj TRIGGER] + $depobj triggers + } + } + } + if {[info exists ::make($define(name))] && $::make($define(name))} { + return + } + set ::make($define(name)) 1 + ::practcl::trigger {*}[my define get triggers] + } +} + + +### +# Define the metaclass +### +::oo::class create ::practcl::object { + superclass ::practcl::metaclass + + constructor {parent args} { + my variable links define + set organs [$parent child organs] + my graft {*}$organs + array set define $organs + array set define [$parent child define] + array set links {} + if {[llength $args]==1 && [file exists [lindex $args 0]]} { + my InitializeSourceFile [lindex $args 0] + } elseif {[llength $args] == 1} { + set data [uplevel 1 [list subst [lindex $args 0]]] + array set define $data + my select + my initialize + } else { + array set define [uplevel 1 [list subst $args]] + my select + my initialize + } + } + + + method include_dir args { + my define add include_dir {*}$args + } + + method include_directory args { + my define add include_dir {*}$args + } + + method Collate_Source CWD {} + + + method child {method} { + return {} + } + + method InitializeSourceFile filename { + my define set filename $filename + set class {} + switch [file extension $filename] { + .tcl { + set class ::practcl::dynamic + } + .h { + set class ::practcl::cheader + } + .c { + set class ::practcl::csource + } + .ini { + switch [file tail $filename] { + module.ini { + set class ::practcl::module + } + library.ini { + set class ::practcl::subproject + } + } + } + .so - + .dll - + .dylib - + .a { + set class ::practcl::clibrary + } + } + if {$class ne {}} { + oo::objdefine [self] class $class + my initialize + } + } + + method add args { + my variable links + set object [::practcl::object new [self] {*}$args] + foreach linktype [$object linktype] { + lappend links($linktype) $object + } + return $object + } + + method go {} { + debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] + my variable links + foreach {linktype objs} [array get links] { + foreach obj $objs { + $obj go + } + } + debug [list /[self] [self method] [self class]] + } + + method code {section body} { + my variable code + ::practcl::cputs code($section) $body + } + + method Ofile filename { + set lpath [my define get localpath] + if {$lpath eq {}} { + set lpath [my define get name] + } + return ${lpath}_[file rootname [file tail $filename]].o + } + + method compile-products {} { + set filename [my define get filename] + set result {} + if {$filename ne {}} { + if {[my define exists ofile]} { + set ofile [my define get ofile] + } else { + set ofile [my Ofile $filename] + my define set ofile $ofile + } + lappend result $ofile [list cfile $filename extra [my define get extra] external [string is true -strict [my define get external]] object [self]] + } + foreach item [my link list subordinate] { + lappend result {*}[$item compile-products] + } + return $result + } + + method generate-include-directory {} { + debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] + set result [my define get include_dir] + foreach obj [my link list product] { + foreach path [$obj generate-include-directory] { + lappend result $path + } + } + return $result + } + + method generate-debug {{spaces {}}} { + set result {} + ::practcl::cputs result "$spaces[list [self] [list class [info object class [self]] filename [my define get filename]] links [my link list]]" + foreach item [my link list subordinate] { + practcl::cputs result [$item generate-debug "$spaces "] + } + return $result + } + + # Empty template methods + method generate-cheader {} { + debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] + my variable code cfunct cstruct methods tcltype tclprocs + set result {} + if {[info exists code(header)]} { + ::practcl::cputs result $code(header) + } + foreach obj [my link list product] { + # Exclude products that will generate their own C files + if {[$obj define get output_c] ne {}} continue + ::practcl::cputs result "/* BEGIN [$obj define get filename] generate-cheader */" + ::practcl::cputs result [$obj generate-cheader] + ::practcl::cputs result "/* END [$obj define get filename] generate-cheader */" + } + debug [list cfunct [info exists cfunct]] + if {[info exists cfunct]} { + foreach {funcname info} $cfunct { + if {[dict get $info public]} continue + ::practcl::cputs result "[dict get $info header]\;" + } + } + debug [list tclprocs [info exists tclprocs]] + if {[info exists tclprocs]} { + foreach {name info} $tclprocs { + if {[dict exists $info header]} { + ::practcl::cputs result "[dict get $info header]\;" + } + } + } + debug [list methods [info exists methods] [my define get cclass]] + + if {[info exists methods]} { + set thisclass [my define get cclass] + foreach {name info} $methods { + if {[dict exists $info header]} { + ::practcl::cputs result "[dict get $info header]\;" + } + } + # Add the initializer wrapper for the class + ::practcl::cputs result "static int ${thisclass}_OO_Init(Tcl_Interp *interp)\;" + } + return $result + } + + method generate-public-define {} { + debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] + my variable code + set result {} + if {[info exists code(public-define)]} { + ::practcl::cputs result $code(public-define) + } + set result [::practcl::_tagblock $result c [my define get filename]] + foreach mod [my link list product] { + ::practcl::cputs result [$mod generate-public-define] + } + return $result + } + + method generate-public-macro {} { + debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] + my variable code + set result {} + if {[info exists code(public-macro)]} { + ::practcl::cputs result $code(public-macro) + } + set result [::practcl::_tagblock $result c [my define get filename]] + foreach mod [my link list product] { + ::practcl::cputs result [$mod generate-public-macro] + } + return $result + } + + method generate-public-typedef {} { + debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] + my variable code cstruct + set result {} + if {[info exists code(public-typedef)]} { + ::practcl::cputs result $code(public-typedef) + } + if {[info exists cstruct]} { + # Add defintion for native c data structures + foreach {name info} $cstruct { + ::practcl::cputs result "typedef struct $name ${name}\;" + if {[dict exists $info aliases]} { + foreach n [dict get $info aliases] { + ::practcl::cputs result "typedef struct $name ${n}\;" + } + } + } + } + set result [::practcl::_tagblock $result c [my define get filename]] + foreach mod [my link list product] { + ::practcl::cputs result [$mod generate-public-typedef] + } + return $result + } + + method generate-public-structure {} { + debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] + my variable code cstruct + set result {} + if {[info exists code(public-structure)]} { + ::practcl::cputs result $code(public-structure) + } + if {[info exists cstruct]} { + foreach {name info} $cstruct { + if {[dict exists $info comment]} { + ::practcl::cputs result [dict get $info comment] + } + ::practcl::cputs result "struct $name \{[dict get $info body]\}\;" + } + } + set result [::practcl::_tagblock $result c [my define get filename]] + foreach mod [my link list product] { + ::practcl::cputs result [$mod generate-public-structure] + } + return $result + } + method generate-public-headers {} { + debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] + my variable code tcltype + set result {} + if {[info exists code(public-header)]} { + ::practcl::cputs result $code(public-header) + } + if {[info exists tcltype]} { + foreach {type info} $tcltype { + if {![dict exists $info cname]} { + set cname [string tolower ${type}]_tclobjtype + dict set tcltype $type cname $cname + } else { + set cname [dict get $info cname] + } + ::practcl::cputs result "extern const Tcl_ObjType $cname\;" + } + } + if {[info exists code(public)]} { + ::practcl::cputs result $code(public) + } + set result [::practcl::_tagblock $result c [my define get filename]] + foreach mod [my link list product] { + ::practcl::cputs result [$mod generate-public-headers] + } + return $result + } + + method generate-stub-function {} { + debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] + my variable code cfunct tcltype + set result {} + foreach mod [my link list product] { + foreach {funct def} [$mod generate-stub-function] { + dict set result $funct $def + } + } + if {[info exists cfunct]} { + foreach {funcname info} $cfunct { + if {![dict get $info export]} continue + dict set result $funcname [dict get $info header] + } + } + return $result + } + + method generate-public-function {} { + debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] + my variable code cfunct tcltype + set result {} + + if {[my define get initfunc] ne {}} { + ::practcl::cputs result "int [my define get initfunc](Tcl_Interp *interp);" + } + if {[info exists cfunct]} { + foreach {funcname info} $cfunct { + if {![dict get $info public]} continue + ::practcl::cputs result "[dict get $info header]\;" + } + } + set result [::practcl::_tagblock $result c [my define get filename]] + foreach mod [my link list product] { + ::practcl::cputs result [$mod generate-public-function] + } + return $result + } + + method generate-public-includes {} { + debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] + set includes {} + foreach item [my define get public-include] { + if {$item ni $includes} { + lappend includes $item + } + } + foreach mod [my link list product] { + foreach item [$mod generate-public-includes] { + if {$item ni $includes} { + lappend includes $item + } + } + } + return $includes + } + method generate-public-verbatim {} { + debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] + set includes {} + foreach item [my define get public-verbatim] { + if {$item ni $includes} { + lappend includes $item + } + } + foreach mod [my link list subordinate] { + foreach item [$mod generate-public-verbatim] { + if {$item ni $includes} { + lappend includes $item + } + } + } + return $includes + } + ### + # This methods generates the contents of an amalgamated .h file + # which describes the public API of this module + ### + method generate-h {} { + debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] + set result {} + set includes [my generate-public-includes] + foreach inc $includes { + if {[string index $inc 0] ni {< \"}} { + ::practcl::cputs result "#include \"$inc\"" + } else { + ::practcl::cputs result "#include $inc" + } + } + foreach file [my generate-public-verbatim] { + ::practcl::cputs result "/* BEGIN $file */" + ::practcl::cputs result [::practcl::cat $file] + ::practcl::cputs result "/* END $file */" + } + foreach method { + generate-public-define + generate-public-macro + generate-public-typedef + generate-public-structure + generate-public-headers + generate-public-function + } { + ::practcl::cputs result "/* BEGIN SECTION $method */" + ::practcl::cputs result [my $method] + ::practcl::cputs result "/* END SECTION $method */" + } + return $result + } + + ### + # This methods generates the contents of an amalgamated .c file + # which implements the loader for a batch of tools + ### + method generate-c {} { + debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] + set result { +/* This file was generated by practcl */ + } + set includes {} + lappend headers + if {[my define get tk 0]} { + lappend headers + } + lappend headers {*}[my define get include] + if {[my define get output_h] ne {}} { + lappend headers "\"[my define get output_h]\"" + } + foreach mod [my link list product] { + # Signal modules to formulate final implementation + $mod go + } + foreach mod [my link list dynamic] { + foreach inc [$mod define get include] { + if {$inc ni $headers} { + lappend headers $inc + } + } + } + foreach inc $headers { + if {[string index $inc 0] ni {< \"}} { + ::practcl::cputs result "#include \"$inc\"" + } else { + ::practcl::cputs result "#include $inc" + } + } + foreach {method} { + generate-cheader + generate-cstruct + generate-constant + generate-cfunct + generate-cmethod + } { + ::practcl::cputs result "/* BEGIN $method [my define get filename] */" + ::practcl::cputs result [my $method] + ::practcl::cputs result "/* END $method [my define get filename] */" + } + debug [list /[self] [self method] [self class] -- [my define get filename] [info object class [self]]] + return $result + } + + + method generate-loader {} { + debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] + set result {} + if {[my define get initfunc] eq {}} return + ::practcl::cputs result " +extern int DLLEXPORT [my define get initfunc]( Tcl_Interp *interp ) \{" + ::practcl::cputs result { + /* Initialise the stubs tables. */ + #ifdef USE_TCL_STUBS + if (Tcl_InitStubs(interp, "8.6", 0)==NULL) return TCL_ERROR; + if (TclOOInitializeStubs(interp, "1.0") == NULL) return TCL_ERROR; +} + if {[my define get tk 0]} { + ::practcl::cputs result { if (Tk_InitStubs(interp, "8.6", 0)==NULL) return TCL_ERROR;} + } + ::practcl::cputs result { #endif} + set TCLINIT [my generate-tcl] + ::practcl::cputs result " if(Tcl_Eval(interp,[::practcl::tcl_to_c $TCLINIT])) return TCL_ERROR ;" + foreach item [my link list product] { + if {[$item define get output_c] ne {}} { + ::practcl::cputs result [$item generate-cinit-external] + } else { + ::practcl::cputs result [$item generate-cinit] + } + } + if {[my define exists pkg_name]} { + ::practcl::cputs result " if (Tcl_PkgProvide(interp, \"[my define get pkg_name [my define get name]]\" , \"[my define get pkg_vers [my define get version]]\" )) return TCL_ERROR\;" + } + ::practcl::cputs result " return TCL_OK\;\n\}\n" + return $result + } + + ### + # This methods generates any Tcl script file + # which is required to pre-initialize the C library + ### + method generate-tcl {} { + debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] + set result {} + my variable code + if {[info exists code(tcl)]} { + ::practcl::cputs result $code(tcl) + } + set result [::practcl::_tagblock $result tcl [my define get filename]] + foreach mod [my link list product] { + ::practcl::cputs result [$mod generate-tcl] + } + return $result + } + + method static-packages {} { + set result [my define get static_packages] + set statpkg [my define get static_pkg] + set initfunc [my define get initfunc] + if {$initfunc ne {}} { + set pkg_name [my define get pkg_name] + if {$pkg_name ne {}} { + dict set result $pkg_name initfunc $initfunc + dict set result $pkg_name version [my define get version [my define get pkg_vers]] + dict set result $pkg_name autoload [my define get autoload 0] + } + } + foreach item [my link list subordinate] { + foreach {pkg info} [$item static-packages] { + dict set result $pkg $info + } + } + return $result + } + + method target {method args} { + switch $method { + is_unix { return [expr {$::tcl_platform(platform) eq "unix"}] } + } + } + +} + +::oo::class create ::practcl::product { + superclass ::practcl::object + + method linktype {} { + return {subordinate product} + } + + method include header { + my define add include $header + } + + method cstructure {name definition {argdat {}}} { + my variable cstruct + dict set cstruct $name body $definition + foreach {f v} $argdat { + dict set cstruct $name $f $v + } + } + + method generate-cinit {} { + debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] + my variable code + set result {} + if {[info exists code(cinit)]} { + ::practcl::cputs result $code(cinit) + } + if {[my define get initfunc] ne {}} { + ::practcl::cputs result " if([my define get initfunc](interp)!=TCL_OK) return TCL_ERROR\;" + } + set result [::practcl::_tagblock $result c [my define get filename]] + foreach obj [my link list product] { + ::practcl::cputs result [$obj generate-cinit] + } + return $result + } +} + +### +# Dynamic blocks do not generate their own .c files, +# instead the contribute to the amalgamation +# of the main library file +### +::oo::class create ::practcl::dynamic { + superclass ::practcl::product + + # Retrieve any additional source files required + + method compile-products {} { + set filename [my define get output_c] + set result {} + if {$filename ne {}} { + if {[my define exists ofile]} { + set ofile [my define get ofile] + } else { + set ofile [my Ofile $filename] + my define set ofile $ofile + } + lappend result $ofile [list cfile $filename extra [my define get extra] external [string is true -strict [my define get external]]] + } else { + set filename [my define get cfile] + if {$filename ne {}} { + if {[my define exists ofile]} { + set ofile [my define get ofile] + } else { + set ofile [my Ofile $filename] + my define set ofile $ofile + } + lappend result $ofile [list cfile $filename extra [my define get extra] external [string is true -strict [my define get external]]] + } + } + foreach item [my link list subordinate] { + lappend result {*}[$item compile-products] + } + return $result + } + + method implement path { + my go + my Collate_Source $path + if {[my define get output_c] eq {}} return + set filename [file join $path [my define get output_c]] + my define set cfile $filename + set fout [open $filename w] + puts $fout [my generate-c] + puts $fout "extern int DLLEXPORT [my define get initfunc]( Tcl_Interp *interp ) \x7B" + puts $fout [my generate-cinit] + if {[my define get pkg_name] ne {}} { + puts $fout " Tcl_PkgProvide(interp, \"[my define get pkg_name]\", \"[my define get pkg_vers]\");" + } + puts $fout " return TCL_OK\;" + puts $fout "\x7D" + close $fout + } + + method initialize {} { + set filename [my define get filename] + if {$filename eq {}} { + return + } + if {[my define get name] eq {}} { + my define set name [file tail [file rootname $filename]] + } + if {[my define get localpath] eq {}} { + my define set localpath [my define get localpath]_[my define get name] + } + ::source $filename + } + + method linktype {} { + return {subordinate product dynamic} + } + + ### + # Populate const static data structures + ### + method generate-cstruct {} { + debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] + my variable code cstruct methods tcltype + set result {} + if {[info exists code(struct)]} { + ::practcl::cputs result $code(struct) + } + foreach obj [my link list dynamic] { + # Exclude products that will generate their own C files + if {[$obj define get output_c] ne {}} continue + ::practcl::cputs result [$obj generate-cstruct] + } + return $result + } + + method generate-constant {} { + debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] + set result {} + my variable code cstruct methods tcltype + if {[info exists code(constant)]} { + ::practcl::cputs result "/* [my define get filename] CONSTANT */" + ::practcl::cputs result $code(constant) + } + if {[info exists cstruct]} { + foreach {name info} $cstruct { + set map {} + lappend map @NAME@ $name + lappend map @MACRO@ GET[string toupper $name] + + if {[dict exists $info deleteproc]} { + lappend map @DELETEPROC@ [dict get $info deleteproc] + } else { + lappend map @DELETEPROC@ NULL + } + if {[dict exists $info cloneproc]} { + lappend map @CLONEPROC@ [dict get $info cloneproc] + } else { + lappend map @CLONEPROC@ NULL + } + ::practcl::cputs result [string map $map { +const static Tcl_ObjectMetadataType @NAME@DataType = { + TCL_OO_METADATA_VERSION_CURRENT, + "@NAME@", + @DELETEPROC@, + @CLONEPROC@ +}; +#define @MACRO@(OBJCONTEXT) (@NAME@ *) Tcl_ObjectGetMetadata(OBJCONTEXT,&@NAME@DataType) +}] + } + } + if {[info exists tcltype]} { + foreach {type info} $tcltype { + dict with info {} + ::practcl::cputs result "const Tcl_ObjType $cname = \{\n .freeIntRepProc = &${freeproc},\n .dupIntRepProc = &${dupproc},\n .updateStringProc = &${updatestringproc},\n .setFromAnyProc = &${setfromanyproc}\n\}\;" + } + } + + if {[info exists methods]} { + set mtypes {} + foreach {name info} $methods { + set callproc [dict get $info callproc] + set methodtype [dict get $info methodtype] + if {$methodtype in $mtypes} continue + lappend mtypes $methodtype + ### + # Build the data struct for this method + ### + ::practcl::cputs result "const static Tcl_MethodType $methodtype = \{" + ::practcl::cputs result " .version = TCL_OO_METADATA_VERSION_CURRENT,\n .name = \"$name\",\n .callProc = $callproc," + if {[dict exists $info deleteproc]} { + set deleteproc [dict get $info deleteproc] + } else { + set deleteproc NULL + } + if {$deleteproc ni { {} NULL }} { + ::practcl::cputs result " .deleteProc = $deleteproc," + } else { + ::practcl::cputs result " .deleteProc = NULL," + } + if {[dict exists $info cloneproc]} { + set cloneproc [dict get $info cloneproc] + } else { + set cloneproc NULL + } + if {$cloneproc ni { {} NULL }} { + ::practcl::cputs result " .cloneProc = $cloneproc\n\}\;" + } else { + ::practcl::cputs result " .cloneProc = NULL\n\}\;" + } + dict set methods $name methodtype $methodtype + } + } + foreach obj [my link list dynamic] { + # Exclude products that will generate their own C files + if {[$obj define get output_c] ne {}} continue + ::practcl::cputs result [$obj generate-constant] + } + return $result + } + + ### + # Generate code that provides subroutines called by + # Tcl API methods + ### + method generate-cfunct {} { + debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] + my variable code cfunct + set result {} + if {[info exists code(funct)]} { + ::practcl::cputs result $code(funct) + } + if {[info exists cfunct]} { + foreach {funcname info} $cfunct { + ::practcl::cputs result "[dict get $info header]\{[dict get $info body]\}\;" + } + } + foreach obj [my link list dynamic] { + # Exclude products that will generate their own C files + if {[$obj define get output_c] ne {}} { + continue + } + ::practcl::cputs result [$obj generate-cfunct] + } + return $result + } + + ### + # Generate code that provides implements Tcl API + # calls + ### + method generate-cmethod {} { + debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] + my variable code methods tclprocs + set result {} + if {[info exists code(method)]} { + ::practcl::cputs result $code(method) + } + + if {[info exists tclprocs]} { + foreach {name info} $tclprocs { + if {![dict exists $info body]} continue + set callproc [dict get $info callproc] + set header [dict get $info header] + set body [dict get $info body] + ::practcl::cputs result "${header} \{${body}\}" + } + } + + + if {[info exists methods]} { + set thisclass [my define get cclass] + foreach {name info} $methods { + if {![dict exists $info body]} continue + set callproc [dict get $info callproc] + set header [dict get $info header] + set body [dict get $info body] + ::practcl::cputs result "${header} \{${body}\}" + } + # Build the OO_Init function + ::practcl::cputs result "static int ${thisclass}_OO_Init(Tcl_Interp *interp) \{" + ::practcl::cputs result [string map [list @CCLASS@ $thisclass @TCLCLASS@ [my define get class]] { + /* + ** Build the "@TCLCLASS@" class + */ + Tcl_Obj* nameObj; /* Name of a class or method being looked up */ + Tcl_Object curClassObject; /* Tcl_Object representing the current class */ + Tcl_Class curClass; /* Tcl_Class representing the current class */ + + /* + * Find the "@TCLCLASS@" class, and attach an 'init' method to it. + */ + + nameObj = Tcl_NewStringObj("@TCLCLASS@", -1); + Tcl_IncrRefCount(nameObj); + if ((curClassObject = Tcl_GetObjectFromObj(interp, nameObj)) == NULL) { + Tcl_DecrRefCount(nameObj); + return TCL_ERROR; + } + Tcl_DecrRefCount(nameObj); + curClass = Tcl_GetObjectAsClass(curClassObject); +}] + if {[dict exists $methods constructor]} { + set mtype [dict get $methods constructor methodtype] + ::practcl::cputs result [string map [list @MTYPE@ $mtype] { + /* Attach the constructor to the class */ + Tcl_ClassSetConstructor(interp, curClass, Tcl_NewMethod(interp, curClass, NULL, 1, &@MTYPE@, NULL)); + }] + } + foreach {name info} $methods { + dict with info {} + if {$name in {constructor destructor}} continue + ::practcl::cputs result [string map [list @NAME@ $name @MTYPE@ $methodtype] { + nameObj=Tcl_NewStringObj("@NAME@",-1); + Tcl_NewMethod(interp, curClass, nameObj, 1, &@MTYPE@, (ClientData) NULL); + Tcl_DecrRefCount(nameObj); +}] + if {[dict exists $info aliases]} { + foreach alias [dict get $info aliases] { + if {[dict exists $methods $alias]} continue + ::practcl::cputs result [string map [list @NAME@ $alias @MTYPE@ $methodtype] { + nameObj=Tcl_NewStringObj("@NAME@",-1); + Tcl_NewMethod(interp, curClass, nameObj, 1, &@MTYPE@, (ClientData) NULL); + Tcl_DecrRefCount(nameObj); +}] + } + } + } + ::practcl::cputs result " return TCL_OK\;\n\}\n" + } + foreach obj [my link list dynamic] { + # Exclude products that will generate their own C files + if {[$obj define get output_c] ne {}} continue + ::practcl::cputs result [$obj generate-cmethod] + } + return $result + } + + method generate-cinit-external {} { + if {[my define get initfunc] eq {}} { + return "/* [my define get filename] declared not initfunc */" + } + return " if([my define get initfunc](interp)) return TCL_ERROR\;" + } + + ### + # Generate code that runs when the package/module is + # initialized into the interpreter + ### + method generate-cinit {} { + debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] + set result {} + my variable code methods tclprocs + if {[info exists code(nspace)]} { + ::practcl::cputs result " \{\n Tcl_Namespace *modPtr;" + foreach nspace $code(nspace) { + ::practcl::cputs result [string map [list @NSPACE@ $nspace] { + modPtr=Tcl_FindNamespace(interp,"@NSPACE@",NULL,TCL_NAMESPACE_ONLY); + if(!modPtr) { + modPtr = Tcl_CreateNamespace(interp, "@NSPACE@", NULL, NULL); + } +}] + } + ::practcl::cputs result " \}" + } + if {[info exists code(tclinit)]} { + ::practcl::cputs result $code(tclinit) + } + if {[info exists code(cinit)]} { + ::practcl::cputs result $code(cinit) + } + if {[info exists code(initfuncts)]} { + foreach func $code(initfuncts) { + ::practcl::cputs result " if (${func}(interp) != TCL_OK) return TCL_ERROR\;" + } + } + if {[info exists tclprocs]} { + foreach {name info} $tclprocs { + set map [list @NAME@ $name @CALLPROC@ [dict get $info callproc]] + ::practcl::cputs result [string map $map { Tcl_CreateObjCommand(interp,"@NAME@",(Tcl_ObjCmdProc *)@CALLPROC@,NULL,NULL);}] + if {[dict exists $info aliases]} { + foreach alias [dict get $info aliases] { + set map [list @NAME@ $alias @CALLPROC@ [dict get $info callproc]] + ::practcl::cputs result [string map $map { Tcl_CreateObjCommand(interp,"@NAME@",(Tcl_ObjCmdProc *)@CALLPROC@,NULL,NULL);}] + } + } + } + } + + if {[info exists code(nspace)]} { + ::practcl::cputs result " \{\n Tcl_Namespace *modPtr;" + foreach nspace $code(nspace) { + ::practcl::cputs result [string map [list @NSPACE@ $nspace] { + modPtr=Tcl_FindNamespace(interp,"@NSPACE@",NULL,TCL_NAMESPACE_ONLY); + Tcl_CreateEnsemble(interp, modPtr->fullName, modPtr, TCL_ENSEMBLE_PREFIX); + Tcl_Export(interp, modPtr, "[a-z]*", 1); +}] + } + ::practcl::cputs result " \}" + } + set result [::practcl::_tagblock $result c [my define get filename]] + foreach obj [my link list product] { + # Exclude products that will generate their own C files + if {[$obj define get output_c] ne {}} { + ::practcl::cputs result [$obj generate-cinit-external] + } else { + ::practcl::cputs result [$obj generate-cinit] + } + } + return $result + } + + method c_header body { + my variable code + ::practcl::cputs code(header) $body + } + + method c_code body { + my variable code + ::practcl::cputs code(funct) $body + } + method c_function {header body} { + my variable code cfunct + foreach regexp { + {(.*) ([a-zA-Z_][a-zA-Z0-9_]*) *\((.*)\)} + {(.*) (\x2a[a-zA-Z_][a-zA-Z0-9_]*) *\((.*)\)} + } { + if {[regexp $regexp $header all keywords funcname arglist]} { + dict set cfunct $funcname header $header + dict set cfunct $funcname body $body + dict set cfunct $funcname keywords $keywords + dict set cfunct $funcname arglist $arglist + dict set cfunct $funcname public [expr {"static" ni $keywords}] + dict set cfunct $funcname export [expr {"STUB_EXPORT" in $keywords}] + + return + } + } + ::practcl::cputs code(header) "$header\;" + # Could not parse that block as a function + # append it verbatim to our c_implementation + ::practcl::cputs code(funct) "$header [list $body]" + } + + + method cmethod {name body {arginfo {}}} { + my variable methods code + foreach {f v} $arginfo { + dict set methods $name $f $v + } + dict set methods $name body "Tcl_Object thisObject = Tcl_ObjectContextObject(objectContext); /* The current connection object */ +$body" + } + + method c_tclproc_nspace nspace { + my variable code + if {![info exists code(nspace)]} { + set code(nspace) {} + } + if {$nspace ni $code(nspace)} { + lappend code(nspace) $nspace + } + } + + method c_tclproc_raw {name body {arginfo {}}} { + my variable tclprocs code + + foreach {f v} $arginfo { + dict set tclprocs $name $f $v + } + dict set tclprocs $name body $body + } + + method go {} { + debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] + next + my variable methods code cstruct tclprocs + if {[info exists methods]} { + debug [self] methods [my define get cclass] + set thisclass [my define get cclass] + foreach {name info} $methods { + # Provide a callproc + if {![dict exists $info callproc]} { + set callproc [string map {____ _ ___ _ __ _} [string map {{ } _ : _} OOMethod_${thisclass}_${name}]] + dict set methods $name callproc $callproc + } else { + set callproc [dict get $info callproc] + } + if {[dict exists $info body] && ![dict exists $info header]} { + dict set methods $name header "static int ${callproc}(ClientData clientData, Tcl_Interp *interp, Tcl_ObjectContext objectContext ,int objc ,Tcl_Obj *const *objv)" + } + if {![dict exists $info methodtype]} { + set methodtype [string map {{ } _ : _} MethodType_${thisclass}_${name}] + dict set methods $name methodtype $methodtype + } + } + if {![info exists code(initfuncts)] || "${thisclass}_OO_Init" ni $code(initfuncts)} { + lappend code(initfuncts) "${thisclass}_OO_Init" + } + } + set thisnspace [my define get nspace] + + if {[info exists tclprocs]} { + debug [self] tclprocs [dict keys $tclprocs] + foreach {name info} $tclprocs { + if {![dict exists $info callproc]} { + set callproc [string map {____ _ ___ _ __ _} [string map {{ } _ : _} Tclcmd_${thisnspace}_${name}]] + dict set tclprocs $name callproc $callproc + } else { + set callproc [dict get $info callproc] + } + if {[dict exists $info body] && ![dict exists $info header]} { + dict set tclprocs $name header "static int ${callproc}(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv\[\])" + } + } + } + debug [list /[self] [self method] [self class]] + } + + # Once an object marks itself as some + # flavor of dynamic, stop trying to morph + # it into something else + method select {} {} + + + method tcltype {name argdat} { + my variable tcltype + foreach {f v} $argdat { + dict set tcltype $name $f $v + } + if {![dict exists tcltype $name cname]} { + dict set tcltype $name cname [string tolower $name]_tclobjtype + } + lappend map @NAME@ $name + set info [dict get $tcltype $name] + foreach {f v} $info { + lappend map @[string toupper $f]@ $v + } + foreach {func fpat template} { + freeproc {@Name@Obj_freeIntRepProc} {void @FNAME@(Tcl_Obj *objPtr)} + dupproc {@Name@Obj_dupIntRepProc} {void @FNAME@(Tcl_Obj *srcPtr,Tcl_Obj *dupPtr)} + updatestringproc {@Name@Obj_updateStringRepProc} {void @FNAME@(Tcl_Obj *objPtr)} + setfromanyproc {@Name@Obj_setFromAnyProc} {int @FNAME@(Tcl_Interp *interp,Tcl_Obj *objPtr)} + } { + if {![dict exists $info $func]} { + error "$name does not define $func" + } + set body [dict get $info $func] + # We were given a function name to call + if {[llength $body] eq 1} continue + set fname [string map [list @Name@ [string totitle $name]] $fpat] + my c_function [string map [list @FNAME@ $fname] $template] [string map $map $body] + dict set tcltype $name $func $fname + } + } +} + +::oo::class create ::practcl::cheader { + superclass ::practcl::product + + method compile-products {} {} + method generate-cinit {} {} +} + +::oo::class create ::practcl::csource { + superclass ::practcl::product +} + +::oo::class create ::practcl::clibrary { + superclass ::practcl::product + + method linker-products {configdict} { + return [my define get filename] + } + +} + +### +# In the end, all C code must be loaded into a module +# This will either be a dynamically loaded library implementing +# a tcl extension, or a compiled in segment of a custom shell/app +### +::oo::class create ::practcl::module { + superclass ::practcl::dynamic + + method child which { + switch $which { + organs { + return [list project [my define get project] module [self]] + } + } + } + + method initialize {} { + set filename [my define get filename] + if {$filename eq {}} { + return + } + if {[my define get name] eq {}} { + my define set name [file tail [file dirname $filename]] + } + if {[my define get localpath] eq {}} { + my define set localpath [my define get name]_[my define get name] + } + debug [self] SOURCE $filename + my source $filename + } + + method implement path { + my go + my Collate_Source $path + foreach item [my link list dynamic] { + if {[catch {$item implement $path} err]} { + puts "Skipped $item: $err" + } + } + foreach item [my link list module] { + if {[catch {$item implement $path} err]} { + puts "Skipped $item: $err" + } + } + debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] + set filename [my define get output_c] + if {$filename eq {}} { + debug [list /[self] [self method] [self class]] + return + } + set cout [open [file join $path [file rootname $filename].c] w] + puts $cout [subst {/* +** This file is generated by the [info script] script +** any changes will be overwritten the next time it is run +*/}] + puts $cout [my generate-c] + puts $cout [my generate-loader] + close $cout + debug [list /[self] [self method] [self class]] + } + + method linktype {} { + return {subordinate product dynamic module} + } +} + +::oo::class create ::practcl::autoconf { + + ### + # find or fake a key/value list describing this project + ### + method config.sh {} { + my variable conf_result + if {[info exists conf_result]} { + return $conf_result + } + set result {} + set name [my define get name] + set PWD $::CWD + set builddir [my define get builddir] + my unpack + set srcroot [my define get srcroot] + if {![file exists $builddir]} { + my Configure + } + set filename [file join $builddir config.tcl] + # Project uses the practcl template. Use the leavings from autoconf + if {[file exists $filename]} { + set dat [::practcl::config.tcl $builddir] + foreach {item value} [lsort -stride 2 -dictionary $dat] { + dict set result $item $value + } + set conf_result $result + return $result + } + set filename [file join $builddir ${name}Config.sh] + if {[file exists $filename]} { + set l [expr {[string length $name]+1}] + foreach {field dat} [::practcl::read_Config.sh $filename] { + set field [string tolower $field] + if {[string match ${name}_* $field]} { + set field [string range $field $l end] + } + dict set result $field $dat + } + set conf_result $result + return $result + } + ### + # Oh man... we have to guess + ### + set filename [file join $builddir Makefile] + if {![file exists $filename]} { + error "Could not locate any configuration data in $srcroot" + } + foreach {field dat} [::practcl::read_Makefile $filename] { + dict set result $field $dat + } + set conf_result $result + cd $PWD + return $result + } +} + + +::oo::class create ::practcl::project { + superclass ::practcl::module ::practcl::autoconf + + constructor args { + my variable define + if {[llength $args] == 1} { + if {[catch {uplevel 1 [list subst [lindex $args 0]]} contents]} { + set contents [lindex $args 0] + } + } else { + if {[catch {uplevel 1 [list subst $args]} contents]} { + set contents $args + } + } + array set define $contents + my select + my initialize + } + + + method add_project {pkg info {oodefine {}}} { + set os [my define get os] + if {$os eq {}} { + set os [::practcl::os] + my define set os $os + } + set fossilinfo [list download [my define get download] tag trunk sandbox [my define get sandbox]] + if {[dict exists $info os] && ($os ni [dict get $info os])} return + # Select which tag to use here. + # For production builds: tag-release + if {[::info exists ::env(FOSSIL_MIRROR)]} { + dict set info localmirror $::env(FOSSIL_MIRROR) + } + set profile [my define get profile release]: + if {[dict exists $info profile $profile]} { + dict set info tag [dict get $info profile $profile] + } + set obj [namespace current]::PROJECT.$pkg + if {[info command $obj] eq {}} { + set obj [::practcl::subproject create $obj [self] [dict merge $fossilinfo [list name $pkg pkg_name $pkg static 0] $info]] + } + my link object $obj + oo::objdefine $obj $oodefine + $obj define set masterpath $::CWD + $obj go + return $obj + } + + method child which { + switch $which { + organs { + # A library can be a project, it can be a module. Any + # subordinate modules will indicate their existance + return [list project [self] module [self]] + } + } + } + + method linktype {} { + return project + } + + # Exercise the methods of a sub-object + method project {pkg args} { + set obj [namespace current]::PROJECT.$pkg + if {[llength $args]==0} { + return $obj + } + tailcall ${obj} {*}$args + } +} + +::oo::class create ::practcl::library { + superclass ::practcl::project + + method compile-products {} { + set result {} + foreach item [my link list subordinate] { + lappend result {*}[$item compile-products] + } + set filename [my define get output_c] + if {$filename ne {}} { + set ofile [file rootname [file tail $filename]]_main.o + lappend result $ofile [list cfile $filename extra [my define get extra] external [string is true -strict [my define get external]]] + } + return $result + } + + method generate-tcl-loader {} { + set result {} + set PKGINIT [my define get pkginit] + set PKG_NAME [my define get name [my define get pkg_name]] + set PKG_VERSION [my define get pkg_vers [my define get version]] + if {[string is true [my define get SHARED_BUILD 0]]} { + set LIBFILE [my define get libfile] + ::practcl::cputs result [string map \ + [list @LIBFILE@ $LIBFILE @PKGINIT@ $PKGINIT @PKG_NAME@ $PKG_NAME @PKG_VERSION@ $PKG_VERSION] { +# Shared Library Style +load [file join [file dirname [file join [pwd] [info script]]] @LIBFILE@] @PKGINIT@ +package provide @PKG_NAME@ @PKG_VERSION@ +}] + } else { + ::practcl::cputs result [string map \ + [list @PKGINIT@ $PKGINIT @PKG_NAME@ $PKG_NAME @PKG_VERSION@ $PKG_VERSION] { +# Tclkit Style +load {} @PKGINIT@ +package provide @PKG_NAME@ @PKG_VERSION@ +}] + } + return $result + } + + method go {} { + debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] + set name [my define getnull name] + if {$name eq {}} { + set name generic + my define name generic + } + if {[my define get tk] eq {@TEA_TK_EXTENSION@}} { + my define set tk 0 + } + set output_c [my define getnull output_c] + if {$output_c eq {}} { + set output_c [file rootname $name].c + my define set output_c $output_c + } + set output_h [my define getnull output_h] + if {$output_h eq {}} { + set output_h [file rootname $output_c].h + my define set output_h $output_h + } + set output_tcl [my define getnull output_tcl] + #if {$output_tcl eq {}} { + # set output_tcl [file rootname $output_c].tcl + # my define set output_tcl $output_tcl + #} + #set output_mk [my define getnull output_mk] + #if {$output_mk eq {}} { + # set output_mk [file rootname $output_c].mk + # my define set output_mk $output_mk + #} + set initfunc [my define getnull initfunc] + if {$initfunc eq {}} { + set initfunc [string totitle $name]_Init + my define set initfunc $initfunc + } + set output_decls [my define getnull output_decls] + if {$output_decls eq {}} { + set output_decls [file rootname $output_c].decls + my define set output_decls $output_decls + } + my variable links + foreach {linktype objs} [array get links] { + foreach obj $objs { + $obj go + } + } + debug [list /[self] [self method] [self class] -- [my define get filename] [info object class [self]]] + } + + method implement path { + my go + my Collate_Source $path + foreach item [my link list dynamic] { + if {[catch {$item implement $path} err]} { + puts "Skipped $item: $err" + } + } + foreach item [my link list module] { + if {[catch {$item implement $path} err]} { + puts "Skipped $item: $err" + } + } + set cout [open [file join $path [my define get output_c]] w] + puts $cout [subst {/* +** This file is generated by the [info script] script +** any changes will be overwritten the next time it is run +*/}] + puts $cout [my generate-c] + puts $cout [my generate-loader] + close $cout + + set macro HAVE_[string toupper [file rootname [my define get output_h]]]_H + set hout [open [file join $path [my define get output_h]] w] + puts $hout [subst {/* +** This file is generated by the [info script] script +** any changes will be overwritten the next time it is run +*/}] + puts $hout "#ifndef ${macro}" + puts $hout "#define ${macro}" + puts $hout [my generate-h] + puts $hout "#endif" + close $hout + + set output_tcl [my define get output_tcl] + if {$output_tcl ne {}} { + set tclout [open [file join $path [my define get output_tcl]] w] + puts $tclout "### +# This file is generated by the [info script] script +# any changes will be overwritten the next time it is run +###" + puts $tclout [my generate-tcl] + puts $tclout [my generate-tcl-loader] + close $tclout + } + } + + method generate-decls {pkgname path} { + debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] + set outfile [file join $path/$pkgname.decls] + + ### + # Build the decls file + ### + set fout [open $outfile w] + puts $fout [subst {### + # $outfile + # + # This file was generated by [info script] + ### + + library $pkgname + interface $pkgname + }] + + ### + # Generate list of functions + ### + set stubfuncts [my generate-stub-function] + set thisline {} + set functcount 0 + foreach {func header} $stubfuncts { + puts $fout [list declare [incr functcount] $header] + } + puts $fout [list export "int [my define get initfunc](Tcl_Inter *interp)"] + puts $fout [list export "char *[string totitle [my define get name]]_InitStubs(Tcl_Inter *interp, char *version, int exact)"] + + close $fout + + ### + # Build [package]Decls.h + ### + set hout [open [file join $path ${pkgname}Decls.h] w] + + close $hout + + set cout [open [file join $path ${pkgname}StubInit.c] w] +puts $cout [string map [list %pkgname% $pkgname %PkgName% [string totitle $pkgname]] { +#ifndef USE_TCL_STUBS +#define USE_TCL_STUBS +#endif +#undef USE_TCL_STUB_PROCS + +#include "tcl.h" +#include "%pkgname%.h" + + /* + ** Ensure that Tdom_InitStubs is built as an exported symbol. The other stub + ** functions should be built as non-exported symbols. + */ + +#undef TCL_STORAGE_CLASS +#define TCL_STORAGE_CLASS DLLEXPORT + +%PkgName%Stubs *%pkgname%StubsPtr; + + /* + **---------------------------------------------------------------------- + ** + ** %PkgName%_InitStubs -- + ** + ** Checks that the correct version of %PkgName% is loaded and that it + ** supports stubs. It then initialises the stub table pointers. + ** + ** Results: + ** The actual version of %PkgName% that satisfies the request, or + ** NULL to indicate that an error occurred. + ** + ** Side effects: + ** Sets the stub table pointers. + ** + **---------------------------------------------------------------------- + */ + +char * +%PkgName%_InitStubs (Tcl_Interp *interp, char *version, int exact) +{ + char *actualVersion; + actualVersion = Tcl_PkgRequireEx(interp, "%pkgname%", version, exact,(ClientData *) &%pkgname%StubsPtr); + if (!actualVersion) { + return NULL; + } + if (!%pkgname%StubsPtr) { + Tcl_SetResult(interp,"This implementation of %PkgName% does not support stubs",TCL_STATIC); + return NULL; + } + return actualVersion; +} +}] + close $cout + } + + # Backward compadible call + method generate-make path { + ::practcl::build::Makefile $path [self] + } + + method install-headers {} { + set result {} + return $result + } + + method linktype {} { + return library + } + + # Create a "package ifneeded" + # Args are a list of aliases for which this package will answer to + method package-ifneeded {args} { + set result {} + set name [my define get pkg_name [my define get name]] + set version [my define get pkg_vers [my define get version]] + if {$version eq {}} { + set version 0.1a + } + set output_tcl [my define get output_tcl] + if {$output_tcl ne {}} { + set script "\[list source \[file join \$dir $output_tcl\]\]" + } elseif {[string is true -strict [my define get SHARED_BUILD]]} { + set script "\[list load \[file join \$dir [my define get libfile]\] $name\]" + } else { + # Provide a null passthrough + set script [list package provide $name $version] + } + set result "package ifneeded [list $name] [list $version] $script" + foreach alias $args { + set script "package require $name $version \; package provide $alias $version" + append result \n\n [list package ifneeded $alias $version $script] + } + return $result + } + + + method shared_library {} { + set name [string tolower [my define get name [my define get pkg_name]]] + set NAME [string toupper $name] + set version [my define get version [my define get pkg_vers]] + set map {} + lappend map %LIBRARY_NAME% $name + lappend map %LIBRARY_VERSION% $version + lappend map %LIBRARY_VERSION_NODOTS% [string map {. {}} $version] + lappend map %LIBRARY_PREFIX% [my define getnull libprefix] + set outfile [string map $map [my define get PRACTCL_NAME_LIBRARY]][my define get SHLIB_SUFFIX] + return $outfile + } +} + +::oo::class create ::practcl::tclkit { + superclass ::practcl::library + + method Collate_Source CWD { + my define set SHARED_BUILD 0 + set name [my define get name] + + if {![my define exists TCL_LOCAL_APPINIT]} { + my define set TCL_LOCAL_APPINIT Tclkit_AppInit + } + if {![my define exists TCL_LOCAL_MAIN_HOOK]} { + my define set TCL_LOCAL_MAIN_HOOK Tclkit_MainHook + } + + set PROJECT [self] + set os [$PROJECT define get os] + set TCLOBJ [$PROJECT project TCLCORE] + set TKOBJ [$PROJECT project TKCORE] + set ODIEOBJ [$PROJECT project odie] + + set TCLSRCDIR [$TCLOBJ define get srcroot] + set TKSRCDIR [$TKOBJ define get srcroot] + set PKG_OBJS {} + foreach item [$PROJECT link list package] { + if {[string is true [$item define get static]]} { + lappend PKG_OBJS $item + } + } + # Arrange to build an main.c that utilizes TCL_LOCAL_APPINIT and TCL_LOCAL_MAIN_HOOK + if {$os eq "windows"} { + set PLATFORM_SRC_DIR win + my add class csource filename [file join $TCLSRCDIR win tclWinReg.c] initfunc Registry_Init pkg_name registry pkg_vers 1.3.1 autoload 1 + my add class csource filename [file join $TCLSRCDIR win tclWinDde.c] initfunc Dde_Init pkg_name dde pkg_vers 1.4.0 autoload 1 + my add class csource ofile [my define get name]_appinit.o filename [file join $TCLSRCDIR win tclAppInit.c] extra [list -DTCL_LOCAL_MAIN_HOOK=[my define get TCL_LOCAL_MAIN_HOOK Tclkit_MainHook] -DTCL_LOCAL_APPINIT=[my define get TCL_LOCAL_APPINIT Tclkit_AppInit]] + } else { + set PLATFORM_SRC_DIR unix + my add class csource ofile [my define get name]_appinit.o filename [file join $TCLSRCDIR unix tclAppInit.c] extra [list -DTCL_LOCAL_MAIN_HOOK=[my define get TCL_LOCAL_MAIN_HOOK Tclkit_MainHook] -DTCL_LOCAL_APPINIT=[my define get TCL_LOCAL_APPINIT Tclkit_AppInit]] + } + ### + # Add local static Zlib implementation + ### + set cdir [file join $TCLSRCDIR compat zlib] + foreach file { + adler32.c compress.c crc32.c + deflate.c infback.c inffast.c + inflate.c inftrees.c trees.c + uncompr.c zutil.c + } { + my add [file join $cdir $file] + } + + ### + # Pre 8.7, Tcl doesn't include a Zipfs implementation + # in the core. Grab the one from odielib + ### + set zipfs [file join $TCLSRCDIR generic zvfs.c] + if {![file exists $zipfs]} { + # The Odie project maintains a mirror of the version + # released with the Tcl core + my add_project odie { + tag trunk + class subproject + vfsinstall 0 + } + my project odie unpack + set ODIESRCROOT [my project odie define get srcroot] + set cdir [file join $ODIESRCROOT compat zipfs] + my define add include_dir $cdir + set zipfs [file join $cdir zvfs.c] + } + + my add class csource filename $zipfs initfunc Tclzipfs_Init pkg_name zipfs pkg_vers 1.0 autoload 1 + + my define add include_dir [file join $TKSRCDIR generic] + my define add include_dir [file join $TKSRCDIR $PLATFORM_SRC_DIR] + my define add include_dir [file join $TKSRCDIR bitmaps] + my define add include_dir [file join $TKSRCDIR xlib] + my define add include_dir [file join $TCLSRCDIR generic] + my define add include_dir [file join $TCLSRCDIR $PLATFORM_SRC_DIR] + my define add include_dir [file join $TCLSRCDIR compat zlib] + # This file will implement TCL_LOCAL_APPINIT and TCL_LOCAL_MAIN_HOOK + ::practcl::build::tclkit_main $PROJECT $PKG_OBJS + } + + ## Wrap an executable + # + method wrap {PWD exename vfspath args} { + cd $PWD + if {![file exists $vfspath]} { + file mkdir $vfspath + } + foreach item [my link list core.library] { + set name [$item define get name] + set libsrcroot [$item define get srcroot] + if {[file exists [file join $libsrcroot library]]} { + ::practcl::copyDir [file join $libsrcroot library] [file join $vfspath boot $name] + } + } + if {[my define get installdir] ne {}} { + ::practcl::copyDir [file join [my define get installdir] [string trimleft [my define get prefix] /] lib] [file join $vfspath lib] + } + foreach arg $args { + ::practcl::copyDir $arg $vfspath + } + + set fout [open [file join $vfspath packages.tcl] w] + puts $fout { + set ::PKGIDXFILE [info script] + set dir [file dirname $::PKGIDXFILE] + } + #set BASEVFS [my define get BASEVFS] + set EXEEXT [my define get EXEEXT] + + set tclkit_bare [my define get tclkit_bare] + + set buffer [::practcl::pkgindex_path $vfspath] + puts $fout $buffer + puts $fout { + # Advertise statically linked packages + foreach {pkg script} [array get ::kitpkg] { + eval $script + } + } + close $fout + package require zipfile::mkzip + ::zipfile::mkzip::mkzip ${exename}${EXEEXT} -runtime $tclkit_bare -directory $vfspath + if { [my define get platform] ne "windows" } { + file attributes ${exename}${EXEEXT} -permissions a+x + } + } +} + +### +# Meta repository +# The default is an inert source code block +### +oo::class create ::practcl::subproject { + superclass ::practcl::object + + method compile {} {} + + method go {} { + set platform [my define get platform] + my define get USEMSVC [my define get USEMSVC] + set name [my define get name] + if {![my define exists srcroot]} { + my define set srcroot [file join [my define get sandbox] $name] + } + set srcroot [my define get srcroot] + my define set localsrcdir $srcroot + my define add include_dir [file join $srcroot generic] + my sources + } + + # Install project into the local build system + method install-local {} { + my unpack + } + + # Install project into the virtual file system + method install-vfs {} {} + + method linktype {} { + return {subordinate package} + } + + method linker-products {configdict} {} + + method linker-external {configdict} { + if {[dict exists $configdict PRACTCL_LIBS]} { + return [dict get $configdict PRACTCL_LIBS] + } + } + + method sources {} {} + + method unpack {} { + set name [my define get name] + puts [list $name [self] UNPACK] + my define set [::practcl::fossil_sandbox $name [my define dump]] + } + + method update {} { + set name [my define get name] + my define set [::practcl::fossil_sandbox $name [dict merge [my define dump] {update 1}]] + } +} + +### +# A project which the kit compiles and integrates +# the source for itself +### +oo::class create ::practcl::subproject.source { + superclass ::practcl::subproject ::practcl::library + + method linktype {} { + return {subordinate package source} + } + +} + +# a copy from the teapot +oo::class create ::practcl::subproject.teapot { + superclass ::practcl::subproject + + method install-local {} { + my install-vfs + } + + method install-vfs {} { + set pkg [my define get pkg_name [my define get name]] + set download [my define get download] + my unpack + set DEST [my define get installdir] + set prefix [string trimleft [my define get prefix] /] + # Get tcllib from our destination + set dir [file join $DEST $prefix lib tcllib] + source [file join $DEST $prefix lib tcllib pkgIndex.tcl] + package require zipfile::decode + ::zipfile::decode::unzipfile [file join $download $pkg.zip] [file join $DEST $prefix lib $pkg] + } +} + +oo::class create ::practcl::subproject.sak { + superclass ::practcl::subproject + + method install-local {} { + my install-vfs + } + + method install-vfs {} { + ### + # Handle teapot installs + ### + set pkg [my define get pkg_name [my define get name]] + my unpack + set DEST [my define get installdir] + set prefix [string trimleft [my define get prefix] /] + set srcroot [my define get srcroot] + ::dotclexec [file join $srcroot installer.tcl] \ + -pkg-path [file join $DEST $prefix lib $pkg] \ + -no-examples -no-html -no-nroff \ + -no-wait -no-gui -no-apps + } +} + +### +# A binary package +### +oo::class create ::practcl::subproject.binary { + superclass ::practcl::subproject ::practcl::autoconf + + + method compile-products {} {} + + method ConfigureOpts {} { + set opts {} + set builddir [my define get builddir] + if {[my define get broken_destroot 0]} { + set PREFIX [my define get prefix_broken_destdir] + } else { + set PREFIX [my define get prefix] + } + if {[my define get HOST] != [my define get TARGET]} { + lappend opts --host=[my define get TARGET] + } + if {[my define exists tclsrcdir]} { + set TCLSRCDIR [::practcl::file_relative [file normalize $builddir] [file normalize [file join $::CWD [my define get tclsrcdir]]]] + set TCLGENERIC [::practcl::file_relative [file normalize $builddir] [file normalize [file join $::CWD [my define get tclsrcdir] .. generic]]] + lappend opts --with-tcl=$TCLSRCDIR --with-tclinclude=$TCLGENERIC + } + if {[my define exists tksrcdir]} { + set TKSRCDIR [::practcl::file_relative [file normalize $builddir] [file normalize [file join $::CWD [my define get tksrcdir]]]] + set TKGENERIC [::practcl::file_relative [file normalize $builddir] [file normalize [file join $::CWD [my define get tksrcdir] .. generic]]] + lappend opts --with-tk=$TKSRCDIR --with-tkinclude=$TKGENERIC + } + lappend opts {*}[my define get config_opts] + lappend opts --prefix=$PREFIX + #--exec_prefix=$PREFIX + #if {$::tcl_platform(platform) eq "windows"} { + # lappend opts --disable-64bit + #} + if {[my define get static 1]} { + lappend opts --disable-shared --disable-stubs + # + } else { + lappend opts --enable-shared + } + return $opts + } + + method go {} { + next + my define set builddir [my BuildDir [my define get masterpath]] + } + + method linker-products {configdict} { + if {![my define get static 0]} { + return {} + } + set srcdir [my define get builddir] + if {[dict exists $configdict libfile]} { + return " [file join $srcdir [dict get $configdict libfile]]" + } + } + + method static-packages {} { + if {![my define get static 0]} { + return {} + } + set result [my define get static_packages] + set statpkg [my define get static_pkg] + set initfunc [my define get initfunc] + if {$initfunc ne {}} { + set pkg_name [my define get pkg_name] + if {$pkg_name ne {}} { + dict set result $pkg_name initfunc $initfunc + set version [my define get version] + if {$version eq {}} { + set info [my config.sh] + set version [dict get $info version] + set pl {} + if {[dict exists $info patch_level]} { + set pl [dict get $info patch_level] + append version $pl + } + my define set version $version + } + dict set result $pkg_name version $version + dict set result $pkg_name autoload [my define get autoload 0] + } + } + foreach item [my link list subordinate] { + foreach {pkg info} [$item static-packages] { + dict set result $pkg $info + } + } + return $result + } + + method BuildDir {PWD} { + set name [my define get name] + return [my define get builddir [file join $PWD pkg.$name]] + } + + method compile {} { + set name [my define get name] + set PWD $::CWD + cd $PWD + my go + set srcroot [file normalize [my define get srcroot]] + my Collate_Source $PWD + + ### + # Build a starter VFS for both Tcl and wish + ### + set srcroot [my define get srcroot] + if {[my define get static 1]} { + puts "BUILDING Static $name $srcroot" + } else { + puts "BUILDING Dynamic $name $srcroot" + } + if {[my define get USEMSVC 0]} { + cd $srcroot + doexec nmake -f makefile.vc INSTALLDIR=[my define get installdir] release + } else { + cd $::CWD + set builddir [file normalize [my define get builddir]] + file mkdir $builddir + if {![file exists [file join $builddir Makefile]]} { + my Configure + } + if {[file exists [file join $builddir make.tcl]]} { + domake.tcl $builddir library + } else { + domake $builddir all + } + } + cd $PWD + } + + + method Configure {} { + cd $::CWD + my unpack + my TeaConfig + set builddir [file normalize [my define get builddir]] + file mkdir $builddir + set srcroot [file normalize [my define get srcroot]] + if {[my define get USEMSVC 0]} { + return + } + set opts [my ConfigureOpts] + puts [list [self] CONFIGURE] + puts [list PWD [pwd]] + puts [list LOCALSRC $srcroot] + puts [list BUILDDIR $builddir] + puts [list CONFIGURE {*}$opts] + cd $builddir + exec sh [file join $srcroot configure] {*}$opts >& [file join $builddir practcl.log] + cd $::CWD + } + + method install-vfs {} { + set PWD [pwd] + set PKGROOT [my define get installdir] + set PREFIX [my define get prefix] + + ### + # Handle teapot installs + ### + set pkg [my define get pkg_name [my define get name]] + if {[my define get teapot] ne {}} { + set TEAPOT [my define get teapot] + set found 0 + foreach ver [my define get pkg_vers [my define get version]] { + set teapath [file join $TEAPOT $pkg$ver] + if {[file exists $teapath]} { + set dest [file join $PKGROOT [string trimleft $PREFIX /] lib [file tail $teapath]] + ::practcl::copyDir $teapath $dest + return + } + } + } + my compile + if {[my define get USEMSVC 0]} { + set srcroot [my define get srcroot] + cd $srcroot + puts "[self] VFS INSTALL $PKGROOT" + doexec nmake -f makefile.vc INSTALLDIR=$PKGROOT install + } else { + set builddir [my define get builddir] + if {[file exists [file join $builddir make.tcl]]} { + # Practcl builds can inject right to where we need them + puts "[self] VFS INSTALL $PKGROOT (Practcl)" + domake.tcl $builddir install-package $PKGROOT + } elseif {[my define get broken_destroot 0] == 0} { + # Most modern TEA projects understand DESTROOT in the makefile + puts "[self] VFS INSTALL $PKGROOT (TEA)" + domake $builddir install DESTDIR=$PKGROOT + } else { + # But some require us to do an install into a fictitious filesystem + # and then extract the gooey parts within. + # (*cough*) TkImg + set PREFIX [my define get prefix] + set BROKENROOT [::practcl::msys_to_tclpath [my define get prefix_broken_destdir]] + file delete -force $BROKENROOT + file mkdir $BROKENROOT + domake $builddir $install + ::practcl::copyDir $BROKENROOT [file join $PKGROOT [string trimleft $PREFIX /]] + file delete -force $BROKENROOT + } + } + cd $PWD + } + + method TeaConfig {} { + set srcroot [file normalize [my define get srcroot]] + set copytea 0 + if {![file exists [file join $srcroot tclconfig]]} { + set copytea 1 + } else { + if {![file exists [file join $srcroot tclconfig practcl.tcl]] || ![file exists [file join $srcroot tclconfig config.tcl.in]]} { + set copytea 1 + } + } + # ensure we have tclconfig with all of the trimming + if {$copytea} { + set tclconfiginfo [::practcl::fossil_sandbox tclconfig [list sandbox [my define get sandbox]]] + ::practcl::copyDir [dict get $tclconfiginfo srcroot] [file join $srcroot tclconfig] + if {$::tcl_platform(platform) ne "windows"} { + set pwd [pwd] + cd $srcroot + # On windows there's no practical way to execute + # autoconf. We'll have to trust that configure + # us up to date + foreach template {configure.ac configure.in} { + set input [file join $srcroot $template] + if {[file exists $input]} { + puts "autoconf -f $input > [file join $srcroot configure]" + exec autoconf -f $input > [file join $srcroot configure] + } + } + cd $pwd + } + } + } +} + +oo::class create ::practcl::subproject.core { + superclass ::practcl::subproject.binary + + # On the windows platform MinGW must build + # from the platform directory in the source repo + method BuildDir {PWD} { + return [my define get localsrcdir] + } + + method Configure {} { + if {[my define get USEMSVC 0]} { + return + } + set opts [my ConfigureOpts] + puts [list PWD [pwd]] + puts [list [self] CONFIGURE] + set builddir [file normalize [my define get builddir]] + set localsrcdir [file normalize [my define get localsrcdir]] + puts [list LOCALSRC $localsrcdir] + puts [list BUILDDIR $builddir] + puts [list CONFIGURE {*}$opts] + cd $localsrcdir + exec sh [file join $localsrcdir configure] {*}$opts >& [file join $builddir practcl.log] + } + + method ConfigureOpts {} { + set opts {} + set builddir [file normalize [my define get builddir]] + set PREFIX [my define get prefix] + if {[my define get HOST] != [my define get TARGET]} { + lappend opts --host=[my define get TARGET] + } + lappend opts {*}[my define get config_opts] + lappend opts --prefix=$PREFIX + #--exec_prefix=$PREFIX + lappend opts --disable-shared + return $opts + } + + method go {} { + set name [my define get name] + set platform [my define get platform] + if {![my define exists srcroot]} { + my define set srcroot [file join [my define get sandbox] $name] + } + set srcroot [my define get srcroot] + my define add include_dir [file join $srcroot generic] + switch $platform { + windows { + my define set localsrcdir [file join $srcroot win] + my define add include_dir [file join $srcroot win] + } + default { + my define set localsrcdir [file join $srcroot unix] + my define add include_dir [file join $srcroot $name unix] + } + } + my define set builddir [my BuildDir [my define get masterpath]] + } + + method linktype {} { + return {subordinate core.library} + } +} + +package provide practcl 0.5 diff --git a/unix/Makefile.in b/unix/Makefile.in index 1afc883..ca15312 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -308,7 +308,7 @@ GENERIC_OBJS = regcomp.o regexec.o regfree.o regerror.o tclAlloc.o \ tclStrToD.o tclThread.o \ tclThreadAlloc.o tclThreadJoin.o tclThreadStorage.o tclStubInit.o \ tclTimer.o tclTrace.o tclUtf.o tclUtil.o tclVar.o tclZlib.o \ - tclTomMathInterface.o zipfs.o + tclTomMathInterface.o tclZipfs.o OO_OBJS = tclOO.o tclOOBasic.o tclOOCall.o tclOODefineCmds.o tclOOInfo.o \ tclOOMethod.o tclOOStubInit.o @@ -373,7 +373,6 @@ GENERIC_HDRS = \ $(GENERIC_DIR)/tclInt.h \ $(GENERIC_DIR)/tclIntDecls.h \ $(GENERIC_DIR)/tclIntPlatDecls.h \ - $(GENERIC_DIR)/tclZipfs.h \ $(GENERIC_DIR)/tclTomMath.h \ $(GENERIC_DIR)/tclTomMathDecls.h \ $(GENERIC_DIR)/tclOO.h \ @@ -954,7 +953,6 @@ install-headers: @for i in $(GENERIC_DIR)/tcl.h $(GENERIC_DIR)/tclDecls.h \ $(GENERIC_DIR)/tclOO.h $(GENERIC_DIR)/tclOODecls.h \ $(GENERIC_DIR)/tclPlatDecls.h \ - $(GENERIC_DIR)/tclZipfs.h \ $(GENERIC_DIR)/tclTomMath.h \ $(GENERIC_DIR)/tclTomMathDecls.h ; \ do \ @@ -1324,8 +1322,8 @@ tclVar.o: $(GENERIC_DIR)/tclVar.c tclZlib.o: $(GENERIC_DIR)/tclZlib.c $(CC) -c $(CC_SWITCHES) $(ZLIB_INCLUDE) $(GENERIC_DIR)/tclZlib.c -zipfs.o: $(GENERIC_DIR)/zipfs.c - $(CC) -c $(CC_SWITCHES) $(ZLIB_INCLUDE) $(GENERIC_DIR)/zipfs.c +tclZipfs.o: $(GENERIC_DIR)/tclZipfs.c + $(CC) -c $(CC_SWITCHES) $(ZLIB_INCLUDE) $(GENERIC_DIR)/tclZipfs.c tclTest.o: $(GENERIC_DIR)/tclTest.c $(IOHDR) $(TCLREHDRS) $(CC) -c $(APP_CC_SWITCHES) $(GENERIC_DIR)/tclTest.c diff --git a/unix/tclAppInit.c b/unix/tclAppInit.c index 2dcd192..9bbc88b 100644 --- a/unix/tclAppInit.c +++ b/unix/tclAppInit.c @@ -15,9 +15,7 @@ #undef BUILD_tcl #undef STATIC_BUILD #include "tcl.h" -#ifdef HAVE_ZLIB -#include "tclZipfs.h" -#endif + #ifdef TCL_TEST extern Tcl_PackageInitProc Tcltest_Init; extern Tcl_PackageInitProc Tcltest_SafeInit; @@ -42,7 +40,6 @@ extern Tcl_PackageInitProc Tclxttest_Init; #endif MODULE_SCOPE int TCL_LOCAL_APPINIT(Tcl_Interp *); MODULE_SCOPE int main(int, char **); -MODULE_SCOPE int Tcl_Zvfs_Boot(const char *,const char *,const char *,const char *); /* * The following #if block allows you to change how Tcl finds the startup @@ -83,12 +80,7 @@ main( #ifdef TCL_LOCAL_MAIN_HOOK TCL_LOCAL_MAIN_HOOK(&argc, &argv); #endif - #define TCLKIT_INIT "main.tcl" - #define TCLKIT_VFSMOUNT "/zvfs" - #define TCLKIT_PASSWD NULL - Tcl_FindExecutable(argv[0]); - CONST char *cp=Tcl_GetNameOfExecutable(); - Tcl_Zvfs_Boot(cp,TCLKIT_VFSMOUNT,TCLKIT_INIT,TCLKIT_PASSWD); + Tcl_Main(argc, argv, TCL_LOCAL_APPINIT); return 0; /* Needed only to prevent compiler warning. */ } @@ -119,11 +111,7 @@ Tcl_AppInit( if ((Tcl_Init)(interp) == TCL_ERROR) { return TCL_ERROR; } - /* Load the zipfs package */ - if (Tclzipfs_Init(interp) == TCL_ERROR) { - return TCL_ERROR; - } - Tcl_StaticPackage(interp, "zipfs", Tclzipfs_Init, Tclzipfs_SafeInit); + #ifdef TCL_XT_TEST if (Tclxttest_Init(interp) == TCL_ERROR) { return TCL_ERROR; diff --git a/win/Makefile.in b/win/Makefile.in index e4ca501..118ccb1 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -152,6 +152,7 @@ SHARED_LIBRARIES = $(TCL_DLL_FILE) @ZLIB_DLL_FILE@ STATIC_LIBRARIES = $(TCL_LIB_FILE) TCLSH = tclsh$(VER)${EXESUFFIX} +TCLKIT = tclkit$(VER)${EXESUFFIX} CAT32 = cat32$(EXEEXT) MAN2TCL = man2tcl$(EXEEXT) @@ -303,7 +304,7 @@ GENERIC_OBJS = \ tclUtil.$(OBJEXT) \ tclVar.$(OBJEXT) \ tclZlib.$(OBJEXT) \ - zipfs.$(OBJEXT) + tclZipfs.$(OBJEXT) TOMMATH_OBJS = \ bncore.${OBJEXT} \ @@ -399,6 +400,8 @@ STUB_OBJS = \ TCLSH_OBJS = tclAppInit.$(OBJEXT) +TCLKIT_OBJS = tclkitMain.${OBJEXT} tclkit.${OBJEXT} + ZLIB_OBJS = \ adler32.$(OBJEXT) \ compress.$(OBJEXT) \ @@ -420,7 +423,7 @@ all: binaries libraries doc packages tcltest: $(TCLSH) $(TEST_DLL_FILE) -binaries: $(TCL_STUB_LIB_FILE) @LIBRARIES@ winextensions $(TCLSH) +binaries: $(TCL_STUB_LIB_FILE) @LIBRARIES@ winextensions $(TCLSH) $(TCLKIT) winextensions: ${DDE_DLL_FILE} ${REG_DLL_FILE} @@ -433,6 +436,11 @@ $(TCLSH): $(TCLSH_OBJS) @LIBRARIES@ $(TCL_STUB_LIB_FILE) tclsh.$(RES) tclsh.$(RES) $(CC_EXENAME) $(LDFLAGS_CONSOLE) @VC_MANIFEST_EMBED_EXE@ +$(TCLKIT): $(TCLKIT_OBJ) @LIBRARIES@ $(TCL_STUB_LIB_FILE) tclsh.$(RES) + $(CC) $(CFLAGS) $(TCLKIT_OBJ) $(TCL_LIB_FILE) $(TCL_STUB_LIB_FILE) $(LIBS) \ + tclsh.$(RES) $(CC_EXENAME) $(LDFLAGS_CONSOLE) + @VC_MANIFEST_EMBED_EXE@ + cat32.$(OBJEXT): cat.c $(CC) -c $(CC_SWITCHES) @DEPARG@ $(CC_OBJNAME) @@ -496,6 +504,9 @@ testMain.${OBJEXT}: tclAppInit.c tclMain2.${OBJEXT}: tclMain.c $(CC) -c $(CC_SWITCHES) -DBUILD_tcl -DTCL_ASCII_MAIN @DEPARG@ $(CC_OBJNAME) +tclkitMain.${OBJEXT}: tclAppInit.c + $(CC) -c $(CC_SWITCHES) -DTCL_LOCAL_MAIN_HOOK="Tclkit_MainHook" -DTCL_LOCAL_APPINIT="Tclkit_AppInit" @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 diff --git a/win/makefile.vc b/win/makefile.vc index ec7afac..cf7d422 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -345,7 +345,7 @@ COREOBJS = \ $(TMP_DIR)\tclUtil.obj \ $(TMP_DIR)\tclVar.obj \ $(TMP_DIR)\tclZlib.obj \ - $(TMP_DIR)\zipfs.obj + $(TMP_DIR)\tclZipfs.obj ZLIBOBJS = \ $(TMP_DIR)\adler32.obj \ diff --git a/win/tclAppInit.c b/win/tclAppInit.c index 1c3ef9b..e06eaf5 100644 --- a/win/tclAppInit.c +++ b/win/tclAppInit.c @@ -25,13 +25,10 @@ #include #ifdef TCL_TEST -#include "tclZipfs.h" extern Tcl_PackageInitProc Tcltest_Init; extern Tcl_PackageInitProc Tcltest_SafeInit; #endif /* TCL_TEST */ -MODULE_SCOPE int Tcl_Zvfs_Boot(const char *,const char *,const char *); - #if defined(STATIC_BUILD) && TCL_USE_STATIC_PACKAGES extern Tcl_PackageInitProc Registry_Init; extern Tcl_PackageInitProc Dde_Init; @@ -128,13 +125,7 @@ _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. */ } @@ -165,9 +156,6 @@ Tcl_AppInit( if ((Tcl_Init)(interp) == TCL_ERROR) { return TCL_ERROR; } - if(Tcl_StaticPackage(interp, "zipfs", Tclzipfs_Init, Tclzipfs_SafeInit) == TCL_ERROR ) { - return TCL_ERROR; - } #if defined(STATIC_BUILD) && TCL_USE_STATIC_PACKAGES if (Registry_Init(interp) == TCL_ERROR) { @@ -186,9 +174,6 @@ Tcl_AppInit( return TCL_ERROR; } Tcl_StaticPackage(interp, "Tcltest", Tcltest_Init, Tcltest_SafeInit); - if (Tclzipfs_Init(interp) == TCL_ERROR) { - return TCL_ERROR; - } #endif /* TCL_TEST */ /* -- cgit v0.12