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 <yoda@etoyoc.com>
+ * Copyright (c) 2013-2015 Christian Werner <chw@ch-werner.de>
+ *
+ * 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 <sys/mman.h>
+#else
+#include <winbase.h>
+#endif
+#include <errno.h>
+#include <string.h>
+#include <sys/stat.h>
+#include <time.h>
+#include <stdlib.h>
+#include <fcntl.h>
+
+#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 <list>]} {
+ dict set eswitch <list> {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 <class>]} {
+ dict set clay .delegate <class> [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] <object> [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 <project> 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 <project> 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 <project> define get prefix_broken_destdir]
+ } else {
+ set PREFIX [my <project> define get prefix]
+ }
+ switch [my define get name] {
+ tcl {
+ set opts [::practcl::platform::tcl_core_options [my <project> define get TEACUP_OS]]
+ }
+ tk {
+ set opts [::practcl::platform::tk_core_options [my <project> define get TEACUP_OS]]
+ }
+ }
+ if {[my <project> define get CONFIG_SITE] != {}} {
+ lappend opts --host=[my <project> define get HOST]
+ }
+ set inside_msys [string is true -strict [my <project> define get MSYS_ENV 0]]
+ lappend opts --with-tclsh=[info nameofexecutable]
+
+ if {[my define get tk 0]} {
+ if {![my <project> define get LOCAL 0]} {
+ set obj [my <project> 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 <project> 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 <project> define get LOCAL 0]} {
+ set obj [my <project> 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 <project> 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 <project> define get CONFIG_SITE] ne {}} {
+ set ::env(CONFIG_SITE) [my <project> 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 <project> 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 <project> define get prefix]
+ set BROKENROOT [::practcl::msys_to_tclpath [my <project> 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 <project> 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 <project> 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 <project> 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 <project> 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 <project> define get tclsrcdir] ..]]]
+ set TCLGENERIC [::practcl::file_relative [file normalize $builddir] [file normalize [file join $::CWD [my <project> define get tclsrcdir] .. generic]]]
+ lappend opts TCLDIR=[file normalize $TCLSRCDIR]
+ #--with-tclinclude=$TCLGENERIC
+ }
+ if {[my <project> define exists tksrcdir]} {
+ set TKSRCDIR [::practcl::file_relative [file normalize $builddir] [file normalize [file join $::CWD [my <project> define get tksrcdir] ..]]]
+ set TKGENERIC [::practcl::file_relative [file normalize $builddir] [file normalize [file join $::CWD [my <project> 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 <module> 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 <module> 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 <module> 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 <module> 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 <module> define get localpath]
+ if {$lpath eq {}} {
+ set lpath [my <module> 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 <module> 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 <tcl.h> <tclOO.h>
+ if {[my define get tk 0]} {
+ my IncludeAdd headers <tk.h>
+ }
+ 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 <project> 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 {<tcl.h>}
+ $PROJECT include {"tclInt.h"}
+ $PROJECT include {"tclFileSystem.h"}
+ $PROJECT include {<assert.h>}
+ $PROJECT include {<stdio.h>}
+ $PROJECT include {<stdlib.h>}
+ $PROJECT include {<string.h>}
+ $PROJECT include {<math.h>}
+
+ $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 <project> 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 <project> 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 <project> define get download]
+ my unpack
+ set prefix [string trimleft [my <project> 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 <project> define get download]
+ my unpack
+ set prefix [string trimleft [my <project> 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 <project> 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 <project> 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 <project> 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 <project> 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 <project> 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 <project> 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 <project> define get prefix]
+ ###
+ # Handle teapot installs
+ ###
+ set pkg [my define get pkg_name [my define get name]]
+ if {[my <project> define get teapot] ne {}} {
+ set TEAPOT [my <project> 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 <project> 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 <project> 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 <project> 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=""