ADDED compat/tclZipfs.c Index: compat/tclZipfs.c ================================================================== --- /dev/null +++ compat/tclZipfs.c @@ -0,0 +1,4597 @@ +/* + * tclZipfs.c -- + * + * Implementation of the ZIP filesystem used in TIP 430 + * Adapted from the implentation for AndroWish. + * + * Coptright (c) 2016-2017 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. + * + * This file is distributed in two ways: + * generic/tclZipfs.c file in the TIP430 enabled tcl cores + * compat/tclZipfs.c file in the tclconfig (TEA) file system, for pre-tip430 projects + */ + +#include "tclInt.h" +#include "tclFileSystem.h" + +#if !defined(_WIN32) && !defined(_WIN64) +#include +#else +#include +#endif +#include +#include +#include +#include +#include +#include + +#ifndef MAP_FILE +#define MAP_FILE 0 +#endif + +#ifdef HAVE_ZLIB +#include "zlib.h" +#include "crypt.h" + +#ifdef CFG_RUNTIME_DLLFILE +/* +** We are compiling as part of the core. +** TIP430 style zipfs prefix +*/ +#define ZIPFS_VOLUME "//zipfs:/" +#define ZIPFS_VOLUME_LEN 9 +#define ZIPFS_APP_MOUNT "//zipfs:/app" +#define ZIPFS_ZIP_MOUNT "//zipfs:/lib/tcl" +#else +/* +** We are compiling from the /compat folder of tclconfig +** Pre TIP430 style zipfs prefix +** //zipfs:/ doesn't work straight out of the box on either windows or Unix +** without other changes made to tip 430 +*/ +#define ZIPFS_VOLUME "zipfs:/" +#define ZIPFS_VOLUME_LEN 7 +#define ZIPFS_APP_MOUNT "zipfs:/app" +#define ZIPFS_ZIP_MOUNT "zipfs:/lib/tcl" +#endif +/* + * 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 + +/* Macro to report errors only if an interp is present */ +#define ZIPFS_ERROR(interp,errstr) \ + if(interp != NULL) Tcl_SetObjResult(interp, Tcl_NewStringObj(errstr, -1)); + +/* + * 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 */ + size_t namelen; + char is_membuf; /* When true, not a file but a memory buffer */ + 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 */ + unsigned long baseoffs; /* Archive start */ + long baseoffsp; /* Password start */ + unsigned long centoffs; /* Archive directory start */ + unsigned char pwbuf[264]; /* Password buffer */ +#if defined(_WIN32) || defined(_WIN64) + HANDLE mh; +#endif + unsigned long 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; + char *mntpt; /* 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, or -1 if root */ + 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, or -1 if root */ + 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 z_crc_t 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, +}; + +const char *zipfs_literal_tcl_library=NULL; + +/* Function prototypes */ +int TclZipfs_Mount( + Tcl_Interp *interp, + const char *mntpt, + const char *zipname, + const char *passwd +); +int TclZipfs_Mount_Buffer( + Tcl_Interp *interp, + const char *mntpt, + unsigned char *data, + size_t datalen, + int copy +); +static int TclZipfs_AppHook_FindTclInit(const char *archive); +static int Zip_FSPathInFilesystemProc(Tcl_Obj *pathPtr, ClientData *clientDataPtr); +static Tcl_Obj *Zip_FSFilesystemPathTypeProc(Tcl_Obj *pathPtr); +static Tcl_Obj *Zip_FSFilesystemSeparatorProc(Tcl_Obj *pathPtr); +static int Zip_FSStatProc(Tcl_Obj *pathPtr, Tcl_StatBuf *buf); +static int Zip_FSAccessProc(Tcl_Obj *pathPtr, int mode); +static Tcl_Channel Zip_FSOpenFileChannelProc( + Tcl_Interp *interp, Tcl_Obj *pathPtr, + int mode, int permissions +); +static int Zip_FSMatchInDirectoryProc( + Tcl_Interp* interp, Tcl_Obj *result, + Tcl_Obj *pathPtr, const char *pattern, + Tcl_GlobTypeData *types +); +static Tcl_Obj *Zip_FSListVolumesProc(void); +static const char *const *Zip_FSFileAttrStringsProc(Tcl_Obj *pathPtr, Tcl_Obj** objPtrRef); +static int Zip_FSFileAttrsGetProc( + Tcl_Interp *interp, int index, Tcl_Obj *pathPtr, + Tcl_Obj **objPtrRef +); +static int Zip_FSFileAttrsSetProc(Tcl_Interp *interp, int index, Tcl_Obj *pathPtr,Tcl_Obj *objPtr); +static int Zip_FSLoadFile(Tcl_Interp *interp, Tcl_Obj *path, Tcl_LoadHandle *loadHandle, + Tcl_FSUnloadFileProc **unloadProcPtr, int flags); +static void TclZipfs_C_Init(void); + +/* + * 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*/ +}; + + + +/* + *------------------------------------------------------------------------- + * + * 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, +#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, 0); + 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, 0); + } + 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) +{ + Tcl_HashEntry *hPtr; + ZipEntry *z; + Tcl_DString ds; + Tcl_DStringInit(&ds); + hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, filename); + 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) +{ + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + ZipFile *zf; + int match = 0; + hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); + while (hPtr != NULL) { + if ((zf = (ZipFile *) Tcl_GetHashValue(hPtr)) == NULL) continue; + if (strcmp(zf->mntpt, filename) == 0) { + match = 1; + break; + } + hPtr = Tcl_NextHashEntry(&search); + } + 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(zf->namelen) { + free(zf->name); //Allocated by strdup + } + if(zf->is_membuf==1) { + /* Pointer to memory */ + if (zf->tofree != NULL) { + Tcl_Free((char *) zf->tofree); + zf->tofree = NULL; + } + zf->data = NULL; + return; + } +#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; + } + if(zf->chan != NULL) { + Tcl_Close(interp, zf->chan); + zf->chan = NULL; + } +} + +/* + *------------------------------------------------------------------------- + * + * ZipFS_Find_TOC -- + * + * This function takes a memory mapped zip file and indexes the contents. + * 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: + * The given ZipFile struct is filled with information about the ZIP archive file. + * + *------------------------------------------------------------------------- + */ +static int +ZipFS_Find_TOC(Tcl_Interp *interp, int needZip, ZipFile *zf) +{ + int i; + unsigned char *p, *q; + 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; + } + ZIPFS_ERROR(interp,"wrong end signature"); + 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; + } + ZIPFS_ERROR(interp,"empty archive"); + 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; + } + ZIPFS_ERROR(interp,"archive directory not found"); + 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)) { + ZIPFS_ERROR(interp,"wrong header length"); + goto error; + } + if (zip_read_int(q) != ZIP_CENTRAL_HEADER_SIG) { + ZIPFS_ERROR(interp,"wrong header signature"); + 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; +} + +/* + *------------------------------------------------------------------------- + * + * 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; + + zf->is_membuf=0; +#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)) { + ZIPFS_ERROR(interp,"illegal file size"); + goto error; + } + Tcl_Seek(zf->chan, 0, SEEK_SET); + zf->tofree = zf->data = (unsigned char *) Tcl_AttemptAlloc(zf->length); + if (zf->tofree == NULL) { + ZIPFS_ERROR(interp,"out of memory") + goto error; + } + i = Tcl_Read(zf->chan, (char *) zf->data, zf->length); + if (i != zf->length) { + ZIPFS_ERROR(interp,"file read error"); + 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) + ) { + ZIPFS_ERROR(interp,"invalid file size"); + goto error; + } + zf->mh = CreateFileMapping((HANDLE) handle, 0, PAGE_READONLY, 0, + zf->length, 0); + if (zf->mh == INVALID_HANDLE_VALUE) { + ZIPFS_ERROR(interp,"file mapping failed"); + goto error; + } + zf->data = MapViewOfFile(zf->mh, FILE_MAP_READ, 0, 0, zf->length); + if (zf->data == NULL) { + ZIPFS_ERROR(interp,"file mapping failed"); + goto error; + } +#else + zf->length = lseek((int) (long) handle, 0, SEEK_END); + if ((zf->length == -1) || (zf->length < ZIP_CENTRAL_END_LEN)) { + ZIPFS_ERROR(interp,"invalid file size"); + 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) { + ZIPFS_ERROR(interp,"file mapping failed"); + goto error; + } +#endif + } + return ZipFS_Find_TOC(interp,needZip,zf); + +error: + ZipFSCloseArchive(interp, zf); + return TCL_ERROR; +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSRootNode -- + * + * This function generates the root node for a ZIPFS filesystem + * + * Results: + * TCL_OK on success, TCL_ERROR otherwise with an error message + * placed into the given "interp" if it is not NULL. + * + * Side effects: + *------------------------------------------------------------------------- + */ + +static int +ZipFS_Catalogue_Filesystem(Tcl_Interp *interp, ZipFile *zf0, const char *mntpt, const char *passwd, const char *zipname) +{ + int i, pwlen, isNew; + ZipFile *zf; + ZipEntry *z; + Tcl_HashEntry *hPtr; + Tcl_DString ds, dsm, fpBuf; + unsigned char *q; +#if HAS_DRIVES + int drive = 0; +#endif + WriteLock(); + + 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; + } + } + /* + * Mount point sometimes is a relative or otherwise denormalized path. + * But an absolute name is needed as mount point here. + */ + Tcl_DStringInit(&ds); + Tcl_DStringInit(&dsm); + if (strcmp(mntpt, "/") == 0) { + mntpt = ""; + } else { + mntpt = CanonicalPath("",mntpt, &dsm, 1); + } + hPtr = Tcl_CreateHashEntry(&ZipFS.zipHash, mntpt, &isNew); + if (!isNew) { + zf = (ZipFile *) Tcl_GetHashValue(hPtr); + if (interp != NULL) { + Tcl_AppendResult(interp, zf->name, " is already mounted on ", mntpt, (char *) NULL); + } + Unlock(); + ZipFSCloseArchive(interp, zf0); + return TCL_ERROR; + } + zf = (ZipFile *) Tcl_AttemptAlloc(sizeof (*zf) + strlen(mntpt) + 1); + if (zf == NULL) { + if (interp != NULL) { + Tcl_AppendResult(interp, "out of memory", (char *) NULL); + } + Unlock(); + ZipFSCloseArchive(interp, zf0); + return TCL_ERROR; + } + Unlock(); + *zf = *zf0; + zf->mntpt = Tcl_GetHashKey(&ZipFS.zipHash, hPtr); + zf->mntptlen=strlen(zf->mntpt); + zf->name = strdup(zipname); + zf->namelen= strlen(zipname); + 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 = (zf->baseoffs == 0) ? 1 : -1; /* root marker */ + 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; + } + Tcl_DStringFree(&fpBuf); + Tcl_DStringFree(&ds); + Tcl_FSMountsChanged(NULL); + Unlock(); + return TCL_OK; +} + +static void TclZipfs_C_Init(void) { + static const Tcl_Time t = { 0, 0 }; + if (!ZipFS.initialized) { +#ifdef TCL_THREADS + /* + * 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; + } +} + + +/* + *------------------------------------------------------------------------- + * + * 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 *mntpt, + const char *zipname, + const char *passwd +) { + int i, pwlen; + ZipFile *zf; + + ReadLock(); + if (!ZipFS.initialized) { + TclZipfs_C_Init(); + } + if (mntpt == NULL) { + Tcl_HashEntry *hPtr; + 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 (zipname == NULL) { + Tcl_HashEntry *hPtr; + if (interp == NULL) { + Unlock(); + return TCL_OK; + } + hPtr = Tcl_FindHashEntry(&ZipFS.zipHash, mntpt); + if (hPtr != NULL) { + if ((zf = Tcl_GetHashValue(hPtr)) != NULL) { + Tcl_SetObjResult(interp,Tcl_NewStringObj(zf->name, -1)); + } + } + Unlock(); + 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; + } + } + zf = (ZipFile *) Tcl_AttemptAlloc(sizeof (*zf) + strlen(mntpt) + 1); + if (zf == NULL) { + if (interp != NULL) { + Tcl_AppendResult(interp, "out of memory", (char *) NULL); + } + return TCL_ERROR; + } + if (ZipFSOpenArchive(interp, zipname, 1, zf) != TCL_OK) { + return TCL_ERROR; + } + return ZipFS_Catalogue_Filesystem(interp,zf,mntpt,passwd,zipname); +} + +/* + *------------------------------------------------------------------------- + * + * TclZipfs_Mount_Buffer -- + * + * 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_Buffer( + Tcl_Interp *interp, + const char *mntpt, + unsigned char *data, + size_t datalen, + int copy +) { + int i; + ZipFile *zf; + + ReadLock(); + if (!ZipFS.initialized) { + TclZipfs_C_Init(); + } + if (mntpt == NULL) { + Tcl_HashEntry *hPtr; + 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 (data == NULL) { + Tcl_HashEntry *hPtr; + + if (interp == NULL) { + Unlock(); + return TCL_OK; + } + hPtr = Tcl_FindHashEntry(&ZipFS.zipHash, mntpt); + if (hPtr != NULL) { + if ((zf = Tcl_GetHashValue(hPtr)) != NULL) { + Tcl_SetObjResult(interp,Tcl_NewStringObj(zf->name, -1)); + } + } + Unlock(); + return TCL_OK; + } + Unlock(); + zf = (ZipFile *) Tcl_AttemptAlloc(sizeof (*zf) + strlen(mntpt) + 1); + if (zf == NULL) { + if (interp != NULL) { + Tcl_AppendResult(interp, "out of memory", (char *) NULL); + } + return TCL_ERROR; + } + zf->is_membuf=1; + zf->length=datalen; + if(copy) { + zf->data=(unsigned char *)Tcl_AttemptAlloc(datalen); + if (zf->data == NULL) { + if (interp != NULL) { + Tcl_AppendResult(interp, "out of memory", (char *) NULL); + } + return TCL_ERROR; + } + memcpy(zf->data,data,datalen); + zf->tofree=zf->data; + } else { + zf->data=data; + zf->tofree=NULL; + } + if(ZipFS_Find_TOC(interp,0,zf)!=TCL_OK) { + return TCL_ERROR; + } + return ZipFS_Catalogue_Filesystem(interp,zf,mntpt,NULL,"Memory Buffer"); +} + +/* + *------------------------------------------------------------------------- + * + * 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 *mntpt) +{ + ZipFile *zf; + ZipEntry *z, *znext; + Tcl_HashEntry *hPtr; + Tcl_DString dsm; + int ret = TCL_OK, unmounted = 0; + + WriteLock(); + if (!ZipFS.initialized) goto done; + /* + * Mount point 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); + + hPtr = Tcl_FindHashEntry(&ZipFS.zipHash, mntpt); + + /* don't report error */ + if (hPtr == NULL) goto done; + + zf = (ZipFile *) Tcl_GetHashValue(hPtr); + if (zf->nopen > 0) { + ZIPFS_ERROR(interp,"filesystem is busy"); + 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(); + 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, + "?mountpoint? ?zipfile? ?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); +} + +/* + *------------------------------------------------------------------------- + * + * 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 +ZipFSMountBufferObjCmd( + ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[] +) { + const char *mntpt; + unsigned char *data; + int length; + if (objc > 4) { + Tcl_WrongNumArgs(interp, 1, objv, "?mountpoint? ?data?"); + return TCL_ERROR; + } + if(objc<2) { + int i; + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + int ret = TCL_OK; + ZipFile *zf; + + ReadLock(); + 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; + } + mntpt=Tcl_GetString(objv[1]); + if(objc<3) { + Tcl_HashEntry *hPtr; + ZipFile *zf; + + if (interp == NULL) { + Unlock(); + return TCL_OK; + } + hPtr = Tcl_FindHashEntry(&ZipFS.zipHash, mntpt); + if (hPtr != NULL) { + if ((zf = Tcl_GetHashValue(hPtr)) != NULL) { + Tcl_SetObjResult(interp,Tcl_NewStringObj(zf->name, -1)); + } + } + Unlock(); + return TCL_OK; + } + data=Tcl_GetByteArrayFromObj(objv[2],&length); + return TclZipfs_Mount_Buffer(interp, mntpt,data,length,1); +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSRootObjCmd -- + * + * This procedure is invoked to process the "zipfs::root" command. It + * returns the root that all zipfs file systems are mounted under. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSRootObjCmd( + ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[] +) { + Tcl_SetObjResult(interp,Tcl_NewStringObj(ZIPFS_VOLUME, -1)); + return TCL_OK; +} + +/* + *------------------------------------------------------------------------- + * + * 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) { + unsigned 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, (const char *)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("::tcl::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 (pwlen <= 0) { + pw = NULL; + pwlen = 0; + } + if (isImg) { + ZipFile *zf, zf0; + int isMounted = 0; + 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 (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'; + } + /* Check for mounted image */ + WriteLock(); + hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); + while (hPtr != NULL) { + if ((zf = (ZipFile *) Tcl_GetHashValue(hPtr)) != NULL) { + if (strcmp(zf->name, imgName) == 0) { + isMounted = 1; + zf->nopen++; + break; + } + } + hPtr = Tcl_NextHashEntry(&search); + } + Unlock(); + if (!isMounted) { + zf = &zf0; + } + if (isMounted || + (ZipFSOpenArchive(interp, imgName, 0, zf) == TCL_OK)) { + i = Tcl_Write(out, (char *) zf->data, zf->baseoffsp); + if (i != zf->baseoffsp) { + memset(pwbuf, 0, sizeof (pwbuf)); + Tcl_DecrRefCount(list); + Tcl_SetObjResult(interp, Tcl_NewStringObj("write error", -1)); + Tcl_Close(interp, out); + if (zf == &zf0) { + ZipFSCloseArchive(interp, zf); + } else { + WriteLock(); + zf->nopen--; + Unlock(); + } + return TCL_ERROR; + } + if (zf == &zf0) { + ZipFSCloseArchive(interp, zf); + } else { + WriteLock(); + zf->nopen--; + Unlock(); + } + } else { + int k, n, m; + Tcl_Channel in; + const char *errMsg = "seek error"; + + /* + * Fall back to read it as plain file which + * hopefully is a static tclsh or wish binary + * with proper zipfs infrastructure built in. + */ + Tcl_ResetResult(interp); + in = Tcl_OpenFileChannel(interp, imgName, "r", 0644); + if (in == NULL) { + memset(pwbuf, 0, sizeof (pwbuf)); + Tcl_DecrRefCount(list); + Tcl_Close(interp, out); + return TCL_ERROR; + } + Tcl_SetChannelOption(interp, in, "-translation", "binary"); + Tcl_SetChannelOption(interp, in, "-encoding", "binary"); + i = Tcl_Seek(in, 0, SEEK_END); + if (i == -1) { +cperr: + memset(pwbuf, 0, sizeof (pwbuf)); + Tcl_DecrRefCount(list); + Tcl_SetObjResult(interp, Tcl_NewStringObj(errMsg, -1)); + Tcl_Close(interp, out); + Tcl_Close(interp, in); + return TCL_ERROR; + } + Tcl_Seek(in, 0, SEEK_SET); + k = 0; + while (k < i) { + m = i - k; + if (m > sizeof (buf)) { + m = sizeof (buf); + } + n = Tcl_Read(in, buf, m); + if (n == -1) { + errMsg = "read error"; + goto cperr; + } else if (n == 0) { + break; + } + m = Tcl_Write(out, buf, n); + if (m != n) { + errMsg = "write error"; + goto cperr; + } + k += m; + } + Tcl_Close(interp, in); + } + 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_NextHashEntry(&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); +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSZipFSOpenArchiveObjCmd -- + * + * 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); +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSCanonicalObjCmd -- + * + * This procedure is invoked to process the "zipfs::canonical" command. + * It returns the canonical name for a file within zipfs + * + * 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; + Tcl_DString ds; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "filename"); + return TCL_ERROR; + } + + /* prepend ZIPFS_VOLUME to filename, eliding the final / */ + filename = Tcl_GetStringFromObj(objv[1], 0); + Tcl_DStringInit(&ds); + Tcl_DStringAppend(&ds, ZIPFS_VOLUME, ZIPFS_VOLUME_LEN-1); + Tcl_DStringAppend(&ds, filename, -1); + filename = Tcl_DStringValue(&ds); + + 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; +} + +#if defined(_WIN32) || defined(_WIN64) +#define LIBRARY_SIZE 64 +static int +ToUtf( + const WCHAR *wSrc, + char *dst) +{ + char *start; + + start = dst; + while (*wSrc != '\0') { + dst += Tcl_UniCharToUtf(*wSrc, dst); + wSrc++; + } + *dst = '\0'; + return (int) (dst - start); +} +#endif + +Tcl_Obj *TclZipfs_TclLibrary(void) { + if(zipfs_literal_tcl_library) { + return Tcl_NewStringObj(zipfs_literal_tcl_library,-1); + } else { + Tcl_Obj *vfsinitscript; + int found=0; + + /* Look for the library file system within the executable */ + vfsinitscript=Tcl_NewStringObj(ZIPFS_APP_MOUNT "/tcl_library/init.tcl",-1); + Tcl_IncrRefCount(vfsinitscript); + found=Tcl_FSAccess(vfsinitscript,F_OK); + Tcl_DecrRefCount(vfsinitscript); + if(found==TCL_OK) { + zipfs_literal_tcl_library=ZIPFS_APP_MOUNT "/tcl_library"; + return Tcl_NewStringObj(zipfs_literal_tcl_library,-1); + } +#if defined(_WIN32) || defined(_WIN64) + HMODULE hModule = TclWinGetTclInstance(); + WCHAR wName[MAX_PATH + LIBRARY_SIZE]; + char dllname[(MAX_PATH + LIBRARY_SIZE) * TCL_UTF_MAX]; + + if (GetModuleFileNameW(hModule, wName, MAX_PATH) == 0) { + GetModuleFileNameA(hModule, dllname, MAX_PATH); + } else { + ToUtf(wName, dllname); + } + /* Mount zip file and dll before releasing to search */ + if(TclZipfs_AppHook_FindTclInit(dllname)==TCL_OK) { + return Tcl_NewStringObj(zipfs_literal_tcl_library,-1); + } +#else +#ifdef CFG_RUNTIME_DLLFILE + /* Mount zip file and dll before releasing to search */ + if(TclZipfs_AppHook_FindTclInit(CFG_RUNTIME_LIBDIR "/" CFG_RUNTIME_DLLFILE)==TCL_OK) { + return Tcl_NewStringObj(zipfs_literal_tcl_library,-1); + } +#endif +#endif +#ifdef CFG_RUNTIME_ZIPFILE + if(TclZipfs_AppHook_FindTclInit(CFG_RUNTIME_LIBDIR "/" CFG_RUNTIME_ZIPFILE)==TCL_OK) { + return Tcl_NewStringObj(zipfs_literal_tcl_library,-1); + } + if(TclZipfs_AppHook_FindTclInit(CFG_RUNTIME_SCRDIR "/" CFG_RUNTIME_ZIPFILE)==TCL_OK) { + return Tcl_NewStringObj(zipfs_literal_tcl_library,-1); + } +#endif + } + if(zipfs_literal_tcl_library) { + return Tcl_NewStringObj(zipfs_literal_tcl_library,-1); + } + return NULL; +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSTclLibraryObjCmd -- + * + * This procedure is invoked to process the "zipfs::root" command. It + * returns the root that all zipfs file systems are mounted under. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSTclLibraryObjCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]) +{ + Tcl_Obj *pResult; + + pResult=TclZipfs_TclLibrary(); + if(!pResult) { + pResult=Tcl_NewObj(); + } + Tcl_SetObjResult(interp,pResult); + 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 < 0) { + /* + * Special case: when executable combined with ZIP archive file + * read data in front of ZIP, i.e. the executable itself. + */ + nextpos = info->nread + toRead; + if (nextpos > info->zipfile->baseoffs) { + toRead = info->zipfile->baseoffs - info->nread; + nextpos = info->zipfile->baseoffs; + } + if (toRead == 0) { + return 0; + } + memcpy(buf, info->zipfile->data, toRead); + info->nread = nextpos; + *errloc = 0; + return toRead; + } + 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; + unsigned long end; + + if (!info->iswr && (info->isdir < 0)) { + /* + * Special case: when executable combined with ZIP archive file, + * seek within front of ZIP, i.e. the executable itself. + */ + end = info->zipfile->baseoffs; + } else if (info->isdir) { + *errloc = EINVAL; + return -1; + } else { + end = info->nbyte; + } + switch (mode) { + case SEEK_CUR: + offset += info->nread; + break; + case SEEK_END: + offset += end; + 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 > end) { + *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)); + Tcl_AppendResult(interp, " \"", filename, "\"", NULL); + } + 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)) { + ZIPFS_ERROR(interp,"unsupported compression method"); + goto error; + } + if (wr && z->isdir) { + ZIPFS_ERROR(interp,"unsupported file type"); + goto error; + } + if (!trunc) { + flags |= TCL_READABLE; + if (z->isenc && (z->zipfile->pwbuf[0] == 0)) { + ZIPFS_ERROR(interp,"decryption failed"); + goto error; + } else if (wr && (z->data == NULL) && (z->nbyte > ZipFS.wrmax)) { + ZIPFS_ERROR(interp,"file too large"); + goto error; + } + } else { + flags = TCL_WRITABLE; + } + info = (ZipChannel *) Tcl_AttemptAlloc(sizeof (*info)); + if (info == NULL) { + ZIPFS_ERROR(interp,"out of memory"); + 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); + ZIPFS_ERROR(interp,"out of memory"); + 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); + ZIPFS_ERROR(interp,"decompression error"); + 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); + ZIPFS_ERROR(interp,"decompression error"); + 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; + if (!(pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr))) return NULL; + 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; + if (!(pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr))) return -1; + 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; + if (!(pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr))) return -1; + 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; + Tcl_Obj *normPathPtr; + int scnt, len, l, dirOnly = -1, prefixLen, strip = 0; + char *pat, *prefix, *path; + Tcl_DString dsPref; + + if (!(normPathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr))) return -1; + + if (types != NULL) { + dirOnly = (types->type & TCL_GLOB_TYPE_DIR) == TCL_GLOB_TYPE_DIR; + } + + /* the prefix that gets prepended to results */ + prefix = Tcl_GetStringFromObj(pathPtr, &prefixLen); + + /* the (normalized) path we're searching */ + path = Tcl_GetStringFromObj(normPathPtr, &len); + + Tcl_DStringInit(&dsPref); + Tcl_DStringAppend(&dsPref, prefix, prefixLen); + + 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); + 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; + + if (!(pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr))) return -1; + + path = Tcl_GetStringFromObj(pathPtr, &len); + if(strncmp(path,ZIPFS_VOLUME,ZIPFS_VOLUME_LEN)!=0) { + return -1; + } + + len = strlen(path); + + 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(); + 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; + + if (!(pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr))) return -1; + path = Tcl_GetStringFromObj(pathPtr, &len); + ReadLock(); + z = ZipFSLookup(path); + if (z == NULL) { + ZIPFS_ERROR(interp,"file not found"); + 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, z->zipfile->mntptlen); + goto done; + case 4: + *objPtrRef= Tcl_NewStringObj(z->zipfile->name, -1); + goto done; + case 5: + *objPtrRef= Tcl_NewStringObj("0555", -1); + goto done; + } + ZIPFS_ERROR(interp,"unknown attribute"); + 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, TCL_ERROR otherwise with error message left. + * + * 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 manager 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); + ZIPFS_ERROR(interp,Tcl_PosixError(interp)); + return TCL_ERROR; +#else + Tcl_Obj *altPath = NULL; + int ret = TCL_ERROR; + + if (Tcl_FSAccess(path, R_OK) == 0) { + /* + * EXDEV should trigger loading by copying to temp store. + */ + + Tcl_SetErrno(EXDEV); + ZIPFS_ERROR(interp,Tcl_PosixError(interp)); + 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) { +#if TCL_RELEASE_SERIAL < 9 + altPath = TclJoinPath(2, objs); +#else + altPath = TclJoinPath(2, objs, 0); +#endif + 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); + ZIPFS_ERROR(interp,Tcl_PosixError(interp)); + } + if (altPath != NULL) { + Tcl_DecrRefCount(altPath); + } + return ret; +#endif +} + +#endif /* HAVE_ZLIB */ + + + +/* + *------------------------------------------------------------------------- + * + * TclZipfs_Init -- + * + * 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. + * + *------------------------------------------------------------------------- + */ + +MODULE_SCOPE int +TclZipfs_Init(Tcl_Interp *interp) +{ +#ifdef HAVE_ZLIB + /* one-time initialization */ + WriteLock(); + /* Tcl_StaticPackage(interp, "zipfs", TclZipfs_Init, TclZipfs_Init); */ + if (!ZipFS.initialized) { + TclZipfs_C_Init(); + } + Unlock(); + if(interp != NULL) { + static const EnsembleImplMap initMap[] = { + {"mount", ZipFSMountObjCmd, NULL, NULL, NULL, 0}, + {"mount_data", ZipFSMountBufferObjCmd, 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}, + {"root", ZipFSRootObjCmd, NULL, NULL, NULL, 1}, + {"tcl_library", ZipFSTclLibraryObjCmd, NULL, NULL, NULL, 0}, + + {NULL, NULL, NULL, NULL, NULL, 0} + }; + static const char findproc[] = + "namespace eval ::tcl::zipfs::zipfs {}\n" + "proc ::tcl::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 [::tcl::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, "::tcl::zipfs::wrmax", (char *) &ZipFS.wrmax,TCL_LINK_INT); + TclMakeEnsemble(interp, "zipfs", initMap); + Tcl_PkgProvide(interp, "zipfs", "2.0"); + } + return TCL_OK; +#else + ZIPFS_ERROR(interp,"no zlib available"); + return TCL_ERROR; +#endif +} + +static int TclZipfs_AppHook_FindTclInit(const char *archive){ + Tcl_Obj *vfsinitscript; + int found; + if(zipfs_literal_tcl_library) { + return TCL_ERROR; + } + if(TclZipfs_Mount(NULL, ZIPFS_ZIP_MOUNT, archive, NULL)) { + /* Either the file doesn't exist or it is not a zip archive */ + return TCL_ERROR; + } + vfsinitscript=Tcl_NewStringObj(ZIPFS_ZIP_MOUNT "/init.tcl",-1); + Tcl_IncrRefCount(vfsinitscript); + found=Tcl_FSAccess(vfsinitscript,F_OK); + Tcl_DecrRefCount(vfsinitscript); + if(found==0) { + zipfs_literal_tcl_library=ZIPFS_ZIP_MOUNT; + return TCL_OK; + } + vfsinitscript=Tcl_NewStringObj(ZIPFS_ZIP_MOUNT "/tcl_library/init.tcl",-1); + Tcl_IncrRefCount(vfsinitscript); + found=Tcl_FSAccess(vfsinitscript,F_OK); + Tcl_DecrRefCount(vfsinitscript); + if(found==0) { + zipfs_literal_tcl_library=ZIPFS_ZIP_MOUNT "/tcl_library"; + return TCL_OK; + } + return TCL_ERROR; +} + +#if defined(_WIN32) || defined(_WIN64) +int TclZipfs_AppHook(int *argc, TCHAR ***argv) +#else +int TclZipfs_AppHook(int *argc, char ***argv) +#endif +{ + /* + * Tclkit_MainHook -- + * Performs the argument munging for the shell + */ + char *archive; + + Tcl_FindExecutable(*argv[0]); + archive=(char *)Tcl_GetNameOfExecutable(); + TclZipfs_Init(NULL); + /* + ** Look for init.tcl in one of the locations mounted later in this function + */ + if(!TclZipfs_Mount(NULL, ZIPFS_APP_MOUNT, archive, NULL)) { + int found; + Tcl_Obj *vfsinitscript; + vfsinitscript=Tcl_NewStringObj(ZIPFS_APP_MOUNT "/main.tcl",-1); + Tcl_IncrRefCount(vfsinitscript); + if(Tcl_FSAccess(vfsinitscript,F_OK)==0) { + /* Startup script should be set before calling Tcl_AppInit */ + Tcl_SetStartupScript(vfsinitscript,NULL); + } else { + Tcl_DecrRefCount(vfsinitscript); + } + /* Set Tcl Encodings */ + if(!zipfs_literal_tcl_library) { + vfsinitscript=Tcl_NewStringObj(ZIPFS_APP_MOUNT "/tcl_library/init.tcl",-1); + Tcl_IncrRefCount(vfsinitscript); + found=Tcl_FSAccess(vfsinitscript,F_OK); + Tcl_DecrRefCount(vfsinitscript); + if(found==TCL_OK) { + zipfs_literal_tcl_library=ZIPFS_APP_MOUNT "/tcl_library"; + return TCL_OK; + } + } + } else if (*argc>1) { +#if defined(_WIN32) || defined(_WIN64) + Tcl_DString ds; + strcpy(archive, Tcl_WinTCharToUtf((*argv)[1], -1, &ds)); + Tcl_DStringFree(&ds); +#else + archive=(*argv)[1]; +#endif + if(strcmp(archive,"install")==0) { + /* If the first argument is mkzip, run the mkzip program */ + Tcl_Obj *vfsinitscript; + /* Run this now to ensure the file is present by the time Tcl_Main wants it */ + TclZipfs_TclLibrary(); + vfsinitscript=Tcl_NewStringObj(ZIPFS_ZIP_MOUNT "/tcl_library/install.tcl",-1); + Tcl_IncrRefCount(vfsinitscript); + if(Tcl_FSAccess(vfsinitscript,F_OK)==0) { + Tcl_SetStartupScript(vfsinitscript,NULL); + } + return TCL_OK; + } else { + if(!TclZipfs_Mount(NULL, ZIPFS_APP_MOUNT, archive, NULL)) { + int found; + Tcl_Obj *vfsinitscript; + vfsinitscript=Tcl_NewStringObj(ZIPFS_APP_MOUNT "/main.tcl",-1); + Tcl_IncrRefCount(vfsinitscript); + if(Tcl_FSAccess(vfsinitscript,F_OK)==0) { + /* Startup script should be set before calling Tcl_AppInit */ + Tcl_SetStartupScript(vfsinitscript,NULL); + } else { + Tcl_DecrRefCount(vfsinitscript); + } + /* Set Tcl Encodings */ + vfsinitscript=Tcl_NewStringObj(ZIPFS_APP_MOUNT "/tcl_library/init.tcl",-1); + Tcl_IncrRefCount(vfsinitscript); + found=Tcl_FSAccess(vfsinitscript,F_OK); + Tcl_DecrRefCount(vfsinitscript); + if(found==TCL_OK) { + zipfs_literal_tcl_library=ZIPFS_APP_MOUNT "/tcl_library"; + return TCL_OK; + } + } + } + } + return TCL_OK; +} + + + +#ifndef HAVE_ZLIB + +/* + *------------------------------------------------------------------------- + * + * TclZipfs_Mount, TclZipfs_Unmount -- + * + * Dummy version when no ZLIB support available. + * + *------------------------------------------------------------------------- + */ + +int +TclZipfs_Mount(Tcl_Interp *interp, const char *mntpt, const char *zipname, + const char *passwd) +{ + return TclZipfs_Init(interp, 1); +} + +int +TclZipfs_Unmount(Tcl_Interp *interp, const char *zipname) +{ + return TclZipfs_Init(interp, 1); +} + +#endif + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ ADDED config.tcl.in Index: config.tcl.in ================================================================== --- /dev/null +++ config.tcl.in @@ -0,0 +1,83 @@ +### +# Tcl Parsable version of data from xxxConfig.sh +### +name {@PACKAGE_NAME@} +version {@PACKAGE_VERSION@} +libfile {@PKG_LIB_FILE@} +srcdir {@srcdir@} +prefix {@prefix@} +exec_prefix {@exec_prefix@} +exeext {@EXEEXT@} +tk {@TEA_TK_EXTENSION@} + +bindir {@bindir@} +libdir {@libdir@} +includedir {@includedir@} +datarootdir {@datarootdir@} +datadir {@datadir@} +mandir {@mandir@} +cleanfiles {@CLEANFILES@} + +AR {@AR@} +CC {@CC@} +CFLAGS {@CFLAGS@} +CFLAGS_DEBUG {@CFLAGS_DEBUG@} +CFLAGS_OPTIMIZE {@CFLAGS_OPTIMIZE@} +CFLAGS_DEFAULT {@CFLAGS_DEFAULT@} +CFLAGS_WARNING {@CFLAGS_WARNING@} +CPPFLAGS {@CPPFLAGS@} +DEFS {@DEFS@ @PKG_CFLAGS@} +EXEEXT {@EXEEXT@} +LDFLAGS {@LDFLAGS@} +LDFLAGS_DEFAULT {@LDFLAGS_DEFAULT@} +LIBS {@PKG_LIBS@ @LIBS@} +MAKE_LIB {@MAKE_LIB@} +MAKE_SHARED_LIB {@MAKE_SHARED_LIB@} +MAKE_STATIC_LIB {@MAKE_STATIC_LIB@} +MAKE_STUB_LIB {@MAKE_STUB_LIB@} +OBJEXT {@OBJEXT@} +PKG_CFLAGS {@PKG_CFLAGS@} +RANLIB {@RANLIB@} +RANLIB_STUB {@RANLIB_STUB@} + +SHELL {@SHELL@} + +SHARED_BUILD {@SHARED_BUILD@} + +SHLIB_CFLAGS {@SHLIB_CFLAGS@} +SHLIB_LD {@SHLIB_LD@} +SHLIB_LD_LIBS {@SHLIB_LD_LIBS@} +SHLIB_SUFFIX {@SHLIB_SUFFIX@} +STLIB_LD {@STLIB_LD@} +TCL_DEFS {@TCL_DEFS@} +TCL_VERSION {@TCL_VERSION@} +TCL_PATCH_LEVEL {@TCL_PATCH_LEVEL@} +TCL_BIN_DIR {@TCL_BIN_DIR@} +TCL_SRC_DIR {@TCL_SRC_DIR@} +TEA_TK_EXTENSION {@TEA_TK_EXTENSION@} + +TK_VERSION {@TK_VERSION@} +TK_PATCH_LEVEL {@TK_PATCH_LEVEL@} +TK_BIN_DIR {@TK_BIN_DIR@} +TK_SRC_DIR {@TK_SRC_DIR@} + +TEA_PLATFORM {@TEA_PLATFORM@} +TEA_WINDOWINGSYSTEM {@TEA_WINDOWINGSYSTEM@} +TEA_SYSTEM {@TEA_SYSTEM@} +TEACUP_OS {@TEACUP_OS@} +TEACUP_ARCH {@TEACUP_ARCH@} +TEACUP_TOOLSET {@TEACUP_TOOLSET@} +TEACUP_PROFILE {@TEACUP_PROFILE@} +TEACUP_ZIPFILE {@PACKAGE_NAME@-@PACKAGE_VERSION@-@TEACUP_PROFILE@.zip} + +PRACTCL_DEFS {@PRACTCL_DEFS@} +PRACTCL_TOOLSET {@PRACTCL_TOOLSET@} +PRACTCL_SHARED_LIB {@PRACTCL_SHARED_LIB@} +PRACTCL_STATIC_LIB {@PRACTCL_STATIC_LIB@} +PRACTCL_STUB_LIB {@PRACTCL_STUB_LIB@} +PRACTCL_LIBS {@PKG_LIBS@ @LIBS@} +PRACTCL_VC_MANIFEST_EMBED_DLL {@PRACTCL_VC_MANIFEST_EMBED_DLL@} +PRACTCL_VC_MANIFEST_EMBED_EXE {@PRACTCL_VC_MANIFEST_EMBED_EXE@} +PRACTCL_NAME_LIBRARY {@PRACTCL_NAME_LIBRARY@} + +PRACTCL_PKG_LIBS {@PKG_LIBS@} ADDED practcl.tcl Index: practcl.tcl ================================================================== --- /dev/null +++ practcl.tcl @@ -0,0 +1,8547 @@ +### +# Amalgamated package for practcl +# Do not edit directly, tweak the source in src/ and rerun +# build.tcl +### +package require Tcl 8.6 +package provide practcl 0.16.3 +namespace eval ::practcl {} + +### +# START: httpwget/wget.tcl +### + +### +# END: httpwget/wget.tcl +### +### +# START: clay/clay.tcl +### +package provide clay 0.8.1 +namespace eval ::clay { +} +namespace eval ::clay { +} +set ::clay::trace 0 +proc ::clay::PROC {name arglist body {ninja {}}} { + if {[info commands $name] ne {}} return + proc $name $arglist $body + eval $ninja +} +if {[info commands ::PROC] eq {}} { + namespace eval ::clay { namespace export PROC } + namespace eval :: { namespace import ::clay::PROC } +} +proc ::clay::_ancestors {resultvar class} { + upvar 1 $resultvar result + if {$class in $result} { + return + } + lappend result $class + foreach aclass [::info class superclasses $class] { + _ancestors result $aclass + } +} +proc ::clay::ancestors {args} { + set result {} + set queue {} + set metaclasses {} + + foreach class $args { + set ancestors($class) {} + _ancestors ancestors($class) $class + } + foreach class [lreverse $args] { + foreach aclass $ancestors($class) { + if {$aclass in $result} continue + set skip 0 + foreach bclass $args { + if {$class eq $bclass} continue + if {$aclass in $ancestors($bclass)} { + set skip 1 + break + } + } + if {$skip} continue + lappend result $aclass + } + } + foreach class [lreverse $args] { + foreach aclass $ancestors($class) { + if {$aclass in $result} continue + lappend result $aclass + } + } + ### + # Screen out classes that do not participate in clay + # interactions + ### + set output {} + foreach {item} $result { + if {[catch {$item clay noop} err]} { + continue + } + lappend output $item + } + return $output +} +proc ::clay::args_to_dict args { + if {[llength $args]==1} { + return [lindex $args 0] + } + return $args +} +proc ::clay::args_to_options args { + set result {} + foreach {var val} [args_to_dict {*}$args] { + lappend result [string trim $var -:] $val + } + return $result +} +proc ::clay::dynamic_arguments {ensemble method arglist args} { + set idx 0 + set len [llength $args] + if {$len > [llength $arglist]} { + ### + # Catch if the user supplies too many arguments + ### + set dargs 0 + if {[lindex $arglist end] ni {args dictargs}} { + return -code error -level 2 "Usage: $ensemble $method [string trim [dynamic_wrongargs_message $arglist]]" + } + } + foreach argdef $arglist { + if {$argdef eq "args"} { + ### + # Perform args processing in the style of tcl + ### + uplevel 1 [list set args [lrange $args $idx end]] + break + } + if {$argdef eq "dictargs"} { + ### + # Perform args processing in the style of tcl + ### + uplevel 1 [list set args [lrange $args $idx end]] + ### + # Perform args processing in the style of clay + ### + set dictargs [::clay::args_to_options {*}[lrange $args $idx end]] + uplevel 1 [list set dictargs $dictargs] + break + } + if {$idx > $len} { + ### + # Catch if the user supplies too few arguments + ### + if {[llength $argdef]==1} { + return -code error -level 2 "Usage: $ensemble $method [string trim [dynamic_wrongargs_message $arglist]]" + } else { + uplevel 1 [list set [lindex $argdef 0] [lindex $argdef 1]] + } + } else { + uplevel 1 [list set [lindex $argdef 0] [lindex $args $idx]] + } + incr idx + } +} +proc ::clay::dynamic_wrongargs_message {arglist} { + set result "" + set dargs 0 + foreach argdef $arglist { + if {$argdef in {args dictargs}} { + set dargs 1 + break + } + if {[llength $argdef]==1} { + append result " $argdef" + } else { + append result " ?[lindex $argdef 0]?" + } + } + if { $dargs } { + append result " ?option value?..." + } + return $result +} +proc ::clay::is_dict { d } { + # is it a dict, or can it be treated like one? + if {[catch {::dict size $d} err]} { + #::set ::errorInfo {} + return 0 + } + return 1 +} +proc ::clay::is_null value { + return [expr {$value in {{} NULL}}] +} +proc ::clay::leaf args { + set marker [string index [lindex $args end] end] + set result [path {*}${args}] + if {$marker eq "/"} { + return $result + } + return [list {*}[lrange $result 0 end-1] [string trim [string trim [lindex $result end]] /]] +} +proc ::clay::K {a b} {set a} +if {[info commands ::K] eq {}} { + namespace eval ::clay { namespace export K } + namespace eval :: { namespace import ::clay::K } +} +proc ::clay::noop args {} +if {[info commands ::noop] eq {}} { + namespace eval ::clay { namespace export noop } + namespace eval :: { namespace import ::clay::noop } +} +proc ::clay::path args { + set result {} + foreach item $args { + set item [string trim $item :./] + foreach subitem [split $item /] { + lappend result [string trim ${subitem}]/ + } + } + return $result +} +proc ::clay::putb {buffername args} { + upvar 1 $buffername buffer + switch [llength $args] { + 1 { + append buffer [lindex $args 0] \n + } + 2 { + append buffer [string map {*}$args] \n + } + default { + error "usage: putb buffername ?map? string" + } + } +} +if {[info command ::putb] eq {}} { + namespace eval ::clay { namespace export putb } + namespace eval :: { namespace import ::clay::putb } +} +proc ::clay::script_path {} { + set path [file dirname [file join [pwd] [info script]]] + return $path +} +proc ::clay::NSNormalize qualname { + if {![string match ::* $qualname]} { + set qualname ::clay::classes::$qualname + } + regsub -all {::+} $qualname "::" +} +proc ::clay::uuid_generate args { + return [uuid generate] +} +namespace eval ::clay { + variable option_class {} + variable core_classes {::oo::class ::oo::object} +} +package require Tcl 8.6 ;# try in pipeline.tcl. Possibly other things. +if {[info commands irmmd5] eq {}} { + if {[catch {package require odielibc}]} { + package require md5 2 + } +} +::namespace eval ::clay { +} +::namespace eval ::clay::classes { +} +::namespace eval ::clay::define { +} +::namespace eval ::clay::tree { +} +::namespace eval ::clay::dict { +} +::namespace eval ::clay::list { +} +::namespace eval ::clay::uuid { +} +if {![info exists ::clay::idle_destroy]} { + set ::clay::idle_destroy {} +} +namespace eval ::clay::uuid { + namespace export uuid +} +proc ::clay::uuid::generate_tcl_machinfo {} { + variable machinfo + if {[info exists machinfo]} { + return $machinfo + } + lappend machinfo [clock seconds]; # timestamp + lappend machinfo [clock clicks]; # system incrementing counter + lappend machinfo [info hostname]; # spatial unique id (poor) + lappend machinfo [pid]; # additional entropy + lappend machinfo [array get ::tcl_platform] + + ### + # If we have /dev/urandom just stream 128 bits from that + ### + if {[file exists /dev/urandom]} { + set fin [open /dev/urandom r] + binary scan [read $fin 128] H* machinfo + close $fin + } elseif {[catch {package require nettool}]} { + # More spatial information -- better than hostname. + # bug 1150714: opening a server socket may raise a warning messagebox + # with WinXP firewall, using ipconfig will return all IP addresses + # including ipv6 ones if available. ipconfig is OK on win98+ + if {[string equal $::tcl_platform(platform) "windows"]} { + catch {exec ipconfig} config + lappend machinfo $config + } else { + catch { + set s [socket -server void -myaddr [info hostname] 0] + ::clay::K [fconfigure $s -sockname] [close $s] + } r + lappend machinfo $r + } + + if {[package provide Tk] != {}} { + lappend machinfo [winfo pointerxy .] + lappend machinfo [winfo id .] + } + } else { + ### + # If the nettool package works on this platform + # use the stream of hardware ids from it + ### + lappend machinfo {*}[::nettool::hwid_list] + } + return $machinfo +} +if {[info commands irmmd5] ne {}} { +proc ::clay::uuid::generate {{type {}}} { + variable nextuuid + set s [irmmd5 "$type [incr nextuuid(type)] [generate_tcl_machinfo]"] + foreach {a b} {0 7 8 11 12 15 16 19 20 31} { + append r [string range $s $a $b] - + } + return [string tolower [string trimright $r -]] +} +proc ::clay::uuid::short {{type {}}} { + variable nextuuid + set r [irmmd5 "$type [incr nextuuid(type)] [generate_tcl_machinfo]"] + return [string range $r 0 16] +} + +} else { +package require md5 2 +proc ::clay::uuid::raw {{type {}}} { + variable nextuuid + set tok [md5::MD5Init] + md5::MD5Update $tok "$type [incr nextuuid($type)] [generate_tcl_machinfo]" + set r [md5::MD5Final $tok] + return $r + #return [::clay::uuid::tostring $r] +} +proc ::clay::uuid::generate {{type {}}} { + return [::clay::uuid::tostring [::clay::uuid::raw $type]] +} +proc ::clay::uuid::short {{type {}}} { + set r [::clay::uuid::raw $type] + binary scan $r H* s + return [string range $s 0 16] +} +} +proc ::clay::uuid::tostring {uuid} { + binary scan $uuid H* s + foreach {a b} {0 7 8 11 12 15 16 19 20 31} { + append r [string range $s $a $b] - + } + return [string tolower [string trimright $r -]] +} +proc ::clay::uuid::fromstring {uuid} { + return [binary format H* [string map {- {}} $uuid]] +} +proc ::clay::uuid::equal {left right} { + set l [fromstring $left] + set r [fromstring $right] + return [string equal $l $r] +} +proc ::clay::uuid {cmd args} { + switch -exact -- $cmd { + generate { + return [::clay::uuid::generate {*}$args] + } + short { + set uuid [::clay::uuid::short {*}$args] + } + equal { + tailcall ::clay::uuid::equal {*}$args + } + default { + return -code error "bad option \"$cmd\":\ + must be generate or equal" + } + } +} +::clay::PROC ::tcl::dict::getnull {dictionary args} { + if {[exists $dictionary {*}$args]} { + get $dictionary {*}$args + } +} { + namespace ensemble configure dict -map [dict replace\ + [namespace ensemble configure dict -map] getnull ::tcl::dict::getnull] +} +::clay::PROC ::tcl::dict::is_dict { d } { + # is it a dict, or can it be treated like one? + if {[catch {dict size $d} err]} { + #::set ::errorInfo {} + return 0 + } + return 1 +} { + namespace ensemble configure dict -map [dict replace\ + [namespace ensemble configure dict -map] is_dict ::tcl::dict::is_dict] +} +::clay::PROC ::tcl::dict::rmerge {args} { + ::set result [dict create . {}] + # Merge b into a, and handle nested dicts appropriately + ::foreach b $args { + for { k v } $b { + ::set field [string trim $k :/] + if {![::clay::tree::is_branch $b $k]} { + # Element names that end in ":" are assumed to be literals + set result $k $v + } elseif { [exists $result $k] } { + # key exists in a and b? let's see if both values are dicts + # both are dicts, so merge the dicts + if { [is_dict [get $result $k]] && [is_dict $v] } { + set result $k [rmerge [get $result $k] $v] + } else { + set result $k $v + } + } else { + set result $k $v + } + } + } + return $result +} { + namespace ensemble configure dict -map [dict replace\ + [namespace ensemble configure dict -map] rmerge ::tcl::dict::rmerge] +} +::clay::PROC ::clay::tree::is_branch { dict path } { + set field [lindex $path end] + if {[string index $field end] eq ":"} { + return 0 + } + if {[string index $field 0] eq "."} { + return 0 + } + if {[string index $field end] eq "/"} { + return 1 + } + return [dict exists $dict {*}$path .] +} +::clay::PROC ::clay::tree::print {dict} { + ::set result {} + ::set level -1 + ::clay::tree::_dictputb $level result $dict + return $result +} +::clay::PROC ::clay::tree::_dictputb {level varname dict} { + upvar 1 $varname result + incr level + dict for {field value} $dict { + if {$field eq "."} continue + if {[clay::tree::is_branch $dict $field]} { + putb result "[string repeat " " $level]$field \{" + _dictputb $level result $value + putb result "[string repeat " " $level]\}" + } else { + putb result "[string repeat " " $level][list $field $value]" + } + } +} +proc ::clay::tree::sanitize {dict} { + ::set result {} + ::set level -1 + ::clay::tree::_sanitizeb {} result $dict + return $result +} +proc ::clay::tree::_sanitizeb {path varname dict} { + upvar 1 $varname result + dict for {field value} $dict { + if {$field eq "."} continue + if {[clay::tree::is_branch $dict $field]} { + _sanitizeb [list {*}$path $field] result $value + } else { + dict set result {*}$path $field $value + } + } +} +proc ::clay::tree::storage {rawpath} { + set isleafvar 0 + set path {} + set tail [string index $rawpath end] + foreach element $rawpath { + set items [split [string trim $element /] /] + foreach item $items { + if {$item eq {}} continue + lappend path $item + } + } + return $path +} +proc ::clay::tree::dictset {varname args} { + upvar 1 $varname result + if {[llength $args] < 2} { + error "Usage: ?path...? path value" + } elseif {[llength $args]==2} { + set rawpath [lindex $args 0] + } else { + set rawpath [lrange $args 0 end-1] + } + set value [lindex $args end] + set path [storage $rawpath] + set dot . + set one {} + dict set result $dot $one + set dpath {} + foreach item [lrange $path 0 end-1] { + set field $item + lappend dpath [string trim $item /] + dict set result {*}$dpath $dot $one + } + set field [lindex $rawpath end] + set ext [string index $field end] + if {$ext eq {:} || ![dict is_dict $value]} { + dict set result {*}$path $value + return + } + if {$ext eq {/} && ![dict exists $result {*}$path $dot]} { + dict set result {*}$path $dot $one + } + if {[dict exists $result {*}$path $dot]} { + dict set result {*}$path [::clay::tree::merge [dict get $result {*}$path] $value] + return + } + dict set result {*}$path $value +} +proc ::clay::tree::dictmerge {varname args} { + upvar 1 $varname result + set dot . + set one {} + dict set result $dot $one + foreach dict $args { + dict for {f v} $dict { + set field [string trim $f /] + set bbranch [clay::tree::is_branch $dict $f] + if {![dict exists $result $field]} { + dict set result $field $v + if {$bbranch} { + dict set result $field [clay::tree::merge $v] + } else { + dict set result $field $v + } + } elseif {[dict exists $result $field $dot]} { + if {$bbranch} { + dict set result $field [clay::tree::merge [dict get $result $field] $v] + } else { + dict set result $field $v + } + } + } + } + return $result +} +proc ::clay::tree::merge {args} { + ### + # The result of a merge is always a dict with branches + ### + set dot . + set one {} + dict set result $dot $one + set argument 0 + foreach b $args { + # Merge b into a, and handle nested dicts appropriately + if {![dict is_dict $b]} { + error "Element $b is not a dictionary" + } + dict for { k v } $b { + if {$k eq $dot} { + dict set result $dot $one + continue + } + set bbranch [is_branch $b $k] + set field [string trim $k /] + if { ![dict exists $result $field] } { + if {$bbranch} { + dict set result $field [merge $v] + } else { + dict set result $field $v + } + } else { + set abranch [dict exists $result $field $dot] + if {$abranch && $bbranch} { + dict set result $field [merge [dict get $result $field] $v] + } else { + dict set result $field $v + if {$bbranch} { + dict set result $field $dot $one + } + } + } + } + } + return $result +} +::clay::PROC ::tcl::dict::isnull {dictionary args} { + if {![exists $dictionary {*}$args]} {return 1} + return [expr {[get $dictionary {*}$args] in {{} NULL null}}] +} { + namespace ensemble configure dict -map [dict replace\ + [namespace ensemble configure dict -map] isnull ::tcl::dict::isnull] +} +::clay::PROC ::clay::ladd {varname args} { + upvar 1 $varname var + if ![info exists var] { + set var {} + } + foreach item $args { + if {$item in $var} continue + lappend var $item + } + return $var +} +::clay::PROC ::clay::ldelete {varname args} { + upvar 1 $varname var + if ![info exists var] { + return + } + foreach item [lsort -unique $args] { + while {[set i [lsearch $var $item]]>=0} { + set var [lreplace $var $i $i] + } + } + return $var +} +::clay::PROC ::clay::lrandom list { + set len [llength $list] + set idx [expr int(rand()*$len)] + return [lindex $list $idx] +} +namespace eval ::dictargs { +} +if {[info commands ::dictargs::parse] eq {}} { + proc ::dictargs::parse {argdef argdict} { + set result {} + dict for {field info} $argdef { + if {![string is alnum [string index $field 0]]} { + error "$field is not a simple variable name" + } + upvar 1 $field _var + set aliases {} + if {[dict exists $argdict $field]} { + set _var [dict get $argdict $field] + continue + } + if {[dict exists $info aliases:]} { + set found 0 + foreach {name} [dict get $info aliases:] { + if {[dict exists $argdict $name]} { + set _var [dict get $argdict $name] + set found 1 + break + } + } + if {$found} continue + } + if {[dict exists $info default:]} { + set _var [dict get $info default:] + continue + } + set mandatory 1 + if {[dict exists $info mandatory:]} { + set mandatory [dict get $info mandatory:] + } + if {$mandatory} { + error "$field is required" + } + } + } +} +proc ::dictargs::proc {name argspec body} { + set result {} + append result "::dictargs::parse \{$argspec\} \$args" \; + append result $body + uplevel 1 [list ::proc $name [list [list args [list dictargs $argspec]]] $result] +} +proc ::dictargs::method {name argspec body} { + set class [lindex [::info level -1] 1] + set result {} + append result "::dictargs::parse \{$argspec\} \$args" \; + append result $body + oo::define $class method $name [list [list args [list dictargs $argspec]]] $result +} +namespace eval ::clay::dialect { + namespace export create + foreach {flag test} { + tip470 {package vsatisfies [package provide Tcl] 8.7} + } { + if {![info exists ::clay::dialect::has($flag)]} { + set ::clay::dialect::has($flag) [eval $test] + } + } +} +proc ::clay::dialect::Push {class} { + ::variable class_stack + lappend class_stack $class +} +proc ::clay::dialect::Peek {} { + ::variable class_stack + return [lindex $class_stack end] +} +proc ::clay::dialect::Pop {} { + ::variable class_stack + set class_stack [lrange $class_stack 0 end-1] +} +if {$::clay::dialect::has(tip470)} { +proc ::clay::dialect::current_class {} { + return [uplevel 1 self] +} +} else { +proc ::clay::dialect::current_class {} { + tailcall Peek +} +} +proc ::clay::dialect::create {name {parent ""}} { + variable has + set NSPACE [NSNormalize [uplevel 1 {namespace current}] $name] + ::namespace eval $NSPACE {::namespace eval define {}} + ### + # Build the "define" namespace + ### + + if {$parent eq ""} { + ### + # With no "parent" language, begin with all of the keywords in + # oo::define + ### + foreach command [info commands ::oo::define::*] { + set procname [namespace tail $command] + interp alias {} ${NSPACE}::define::$procname {} \ + ::clay::dialect::DefineThunk $procname + } + # Create an empty dynamic_methods proc + proc ${NSPACE}::dynamic_methods {class} {} + namespace eval $NSPACE { + ::namespace export dynamic_methods + ::namespace eval define {::namespace export *} + } + set ANCESTORS {} + } else { + ### + # If we have a parent language, that language already has the + # [oo::define] keywords as well as additional keywords and behaviors. + # We should begin with that + ### + set pnspace [NSNormalize [uplevel 1 {namespace current}] $parent] + apply [list parent { + ::namespace export dynamic_methods + ::namespace import -force ${parent}::dynamic_methods + } $NSPACE] $pnspace + + apply [list parent { + ::namespace import -force ${parent}::define::* + ::namespace export * + } ${NSPACE}::define] $pnspace + set ANCESTORS [list ${pnspace}::object] + } + ### + # Build our dialect template functions + ### + proc ${NSPACE}::define {oclass args} [string map [list %NSPACE% $NSPACE] { + ### + # To facilitate library reloading, allow + # a dialect to create a class from DEFINE + ### + set class [::clay::dialect::NSNormalize [uplevel 1 {namespace current}] $oclass] + if {[info commands $class] eq {}} { + %NSPACE%::class create $class {*}${args} + } else { + ::clay::dialect::Define %NSPACE% $class {*}${args} + } +}] + interp alias {} ${NSPACE}::define::current_class {} \ + ::clay::dialect::current_class + interp alias {} ${NSPACE}::define::aliases {} \ + ::clay::dialect::Aliases $NSPACE + interp alias {} ${NSPACE}::define::superclass {} \ + ::clay::dialect::SuperClass $NSPACE + + if {[info command ${NSPACE}::class] ne {}} { + ::rename ${NSPACE}::class {} + } + ### + # Build the metaclass for our language + ### + ::oo::class create ${NSPACE}::class { + superclass ::clay::dialect::MotherOfAllMetaClasses + } + # Wire up the create method to add in the extra argument we need; the + # MotherOfAllMetaClasses will know what to do with it. + ::oo::objdefine ${NSPACE}::class \ + method create {name {definitionScript ""}} \ + "next \$name [list ${NSPACE}::define] \$definitionScript" + + ### + # Build the mother of all classes. Note that $ANCESTORS is already + # guaranteed to be a list in canonical form. + ### + uplevel #0 [string map [list %NSPACE% [list $NSPACE] %name% [list $name] %ANCESTORS% $ANCESTORS] { + %NSPACE%::class create %NSPACE%::object { + superclass %ANCESTORS% + # Put MOACish stuff in here + } + }] + if { "${NSPACE}::class" ni $::clay::dialect::core_classes } { + lappend ::clay::dialect::core_classes "${NSPACE}::class" + } + if { "${NSPACE}::object" ni $::clay::dialect::core_classes } { + lappend ::clay::dialect::core_classes "${NSPACE}::object" + } +} +proc ::clay::dialect::NSNormalize {namespace qualname} { + if {![string match ::* $qualname]} { + set qualname ${namespace}::$qualname + } + regsub -all {::+} $qualname "::" +} +proc ::clay::dialect::DefineThunk {target args} { + tailcall ::oo::define [Peek] $target {*}$args +} +proc ::clay::dialect::Canonical {namespace NSpace class} { + namespace upvar $namespace cname cname + #if {[string match ::* $class]} { + # return $class + #} + if {[info exists cname($class)]} { + return $cname($class) + } + if {[info exists ::clay::dialect::cname($class)]} { + return $::clay::dialect::cname($class) + } + if {[info exists ::clay::dialect::cname(${NSpace}::${class})]} { + return $::clay::dialect::cname(${NSpace}::${class}) + } + foreach item [list "${NSpace}::$class" "::$class"] { + if {[info commands $item] ne {}} { + return $item + } + } + return ${NSpace}::$class +} +proc ::clay::dialect::Define {namespace class args} { + Push $class + try { + if {[llength $args]==1} { + namespace eval ${namespace}::define [lindex $args 0] + } else { + ${namespace}::define::[lindex $args 0] {*}[lrange $args 1 end] + } + ${namespace}::dynamic_methods $class + } finally { + Pop + } +} +proc ::clay::dialect::Aliases {namespace args} { + set class [Peek] + namespace upvar $namespace cname cname + set NSpace [join [lrange [split $class ::] 1 end-2] ::] + set cname($class) $class + foreach name $args { + set cname($name) $class + #set alias $name + set alias [NSNormalize $NSpace $name] + # Add a local metaclass reference + if {![info exists ::clay::dialect::cname($alias)]} { + lappend ::clay::dialect::aliases($class) $alias + ## + # Add a global reference, first come, first served + ## + set ::clay::dialect::cname($alias) $class + } + } +} +proc ::clay::dialect::SuperClass {namespace args} { + set class [Peek] + namespace upvar $namespace class_info class_info + dict set class_info($class) superclass 1 + set ::clay::dialect::cname($class) $class + set NSpace [join [lrange [split $class ::] 1 end-2] ::] + set unique {} + foreach item $args { + set Item [Canonical $namespace $NSpace $item] + dict set unique $Item $item + } + set root ${namespace}::object + if {$class ne $root} { + dict set unique $root $root + } + tailcall ::oo::define $class superclass {*}[dict keys $unique] +} +if {[info command ::clay::dialect::MotherOfAllMetaClasses] eq {}} { +::oo::class create ::clay::dialect::MotherOfAllMetaClasses { + superclass ::oo::class + constructor {define definitionScript} { + $define [self] { + superclass + } + $define [self] $definitionScript + } + method aliases {} { + if {[info exists ::clay::dialect::aliases([self])]} { + return $::clay::dialect::aliases([self]) + } + } +} +} +namespace eval ::clay::dialect { + variable core_classes {::oo::class ::oo::object} +} +::clay::dialect::create ::clay +proc ::clay::dynamic_methods class { + foreach command [info commands [namespace current]::dynamic_methods_*] { + $command $class + } +} +proc ::clay::dynamic_methods_class {thisclass} { + set methods {} + set mdata [$thisclass clay find class_typemethod] + foreach {method info} $mdata { + if {$method eq {.}} continue + set method [string trimright $method :/-] + if {$method in $methods} continue + lappend methods $method + set arglist [dict getnull $info arglist] + set body [dict getnull $info body] + ::oo::objdefine $thisclass method $method $arglist $body + } +} +proc ::clay::define::Array {name {values {}}} { + set class [current_class] + set name [string trim $name :/] + $class clay branch array $name + dict for {var val} $values { + $class clay set array/ $name $var $val + } +} +proc ::clay::define::Delegate {name info} { + set class [current_class] + foreach {field value} $info { + $class clay set component/ [string trim $name :/]/ $field $value + } +} +proc ::clay::define::constructor {arglist rawbody} { + set body { +my variable DestroyEvent +set DestroyEvent 0 +::clay::object_create [self] [info object class [self]] +# Initialize public variables and options +my InitializePublic + } + append body $rawbody + set class [current_class] + ::oo::define $class constructor $arglist $body +} +proc ::clay::define::Class_Method {name arglist body} { + set class [current_class] + $class clay set class_typemethod/ [string trim $name :/] [dict create arglist $arglist body $body] +} +proc ::clay::define::class_method {name arglist body} { + set class [current_class] + $class clay set class_typemethod/ [string trim $name :/] [dict create arglist $arglist body $body] +} +proc ::clay::define::clay {args} { + set class [current_class] + if {[lindex $args 0] in "cget set branch"} { + $class clay {*}$args + } else { + $class clay set {*}$args + } +} +proc ::clay::define::destructor rawbody { + set body { +# Run the destructor once and only once +set self [self] +my variable DestroyEvent +if {$DestroyEvent} return +set DestroyEvent 1 +} + append body $rawbody + ::oo::define [current_class] destructor $body +} +proc ::clay::define::Dict {name {values {}}} { + set class [current_class] + set name [string trim $name :/] + $class clay branch dict $name + foreach {var val} $values { + $class clay set dict/ $name/ $var $val + } +} +proc ::clay::define::Option {name args} { + set class [current_class] + set dictargs {default {}} + foreach {var val} [::clay::args_to_dict {*}$args] { + dict set dictargs [string trim $var -:/] $val + } + set name [string trimleft $name -] + + ### + # Option Class handling + ### + set optclass [dict getnull $dictargs class] + if {$optclass ne {}} { + foreach {f v} [$class clay find option_class $optclass] { + if {![dict exists $dictargs $f]} { + dict set dictargs $f $v + } + } + if {$optclass eq "variable"} { + variable $name [dict getnull $dictargs default] + } + } + foreach {f v} $dictargs { + $class clay set option $name $f $v + } +} +proc ::clay::define::Method {name argstyle argspec body} { + set class [current_class] + set result {} + switch $argstyle { + dictargs { + append result "::dictargs::parse \{$argspec\} \$args" \; + } + } + append result $body + oo::define $class method $name [list [list args [list dictargs $argspec]]] $result +} +proc ::clay::define::Option_Class {name args} { + set class [current_class] + set dictargs {default {}} + set name [string trimleft $name -:] + foreach {f v} [::clay::args_to_dict {*}$args] { + $class clay set option_class $name [string trim $f -/:] $v + } +} +proc ::clay::define::Variable {name {default {}}} { + set class [current_class] + set name [string trimright $name :/] + $class clay set variable/ $name $default +} +::namespace eval ::clay::define { +} +proc ::clay::ensemble_methodbody {ensemble einfo} { + set default standard + set preamble {} + set eswitch {} + if {[dict exists $einfo default]} { + set emethodinfo [dict get $einfo default] + set argspec [dict getnull $emethodinfo argspec] + set realbody [dict getnull $emethodinfo body] + set argstyle [dict getnull $emethodinfo argstyle] + if {$argstyle eq "dictargs"} { + set body "\n ::dictargs::parse \{$argspec\} \$args" + } elseif {[llength $argspec]==1 && [lindex $argspec 0] in {{} args arglist}} { + set body {} + } else { + set body "\n ::clay::dynamic_arguments $ensemble \$method [list $argspec] {*}\$args" + } + append body "\n " [string trim $realbody] " \n" + set default $body + dict unset einfo default + } + foreach {msubmethod esubmethodinfo} [lsort -dictionary -stride 2 $einfo] { + set submethod [string trim $msubmethod :/-] + if {$submethod eq "_body"} continue + if {$submethod eq "_preamble"} { + set preamble [dict getnull $esubmethodinfo body] + continue + } + set argspec [dict getnull $esubmethodinfo argspec] + set realbody [dict getnull $esubmethodinfo body] + set argstyle [dict getnull $esubmethodinfo argstyle] + if {[string length [string trim $realbody]] eq {}} { + dict set eswitch $submethod {} + } else { + if {$argstyle eq "dictargs"} { + set body "\n ::dictargs::parse \{$argspec\} \$args" + } elseif {[llength $argspec]==1 && [lindex $argspec 0] in {{} args arglist}} { + set body {} + } else { + set body "\n ::clay::dynamic_arguments $ensemble \$method [list $argspec] {*}\$args" + } + append body "\n " [string trim $realbody] " \n" + if {$submethod eq "default"} { + set default $body + } else { + foreach alias [dict getnull $esubmethodinfo aliases] { + dict set eswitch $alias - + } + dict set eswitch $submethod $body + } + } + } + set methodlist [lsort -dictionary [dict keys $eswitch]] + if {![dict exists $eswitch ]} { + dict set eswitch {return $methodlist} + } + if {$default eq "standard"} { + set default "error \"unknown method $ensemble \$method. Valid: \$methodlist\"" + } + dict set eswitch default $default + set mbody {} + + append mbody $preamble \n + + append mbody \n [list set methodlist $methodlist] + append mbody \n "set code \[catch {switch -- \$method [list $eswitch]} result opts\]" + append mbody \n {return -options $opts $result} + return $mbody +} +::proc ::clay::define::Ensemble {rawmethod args} { + if {[llength $args]==2} { + lassign $args argspec body + set argstyle tcl + } elseif {[llength $args]==3} { + lassign $args argstyle argspec body + } else { + error "Usage: Ensemble name ?argstyle? argspec body" + } + set class [current_class] + #if {$::clay::trace>2} { + # puts [list $class Ensemble $rawmethod $argspec $body] + #} + set mlist [split $rawmethod "::"] + set ensemble [string trim [lindex $mlist 0] :/] + set mensemble ${ensemble}/ + if {[llength $mlist]==1 || [lindex $mlist 1] in "_body"} { + set method _body + ### + # Simple method, needs no parsing, but we do need to record we have one + ### + if {$argstyle eq "dictargs"} { + set argspec [list args $argspec] + } + $class clay set method_ensemble/ $mensemble _body [dict create argspec $argspec body $body argstyle $argstyle] + if {$::clay::trace>2} { + puts [list $class clay set method_ensemble/ $mensemble _body ...] + } + set method $rawmethod + if {$::clay::trace>2} { + puts [list $class Ensemble $rawmethod $argspec $body] + set rawbody $body + set body {puts [list [self] $class [self method]]} + append body \n $rawbody + } + if {$argstyle eq "dictargs"} { + set rawbody $body + set body "::dictargs::parse \{$argspec\} \$args\; " + append body $rawbody + } + ::oo::define $class method $rawmethod $argspec $body + return + } + set method [join [lrange $mlist 2 end] "::"] + $class clay set method_ensemble/ $mensemble [string trim [lindex $method 0] :/] [dict create argspec $argspec body $body argstyle $argstyle] + if {$::clay::trace>2} { + puts [list $class clay set method_ensemble/ $mensemble [string trim $method :/] ...] + } +} +::oo::define ::clay::class { + method clay {submethod args} { + my variable clay + if {![info exists clay]} { + set clay {} + } + switch $submethod { + ancestors { + tailcall ::clay::ancestors [self] + } + branch { + set path [::clay::tree::storage $args] + if {![dict exists $clay {*}$path .]} { + dict set clay {*}$path . {} + } + } + exists { + if {![info exists clay]} { + return 0 + } + set path [::clay::tree::storage $args] + if {[dict exists $clay {*}$path]} { + return 1 + } + if {[dict exists $clay {*}[lrange $path 0 end-1] [lindex $path end]:]} { + return 1 + } + return 0 + } + dump { + return $clay + } + dget { + if {![info exists clay]} { + return {} + } + set path [::clay::tree::storage $args] + if {[dict exists $clay {*}$path]} { + return [dict get $clay {*}$path] + } + if {[dict exists $clay {*}[lrange $path 0 end-1] [lindex $path end]:]} { + return [dict get $clay {*}[lrange $path 0 end-1] [lindex $path end]:] + } + return {} + } + is_branch { + set path [::clay::tree::storage $args] + return [dict exists $clay {*}$path .] + } + getnull - + get { + if {![info exists clay]} { + return {} + } + set path [::clay::tree::storage $args] + if {[llength $path]==0} { + return $clay + } + if {[dict exists $clay {*}$path .]} { + return [::clay::tree::sanitize [dict get $clay {*}$path]] + } + if {[dict exists $clay {*}$path]} { + return [dict get $clay {*}$path] + } + if {[dict exists $clay {*}[lrange $path 0 end-1] [lindex $path end]:]} { + return [dict get $clay {*}[lrange $path 0 end-1] [lindex $path end]:] + } + return {} + } + find { + set path [::clay::tree::storage $args] + if {![info exists clay]} { + set clay {} + } + set clayorder [::clay::ancestors [self]] + set found 0 + if {[llength $path]==0} { + set result [dict create . {}] + foreach class $clayorder { + ::clay::tree::dictmerge result [$class clay dump] + } + return [::clay::tree::sanitize $result] + } + foreach class $clayorder { + if {[$class clay exists {*}$path .]} { + # Found a branch break + set found 1 + break + } + if {[$class clay exists {*}$path]} { + # Found a leaf. Return that value immediately + return [$class clay get {*}$path] + } + if {[dict exists $clay {*}[lrange $path 0 end-1] [lindex $path end]:]} { + return [dict get $clay {*}[lrange $path 0 end-1] [lindex $path end]:] + } + } + if {!$found} { + return {} + } + set result {} + # Leaf searches return one data field at a time + # Search in our local dict + # Search in the in our list of classes for an answer + foreach class [lreverse $clayorder] { + ::clay::tree::dictmerge result [$class clay dget {*}$path] + } + return [::clay::tree::sanitize $result] + } + merge { + foreach arg $args { + ::clay::tree::dictmerge clay {*}$arg + } + } + noop { + # Do nothing. Used as a sign of clay savviness + } + search { + foreach aclass [::clay::ancestors [self]] { + if {[$aclass clay exists {*}$args]} { + return [$aclass clay get {*}$args] + } + } + } + set { + ::clay::tree::dictset clay {*}$args + } + unset { + dict unset clay {*}$args + } + default { + dict $submethod clay {*}$args + } + } + } +} +::oo::define ::clay::object { + method clay {submethod args} { + my variable clay claycache clayorder config option_canonical + if {![info exists clay]} {set clay {}} + if {![info exists claycache]} {set claycache {}} + if {![info exists config]} {set config {}} + if {![info exists clayorder] || [llength $clayorder]==0} { + set clayorder {} + if {[dict exists $clay cascade]} { + dict for {f v} [dict get $clay cascade] { + if {$f eq "."} continue + if {[info commands $v] ne {}} { + lappend clayorder $v + } + } + } + lappend clayorder {*}[::clay::ancestors [info object class [self]] {*}[lreverse [info object mixins [self]]]] + } + switch $submethod { + ancestors { + return $clayorder + } + branch { + set path [::clay::tree::storage $args] + if {![dict exists $clay {*}$path .]} { + dict set clay {*}$path . {} + } + } + cache { + set path [lindex $args 0] + set value [lindex $args 1] + dict set claycache $path $value + } + cget { + # Leaf searches return one data field at a time + # Search in our local dict + if {[llength $args]==1} { + set field [string trim [lindex $args 0] -:/] + if {[info exists option_canonical($field)]} { + set field $option_canonical($field) + } + if {[dict exists $config $field]} { + return [dict get $config $field] + } + } + set path [::clay::tree::storage $args] + if {[dict exists $clay {*}$path]} { + return [dict get $clay {*}$path] + } + # Search in our local cache + if {[dict exists $claycache {*}$path]} { + if {[dict exists $claycache {*}$path .]} { + return [dict remove [dict get $claycache {*}$path] .] + } else { + return [dict get $claycache {*}$path] + } + } + # Search in the in our list of classes for an answer + foreach class $clayorder { + if {[$class clay exists {*}$path]} { + set value [$class clay get {*}$path] + dict set claycache {*}$path $value + return $value + } + if {[$class clay exists const {*}$path]} { + set value [$class clay get const {*}$path] + dict set claycache {*}$path $value + return $value + } + if {[$class clay exists option {*}$path default]} { + set value [$class clay get option {*}$path default] + dict set claycache {*}$path $value + return $value + } + } + return {} + } + delegate { + if {![dict exists $clay .delegate ]} { + dict set clay .delegate [info object class [self]] + } + if {[llength $args]==0} { + return [dict get $clay .delegate] + } + if {[llength $args]==1} { + set stub <[string trim [lindex $args 0] <>]> + if {![dict exists $clay .delegate $stub]} { + return {} + } + return [dict get $clay .delegate $stub] + } + if {([llength $args] % 2)} { + error "Usage: delegate + OR + delegate stub + OR + delegate stub OBJECT ?stub OBJECT? ..." + } + foreach {stub object} $args { + set stub <[string trim $stub <>]> + dict set clay .delegate $stub $object + oo::objdefine [self] forward ${stub} $object + oo::objdefine [self] export ${stub} + } + } + dump { + # Do a full dump of clay data + set result {} + # Search in the in our list of classes for an answer + foreach class $clayorder { + ::clay::tree::dictmerge result [$class clay dump] + } + ::clay::tree::dictmerge result $clay + return $result + } + ensemble_map { + set ensemble [lindex $args 0] + set mensemble [string trim $ensemble :/] + if {[dict exists $claycache method_ensemble $mensemble]} { + return [clay::tree::sanitize [dict get $claycache method_ensemble $mensemble]] + } + set emap [my clay dget method_ensemble $mensemble] + dict set claycache method_ensemble $mensemble $emap + return [clay::tree::sanitize $emap] + } + eval { + set script [lindex $args 0] + set buffer {} + set thisline {} + foreach line [split $script \n] { + append thisline $line + if {![info complete $thisline]} { + append thisline \n + continue + } + set thisline [string trim $thisline] + if {[string index $thisline 0] eq "#"} continue + if {[string length $thisline]==0} continue + if {[lindex $thisline 0] eq "my"} { + # Line already calls out "my", accept verbatim + append buffer $thisline \n + } elseif {[string range $thisline 0 2] eq "::"} { + # Fully qualified commands accepted verbatim + append buffer $thisline \n + } elseif { + append buffer "my $thisline" \n + } + set thisline {} + } + eval $buffer + } + evolve - + initialize { + my InitializePublic + } + exists { + # Leaf searches return one data field at a time + # Search in our local dict + set path [::clay::tree::storage $args] + if {[dict exists $clay {*}$path]} { + return 1 + } + # Search in our local cache + if {[dict exists $claycache {*}$path]} { + return 2 + } + set count 2 + # Search in the in our list of classes for an answer + foreach class $clayorder { + incr count + if {[$class clay exists {*}$path]} { + return $count + } + } + return 0 + } + flush { + set claycache {} + set clayorder [::clay::ancestors [info object class [self]] {*}[lreverse [info object mixins [self]]]] + } + forward { + oo::objdefine [self] forward {*}$args + } + dget { + set path [::clay::tree::storage $args] + if {[llength $path]==0} { + # Do a full dump of clay data + set result {} + # Search in the in our list of classes for an answer + foreach class $clayorder { + ::clay::tree::dictmerge result [$class clay dump] + } + ::clay::tree::dictmerge result $clay + return $result + } + if {[dict exists $clay {*}$path] && ![dict exists $clay {*}$path .]} { + # Path is a leaf + return [dict get $clay {*}$path] + } + # Search in our local cache + if {[my clay search $path value isleaf]} { + return $value + } + + set found 0 + set branch [dict exists $clay {*}$path .] + foreach class $clayorder { + if {[$class clay exists {*}$path .]} { + set found 1 + break + } + if {!$branch && [$class clay exists {*}$path]} { + set result [$class clay dget {*}$path] + my clay cache $path $result + return $result + } + } + # Path is a branch + set result [dict getnull $clay {*}$path] + foreach class $clayorder { + if {![$class clay exists {*}$path .]} continue + ::clay::tree::dictmerge result [$class clay dget {*}$path] + } + #if {[dict exists $clay {*}$path .]} { + # ::clay::tree::dictmerge result + #} + my clay cache $path $result + return $result + } + getnull - + get { + set path [::clay::tree::storage $args] + if {[llength $path]==0} { + # Do a full dump of clay data + set result {} + # Search in the in our list of classes for an answer + foreach class $clayorder { + ::clay::tree::dictmerge result [$class clay dump] + } + ::clay::tree::dictmerge result $clay + return [::clay::tree::sanitize $result] + } + if {[dict exists $clay {*}$path] && ![dict exists $clay {*}$path .]} { + # Path is a leaf + return [dict get $clay {*}$path] + } + # Search in our local cache + if {[my clay search $path value isleaf]} { + if {!$isleaf} { + return [clay::tree::sanitize $value] + } else { + return $value + } + } + set found 0 + set branch [dict exists $clay {*}$path .] + foreach class $clayorder { + if {[$class clay exists {*}$path .]} { + set found 1 + break + } + if {!$branch && [$class clay exists {*}$path]} { + set result [$class clay dget {*}$path] + my clay cache $path $result + return $result + } + } + # Path is a branch + set result [dict getnull $clay {*}$path] + #foreach class [lreverse $clayorder] { + # if {![$class clay exists {*}$path .]} continue + # ::clay::tree::dictmerge result [$class clay dget {*}$path] + #} + foreach class $clayorder { + if {![$class clay exists {*}$path .]} continue + ::clay::tree::dictmerge result [$class clay dget {*}$path] + } + #if {[dict exists $clay {*}$path .]} { + # ::clay::tree::dictmerge result [dict get $clay {*}$path] + #} + my clay cache $path $result + return [clay::tree::sanitize $result] + } + leaf { + # Leaf searches return one data field at a time + # Search in our local dict + set path [::clay::tree::storage $args] + if {[dict exists $clay {*}$path .]} { + return [clay::tree::sanitize [dict get $clay {*}$path]] + } + if {[dict exists $clay {*}$path]} { + return [dict get $clay {*}$path] + } + # Search in our local cache + if {[my clay search $path value isleaf]} { + if {!$isleaf} { + return [clay::tree::sanitize $value] + } else { + return $value + } + } + # Search in the in our list of classes for an answer + foreach class $clayorder { + if {[$class clay exists {*}$path]} { + set value [$class clay get {*}$path] + my clay cache $path $value + return $value + } + } + } + merge { + foreach arg $args { + ::clay::tree::dictmerge clay {*}$arg + } + } + mixin { + ### + # Mix in the class + ### + my clay flush + set prior [info object mixins [self]] + set newmixin {} + foreach item $args { + lappend newmixin ::[string trimleft $item :] + } + set newmap $args + foreach class $prior { + if {$class ni $newmixin} { + set script [$class clay search mixin/ unmap-script] + if {[string length $script]} { + if {[catch $script err errdat]} { + puts stderr "[self] MIXIN ERROR POPPING $class:\n[dict get $errdat -errorinfo]" + } + } + } + } + ::oo::objdefine [self] mixin {*}$args + ### + # Build a compsite map of all ensembles defined by the object's current + # class as well as all of the classes being mixed in + ### + my InitializePublic + foreach class $newmixin { + if {$class ni $prior} { + set script [$class clay search mixin/ map-script] + if {[string length $script]} { + if {[catch $script err errdat]} { + puts stderr "[self] MIXIN ERROR PUSHING $class:\n[dict get $errdat -errorinfo]" + } + } + } + } + foreach class $newmixin { + set script [$class clay search mixin/ react-script] + if {[string length $script]} { + if {[catch $script err errdat]} { + puts stderr "[self] MIXIN ERROR PEEKING $class:\n[dict get $errdat -errorinfo]" + } + break + } + } + } + mixinmap { + if {![dict exists $clay .mixin]} { + dict set clay .mixin {} + } + if {[llength $args]==0} { + return [dict get $clay .mixin] + } elseif {[llength $args]==1} { + return [dict getnull $clay .mixin [lindex $args 0]] + } else { + dict for {slot classes} $args { + dict set clay .mixin $slot $classes + } + set classlist {} + dict for {item class} [dict get $clay .mixin] { + if {$class ne {}} { + lappend classlist $class + } + } + my clay mixin {*}[lreverse $classlist] + } + } + provenance { + if {[dict exists $clay {*}$args]} { + return self + } + foreach class $clayorder { + if {[$class clay exists {*}$args]} { + return $class + } + } + return {} + } + refcount { + my variable refcount + if {![info exists refcount]} { + return 0 + } + return $refcount + } + refcount_incr { + my variable refcount + incr refcount + } + refcount_decr { + my variable refcount + incr refcount -1 + if {$refcount <= 0} { + ::clay::object_destroy [self] + } + } + replace { + set clay [lindex $args 0] + } + search { + set path [lindex $args 0] + upvar 1 [lindex $args 1] value [lindex $args 2] isleaf + set isleaf [expr {![dict exists $claycache $path .]}] + if {[dict exists $claycache $path]} { + set value [dict get $claycache $path] + return 1 + } + return 0 + } + source { + source [lindex $args 0] + } + set { + #puts [list [self] clay SET {*}$args] + ::clay::tree::dictset clay {*}$args + } + default { + dict $submethod clay {*}$args + } + } + } + method InitializePublic {} { + my variable clayorder clay claycache config option_canonical + set claycache {} + set clayorder [::clay::ancestors [info object class [self]] {*}[lreverse [info object mixins [self]]]] + if {![info exists clay]} { + set clay {} + } + if {![info exists config]} { + set config {} + } + dict for {var value} [my clay get variable] { + if { $var in {. clay} } continue + set var [string trim $var :/] + my variable $var + if {![info exists $var]} { + if {$::clay::trace>2} {puts [list initialize variable $var $value]} + set $var $value + } + } + dict for {var value} [my clay get dict/] { + if { $var in {. clay} } continue + set var [string trim $var :/] + my variable $var + if {![info exists $var]} { + set $var {} + } + foreach {f v} $value { + if {$f eq "."} continue + if {![dict exists ${var} $f]} { + if {$::clay::trace>2} {puts [list initialize dict $var $f $v]} + dict set ${var} $f $v + } + } + } + foreach {var value} [my clay get array/] { + if { $var in {. clay} } continue + set var [string trim $var :/] + if { $var eq {clay} } continue + my variable $var + if {![info exists $var]} { array set $var {} } + foreach {f v} $value { + if {![array exists ${var}($f)]} { + if {$f eq "."} continue + if {$::clay::trace>2} {puts [list initialize array $var\($f\) $v]} + set ${var}($f) $v + } + } + } + foreach {field info} [my clay get option/] { + if { $field in {. clay} } continue + set field [string trim $field -/:] + foreach alias [dict getnull $info aliases] { + set option_canonical($alias) $field + } + if {[dict exists $config $field]} continue + set getcmd [dict getnull $info default-command] + if {$getcmd ne {}} { + set value [{*}[string map [list %field% $field %self% [namespace which my]] $getcmd]] + } else { + set value [dict getnull $info default] + } + dict set config $field $value + set setcmd [dict getnull $info set-command] + if {$setcmd ne {}} { + {*}[string map [list %field% [list $field] %value% [list $value] %self% [namespace which my]] $setcmd] + } + } + if {[info exists clay]} { + set emap [dict getnull $clay method_ensemble] + } else { + set emap {} + } + foreach class [lreverse $clayorder] { + ### + # Build a compsite map of all ensembles defined by the object's current + # class as well as all of the classes being mixed in + ### + dict for {mensemble einfo} [$class clay get method_ensemble] { + if {$mensemble eq {.}} continue + set ensemble [string trim $mensemble :/] + if {$::clay::trace>2} {puts [list Defining $ensemble from $class]} + + dict for {method info} $einfo { + if {$method eq {.}} continue + if {![dict is_dict $info]} { + puts [list WARNING: class: $class method: $method not dict: $info] + continue + } + dict set info source $class + if {$::clay::trace>2} {puts [list Defining $ensemble -> $method from $class - $info]} + dict set emap $ensemble $method $info + } + } + } + foreach {ensemble einfo} $emap { + #if {[dict exists $einfo _body]} continue + set body [::clay::ensemble_methodbody $ensemble $einfo] + if {$::clay::trace>2} { + set rawbody $body + set body {puts [list [self] [self method]]} + append body \n $rawbody + } + oo::objdefine [self] method $ensemble {{method default} args} $body + } + } +} +::clay::object clay branch array +::clay::object clay branch mixin +::clay::object clay branch option +::clay::object clay branch dict clay +::clay::object clay set variable DestroyEvent 0 +if {[info commands ::cron::object_destroy] eq {}} { + # Provide a noop if we aren't running with the cron scheduler + namespace eval ::cron {} + proc ::cron::object_destroy args {} +} +::namespace eval ::clay::event { +} +proc ::clay::cleanup {} { + set count 0 + if {![info exists ::clay::idle_destroy]} return + set objlist $::clay::idle_destroy + set ::clay::idle_destroy {} + foreach obj $objlist { + if {![catch {$obj destroy}]} { + incr count + } + } + return $count +} +proc ::clay::object_create {objname {class {}}} { + #if {$::clay::trace>0} { + # puts [list $objname CREATE] + #} +} +proc ::clay::object_rename {object newname} { + if {$::clay::trace>0} { + puts [list $object RENAME -> $newname] + } +} +proc ::clay::object_destroy args { + if {![info exists ::clay::idle_destroy]} { + set ::clay::idle_destroy {} + } + foreach objname $args { + if {$::clay::trace>0} { + puts [list $objname DESTROY] + } + ::cron::object_destroy $objname + if {$objname in $::clay::idle_destroy} continue + lappend ::clay::idle_destroy $objname + } +} +proc ::clay::event::cancel {self {task *}} { + variable timer_event + variable timer_script + + foreach {id event} [array get timer_event $self:$task] { + ::after cancel $event + set timer_event($id) {} + set timer_script($id) {} + } +} +proc ::clay::event::generate {self event args} { + set wholist [Notification_list $self $event] + if {$wholist eq {}} return + set dictargs [::oo::meta::args_to_options {*}$args] + set info $dictargs + set strict 0 + set debug 0 + set sender $self + dict with dictargs {} + dict set info id [::clay::event::nextid] + dict set info origin $self + dict set info sender $sender + dict set info rcpt {} + foreach who $wholist { + catch {::clay::event::notify $who $self $event $info} + } +} +proc ::clay::event::nextid {} { + return "event#[format %0.8x [incr ::clay::event_count]]" +} +proc ::clay::event::Notification_list {self event {stackvar {}}} { + set notify_list {} + foreach {obj patternlist} [array get ::clay::object_subscribe] { + if {$obj eq $self} continue + if {$obj in $notify_list} continue + set match 0 + foreach {objpat eventlist} $patternlist { + if {![string match $objpat $self]} continue + foreach eventpat $eventlist { + if {![string match $eventpat $event]} continue + set match 1 + break + } + if {$match} { + break + } + } + if {$match} { + lappend notify_list $obj + } + } + return $notify_list +} +proc ::clay::event::notify {rcpt sender event eventinfo} { + if {[info commands $rcpt] eq {}} return + if {$::clay::trace} { + puts [list event notify rcpt $rcpt sender $sender event $event info $eventinfo] + } + $rcpt notify $event $sender $eventinfo +} +proc ::clay::event::process {self handle script} { + variable timer_event + variable timer_script + + array unset timer_event $self:$handle + array unset timer_script $self:$handle + + set err [catch {uplevel #0 $script} result errdat] + if $err { + puts "BGError: $self $handle $script +ERR: $result +[dict get $errdat -errorinfo] +***" + } +} +proc ::clay::event::schedule {self handle interval script} { + variable timer_event + variable timer_script + if {$::clay::trace} { + puts [list $self schedule $handle $interval] + } + if {[info exists timer_event($self:$handle)]} { + if {$script eq $timer_script($self:$handle)} { + return + } + ::after cancel $timer_event($self:$handle) + } + set timer_script($self:$handle) $script + set timer_event($self:$handle) [::after $interval [list ::clay::event::process $self $handle $script]] +} +proc ::clay::event::subscribe {self who event} { + upvar #0 ::clay::object_subscribe($self) subscriptions + if {![info exists subscriptions]} { + set subscriptions {} + } + set match 0 + foreach {objpat eventlist} $subscriptions { + if {![string match $objpat $who]} continue + foreach eventpat $eventlist { + if {[string match $eventpat $event]} { + # This rule already exists + return + } + } + } + dict lappend subscriptions $who $event +} +proc ::clay::event::unsubscribe {self args} { + upvar #0 ::clay::object_subscribe($self) subscriptions + if {![info exists subscriptions]} { + return + } + switch [llength $args] { + 1 { + set event [lindex $args 0] + if {$event eq "*"} { + # Shortcut, if the + set subscriptions {} + } else { + set newlist {} + foreach {objpat eventlist} $subscriptions { + foreach eventpat $eventlist { + if {[string match $event $eventpat]} continue + dict lappend newlist $objpat $eventpat + } + } + set subscriptions $newlist + } + } + 2 { + set who [lindex $args 0] + set event [lindex $args 1] + if {$who eq "*" && $event eq "*"} { + set subscriptions {} + } else { + set newlist {} + foreach {objpat eventlist} $subscriptions { + if {[string match $who $objpat]} { + foreach eventpat $eventlist { + if {[string match $event $eventpat]} continue + dict lappend newlist $objpat $eventpat + } + } + } + set subscriptions $newlist + } + } + } +} +namespace eval ::clay { + namespace export * +} + +### +# END: clay/clay.tcl +### +### +# START: setup.tcl +### +package require TclOO +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 +} +namespace eval ::practcl { +} +namespace eval ::practcl::OBJECT { +} + +### +# END: setup.tcl +### +### +# START: doctool.tcl +### +namespace eval ::practcl { +} +proc ::practcl::cat fname { + if {![file exists $fname]} { + return + } + set fin [open $fname r] + set data [read $fin] + close $fin + return $data +} +proc ::practcl::docstrip text { + set result {} + foreach line [split $text \n] { + append thisline $line \n + if {![info complete $thisline]} continue + set outline $thisline + set thisline {} + if {[string trim $outline] eq {}} { + continue + } + if {[string index [string trim $outline] 0] eq "#"} continue + set cmd [string trim [lindex $outline 0] :] + if {$cmd eq "namespace" && [lindex $outline 1] eq "eval"} { + append result [list {*}[lrange $outline 0 end-1]] " " \{ \n [docstrip [lindex $outline end]]\} \n + continue + } + if {[string match "*::define" $cmd] && [llength $outline]==3} { + append result [list {*}[lrange $outline 0 end-1]] " " \{ \n [docstrip [lindex $outline end]]\} \n + continue + } + if {$cmd eq "oo::class" && [lindex $outline 1] eq "create"} { + append result [list {*}[lrange $outline 0 end-1]] " " \{ \n [docstrip [lindex $outline end]]\} \n + continue + } + append result $outline + } + return $result +} +proc ::putb {buffername args} { + upvar 1 $buffername buffer + switch [llength $args] { + 1 { + append buffer [lindex $args 0] \n + } + 2 { + append buffer [string map {*}$args] \n + } + default { + error "usage: putb buffername ?map? string" + } + } +} +::oo::class create ::practcl::doctool { + constructor {} { + my reset + } + method argspec {argspec} { + set result [dict create] + foreach arg $argspec { + set name [lindex $arg 0] + dict set result $name positional 1 + dict set result $name mandatory 1 + if {$name in {args dictargs}} { + switch [llength $arg] { + 1 { + dict set result $name mandatory 0 + } + 2 { + dict for {optname optinfo} [lindex $arg 1] { + set optname [string trim $optname -:] + dict set result $optname {positional 1 mandatory 0} + dict for {f v} $optinfo { + dict set result $optname [string trim $f -:] $v + } + } + } + default { + error "Bad argument" + } + } + } else { + switch [llength $arg] { + 1 { + dict set result $name mandatory 1 + } + 2 { + dict set result $name mandatory 0 + dict set result $name default [lindex $arg 1] + } + default { + error "Bad argument" + } + } + } + } + return $result + } + method comment block { + set count 0 + set field description + set result [dict create description {}] + foreach line [split $block \n] { + set sline [string trim $line] + set fwidx [string first " " $sline] + if {$fwidx < 0} { + set firstword [string range $sline 0 end] + set restline {} + } else { + set firstword [string range $sline 0 [expr {$fwidx-1}]] + set restline [string range $sline [expr {$fwidx+1}] end] + } + if {[string index $firstword end] eq ":"} { + set field [string tolower [string trim $firstword -:]] + switch $field { + dictargs - + arglist { + set field argspec + } + desc { + set field description + } + } + if {[string length $restline]} { + dict append result $field "$restline\n" + } + } else { + dict append result $field "$line\n" + } + } + return $result + } + method keyword.Annotation {resultvar commentblock type name body} { + upvar 1 $resultvar result + set name [string trim $name :] + if {[dict exists $result $type $name]} { + set info [dict get $result $type $name] + } else { + set info [my comment $commentblock] + } + foreach {f v} $body { + dict set info $f $v + } + dict set result $type $name $info + } + method keyword.Class {resultvar commentblock name body} { + upvar 1 $resultvar result + set name [string trim $name :] + if {[dict exists $result class $name]} { + set info [dict get $result class $name] + } else { + set info [my comment $commentblock] + } + set commentblock {} + foreach line [split $body \n] { + append thisline $line \n + if {![info complete $thisline]} continue + set thisline [string trim $thisline] + if {[string index $thisline 0] eq "#"} { + append commentblock [string trimleft $thisline #] \n + set thisline {} + continue + } + set cmd [string trim [lindex $thisline 0] ":"] + switch $cmd { + Option - + option { + my keyword.Annotation info $commentblock option [lindex $thisline 1] [lindex $thisline 2] + set commentblock {} + } + variable - + Variable { + my keyword.Annotation info $commentblock variable [lindex $thisline 1] [list type scaler default [lindex $thisline 2]] + set commentblock {} + } + Dict - + Array { + set iinfo [lindex $thisline 2] + dict set iinfo type [string tolower $cmd] + my keyword.Annotation info $commentblock variable [lindex $thisline 1] $iinfo + set commentblock {} + } + Componant - + Delegate { + my keyword.Annotation info $commentblock delegate [lindex $thisline 1] [lindex $thisline 2] + set commentblock {} + } + method - + Ensemble { + my keyword.Class_Method info $commentblock {*}[lrange $thisline 1 end-1] + set commentblock {} + } + } + set thisline {} + } + dict set result class $name $info + } + method keyword.class {resultvar commentblock name body} { + upvar 1 $resultvar result + set name [string trim $name :] + if {[dict exists $result class $name]} { + set info [dict get $result class $name] + } else { + set info [my comment $commentblock] + } + set commentblock {} + foreach line [split $body \n] { + append thisline $line \n + if {![info complete $thisline]} continue + set thisline [string trim $thisline] + if {[string index $thisline 0] eq "#"} { + append commentblock [string trimleft $thisline #] \n + set thisline {} + continue + } + set cmd [string trim [lindex $thisline 0] ":"] + switch $cmd { + Option - + option { + puts [list keyword.Annotation $cmd $thisline] + my keyword.Annotation info $commentblock option [lindex $thisline 1] [lindex $thisline 2] + set commentblock {} + } + variable - + Variable { + my keyword.Annotation info $commentblock variable [lindex $thisline 1] [list default [lindex $thisline 2]] + set commentblock {} + } + Dict - + Array { + set iinfo [lindex $thisline 2] + dict set iinfo type [string tolower $cmd] + my keyword.Annotation info $commentblock variable [lindex $thisline 1] $iinfo + set commentblock {} + } + Componant - + Delegate { + my keyword.Annotation info $commentblock delegate [lindex $thisline 1] [lindex $thisline 2] + set commentblock {} + } + superclass { + dict set info ancestors [lrange $thisline 1 end] + set commentblock {} + } + classmethod - + class_method - + Class_Method { + my keyword.Class_Method info $commentblock {*}[lrange $thisline 1 end-1] + set commentblock {} + } + destructor - + constructor { + my keyword.method info $commentblock {*}[lrange $thisline 0 end-1] + set commentblock {} + } + method - + Ensemble { + my keyword.method info $commentblock {*}[lrange $thisline 1 end-1] + set commentblock {} + } + } + set thisline {} + } + dict set result class $name $info + } + method keyword.Class_Method {resultvar commentblock name args} { + upvar 1 $resultvar result + set info [my comment $commentblock] + if {[dict exists $info show_body] && [dict get $info show_body]} { + dict set info internals [lindex $args end] + } + if {[dict exists $info ensemble]} { + dict for {method minfo} [dict get $info ensemble] { + dict set result Class_Method "${name} $method" $minfo + } + } else { + switch [llength $args] { + 1 { + set argspec [lindex $args 0] + } + 0 { + set argspec dictargs + #set body [lindex $args 0] + } + default {error "could not interpret method $name {*}$args"} + } + if {![dict exists $info argspec]} { + dict set info argspec [my argspec $argspec] + } + dict set result Class_Method [string trim $name :] $info + } + } + method keyword.method {resultvar commentblock name args} { + upvar 1 $resultvar result + set info [my comment $commentblock] + if {[dict exists $info show_body] && [dict get $info show_body]} { + dict set info internals [lindex $args end] + } + if {[dict exists $info ensemble]} { + dict for {method minfo} [dict get $info ensemble] { + dict set result method "\"${name} $method\"" $minfo + } + } else { + switch [llength $args] { + 1 { + set argspec [lindex $args 0] + } + 0 { + set argspec dictargs + #set body [lindex $args 0] + } + default {error "could not interpret method $name {*}$args"} + } + if {![dict exists $info argspec]} { + dict set info argspec [my argspec $argspec] + } + dict set result method "\"[split [string trim $name :] ::]\"" $info + } + } + method keyword.proc {commentblock name argspec} { + set info [my comment $commentblock] + if {![dict exists $info argspec]} { + dict set info argspec [my argspec $argspec] + } + return $info + } + method reset {} { + my variable coro + set coro [info object namespace [self]]::coro + oo::objdefine [self] forward coro $coro + if {[info command $coro] ne {}} { + rename $coro {} + } + coroutine $coro {*}[namespace code {my Main}] + } + method Main {} { + + my variable info + set info [dict create] + yield [info coroutine] + set thisline {} + set commentblock {} + set linec 0 + while 1 { + set line [yield] + append thisline $line \n + if {![info complete $thisline]} continue + set thisline [string trim $thisline] + if {[string index $thisline 0] eq "#"} { + append commentblock [string trimleft $thisline #] \n + set thisline {} + continue + } + set cmd [string trim [lindex $thisline 0] ":"] + switch $cmd { + dictargs::proc { + set procinfo [my keyword.proc $commentblock [lindex $thisline 1] [list args [list dictargs [lindex $thisline 2]]]] + if {[dict exists $procinfo show_body] && [dict get $procinfo show_body]} { + dict set procinfo internals [lindex $thisline end] + } + dict set info proc [string trim [lindex $thisline 1] :] $procinfo + set commentblock {} + } + tcllib::PROC - + PROC - + Proc - + proc { + set procinfo [my keyword.proc $commentblock {*}[lrange $thisline 1 2]] + if {[dict exists $procinfo show_body] && [dict get $procinfo show_body]} { + dict set procinfo internals [lindex $thisline end] + } + dict set info proc [string trim [lindex $thisline 1] :] $procinfo + set commentblock {} + } + oo::objdefine { + if {[llength $thisline]==3} { + lassign $thisline tcmd name body + my keyword.Class info $commentblock $name $body + } else { + puts "Warning: bare oo::define in library" + } + } + oo::define { + if {[llength $thisline]==3} { + lassign $thisline tcmd name body + my keyword.class info $commentblock $name $body + } else { + puts "Warning: bare oo::define in library" + } + } + tao::define - + clay::define - + tool::define { + lassign $thisline tcmd name body + my keyword.class info $commentblock $name $body + set commentblock {} + } + oo::class { + lassign $thisline tcmd mthd name body + my keyword.class info $commentblock $name $body + set commentblock {} + } + default { + if {[lindex [split $cmd ::] end] eq "define"} { + lassign $thisline tcmd name body + my keyword.class info $commentblock $name $body + set commentblock {} + } + set commentblock {} + } + } + set thisline {} + } + } + method section.method {keyword method minfo} { + set result {} + set line "\[call $keyword \[cmd $method\]" + if {[dict exists $minfo argspec]} { + dict for {argname arginfo} [dict get $minfo argspec] { + set positional 1 + set mandatory 1 + set repeating 0 + dict with arginfo {} + if {$mandatory==0} { + append line " \[opt \"" + } else { + append line " " + } + if {$positional} { + append line "\[arg $argname" + } else { + append line "\[option \"$argname" + if {[dict exists $arginfo type]} { + append line " \[emph [dict get $arginfo type]\]" + } else { + append line " \[emph value\]" + } + append line "\"" + } + append line "\]" + if {$mandatory==0} { + if {[dict exists $arginfo default]} { + append line " \[const \"[dict get $arginfo default]\"\]" + } + append line "\"\]" + } + if {$repeating} { + append line " \[opt \[option \"$argname...\"\]\]" + } + } + } + append line \] + putb result $line + if {[dict exists $minfo description]} { + putb result [dict get $minfo description] + } + if {[dict exists $minfo example]} { + putb result "\[para\]Example: \[example [list [dict get $minfo example]]\]" + } + if {[dict exists $minfo internals]} { + putb result "\[para\]Internals: \[example [list [dict get $minfo internals]]\]" + } + return $result + } + method section.annotation {type name iinfo} { + set result "\[call $type \[cmd $name\]\]" + if {[dict exists $iinfo description]} { + putb result [dict get $iinfo description] + } + if {[dict exists $iinfo example]} { + putb result "\[para\]Example: \[example [list [dict get $minfo example]]\]" + } + return $result + } + method section.class {class_name class_info} { + set result {} + putb result "\[subsection \{Class $class_name\}\]" + if {[dict exists $class_info ancestors]} { + set line "\[emph \"ancestors\"\]:" + foreach {c} [dict get $class_info ancestors] { + append line " \[class [string trim $c :]\]" + } + putb result $line + putb result {[para]} + } + dict for {f v} $class_info { + if {$f in {Class_Method method description ancestors example option variable delegate}} continue + putb result "\[emph \"$f\"\]: $v" + putb result {[para]} + } + if {[dict exists $class_info example]} { + putb result "\[example \{[list [dict get $class_info example]]\}\]" + putb result {[para]} + } + if {[dict exists $class_info description]} { + putb result [dict get $class_info description] + putb result {[para]} + } + dict for {f v} $class_info { + if {$f ni {option variable delegate}} continue + putb result "\[class \{[string totitle $f]\}\]" + #putb result "Methods on the class object itself." + putb result {[list_begin definitions]} + dict for {item iinfo} [dict get $class_info $f] { + putb result [my section.annotation $f $item $iinfo] + } + putb result {[list_end]} + putb result {[para]} + } + if {[dict exists $class_info Class_Method]} { + putb result "\[class \{Class Methods\}\]" + #putb result "Methods on the class object itself." + putb result {[list_begin definitions]} + dict for {method minfo} [dict get $class_info Class_Method] { + putb result [my section.method classmethod $method $minfo] + } + putb result {[list_end]} + putb result {[para]} + } + if {[dict exists $class_info method]} { + putb result "\[class {Methods}\]" + putb result {[list_begin definitions]} + dict for {method minfo} [dict get $class_info method] { + putb result [my section.method method $method $minfo] + } + putb result {[list_end]} + putb result {[para]} + } + return $result + } + method section.command {procinfo} { + set result {} + putb result "\[section \{Commands\}\]" + putb result {[list_begin definitions]} + dict for {method minfo} $procinfo { + putb result [my section.method proc $method $minfo] + } + putb result {[list_end]} + return $result + } + method manpage args { + my variable info + set map {%version% 0.0 %module% {Your_Module_Here}} + set result {} + set header {} + set footer {} + set authors {} + dict with args {} + dict set map %keyword% comment + putb result $map {[%keyword% {-*- tcl -*- doctools manpage}] +[vset PACKAGE_VERSION %version%] +[manpage_begin %module% n [vset PACKAGE_VERSION]]} + putb result $map $header + + dict for {sec_type sec_info} $info { + switch $sec_type { + proc { + putb result [my section.command $sec_info] + } + class { + putb result "\[section Classes\]" + dict for {class_name class_info} $sec_info { + putb result [my section.class $class_name $class_info] + } + } + default { + putb result "\[section [list $sec_type $sec_name]\]" + if {[dict exists $sec_info description]} { + putb result [dict get $sec_info description] + } + } + } + } + if {[llength $authors]} { + putb result {[section AUTHORS]} + foreach {name email} $authors { + putb result "$name \[uri mailto:$email\]\[para\]" + } + } + putb result $footer + putb result {[manpage_end]} + return $result + } + method scan_text {text} { + my variable linecount coro + set linecount 0 + foreach line [split $text \n] { + incr linecount + $coro $line + } + } + method scan_file {filename} { + my variable linecount coro + set fin [open $filename r] + set linecount 0 + while {[gets $fin line]>=0} { + incr linecount + $coro $line + } + close $fin + } +} + +### +# END: doctool.tcl +### +### +# START: buildutil.tcl +### +proc Proc {name arglist body} { + if {[info command $name] ne {}} return + proc $name $arglist $body +} +Proc ::noop args {} +proc ::practcl::debug args { + #puts $args + ::practcl::cputs ::DEBUG_INFO $args +} +proc ::practcl::doexec args { + puts [list {*}$args] + exec {*}$args >&@ stdout +} +proc ::practcl::doexec_in {path args} { + set PWD [pwd] + cd $path + puts [list {*}$args] + exec {*}$args >&@ stdout + cd $PWD +} +proc ::practcl::dotclexec args { + puts [list [info nameofexecutable] {*}$args] + exec [info nameofexecutable] {*}$args >&@ stdout +} +proc ::practcl::domake {path args} { + set PWD [pwd] + cd $path + puts [list *** $path ***] + puts [list make {*}$args] + exec make {*}$args >&@ stdout + cd $PWD +} +proc ::practcl::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 ::practcl::fossil {path args} { + set PWD [pwd] + cd $path + puts [list {*}$args] + exec fossil {*}$args >&@ stdout + cd $PWD +} +proc ::practcl::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 +} +proc ::practcl::os {} { + return [${::practcl::MAIN} define get TEACUP_OS] +} +proc ::practcl::mkzip {exename barekit vfspath} { + ::practcl::tcllib_require zipfile::mkzip + ::zipfile::mkzip::mkzip $exename -runtime $barekit -directory $vfspath +} +proc ::practcl::sort_dict list { + return [::lsort -stride 2 -dictionary $list] +} +if {[::package vcompare $::tcl_version 8.6] < 0} { + # Approximate ::zipfile::mkzip with exec calls + proc ::practcl::mkzip {exename barekit vfspath} { + set path [file dirname [file normalize $exename]] + set zipfile [file join $path [file rootname $exename].zip] + file copy -force $barekit $exename + set pwd [pwd] + cd $vfspath + exec zip -r $zipfile . + cd $pwd + set fout [open $exename a] + set fin [open $zipfile r] + chan configure $fout -translation binary + chan configure $fin -translation binary + chan copy $fin $fout + chan close $fin + chan close $fout + exec zip -A $exename + } + proc ::practcl::sort_dict list { + set result {} + foreach key [lsort -dictionary [dict keys $list]] { + dict set result $key [dict get $list $key] + } + return $result + } +} +proc ::practcl::local_os {} { + # If we have already run this command, return + # a cached copy of the data + if {[info exists ::practcl::LOCAL_INFO]} { + return $::practcl::LOCAL_INFO + } + set result [array get ::practcl::CONFIG] + dict set result TEACUP_PROFILE unknown + dict set result TEACUP_OS unknown + dict set result EXEEXT {} + set windows 0 + if {$::tcl_platform(platform) eq "windows"} { + set windows 1 + } + if {$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 + if {[info exists ::SANDBOX]} { + dict set result sandbox $::SANDBOX + } + 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 + } + set OS [dict get $result TEACUP_OS] + dict set result os $OS + + # Look for a local preference file + set pathlist {} + set userhome [file normalize ~/tcl] + set local_install [file join $userhome lib] + switch $OS { + windows { + set userhome [file join [file normalize $::env(LOCALAPPDATA)] Tcl] + if {[file exists c:/Tcl/Teapot]} { + dict set result teapot c:/Tcl/Teapot + } + } + macosx { + set userhome [file join [file normalize {~/Library/Application Support/}] Tcl] + if {[file exists {~/Library/Application Support/ActiveState/Teapot/repository/}]} { + dict set result teapot [file normalize {~/Library/Application Support/ActiveState/Teapot/repository/}] + } + dict set result local_install [file normalize ~/Library/Tcl] + if {![dict exists $result sandbox]} { + dict set result sandbox [file normalize ~/Library/Tcl/sandbox] + } + } + default { + } + } + dict set result userhome $userhome + # Load user preferences + if {[file exists [file join $userhome practcl.rc]]} { + set dat [::practcl::read_rc_file [file join $userhome practcl.rc]] + foreach {f v} $dat { + dict set result $f $v + } + } + if {![dict exists $result prefix]} { + dict set result prefix $userhome + } + + # Create a default path for the teapot + if {![dict exists $result teapot]} { + dict set result teapot [file join $userhome teapot] + } + # Create a default path for the local sandbox + if {![dict exists $result sandbox]} { + dict set result sandbox [file join $userhome sandbox] + } + # Create a default path for download folder + if {![dict exists $result download]} { + dict set result download [file join $userhome download] + } + # Path to install local packages + if {![dict exists $result local_install]} { + dict set result local_install [file join $userhome lib] + } + if {![dict exists result fossil_mirror] && [::info exists ::env(FOSSIL_MIRROR)]} { + dict set result fossil_mirror $::env(FOSSIL_MIRROR) + } + + set ::practcl::LOCAL_INFO $result + return $result +} +proc ::practcl::config.tcl {path} { + return [read_configuration $path] +} +proc ::practcl::read_configuration {path} { + dict set result buildpath $path + set result [local_os] + set OS [dict get $result TEACUP_OS] + set windows 0 + dict set result USEMSVC 0 + if {[file exists [file join $path config.tcl]]} { + # We have a definitive configuration file. Read its content + # and take it as gospel + set cresult [read_rc_file [file join $path config.tcl]] + set cresult [::practcl::de_shell $cresult] + if {[dict exists $cresult srcdir] && ![dict exists $cresult sandbox]} { + dict set cresult sandbox [file dirname [dict get $cresult srcdir]] + } + set result [dict merge $result [::practcl::de_shell $cresult]] + } + if {[file exists [file join $path config.site]]} { + # No config.tcl file is present but we do seed + dict set result USEMSVC 0 + foreach {f v} [::practcl::de_shell [::practcl::read_sh_file [file join $path config.site]]] { + dict set result $f $v + dict set result XCOMPILE_${f} $v + } + dict set result CONFIG_SITE [file join $path config.site] + if {[dict exist $result XCOMPILE_CC] && [regexp mingw [dict get $result XCOMPILE_CC]]} { + set windows 1 + } + } elseif {[info exists ::env(VisualStudioVersion)]} { + set windows 1 + dict set result USEMSVC 1 + } + if {$windows && [dict get $result TEACUP_OS] ne "windows"} { + if {![dict exists exists $result TEACUP_ARCH]} { + dict set result TEACUP_ARCH ix86 + } + dict set result TEACUP_PROFILE win32-[dict get $result TEACUP_ARCH] + dict set result TEACUP_OS windows + dict set result EXEEXT .exe + } + return $result +} +if {$::tcl_platform(platform) eq "windows"} { +proc ::practcl::msys_to_tclpath msyspath { + return [exec sh -c "cd $msyspath ; pwd -W"] +} +proc ::practcl::tcl_to_myspath tclpath { + set path [file normalize $tclpath] + return "/[string index $path 0][string range $path 2 end]" + #return [exec sh -c "cd $tclpath ; pwd"] +} +} else { +proc ::practcl::msys_to_tclpath msyspath { + return [file normalize $msyspath] +} +proc ::practcl::tcl_to_myspath msyspath { + return [file normalize $msyspath] +} +} +proc ::practcl::tcllib_require {pkg args} { + # Try to load the package from the local environment + if {[catch [list ::package require $pkg {*}$args] err]==0} { + return $err + } + ::practcl::LOCAL tool tcllib env-load + uplevel #0 [list ::package require $pkg {*}$args] +} +namespace eval ::practcl::platform { +} +proc ::practcl::platform::tcl_core_options {os} { + ### + # Download our required packages + ### + set tcl_config_opts {} + # Auto-guess options for the local operating system + switch $os { + windows { + #lappend tcl_config_opts --disable-stubs + } + linux { + } + macosx { + lappend tcl_config_opts --enable-corefoundation=yes --enable-framework=no + } + } + lappend tcl_config_opts --with-tzdata + return $tcl_config_opts +} +proc ::practcl::platform::tk_core_options {os} { + ### + # Download our required packages + ### + set tk_config_opts {} + + # Auto-guess options for the local operating system + switch $os { + windows { + } + linux { + lappend tk_config_opts --enable-xft=no --enable-xss=no + } + macosx { + lappend tk_config_opts --enable-aqua=yes + } + } + return $tk_config_opts +} +proc ::practcl::read_rc_file {filename {localdat {}}} { + set result $localdat + set fin [open $filename 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 + append result \n $line + #incr linecount + #set key [lindex $line 0] + #set value [lindex $line 1] + #dict set result $key $value + } + close $fin + return $result +} +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 '] +} +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 +} +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 +} +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 +} +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::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 [dict get $data $flag] + } + } + 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% + + if {[dict exists $data name]} { + 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 + set value [string trim [dict get $data $flag] \"] + dict set map "\$\{${flag}\}" $value + dict set map "\$\(${flag}\)" $value + #dict set map "\$${flag}" $value + dict set map "%${flag}%" $value + 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 +} + +### +# END: buildutil.tcl +### +### +# START: fileutil.tcl +### +proc ::practcl::grep {pattern {files {}}} { + set result [list] + if {[llength $files] == 0} { + # read from stdin + set lnum 0 + while {[gets stdin line] >= 0} { + incr lnum + if {[regexp -- $pattern $line]} { + lappend result "${lnum}:${line}" + } + } + } else { + foreach filename $files { + set file [open $filename r] + set lnum 0 + while {[gets $file line] >= 0} { + incr lnum + if {[regexp -- $pattern $line]} { + lappend result "${filename}:${lnum}:${line}" + } + } + close $file + } + } + return $result +} +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 +} +proc ::practcl::findByPattern {basedir patterns} { + set queue $basedir + set result {} + while {[llength $queue]} { + set item [lindex $queue 0] + set queue [lrange $queue 1 end] + if {[file isdirectory $item]} { + foreach path [glob -nocomplain [file join $item *]] { + lappend queue $path + } + continue + } + foreach pattern $patterns { + set fname [file tail $item] + if {[string match $pattern $fname]} { + lappend result $item + break + } + } + } + return $result +} +proc ::practcl::log {fname comment} { + set fname [file normalize $fname] + if {[info exists ::practcl::logchan($fname)]} { + set fout $::practcl::logchan($fname) + after cancel $::practcl::logevent($fname) + } else { + set fout [open $fname a] + } + puts $fout $comment + # Defer close until idle + set ::practcl::logevent($fname) [after idle "close $fout ; unset ::practcl::logchan($fname)"] +} + +### +# END: fileutil.tcl +### +### +# START: installutil.tcl +### +proc ::practcl::_pkgindex_simpleIndex {path} { +set buffer {} + set pkgidxfile [file join $path pkgIndex.tcl] + set modfile [file join $path [file tail $path].tcl] + set use_pkgindex [file exists $pkgidxfile] + set tclfiles {} + set found 0 + set mlist [list pkgIndex.tcl index.tcl [file tail $modfile] version_info.tcl] + foreach file [glob -nocomplain [file join $path *.tcl]] { + if {[file tail $file] ni $mlist} { + #puts [list NONMODFILE $file] + return {} + } + } + foreach file [glob -nocomplain [file join $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 + #puts "PKGLINE $line" + append buffer "package ifneeded $package $version \[list source \[file join %DIR% [file tail $file]\]\]" \n + break + } + } + return $buffer +} +proc ::practcl::_pkgindex_directory {path} { + set buffer {} + set pkgidxfile [file join $path pkgIndex.tcl] + set modfile [file join $path [file tail $path].tcl] + set use_pkgindex [file exists $pkgidxfile] + set tclfiles {} + if {$use_pkgindex && [file exists $modfile]} { + set use_pkgindex 0 + set mlist [list pkgIndex.tcl [file tail $modfile]] + foreach file [glob -nocomplain [file join $path *.tcl]] { + lappend tclfiles [file tail $file] + if {[file tail $file] in $mlist} continue + incr use_pkgindex + } + } + if {!$use_pkgindex} { + # 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 + } + if {[string trim $version] ne {}} { + 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 trace 0 + #if {[file tail $path] eq "tool"} { + # set trace 1 + #} + 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 + } + if {[regexp "if.*catch.*package.*Tcl.*return" $thisline]} { + if {$trace} {puts "[file dirname $pkgidxfile] Ignoring $thisline"} + set thisline {} ; continue + } + if {[regexp "if.*package.*vsatisfies.*package.*provide.*return" $thisline]} { + if {$trace} { puts "[file dirname $pkgidxfile] Ignoring $thisline" } + set 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 + if {$trace} { puts "[file dirname $pkgidxfile] Arbitrary code $thisline" } + return {source [file join $dir pkgIndex.tcl]} + } + append buffer $thisline \n + set thisline {} + } + if {$trace} {puts [list [file dirname $pkgidxfile] $buffer]} + return $buffer +} +proc ::practcl::_pkgindex_path_subdir {path} { + set result {} + if {[file exists [file join $path src build.tcl]]} { + # Tool style module, don't dive into subdirectories + return $path + } + foreach subpath [glob -nocomplain [file join $path *]] { + if {[file isdirectory $subpath]} { + if {[file tail $subpath] eq "build" && [file exists [file join $subpath build.tcl]]} continue + lappend result $subpath {*}[_pkgindex_path_subdir $subpath] + } + } + return $result +} +proc ::practcl::pkgindex_path {args} { + set stack {} + set buffer { +lappend ::PATHSTACK $dir +set IDXPATH [lindex $::PATHSTACK end] + } + set preindexed {} + foreach base $args { + set base [file normalize $base] + set paths {} + foreach dir [glob -nocomplain [file join $base *]] { + set thisdir [file tail $dir] + if {$thisdir eq "teapot"} continue + if {$thisdir eq "pkgs"} { + foreach subdir [glob -nocomplain [file join $dir *]] { + set thissubdir [file tail $subdir] + set skip 0 + foreach file {pkgIndex.tcl tclIndex} { + if {[file exists [file join $subdir $file]]} { + set skip 1 + append buffer "set dir \[file join \$::IDXPATH [list $thisdir] [list $thissubdir]\] \; " + append buffer "source \[file join \$dir ${file}\]" \n + } + } + if {$skip} continue + lappend paths {*}[::practcl::_pkgindex_path_subdir $subdir] + } + continue + } + lappend paths $dir {*}[::practcl::_pkgindex_path_subdir $dir] + } + append buffer "" + set i [string length $base] + # Build a list of all of the paths + if {[llength $paths]} { + foreach path $paths { + if {$path eq $base} continue + set path_indexed($path) 0 + } + } else { + puts [list WARNING: NO PATHS FOUND IN $base] + } + set path_indexed($base) 1 + set path_indexed([file join $base boot tcl]) 1 + append buffer \n {# SINGLE FILE MODULES BEGIN} \n {set dir [lindex $::PATHSTACK end]} \n + foreach path $paths { + if {$path_indexed($path)} continue + set thisdir [file_relative $base $path] + set simpleIdx [_pkgindex_simpleIndex $path] + if {[string length $simpleIdx]==0} continue + incr path_indexed($path) + if {[string length $simpleIdx]} { + incr path_indexed($path) + append buffer [string map [list %DIR% "\$dir \{$thisdir\}"] [string trimright $simpleIdx]] \n + } + } + append buffer {# SINGLE FILE MODULES END} \n + foreach path $paths { + if {$path_indexed($path)} continue + set thisdir [file_relative $base $path] + 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 +} +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 {toplevel 1}} { + #if {$toplevel} { + # puts [list ::practcl::copyDir $d1 -> $d2] + #} + #file delete -force -- $d2 + file mkdir $d2 + if {[file isfile $d1]} { + file copy -force $d1 $d2 + set ftail [file tail $d1] + if {$::tcl_platform(platform) eq {unix}} { + file attributes [file join $d2 $ftail] -permissions 0644 + } else { + file attributes [file join $d2 $ftail] -readonly 1 + } + } else { + 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] 0 + } 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 + } + } + } + } +} +proc ::practcl::buildModule {modpath} { + set buildscript [file join $modpath build build.tcl] + if {![file exists $buildscript]} return + set pkgIndexFile [file join $modpath pkgIndex.tcl] + if {[file exists $pkgIndexFile]} { + set latest 0 + foreach file [::practcl::findByPattern [file dirname $buildscript] *.tcl] { + set mtime [file mtime $file] + if {$mtime>$latest} { + set latest $mtime + } + } + set IdxTime [file mtime $pkgIndexFile] + if {$latest<$IdxTime} return + } + ::practcl::dotclexec $buildscript +} +proc ::practcl::installModule {modpath DEST} { + set dpath [file join $DEST modules [file tail $modpath]] + #puts [list ::practcl::installModule $modpath -> $dpath] + if {[file exists [file join $modpath index.tcl]]} { + # IRM/Tao style modules non-amalgamated + ::practcl::installDir $modpath $dpath + return + } + if {[file exists [file join $modpath build build.tcl]]} { + buildModule $modpath + } + set files [glob -nocomplain [file join $modpath *.tcl]] + if {[llength $files]} { + if {[llength $files]>1} { + if {![file exists [file join $modpath pkgIndex.tcl]]} { + pkg_mkIndex $modpath + } + } + file delete -force $dpath + file mkdir $dpath + foreach file $files { + file copy $file $dpath + } + } + if {[file exists [file join $modpath htdocs]]} { + ::practcl::copyDir [file join $modpath htdocs] [file join $dpath htdocs] + } +} + +### +# END: installutil.tcl +### +### +# START: makeutil.tcl +### +proc ::practcl::trigger {args} { + ::practcl::LOCAL make trigger {*}$args + foreach {name obj} [::practcl::LOCAL make objects] { + set ::make($name) [$obj do] + } +} +proc ::practcl::depends {args} { + ::practcl::LOCAL make depends {*}$args +} +proc ::practcl::target {name info {action {}}} { + set obj [::practcl::LOCAL make task $name $info $action] + set ::make($name) 0 + set filename [$obj define get filename] + if {$filename ne {}} { + set ::target($name) $filename + } +} + +### +# END: makeutil.tcl +### +### +# START: class metaclass.tcl +### +::clay::define ::practcl::metaclass { + method _MorphPatterns {} { + return {{@name@} {::practcl::@name@} {::practcl::*@name@} {::practcl::*@name@*}} + } + 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 { + return [my clay delegate {*}$args] + } + method initialize {} {} + 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 morph classname { + my variable define + if {$classname ne {}} { + set map [list @name@ $classname] + foreach pattern [string map $map [my _MorphPatterns]] { + set pattern [string trim $pattern] + set matches [info commands $pattern] + if {![llength $matches]} continue + set class [lindex $matches 0] + break + } + set mixinslot {} + foreach {slot pattern} { + distribution ::practcl::distribution* + product ::practcl::product* + toolset ::practcl::toolset* + } { + if {[string match $pattern $class]} { + set mixinslot $slot + break + } + } + if {$mixinslot ne {}} { + my clay mixinmap $mixinslot $class + } elseif {[info command $class] ne {}} { + if {[info object class [self]] ne $class} { + ::oo::objdefine [self] class $class + ::practcl::debug [self] morph $class + my define set class $class + } + } else { + error "[self] Could not detect class for $classname" + } + } + if {[::info exists define(oodefine)]} { + ::oo::objdefine [self] $define(oodefine) + #unset define(oodefine) + } + } + method script script { + eval $script + } + method select {} { + my variable define + if {[info exists define(class)]} { + my morph $define(class) + } else { + if {[::info exists define(oodefine)]} { + ::oo::objdefine [self] $define(oodefine) + #unset define(oodefine) + } + } + } + method source filename { + source $filename + } +} + +### +# END: class metaclass.tcl +### +### +# START: class toolset baseclass.tcl +### +::clay::define ::practcl::toolset { + method config.sh {} { + return [my read_configuration] + } + method BuildDir {PWD} { + set name [my define get name] + set debug [my define get debug 0] + if {[my define get LOCAL 0]} { + return [my define get builddir [file join $PWD local $name]] + } + if {$debug} { + return [my define get builddir [file join $PWD debug $name]] + } else { + return [my define get builddir [file join $PWD pkg $name]] + } + } + method MakeDir {srcdir} { + return $srcdir + } + method read_configuration {} { + 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 srcdir [my define get srcdir] + 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::read_configuration $builddir] + foreach {item value} [::practcl::sort_dict $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] + } + switch $field { + version { + dict set result pkg_vers $dat + } + lib_file { + set field libfile + } + } + dict set result $field $dat + } + set conf_result $result + return $result + } + ### + # Oh man... we have to guess + ### + if {![file exists [file join $builddir Makefile]]} { + my Configure + } + set filename [file join $builddir Makefile] + if {![file exists $filename]} { + error "Could not locate any configuration data in $srcdir" + } + foreach {field dat} [::practcl::read_Makefile $filename] { + dict set result $field $dat + } + if {![dict exists $result PRACTCL_PKG_LIBS] && [dict exists $result LIBS]} { + dict set result PRACTCL_PKG_LIBS [dict get $result LIBS] + } + set conf_result $result + cd $PWD + return $result + } + method build-cflags {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 $DEFS + foreach flag { + -DPACKAGE_NAME + -DPACKAGE_VERSION + -DPACKAGE_TARNAME + -DPACKAGE_STRING + } { + if {[set i [string first $flag $defs]] >= 0} { + set j [string first -D $flag [expr {$i+[string length $flag]}]] + set predef [string range $defs 0 [expr {$i-1}]] + set postdef [string range $defs $j end] + set defs "$predef $postdef" + } + } + append defs " -DPACKAGE_NAME=\"${name}\" -DPACKAGE_VERSION=\"${version}\"" + append defs " -DPACKAGE_TARNAME=\"${name}\" -DPACKAGE_STRING=\"${name}\x5c\x20${version}\"" + return $defs + } + method critcl args { + if {![info exists critcl]} { + ::practcl::LOCAL tool critcl env-load + set critcl [file join [::practcl::LOCAL tool critcl define get srcdir] main.tcl + } + set srcdir [my SourceRoot] + set PWD [pwd] + cd $srcdir + ::practcl::dotclexec $critcl {*}$args + cd $PWD + } +} +oo::objdefine ::practcl::toolset { + # Perform the selection for the toolset mixin + method select object { + ### + # Select the toolset to use for this project + ### + if {[$object define exists toolset]} { + return [$object define get toolset] + } + set class [$object define get toolset] + if {$class ne {}} { + $object clay mixinmap toolset $class + } else { + if {[info exists ::env(VisualStudioVersion)]} { + $object clay mixinmap toolset ::practcl::toolset.msvc + } else { + $object clay mixinmap toolset ::practcl::toolset.gcc + } + } + } +} + +### +# END: class toolset baseclass.tcl +### +### +# START: class toolset gcc.tcl +### +::clay::define ::practcl::toolset.gcc { + superclass ::practcl::toolset + method Autoconf {} { + ### + # Re-run autoconf for this project + # Not a good idea in practice... but in the right hands it can be useful + ### + set pwd [pwd] + set srcdir [file normalize [my define get srcdir]] + set localsrcdir [my MakeDir $srcdir] + cd $localsrcdir + foreach template {configure.ac configure.in} { + set input [file join $srcdir $template] + if {[file exists $input]} { + puts "autoconf -f $input > [file join $srcdir configure]" + exec autoconf -f $input > [file join $srcdir configure] + } + } + cd $pwd + } + method BuildDir {PWD} { + set name [my define get name] + set debug [my define get debug 0] + if {[my define get LOCAL 0]} { + return [my define get builddir [file join $PWD local $name]] + } + if {$debug} { + return [my define get builddir [file join $PWD debug $name]] + } else { + return [my define get builddir [file join $PWD pkg $name]] + } + } + 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] + } + switch [my define get name] { + tcl { + set opts [::practcl::platform::tcl_core_options [my define get TEACUP_OS]] + } + tk { + set opts [::practcl::platform::tk_core_options [my define get TEACUP_OS]] + } + } + if {[my define get CONFIG_SITE] != {}} { + lappend opts --host=[my define get HOST] + } + set inside_msys [string is true -strict [my define get MSYS_ENV 0]] + lappend opts --with-tclsh=[info nameofexecutable] + + if {[my define get tk 0]} { + if {![my define get LOCAL 0]} { + set obj [my tclcore] + if {$obj ne {}} { + if {$inside_msys} { + lappend opts --with-tcl=[::practcl::file_relative [file normalize $builddir] [$obj define get builddir]] + } else { + lappend opts --with-tcl=[file normalize [$obj define get builddir]] + } + } + set obj [my tkcore] + if {$obj ne {}} { + if {$inside_msys} { + lappend opts --with-tk=[::practcl::file_relative [file normalize $builddir] [$obj define get builddir]] + } else { + lappend opts --with-tk=[file normalize [$obj define get builddir]] + } + } + } else { + lappend opts --with-tcl=[file join $PREFIX lib] + lappend opts --with-tk=[file join $PREFIX lib] + } + } else { + if {![my define get LOCAL 0]} { + set obj [my tclcore] + if {$obj ne {}} { + if {$inside_msys} { + lappend opts --with-tcl=[::practcl::file_relative [file normalize $builddir] [$obj define get builddir]] + } else { + lappend opts --with-tcl=[file normalize [$obj define get builddir]] + } + } + } else { + lappend opts --with-tcl=[file join $PREFIX lib] + } + } + + lappend opts {*}[my define get config_opts] + if {![regexp -- "--prefix" $opts]} { + lappend opts --prefix=$PREFIX --exec-prefix=$PREFIX + } + if {[my define get debug 0]} { + lappend opts --enable-symbols=true + } + #--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 MakeDir {srcdir} { + set localsrcdir $srcdir + if {[file exists [file join $srcdir generic]]} { + my define add include_dir [file join $srcdir generic] + } + set os [my define get TEACUP_OS] + switch $os { + windows { + if {[file exists [file join $srcdir win]]} { + my define add include_dir [file join $srcdir win] + } + if {[file exists [file join $srcdir win Makefile.in]]} { + set localsrcdir [file join $srcdir win] + } + } + macosx { + if {[file exists [file join $srcdir unix Makefile.in]]} { + set localsrcdir [file join $srcdir unix] + } + } + default { + if {[file exists [file join $srcdir $os]]} { + my define add include_dir [file join $srcdir $os] + } + if {[file exists [file join $srcdir unix]]} { + my define add include_dir [file join $srcdir unix] + } + if {[file exists [file join $srcdir $os Makefile.in]]} { + set localsrcdir [file join $srcdir $os] + } elseif {[file exists [file join $srcdir unix Makefile.in]]} { + set localsrcdir [file join $srcdir unix] + } + } + } + return $localsrcdir + } + Ensemble make::autodetect {} { + set srcdir [my define get srcdir] + set localsrcdir [my MakeDir $srcdir] + if {$localsrcdir eq {}} { + set localsrcdir $srcdir + } + if {$srcdir eq $localsrcdir} { + if {![file exists [file join $srcdir tclconfig install-sh]]} { + # ensure we have tclconfig with all of the trimmings + set teapath {} + if {[file exists [file join $srcdir .. tclconfig install-sh]]} { + set teapath [file join $srcdir .. tclconfig] + } else { + set tclConfigObj [::practcl::LOCAL tool tclconfig] + $tclConfigObj load + set teapath [$tclConfigObj define get srcdir] + } + set teapath [file normalize $teapath] + #file mkdir [file join $srcdir tclconfig] + if {[catch {file link -symbolic [file join $srcdir tclconfig] $teapath}]} { + ::practcl::copyDir [file join $teapath] [file join $srcdir tclconfig] + } + } + } + set builddir [my define get builddir] + file mkdir $builddir + if {![file exists [file join $localsrcdir configure]]} { + if {[file exists [file join $localsrcdir autogen.sh]]} { + cd $localsrcdir + catch {exec sh autogen.sh >>& [file join $builddir autoconf.log]} + cd $::CWD + } + } + set opts [my ConfigureOpts] + if {[file exists [file join $builddir autoconf.log]]} { + file delete [file join $builddir autoconf.log] + } + ::practcl::debug [list PKG [my define get name] CONFIGURE {*}$opts] + ::practcl::log [file join $builddir autoconf.log] [list CONFIGURE {*}$opts] + cd $builddir + if {[my define get CONFIG_SITE] ne {}} { + set ::env(CONFIG_SITE) [my define get CONFIG_SITE] + } + catch {exec sh [file join $localsrcdir configure] {*}$opts >>& [file join $builddir autoconf.log]} + cd $::CWD + } + Ensemble make::clean {} { + set builddir [file normalize [my define get builddir]] + catch {::practcl::domake $builddir clean} + } + Ensemble make::compile {} { + set name [my define get name] + set srcdir [my define get srcdir] + if {[my define get static 1]} { + puts "BUILDING Static $name $srcdir" + } else { + puts "BUILDING Dynamic $name $srcdir" + } + 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]]} { + if {[my define get debug 0]} { + ::practcl::domake.tcl $builddir debug all + } else { + ::practcl::domake.tcl $builddir all + } + } else { + ::practcl::domake $builddir all + } + } + Ensemble make::install DEST { + set PWD [pwd] + set builddir [my define get builddir] + if {[my define get LOCAL 0] || $DEST eq {}} { + if {[file exists [file join $builddir make.tcl]]} { + puts "[self] Local INSTALL (Practcl)" + ::practcl::domake.tcl $builddir install + } elseif {[my define get broken_destroot 0] == 0} { + puts "[self] Local INSTALL (TEA)" + ::practcl::domake $builddir install + } + } else { + if {[file exists [file join $builddir make.tcl]]} { + # Practcl builds can inject right to where we need them + puts "[self] VFS INSTALL $DEST (Practcl)" + ::practcl::domake.tcl $builddir install-package $DEST + } elseif {[my define get broken_destroot 0] == 0} { + # Most modern TEA projects understand DESTROOT in the makefile + puts "[self] VFS INSTALL $DEST (TEA)" + ::practcl::domake $builddir install DESTDIR=[::practcl::file_relative $builddir $DEST] + } 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 + ::practcl::domake $builddir $install + ::practcl::copyDir $BROKENROOT [file join $DEST [string trimleft $PREFIX /]] + file delete -force $BROKENROOT + } + } + cd $PWD + } + method build-compile-sources {PROJECT COMPILE CPPCOMPILE INCLUDES} { + set objext [my define get OBJEXT o] + 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] + + set task {} + ### + # Compile the C sources + ### + ::practcl::debug ### COMPILE PRODUCTS + foreach {ofile info} [${PROJECT} project-compile-products] { + ::practcl::debug $ofile $info + 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 ofile [file rootname $ofile] + 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 + } + set cfile [dict get $info cfile] + if {$debug} { + set ofilename [file join $builddir objs [file rootname [file tail $ofile]].debug.${objext}] + } else { + set ofilename [file join $builddir objs [file tail $ofile]].${objext} + } + dict set task $ofile source $cfile + dict set task $ofile objfile $ofilename + 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 " $INCLUDES" + 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 + ::practcl::debug COMPILING $ofile $info + set filename [dict get $info objfile] + if {[file exists $filename] && [file mtime $filename]>[file mtime [dict get $info source]]} { + lappend result $filename + dict set task $ofile done 1 + 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 + } + if {[file exists $filename]} { + lappend result $filename + dict set task $ofile done 1 + continue + } + error "Failed to produce $filename" + } + } + return $result + } +method build-Makefile {path PROJECT} { + array set proj [$PROJECT define dump] + set path $proj(builddir) + cd $path + set includedir . + set objext [my define get OBJEXT o] + + #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 toolset-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 project-compile-products] { + dict set products $ofile $info + set fname [file rootname ${ofile}].${objext} + if {[dict exists $info library]} { +lappend libraries $ofile +continue + } + if {[dict exists $info depend]} { + ::practcl::cputs result "\n${fname}: [dict get $info depend]" + } else { + ::practcl::cputs result "\n${fname}:" + } + 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 +} +method 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]]] + if {[$PROJECT define get TEA_PRIVATE_TCL_HEADERS 0]} { + if {[$PROJECT define get TEA_PLATFORM] eq "windows"} { + lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(TCL_SRC_DIR) win]]] + } else { + lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(TCL_SRC_DIR) unix]]] + } + } + + 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]]] + if {[$PROJECT define get TEA_PRIVATE_TK_HEADERS 0]} { + if {[$PROJECT define get TEA_PLATFORM] eq "windows"} { + lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(TK_SRC_DIR) win]]] + } else { + lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(TK_SRC_DIR) unix]]] + } + } + lappend includedir [::practcl::file_relative $path [file normalize $proj(TK_BIN_DIR)]] + } + foreach include [$PROJECT toolset-include-directory] { + set cpath [::practcl::file_relative $path [file normalize $include]] + if {$cpath ni $includedir} { + lappend includedir $cpath + } + } + my build-cflags $PROJECT $proj(DEFS) name version defs + set NAME [string toupper $name] + set debug [$PROJECT define get debug 0] + set os [$PROJECT define get TEACUP_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 \ + $defs $proj(CFLAGS_WARNING)" + } else { + set COMPILECPP $COMPILE + } + } else { + set COMPILE "$proj(CC) $proj(CFLAGS) $defs" + + if {[info exists proc(CXX)]} { + set COMPILECPP "$proj(CXX) $defs $proj(CFLAGS)" + } else { + set COMPILECPP $COMPILE + } + } + + set products [my build-compile-sources $PROJECT $COMPILE $COMPILECPP $INCLUDES] + + 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 + } + set ranlib [$PROJECT define get RANLIB] + if {$ranlib ni {{} :}} { + catch {exec $ranlib $outfile} + } +} +method build-tclsh {outfile PROJECT {path {auto}}} { + if {[my define get tk 0] && [my define get static_tk 0]} { + puts " BUILDING STATIC TCL/TK EXE $PROJECT" + set TKOBJ [$PROJECT tkcore] + if {[info command $TKOBJ] eq {}} { + set TKOBJ ::noop + $PROJECT define set static_tk 0 + } else { + ::practcl::toolset select $TKOBJ + array set TK [$TKOBJ read_configuration] + set do_tk [$TKOBJ define get static] + $PROJECT define set static_tk $do_tk + $PROJECT define set tk $do_tk + set TKSRCDIR [$TKOBJ define get srcdir] + } + } else { + puts " BUILDING STATIC TCL EXE $PROJECT" + set TKOBJ ::noop + my define set static_tk 0 + } + set TCLOBJ [$PROJECT tclcore] + ::practcl::toolset select $TCLOBJ + set PKG_OBJS {} + foreach item [$PROJECT link list core.library] { + if {[string is true [$item define get static]]} { + lappend PKG_OBJS $item + } + } + foreach item [$PROJECT link list package] { + if {[string is true [$item define get static]]} { + lappend PKG_OBJS $item + } + } + array set TCL [$TCLOBJ read_configuration] + if {$path in {{} auto}} { + set path [file dirname [file normalize $outfile]] + } + if {$path eq "."} { + set path [pwd] + } + 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 + ### + my build-cflags $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 read_configuration] + } + set os [$PROJECT define get TEACUP_OS] + set TCLSRCDIR [$TCLOBJ define get srcdir] + + set includedir . + foreach include [$TCLOBJ toolset-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]] + if {[$PROJECT define get static_tk]} { + lappend includedir [::practcl::file_relative $path [file normalize [file join $TKSRCDIR generic]]] + lappend includedir [::practcl::file_relative $path [file normalize [file join $TKSRCDIR ttk]]] + lappend includedir [::practcl::file_relative $path [file normalize [file join $TKSRCDIR xlib]]] + lappend includedir [::practcl::file_relative $path [file normalize $TKSRCDIR]] + } + + foreach include [$PROJECT toolset-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)" + } else { + set COMPILE "$TCL(cc) $TCL(shlib_cflags) $TCL(cflags_optimize) \ +$TCL(cflags_warning) $TCL(extra_cflags)" + } + append COMPILE " " $defs + lappend OBJECTS {*}[my build-compile-sources $PROJECT $COMPILE $COMPILE $INCLUDES] + + set TCLSRC [file normalize $TCLSRCDIR] + + if {[${PROJECT} define get TEACUP_OS] eq "windows"} { + set windres [$PROJECT define get RC windres] + set RSOBJ [file join $path objs tclkit.res.o] + set RCSRC [${PROJECT} define get kit_resource_file] + set RCMAN [${PROJECT} define get kit_manifest_file] + set RCICO [${PROJECT} define get kit_icon_file] + + set cmd [list $windres -o $RSOBJ -DSTATIC_BUILD --include [::practcl::file_relative $path [file join $TCLSRC generic]]] + if {[$PROJECT define get static_tk]} { + if {$RCSRC eq {} || ![file exists $RCSRC]} { + set RCSRC [file join $TKSRCDIR win rc wish.rc] + } + if {$RCMAN eq {} || ![file exists $RCMAN]} { + set RCMAN [file join [$TKOBJ define get builddir] wish.exe.manifest] + } + if {$RCICO eq {} || ![file exists $RCICO]} { + set RCICO [file join $TKSRCDIR win rc wish.ico] + } + set TKSRC [file normalize $TKSRCDIR] + lappend cmd --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]] + } else { + if {$RCSRC eq {} || ![file exists $RCSRC]} { + set RCSRC [file join $TCLSRCDIR win tclsh.rc] + } + if {$RCMAN eq {} || ![file exists $RCMAN]} { + set RCMAN [file join [$TCLOBJ define get builddir] tclsh.exe.manifest] + } + if {$RCICO eq {} || ![file exists $RCICO]} { + set RCICO [file join $TCLSRCDIR win tclsh.ico] + } + } + foreach item [${PROJECT} define get resource_include] { + lappend cmd --include [::practcl::file_relative $path [file normalize $item]] + } + lappend cmd [file tail $RCSRC] + if {![file exists [file join $path [file tail $RCSRC]]]} { + file copy -force $RCSRC [file join $path [file tail $RCSRC]] + } + if {![file exists [file join $path [file tail $RCMAN]]]} { + file copy -force $RCMAN [file join $path [file tail $RCMAN]] + } + if {![file exists [file join $path [file tail $RCICO]]]} { + file copy -force $RCICO [file join $path [file tail $RCICO]] + } + ::practcl::doexec {*}$cmd + lappend OBJECTS $RSOBJ + } + puts "***" + set cmd "$TCL(cc)" + if {$debug} { + append cmd " $TCL(cflags_debug)" + } else { + append cmd " $TCL(cflags_optimize)" + } + append cmd " $TCL(ld_flags)" + if {$debug} { + append cmd " $TCL(ldflags_debug)" + } else { + append cmd " $TCL(ldflags_optimize)" + } + + append cmd " $OBJECTS" + append cmd " $EXTERN_OBJS" + if {$debug && $os eq "windows"} { + ### + # There is bug in the core's autoconf and the value for + # tcl_build_lib_spec does not have the 'g' suffix + ### + append cmd " -L[file dirname $TCL(build_stub_lib_path)] -ltcl86g" + if {[$PROJECT define get static_tk]} { + append cmd " -L[file dirname $TK(build_stub_lib_path)] -ltk86g" + } + } else { + append cmd " $TCL(build_lib_spec)" + if {[$PROJECT define get static_tk]} { + append cmd " $TK(build_lib_spec)" + } + } + foreach obj $PKG_OBJS { + append cmd " [$obj linker-products $config($obj)]" + } + set LIBS {} + foreach item $TCL(libs) { + if {[string range $item 0 1] eq "-l" && $item in $LIBS } continue + lappend LIBS $item + } + if {[$PROJECT define get static_tk]} { + foreach item $TK(libs) { + if {[string range $item 0 1] eq "-l" && $item in $LIBS } continue + lappend LIBS $item + } + } + if {[info exists TCL(extra_libs)]} { + foreach item $TCL(extra_libs) { + if {[string range $item 0 1] eq "-l" && $item in $LIBS } continue + lappend LIBS $item + } + } + foreach obj $PKG_OBJS { + puts [list Checking $obj for external dependencies] + foreach item [$obj linker-external $config($obj)] { + puts [list $obj adds $item] + if {[string range $item 0 1] eq "-l" && $item in $LIBS } continue + lappend LIBS $item + } + } + append cmd " ${LIBS}" + foreach obj $PKG_OBJS { + puts [list Checking $obj for additional link items] + foreach item [$obj linker-extra $config($obj)] { + append cmd $item + } + } + if {$debug && $os eq "windows"} { + append cmd " -L[file dirname $TCL(build_stub_lib_path)] ${TCL(stub_lib_flag)}" + if {[$PROJECT define get static_tk]} { + append cmd " -L[file dirname $TK(build_stub_lib_path)] ${TK(stub_lib_flag)}" + } + } else { + append cmd " $TCL(build_stub_lib_spec)" + if {[$PROJECT define get static_tk]} { + append cmd " $TK(build_stub_lib_spec)" + } + } + if {[info exists TCL(cc_search_flags)]} { + append cmd " $TCL(cc_search_flags)" + } + append cmd " -o $outfile " + if {$os eq "windows"} { + set LDFLAGS_CONSOLE {-mconsole -pipe -static-libgcc} + set LDFLAGS_WINDOW {-mwindows -pipe -static-libgcc} + append cmd " $LDFLAGS_CONSOLE" + } + puts "LINK: $cmd" + exec {*}[string map [list "\n" " " " " " "] $cmd] >&@ stdout +} +} + +### +# END: class toolset gcc.tcl +### +### +# START: class toolset msvc.tcl +### +::clay::define ::practcl::toolset.msvc { + superclass ::practcl::toolset + method BuildDir {PWD} { + set srcdir [my define get srcdir] + return $srcdir + } + Ensemble make::autodetect {} { + } + Ensemble make::clean {} { + set PWD [pwd] + set srcdir [my define get srcdir] + cd $srcdir + catch {::practcl::doexec nmake -f makefile.vc clean} + cd $PWD + } + Ensemble make::compile {} { + set srcdir [my define get srcdir] + if {[my define get static 1]} { + puts "BUILDING Static $name $srcdir" + } else { + puts "BUILDING Dynamic $name $srcdir" + } + cd $srcdir + if {[file exists [file join $srcdir make.tcl]]} { + if {[my define get debug 0]} { + ::practcl::domake.tcl $srcdir debug all + } else { + ::practcl::domake.tcl $srcdir all + } + } else { + if {[file exists [file join $srcdir makefile.vc]]} { + ::practcl::doexec nmake -f makefile.vc INSTALLDIR=[my define get installdir] {*}[my NmakeOpts] release + } elseif {[file exists [file join $srcdir win makefile.vc]]} { + cd [file join $srcdir win] + ::practcl::doexec nmake -f makefile.vc INSTALLDIR=[my define get installdir] {*}[my NmakeOpts] release + } else { + error "No make.tcl or makefile.vc found for project $name" + } + } + } + Ensemble make::install DEST { + set PWD [pwd] + set srcdir [my define get srcdir] + cd $srcdir + if {$DEST eq {}} { + error "No destination given" + } + if {[my define get LOCAL 0] || $DEST eq {}} { + if {[file exists [file join $srcdir make.tcl]]} { + # Practcl builds can inject right to where we need them + puts "[self] Local Install (Practcl)" + ::practcl::domake.tcl $srcdir install + } else { + puts "[self] Local Install (Nmake)" + ::practcl::doexec nmake -f makefile.vc {*}[my NmakeOpts] install + } + } else { + if {[file exists [file join $srcdir make.tcl]]} { + # Practcl builds can inject right to where we need them + puts "[self] VFS INSTALL $DEST (Practcl)" + ::practcl::domake.tcl $srcdir install-package $DEST + } else { + puts "[self] VFS INSTALL $DEST" + ::practcl::doexec nmake -f makefile.vc INSTALLDIR=$DEST {*}[my NmakeOpts] install + } + } + cd $PWD + } + method MakeDir {srcdir} { + set localsrcdir $srcdir + if {[file exists [file join $srcdir generic]]} { + my define add include_dir [file join $srcdir generic] + } + if {[file exists [file join $srcdir win]]} { + my define add include_dir [file join $srcdir win] + } + if {[file exists [file join $srcdir makefile.vc]]} { + set localsrcdir [file join $srcdir win] + } + return $localsrcdir + } + method NmakeOpts {} { + set opts {} + set builddir [file normalize [my define get builddir]] + + if {[my define exists tclsrcdir]} { + ### + # On Windows we are probably running under MSYS, which doesn't deal with + # spaces in filename well + ### + 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 TCLDIR=[file normalize $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 TKDIR=[file normalize $TKSRCDIR] + } + return $opts + } +} + +### +# END: class toolset msvc.tcl +### +### +# START: class target.tcl +### +::clay::define ::practcl::make_obj { + superclass ::practcl::metaclass + constructor {module_object name info {action_body {}}} { + my variable define triggered domake + set triggered 0 + set domake 0 + set define(name) $name + set define(action) {} + array set define $info + my select + my initialize + foreach {stub obj} [$module_object child organs] { + my graft $stub $obj + } + if {$action_body ne {}} { + set define(action) $action_body + } + } + 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 make_objects [my make objects] + 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} { + foreach filename [my output] { + if {$filename ne {} && ![file exists $filename]} { + set needs_make 1 + } + } + } + return $needs_make + } + method output {} { + set result {} + set filename [my define get filename] + if {$filename ne {}} { + lappend result $filename + } + foreach filename [my define get files] { + if {$filename ne {}} { + lappend result $filename + } + } + return $result + } + method reset {} { + my variable triggered domake needs_make + set triggerd 0 + set domake 0 + set needs_make 0 + } + method triggers {} { + my variable triggered domake define + if {$triggered} { + return $domake + } + set triggered 1 + set make_objects [my make objects] + + 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] triggers itself" + continue + } else { + set r [$depobj check] + if {$r} { + $depobj triggers + } + } + } + set domake 1 + my make trigger {*}[my define get triggers] + } +} + +### +# END: class target.tcl +### +### +# START: class object.tcl +### +::clay::define ::practcl::object { + superclass ::practcl::metaclass + constructor {parent args} { + my variable links define + set organs [$parent child organs] + my clay delegate {*}$organs + array set define $organs + array set define [$parent child define] + array set links {} + if {[llength $args]==1 && [file exists [lindex $args 0]]} { + my define set filename [lindex $args 0] + ::practcl::product select [self] + } elseif {[llength $args] == 1} { + set data [uplevel 1 [list subst [lindex $args 0]]] + array set define $data + my select + } else { + array set define [uplevel 1 [list subst $args]] + my select + } + my initialize + + } + method child {method} { + return {} + } + method go {} { + ::practcl::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 + } + } + ::practcl::debug [list /[self] [self method] [self class]] + } +} + +### +# END: class object.tcl +### +### +# START: class dynamic.tcl +### +::clay::define ::practcl::dynamic { + method cstructure {name definition {argdat {}}} { + my variable cstruct + dict set cstruct $name body $definition + foreach {f v} $argdat { + dict set cstruct $name $f $v + } + if {![dict exists $cstruct $name public]} { + dict set cstruct $name public 1 + } + } + method include header { + my define add include $header + } + method include_dir args { + my define add include_dir {*}$args + } + method include_directory args { + my define add include_dir {*}$args + } + 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 {info {}}} { + set header [string map "\t \ \n \ \ \ \ " $header] + 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]} { + set dat [dict merge {export 0 extern 0 public 1 inline 0} $info] + dict set dat header $header + dict set dat body $body + dict set dat keywords $keywords + dict set dat arglist $arglist + if {"IRM_INLINE" in $keywords || "CTHULHU_INLINE" in $keywords} { + dict set dat public 1 + dict set dat extern 0 + dict set dat inline 1 + } else { + if {"inline" in $keywords} { + dict set dat inline 1 + } + if {"STUB_EXPORT" in $keywords} { + dict set dat extern 1 + dict set dat public 1 + dict set dat export 1 + dict set dat inline 0 + } elseif {"extern" in $keywords} { + dict set dat extern 1 + dict set dat public 1 + } elseif {"static" in $keywords} { + dict set dat public 0 + } + } + if {[dict get $dat inline] && [dict get $dat public]} { + set header [string map {IRM_INLINE {} CTHULHU_INLINE {} static {} inline {} extern {}} [dict get $dat header]] + dict set dat header "extern $header" + } + dict set cfunct $funcname $dat + return + } + } + puts "WARNING: NON CONFORMING FUNCTION DEFINITION: $headers $body" + ::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 c_tcloomethod {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 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_tclcmd {name body {arginfo {}}} { + my variable tclprocs code + + foreach {f v} $arginfo { + dict set tclprocs $name $f $v + } + dict set tclprocs $name body $body + } + 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 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 + } + } + method project-compile-products {} { + set filename [my define get output_c] + set result {} + if {$filename ne {}} { + ::practcl::debug [self] [self class] [self method] project-compile-products $filename + + 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 {}} { + ::practcl::debug [self] [self class] [self method] project-compile-products $filename + 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 project-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]] + ::practcl::debug [self] [my define get filename] WANTS TO GENERATE $filename + my define set cfile $filename + set fout [open $filename w] + puts $fout [my generate-c] + if {[my define get initfunc] ne {}} { + puts $fout "extern int DLLEXPORT [my define get initfunc]( Tcl_Interp *interp ) \x7B" + puts $fout [my generate-loader-module] + 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} + } + method generate-cfile-constant {} { + ::practcl::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 .name=\"$type\",\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 product] { + # Exclude products that will generate their own C files + if {[$obj define get output_c] ne {}} continue + ::practcl::cputs result [$obj generate-cfile-constant] + } + return $result + } + method generate-cfile-header {} { + ::practcl::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) + } + ::practcl::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]\;" + } + } + ::practcl::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]\;" + } + } + } + ::practcl::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)\;" + } + foreach obj [my link list product] { + # Exclude products that will generate their own C files + if {[$obj define get output_c] ne {}} continue + set dat [$obj generate-cfile-header] + if {[string length [string trim $dat]]} { + ::practcl::cputs result "/* BEGIN [$obj define get filename] generate-cfile-header */" + ::practcl::cputs result $dat + ::practcl::cputs result "/* END [$obj define get filename] generate-cfile-header */" + } + } + return $result + } + method generate-cfile-tclapi {} { + ::practcl::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 "/* Tcl Proc $name */" + ::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 "/* OO Method $thisclass $name */" + ::practcl::cputs result "${header} \{${body}\}" + } + # Build the OO_Init function + ::practcl::cputs result "/* Loader for $thisclass */" + ::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 product] { + # Exclude products that will generate their own C files + if {[$obj define get output_c] ne {}} continue + ::practcl::cputs result [$obj generate-cfile-tclapi] + } + return $result + } + method generate-loader-module {} { + ::practcl::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-loader-external] + } else { + ::practcl::cputs result [$obj generate-loader-module] + } + } + return $result + } + method Collate_Source CWD { + my variable methods code cstruct tclprocs + if {[info exists methods]} { + ::practcl::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 {{ } _ : _} OOMethodType_${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]} { + ::practcl::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\[\])" + } + } + } + } + method select {} {} +} + +### +# END: class dynamic.tcl +### +### +# START: class product.tcl +### +::clay::define ::practcl::product { + method code {section body} { + my variable code + ::practcl::cputs code($section) $body + } + method Collate_Source CWD {} + method project-compile-products {} { + set result {} + noop { + set filename [my define get filename] + if {$filename ne {}} { + ::practcl::debug [self] [self class] [self method] project-compile-products $filename + 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 include [my define get include] 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 project-compile-products] + } + 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 + } + method generate-cfile-constant {} { + ::practcl::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) + } + 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 [$obj generate-cfile-constant] + } + return $result + } + method generate-cfile-public-structure {} { + ::practcl::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 product] { + # Exclude products that will generate their own C files + if {[$obj define get output_c] ne {}} continue + ::practcl::cputs result [$obj generate-cfile-public-structure] + } + return $result + } + method generate-cfile-header {} { + ::practcl::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 + set dat [$obj generate-cfile-header] + if {[string length [string trim $dat]]} { + ::practcl::cputs result "/* BEGIN [$obj define get filename] generate-cfile-header */" + ::practcl::cputs result $dat + ::practcl::cputs result "/* END [$obj define get filename] generate-cfile-header */" + } + } + return $result + } + method generate-cfile-global {} { + ::practcl::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(global)]} { + ::practcl::cputs result $code(global) + } + foreach obj [my link list product] { + # Exclude products that will generate their own C files + if {[$obj define get output_c] ne {}} continue + set dat [$obj generate-cfile-global] + if {[string length [string trim $dat]]} { + ::practcl::cputs result "/* BEGIN [$obj define get filename] generate-cfile-global */" + ::practcl::cputs result $dat + ::practcl::cputs result "/* END [$obj define get filename] generate-cfile-global */" + } + } + return $result + } + method generate-cfile-private-typedef {} { + ::practcl::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(private-typedef)]} { + ::practcl::cputs result $code(private-typedef) + } + if {[info exists cstruct]} { + # Add defintion for native c data structures + foreach {name info} $cstruct { + if {[dict get $info public]==1} continue + ::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-cfile-private-typedef] + } + return $result + } + method generate-cfile-private-structure {} { + ::practcl::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(private-structure)]} { + ::practcl::cputs result $code(private-structure) + } + if {[info exists cstruct]} { + foreach {name info} $cstruct { + if {[dict get $info public]==1} continue + 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-cfile-private-structure] + } + return $result + } + method generate-cfile-functions {} { + ::practcl::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 "/* $funcname */" + if {[dict get $info inline] && [dict get $info public]} { + ::practcl::cputs result "\ninline [dict get $info header]\{[dict get $info body]\}" + } else { + ::practcl::cputs result "\n[dict get $info header]\{[dict get $info body]\}" + } + } + } + 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 [$obj generate-cfile-functions] + } + return $result + } + method generate-cfile-tclapi {} { + ::practcl::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) + } + 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 [$obj generate-cfile-tclapi] + } + return $result + } + method generate-hfile-public-define {} { + ::practcl::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-hfile-public-define] + } + return $result + } + method generate-hfile-public-macro {} { + ::practcl::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-hfile-public-macro] + } + return $result + } + method generate-hfile-public-typedef {} { + ::practcl::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 { + if {[dict get $info public]==0} continue + ::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-hfile-public-typedef] + } + return $result + } + method generate-hfile-public-structure {} { + ::practcl::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 get $info public]==0} continue + 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-hfile-public-structure] + } + return $result + } + method generate-hfile-public-headers {} { + ::practcl::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-hfile-public-headers] + } + return $result + } + method generate-hfile-public-function {} { + ::practcl::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-hfile-public-function] + } + return $result + } + method generate-hfile-public-includes {} { + ::practcl::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-hfile-public-includes] { + if {$item ni $includes} { + lappend includes $item + } + } + } + return $includes + } + method generate-hfile-public-verbatim {} { + ::practcl::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-hfile-public-verbatim] { + if {$item ni $includes} { + lappend includes $item + } + } + } + return $includes + } + method generate-loader-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\;" + } + method generate-loader-module {} { + ::practcl::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 item [my link list product] { + if {[$item define get output_c] ne {}} { + ::practcl::cputs result [$item generate-loader-external] + } else { + ::practcl::cputs result [$item generate-loader-module] + } + } + return $result + } + method generate-stub-function {} { + ::practcl::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 IncludeAdd {headervar args} { + upvar 1 $headervar headers + foreach inc $args { + if {[string index $inc 0] ni {< \"}} { + set inc "\"$inc\"" + } + if {$inc ni $headers} { + lappend headers $inc + } + } + } + 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 generate-tcl-pre {} { + ::practcl::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)]} { + set result [::practcl::_tagblock $code(tcl) tcl [my define get filename]] + } + if {[info exists code(tcl-pre)]} { + set result [::practcl::_tagblock $code(tcl) tcl [my define get filename]] + } + foreach mod [my link list product] { + ::practcl::cputs result [$mod generate-tcl-pre] + } + return $result + } + method generate-tcl-post {} { + ::practcl::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-post)]} { + set result [::practcl::_tagblock $code(tcl-post) tcl [my define get filename]] + } + foreach mod [my link list product] { + ::practcl::cputs result [$mod generate-tcl-post] + } + return $result + } + method linktype {} { + return {subordinate product} + } + 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]] + } + method project-static-packages {} { + set result [my define get static_packages] + 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 project-static-packages] { + dict set result $pkg $info + } + } + return $result + } + method toolset-include-directory {} { + ::practcl::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 toolset-include-directory] { + lappend result $path + } + } + return $result + } + method target {method args} { + switch $method { + is_unix { return [expr {$::tcl_platform(platform) eq "unix"}] } + } + } +} +oo::objdefine ::practcl::product { + + method select {object} { + set class [$object define get class] + set mixin [$object define get product] + if {$class eq {} && $mixin eq {}} { + set filename [$object define get filename] + if {$filename ne {} && [file exists $filename]} { + switch [file extension $filename] { + .tcl { + set mixin ::practcl::product.dynamic + } + .h { + set mixin ::practcl::product.cheader + } + .c { + set mixin ::practcl::product.csource + } + .ini { + switch [file tail $filename] { + module.ini { + set class ::practcl::module + } + library.ini { + set class ::practcl::subproject + } + } + } + .so - + .dll - + .dylib - + .a { + set mixin ::practcl::product.clibrary + } + } + } + } + if {$class ne {}} { + $object clay mixinmap core $class + } + if {$mixin ne {}} { + $object clay mixinmap product $mixin + } + } +} +::clay::define ::practcl::product.cheader { + superclass ::practcl::product + method project-compile-products {} {} + method generate-loader-module {} {} +} +::clay::define ::practcl::product.csource { + superclass ::practcl::product + method project-compile-products {} { + set result {} + set filename [my define get filename] + if {$filename ne {}} { + ::practcl::debug [self] [self class] [self method] project-compile-products $filename + 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 project-compile-products] + } + return $result + } +} +::clay::define ::practcl::product.clibrary { + superclass ::practcl::product + method linker-products {configdict} { + return [my define get filename] + } +} +::clay::define ::practcl::product.dynamic { + superclass ::practcl::dynamic ::practcl::product + 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] + } + # Future Development: + # Scan source file to see if it is encoded in criticl or practcl notation + #set thisline {} + #foreach line [split [::practcl::cat $filename] \n] { + # + #} + ::source $filename + if {[my define get output_c] ne {}} { + # Turn into a module if we have an output_c file + my morph ::practcl::module + } + } +} +::clay::define ::practcl::product.critcl { + superclass ::practcl::dynamic ::practcl::product +} + +### +# END: class product.tcl +### +### +# START: class module.tcl +### +::clay::define ::practcl::module { + superclass ::practcl::object ::practcl::product.dynamic + Dict make_object {} + method _MorphPatterns {} { + return {{@name@} {::practcl::module.@name@} ::practcl::module} + } + method add args { + my variable links + set object [::practcl::object new [self] {*}$args] + foreach linktype [$object linktype] { + lappend links($linktype) $object + } + return $object + } + method install-headers args {} + Ensemble make::_preamble {} { + my variable make_object + if {![info exists make_object]} { + set make_object {} + } + } + Ensemble make::pkginfo {} { + ### + # Build local variables needed for install + ### + package require platform + set result {} + set dat [my define dump] + set PKG_DIR [dict get $dat name][dict get $dat version] + dict set result PKG_DIR $PKG_DIR + dict with dat {} + if {![info exists DESTDIR]} { + set DESTDIR {} + } + dict set result profile [::platform::identify] + dict set result os $::tcl_platform(os) + dict set result platform $::tcl_platform(platform) + foreach {field value} $dat { + switch $field { + includedir - + mandir - + datadir - + libdir - + libfile - + name - + output_tcl - + version - + authors - + license - + requires { + dict set result $field $value + } + TEA_PLATFORM { + dict set result platform $value + } + TEACUP_OS { + dict set result os $value + } + TEACUP_PROFILE { + dict set result profile $value + } + TEACUP_ZIPFILE { + dict set result zipfile $value + } + } + } + if {![dict exists $result zipfile]} { + dict set result zipfile "[dict get $result name]-[dict get $result version]-[dict get $result profile].zip" + } + return $result + } + Ensemble make::objects {} { + return $make_object + } + Ensemble make::object name { + if {[dict exists $make_object $name]} { + return [dict get $make_object $name] + } + return {} + } + Ensemble make::reset {} { + foreach {name obj} $make_object { + $obj reset + } + } + Ensemble make::trigger args { + foreach {name obj} $make_object { + if {$name in $args} { + $obj triggers + } + } + } + Ensemble make::depends args { + foreach {name obj} $make_object { + if {$name in $args} { + $obj check + } + } + } + Ensemble make::filename name { + if {[dict exists $make_object $name]} { + return [[dict get $make_object $name] define get filename] + } + } + Ensemble make::target {name Info body} { + set info [uplevel #0 [list subst $Info]] + set nspace [namespace current] + if {[dict exist $make_object $name]} { + set obj [dict get $$make_object $name] + } else { + set obj [::practcl::make_obj new [self] $name $info $body] + dict set make_object $name $obj + dict set target_make $name 0 + dict set target_trigger $name 0 + } + if {[dict exists $info aliases]} { + foreach item [dict get $info aliases] { + if {![dict exists $make_object $item]} { + dict set make_object $item $obj + } + } + } + return $obj + } + clay set method_ensemble make target aliases {task add} + Ensemble make::todo {} { + foreach {name obj} $make_object { + if {[$obj do]} { + lappend result $name + } + } + return $result + } + Ensemble make::do {} { + global CWD SRCDIR project SANDBOX + foreach {name obj} $make_object { + if {[$obj do]} { + eval [$obj define get action] + } + } + } + method child which { + switch $which { + delegate - + organs { + return [list project [my define get project] module [self]] + } + } + } + method generate-c {} { + ::practcl::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 {} + + foreach mod [my link list product] { + # Signal modules to formulate final implementation + $mod go + } + set headers {} + + my IncludeAdd headers + if {[my define get tk 0]} { + my IncludeAdd headers + } + if {[my define get output_h] ne {}} { + my IncludeAdd headers [my define get output_h] + } + my IncludeAdd headers {*}[my define get include] + + foreach mod [my link list dynamic] { + my IncludeAdd headers {*}[$mod define get include] + } + foreach inc $headers { + ::practcl::cputs result "#include $inc" + } + foreach {method} { + generate-cfile-header + generate-cfile-private-typedef + generate-cfile-private-structure + generate-cfile-public-structure + generate-cfile-constant + generate-cfile-global + generate-cfile-functions + generate-cfile-tclapi + } { + set dat [my $method] + if {[string length [string trim $dat]]} { + ::practcl::cputs result "/* BEGIN $method [my define get filename] */" + ::practcl::cputs result $dat + ::practcl::cputs result "/* END $method [my define get filename] */" + } + } + ::practcl::debug [list /[self] [self method] [self class] -- [my define get filename] [info object class [self]]] + return $result + } + method generate-h {} { + ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] + set result {} + foreach method { + generate-hfile-public-define + generate-hfile-public-macro + } { + ::practcl::cputs result "/* BEGIN SECTION $method */" + ::practcl::cputs result [my $method] + ::practcl::cputs result "/* END SECTION $method */" + } + set includes [my generate-hfile-public-includes] + foreach inc $includes { + if {[string index $inc 0] ni {< \"}} { + ::practcl::cputs result "#include \"$inc\"" + } else { + ::practcl::cputs result "#include $inc" + } + } + foreach method { + generate-hfile-public-typedef + generate-hfile-public-structure + } { + ::practcl::cputs result "/* BEGIN SECTION $method */" + ::practcl::cputs result [my $method] + ::practcl::cputs result "/* END SECTION $method */" + } + + foreach file [my generate-hfile-public-verbatim] { + ::practcl::cputs result "/* BEGIN $file */" + ::practcl::cputs result [::practcl::cat $file] + ::practcl::cputs result "/* END $file */" + } + + foreach method { + generate-hfile-public-headers + generate-hfile-public-function + } { + ::practcl::cputs result "/* BEGIN SECTION $method */" + ::practcl::cputs result [my $method] + ::practcl::cputs result "/* END SECTION $method */" + } + return $result + } + method generate-loader {} { + ::practcl::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-pre] + if {[string length [string trim $TCLINIT]]} { + ::practcl::cputs result " if(interp) {\nif(Tcl_Eval(interp,[::practcl::tcl_to_c $TCLINIT])) return TCL_ERROR;\n }" + } + ::practcl::cputs result [my generate-loader-module] + + set TCLINIT [my generate-tcl-post] + if {[string length [string trim $TCLINIT]]} { + ::practcl::cputs result " if(interp) {\nif(Tcl_Eval(interp,[::practcl::tcl_to_c $TCLINIT])) return TCL_ERROR;\n }" + } + 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 + } + 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] + } + my graft module [self] + ::practcl::debug [self] SOURCE $filename + my source $filename + } + method implement path { + my go + my Collate_Source $path + set errs {} + foreach item [my link list dynamic] { + if {[catch {$item implement $path} err errdat]} { + lappend errs "Skipped $item: [$item define get filename] $err" + if {[dict exists $errdat -errorinfo]} { + lappend errs [dict get $errdat -errorinfo] + } else { + lappend errs $errdat + } + } + } + foreach item [my link list module] { + if {[catch {$item implement $path} err errdat]} { + lappend errs "Skipped $item: [$item define get filename] $err" + if {[dict exists $errdat -errorinfo]} { + lappend errs [dict get $errdat -errorinfo] + } else { + lappend errs $errdat + } + } + } + if {[llength $errs]} { + set logfile [file join $::CWD practcl.log] + ::practcl::log $logfile "*** ERRORS ***" + foreach {item trace} $errs { + ::practcl::log $logfile "###\n# ERROR\n###\n$item" + ::practcl::log $logfile "###\n# TRACE\n###\n$trace" + } + ::practcl::log $logfile "*** DEBUG INFO ***" + ::practcl::log $logfile $::DEBUG_INFO + puts stderr "Errors saved to $logfile" + exit 1 + } + ::practcl::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 {}} { + ::practcl::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 + ::practcl::debug [list /[self] [self method] [self class]] + } + method linktype {} { + return {subordinate product dynamic module} + } +} + +### +# END: class module.tcl +### +### +# START: class project baseclass.tcl +### +::clay::define ::practcl::project { + superclass ::practcl::module + method _MorphPatterns {} { + return {{@name@} {::practcl::@name@} {::practcl::project.@name@} {::practcl::project}} + } + constructor args { + my variable define + if {[llength $args] == 1} { + set rawcontents [lindex $args 0] + } else { + set rawcontents $args + } + if {[catch {uplevel 1 [list subst $rawcontents]} contents]} { + set contents $rawcontents + } + ### + # The first instance of ::practcl::project (or its descendents) + # registers itself as the ::practcl::MAIN. If a project other + # than ::practcl::LOCAL is created, odds are that was the one + # the developer intended to be the main project + ### + if {$::practcl::MAIN eq "::practcl::LOCAL"} { + set ::practcl::MAIN [self] + } + # DEFS fields need to be passed unchanged and unsubstituted + # as we need to preserve their escape characters + foreach field {TCL_DEFS DEFS TK_DEFS} { + if {[dict exists $rawcontents $field]} { + dict set contents $field [dict get $rawcontents $field] + } + } + my graft module [self] + array set define $contents + ::practcl::toolset select [self] + my initialize + } + method add_object object { + my link object $object + } + method add_project {pkg info {oodefine {}}} { + ::practcl::debug [self] add_project $pkg $info + set os [my define get TEACUP_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 + set profile [my define get profile release]: + if {[dict exists $info profile $profile]} { + dict set info tag [dict get $info profile $profile] + } + dict set info USEMSVC [my define get USEMSVC 0] + dict set info debug [my define get debug 0] + 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 class subproject.binary] $info]] + } + my link object $obj + oo::objdefine $obj $oodefine + $obj define set masterpath $::CWD + $obj go + return $obj + } + method add_tool {pkg info {oodefine {}}} { + ::practcl::debug [self] add_tool $pkg $info + set info [dict merge [::practcl::local_os] $info] + + set os [dict get $info TEACUP_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 + set profile [my define get profile release]: + if {[dict exists $info profile $profile]} { + dict set info tag [dict get $info profile $profile] + } + set obj ::practcl::OBJECT::TOOL.$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 add tool $obj + oo::objdefine $obj $oodefine + $obj define set masterpath $::CWD + $obj go + return $obj + } + method build-tclcore {} { + set os [my define get TEACUP_OS] + set tcl_config_opts [::practcl::platform::tcl_core_options $os] + set tk_config_opts [::practcl::platform::tk_core_options $os] + + lappend tcl_config_opts --prefix [my define get prefix] --exec-prefix [my define get prefix] + set tclobj [my tclcore] + if {[my define get debug 0]} { + $tclobj define set debug 1 + lappend tcl_config_opts --enable-symbols=true + } + $tclobj define set config_opts $tcl_config_opts + $tclobj go + $tclobj compile + + set _TclSrcDir [$tclobj define get localsrcdir] + my define set tclsrcdir $_TclSrcDir + if {[my define get tk 0]} { + set tkobj [my tkcore] + lappend tk_config_opts --with-tcl=[::practcl::file_relative [$tkobj define get builddir] [$tclobj define get builddir]] + if {[my define get debug 0]} { + $tkobj define set debug 1 + lappend tk_config_opts --enable-symbols=true + } + $tkobj define set config_opts $tk_config_opts + $tkobj compile + } + } + method child which { + switch $which { + delegate - + 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 + } + method project {pkg args} { + set obj [namespace current]::PROJECT.$pkg + if {[llength $args]==0} { + return $obj + } + ${obj} {*}$args + } + method tclcore {} { + if {[info commands [set obj [my clay delegate tclcore]]] ne {}} { + return $obj + } + if {[info commands [set obj [my project TCLCORE]]] ne {}} { + my graft tclcore $obj + return $obj + } + if {[info commands [set obj [my project tcl]]] ne {}} { + my graft tclcore $obj + return $obj + } + if {[info commands [set obj [my tool tcl]]] ne {}} { + my graft tclcore $obj + return $obj + } + # Provide a fallback + set obj [my add_tool tcl { + tag release class subproject.core + fossil_url http://core.tcl.tk/tcl + }] + my graft tclcore $obj + return $obj + } + method tkcore {} { + if {[set obj [my clay delegate tkcore]] ne {}} { + return $obj + } + if {[set obj [my project tk]] ne {}} { + my graft tkcore $obj + return $obj + } + if {[set obj [my tool tk]] ne {}} { + my graft tkcore $obj + return $obj + } + # Provide a fallback + set obj [my add_tool tk { + tag release class tool.core + fossil_url http://core.tcl.tk/tk + }] + my graft tkcore $obj + return $obj + } + method tool {pkg args} { + set obj ::practcl::OBJECT::TOOL.$pkg + if {[llength $args]==0} { + return $obj + } + ${obj} {*}$args + } +} + +### +# END: class project baseclass.tcl +### +### +# START: class project library.tcl +### +::clay::define ::practcl::library { + superclass ::practcl::project + method clean {PATH} { + set objext [my define get OBJEXT o] + foreach {ofile info} [my project-compile-products] { + if {[file exists [file join $PATH objs $ofile].${objext}]} { + file delete [file join $PATH objs $ofile].${objext} + } + } + foreach ofile [glob -nocomplain [file join $PATH *.${objext}]] { + file delete $ofile + } + foreach ofile [glob -nocomplain [file join $PATH objs *]] { + file delete $ofile + } + set libfile [my define get libfile] + if {[file exists [file join $PATH $libfile]]} { + file delete [file join $PATH $libfile] + } + my implement $PATH + } + method project-compile-products {} { + set result {} + foreach item [my link list subordinate] { + lappend result {*}[$item project-compile-products] + } + set filename [my define get output_c] + if {$filename ne {}} { + ::practcl::debug [self] [self class] [self method] project-compile-products $filename + set ofile [file rootname [file tail $filename]]_main + lappend result $ofile [list cfile $filename extra [my define get extra] external [string is true -strict [my define get external]]] + } + return $result + } + method go {} { + ::practcl::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 + } + } + ::practcl::debug [list /[self] [self method] [self class] -- [my define get filename] [info object class [self]]] + } + method generate-decls {pkgname path} { + ::practcl::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 + } + method implement path { + my go + my Collate_Source $path + set errs {} + foreach item [my link list dynamic] { + if {[catch {$item implement $path} err errdat]} { + lappend errs "Skipped $item: [$item define get filename] $err" + if {[dict exists $errdat -errorinfo]} { + lappend errs [dict get $errdat -errorinfo] + } else { + lappend errs $errdat + } + } + } + foreach item [my link list module] { + if {[catch {$item implement $path} err errdat]} { + lappend errs "Skipped $item: [$item define get filename] $err" + if {[dict exists $errdat -errorinfo]} { + lappend errs [dict get $errdat -errorinfo] + } else { + lappend errs $errdat + } + } + } + if {[llength $errs]} { + set logfile [file join $::CWD practcl.log] + ::practcl::log $logfile "*** ERRORS ***" + foreach {item trace} $errs { + ::practcl::log $logfile "###\n# ERROR\n###$item" + ::practcl::log $logfile "###\n# TRACE\n###$trace" + } + ::practcl::log $logfile "*** DEBUG INFO ***" + ::practcl::log $logfile $::DEBUG_INFO + puts stderr "Errors saved to $logfile" + exit 1 + } + 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} 1" + 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-pre] + puts $tclout [my generate-tcl-loader] + puts $tclout [my generate-tcl-post] + close $tclout + } + } + method generate-make path { + my build-Makefile $path [self] + } + method linktype {} { + return library + } + 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 {[my define get SHARED_BUILD 0]} { + 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 {{filename {}}} { + 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 + } + method static_library {{filename {}}} { + 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]].a + return $outfile + } +} + +### +# END: class project library.tcl +### +### +# START: class project tclkit.tcl +### +::clay::define ::practcl::tclkit { + superclass ::practcl::library + method build-tclkit_main {PROJECT PKG_OBJS} { + ### + # Build static package list + ### + set statpkglist {} + foreach cobj [list {*}${PKG_OBJS} $PROJECT] { + foreach {pkg info} [$cobj project-static-packages] { + dict set statpkglist $pkg $info + } + } + foreach {ofile info} [${PROJECT} project-compile-products] { + if {![dict exists $info object]} continue + set cobj [dict get $info object] + foreach {pkg info} [$cobj project-static-packages] { + 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 "[$PROJECT define get ZIPFS_VOLUME]app"] + set vfs_main "${vfsroot}/${mainscript}" + + set map {} + foreach var { + vfsroot mainhook mainfunc vfs_main + } { + dict set map %${var}% [set $var] + } + set thread_init_script {namespace eval ::starkit {}} + append thread_init_script \n [list set ::starkit::topdir $vfsroot] + set preinitscript { +set ::odie(boot_vfs) %vfsroot% +set ::SRCDIR $::odie(boot_vfs) +namespace eval ::starkit {} +set ::starkit::topdir %vfsroot% +if {[file exists [file join %vfsroot% tcl_library init.tcl]]} { + set ::tcl_library [file join %vfsroot% tcl_library] + set ::auto_path {} +} +if {[file exists [file join %vfsroot% tk_library tk.tcl]]} { + set ::tk_library [file join %vfsroot% 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(); +} + # 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 {![$PROJECT define get tip_430 0]} { + # Add declarations of functions that tip430 puts in the stub files + $PROJECT code public-header { +int TclZipfs_Init(Tcl_Interp *interp); +int TclZipfs_Mount( + Tcl_Interp *interp, + const char *mntpt, + const char *zipname, + const char *passwd +); +int TclZipfs_Mount_Buffer( + Tcl_Interp *interp, + const char *mntpt, + unsigned char *data, + size_t datalen, + int copy +); +} + ::practcl::cputs zvfsboot { TclZipfs_Init(NULL);} + } + ::practcl::cputs zvfsboot " if(!TclZipfs_Mount(NULL, \"app\", archive, 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 TEACUP_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; + } + +} + if {![$PROJECT define get tip_430 0]} { + ::practcl::cputs appinit { TclZipfs_Init(interp);} + } + 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 + } + if {![dict exists $info version]} { + error "$statpkg HAS NO VERSION" + } + # 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 ::starkit::static_packages(${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 $::starkit::topdir pkgIndex.tcl]]} { + #In a wrapped exe, we don't go out to the environment + set dir $::starkit::topdir + source [file join $::starkit::topdir pkgIndex.tcl] +}} + append thread_init_script $main_init_script + append main_init_script \n { +# 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 thread_init_script \n [list set ::starkit::thread_init $thread_init_script] + append main_init_script \n [list set ::starkit::thread_init $thread_init_script] + 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 $thread_init_script]);" + practcl::cputs appinit { return TCL_OK;} + $PROJECT c_function [string map $map "int %mainfunc%(Tcl_Interp *interp)"] [string map $map $appinit] + } + method Collate_Source CWD { + next $CWD + set name [my define get name] + # Assume a static shell + if {[my define exists SHARED_BUILD]} { + my define set SHARED_BUILD 0 + } + 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 TEACUP_OS] + if {[my define get SHARED_BUILD 0]} { + puts [list BUILDING TCLSH FOR OS $os] + } else { + puts [list BUILDING KIT FOR OS $os] + } + set TCLOBJ [$PROJECT tclcore] + ::practcl::toolset select $TCLOBJ + + set TCLSRCDIR [$TCLOBJ define get srcdir] + set PKG_OBJS {} + foreach item [$PROJECT link list core.library] { + if {[string is true [$item define get static]]} { + lappend PKG_OBJS $item + } + } + 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 + if {![my define get SHARED_BUILD 0]} { + 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]] + } + + if {![my define get SHARED_BUILD 0]} { + ### + # 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 tclZipfs.c] + if {![$PROJECT define exists ZIPFS_VOLUME]} { + $PROJECT define set ZIPFS_VOLUME "zipfs:/" + } + $PROJECT code header "#define ZIPFS_VOLUME \"[$PROJECT define get ZIPFS_VOLUME]\"" + if {[file exists $zipfs]} { + $TCLOBJ define set tip_430 1 + my define set tip_430 1 + } else { + # The Tclconfig project maintains a mirror of the version + # released with the Tcl core + my define set tip_430 0 + set tclzipfs_c [my define get tclzipfs_c] + if {![file exists $tclzipfs_c]} { + ::practcl::LOCAL tool tclconfig unpack + set COMPATSRCROOT [::practcl::LOCAL tool tclconfig define get srcdir] + set tclzipfs_c [file join $COMPATSRCROOT compat tclZipfs.c] + } + my add class csource ofile tclZipfs.o filename $tclzipfs_c \ + extra -I[::practcl::file_relative $CWD [file join $TCLSRCDIR compat zlib contrib minizip]] + } + + my define add include_dir [file join $TCLSRCDIR generic] + my define add include_dir [file join $TCLSRCDIR $PLATFORM_SRC_DIR] + # This file will implement TCL_LOCAL_APPINIT and TCL_LOCAL_MAIN_HOOK + my build-tclkit_main $PROJECT $PKG_OBJS + } + 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 libsrcdir [$item define get srcdir] + if {[file exists [file join $libsrcdir library]]} { + ::practcl::copyDir [file join $libsrcdir library] [file join $vfspath ${name}_library] + } + } + # Assume the user will populate the VFS path + #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 pkgIndex.tcl] w] + puts $fout [string map [list %platform% [my define get TEACUP_PROFILE]] {set ::tcl_teapot_profile {%platform%}}] + puts $fout { +namespace eval ::starkit {} +set ::PKGIDXFILE [info script] +set dir [file dirname $::PKGIDXFILE] +if {$::tcl_platform(platform) eq "windows"} { + set ::starkit::localHome [file join [file normalize $::env(LOCALAPPDATA)] tcl] +} else { + set ::starkit::localHome [file normalize ~/tcl] +} +set ::tcl_teapot [file join $::starkit::localHome teapot $::tcl_teapot_profile] +lappend ::auto_path $::tcl_teapot +} + puts $fout [list proc installDir [info args ::practcl::installDir] [info body ::practcl::installDir]] + set buffer [::practcl::pkgindex_path $vfspath] + puts $fout $buffer + puts $fout { +# Advertise statically linked packages +foreach {pkg script} [array get ::starkit::static_packages] { + eval $script +} +} + puts $fout { +### +# Cache binary packages distributed as dynamic libraries in a known location +### +foreach teapath [glob -nocomplain [file join $dir teapot $::tcl_teapot_profile *]] { + set pkg [file tail $teapath] + set pkginstall [file join $::tcl_teapot $pkg] + if {![file exists $pkginstall]} { + installDir $teapath $pkginstall + } +} +} + close $fout + + set EXEEXT [my define get EXEEXT] + set tclkit_bare [my define get tclkit_bare] + ::practcl::mkzip ${exename}${EXEEXT} $tclkit_bare $vfspath + if { [my define get TEACUP_OS] ne "windows" } { + file attributes ${exename}${EXEEXT} -permissions a+x + } + } +} + +### +# END: class project tclkit.tcl +### +### +# START: class distro baseclass.tcl +### +::clay::define ::practcl::distribution { + method scm_info {} { + return { + scm None + hash {} + maxdate {} + tags {} + isodate {} + } + } + method DistroMixIn {} { + my define set scm none + } + method Sandbox {} { + if {[my define exists sandbox]} { + return [my define get sandbox] + } + if {[my clay delegate project] ni {::noop {}}} { + set sandbox [my define get sandbox] + if {$sandbox ne {}} { + my define set sandbox $sandbox + return $sandbox + } + } + set sandbox [file normalize [file join $::CWD ..]] + my define set sandbox $sandbox + return $sandbox + } + method SrcDir {} { + set pkg [my define get name] + if {[my define exists srcdir]} { + return [my define get srcdir] + } + set sandbox [my Sandbox] + set srcdir [file join [my Sandbox] $pkg] + my define set srcdir $srcdir + return $srcdir + } + method ScmTag {} {} + method ScmClone {} {} + method ScmUnpack {} {} + method ScmUpdate {} {} + method Unpack {} { + set srcdir [my SrcDir] + if {[file exists $srcdir]} { + return + } + set pkg [my define get name] + if {[my define exists download]} { + # Utilize a staged download + set download [my define get download] + if {[file exists [file join $download $pkg.zip]]} { + ::practcl::tcllib_require zipfile::decode + ::zipfile::decode::unzipfile [file join $download $pkg.zip] $srcdir + return + } + } + my ScmUnpack + } +} +oo::objdefine ::practcl::distribution { + method Sandbox {object} { + if {[$object define exists sandbox]} { + return [$object define get sandbox] + } + if {[$object clay delegate project] ni {::noop {}}} { + set sandbox [$object define get sandbox] + if {$sandbox ne {}} { + $object define set sandbox $sandbox + return $sandbox + } + } + set pkg [$object define get name] + set sandbox [file normalize [file join $::CWD ..]] + $object define set sandbox $sandbox + return $sandbox + } + + method select object { + if {[$object define exists scm]} { + return [$object define get scm] + } + + set pkg [$object define get name] + if {[$object define get srcdir] ne {}} { + set srcdir [$object define get srcdir] + } else { + set srcdir [file join [my Sandbox $object] $pkg] + $object define set srcdir $srcdir + } + + set classprefix ::practcl::distribution. + if {[file exists $srcdir]} { + foreach class [::info commands ${classprefix}*] { + if {[$class claim_path $srcdir]} { + $object clay mixinmap distribution $class + set name [$class claim_option] + $object define set scm $name + return $name + } + } + } + foreach class [::info commands ${classprefix}*] { + if {[$class claim_object $object]} { + $object clay mixinmap distribution $class + set name [$class claim_option] + $object define set scm $name + return $name + } + } + if {[$object define get scm] eq {} && [$object define exists file_url]} { + set class ::practcl::distribution.snapshot + set name [$class claim_option] + $object define set scm $name + $object clay mixinmap distribution $class + return $name + } + error "Cannot determine source distribution method" + } + + method claim_option {} { + return Unknown + } + + method claim_object object { + return false + } + + method claim_path path { + return false + } +} + +### +# END: class distro baseclass.tcl +### +### +# START: class distro snapshot.tcl +### +::clay::define ::practcl::distribution.snapshot { + superclass ::practcl::distribution + method ScmUnpack {} { + set srcdir [my SrcDir] + if {[file exists [file join $srcdir .download]]} { + return 0 + } + set dpath [::practcl::LOCAL define get download] + set url [my define get file_url] + set fname [file tail $url] + set archive [file join $dpath $fname] + if {![file exists $archive]} { + ::http::wget $url $archive + } + set CWD [pwd] + switch [file extension $fname] { + .zip { + # Zipfile + + } + .tar { + ::practcl::tcllib_require tar + } + .tgz - + .gz { + # Tarball + ::practcl::tcllib_require tcl::transform::zlib + ::practcl::tcllib_require tar + set fh [::open $archive] + fconfigure $fh -encoding binary -translation lf -eofchar {} + ::tcl::transform::zlib $fh + } + } + set fosdb [my ScmClone] + set tag [my ScmTag] + file mkdir $srcdir + ::practcl::fossil $srcdir open $fosdb $tag + return 1 + } +} +oo::objdefine ::practcl::distribution.snapshot { + + method claim_object object { + return false + } + + method claim_option {} { + return snapshot + } + + method claim_path path { + if {[file exists [file join $path .download]]} { + return true + } + return false + } +} + +### +# END: class distro snapshot.tcl +### +### +# START: class distro fossil.tcl +### +::clay::define ::practcl::distribution.fossil { + superclass ::practcl::distribution + method scm_info {} { + set info [next] + dict set info scm fossil + foreach {field value} [::practcl::fossil_status [my define get srcdir]] { + dict set info $field $value + } + return $info + } + method ScmClone {} { + set srcdir [my SrcDir] + if {[file exists [file join $srcdir .fslckout]]} { + return + } + if {[file exists [file join $srcdir _FOSSIL_]]} { + return + } + if {![::info exists ::practcl::fossil_dbs]} { + # Get a list of local fossil databases + set ::practcl::fossil_dbs [exec fossil all list] + } + set pkg [my define get name] + # Return an already downloaded fossil repo + foreach line [split $::practcl::fossil_dbs \n] { + set line [string trim $line] + if {[file rootname [file tail $line]] eq $pkg} { + return $line + } + } + set download [::practcl::LOCAL define get download] + set fosdb [file join $download $pkg.fos] + if {[file exists $fosdb]} { + return $fosdb + } + + file mkdir [file join $download fossil] + set fosdb [file join $download fossil $pkg.fos] + if {[file exists $fosdb]} { + return $fosdb + } + + set cloned 0 + # Attempt to clone from a local network mirror + if {[::practcl::LOCAL define exists fossil_mirror]} { + set localmirror [::practcl::LOCAL define get fossil_mirror] + catch { + ::practcl::doexec fossil clone $localmirror/$pkg $fosdb + set cloned 1 + } + if {$cloned} { + return $fosdb + } + } + # Attempt to clone from the canonical source + if {[my define get fossil_url] ne {}} { + catch { + ::practcl::doexec fossil clone [my define get fossil_url] $fosdb + set cloned 1 + } + if {$cloned} { + return $fosdb + } + } + # Fall back to the fossil mirror on the island of misfit toys + ::practcl::doexec fossil clone http://fossil.etoyoc.com/fossil/$pkg $fosdb + return $fosdb + } + method ScmTag {} { + if {[my define exists scm_tag]} { + return [my define get scm_tag] + } + if {[my define exists tag]} { + set tag [my define get tag] + } else { + set tag trunk + } + my define set scm_tag $tag + return $tag + } + method ScmUnpack {} { + set srcdir [my SrcDir] + if {[file exists [file join $srcdir .fslckout]]} { + return 0 + } + if {[file exists [file join $srcdir _FOSSIL_]]} { + return 0 + } + set CWD [pwd] + set fosdb [my ScmClone] + set tag [my ScmTag] + file mkdir $srcdir + ::practcl::fossil $srcdir open $fosdb $tag + return 1 + } + method ScmUpdate {} { + if {[my ScmUnpack]} { + return + } + set srcdir [my SrcDir] + set tag [my ScmTag] + ::practcl::fossil $srcdir update $tag + } +} +oo::objdefine ::practcl::distribution.fossil { + + # Check for markers in the metadata + method claim_object obj { + set path [$obj define get srcdir] + if {[my claim_path $path]} { + return true + } + if {[$obj define get fossil_url] ne {}} { + return true + } + return false + } + + method claim_option {} { + return fossil + } + + # Check for markers in the source root + method claim_path path { + if {[file exists [file join $path .fslckout]]} { + return true + } + if {[file exists [file join $path _FOSSIL_]]} { + return true + } + return false + } +} + +### +# END: class distro fossil.tcl +### +### +# START: class distro git.tcl +### +::clay::define ::practcl::distribution.git { + superclass ::practcl::distribution + method ScmTag {} { + if {[my define exists scm_tag]} { + return [my define get scm_tag] + } + if {[my define exists tag]} { + set tag [my define get tag] + } else { + set tag master + } + my define set scm_tag $tag + return $tag + } + method ScmUnpack {} { + set srcdir [my SrcDir] + if {[file exists [file join $srcdir .git]]} { + return 0 + } + set CWD [pwd] + set tag [my ScmTag] + set pkg [my define get name] + if {[my define exists git_url]} { + ::practcl::doexec git clone --branch $tag [my define get git_url] $srcdir + } else { + ::practcl::doexec git clone --branch $tag https://github.com/eviltwinskippy/$pkg $srcdir + } + return 1 + } + method ScmUpdate {} { + if {[my ScmUnpack]} { + return + } + set CWD [pwd] + set srcdir [my SrcDir] + set tag [my ScmTag] + ::practcl::doexec_in $srcdir git pull + cd $CWD + } +} +oo::objdefine ::practcl::distribution.git { + + method claim_object obj { + set path [$obj define get srcdir] + if {[my claim_path $path]} { + return true + } + if {[$obj define get git_url] ne {}} { + return true + } + return false + } + + method claim_option {} { + return git + } + + method claim_path path { + if {[file exists [file join $path .git]]} { + return true + } + return false + } +} + +### +# END: class distro git.tcl +### +### +# START: class subproject baseclass.tcl +### +::clay::define ::practcl::subproject { + superclass ::practcl::module + method _MorphPatterns {} { + return {{::practcl::subproject.@name@} {::practcl::@name@} {@name@} {::practcl::subproject}} + } + method BuildDir {PWD} { + return [my define get srcdir] + } + method child which { + switch $which { + delegate - + 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 compile {} {} + method go {} { + ::practcl::distribution select [self] + set name [my define get name] + my define set builddir [my BuildDir [my define get masterpath]] + my define set builddir [my BuildDir [my define get masterpath]] + my sources + } + method install args {} + method linktype {} { + return {subordinate package} + } + method linker-products {configdict} {} + method linker-external {configdict} { + if {[dict exists $configdict PRACTCL_PKG_LIBS]} { + return [dict get $configdict PRACTCL_PKG_LIBS] + } + if {[dict exists $configdict LIBS]} { + return [dict get $configdict LIBS] + } + } + method linker-extra {configdict} { + if {[dict exists $configdict PRACTCL_LINKER_EXTRA]} { + return [dict get $configdict PRACTCL_LINKER_EXTRA] + } + return {} + } + method env-bootstrap {} { + set pkg [my define get pkg_name [my define get name]] + package require $pkg + } + method env-exec {} {} + method env-install {} { + my unpack + } + method env-load {} { + my variable loaded + if {[info exists loaded]} { + return 0 + } + if {![my env-present]} { + my env-install + } + my env-bootstrap + set loaded 1 + } + method env-present {} { + set pkg [my define get pkg_name [my define get name]] + if {[catch [list package require $pkg]]} { + return 0 + } + return 1 + } + method sources {} {} + method update {} { + my ScmUpdate + } + method unpack {} { + cd $::CWD + ::practcl::distribution select [self] + my Unpack + ::practcl::toolset select [self] + cd $::CWD + } +} +::clay::define ::practcl::subproject.source { + superclass ::practcl::subproject ::practcl::library + method env-bootstrap {} { + set LibraryRoot [file join [my define get srcdir] [my define get module_root modules]] + if {[file exists $LibraryRoot] && $LibraryRoot ni $::auto_path} { + set ::auto_path [linsert $::auto_path 0 $LibraryRoot] + } + } + method env-present {} { + set path [my define get srcdir] + return [file exists $path] + } + method linktype {} { + return {subordinate package source} + } +} +::clay::define ::practcl::subproject.teapot { + superclass ::practcl::subproject + method env-bootstrap {} { + set pkg [my define get pkg_name [my define get name]] + package require $pkg + } + method env-install {} { + set pkg [my define get pkg_name [my define get name]] + set download [my define get download] + my unpack + set prefix [string trimleft [my define get prefix] /] + ::practcl::tcllib_require zipfile::decode + ::zipfile::decode::unzipfile [file join $download $pkg.zip] [file join $prefix lib $pkg] + } + method env-present {} { + set pkg [my define get pkg_name [my define get name]] + if {[catch [list package require $pkg]]} { + return 0 + } + return 1 + } + method install DEST { + set pkg [my define get pkg_name [my define get name]] + set download [my define get download] + my unpack + set prefix [string trimleft [my define get prefix] /] + ::practcl::tcllib_require zipfile::decode + ::zipfile::decode::unzipfile [file join $download $pkg.zip] [file join $DEST $prefix lib $pkg] + } +} +::clay::define ::practcl::subproject.kettle { + superclass ::practcl::subproject + method kettle {path args} { + my variable kettle + if {![info exists kettle]} { + ::practcl::LOCAL tool kettle env-load + set kettle [file join [::practcl::LOCAL tool kettle define get srcdir] kettle] + } + set srcdir [my SourceRoot] + ::practcl::dotclexec $kettle -f [file join $srcdir build.tcl] {*}$args + } + method install DEST { + my kettle reinstall --prefix $DEST + } +} +::clay::define ::practcl::subproject.critcl { + superclass ::practcl::subproject + method install DEST { + my critcl -pkg [my define get name] + set srcdir [my SourceRoot] + ::practcl::copyDir [file join $srcdir [my define get name]] [file join $DEST lib [my define get name]] + } +} +::clay::define ::practcl::subproject.sak { + superclass ::practcl::subproject + method env-bootstrap {} { + set LibraryRoot [file join [my define get srcdir] [my define get module_root modules]] + if {[file exists $LibraryRoot] && $LibraryRoot ni $::auto_path} { + set ::auto_path [linsert $::auto_path 0 $LibraryRoot] + } + } + method env-install {} { + ### + # Handle teapot installs + ### + set pkg [my define get pkg_name [my define get name]] + my unpack + set prefix [my define get prefix [file normalize [file join ~ tcl]]] + set srcdir [my define get srcdir] + ::practcl::dotclexec [file join $srcdir installer.tcl] \ + -apps -app-path [file join $prefix apps] \ + -html -html-path [file join $prefix doc html $pkg] \ + -pkg-path [file join $prefix lib $pkg] \ + -no-nroff -no-wait -no-gui + } + method env-present {} { + set path [my define get srcdir] + return [file exists $path] + } + method install DEST { + ### + # Handle teapot installs + ### + set pkg [my define get pkg_name [my define get name]] + my unpack + set prefix [string trimleft [my define get prefix] /] + set srcdir [my define get srcdir] + ::practcl::dotclexec [file join $srcdir installer.tcl] \ + -pkg-path [file join $DEST $prefix lib $pkg] \ + -no-examples -no-html -no-nroff \ + -no-wait -no-gui -no-apps + } + method install-module {DEST args} { + set srcdir [my define get srcdir] + if {[llength $args]==1 && [lindex $args 0] in {* all}} { + set pkg [my define get pkg_name [my define get name]] + ::practcl::dotclexec [file join $srcdir installer.tcl] \ + -pkg-path [file join $DEST $pkg] \ + -no-examples -no-html -no-nroff \ + -no-wait -no-gui -no-apps + } else { + foreach module $args { + ::practcl::installModule [file join $srcdir modules $module] [file join $DEST $module] + } + } + } +} +::clay::define ::practcl::subproject.practcl { + superclass ::practcl::subproject + method env-bootstrap {} { + set LibraryRoot [file join [my define get srcdir] [my define get module_root modules]] + if {[file exists $LibraryRoot] && $LibraryRoot ni $::auto_path} { + set ::auto_path [linsert $::auto_path 0 $LibraryRoot] + } + } + method env-install {} { + ### + # Handle teapot installs + ### + set pkg [my define get pkg_name [my define get name]] + my unpack + set prefix [my define get prefix [file normalize [file join ~ tcl]]] + set srcdir [my define get srcdir] + ::practcl::dotclexec [file join $srcdir make.tcl] install [file join $prefix lib $pkg] + } + method install DEST { + ### + # Handle teapot installs + ### + set pkg [my define get pkg_name [my define get name]] + my unpack + set prefix [string trimleft [my define get prefix] /] + set srcdir [my define get srcdir] + puts [list INSTALLING [my define get name] to [file join $DEST $prefix lib $pkg]] + ::practcl::dotclexec [file join $srcdir make.tcl] install [file join $DEST $prefix lib $pkg] + } + method install-module {DEST args} { + set pkg [my define get pkg_name [my define get name]] + set srcdir [my define get srcdir] + ::practcl::dotclexec [file join $srcdir make.tcl] install-module $DEST {*}$args + } +} + +### +# END: class subproject baseclass.tcl +### +### +# START: class subproject binary.tcl +### +::clay::define ::practcl::subproject.binary { + superclass ::practcl::subproject + method clean {} { + set builddir [file normalize [my define get builddir]] + if {![file exists $builddir]} return + if {[file exists [file join $builddir make.tcl]]} { + ::practcl::domake.tcl $builddir clean + } else { + catch {::practcl::domake $builddir clean} + } + } + method env-install {} { + ### + # Handle tea installs + ### + set pkg [my define get pkg_name [my define get name]] + set os [::practcl::local_os] + my define set os $os + my unpack + set prefix [my define get prefix [file normalize [file join ~ tcl]]] + set srcdir [my define get srcdir] + lappend options --prefix $prefix --exec-prefix $prefix + my define set config_opts $options + my go + my clean + my compile + my make install {} + } + method project-compile-products {} {} + method ComputeInstall {} { + if {[my define exists install]} { + switch [my define get install] { + static { + my define set static 1 + my define set autoload 0 + } + static-autoload { + my define set static 1 + my define set autoload 1 + } + vfs { + my define set static 0 + my define set autoload 0 + my define set vfsinstall 1 + } + null { + my define set static 0 + my define set autoload 0 + my define set vfsinstall 0 + } + default { + + } + } + } + } + method go {} { + next + ::practcl::distribution select [self] + my ComputeInstall + 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 project-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 {}} { + my unpack + set info [my read_configuration] + 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 project-static-packages] { + dict set result $pkg $info + } + } + return $result + } + method BuildDir {PWD} { + set name [my define get name] + set debug [my define get debug 0] + if {[my define get LOCAL 0]} { + return [my define get builddir [file join $PWD local $name]] + } + if {$debug} { + return [my define get builddir [file join $PWD debug $name]] + } else { + return [my define get builddir [file join $PWD pkg $name]] + } + } + method compile {} { + set name [my define get name] + set PWD $::CWD + cd $PWD + my unpack + set srcdir [file normalize [my SrcDir]] + set localsrcdir [my MakeDir $srcdir] + my define set localsrcdir $localsrcdir + my Collate_Source $PWD + ### + # Build a starter VFS for both Tcl and wish + ### + set srcdir [my define get srcdir] + if {[my define get static 1]} { + puts "BUILDING Static $name $srcdir" + } else { + puts "BUILDING Dynamic $name $srcdir" + } + my make compile + cd $PWD + } + method Configure {} { + cd $::CWD + my unpack + ::practcl::toolset select [self] + set srcdir [file normalize [my define get srcdir]] + set builddir [file normalize [my define get builddir]] + file mkdir $builddir + my make autodetect + } + method install DEST { + set PWD [pwd] + 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 $DEST [string trimleft $PREFIX /] lib [file tail $teapath]] + ::practcl::copyDir $teapath $dest + return + } + } + } + my compile + my make install $DEST + cd $PWD + } +} +::clay::define ::practcl::subproject.tea { + superclass ::practcl::subproject.binary +} +::clay::define ::practcl::subproject.library { + superclass ::practcl::subproject.binary ::practcl::library + method install DEST { + my compile + } +} +::clay::define ::practcl::subproject.external { + superclass ::practcl::subproject.binary + method install DEST { + my compile + } +} + +### +# END: class subproject binary.tcl +### +### +# START: class subproject core.tcl +### +::clay::define ::practcl::subproject.core { + superclass ::practcl::subproject.binary + method env-bootstrap {} {} + method env-present {} { + set PREFIX [my define get prefix] + set name [my define get name] + set fname [file join $PREFIX lib ${name}Config.sh] + return [file exists $fname] + } + method env-install {} { + my unpack + set os [::practcl::local_os] + + set prefix [my define get prefix [file normalize [file join ~ tcl]]] + lappend options --prefix $prefix --exec-prefix $prefix + my define set config_opts $options + puts [list [self] OS [dict get $os TEACUP_OS] options $options] + my go + my compile + my make install {} + } + method go {} { + my define set core_binary 1 + next + } + method linktype {} { + return {subordinate core.library} + } +} + +### +# END: class subproject core.tcl +### +### +# START: class tool.tcl +### +set ::practcl::MAIN ::practcl::LOCAL +set ::auto_index(::practcl::LOCAL) { + ::practcl::project create ::practcl::LOCAL + ::practcl::LOCAL define set [::practcl::local_os] + ::practcl::LOCAL define set LOCAL 1 + + # Until something better comes along, use ::practcl::LOCAL + # as our main project + # Add tclconfig as a project of record + ::practcl::LOCAL add_tool tclconfig { + name tclconfig tag practcl class subproject.source fossil_url http://core.tcl.tk/tclconfig + } + # Add tcllib as a project of record + ::practcl::LOCAL add_tool tcllib { + tag trunk class sak fossil_url http://core.tcl.tk/tcllib + } + ::practcl::LOCAL add_tool kettle { + tag trunk class sak fossil_url http://fossil.etoyoc.com/fossil/kettle + } + ::practcl::LOCAL add_tool tclvfs { + tag trunk class tea + fossil_url http://fossil.etoyoc.com/fossil/tclvfs + } + ::practcl::LOCAL add_tool critcl { + tag master class subproject.binary + git_url http://github.com/andreas-kupries/critcl + modules lib + } { + method env-bootstrap {} { + package require critcl::app + } + method env-install {} { + my unpack + set prefix [my define get prefix [file join [file normalize ~] tcl]] + set srcdir [my define get srcdir] + ::practcl::dotclexec [file join $srcdir build.tcl] install [file join $prefix lib] + } + } + ::practcl::LOCAL add_tool odie { + tag trunk class subproject.source + fossil_url http://fossil.etoyoc.com/fossil/odie + } + ::practcl::LOCAL add_tool tcl { + tag release class subproject.core + fossil_url http://core.tcl.tk/tcl + } + ::practcl::LOCAL add_tool tk { + tag release class subproject.core + fossil_url http://core.tcl.tk/tcl + } + ::practcl::LOCAL add_tool sqlite { + tag practcl + class subproject.tea + pkg_name sqlite3 + fossil_url http://fossil.etoyoc.com/fossil/sqlite + } +} + +### +# END: class tool.tcl +### + +namespace eval ::practcl { + namespace export * +} + Index: tcl.m4 ================================================================== --- tcl.m4 +++ tcl.m4 @@ -3,21 +3,26 @@ # This file provides a set of autoconf macros to help TEA-enable # a Tcl extension. # # Copyright (c) 1999-2000 Ajuba Solutions. # Copyright (c) 2002-2005 ActiveState Corporation. +# Copyright (c) 2012-2018 Sean Woods. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. AC_PREREQ(2.57) # Possible values for key variables defined: # # TEA_WINDOWINGSYSTEM - win32 aqua x11 (mirrors 'tk windowingsystem') +# PRACTCL_WINDOWINGSYSTEM - windows cocoa hitheme x11 sdl # TEA_PLATFORM - windows unix # TEA_TK_EXTENSION - True if this is a Tk extension +# TEACUP_OS - windows macosx linux generic +# TEACUP_TOOLSET - Toolset in use (gcc,mingw,msvc,llvm) +# TEACUP_PROFILE - win32 # #------------------------------------------------------------------------ # TEA_PATH_TCLCONFIG -- # @@ -210,10 +215,11 @@ # if test x"${no_tk}" = x ; then # we reset no_tk in case something fails here no_tk=true + TEA_TK_EXTENSION=0 AC_ARG_WITH(tk, AC_HELP_STRING([--with-tk], [directory containing tk configuration (tkConfig.sh)]), with_tkconfig="${withval}") AC_MSG_CHECKING([for Tk configuration]) @@ -339,10 +345,11 @@ if test x"${ac_cv_c_tkconfig}" = x ; then TK_BIN_DIR="# no Tk configs found" AC_MSG_ERROR([Can't find Tk configuration definitions. Use --with-tk to specify a directory containing tkConfig.sh]) else no_tk= + TEA_TK_EXTENSION=1 TK_BIN_DIR="${ac_cv_c_tkconfig}" AC_MSG_RESULT([found ${TK_BIN_DIR}/tkConfig.sh]) fi fi ]) @@ -536,22 +543,46 @@ eval "TK_LIB_SPEC=\"${TK_LIB_SPEC}\"" eval "TK_STUB_LIB_FLAG=\"${TK_STUB_LIB_FLAG}\"" eval "TK_STUB_LIB_SPEC=\"${TK_STUB_LIB_SPEC}\"" # TEA specific: Ensure windowingsystem is defined - if test "${TEA_PLATFORM}" = "unix" ; then + case ${TK_DEFS} in + *PLATFORM_SDL*) + TEA_WINDOWINGSYSTEM="x11" + PRACTCL_WINDOWINGSYSTEM="sdl" + TEA_USE_SDL=yes + ;; + esac + if test "${TEA_USE_SDL}" = "yes" ; then + true + elif test "${TEA_PLATFORM}" = "unix" ; then case ${TK_DEFS} in *MAC_OSX_TK*) - AC_DEFINE(MAC_OSX_TK, 1, [Are we building against Mac OS X TkAqua?]) + AC_DEFINE(MAC_OSX_TK, 1, [Are we building against Mac OS X Cocoa?]) TEA_WINDOWINGSYSTEM="aqua" + PRACTCL_WINDOWINGSYSTEM="cocoa" + TEA_USE_HITHEME=no; + if test "${TK_VERSION}" = "8.5" ; then + if test "${TK_PATCH_LEVEL}" > ".17" ; then + TEA_USE_HITHEME=yes; + fi + elif test "${TK_VERSION}" = "8.6" ; then + if test "${TK_PATCH_LEVEL}" > ".3" ; then + TEA_USE_HITHEME=yes; + fi + elif test "${TK_VERSION}" > "8.6" ; then + TEA_USE_HITHEME=yes; + fi ;; *) TEA_WINDOWINGSYSTEM="x11" + PRACTCL_WINDOWINGSYSTEM="x11" ;; esac elif test "${TEA_PLATFORM}" = "windows" ; then TEA_WINDOWINGSYSTEM="win32" + PRACTCL_WINDOWINGSYSTEM="windows" fi AC_SUBST(TK_VERSION) AC_SUBST(TK_BIN_DIR) AC_SUBST(TK_SRC_DIR) @@ -565,10 +596,12 @@ AC_SUBST(TK_STUB_LIB_SPEC) # TEA specific: AC_SUBST(TK_LIBS) AC_SUBST(TK_XINCLUDES) + # Practcl + AC_SUBST(PRACTCL_WINDOWINGSYSTEM) ]) #------------------------------------------------------------------------ # TEA_PROG_TCLSH # Determine the fully qualified path name of the tclsh executable @@ -588,15 +621,36 @@ # TCLSH_PROG #------------------------------------------------------------------------ AC_DEFUN([TEA_PROG_TCLSH], [ AC_MSG_CHECKING([for tclsh]) - if test -f "${TCL_BIN_DIR}/Makefile" ; then + + AC_ARG_WITH(tclsh, [ --with-tclsh Specify a local tcl shell to use for dynamic code], with_tclsh=${withval}) + # Use the value from --with-tclsh, if it was given + TCLSH_PROG=0 + if test x"${with_tclsh}" != x ; then + if test -f "${with_tclsh}" ; then + TCLSH_PROG=${with_tclsh} + else + if test -f "${with_tclsh}/tcl8.6" ; then + TCLSH_PROG="${with_tclsh}/tcl8.6" + else + if test -f "${with_tclsh}/tclsh86.exe" ; then + TCLSH_PROG="${with_tclsh}/tclsh86.exe" + else + AC_MSG_ERROR([${with_tclsh} does not point to a valid Tcl executable]) + fi + fi + fi + else + if test -f "${TCL_BIN_DIR}/Makefile" ; then # tclConfig.sh is in Tcl build directory if test "${TEA_PLATFORM}" = "windows"; then if test -f "${TCL_BIN_DIR}/tclsh${TCL_MAJOR_VERSION}${TCL_MINOR_VERSION}${TCL_DBGX}${EXEEXT}" ; then TCLSH_PROG="${TCL_BIN_DIR}/tclsh${TCL_MAJOR_VERSION}${TCL_MINOR_VERSION}${TCL_DBGX}${EXEEXT}" + elif test -f "${TCL_BIN_DIR}/tclsh${TCL_MAJOR_VERSION}${TCL_MINOR_VERSION}${TCL_DBGX}sg${EXEEXT}" ; then + TCLSH_PROG="${TCL_BIN_DIR}/tclsh${TCL_MAJOR_VERSION}${TCL_MINOR_VERSION}${TCL_DBGX}sg${EXEEXT}" elif test -f "${TCL_BIN_DIR}/tclsh${TCL_MAJOR_VERSION}${TCL_MINOR_VERSION}${TCL_DBGX}s${EXEEXT}" ; then TCLSH_PROG="${TCL_BIN_DIR}/tclsh${TCL_MAJOR_VERSION}${TCL_MINOR_VERSION}${TCL_DBGX}s${EXEEXT}" elif test -f "${TCL_BIN_DIR}/tclsh${TCL_MAJOR_VERSION}${TCL_MINOR_VERSION}${TCL_DBGX}t${EXEEXT}" ; then TCLSH_PROG="${TCL_BIN_DIR}/tclsh${TCL_MAJOR_VERSION}${TCL_MINOR_VERSION}${TCL_DBGX}t${EXEEXT}" elif test -f "${TCL_BIN_DIR}/tclsh${TCL_MAJOR_VERSION}${TCL_MINOR_VERSION}${TCL_DBGX}st${EXEEXT}" ; then @@ -603,11 +657,11 @@ TCLSH_PROG="${TCL_BIN_DIR}/tclsh${TCL_MAJOR_VERSION}${TCL_MINOR_VERSION}${TCL_DBGX}st${EXEEXT}" fi else TCLSH_PROG="${TCL_BIN_DIR}/tclsh" fi - else + else # tclConfig.sh is in install location if test "${TEA_PLATFORM}" = "windows"; then TCLSH_PROG="tclsh${TCL_MAJOR_VERSION}${TCL_MINOR_VERSION}${TCL_DBGX}${EXEEXT}" else TCLSH_PROG="tclsh${TCL_MAJOR_VERSION}.${TCL_MINOR_VERSION}${TCL_DBGX}" @@ -620,11 +674,12 @@ REAL_TCL_BIN_DIR="`cd "$i"; pwd`/" break fi done TCLSH_PROG="${REAL_TCL_BIN_DIR}${TCLSH_PROG}" - fi + fi + fi AC_MSG_RESULT([${TCLSH_PROG}]) AC_SUBST(TCLSH_PROG) ]) #------------------------------------------------------------------------ @@ -659,11 +714,11 @@ WISH_PROG="${TK_BIN_DIR}/wish${TK_MAJOR_VERSION}${TK_MINOR_VERSION}${TK_DBGX}t${EXEEXT}" elif test -f "${TK_BIN_DIR}/wish${TK_MAJOR_VERSION}${TK_MINOR_VERSION}${TK_DBGX}st${EXEEXT}" ; then WISH_PROG="${TK_BIN_DIR}/wish${TK_MAJOR_VERSION}${TK_MINOR_VERSION}${TK_DBGX}st${EXEEXT}" fi else - WISH_PROG="${TK_BIN_DIR}/wish" + WISH_PROG="${TK_BIN_DIR}/wish" fi else # tkConfig.sh is in install location if test "${TEA_PLATFORM}" = "windows"; then WISH_PROG="wish${TK_MAJOR_VERSION}${TK_MINOR_VERSION}${TK_DBGX}${EXEEXT}" @@ -796,104 +851,114 @@ # _THREAD_SAFE #------------------------------------------------------------------------ AC_DEFUN([TEA_ENABLE_THREADS], [ AC_ARG_ENABLE(threads, - AC_HELP_STRING([--enable-threads], - [build with threads (default: on)]), - [tcl_ok=$enableval], [tcl_ok=yes]) + AC_HELP_STRING([--enable-threads], + [build with threads (default: on)]), + [tcl_ok=$enableval], [tcl_ok=yes]) if test "${enable_threads+set}" = set; then - enableval="$enable_threads" - tcl_ok=$enableval + enableval="$enable_threads" + tcl_ok=$enableval else - tcl_ok=yes + tcl_ok=yes fi if test "$tcl_ok" = "yes" -o "${TCL_THREADS}" = 1; then - TCL_THREADS=1 - - if test "${TEA_PLATFORM}" != "windows" ; then - # We are always OK on Windows, so check what this platform wants: - - # USE_THREAD_ALLOC tells us to try the special thread-based - # allocator that significantly reduces lock contention - AC_DEFINE(USE_THREAD_ALLOC, 1, - [Do we want to use the threaded memory allocator?]) - AC_DEFINE(_REENTRANT, 1, [Do we want the reentrant OS API?]) - if test "`uname -s`" = "SunOS" ; then - AC_DEFINE(_POSIX_PTHREAD_SEMANTICS, 1, - [Do we really want to follow the standard? Yes we do!]) - fi - AC_DEFINE(_THREAD_SAFE, 1, [Do we want the thread-safe OS API?]) - AC_CHECK_LIB(pthread,pthread_mutex_init,tcl_ok=yes,tcl_ok=no) - if test "$tcl_ok" = "no"; then - # Check a little harder for __pthread_mutex_init in the same - # library, as some systems hide it there until pthread.h is - # defined. We could alternatively do an AC_TRY_COMPILE with - # pthread.h, but that will work with libpthread really doesn't - # exist, like AIX 4.2. [Bug: 4359] - AC_CHECK_LIB(pthread, __pthread_mutex_init, - tcl_ok=yes, tcl_ok=no) - fi - - if test "$tcl_ok" = "yes"; then - # The space is needed - THREADS_LIBS=" -lpthread" - else - AC_CHECK_LIB(pthreads, pthread_mutex_init, - tcl_ok=yes, tcl_ok=no) - if test "$tcl_ok" = "yes"; then - # The space is needed - THREADS_LIBS=" -lpthreads" - else - AC_CHECK_LIB(c, pthread_mutex_init, - tcl_ok=yes, tcl_ok=no) - if test "$tcl_ok" = "no"; then - AC_CHECK_LIB(c_r, pthread_mutex_init, - tcl_ok=yes, tcl_ok=no) - if test "$tcl_ok" = "yes"; then - # The space is needed - THREADS_LIBS=" -pthread" - else - TCL_THREADS=0 - AC_MSG_WARN([Do not know how to find pthread lib on your system - thread support disabled]) - fi - fi - fi - fi - fi - else - TCL_THREADS=0 + TCL_THREADS=1 + + if test "${TEA_PLATFORM}" != "windows" ; then + # We are always OK on Windows, so check what this platform wants: + + # USE_THREAD_ALLOC tells us to try the special thread-based + # allocator that significantly reduces lock contention + AC_DEFINE(USE_THREAD_ALLOC, 1, + [Do we want to use the threaded memory allocator?]) + AC_DEFINE(_REENTRANT, 1, [Do we want the reentrant OS API?]) + if test "`uname -s`" = "SunOS" ; then + AC_DEFINE(_POSIX_PTHREAD_SEMANTICS, 1, + [Do we really want to follow the standard? Yes we do!]) + fi + AC_DEFINE(_THREAD_SAFE, 1, [Do we want the thread-safe OS API?]) + AC_CHECK_LIB(pthread,pthread_mutex_init,tcl_ok=yes,tcl_ok=no) + if test "$tcl_ok" = "no"; then + # Check a little harder for __pthread_mutex_init in the same + # library, as some systems hide it there until pthread.h is + # defined. We could alternatively do an AC_TRY_COMPILE with + # pthread.h, but that will work with libpthread really doesn't + # exist, like AIX 4.2. [Bug: 4359] + AC_CHECK_LIB(pthread, __pthread_mutex_init, + tcl_ok=yes, tcl_ok=no) + fi + + if test "$tcl_ok" = "yes"; then + # The space is needed + THREADS_LIBS=" -lpthread" + else + AC_CHECK_LIB(pthreads, pthread_mutex_init, + tcl_ok=yes, tcl_ok=no) + if test "$tcl_ok" = "yes"; then + # The space is needed + THREADS_LIBS=" -lpthreads" + else + AC_CHECK_LIB(c, pthread_mutex_init, + tcl_ok=yes, tcl_ok=no) + if test "$tcl_ok" = "no"; then + AC_CHECK_LIB(c_r, pthread_mutex_init, + tcl_ok=yes, tcl_ok=no) + if test "$tcl_ok" = "yes"; then + # The space is needed + THREADS_LIBS=" -pthread" + else + TCL_THREADS=0 + AC_MSG_WARN([Do not know how to find pthread lib on your system - thread support disabled]) + fi + fi + fi + fi + fi + else + TCL_THREADS=0 fi # Do checking message here to not mess up interleaved configure output AC_MSG_CHECKING([for building with threads]) if test "${TCL_THREADS}" = 1; then - AC_DEFINE(TCL_THREADS, 1, [Are we building with threads enabled?]) - AC_MSG_RESULT([yes (default)]) + AC_DEFINE(TCL_THREADS, 1, [Are we building with threads enabled?]) + AC_MSG_RESULT([yes (default)]) else - AC_MSG_RESULT([no]) + AC_MSG_RESULT([no]) fi # TCL_THREADS sanity checking. See if our request for building with # threads is the same as the way Tcl was built. If not, warn the user. - case ${TCL_DEFS} in - *THREADS=1*) - if test "${TCL_THREADS}" = "0"; then - AC_MSG_WARN([ + + if test "${TCL_VERSION}" > "8.6" ; then + TCL_HAS_THREADS=1 + else + case ${TCL_DEFS} in + *THREADS=1*) + TCL_HAS_THREADS=1; + ;; + *) + TCL_HAS_THREADS=0; + ;; + esac + fi + if test "${TCL_HAS_THREADS}" = "1"; then + if test "${TCL_THREADS}" = "0"; then + AC_MSG_WARN([ Building ${PACKAGE_NAME} without threads enabled, but building against Tcl that IS thread-enabled. It is recommended to use --enable-threads.]) - fi - ;; - *) - if test "${TCL_THREADS}" = "1"; then - AC_MSG_WARN([ + fi + else + if test "${TCL_THREADS}" = "1"; then + AC_MSG_WARN([ --enable-threads requested, but building against a Tcl that is NOT thread-enabled. This is an OK configuration that will also run in a thread-enabled core.]) - fi - ;; - esac + fi + fi AC_SUBST(TCL_THREADS) ]) #------------------------------------------------------------------------ # TEA_ENABLE_SYMBOLS -- @@ -1365,10 +1430,12 @@ AC_CHECK_TOOL(RC, windres) CFLAGS_DEBUG="-g" CFLAGS_OPTIMIZE="-O2 -fomit-frame-pointer" SHLIB_LD='${CC} -shared' UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a' + PRACTCL_UNSHARED_LIB_SUFFIX='.a' + LDFLAGS_CONSOLE="-wl,--subsystem,console ${lflags}" LDFLAGS_WINDOW="-wl,--subsystem,windows ${lflags}" AC_CACHE_CHECK(for cross-compile version of gcc, ac_cv_cross, @@ -2080,14 +2147,16 @@ [No Compiler support for module scope symbols]) ]) AS_IF([test "$SHARED_LIB_SUFFIX" = ""], [ # TEA specific: use PACKAGE_VERSION instead of VERSION - SHARED_LIB_SUFFIX='${PACKAGE_VERSION}${SHLIB_SUFFIX}']) + SHARED_LIB_SUFFIX='${PACKAGE_VERSION}${SHLIB_SUFFIX}' + ]) AS_IF([test "$UNSHARED_LIB_SUFFIX" = ""], [ # TEA specific: use PACKAGE_VERSION instead of VERSION - UNSHARED_LIB_SUFFIX='${PACKAGE_VERSION}.a']) + UNSHARED_LIB_SUFFIX='${PACKAGE_VERSION}.a' + ]) if test "${GCC}" = "yes" -a ${SHLIB_SUFFIX} = ".dll"; then AC_CACHE_CHECK(for SEH support in compiler, tcl_cv_seh, AC_TRY_RUN([ @@ -2186,10 +2255,11 @@ AC_SUBST(CFLAGS_OPTIMIZE) AC_SUBST(CFLAGS_WARNING) AC_SUBST(STLIB_LD) AC_SUBST(SHLIB_LD) + AC_SUBST(SHLIB_SUFFIX) AC_SUBST(SHLIB_LD_LIBS) AC_SUBST(SHLIB_CFLAGS) AC_SUBST(LD_LIBRARY_PATH_VAR) @@ -2340,11 +2410,11 @@ # XLIBSW # PKG_LIBS (appends to) #-------------------------------------------------------------------- AC_DEFUN([TEA_PATH_X], [ - if test "${TEA_WINDOWINGSYSTEM}" = "x11" ; then + if test "${PRACTCL_WINDOWINGSYSTEM}" = "x11" ; then TEA_PATH_UNIX_X fi ]) AC_DEFUN([TEA_PATH_UNIX_X], [ @@ -2730,12 +2800,11 @@ # is a lightweight replacement for AC_EXEEXT that doesn't require # a compiler. #------------------------------------------------------------------------ AC_DEFUN([TEA_INIT], [ - TEA_VERSION="3.13" - + TEA_VERSION="4.0" AC_MSG_CHECKING([TEA configuration]) if test x"${PACKAGE_NAME}" = x ; then AC_MSG_ERROR([ The PACKAGE_NAME variable must be defined by your TEA configure.ac]) fi @@ -2744,11 +2813,12 @@ # If the user did not set CFLAGS, set it now to keep macros # like AC_PROG_CC and AC_TRY_COMPILE from adding "-g -O2". if test "${CFLAGS+set}" != "set" ; then CFLAGS="" fi - + TEA_TK_EXTENSION=0 + AC_SUBST(TEA_TK_EXTENSION) case "`uname -s`" in *win32*|*WIN32*|*MINGW32_*|*MINGW64_*) AC_CHECK_PROG(CYGPATH, cygpath, cygpath -m, echo) EXEEXT=".exe" TEA_PLATFORM="windows" @@ -2993,12 +3063,16 @@ #------------------------------------------------------------------------ AC_DEFUN([TEA_ADD_LIBS], [ vars="$@" for i in $vars; do if test "${TEA_PLATFORM}" = "windows" -a "$GCC" = "yes" ; then - # Convert foo.lib to -lfoo for GCC. No-op if not *.lib - i=`echo "$i" | sed -e 's/^\([[^-]].*\)\.lib[$]/-l\1/i'` + case $i in + *.lib) + # Convert foo.lib to -lfoo for GCC + i=-l`echo "$i" | sed -e 's/\.[[^.]]*$//' -e 's/\.lib.*//'` + ;; + esac fi PKG_LIBS="$PKG_LIBS $i" done AC_SUBST(PKG_LIBS) ]) @@ -3176,95 +3250,135 @@ # MAKE_SHARED_LIB Makefile rule for building a shared library # MAKE_STATIC_LIB Makefile rule for building a static library # MAKE_STUB_LIB Makefile rule for building a stub library # VC_MANIFEST_EMBED_DLL Makefile rule for embedded VC manifest in DLL # VC_MANIFEST_EMBED_EXE Makefile rule for embedded VC manifest in EXE +# +# PRACTCL_TOOLSET What toolset is in use (gcc or msvc) +# PRACTCL_SHARED_LIB Template rule for building a shared library +# PRACTCL_STATIC_LIB Template rule for building a static library +# PRACTCL_STUB_LIB Template rule for building a stub library +# PRACTCL_VC_MANIFEST_EMBED_DLL Template rule for embedded VC manifest in DLL +# PRACTCL_VC_MANIFEST_EMBED_EXE Template rule for embedded VC manifest in EXE +# PRACTCL_NAME_LIBRARY Template rule for naming libraries +# #------------------------------------------------------------------------ AC_DEFUN([TEA_MAKE_LIB], [ - if test "${TEA_PLATFORM}" = "windows" -a "$GCC" != "yes"; then - MAKE_STATIC_LIB="\${STLIB_LD} -out:\[$]@ \$(PKG_OBJECTS)" - MAKE_SHARED_LIB="\${SHLIB_LD} \${SHLIB_LD_LIBS} \${LDFLAGS_DEFAULT} -out:\[$]@ \$(PKG_OBJECTS)" - AC_EGREP_CPP([manifest needed], [ + PRACTCL_TOOLSET="gcc" + PRACTCL_VC_MANIFEST_EMBED_DLL=: + PRACTCL_VC_MANIFEST_EMBED_EXE=: + if test "${TEA_PLATFORM}" = "windows" -a "$GCC" != "yes"; then + PRACTCL_TOOLSET="msvc" + PRACTCL_STATIC_LIB="%STLIB_LD% -out:%OUTFILE% %LIBRARY_OBJECTS%" + PRACTCL_SHARED_LIB="%SHLIB_LD% %SHLIB_LD_LIBS% %LDFLAGS_DEFAULT% -out:%OUTFILE% %LIBRARY_OBJECTS%" + MAKE_STATIC_LIB="\${STLIB_LD} -out:\[$]@ \$(PKG_OBJECTS)" + MAKE_SHARED_LIB="\${SHLIB_LD} \${SHLIB_LD_LIBS} \${LDFLAGS_DEFAULT} -out:\[$]@ \$(PKG_OBJECTS)" + AC_EGREP_CPP([manifest needed], [ #if defined(_MSC_VER) && _MSC_VER >= 1400 print("manifest needed") #endif - ], [ - # Could do a CHECK_PROG for mt, but should always be with MSVC8+ - VC_MANIFEST_EMBED_DLL="if test -f \[$]@.manifest ; then mt.exe -nologo -manifest \[$]@.manifest -outputresource:\[$]@\;2 ; fi" - VC_MANIFEST_EMBED_EXE="if test -f \[$]@.manifest ; then mt.exe -nologo -manifest \[$]@.manifest -outputresource:\[$]@\;1 ; fi" - MAKE_SHARED_LIB="${MAKE_SHARED_LIB} ; ${VC_MANIFEST_EMBED_DLL}" - TEA_ADD_CLEANFILES([*.manifest]) - ]) - MAKE_STUB_LIB="\${STLIB_LD} -nodefaultlib -out:\[$]@ \$(PKG_STUB_OBJECTS)" - else - MAKE_STATIC_LIB="\${STLIB_LD} \[$]@ \$(PKG_OBJECTS)" - MAKE_SHARED_LIB="\${SHLIB_LD} -o \[$]@ \$(PKG_OBJECTS) \${SHLIB_LD_LIBS}" - MAKE_STUB_LIB="\${STLIB_LD} \[$]@ \$(PKG_STUB_OBJECTS)" - fi - - if test "${SHARED_BUILD}" = "1" ; then - MAKE_LIB="${MAKE_SHARED_LIB} " - else - MAKE_LIB="${MAKE_STATIC_LIB} " - fi - - #-------------------------------------------------------------------- - # Shared libraries and static libraries have different names. - # Use the double eval to make sure any variables in the suffix is - # substituted. (@@@ Might not be necessary anymore) - #-------------------------------------------------------------------- - - if test "${TEA_PLATFORM}" = "windows" ; then - if test "${SHARED_BUILD}" = "1" ; then + ], [ + # Could do a CHECK_PROG for mt, but should always be with MSVC8+ + PRACTCL_VC_MANIFEST_EMBED_DLL="mt.exe -nologo -manifest %OUTFILE%.manifest -outputresource:%OUTFILE%\;2" + PRACTCL_VC_MANIFEST_EMBED_EXE="mt.exe -nologo -manifest %OUTFILE%.manifest -outputresource:%OUTFILE%\;1" + VC_MANIFEST_EMBED_DLL="if test -f \[$]@.manifest ; then mt.exe -nologo -manifest \[$]@.manifest -outputresource:\[$]@\;2 ; fi" + VC_MANIFEST_EMBED_EXE="if test -f \[$]@.manifest ; then mt.exe -nologo -manifest \[$]@.manifest -outputresource:\[$]@\;1 ; fi" + MAKE_SHARED_LIB="${MAKE_SHARED_LIB} ; ${VC_MANIFEST_EMBED_DLL}" + TEA_ADD_CLEANFILES([*.manifest]) + ]) + PRACTCL_STUB_LIB="%STLIB_LD% -nodefaultlib -out:%OUTFILE% %LIBRARY_OBJECTS%" + MAKE_STUB_LIB="\${STLIB_LD} -nodefaultlib -out:\[$]@ \$(PKG_STUB_OBJECTS)" + else + MAKE_STATIC_LIB="\${STLIB_LD} \[$]@ \$(PKG_OBJECTS)" + MAKE_SHARED_LIB="\${SHLIB_LD} -o \[$]@ \$(PKG_OBJECTS) \${SHLIB_LD_LIBS}" + MAKE_STUB_LIB="\${STLIB_LD} \[$]@ \$(PKG_STUB_OBJECTS)" + + PRACTCL_STATIC_LIB="%STLIB_LD% %OUTFILE% %LIBRARY_OBJECTS%" + PRACTCL_SHARED_LIB="%SHLIB_LD% -o %OUTFILE% %LIBRARY_OBJECTS% %SHLIB_LD_LIBS%" + PRACTCL_STUB_LIB="%STLIB_LD% %OUTFILE% %LIBRARY_OBJECTS%" + fi + + if test "${SHARED_BUILD}" = "1" ; then + MAKE_LIB="${MAKE_SHARED_LIB} " + else + MAKE_LIB="${MAKE_STATIC_LIB} " + fi + + #-------------------------------------------------------------------- + # Shared libraries and static libraries have different names. + # Use the double eval to make sure any variables in the suffix is + # substituted. (@@@ Might not be necessary anymore) + #-------------------------------------------------------------------- + if test "${TEA_PLATFORM}" = "windows" ; then + PRACTCL_NAME_LIBRARY="%LIBRARY_PREFIX%%LIBRARY_NAME%%LIBRARY_VERSION_NODOTS%" + if test "${SHARED_BUILD}" = "1" ; then # We force the unresolved linking of symbols that are really in # the private libraries of Tcl and Tk. if test x"${TK_BIN_DIR}" != x ; then - SHLIB_LD_LIBS="${SHLIB_LD_LIBS} \"`${CYGPATH} ${TK_BIN_DIR}/${TK_STUB_LIB_FILE}`\"" + SHLIB_LD_LIBS="${SHLIB_LD_LIBS} \"`${CYGPATH} ${TK_BIN_DIR}/${TK_STUB_LIB_FILE}`\"" fi SHLIB_LD_LIBS="${SHLIB_LD_LIBS} \"`${CYGPATH} ${TCL_BIN_DIR}/${TCL_STUB_LIB_FILE}`\"" if test "$GCC" = "yes"; then - SHLIB_LD_LIBS="${SHLIB_LD_LIBS} -static-libgcc" + SHLIB_LD_LIBS="${SHLIB_LD_LIBS} -static-libgcc" fi eval eval "PKG_LIB_FILE=${PACKAGE_LIB_PREFIX}${PACKAGE_NAME}${SHARED_LIB_SUFFIX}" - else + else eval eval "PKG_LIB_FILE=${PACKAGE_LIB_PREFIX}${PACKAGE_NAME}${UNSHARED_LIB_SUFFIX}" if test "$GCC" = "yes"; then - PKG_LIB_FILE=lib${PKG_LIB_FILE} - fi - fi - # Some packages build their own stubs libraries - eval eval "PKG_STUB_LIB_FILE=${PACKAGE_LIB_PREFIX}${PACKAGE_NAME}stub${UNSHARED_LIB_SUFFIX}" - if test "$GCC" = "yes"; then - PKG_STUB_LIB_FILE=lib${PKG_STUB_LIB_FILE} - fi - # These aren't needed on Windows (either MSVC or gcc) - RANLIB=: - RANLIB_STUB=: - else - RANLIB_STUB="${RANLIB}" - if test "${SHARED_BUILD}" = "1" ; then - SHLIB_LD_LIBS="${SHLIB_LD_LIBS} ${TCL_STUB_LIB_SPEC}" - if test x"${TK_BIN_DIR}" != x ; then - SHLIB_LD_LIBS="${SHLIB_LD_LIBS} ${TK_STUB_LIB_SPEC}" - fi - eval eval "PKG_LIB_FILE=lib${PACKAGE_LIB_PREFIX}${PACKAGE_NAME}${SHARED_LIB_SUFFIX}" - RANLIB=: - else - eval eval "PKG_LIB_FILE=lib${PACKAGE_LIB_PREFIX}${PACKAGE_NAME}${UNSHARED_LIB_SUFFIX}" - fi - # Some packages build their own stubs libraries - eval eval "PKG_STUB_LIB_FILE=lib${PACKAGE_LIB_PREFIX}${PACKAGE_NAME}stub${UNSHARED_LIB_SUFFIX}" - fi - - AC_SUBST(MAKE_LIB) - AC_SUBST(MAKE_SHARED_LIB) - AC_SUBST(MAKE_STATIC_LIB) - AC_SUBST(MAKE_STUB_LIB) - AC_SUBST(RANLIB_STUB) - AC_SUBST(VC_MANIFEST_EMBED_DLL) - AC_SUBST(VC_MANIFEST_EMBED_EXE) + PKG_LIB_FILE=lib${PKG_LIB_FILE} + fi + fi + # Some packages build their own stubs libraries + eval eval "PKG_STUB_LIB_FILE=${PACKAGE_LIB_PREFIX}${PACKAGE_NAME}stub${UNSHARED_LIB_SUFFIX}" + if test "$GCC" = "yes"; then + PKG_STUB_LIB_FILE=lib${PKG_STUB_LIB_FILE} + fi + # These aren't needed on Windows (either MSVC or gcc) + RANLIB=: + RANLIB_STUB=: + else + PRACTCL_NAME_LIBRARY="lib%LIBRARY_PREFIX%%LIBRARY_NAME%%LIBRARY_VERSION%" + RANLIB_STUB="${RANLIB}" + if test "${SHARED_BUILD}" = "1" ; then + SHLIB_LD_LIBS="${SHLIB_LD_LIBS} ${TCL_STUB_LIB_SPEC}" + if test x"${TK_BIN_DIR}" != x ; then + SHLIB_LD_LIBS="${SHLIB_LD_LIBS} ${TK_STUB_LIB_SPEC}" + fi + eval eval "PKG_LIB_FILE=lib${PACKAGE_LIB_PREFIX}${PACKAGE_NAME}${SHARED_LIB_SUFFIX}" + RANLIB=: + else + eval eval "PKG_LIB_FILE=lib${PACKAGE_LIB_PREFIX}${PACKAGE_NAME}${UNSHARED_LIB_SUFFIX}" + fi + # Some packages build their own stubs libraries + eval eval "PKG_STUB_LIB_FILE=lib${PACKAGE_LIB_PREFIX}${PACKAGE_NAME}stub${UNSHARED_LIB_SUFFIX}" + fi + + # Store the raw CFLAGS before we add the trimmings + PRACTCL_CFLAGS=${CFLAGS} + # These are escaped so that only CFLAGS is picked up at configure time. + # The other values will be substituted at make time. + CFLAGS="${CFLAGS} \${CFLAGS_DEFAULT} \${CFLAGS_WARNING}" + if test "${SHARED_BUILD}" = "1" ; then + CFLAGS="${CFLAGS} \${SHLIB_CFLAGS}" + fi + + AC_SUBST(MAKE_LIB) + AC_SUBST(MAKE_SHARED_LIB) + AC_SUBST(MAKE_STATIC_LIB) + AC_SUBST(MAKE_STUB_LIB) + AC_SUBST(RANLIB_STUB) + AC_SUBST(VC_MANIFEST_EMBED_DLL) + AC_SUBST(VC_MANIFEST_EMBED_EXE) + AC_SUBST(PRACTCL_CFLAGS) + AC_SUBST(PRACTCL_TOOLSET) + AC_SUBST(PRACTCL_SHARED_LIB) + AC_SUBST(PRACTCL_STATIC_LIB) + AC_SUBST(PRACTCL_STUB_LIB) + AC_SUBST(PRACTCL_VC_MANIFEST_EMBED_DLL) + AC_SUBST(PRACTCL_VC_MANIFEST_EMBED_EXE) + AC_SUBST(PRACTCL_NAME_LIBRARY) ]) #------------------------------------------------------------------------ # TEA_LIB_SPEC -- # @@ -3555,16 +3669,28 @@ TK_INCLUDES="-I${TK_GENERIC_DIR_NATIVE} -I${TK_PLATFORM_DIR_NATIVE}" # Detect and add ttk subdir if test -d "${TK_SRC_DIR}/generic/ttk"; then TK_INCLUDES="${TK_INCLUDES} -I\"${TK_SRC_DIR_NATIVE}/generic/ttk\"" fi - if test "${TEA_WINDOWINGSYSTEM}" != "x11"; then + case ${PRACTCL_WINDOWINGSYSTEM} in + cocoa) TK_INCLUDES="${TK_INCLUDES} -I\"${TK_XLIB_DIR_NATIVE}\"" - fi - if test "${TEA_WINDOWINGSYSTEM}" = "aqua"; then + TK_INCLUDES="${TK_INCLUDES} -I\"${TK_SRC_DIR_NATIVE}/macosx\"" + ;; + hitheme) + TK_INCLUDES="${TK_INCLUDES} -I\"${TK_XLIB_DIR_NATIVE}\"" TK_INCLUDES="${TK_INCLUDES} -I\"${TK_SRC_DIR_NATIVE}/macosx\"" - fi + ;; + sdl) + TK_INCLUDES="${TK_INCLUDES} -I\"${TK_XLIB_DIR_NATIVE}\"" + ;; + x11) + ;; + *) + TK_INCLUDES="${TK_INCLUDES} -I\"${TK_XLIB_DIR_NATIVE}\"" + ;; + esac if test "`uname -s`" = "Darwin"; then # If Tk was built as a framework, attempt to use # the framework's Headers and PrivateHeaders directories case ${TK_DEFS} in *TK_FRAMEWORK*) @@ -3685,11 +3811,11 @@ TK_INCLUDES=-I\"${INCLUDE_DIR_NATIVE}\" AC_SUBST(TK_INCLUDES) - if test "${TEA_WINDOWINGSYSTEM}" != "x11"; then + if test "${PRACTCL_WINDOWINGSYSTEM}" != "x11"; then # On Windows and Aqua, we need the X compat headers AC_MSG_CHECKING([for X11 header files]) if test ! -r "${INCLUDE_DIR_NATIVE}/X11/Xlib.h"; then INCLUDE_DIR_NATIVE="`${CYGPATH} ${TK_SRC_DIR}/xlib`" TK_XINCLUDES=-I\"${INCLUDE_DIR_NATIVE}\" @@ -4023,10 +4149,117 @@ CELIB_DIR=`echo "$CELIB_DIR" | sed -e 's!\\\!/!g'` AC_MSG_RESULT([found $CELIB_DIR]) fi fi ]) + +#-------------------------------------------------------------------- +# TEA_CONFIG_TEAPOT +# +# Try to determine the canonical name for this package's binary +# target +# +# Arguments: +# none +AC_DEFUN([TEA_CONFIG_TEAPOT], [ + AC_REQUIRE([TEA_INIT]) + AC_REQUIRE([TEA_CONFIG_SYSTEM]) + TEACUP_OS=$system + TEACUP_ARCH="unknown" + TEACUP_TOOLSET="gcc" + TEACUP_PROFILE="unknown" + arch="unknown" + case ${host_alias} in + *mingw32*) + arch="ix86" + TEACUP_PROFILE="win32-ix86" + ;; + *mingw64*) + arch="x86_64" + TEACUP_PROFILE="win32-x86_64" + ;; + esac + if test "${arch}" = "unknown" ; then + if test "${TEA_PLATFORM}" = "windows" ; then + if test "$GCC" = "yes" ; then + TEACUP_TOOLSET="gcc" + else + TEACUP_TOOLSET="msvc" + fi + if test "$do64bit" != "no" ; then + case "$do64bit" in + amd64|x64|yes) + arch="x86_64" + TEACUP_PROFILE="win32-x86_64" + ;; + ia64) + arch="ia64" + TEACUP_PROFILE="win32-ia64" + ;; + esac + else + arch="ix86" + TEACUP_PROFILE="win32-ix86" + fi + else + case $system in + Linux*) + TEACUP_OS="linux" + arch=`uname -m` + TEACUP_PROFILE="linux-glibc2.3-$arch" + ;; + GNU*) + TEACUP_OS="gnu" + arch=`uname -m` + ;; + NetBSD-Debian) + TEACUP_OS="netbsd-debian" + arch=`uname -m` + ;; + OpenBSD-*) + TEACUP_OS="openbsd" + arch=`arch -s` + ;; + Darwin*) + TEACUP_OS="macosx" + TEACUP_PROFILE="macosx-universal" + arch=`uname -m` + if test $arch = "x86_64"; then + TEACUP_PROFILE="macosx10.5-i386-x86_84" + fi + ;; + OpenBSD*) + TEACUP_OS="openbsd" + arch=`arch -s` + ;; + esac + fi + fi + TEACUP_ARCH=$arch + if test "$TEACUP_PROFILE" = "unknown"; then + if test $arch = "unknown"; then + arch=`uname -m` + fi + case $arch in + i*86) + arch="ix86" + ;; + amd64) + arch="x86_64" + ;; + esac + TEACUP_PROFILE="$TEACUP_OS-$arch" + fi + TEA_SYSTEM=$system + AC_SUBST(TEA_SYSTEM) + AC_SUBST(TEA_PLATFORM) + AC_SUBST(TEA_WINDOWINGSYSTEM) + AC_SUBST(TEACUP_OS) + AC_SUBST(TEACUP_ARCH) + AC_SUBST(TEACUP_TOOLSET) + AC_SUBST(TEACUP_PROFILE) +]) #------------------------------------------------------------------------ # TEA_INSTALLER -- # # Configure the installer. @@ -4067,11 +4300,11 @@ ### # Tip 430 - ZipFS Modifications ### #------------------------------------------------------------------------ -# SC_ZIPFS_SUPPORT +# TEA_ZIPFS_SUPPORT # Locate a zip encoder installed on the system path, or none. # # Arguments: # none # @@ -4079,25 +4312,10 @@ # Substitutes the following vars: # TCL_ZIP_FILE # TCL_ZIPFS_SUPPORT # TCL_ZIPFS_FLAG # ZIP_PROG -#------------------------------------------------------------------------ - -#------------------------------------------------------------------------ -# SC_PROG_ZIP -# Locate a zip encoder installed on the system path, or none. -# -# Arguments: -# none -# -# Results: -# Substitutes the following vars: -# ZIP_PROG -# ZIP_PROG_OPTIONS -# ZIP_PROG_VFSSEARCH -# ZIP_INSTALL_OBJS #------------------------------------------------------------------------ AC_DEFUN([TEA_ZIPFS_SUPPORT], [ AC_MSG_CHECKING([for zipfs support]) ZIP_PROG="" ZIP_PROG_OPTIONS=""