TEA (tclconfig) Source Code

Changes On Branch practcl
Login
Bounty program for improvements to Tcl and certain Tcl packages.

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Changes In Branch practcl Excluding Merge-Ins

This is equivalent to a diff from a413acb98d to 832915fb01

2019-09-09
13:17
Closing fork Leaf check-in: 832915fb01 user: hypnotoad tags: practcl
13:11
Update Practcl.tcl to the latest    Workaround in tclZipFs for an internal API change in the Tcl Core post 8.6.9 check-in: 79972997da user: hypnotoad tags: practcl
2019-07-25
21:48
Updated Practcl from clay check-in: 9904f168a6 user: hypnotoad tags: practcl
2018-10-16
21:12
Backout [a413acb98d], since with this change at least tclsqlite doesn't build any more check-in: 094d08a80a user: jan.nijtmans tags: trunk
2018-09-24
14:16
Pulling changes from TEA check-in: 72a7e44a99 user: hypnotoad tags: practcl
2018-08-13
08:22
remove strings that break CFLAGS at configure time check-in: a413acb98d user: pooryorick tags: trunk
2018-06-20
07:17
Undo TEA_PATH_CONFIG changes regarding addtional paths until it's more clear where OpenBSD/FreeBSD stores it's 'official' itclConfig.sh/tdbcConfig.sh. Fix [923f400aa03a5608]: New paths required for Darwin    Stu adds: This has nothing to do with where any one os stores itcl/itkConfig.sh.    It shouldn't matter to *tclconfig* where any anything stores anything, should it?    This is supposed to be a generic routine, used to pick up the *Config.sh of any extension.    There is no "common store" for *Config.sh files on any platform, afaict. Extensions currently keep their *Config.sh files in their own dirs. I believe this to be the case currently for all extensions and platforms. Perhaps changing this convention is a good idea.    The way things are currently, adding dirs for itcl would then mean adding dirs fors tdbc, tdom, etc.? I don't see that as being viable in the long-term. check-in: df3b672e10 user: jan.nijtmans tags: trunk

Added compat/tclZipfs.c.

            1  +/*
            2  + * tclZipfs.c --
            3  + *
            4  + *    Implementation of the ZIP filesystem used in TIP 430
            5  + *    Adapted from the implentation for AndroWish.
            6  + *
            7  + * Coptright (c) 2016-2017 Sean Woods <[email protected]>
            8  + * Copyright (c) 2013-2015 Christian Werner <[email protected]>
            9  + *
           10  + * See the file "license.terms" for information on usage and redistribution of
           11  + * this file, and for a DISCLAIMER OF ALL WARRANTIES.
           12  + *
           13  + * This file is distributed in two ways:
           14  + *   generic/tclZipfs.c file in the TIP430 enabled tcl cores
           15  + *   compat/tclZipfs.c file in the tclconfig (TEA) file system, for pre-tip430 projects
           16  + */
           17  +
           18  +#include "tclInt.h"
           19  +#include "tclFileSystem.h"
           20  +
           21  +#if !defined(_WIN32) && !defined(_WIN64)
           22  +#include <sys/mman.h>
           23  +#else
           24  +#include <winbase.h>
           25  +#endif
           26  +#include <errno.h>
           27  +#include <string.h>
           28  +#include <sys/stat.h>
           29  +#include <time.h>
           30  +#include <stdlib.h>
           31  +#include <fcntl.h>
           32  +
           33  +#ifndef MAP_FILE
           34  +#define MAP_FILE 0
           35  +#endif
           36  +
           37  +#ifdef HAVE_ZLIB
           38  +#include "zlib.h"
           39  +#include "crypt.h"
           40  +
           41  +#ifdef CFG_RUNTIME_DLLFILE
           42  +/*
           43  +** We are compiling as part of the core.
           44  +** TIP430 style zipfs prefix
           45  +*/
           46  +#define ZIPFS_VOLUME      "//zipfs:/"
           47  +#define ZIPFS_VOLUME_LEN  9
           48  +#define ZIPFS_APP_MOUNT   "//zipfs:/app"
           49  +#define ZIPFS_ZIP_MOUNT   "//zipfs:/lib/tcl"
           50  +#else
           51  +/*
           52  +** We are compiling from the /compat folder of tclconfig
           53  +** Pre TIP430 style zipfs prefix
           54  +** //zipfs:/ doesn't work straight out of the box on either windows or Unix
           55  +** without other changes made to tip 430
           56  +*/
           57  +#define ZIPFS_VOLUME      "zipfs:/"
           58  +#define ZIPFS_VOLUME_LEN  7
           59  +#define ZIPFS_APP_MOUNT   "zipfs:/app"
           60  +#define ZIPFS_ZIP_MOUNT   "zipfs:/lib/tcl"
           61  +#endif
           62  +/*
           63  + * Various constants and offsets found in ZIP archive files
           64  + */
           65  +
           66  +#define ZIP_SIG_LEN                     4
           67  +
           68  +/* Local header of ZIP archive member (at very beginning of each member). */
           69  +#define ZIP_LOCAL_HEADER_SIG            0x04034b50
           70  +#define ZIP_LOCAL_HEADER_LEN            30
           71  +#define ZIP_LOCAL_SIG_OFFS              0
           72  +#define ZIP_LOCAL_VERSION_OFFS          4
           73  +#define ZIP_LOCAL_FLAGS_OFFS            6
           74  +#define ZIP_LOCAL_COMPMETH_OFFS         8
           75  +#define ZIP_LOCAL_MTIME_OFFS            10
           76  +#define ZIP_LOCAL_MDATE_OFFS            12
           77  +#define ZIP_LOCAL_CRC32_OFFS            14
           78  +#define ZIP_LOCAL_COMPLEN_OFFS          18
           79  +#define ZIP_LOCAL_UNCOMPLEN_OFFS        22
           80  +#define ZIP_LOCAL_PATHLEN_OFFS          26
           81  +#define ZIP_LOCAL_EXTRALEN_OFFS         28
           82  +
           83  +/* Central header of ZIP archive member at end of ZIP file. */
           84  +#define ZIP_CENTRAL_HEADER_SIG          0x02014b50
           85  +#define ZIP_CENTRAL_HEADER_LEN          46
           86  +#define ZIP_CENTRAL_SIG_OFFS            0
           87  +#define ZIP_CENTRAL_VERSIONMADE_OFFS    4
           88  +#define ZIP_CENTRAL_VERSION_OFFS        6
           89  +#define ZIP_CENTRAL_FLAGS_OFFS          8
           90  +#define ZIP_CENTRAL_COMPMETH_OFFS       10
           91  +#define ZIP_CENTRAL_MTIME_OFFS          12
           92  +#define ZIP_CENTRAL_MDATE_OFFS          14
           93  +#define ZIP_CENTRAL_CRC32_OFFS          16
           94  +#define ZIP_CENTRAL_COMPLEN_OFFS        20
           95  +#define ZIP_CENTRAL_UNCOMPLEN_OFFS      24
           96  +#define ZIP_CENTRAL_PATHLEN_OFFS        28
           97  +#define ZIP_CENTRAL_EXTRALEN_OFFS       30
           98  +#define ZIP_CENTRAL_FCOMMENTLEN_OFFS    32
           99  +#define ZIP_CENTRAL_DISKFILE_OFFS       34
          100  +#define ZIP_CENTRAL_IATTR_OFFS          36
          101  +#define ZIP_CENTRAL_EATTR_OFFS          38
          102  +#define ZIP_CENTRAL_LOCALHDR_OFFS       42
          103  +
          104  +/* Central end signature at very end of ZIP file. */
          105  +#define ZIP_CENTRAL_END_SIG             0x06054b50
          106  +#define ZIP_CENTRAL_END_LEN             22
          107  +#define ZIP_CENTRAL_END_SIG_OFFS        0
          108  +#define ZIP_CENTRAL_DISKNO_OFFS         4
          109  +#define ZIP_CENTRAL_DISKDIR_OFFS        6
          110  +#define ZIP_CENTRAL_ENTS_OFFS           8
          111  +#define ZIP_CENTRAL_TOTALENTS_OFFS      10
          112  +#define ZIP_CENTRAL_DIRSIZE_OFFS        12
          113  +#define ZIP_CENTRAL_DIRSTART_OFFS       16
          114  +#define ZIP_CENTRAL_COMMENTLEN_OFFS     20
          115  +
          116  +#define ZIP_MIN_VERSION                 20
          117  +#define ZIP_COMPMETH_STORED             0
          118  +#define ZIP_COMPMETH_DEFLATED           8
          119  +
          120  +#define ZIP_PASSWORD_END_SIG            0x5a5a4b50
          121  +
          122  +/* Macro to report errors only if an interp is present */
          123  +#define ZIPFS_ERROR(interp,errstr) \
          124  +    if(interp != NULL) Tcl_SetObjResult(interp, Tcl_NewStringObj(errstr, -1));
          125  +
          126  +/*
          127  + * Macros to read and write 16 and 32 bit integers from/to ZIP archives.
          128  + */
          129  +
          130  +#define zip_read_int(p)                         \
          131  +    ((p)[0] | ((p)[1] << 8) | ((p)[2] << 16) | ((p)[3] << 24))
          132  +#define zip_read_short(p)                       \
          133  +    ((p)[0] | ((p)[1] << 8))
          134  +
          135  +#define zip_write_int(p, v)                    \
          136  +    (p)[0] = (v) & 0xff; (p)[1] = ((v) >> 8) & 0xff;        \
          137  +    (p)[2] = ((v) >> 16) & 0xff; (p)[3] = ((v) >> 24) & 0xff;
          138  +#define zip_write_short(p, v)                    \
          139  +    (p)[0] = (v) & 0xff; (p)[1] = ((v) >> 8) & 0xff;
          140  +
          141  +/*
          142  + * Windows drive letters.
          143  + */
          144  +
          145  +#if defined(_WIN32) || defined(_WIN64)
          146  +#define HAS_DRIVES 1
          147  +static const char drvletters[] =
          148  +    "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ";
          149  +#else
          150  +#define HAS_DRIVES 0
          151  +#endif
          152  +
          153  +/*
          154  + * Mutex to protect localtime(3) when no reentrant version available.
          155  + */
          156  +
          157  +#if !defined(_WIN32) && !defined(_WIN64)
          158  +#ifndef HAVE_LOCALTIME_R
          159  +#ifdef TCL_THREADS
          160  +TCL_DECLARE_MUTEX(localtimeMutex)
          161  +#endif
          162  +#endif
          163  +#endif
          164  +
          165  +/*
          166  + * In-core description of mounted ZIP archive file.
          167  + */
          168  +
          169  +typedef struct ZipFile {
          170  +    char *name;               /* Archive name */
          171  +    size_t namelen;
          172  +    char is_membuf;           /* When true, not a file but a memory buffer */
          173  +    Tcl_Channel chan;         /* Channel handle or NULL */
          174  +    unsigned char *data;      /* Memory mapped or malloc'ed file */
          175  +    long length;              /* Length of memory mapped file */
          176  +    unsigned char *tofree;    /* Non-NULL if malloc'ed file */
          177  +    int nfiles;               /* Number of files in archive */
          178  +    unsigned long baseoffs;             /* Archive start */
          179  +    long baseoffsp;            /* Password start */
          180  +    unsigned long centoffs;             /* Archive directory start */
          181  +    unsigned char pwbuf[264];          /* Password buffer */
          182  +#if defined(_WIN32) || defined(_WIN64)
          183  +    HANDLE mh;
          184  +#endif
          185  +    unsigned long nopen;                /* Number of open files on archive */
          186  +    struct ZipEntry *entries; /* List of files in archive */
          187  +    struct ZipEntry *topents; /* List of top-level dirs in archive */
          188  +#if HAS_DRIVES
          189  +    int mntdrv;                  /* Drive letter of mount point */
          190  +#endif
          191  +    int mntptlen;
          192  +    char *mntpt;              /* Mount point */
          193  +} ZipFile;
          194  +
          195  +/*
          196  + * In-core description of file contained in mounted ZIP archive.
          197  + */
          198  +
          199  +typedef struct ZipEntry {
          200  +    char *name;               /* The full pathname of the virtual file */
          201  +    ZipFile *zipfile;         /* The ZIP file holding this virtual file */
          202  +    long offset;              /* Data offset into memory mapped ZIP file */
          203  +    int nbyte;                /* Uncompressed size of the virtual file */
          204  +    int nbytecompr;           /* Compressed size of the virtual file */
          205  +    int cmeth;                /* Compress method */
          206  +    int isdir;                  /* Set to 1 if directory, or -1 if root */
          207  +    int depth;                   /* Number of slashes in path. */
          208  +    int crc32;                /* CRC-32 */
          209  +    int timestamp;            /* Modification time */
          210  +    int isenc;                /* True if data is encrypted */
          211  +    unsigned char *data;      /* File data if written */
          212  +    struct ZipEntry *next;    /* Next file in the same archive */
          213  +    struct ZipEntry *tnext;   /* Next top-level dir in archive */
          214  +} ZipEntry;
          215  +
          216  +/*
          217  + * File channel for file contained in mounted ZIP archive.
          218  + */
          219  +
          220  +typedef struct ZipChannel {
          221  +    ZipFile *zipfile;         /* The ZIP file holding this channel */
          222  +    ZipEntry *zipentry;       /* Pointer back to virtual file */
          223  +    unsigned long nmax;       /* Max. size for write */
          224  +    unsigned long nbyte;      /* Number of bytes of uncompressed data */
          225  +    unsigned long nread;      /* Pos of next byte to be read from the channel */
          226  +    unsigned char *ubuf;      /* Pointer to the uncompressed data */
          227  +    int iscompr;              /* True if data is compressed */
          228  +    int isdir;                  /* Set to 1 if directory, or -1 if root */
          229  +    int isenc;                /* True if data is encrypted */
          230  +    int iswr;                 /* True if open for writing */
          231  +    unsigned long keys[3];    /* Key for decryption */
          232  +} ZipChannel;
          233  +
          234  +/*
          235  + * Global variables.
          236  + *
          237  + * Most are kept in single ZipFS struct. When build with threading
          238  + * support this struct is protected by the ZipFSMutex (see below).
          239  + *
          240  + * The "fileHash" component is the process wide global table of all known
          241  + * ZIP archive members in all mounted ZIP archives.
          242  + *
          243  + * The "zipHash" components is the process wide global table of all mounted
          244  + * ZIP archive files.
          245  + */
          246  +
          247  +static struct {
          248  +    int initialized;        /* True when initialized */
          249  +    int lock;            /* RW lock, see below */
          250  +    int waiters;        /* RW lock, see below */
          251  +    int wrmax;            /* Maximum write size of a file */
          252  +    int idCount;        /* Counter for channel names */
          253  +    Tcl_HashTable fileHash;    /* File name to ZipEntry mapping */
          254  +    Tcl_HashTable zipHash;    /* Mount to ZipFile mapping */
          255  +} ZipFS = {
          256  +    0, 0, 0, 0, 0,
          257  +};
          258  +
          259  +/*
          260  + * For password rotation.
          261  + */
          262  +
          263  +static const char pwrot[16] = {
          264  +    0x00, 0x80, 0x40, 0xc0, 0x20, 0xa0, 0x60, 0xe0,
          265  +    0x10, 0x90, 0x50, 0xd0, 0x30, 0xb0, 0x70, 0xf0
          266  +};
          267  +
          268  +/*
          269  + * Table to compute CRC32.
          270  + */
          271  +
          272  +static const z_crc_t crc32tab[256] = {
          273  +    0x00000000, 0x77073096, 0xee0e612c, 0x990951ba, 0x076dc419,
          274  +    0x706af48f, 0xe963a535, 0x9e6495a3, 0x0edb8832, 0x79dcb8a4,
          275  +    0xe0d5e91e, 0x97d2d988, 0x09b64c2b, 0x7eb17cbd, 0xe7b82d07,
          276  +    0x90bf1d91, 0x1db71064, 0x6ab020f2, 0xf3b97148, 0x84be41de,
          277  +    0x1adad47d, 0x6ddde4eb, 0xf4d4b551, 0x83d385c7, 0x136c9856,
          278  +    0x646ba8c0, 0xfd62f97a, 0x8a65c9ec, 0x14015c4f, 0x63066cd9,
          279  +    0xfa0f3d63, 0x8d080df5, 0x3b6e20c8, 0x4c69105e, 0xd56041e4,
          280  +    0xa2677172, 0x3c03e4d1, 0x4b04d447, 0xd20d85fd, 0xa50ab56b,
          281  +    0x35b5a8fa, 0x42b2986c, 0xdbbbc9d6, 0xacbcf940, 0x32d86ce3,
          282  +    0x45df5c75, 0xdcd60dcf, 0xabd13d59, 0x26d930ac, 0x51de003a,
          283  +    0xc8d75180, 0xbfd06116, 0x21b4f4b5, 0x56b3c423, 0xcfba9599,
          284  +    0xb8bda50f, 0x2802b89e, 0x5f058808, 0xc60cd9b2, 0xb10be924,
          285  +    0x2f6f7c87, 0x58684c11, 0xc1611dab, 0xb6662d3d, 0x76dc4190,
          286  +    0x01db7106, 0x98d220bc, 0xefd5102a, 0x71b18589, 0x06b6b51f,
          287  +    0x9fbfe4a5, 0xe8b8d433, 0x7807c9a2, 0x0f00f934, 0x9609a88e,
          288  +    0xe10e9818, 0x7f6a0dbb, 0x086d3d2d, 0x91646c97, 0xe6635c01,
          289  +    0x6b6b51f4, 0x1c6c6162, 0x856530d8, 0xf262004e, 0x6c0695ed,
          290  +    0x1b01a57b, 0x8208f4c1, 0xf50fc457, 0x65b0d9c6, 0x12b7e950,
          291  +    0x8bbeb8ea, 0xfcb9887c, 0x62dd1ddf, 0x15da2d49, 0x8cd37cf3,
          292  +    0xfbd44c65, 0x4db26158, 0x3ab551ce, 0xa3bc0074, 0xd4bb30e2,
          293  +    0x4adfa541, 0x3dd895d7, 0xa4d1c46d, 0xd3d6f4fb, 0x4369e96a,
          294  +    0x346ed9fc, 0xad678846, 0xda60b8d0, 0x44042d73, 0x33031de5,
          295  +    0xaa0a4c5f, 0xdd0d7cc9, 0x5005713c, 0x270241aa, 0xbe0b1010,
          296  +    0xc90c2086, 0x5768b525, 0x206f85b3, 0xb966d409, 0xce61e49f,
          297  +    0x5edef90e, 0x29d9c998, 0xb0d09822, 0xc7d7a8b4, 0x59b33d17,
          298  +    0x2eb40d81, 0xb7bd5c3b, 0xc0ba6cad, 0xedb88320, 0x9abfb3b6,
          299  +    0x03b6e20c, 0x74b1d29a, 0xead54739, 0x9dd277af, 0x04db2615,
          300  +    0x73dc1683, 0xe3630b12, 0x94643b84, 0x0d6d6a3e, 0x7a6a5aa8,
          301  +    0xe40ecf0b, 0x9309ff9d, 0x0a00ae27, 0x7d079eb1, 0xf00f9344,
          302  +    0x8708a3d2, 0x1e01f268, 0x6906c2fe, 0xf762575d, 0x806567cb,
          303  +    0x196c3671, 0x6e6b06e7, 0xfed41b76, 0x89d32be0, 0x10da7a5a,
          304  +    0x67dd4acc, 0xf9b9df6f, 0x8ebeeff9, 0x17b7be43, 0x60b08ed5,
          305  +    0xd6d6a3e8, 0xa1d1937e, 0x38d8c2c4, 0x4fdff252, 0xd1bb67f1,
          306  +    0xa6bc5767, 0x3fb506dd, 0x48b2364b, 0xd80d2bda, 0xaf0a1b4c,
          307  +    0x36034af6, 0x41047a60, 0xdf60efc3, 0xa867df55, 0x316e8eef,
          308  +    0x4669be79, 0xcb61b38c, 0xbc66831a, 0x256fd2a0, 0x5268e236,
          309  +    0xcc0c7795, 0xbb0b4703, 0x220216b9, 0x5505262f, 0xc5ba3bbe,
          310  +    0xb2bd0b28, 0x2bb45a92, 0x5cb36a04, 0xc2d7ffa7, 0xb5d0cf31,
          311  +    0x2cd99e8b, 0x5bdeae1d, 0x9b64c2b0, 0xec63f226, 0x756aa39c,
          312  +    0x026d930a, 0x9c0906a9, 0xeb0e363f, 0x72076785, 0x05005713,
          313  +    0x95bf4a82, 0xe2b87a14, 0x7bb12bae, 0x0cb61b38, 0x92d28e9b,
          314  +    0xe5d5be0d, 0x7cdcefb7, 0x0bdbdf21, 0x86d3d2d4, 0xf1d4e242,
          315  +    0x68ddb3f8, 0x1fda836e, 0x81be16cd, 0xf6b9265b, 0x6fb077e1,
          316  +    0x18b74777, 0x88085ae6, 0xff0f6a70, 0x66063bca, 0x11010b5c,
          317  +    0x8f659eff, 0xf862ae69, 0x616bffd3, 0x166ccf45, 0xa00ae278,
          318  +    0xd70dd2ee, 0x4e048354, 0x3903b3c2, 0xa7672661, 0xd06016f7,
          319  +    0x4969474d, 0x3e6e77db, 0xaed16a4a, 0xd9d65adc, 0x40df0b66,
          320  +    0x37d83bf0, 0xa9bcae53, 0xdebb9ec5, 0x47b2cf7f, 0x30b5ffe9,
          321  +    0xbdbdf21c, 0xcabac28a, 0x53b39330, 0x24b4a3a6, 0xbad03605,
          322  +    0xcdd70693, 0x54de5729, 0x23d967bf, 0xb3667a2e, 0xc4614ab8,
          323  +    0x5d681b02, 0x2a6f2b94, 0xb40bbe37, 0xc30c8ea1, 0x5a05df1b,
          324  +    0x2d02ef8d,
          325  +};
          326  +
          327  +const char *zipfs_literal_tcl_library=NULL;
          328  +
          329  +/* Function prototypes */
          330  +int TclZipfs_Mount(
          331  +    Tcl_Interp *interp,
          332  +    const char *mntpt,
          333  +    const char *zipname,
          334  +    const char *passwd
          335  +);
          336  +int TclZipfs_Mount_Buffer(
          337  +    Tcl_Interp *interp,
          338  +    const char *mntpt,
          339  +    unsigned char *data,
          340  +    size_t datalen,
          341  +    int copy
          342  +);
          343  +static int TclZipfs_AppHook_FindTclInit(const char *archive);
          344  +static int Zip_FSPathInFilesystemProc(Tcl_Obj *pathPtr, ClientData *clientDataPtr);
          345  +static Tcl_Obj *Zip_FSFilesystemPathTypeProc(Tcl_Obj *pathPtr);
          346  +static Tcl_Obj *Zip_FSFilesystemSeparatorProc(Tcl_Obj *pathPtr);
          347  +static int Zip_FSStatProc(Tcl_Obj *pathPtr, Tcl_StatBuf *buf);
          348  +static int Zip_FSAccessProc(Tcl_Obj *pathPtr, int mode);
          349  +static Tcl_Channel Zip_FSOpenFileChannelProc(
          350  +    Tcl_Interp *interp, Tcl_Obj *pathPtr,
          351  +    int mode, int permissions
          352  +);
          353  +static int Zip_FSMatchInDirectoryProc(
          354  +    Tcl_Interp* interp, Tcl_Obj *result,
          355  +    Tcl_Obj *pathPtr, const char *pattern,
          356  +    Tcl_GlobTypeData *types
          357  +);
          358  +static Tcl_Obj *Zip_FSListVolumesProc(void);
          359  +static const char *const *Zip_FSFileAttrStringsProc(Tcl_Obj *pathPtr, Tcl_Obj** objPtrRef);
          360  +static int Zip_FSFileAttrsGetProc(
          361  +    Tcl_Interp *interp, int index, Tcl_Obj *pathPtr,
          362  +    Tcl_Obj **objPtrRef
          363  +);
          364  +static int Zip_FSFileAttrsSetProc(Tcl_Interp *interp, int index, Tcl_Obj *pathPtr,Tcl_Obj *objPtr);
          365  +static int Zip_FSLoadFile(Tcl_Interp *interp, Tcl_Obj *path, Tcl_LoadHandle *loadHandle,
          366  +               Tcl_FSUnloadFileProc **unloadProcPtr, int flags);
          367  +static void TclZipfs_C_Init(void);
          368  +
          369  +/*
          370  + * Define the ZIP filesystem dispatch table.
          371  + */
          372  +
          373  +MODULE_SCOPE const Tcl_Filesystem zipfsFilesystem;
          374  +
          375  +const Tcl_Filesystem zipfsFilesystem = {
          376  +    "zipfs",
          377  +    sizeof (Tcl_Filesystem),
          378  +    TCL_FILESYSTEM_VERSION_2,
          379  +    Zip_FSPathInFilesystemProc,
          380  +    NULL, /* dupInternalRepProc */
          381  +    NULL, /* freeInternalRepProc */
          382  +    NULL, /* internalToNormalizedProc */
          383  +    NULL, /* createInternalRepProc */
          384  +    NULL, /* normalizePathProc */
          385  +    Zip_FSFilesystemPathTypeProc,
          386  +    Zip_FSFilesystemSeparatorProc,
          387  +    Zip_FSStatProc,
          388  +    Zip_FSAccessProc,
          389  +    Zip_FSOpenFileChannelProc,
          390  +    Zip_FSMatchInDirectoryProc,
          391  +    NULL, /* utimeProc */
          392  +    NULL, /* linkProc */
          393  +    Zip_FSListVolumesProc,
          394  +    Zip_FSFileAttrStringsProc,
          395  +    Zip_FSFileAttrsGetProc,
          396  +    Zip_FSFileAttrsSetProc,
          397  +    NULL, /* createDirectoryProc */
          398  +    NULL, /* removeDirectoryProc */
          399  +    NULL, /* deleteFileProc */
          400  +    NULL, /* copyFileProc */
          401  +    NULL, /* renameFileProc */
          402  +    NULL, /* copyDirectoryProc */
          403  +    NULL, /* lstatProc */
          404  +    (Tcl_FSLoadFileProc *) Zip_FSLoadFile,
          405  +    NULL, /* getCwdProc */
          406  +    NULL, /* chdirProc*/
          407  +};
          408  +
          409  +
          410  +
          411  +/*
          412  + *-------------------------------------------------------------------------
          413  + *
          414  + * ReadLock, WriteLock, Unlock --
          415  + *
          416  + *    POSIX like rwlock functions to support multiple readers
          417  + *    and single writer on internal structs.
          418  + *
          419  + *    Limitations:
          420  + *    - a read lock cannot be promoted to a write lock
          421  + *    - a write lock may not be nested
          422  + *
          423  + *-------------------------------------------------------------------------
          424  + */
          425  +
          426  +TCL_DECLARE_MUTEX(ZipFSMutex)
          427  +
          428  +#ifdef TCL_THREADS
          429  +
          430  +static Tcl_Condition ZipFSCond;
          431  +
          432  +static void
          433  +ReadLock(void)
          434  +{
          435  +    Tcl_MutexLock(&ZipFSMutex);
          436  +    while (ZipFS.lock < 0) {
          437  +        ZipFS.waiters++;
          438  +        Tcl_ConditionWait(&ZipFSCond, &ZipFSMutex, NULL);
          439  +        ZipFS.waiters--;
          440  +    }
          441  +    ZipFS.lock++;
          442  +    Tcl_MutexUnlock(&ZipFSMutex);
          443  +}
          444  +
          445  +static void
          446  +WriteLock(void)
          447  +{
          448  +    Tcl_MutexLock(&ZipFSMutex);
          449  +    while (ZipFS.lock != 0) {
          450  +        ZipFS.waiters++;
          451  +        Tcl_ConditionWait(&ZipFSCond, &ZipFSMutex, NULL);
          452  +        ZipFS.waiters--;
          453  +    }
          454  +    ZipFS.lock = -1;
          455  +    Tcl_MutexUnlock(&ZipFSMutex);
          456  +}
          457  +
          458  +static void
          459  +Unlock(void)
          460  +{
          461  +    Tcl_MutexLock(&ZipFSMutex);
          462  +    if (ZipFS.lock > 0) {
          463  +        --ZipFS.lock;
          464  +    } else if (ZipFS.lock < 0) {
          465  +        ZipFS.lock = 0;
          466  +    }
          467  +    if ((ZipFS.lock == 0) && (ZipFS.waiters > 0)) {
          468  +        Tcl_ConditionNotify(&ZipFSCond);
          469  +    }
          470  +    Tcl_MutexUnlock(&ZipFSMutex);
          471  +}
          472  +
          473  +#else
          474  +
          475  +#define ReadLock()    do {} while (0)
          476  +#define WriteLock()    do {} while (0)
          477  +#define Unlock()    do {} while (0)
          478  +
          479  +#endif
          480  +
          481  +/*
          482  + *-------------------------------------------------------------------------
          483  + *
          484  + * DosTimeDate, ToDosTime, ToDosDate --
          485  + *
          486  + *    Functions to perform conversions between DOS time stamps
          487  + *    and POSIX time_t.
          488  + *
          489  + *-------------------------------------------------------------------------
          490  + */
          491  +
          492  +static time_t
          493  +DosTimeDate(int dosDate, int dosTime)
          494  +{
          495  +    struct tm tm;
          496  +    time_t ret;
          497  +
          498  +    memset(&tm, 0, sizeof (tm));
          499  +    tm.tm_year = (((dosDate & 0xfe00) >> 9) + 80);
          500  +    tm.tm_mon = ((dosDate & 0x1e0) >> 5) - 1;
          501  +    tm.tm_mday = dosDate & 0x1f;
          502  +    tm.tm_hour = (dosTime & 0xf800) >> 11;
          503  +    tm.tm_min = (dosTime & 0x7e) >> 5;
          504  +    tm.tm_sec = (dosTime & 0x1f) << 1;
          505  +    ret = mktime(&tm);
          506  +    if (ret == (time_t) -1) {
          507  +        /* fallback to 1980-01-01T00:00:00+00:00 (DOS epoch) */
          508  +        ret = (time_t) 315532800;
          509  +    }
          510  +    return ret;
          511  +}
          512  +
          513  +static int
          514  +ToDosTime(time_t when)
          515  +{
          516  +    struct tm *tmp, tm;
          517  +
          518  +#ifdef TCL_THREADS
          519  +#if defined(_WIN32) || defined(_WIN64)
          520  +    /* Win32 uses thread local storage */
          521  +    tmp = localtime(&when);
          522  +    tm = *tmp;
          523  +#else
          524  +#ifdef HAVE_LOCALTIME_R
          525  +    tmp = &tm;
          526  +    localtime_r(&when, tmp);
          527  +#else
          528  +    Tcl_MutexLock(&localtimeMutex);
          529  +    tmp = localtime(&when);
          530  +    tm = *tmp;
          531  +    Tcl_MutexUnlock(&localtimeMutex);
          532  +#endif
          533  +#endif
          534  +#else
          535  +    tmp = localtime(&when);
          536  +    tm = *tmp;
          537  +#endif
          538  +    return (tm.tm_hour << 11) | (tm.tm_min << 5) | (tm.tm_sec >> 1);
          539  +}
          540  +
          541  +static int
          542  +ToDosDate(time_t when)
          543  +{
          544  +    struct tm *tmp, tm;
          545  +
          546  +#ifdef TCL_THREADS
          547  +#if defined(_WIN32) || defined(_WIN64)
          548  +    /* Win32 uses thread local storage */
          549  +    tmp = localtime(&when);
          550  +    tm = *tmp;
          551  +#else
          552  +#ifdef HAVE_LOCALTIME_R
          553  +    tmp = &tm;
          554  +    localtime_r(&when, tmp);
          555  +#else
          556  +    Tcl_MutexLock(&localtimeMutex);
          557  +    tmp = localtime(&when);
          558  +    tm = *tmp;
          559  +    Tcl_MutexUnlock(&localtimeMutex);
          560  +#endif
          561  +#endif
          562  +#else
          563  +    tmp = localtime(&when);
          564  +    tm = *tmp;
          565  +#endif
          566  +    return ((tm.tm_year - 80) << 9) | ((tm.tm_mon + 1) << 5) | tm.tm_mday;
          567  +}
          568  +
          569  +/*
          570  + *-------------------------------------------------------------------------
          571  + *
          572  + * CountSlashes --
          573  + *
          574  + *    This function counts the number of slashes in a pathname string.
          575  + *
          576  + * Results:
          577  + *    Number of slashes found in string.
          578  + *
          579  + * Side effects:
          580  + *    None.
          581  + *
          582  + *-------------------------------------------------------------------------
          583  + */
          584  +
          585  +static int
          586  +CountSlashes(const char *string)
          587  +{
          588  +    int count = 0;
          589  +    const char *p = string;
          590  +
          591  +    while (*p != '\0') {
          592  +        if (*p == '/') {
          593  +            count++;
          594  +        }
          595  +        p++;
          596  +    }
          597  +    return count;
          598  +}
          599  +
          600  +/*
          601  + *-------------------------------------------------------------------------
          602  + *
          603  + * CanonicalPath --
          604  + *
          605  + *    This function computes the canonical path from a directory
          606  + *    and file name components into the specified Tcl_DString.
          607  + *
          608  + * Results:
          609  + *    Returns the pointer to the canonical path contained in the
          610  + *    specified Tcl_DString.
          611  + *
          612  + * Side effects:
          613  + *    Modifies the specified Tcl_DString.
          614  + *
          615  + *-------------------------------------------------------------------------
          616  + */
          617  +
          618  +static char *
          619  +CanonicalPath(const char *root, const char *tail, Tcl_DString *dsPtr,int ZIPFSPATH)
          620  +{
          621  +    char *path;
          622  +    char *result;
          623  +    int i, j, c, isunc = 0, isvfs=0, n=0;
          624  +#if HAS_DRIVES
          625  +    int zipfspath=1;
          626  +    if (
          627  +        (tail[0] != '\0')
          628  +        && (strchr(drvletters, tail[0]) != NULL)
          629  +        && (tail[1] == ':')
          630  +    ) {
          631  +        tail += 2;
          632  +        zipfspath=0;
          633  +    }
          634  +    /* UNC style path */
          635  +    if (tail[0] == '\\') {
          636  +        root = "";
          637  +        ++tail;
          638  +        zipfspath=0;
          639  +    }
          640  +    if (tail[0] == '\\') {
          641  +        root = "/";
          642  +        ++tail;
          643  +        zipfspath=0;
          644  +    }
          645  +    if(zipfspath) {
          646  +#endif
          647  +        /* UNC style path */
          648  +        if(root && strncmp(root,ZIPFS_VOLUME,ZIPFS_VOLUME_LEN)==0) {
          649  +            isvfs=1;
          650  +        } else if (tail && strncmp(tail,ZIPFS_VOLUME,ZIPFS_VOLUME_LEN) == 0) {
          651  +            isvfs=2;
          652  +        }
          653  +        if(isvfs!=1) {
          654  +            if ((root[0] == '/') && (root[1] == '/')) {
          655  +            isunc = 1;
          656  +            }
          657  +        }
          658  +#if HAS_DRIVES
          659  +    }
          660  +#endif
          661  +    if(isvfs!=2) {
          662  +        if (tail[0] == '/') {
          663  +            if(isvfs!=1) {
          664  +                root = "";
          665  +            }
          666  +            ++tail;
          667  +            isunc = 0;
          668  +        }
          669  +        if (tail[0] == '/') {
          670  +            if(isvfs!=1) {
          671  +                root = "/";
          672  +            }
          673  +            ++tail;
          674  +            isunc = 1;
          675  +        }
          676  +    }
          677  +    i = strlen(root);
          678  +    j = strlen(tail);
          679  +    if(isvfs==1) {
          680  +        if(i>ZIPFS_VOLUME_LEN) {
          681  +            Tcl_DStringSetLength(dsPtr, i + j + 1);
          682  +            path = Tcl_DStringValue(dsPtr);
          683  +            memcpy(path, root, i);
          684  +            path[i++] = '/';
          685  +            memcpy(path + i, tail, j);
          686  +        } else {
          687  +            Tcl_DStringSetLength(dsPtr, i + j);
          688  +            path = Tcl_DStringValue(dsPtr);
          689  +            memcpy(path, root, i);
          690  +            memcpy(path + i, tail, j);
          691  +        }
          692  +    } else if(isvfs==2) {
          693  +        Tcl_DStringSetLength(dsPtr, j);
          694  +        path = Tcl_DStringValue(dsPtr);
          695  +        memcpy(path, tail, j);
          696  +    } else {
          697  +        if (ZIPFSPATH) {
          698  +            Tcl_DStringSetLength(dsPtr, i + j + ZIPFS_VOLUME_LEN);
          699  +            path = Tcl_DStringValue(dsPtr);
          700  +            memcpy(path, ZIPFS_VOLUME, ZIPFS_VOLUME_LEN);
          701  +            memcpy(path + ZIPFS_VOLUME_LEN + i , tail, j);
          702  +        } else {
          703  +            Tcl_DStringSetLength(dsPtr, i + j + 1);
          704  +            path = Tcl_DStringValue(dsPtr);
          705  +            memcpy(path, root, i);
          706  +            path[i++] = '/';
          707  +            memcpy(path + i, tail, j);
          708  +        }
          709  +    }
          710  +#if HAS_DRIVES
          711  +    for (i = 0; path[i] != '\0'; i++) {
          712  +        if (path[i] == '\\') {
          713  +            path[i] = '/';
          714  +        }
          715  +    }
          716  +#endif
          717  +    if(ZIPFSPATH) {
          718  +        n=ZIPFS_VOLUME_LEN;
          719  +    } else {
          720  +        n=0;
          721  +    }
          722  +    for (i = j = n; (c = path[i]) != '\0'; i++) {
          723  +        if (c == '/') {
          724  +            int c2 = path[i + 1];
          725  +            if (c2 == '/') {
          726  +                continue;
          727  +            }
          728  +            if (c2 == '.') {
          729  +                int c3 = path[i + 2];
          730  +                if ((c3 == '/') || (c3 == '\0')) {
          731  +                    i++;
          732  +                    continue;
          733  +                }
          734  +                if (
          735  +                    (c3 == '.')
          736  +                    && ((path[i + 3] == '/') || (path [i + 3] == '\0'))
          737  +                ) {
          738  +                    i += 2;
          739  +                    while ((j > 0) && (path[j - 1] != '/')) {
          740  +                        j--;
          741  +                    }
          742  +                    if (j > isunc) {
          743  +                        --j;
          744  +                        while ((j > 1 + isunc) && (path[j - 2] == '/')) {
          745  +                            j--;
          746  +                        }
          747  +                    }
          748  +                    continue;
          749  +                }
          750  +            }
          751  +        }
          752  +        path[j++] = c;
          753  +    }
          754  +    if (j == 0) {
          755  +        path[j++] = '/';
          756  +    }
          757  +    path[j] = 0;
          758  +    Tcl_DStringSetLength(dsPtr, j);
          759  +    result=Tcl_DStringValue(dsPtr);
          760  +    return result;
          761  +}
          762  +
          763  +
          764  +/*
          765  + *-------------------------------------------------------------------------
          766  + *
          767  + * AbsolutePath --
          768  + *
          769  + *        This function computes the absolute path from a given
          770  + *        (relative) path name into the specified Tcl_DString.
          771  + *
          772  + * Results:
          773  + *        Returns the pointer to the absolute path contained in the
          774  + *        specified Tcl_DString.
          775  + *
          776  + * Side effects:
          777  + *        Modifies the specified Tcl_DString.
          778  + *
          779  + *-------------------------------------------------------------------------
          780  + */
          781  +
          782  +static char *
          783  +AbsolutePath(const char *path,
          784  +#if HAS_DRIVES
          785  +             int *drvPtr,
          786  +#endif
          787  +             Tcl_DString *dsPtr)
          788  +{
          789  +    char *result;
          790  +
          791  +#if HAS_DRIVES
          792  +    if (drvPtr != NULL) {
          793  +        *drvPtr = 0;
          794  +    }
          795  +#endif
          796  +    if (*path == '~') {
          797  +        Tcl_DStringAppend(dsPtr, path, -1);
          798  +        return Tcl_DStringValue(dsPtr);
          799  +    }
          800  +    if ((*path != '/')
          801  +#if HAS_DRIVES
          802  +        && (*path != '\\') &&
          803  +        (((*path != '\0') && (strchr(drvletters, *path) == NULL)) ||
          804  +         (path[1] != ':'))
          805  +#endif
          806  +        ) {
          807  +        Tcl_DString pwd;
          808  +
          809  +        /* relative path */
          810  +        Tcl_DStringInit(&pwd);
          811  +        Tcl_GetCwd(NULL, &pwd);
          812  +        result = Tcl_DStringValue(&pwd);
          813  +#if HAS_DRIVES
          814  +        if ((result[0] != '\0') && (strchr(drvletters, result[0]) != NULL) &&
          815  +            (result[1] == ':')) {
          816  +            if (drvPtr != NULL) {
          817  +                drvPtr[0] = result[0];
          818  +                if ((drvPtr[0] >= 'a') && (drvPtr[0] <= 'z')) {
          819  +                    drvPtr[0] -= 'a' - 'A';
          820  +                }
          821  +            }
          822  +            result += 2;
          823  +        }
          824  +#endif
          825  +        result = CanonicalPath(result, path, dsPtr, 0);
          826  +        Tcl_DStringFree(&pwd);
          827  +    } else {
          828  +        /* absolute path */
          829  +#if HAS_DRIVES
          830  +        if ((path[0] != '\0') && (strchr(drvletters, path[0]) != NULL) &&
          831  +            (path[1] == ':')) {
          832  +            if (drvPtr != NULL) {
          833  +                drvPtr[0] = path[0];
          834  +                if ((drvPtr[0] >= 'a') && (drvPtr[0] <= 'z')) {
          835  +                    drvPtr[0] -= 'a' - 'A';
          836  +                }
          837  +            }
          838  +        }
          839  +#endif
          840  +        result = CanonicalPath("", path, dsPtr, 0);
          841  +    }
          842  +    return result;
          843  +}
          844  +
          845  +/*
          846  + *-------------------------------------------------------------------------
          847  + *
          848  + * ZipFSLookup --
          849  + *
          850  + *    This function returns the ZIP entry struct corresponding to
          851  + *    the ZIP archive member of the given file name.
          852  + *
          853  + * Results:
          854  + *    Returns the pointer to ZIP entry struct or NULL if the
          855  + *    the given file name could not be found in the global list
          856  + *    of ZIP archive members.
          857  + *
          858  + * Side effects:
          859  + *    None.
          860  + *
          861  + *-------------------------------------------------------------------------
          862  + */
          863  +
          864  +static ZipEntry *
          865  +ZipFSLookup(char *filename)
          866  +{
          867  +    Tcl_HashEntry *hPtr;
          868  +    ZipEntry *z;
          869  +    Tcl_DString ds;
          870  +    Tcl_DStringInit(&ds);
          871  +    hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, filename);
          872  +    z = hPtr ? (ZipEntry *) Tcl_GetHashValue(hPtr) : NULL;
          873  +    Tcl_DStringFree(&ds);
          874  +    return z;
          875  +}
          876  +
          877  +#ifdef NEVER_USED
          878  +
          879  +/*
          880  + *-------------------------------------------------------------------------
          881  + *
          882  + * ZipFSLookupMount --
          883  + *
          884  + *    This function returns an indication if the given file name
          885  + *    corresponds to a mounted ZIP archive file.
          886  + *
          887  + * Results:
          888  + *    Returns true, if the given file name is a mounted ZIP archive file.
          889  + *
          890  + * Side effects:
          891  + *    None.
          892  + *
          893  + *-------------------------------------------------------------------------
          894  + */
          895  +
          896  +static int
          897  +ZipFSLookupMount(char *filename)
          898  +{
          899  +    Tcl_HashEntry *hPtr;
          900  +    Tcl_HashSearch search;
          901  +    ZipFile *zf;
          902  +    int match = 0;
          903  +    hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search);
          904  +    while (hPtr != NULL) {
          905  +        if ((zf = (ZipFile *) Tcl_GetHashValue(hPtr)) == NULL) continue;
          906  +        if (strcmp(zf->mntpt, filename) == 0) {
          907  +            match = 1;
          908  +            break;
          909  +        }
          910  +        hPtr = Tcl_NextHashEntry(&search);
          911  +    }
          912  +    return match;
          913  +}
          914  +#endif
          915  +
          916  +/*
          917  + *-------------------------------------------------------------------------
          918  + *
          919  + * ZipFSCloseArchive --
          920  + *
          921  + *    This function closes a mounted ZIP archive file.
          922  + *
          923  + * Results:
          924  + *    None.
          925  + *
          926  + * Side effects:
          927  + *    A memory mapped ZIP archive is unmapped, allocated memory is
          928  + *    released.
          929  + *
          930  + *-------------------------------------------------------------------------
          931  + */
          932  +
          933  +static void
          934  +ZipFSCloseArchive(Tcl_Interp *interp, ZipFile *zf)
          935  +{
          936  +    if(zf->namelen) {
          937  +        free(zf->name); //Allocated by strdup
          938  +    }
          939  +    if(zf->is_membuf==1) {
          940  +        /* Pointer to memory */
          941  +        if (zf->tofree != NULL) {
          942  +            Tcl_Free((char *) zf->tofree);
          943  +            zf->tofree = NULL;
          944  +        }
          945  +        zf->data = NULL;
          946  +        return;
          947  +    }
          948  +#if defined(_WIN32) || defined(_WIN64)
          949  +    if ((zf->data != NULL) && (zf->tofree == NULL)) {
          950  +        UnmapViewOfFile(zf->data);
          951  +        zf->data = NULL;
          952  +    }
          953  +    if (zf->mh != INVALID_HANDLE_VALUE) {
          954  +        CloseHandle(zf->mh);
          955  +    }
          956  +#else
          957  +    if ((zf->data != MAP_FAILED) && (zf->tofree == NULL)) {
          958  +        munmap(zf->data, zf->length);
          959  +        zf->data = MAP_FAILED;
          960  +    }
          961  +#endif
          962  +    if (zf->tofree != NULL) {
          963  +        Tcl_Free((char *) zf->tofree);
          964  +        zf->tofree = NULL;
          965  +    }
          966  +    if(zf->chan != NULL) {
          967  +        Tcl_Close(interp, zf->chan);
          968  +        zf->chan = NULL;
          969  +    }
          970  +}
          971  +
          972  +/*
          973  + *-------------------------------------------------------------------------
          974  + *
          975  + * ZipFS_Find_TOC --
          976  + *
          977  + *   This function takes a memory mapped zip file and indexes the contents.
          978  + *   When "needZip" is zero an embedded ZIP archive in an executable file is accepted.
          979  + *
          980  + * Results:
          981  + *    TCL_OK on success, TCL_ERROR otherwise with an error message
          982  + *    placed into the given "interp" if it is not NULL.
          983  + *
          984  + * Side effects:
          985  + *    The given ZipFile struct is filled with information about the ZIP archive file.
          986  + *
          987  + *-------------------------------------------------------------------------
          988  + */
          989  +static int
          990  +ZipFS_Find_TOC(Tcl_Interp *interp, int needZip, ZipFile *zf)
          991  +{
          992  +    int i;
          993  +    unsigned char *p, *q;
          994  +    p = zf->data + zf->length - ZIP_CENTRAL_END_LEN;
          995  +    while (p >= zf->data) {
          996  +        if (*p == (ZIP_CENTRAL_END_SIG & 0xFF)) {
          997  +            if (zip_read_int(p) == ZIP_CENTRAL_END_SIG) {
          998  +            break;
          999  +            }
         1000  +            p -= ZIP_SIG_LEN;
         1001  +        } else {
         1002  +            --p;
         1003  +        }
         1004  +    }
         1005  +    if (p < zf->data) {
         1006  +        if (!needZip) {
         1007  +            zf->baseoffs = zf->baseoffsp = zf->length;
         1008  +            return TCL_OK;
         1009  +        }
         1010  +        ZIPFS_ERROR(interp,"wrong end signature");
         1011  +        goto error;
         1012  +    }
         1013  +    zf->nfiles = zip_read_short(p + ZIP_CENTRAL_ENTS_OFFS);
         1014  +    if (zf->nfiles == 0) {
         1015  +        if (!needZip) {
         1016  +            zf->baseoffs = zf->baseoffsp = zf->length;
         1017  +            return TCL_OK;
         1018  +        }
         1019  +        ZIPFS_ERROR(interp,"empty archive");
         1020  +        goto error;
         1021  +    }
         1022  +    q = zf->data + zip_read_int(p + ZIP_CENTRAL_DIRSTART_OFFS);
         1023  +    p -= zip_read_int(p + ZIP_CENTRAL_DIRSIZE_OFFS);
         1024  +    if (
         1025  +        (p < zf->data) || (p > (zf->data + zf->length)) ||
         1026  +        (q < zf->data) || (q > (zf->data + zf->length))
         1027  +    ) {
         1028  +        if (!needZip) {
         1029  +            zf->baseoffs = zf->baseoffsp = zf->length;
         1030  +            return TCL_OK;
         1031  +        }
         1032  +        ZIPFS_ERROR(interp,"archive directory not found");
         1033  +        goto error;
         1034  +    }
         1035  +    zf->baseoffs = zf->baseoffsp = p - q;
         1036  +    zf->centoffs = p - zf->data;
         1037  +    q = p;
         1038  +    for (i = 0; i < zf->nfiles; i++) {
         1039  +        int pathlen, comlen, extra;
         1040  +
         1041  +        if ((q + ZIP_CENTRAL_HEADER_LEN) > (zf->data + zf->length)) {
         1042  +            ZIPFS_ERROR(interp,"wrong header length");
         1043  +            goto error;
         1044  +        }
         1045  +        if (zip_read_int(q) != ZIP_CENTRAL_HEADER_SIG) {
         1046  +            ZIPFS_ERROR(interp,"wrong header signature");
         1047  +            goto error;
         1048  +        }
         1049  +        pathlen = zip_read_short(q + ZIP_CENTRAL_PATHLEN_OFFS);
         1050  +        comlen = zip_read_short(q + ZIP_CENTRAL_FCOMMENTLEN_OFFS);
         1051  +        extra = zip_read_short(q + ZIP_CENTRAL_EXTRALEN_OFFS);
         1052  +        q += pathlen + comlen + extra + ZIP_CENTRAL_HEADER_LEN;
         1053  +    }
         1054  +    q = zf->data + zf->baseoffs;
         1055  +    if ((zf->baseoffs >= 6) && (zip_read_int(q - 4) == ZIP_PASSWORD_END_SIG)) {
         1056  +        i = q[-5];
         1057  +        if (q - 5 - i > zf->data) {
         1058  +            zf->pwbuf[0] = i;
         1059  +            memcpy(zf->pwbuf + 1, q - 5 - i, i);
         1060  +            zf->baseoffsp -= i ? (5 + i) : 0;
         1061  +        }
         1062  +    }
         1063  +
         1064  +    return TCL_OK;
         1065  +
         1066  +error:
         1067  +    ZipFSCloseArchive(interp, zf);
         1068  +    return TCL_ERROR;
         1069  +}
         1070  +
         1071  +/*
         1072  + *-------------------------------------------------------------------------
         1073  + *
         1074  + * ZipFSOpenArchive --
         1075  + *
         1076  + *    This function opens a ZIP archive file for reading. An attempt
         1077  + *    is made to memory map that file. Otherwise it is read into
         1078  + *    an allocated memory buffer. The ZIP archive header is verified
         1079  + *    and must be valid for the function to succeed. When "needZip"
         1080  + *    is zero an embedded ZIP archive in an executable file is accepted.
         1081  + *
         1082  + * Results:
         1083  + *    TCL_OK on success, TCL_ERROR otherwise with an error message
         1084  + *    placed into the given "interp" if it is not NULL.
         1085  + *
         1086  + * Side effects:
         1087  + *    ZIP archive is memory mapped or read into allocated memory,
         1088  + *    the given ZipFile struct is filled with information about
         1089  + *    the ZIP archive file.
         1090  + *
         1091  + *-------------------------------------------------------------------------
         1092  + */
         1093  +
         1094  +static int
         1095  +ZipFSOpenArchive(Tcl_Interp *interp, const char *zipname, int needZip, ZipFile *zf)
         1096  +{
         1097  +    int i;
         1098  +    ClientData handle;
         1099  +
         1100  +    zf->is_membuf=0;
         1101  +#if defined(_WIN32) || defined(_WIN64)
         1102  +    zf->data = NULL;
         1103  +    zf->mh = INVALID_HANDLE_VALUE;
         1104  +#else
         1105  +    zf->data = MAP_FAILED;
         1106  +#endif
         1107  +    zf->length = 0;
         1108  +    zf->nfiles = 0;
         1109  +    zf->baseoffs = zf->baseoffsp = 0;
         1110  +    zf->tofree = NULL;
         1111  +    zf->pwbuf[0] = 0;
         1112  +    zf->chan = Tcl_OpenFileChannel(interp, zipname, "r", 0);
         1113  +    if (zf->chan == NULL) {
         1114  +        return TCL_ERROR;
         1115  +    }
         1116  +    if (Tcl_GetChannelHandle(zf->chan, TCL_READABLE, &handle) != TCL_OK) {
         1117  +        if (Tcl_SetChannelOption(interp, zf->chan, "-translation", "binary") != TCL_OK) {
         1118  +            goto error;
         1119  +        }
         1120  +        if (Tcl_SetChannelOption(interp, zf->chan, "-encoding", "binary") != TCL_OK) {
         1121  +            goto error;
         1122  +        }
         1123  +        zf->length = Tcl_Seek(zf->chan, 0, SEEK_END);
         1124  +        if ((zf->length <= 0) || (zf->length > 64 * 1024 * 1024)) {
         1125  +            ZIPFS_ERROR(interp,"illegal file size");
         1126  +            goto error;
         1127  +        }
         1128  +        Tcl_Seek(zf->chan, 0, SEEK_SET);
         1129  +        zf->tofree = zf->data = (unsigned char *) Tcl_AttemptAlloc(zf->length);
         1130  +        if (zf->tofree == NULL) {
         1131  +            ZIPFS_ERROR(interp,"out of memory")
         1132  +            goto error;
         1133  +        }
         1134  +        i = Tcl_Read(zf->chan, (char *) zf->data, zf->length);
         1135  +        if (i != zf->length) {
         1136  +            ZIPFS_ERROR(interp,"file read error");
         1137  +            goto error;
         1138  +        }
         1139  +        Tcl_Close(interp, zf->chan);
         1140  +        zf->chan = NULL;
         1141  +    } else {
         1142  +#if defined(_WIN32) || defined(_WIN64)
         1143  +        zf->length = GetFileSize((HANDLE) handle, 0);
         1144  +        if (
         1145  +            (zf->length == INVALID_FILE_SIZE) ||
         1146  +            (zf->length < ZIP_CENTRAL_END_LEN)
         1147  +        ) {
         1148  +            ZIPFS_ERROR(interp,"invalid file size");
         1149  +            goto error;
         1150  +        }
         1151  +        zf->mh = CreateFileMapping((HANDLE) handle, 0, PAGE_READONLY, 0,
         1152  +                       zf->length, 0);
         1153  +        if (zf->mh == INVALID_HANDLE_VALUE) {
         1154  +            ZIPFS_ERROR(interp,"file mapping failed");
         1155  +            goto error;
         1156  +        }
         1157  +        zf->data = MapViewOfFile(zf->mh, FILE_MAP_READ, 0, 0, zf->length);
         1158  +        if (zf->data == NULL) {
         1159  +            ZIPFS_ERROR(interp,"file mapping failed");
         1160  +            goto error;
         1161  +        }
         1162  +#else
         1163  +        zf->length = lseek((int) (long) handle, 0, SEEK_END);
         1164  +        if ((zf->length == -1) || (zf->length < ZIP_CENTRAL_END_LEN)) {
         1165  +            ZIPFS_ERROR(interp,"invalid file size");
         1166  +            goto error;
         1167  +        }
         1168  +        lseek((int) (long) handle, 0, SEEK_SET);
         1169  +        zf->data = (unsigned char *) mmap(0, zf->length, PROT_READ,
         1170  +                          MAP_FILE | MAP_PRIVATE,
         1171  +                          (int) (long) handle, 0);
         1172  +        if (zf->data == MAP_FAILED) {
         1173  +            ZIPFS_ERROR(interp,"file mapping failed");
         1174  +            goto error;
         1175  +        }
         1176  +#endif
         1177  +    }
         1178  +    return ZipFS_Find_TOC(interp,needZip,zf);
         1179  +
         1180  +error:
         1181  +    ZipFSCloseArchive(interp, zf);
         1182  +    return TCL_ERROR;
         1183  +}
         1184  +
         1185  +/*
         1186  + *-------------------------------------------------------------------------
         1187  + *
         1188  + * ZipFSRootNode --
         1189  + *
         1190  + *    This function generates the root node for a ZIPFS filesystem
         1191  + *
         1192  + * Results:
         1193  + *    TCL_OK on success, TCL_ERROR otherwise with an error message
         1194  + *    placed into the given "interp" if it is not NULL.
         1195  + *
         1196  + * Side effects:
         1197  + *-------------------------------------------------------------------------
         1198  + */
         1199  +
         1200  +static int
         1201  +ZipFS_Catalogue_Filesystem(Tcl_Interp *interp, ZipFile *zf0, const char *mntpt, const char *passwd, const char *zipname)
         1202  +{
         1203  +    int i, pwlen, isNew;
         1204  +    ZipFile *zf;
         1205  +    ZipEntry *z;
         1206  +    Tcl_HashEntry *hPtr;
         1207  +    Tcl_DString ds, dsm, fpBuf;
         1208  +    unsigned char *q;
         1209  +#if HAS_DRIVES
         1210  +    int drive = 0;
         1211  +#endif
         1212  +    WriteLock();
         1213  +
         1214  +    pwlen = 0;
         1215  +    if (passwd != NULL) {
         1216  +        pwlen = strlen(passwd);
         1217  +        if ((pwlen > 255) || (strchr(passwd, 0xff) != NULL)) {
         1218  +            if (interp) {
         1219  +            Tcl_SetObjResult(interp,
         1220  +                Tcl_NewStringObj("illegal password", -1));
         1221  +            }
         1222  +            return TCL_ERROR;
         1223  +        }
         1224  +    }
         1225  +    /*
         1226  +     * Mount point sometimes is a relative or otherwise denormalized path.
         1227  +     * But an absolute name is needed as mount point here.
         1228  +     */
         1229  +    Tcl_DStringInit(&ds);
         1230  +    Tcl_DStringInit(&dsm);
         1231  +    if (strcmp(mntpt, "/") == 0) {
         1232  +        mntpt = "";
         1233  +    } else {
         1234  +        mntpt = CanonicalPath("",mntpt, &dsm, 1);
         1235  +    }
         1236  +    hPtr = Tcl_CreateHashEntry(&ZipFS.zipHash, mntpt, &isNew);
         1237  +    if (!isNew) {
         1238  +        zf = (ZipFile *) Tcl_GetHashValue(hPtr);
         1239  +        if (interp != NULL) {
         1240  +            Tcl_AppendResult(interp, zf->name, " is already mounted on ", mntpt, (char *) NULL);
         1241  +        }
         1242  +        Unlock();
         1243  +        ZipFSCloseArchive(interp, zf0);
         1244  +        return TCL_ERROR;
         1245  +    }
         1246  +    zf = (ZipFile *) Tcl_AttemptAlloc(sizeof (*zf) + strlen(mntpt) + 1);
         1247  +    if (zf == NULL) {
         1248  +        if (interp != NULL) {
         1249  +            Tcl_AppendResult(interp, "out of memory", (char *) NULL);
         1250  +        }
         1251  +        Unlock();
         1252  +        ZipFSCloseArchive(interp, zf0);
         1253  +        return TCL_ERROR;
         1254  +    }
         1255  +    Unlock();
         1256  +    *zf = *zf0;
         1257  +    zf->mntpt = Tcl_GetHashKey(&ZipFS.zipHash, hPtr);
         1258  +    zf->mntptlen=strlen(zf->mntpt);
         1259  +    zf->name = strdup(zipname);
         1260  +    zf->namelen= strlen(zipname);
         1261  +    zf->entries = NULL;
         1262  +    zf->topents = NULL;
         1263  +    zf->nopen = 0;
         1264  +    Tcl_SetHashValue(hPtr, (ClientData) zf);
         1265  +    if ((zf->pwbuf[0] == 0) && pwlen) {
         1266  +        int k = 0;
         1267  +        i = pwlen;
         1268  +        zf->pwbuf[k++] = i;
         1269  +        while (i > 0) {
         1270  +            zf->pwbuf[k] = (passwd[i - 1] & 0x0f) |
         1271  +            pwrot[(passwd[i - 1] >> 4) & 0x0f];
         1272  +            k++;
         1273  +            i--;
         1274  +        }
         1275  +        zf->pwbuf[k] = '\0';
         1276  +    }
         1277  +    if (mntpt[0] != '\0') {
         1278  +        z = (ZipEntry *) Tcl_Alloc(sizeof (*z));
         1279  +        z->name = NULL;
         1280  +        z->tnext = NULL;
         1281  +        z->depth = CountSlashes(mntpt);
         1282  +        z->zipfile = zf;
         1283  +        z->isdir = (zf->baseoffs == 0) ? 1 : -1; /* root marker */
         1284  +        z->isenc = 0;
         1285  +        z->offset = zf->baseoffs;
         1286  +        z->crc32 = 0;
         1287  +        z->timestamp = 0;
         1288  +        z->nbyte = z->nbytecompr = 0;
         1289  +        z->cmeth = ZIP_COMPMETH_STORED;
         1290  +        z->data = NULL;
         1291  +        hPtr = Tcl_CreateHashEntry(&ZipFS.fileHash, mntpt, &isNew);
         1292  +        if (!isNew) {
         1293  +            /* skip it */
         1294  +            Tcl_Free((char *) z);
         1295  +        } else {
         1296  +            Tcl_SetHashValue(hPtr, (ClientData) z);
         1297  +            z->name = Tcl_GetHashKey(&ZipFS.fileHash, hPtr);
         1298  +            z->next = zf->entries;
         1299  +            zf->entries = z;
         1300  +        }
         1301  +    }
         1302  +    q = zf->data + zf->centoffs;
         1303  +    Tcl_DStringInit(&fpBuf);
         1304  +    for (i = 0; i < zf->nfiles; i++) {
         1305  +        int pathlen, comlen, extra, isdir = 0, dosTime, dosDate, nbcompr, offs;
         1306  +        unsigned char *lq, *gq = NULL;
         1307  +        char *fullpath, *path;
         1308  +
         1309  +        pathlen = zip_read_short(q + ZIP_CENTRAL_PATHLEN_OFFS);
         1310  +        comlen = zip_read_short(q + ZIP_CENTRAL_FCOMMENTLEN_OFFS);
         1311  +        extra = zip_read_short(q + ZIP_CENTRAL_EXTRALEN_OFFS);
         1312  +        Tcl_DStringSetLength(&ds, 0);
         1313  +        Tcl_DStringAppend(&ds, (char *) q + ZIP_CENTRAL_HEADER_LEN, pathlen);
         1314  +        path = Tcl_DStringValue(&ds);
         1315  +        if ((pathlen > 0) && (path[pathlen - 1] == '/')) {
         1316  +            Tcl_DStringSetLength(&ds, pathlen - 1);
         1317  +            path = Tcl_DStringValue(&ds);
         1318  +            isdir = 1;
         1319  +        }
         1320  +        if ((strcmp(path, ".") == 0) || (strcmp(path, "..") == 0)) {
         1321  +            goto nextent;
         1322  +        }
         1323  +        lq = zf->data + zf->baseoffs + zip_read_int(q + ZIP_CENTRAL_LOCALHDR_OFFS);
         1324  +        if ((lq < zf->data) || (lq > (zf->data + zf->length))) {
         1325  +            goto nextent;
         1326  +        }
         1327  +        nbcompr = zip_read_int(lq + ZIP_LOCAL_COMPLEN_OFFS);
         1328  +        if (
         1329  +            !isdir && (nbcompr == 0)
         1330  +            && (zip_read_int(lq + ZIP_LOCAL_UNCOMPLEN_OFFS) == 0)
         1331  +            && (zip_read_int(lq + ZIP_LOCAL_CRC32_OFFS) == 0)
         1332  +        ) {
         1333  +            gq = q;
         1334  +            nbcompr = zip_read_int(gq + ZIP_CENTRAL_COMPLEN_OFFS);
         1335  +        }
         1336  +        offs = (lq - zf->data)
         1337  +            + ZIP_LOCAL_HEADER_LEN
         1338  +            + zip_read_short(lq + ZIP_LOCAL_PATHLEN_OFFS)
         1339  +            + zip_read_short(lq + ZIP_LOCAL_EXTRALEN_OFFS);
         1340  +        if ((offs + nbcompr) > zf->length) {
         1341  +            goto nextent;
         1342  +        }
         1343  +        if (!isdir && (mntpt[0] == '\0') && !CountSlashes(path)) {
         1344  +#ifdef ANDROID
         1345  +            /*
         1346  +             * When mounting the ZIP archive on the root directory try
         1347  +             * to remap top level regular files of the archive to
         1348  +             * /assets/.root/... since this directory should not be
         1349  +             * in a valid APK due to the leading dot in the file name
         1350  +             * component. This trick should make the files
         1351  +             * AndroidManifest.xml, resources.arsc, and classes.dex
         1352  +             * visible to Tcl.
         1353  +             */
         1354  +            Tcl_DString ds2;
         1355  +
         1356  +            Tcl_DStringInit(&ds2);
         1357  +            Tcl_DStringAppend(&ds2, "assets/.root/", -1);
         1358  +            Tcl_DStringAppend(&ds2, path, -1);
         1359  +            hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, Tcl_DStringValue(&ds2));
         1360  +            if (hPtr != NULL) {
         1361  +                /* should not happen but skip it anyway */
         1362  +                Tcl_DStringFree(&ds2);
         1363  +                goto nextent;
         1364  +            }
         1365  +            Tcl_DStringSetLength(&ds, 0);
         1366  +            Tcl_DStringAppend(&ds, Tcl_DStringValue(&ds2), Tcl_DStringLength(&ds2));
         1367  +            path = Tcl_DStringValue(&ds);
         1368  +            Tcl_DStringFree(&ds2);
         1369  +#else
         1370  +            /*
         1371  +             * Regular files skipped when mounting on root.
         1372  +             */
         1373  +            goto nextent;
         1374  +#endif
         1375  +        }
         1376  +        Tcl_DStringSetLength(&fpBuf, 0);
         1377  +        fullpath = CanonicalPath(mntpt, path, &fpBuf, 1);
         1378  +        z = (ZipEntry *) Tcl_Alloc(sizeof (*z));
         1379  +        z->name = NULL;
         1380  +        z->tnext = NULL;
         1381  +        z->depth = CountSlashes(fullpath);
         1382  +        z->zipfile = zf;
         1383  +        z->isdir = isdir;
         1384  +        z->isenc = (zip_read_short(lq + ZIP_LOCAL_FLAGS_OFFS) & 1) && (nbcompr > 12);
         1385  +        z->offset = offs;
         1386  +        if (gq != NULL) {
         1387  +            z->crc32 = zip_read_int(gq + ZIP_CENTRAL_CRC32_OFFS);
         1388  +            dosDate = zip_read_short(gq + ZIP_CENTRAL_MDATE_OFFS);
         1389  +            dosTime = zip_read_short(gq + ZIP_CENTRAL_MTIME_OFFS);
         1390  +            z->timestamp = DosTimeDate(dosDate, dosTime);
         1391  +            z->nbyte = zip_read_int(gq + ZIP_CENTRAL_UNCOMPLEN_OFFS);
         1392  +            z->cmeth = zip_read_short(gq + ZIP_CENTRAL_COMPMETH_OFFS);
         1393  +        } else {
         1394  +            z->crc32 = zip_read_int(lq + ZIP_LOCAL_CRC32_OFFS);
         1395  +            dosDate = zip_read_short(lq + ZIP_LOCAL_MDATE_OFFS);
         1396  +            dosTime = zip_read_short(lq + ZIP_LOCAL_MTIME_OFFS);
         1397  +            z->timestamp = DosTimeDate(dosDate, dosTime);
         1398  +            z->nbyte = zip_read_int(lq + ZIP_LOCAL_UNCOMPLEN_OFFS);
         1399  +            z->cmeth = zip_read_short(lq + ZIP_LOCAL_COMPMETH_OFFS);
         1400  +        }
         1401  +        z->nbytecompr = nbcompr;
         1402  +        z->data = NULL;
         1403  +        hPtr = Tcl_CreateHashEntry(&ZipFS.fileHash, fullpath, &isNew);
         1404  +        if (!isNew) {
         1405  +            /* should not happen but skip it anyway */
         1406  +            Tcl_Free((char *) z);
         1407  +        } else {
         1408  +            Tcl_SetHashValue(hPtr, (ClientData) z);
         1409  +            z->name = Tcl_GetHashKey(&ZipFS.fileHash, hPtr);
         1410  +            z->next = zf->entries;
         1411  +            zf->entries = z;
         1412  +            if (isdir && (mntpt[0] == '\0') && (z->depth == 1)) {
         1413  +                z->tnext = zf->topents;
         1414  +                zf->topents = z;
         1415  +            }
         1416  +            if (!z->isdir && (z->depth > 1)) {
         1417  +                char *dir, *end;
         1418  +                ZipEntry *zd;
         1419  +
         1420  +                Tcl_DStringSetLength(&ds, strlen(z->name) + 8);
         1421  +                Tcl_DStringSetLength(&ds, 0);
         1422  +                Tcl_DStringAppend(&ds, z->name, -1);
         1423  +                dir = Tcl_DStringValue(&ds);
         1424  +                end = strrchr(dir, '/');
         1425  +                while ((end != NULL) && (end != dir)) {
         1426  +                    Tcl_DStringSetLength(&ds, end - dir);
         1427  +                    hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, dir);
         1428  +                    if (hPtr != NULL) {
         1429  +                        break;
         1430  +                    }
         1431  +                    zd = (ZipEntry *) Tcl_Alloc(sizeof (*zd));
         1432  +                    zd->name = NULL;
         1433  +                    zd->tnext = NULL;
         1434  +                    zd->depth = CountSlashes(dir);
         1435  +                    zd->zipfile = zf;
         1436  +                    zd->isdir = 1;
         1437  +                    zd->isenc = 0;
         1438  +                    zd->offset = z->offset;
         1439  +                    zd->crc32 = 0;
         1440  +                    zd->timestamp = z->timestamp;
         1441  +                    zd->nbyte = zd->nbytecompr = 0;
         1442  +                    zd->cmeth = ZIP_COMPMETH_STORED;
         1443  +                    zd->data = NULL;
         1444  +                    hPtr = Tcl_CreateHashEntry(&ZipFS.fileHash, dir, &isNew);
         1445  +                    if (!isNew) {
         1446  +                        /* should not happen but skip it anyway */
         1447  +                        Tcl_Free((char *) zd);
         1448  +                    } else {
         1449  +                        Tcl_SetHashValue(hPtr, (ClientData) zd);
         1450  +                        zd->name = Tcl_GetHashKey(&ZipFS.fileHash, hPtr);
         1451  +                        zd->next = zf->entries;
         1452  +                        zf->entries = zd;
         1453  +                        if ((mntpt[0] == '\0') && (zd->depth == 1)) {
         1454  +                            zd->tnext = zf->topents;
         1455  +                            zf->topents = zd;
         1456  +                        }
         1457  +                    }
         1458  +                    end = strrchr(dir, '/');
         1459  +                }
         1460  +            }
         1461  +        }
         1462  +nextent:
         1463  +        q += pathlen + comlen + extra + ZIP_CENTRAL_HEADER_LEN;
         1464  +    }
         1465  +    Tcl_DStringFree(&fpBuf);
         1466  +    Tcl_DStringFree(&ds);
         1467  +    Tcl_FSMountsChanged(NULL);
         1468  +    Unlock();
         1469  +    return TCL_OK;
         1470  +}
         1471  +
         1472  +static void TclZipfs_C_Init(void) {
         1473  +    static const Tcl_Time t = { 0, 0 };
         1474  +    if (!ZipFS.initialized) {
         1475  +#ifdef TCL_THREADS
         1476  +        /*
         1477  +         * Inflate condition variable.
         1478  +         */
         1479  +        Tcl_MutexLock(&ZipFSMutex);
         1480  +        Tcl_ConditionWait(&ZipFSCond, &ZipFSMutex, &t);
         1481  +        Tcl_MutexUnlock(&ZipFSMutex);
         1482  +#endif
         1483  +        Tcl_FSRegister(NULL, &zipfsFilesystem);
         1484  +        Tcl_InitHashTable(&ZipFS.fileHash, TCL_STRING_KEYS);
         1485  +        Tcl_InitHashTable(&ZipFS.zipHash, TCL_STRING_KEYS);
         1486  +        ZipFS.initialized = ZipFS.idCount = 1;
         1487  +    }
         1488  +}
         1489  +
         1490  +
         1491  +/*
         1492  + *-------------------------------------------------------------------------
         1493  + *
         1494  + * TclZipfs_Mount --
         1495  + *
         1496  + *      This procedure is invoked to mount a given ZIP archive file on
         1497  + *    a given mountpoint with optional ZIP password.
         1498  + *
         1499  + * Results:
         1500  + *      A standard Tcl result.
         1501  + *
         1502  + * Side effects:
         1503  + *      A ZIP archive file is read, analyzed and mounted, resources are
         1504  + *    allocated.
         1505  + *
         1506  + *-------------------------------------------------------------------------
         1507  + */
         1508  +
         1509  +int
         1510  +TclZipfs_Mount(
         1511  +    Tcl_Interp *interp,
         1512  +    const char *mntpt,
         1513  +    const char *zipname,
         1514  +    const char *passwd
         1515  +) {
         1516  +    int i, pwlen;
         1517  +    ZipFile *zf;
         1518  +
         1519  +    ReadLock();
         1520  +    if (!ZipFS.initialized) {
         1521  +        TclZipfs_C_Init();
         1522  +    }
         1523  +    if (mntpt == NULL) {
         1524  +        Tcl_HashEntry *hPtr;
         1525  +        Tcl_HashSearch search;
         1526  +        int ret = TCL_OK;
         1527  +        i = 0;
         1528  +        hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search);
         1529  +        while (hPtr != NULL) {
         1530  +            if ((zf = (ZipFile *) Tcl_GetHashValue(hPtr)) != NULL) {
         1531  +                if (interp != NULL) {
         1532  +                    Tcl_AppendElement(interp, zf->mntpt);
         1533  +                    Tcl_AppendElement(interp, zf->name);
         1534  +                }
         1535  +                ++i;
         1536  +            }
         1537  +            hPtr = Tcl_NextHashEntry(&search);
         1538  +        }
         1539  +        if (interp == NULL) {
         1540  +            ret = (i > 0) ? TCL_OK : TCL_BREAK;
         1541  +        }
         1542  +        Unlock();
         1543  +        return ret;
         1544  +    }
         1545  +
         1546  +    if (zipname == NULL) {
         1547  +        Tcl_HashEntry *hPtr;
         1548  +        if (interp == NULL) {
         1549  +            Unlock();
         1550  +            return TCL_OK;
         1551  +        }
         1552  +        hPtr = Tcl_FindHashEntry(&ZipFS.zipHash, mntpt);
         1553  +        if (hPtr != NULL) {
         1554  +            if ((zf = Tcl_GetHashValue(hPtr)) != NULL) {
         1555  +                Tcl_SetObjResult(interp,Tcl_NewStringObj(zf->name, -1));
         1556  +            }
         1557  +        }
         1558  +        Unlock();
         1559  +        return TCL_OK;
         1560  +    }
         1561  +    Unlock();
         1562  +    pwlen = 0;
         1563  +    if (passwd != NULL) {
         1564  +        pwlen = strlen(passwd);
         1565  +        if ((pwlen > 255) || (strchr(passwd, 0xff) != NULL)) {
         1566  +            if (interp) {
         1567  +            Tcl_SetObjResult(interp,
         1568  +                Tcl_NewStringObj("illegal password", -1));
         1569  +            }
         1570  +            return TCL_ERROR;
         1571  +        }
         1572  +    }
         1573  +    zf = (ZipFile *) Tcl_AttemptAlloc(sizeof (*zf) + strlen(mntpt) + 1);
         1574  +    if (zf == NULL) {
         1575  +        if (interp != NULL) {
         1576  +            Tcl_AppendResult(interp, "out of memory", (char *) NULL);
         1577  +        }
         1578  +        return TCL_ERROR;
         1579  +    }
         1580  +    if (ZipFSOpenArchive(interp, zipname, 1, zf) != TCL_OK) {
         1581  +        return TCL_ERROR;
         1582  +    }
         1583  +    return ZipFS_Catalogue_Filesystem(interp,zf,mntpt,passwd,zipname);
         1584  +}
         1585  +
         1586  +/*
         1587  + *-------------------------------------------------------------------------
         1588  + *
         1589  + * TclZipfs_Mount_Buffer --
         1590  + *
         1591  + *      This procedure is invoked to mount a given ZIP archive file on
         1592  + *    a given mountpoint with optional ZIP password.
         1593  + *
         1594  + * Results:
         1595  + *      A standard Tcl result.
         1596  + *
         1597  + * Side effects:
         1598  + *      A ZIP archive file is read, analyzed and mounted, resources are
         1599  + *    allocated.
         1600  + *
         1601  + *-------------------------------------------------------------------------
         1602  + */
         1603  +
         1604  +int
         1605  +TclZipfs_Mount_Buffer(
         1606  +    Tcl_Interp *interp,
         1607  +    const char *mntpt,
         1608  +    unsigned char *data,
         1609  +    size_t datalen,
         1610  +    int copy
         1611  +) {
         1612  +    int i;
         1613  +    ZipFile *zf;
         1614  +
         1615  +    ReadLock();
         1616  +    if (!ZipFS.initialized) {
         1617  +        TclZipfs_C_Init();
         1618  +    }
         1619  +    if (mntpt == NULL) {
         1620  +        Tcl_HashEntry *hPtr;
         1621  +        Tcl_HashSearch search;
         1622  +        int ret = TCL_OK;
         1623  +
         1624  +        i = 0;
         1625  +        hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search);
         1626  +        while (hPtr != NULL) {
         1627  +            if ((zf = (ZipFile *) Tcl_GetHashValue(hPtr)) != NULL) {
         1628  +                if (interp != NULL) {
         1629  +                    Tcl_AppendElement(interp, zf->mntpt);
         1630  +                    Tcl_AppendElement(interp, zf->name);
         1631  +                }
         1632  +                ++i;
         1633  +            }
         1634  +            hPtr = Tcl_NextHashEntry(&search);
         1635  +        }
         1636  +        if (interp == NULL) {
         1637  +            ret = (i > 0) ? TCL_OK : TCL_BREAK;
         1638  +        }
         1639  +        Unlock();
         1640  +        return ret;
         1641  +    }
         1642  +
         1643  +    if (data == NULL) {
         1644  +        Tcl_HashEntry *hPtr;
         1645  +
         1646  +        if (interp == NULL) {
         1647  +            Unlock();
         1648  +            return TCL_OK;
         1649  +        }
         1650  +        hPtr = Tcl_FindHashEntry(&ZipFS.zipHash, mntpt);
         1651  +        if (hPtr != NULL) {
         1652  +            if ((zf = Tcl_GetHashValue(hPtr)) != NULL) {
         1653  +                Tcl_SetObjResult(interp,Tcl_NewStringObj(zf->name, -1));
         1654  +            }
         1655  +        }
         1656  +        Unlock();
         1657  +        return TCL_OK;
         1658  +    }
         1659  +    Unlock();
         1660  +    zf = (ZipFile *) Tcl_AttemptAlloc(sizeof (*zf) + strlen(mntpt) + 1);
         1661  +    if (zf == NULL) {
         1662  +        if (interp != NULL) {
         1663  +            Tcl_AppendResult(interp, "out of memory", (char *) NULL);
         1664  +        }
         1665  +        return TCL_ERROR;
         1666  +    }
         1667  +    zf->is_membuf=1;
         1668  +    zf->length=datalen;
         1669  +    if(copy) {
         1670  +        zf->data=(unsigned char *)Tcl_AttemptAlloc(datalen);
         1671  +        if (zf->data == NULL) {
         1672  +            if (interp != NULL) {
         1673  +                Tcl_AppendResult(interp, "out of memory", (char *) NULL);
         1674  +            }
         1675  +            return TCL_ERROR;
         1676  +        }
         1677  +        memcpy(zf->data,data,datalen);
         1678  +        zf->tofree=zf->data;
         1679  +    } else {
         1680  +        zf->data=data;
         1681  +        zf->tofree=NULL;
         1682  +    }
         1683  +    if(ZipFS_Find_TOC(interp,0,zf)!=TCL_OK) {
         1684  +        return TCL_ERROR;
         1685  +    }
         1686  +    return ZipFS_Catalogue_Filesystem(interp,zf,mntpt,NULL,"Memory Buffer");
         1687  +}
         1688  +
         1689  +/*
         1690  + *-------------------------------------------------------------------------
         1691  + *
         1692  + * TclZipfs_Unmount --
         1693  + *
         1694  + *      This procedure is invoked to unmount a given ZIP archive.
         1695  + *
         1696  + * Results:
         1697  + *      A standard Tcl result.
         1698  + *
         1699  + * Side effects:
         1700  + *      A mounted ZIP archive file is unmounted, resources are free'd.
         1701  + *
         1702  + *-------------------------------------------------------------------------
         1703  + */
         1704  +
         1705  +int
         1706  +TclZipfs_Unmount(Tcl_Interp *interp, const char *mntpt)
         1707  +{
         1708  +    ZipFile *zf;
         1709  +    ZipEntry *z, *znext;
         1710  +    Tcl_HashEntry *hPtr;
         1711  +    Tcl_DString dsm;
         1712  +    int ret = TCL_OK, unmounted = 0;
         1713  +
         1714  +    WriteLock();
         1715  +    if (!ZipFS.initialized) goto done;
         1716  +    /*
         1717  +     * Mount point sometimes is a relative or otherwise denormalized path.
         1718  +     * But an absolute name is needed as mount point here.
         1719  +     */
         1720  +    Tcl_DStringInit(&dsm);
         1721  +    mntpt = CanonicalPath("", mntpt, &dsm, 1);
         1722  +
         1723  +    hPtr = Tcl_FindHashEntry(&ZipFS.zipHash, mntpt);
         1724  +
         1725  +    /* don't report error */
         1726  +    if (hPtr == NULL) goto done;
         1727  +
         1728  +    zf = (ZipFile *) Tcl_GetHashValue(hPtr);
         1729  +    if (zf->nopen > 0) {
         1730  +        ZIPFS_ERROR(interp,"filesystem is busy");
         1731  +        ret = TCL_ERROR;
         1732  +        goto done;
         1733  +    }
         1734  +    Tcl_DeleteHashEntry(hPtr);
         1735  +    for (z = zf->entries; z; z = znext) {
         1736  +        znext = z->next;
         1737  +        hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, z->name);
         1738  +        if (hPtr) {
         1739  +            Tcl_DeleteHashEntry(hPtr);
         1740  +        }
         1741  +        if (z->data != NULL) {
         1742  +            Tcl_Free((char *) z->data);
         1743  +        }
         1744  +        Tcl_Free((char *) z);
         1745  +    }
         1746  +    ZipFSCloseArchive(interp, zf);
         1747  +    Tcl_Free((char *) zf);
         1748  +    unmounted = 1;
         1749  +done:
         1750  +    Unlock();
         1751  +    if (unmounted) {
         1752  +        Tcl_FSMountsChanged(NULL);
         1753  +    }
         1754  +    return ret;
         1755  +}
         1756  +
         1757  +/*
         1758  + *-------------------------------------------------------------------------
         1759  + *
         1760  + * ZipFSMountObjCmd --
         1761  + *
         1762  + *      This procedure is invoked to process the "zipfs::mount" command.
         1763  + *
         1764  + * Results:
         1765  + *      A standard Tcl result.
         1766  + *
         1767  + * Side effects:
         1768  + *      A ZIP archive file is mounted, resources are allocated.
         1769  + *
         1770  + *-------------------------------------------------------------------------
         1771  + */
         1772  +
         1773  +static int
         1774  +ZipFSMountObjCmd(
         1775  +    ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]
         1776  +) {
         1777  +    if (objc > 4) {
         1778  +        Tcl_WrongNumArgs(interp, 1, objv,
         1779  +                 "?mountpoint? ?zipfile? ?password?");
         1780  +        return TCL_ERROR;
         1781  +    }
         1782  +    return TclZipfs_Mount(interp, (objc > 1) ? Tcl_GetString(objv[1]) : NULL,
         1783  +               (objc > 2) ? Tcl_GetString(objv[2]) : NULL,
         1784  +               (objc > 3) ? Tcl_GetString(objv[3]) : NULL);
         1785  +}
         1786  +
         1787  +/*
         1788  + *-------------------------------------------------------------------------
         1789  + *
         1790  + * ZipFSMountObjCmd --
         1791  + *
         1792  + *      This procedure is invoked to process the "zipfs::mount" command.
         1793  + *
         1794  + * Results:
         1795  + *      A standard Tcl result.
         1796  + *
         1797  + * Side effects:
         1798  + *      A ZIP archive file is mounted, resources are allocated.
         1799  + *
         1800  + *-------------------------------------------------------------------------
         1801  + */
         1802  +
         1803  +static int
         1804  +ZipFSMountBufferObjCmd(
         1805  +    ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]
         1806  +) {
         1807  +    const char *mntpt;
         1808  +    unsigned char *data;
         1809  +    int length;
         1810  +    if (objc > 4) {
         1811  +        Tcl_WrongNumArgs(interp, 1, objv, "?mountpoint? ?data?");
         1812  +        return TCL_ERROR;
         1813  +    }
         1814  +    if(objc<2) {
         1815  +        int i;
         1816  +        Tcl_HashEntry *hPtr;
         1817  +        Tcl_HashSearch search;
         1818  +        int ret = TCL_OK;
         1819  +        ZipFile *zf;
         1820  +
         1821  +        ReadLock();
         1822  +        i = 0;
         1823  +        hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search);
         1824  +        while (hPtr != NULL) {
         1825  +            if ((zf = (ZipFile *) Tcl_GetHashValue(hPtr)) != NULL) {
         1826  +                if (interp != NULL) {
         1827  +                    Tcl_AppendElement(interp, zf->mntpt);
         1828  +                    Tcl_AppendElement(interp, zf->name);
         1829  +                }
         1830  +                ++i;
         1831  +            }
         1832  +            hPtr = Tcl_NextHashEntry(&search);
         1833  +        }
         1834  +        if (interp == NULL) {
         1835  +            ret = (i > 0) ? TCL_OK : TCL_BREAK;
         1836  +        }
         1837  +        Unlock();
         1838  +        return ret;
         1839  +    }
         1840  +    mntpt=Tcl_GetString(objv[1]);
         1841  +    if(objc<3) {
         1842  +        Tcl_HashEntry *hPtr;
         1843  +        ZipFile *zf;
         1844  +
         1845  +        if (interp == NULL) {
         1846  +            Unlock();
         1847  +            return TCL_OK;
         1848  +        }
         1849  +        hPtr = Tcl_FindHashEntry(&ZipFS.zipHash, mntpt);
         1850  +        if (hPtr != NULL) {
         1851  +            if ((zf = Tcl_GetHashValue(hPtr)) != NULL) {
         1852  +                Tcl_SetObjResult(interp,Tcl_NewStringObj(zf->name, -1));
         1853  +            }
         1854  +        }
         1855  +        Unlock();
         1856  +        return TCL_OK;
         1857  +    }
         1858  +    data=Tcl_GetByteArrayFromObj(objv[2],&length);
         1859  +    return TclZipfs_Mount_Buffer(interp, mntpt,data,length,1);
         1860  +}
         1861  +
         1862  +/*
         1863  + *-------------------------------------------------------------------------
         1864  + *
         1865  + * ZipFSRootObjCmd --
         1866  + *
         1867  + *      This procedure is invoked to process the "zipfs::root" command. It
         1868  + *      returns the root that all zipfs file systems are mounted under.
         1869  + *
         1870  + * Results:
         1871  + *      A standard Tcl result.
         1872  + *
         1873  + * Side effects:
         1874  + *
         1875  + *-------------------------------------------------------------------------
         1876  + */
         1877  +
         1878  +static int
         1879  +ZipFSRootObjCmd(
         1880  +    ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]
         1881  +) {
         1882  +    Tcl_SetObjResult(interp,Tcl_NewStringObj(ZIPFS_VOLUME, -1));
         1883  +    return TCL_OK;
         1884  +}
         1885  +
         1886  +/*
         1887  + *-------------------------------------------------------------------------
         1888  + *
         1889  + * ZipFSUnmountObjCmd --
         1890  + *
         1891  + *      This procedure is invoked to process the "zipfs::unmount" command.
         1892  + *
         1893  + * Results:
         1894  + *      A standard Tcl result.
         1895  + *
         1896  + * Side effects:
         1897  + *      A mounted ZIP archive file is unmounted, resources are free'd.
         1898  + *
         1899  + *-------------------------------------------------------------------------
         1900  + */
         1901  +
         1902  +static int
         1903  +ZipFSUnmountObjCmd(
         1904  +    ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]
         1905  +) {
         1906  +    if (objc != 2) {
         1907  +        Tcl_WrongNumArgs(interp, 1, objv, "zipfile");
         1908  +        return TCL_ERROR;
         1909  +    }
         1910  +    return TclZipfs_Unmount(interp, Tcl_GetString(objv[1]));
         1911  +}
         1912  +
         1913  +/*
         1914  + *-------------------------------------------------------------------------
         1915  + *
         1916  + * ZipFSMkKeyObjCmd --
         1917  + *
         1918  + *      This procedure is invoked to process the "zipfs::mkkey" command.
         1919  + *    It produces a rotated password to be embedded into an image file.
         1920  + *
         1921  + * Results:
         1922  + *      A standard Tcl result.
         1923  + *
         1924  + * Side effects:
         1925  + *      None.
         1926  + *
         1927  + *-------------------------------------------------------------------------
         1928  + */
         1929  +
         1930  +static int
         1931  +ZipFSMkKeyObjCmd(
         1932  +    ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]
         1933  +) {
         1934  +    int len, i = 0;
         1935  +    char *pw, pwbuf[264];
         1936  +
         1937  +    if (objc != 2) {
         1938  +    Tcl_WrongNumArgs(interp, 1, objv, "password");
         1939  +        return TCL_ERROR;
         1940  +    }
         1941  +    pw = Tcl_GetString(objv[1]);
         1942  +    len = strlen(pw);
         1943  +    if (len == 0) {
         1944  +        return TCL_OK;
         1945  +    }
         1946  +    if ((len > 255) || (strchr(pw, 0xff) != NULL)) {
         1947  +        Tcl_SetObjResult(interp, Tcl_NewStringObj("illegal password", -1));
         1948  +        return TCL_ERROR;
         1949  +    }
         1950  +    while (len > 0) {
         1951  +        int ch = pw[len - 1];
         1952  +
         1953  +        pwbuf[i] = (ch & 0x0f) | pwrot[(ch >> 4) & 0x0f];
         1954  +        i++;
         1955  +        len--;
         1956  +    }
         1957  +    pwbuf[i] = i;
         1958  +    ++i;
         1959  +    pwbuf[i++] = (char) ZIP_PASSWORD_END_SIG;
         1960  +    pwbuf[i++] = (char) (ZIP_PASSWORD_END_SIG >> 8);
         1961  +    pwbuf[i++] = (char) (ZIP_PASSWORD_END_SIG >> 16);
         1962  +    pwbuf[i++] = (char) (ZIP_PASSWORD_END_SIG >> 24);
         1963  +    pwbuf[i] = '\0';
         1964  +    Tcl_AppendResult(interp, pwbuf, (char *) NULL);
         1965  +    return TCL_OK;
         1966  +}
         1967  +
         1968  +/*
         1969  + *-------------------------------------------------------------------------
         1970  + *
         1971  + * ZipAddFile --
         1972  + *
         1973  + *      This procedure is used by ZipFSMkZipOrImgCmd() to add a single
         1974  + *    file to the output ZIP archive file being written. A ZipEntry
         1975  + *    struct about the input file is added to the given fileHash table
         1976  + *    for later creation of the central ZIP directory.
         1977  + *
         1978  + * Results:
         1979  + *      A standard Tcl result.
         1980  + *
         1981  + * Side effects:
         1982  + *    Input file is read and (compressed and) written to the output
         1983  + *    ZIP archive file.
         1984  + *
         1985  + *-------------------------------------------------------------------------
         1986  + */
         1987  +
         1988  +static int
         1989  +ZipAddFile(
         1990  +    Tcl_Interp *interp, const char *path, const char *name,
         1991  +    Tcl_Channel out, const char *passwd,
         1992  +    char *buf, int bufsize, Tcl_HashTable *fileHash
         1993  +) {
         1994  +    Tcl_Channel in;
         1995  +    Tcl_HashEntry *hPtr;
         1996  +    ZipEntry *z;
         1997  +    z_stream stream;
         1998  +    const char *zpath;
         1999  +    int nbyte, nbytecompr, len, crc, flush, pos[3], zpathlen, olen;
         2000  +    int mtime = 0, isNew, align = 0, cmeth;
         2001  +    unsigned long keys[3], keys0[3];
         2002  +    char obuf[4096];
         2003  +
         2004  +    zpath = name;
         2005  +    while (zpath != NULL && zpath[0] == '/') {
         2006  +        zpath++;
         2007  +    }
         2008  +    if ((zpath == NULL) || (zpath[0] == '\0')) {
         2009  +        return TCL_OK;
         2010  +    }
         2011  +    zpathlen = strlen(zpath);
         2012  +    if (zpathlen + ZIP_CENTRAL_HEADER_LEN > bufsize) {
         2013  +        Tcl_AppendResult(interp, "path too long for \"", path, "\"", (char *) NULL);
         2014  +        return TCL_ERROR;
         2015  +    }
         2016  +    in = Tcl_OpenFileChannel(interp, path, "r", 0);
         2017  +    if (
         2018  +        (in == NULL)
         2019  +        || (Tcl_SetChannelOption(interp, in, "-translation", "binary") != TCL_OK)
         2020  +        || (Tcl_SetChannelOption(interp, in, "-encoding", "binary") != TCL_OK)
         2021  +    ) {
         2022  +#if defined(_WIN32) || defined(_WIN64)
         2023  +         /* hopefully a directory */
         2024  +         if (strcmp("permission denied", Tcl_PosixError(interp)) == 0) {
         2025  +            Tcl_Close(interp, in);
         2026  +            return TCL_OK;
         2027  +        }
         2028  +#endif
         2029  +        Tcl_Close(interp, in);
         2030  +        return TCL_ERROR;
         2031  +    } else {
         2032  +        Tcl_Obj *pathObj = Tcl_NewStringObj(path, -1);
         2033  +        Tcl_StatBuf statBuf;
         2034  +
         2035  +        Tcl_IncrRefCount(pathObj);
         2036  +        if (Tcl_FSStat(pathObj, &statBuf) != -1) {
         2037  +            mtime = statBuf.st_mtime;
         2038  +        }
         2039  +        Tcl_DecrRefCount(pathObj);
         2040  +    }
         2041  +    Tcl_ResetResult(interp);
         2042  +    crc = 0;
         2043  +    nbyte = nbytecompr = 0;
         2044  +    while ((len = Tcl_Read(in, buf, bufsize)) > 0) {
         2045  +        crc = crc32(crc, (unsigned char *) buf, len);
         2046  +        nbyte += len;
         2047  +    }
         2048  +    if (len == -1) {
         2049  +        if (nbyte == 0) {
         2050  +            if (strcmp("illegal operation on a directory",
         2051  +                   Tcl_PosixError(interp)) == 0) {
         2052  +            Tcl_Close(interp, in);
         2053  +            return TCL_OK;
         2054  +            }
         2055  +        }
         2056  +        Tcl_AppendResult(interp, "read error on \"", path, "\"",
         2057  +                 (char *) NULL);
         2058  +        Tcl_Close(interp, in);
         2059  +        return TCL_ERROR;
         2060  +    }
         2061  +    if (Tcl_Seek(in, 0, SEEK_SET) == -1) {
         2062  +        Tcl_AppendResult(interp, "seek error on \"", path, "\"",
         2063  +                 (char *) NULL);
         2064  +        Tcl_Close(interp, in);
         2065  +        return TCL_ERROR;
         2066  +    }
         2067  +    pos[0] = Tcl_Tell(out);
         2068  +    memset(buf, '\0', ZIP_LOCAL_HEADER_LEN);
         2069  +    memcpy(buf + ZIP_LOCAL_HEADER_LEN, zpath, zpathlen);
         2070  +    len = zpathlen + ZIP_LOCAL_HEADER_LEN;
         2071  +    if (Tcl_Write(out, buf, len) != len) {
         2072  +wrerr:
         2073  +    Tcl_AppendResult(interp, "write error", (char *) NULL);
         2074  +    Tcl_Close(interp, in);
         2075  +    return TCL_ERROR;
         2076  +    }
         2077  +    if ((len + pos[0]) & 3) {
         2078  +        unsigned char abuf[8];
         2079  +
         2080  +        /*
         2081  +         * Align payload to next 4-byte boundary using a dummy extra
         2082  +         * entry similar to the zipalign tool from Android's SDK.
         2083  +         */
         2084  +        align = 4 + ((len + pos[0]) & 3);
         2085  +        zip_write_short(abuf, 0xffff);
         2086  +        zip_write_short(abuf + 2, align - 4);
         2087  +        zip_write_int(abuf + 4, 0x03020100);
         2088  +        if (Tcl_Write(out, (const char *)abuf, align) != align) {
         2089  +            goto wrerr;
         2090  +        }
         2091  +    }
         2092  +    if (passwd != NULL) {
         2093  +        int i, ch, tmp;
         2094  +        unsigned char kvbuf[24];
         2095  +        Tcl_Obj *ret;
         2096  +
         2097  +        init_keys(passwd, keys, crc32tab);
         2098  +        for (i = 0; i < 12 - 2; i++) {
         2099  +            if (Tcl_EvalEx(interp, "expr int(rand() * 256) % 256", -1, 0) != TCL_OK) {
         2100  +                Tcl_AppendResult(interp, "PRNG error", (char *) NULL);
         2101  +                Tcl_Close(interp, in);
         2102  +                return TCL_ERROR;
         2103  +            }
         2104  +            ret = Tcl_GetObjResult(interp);
         2105  +            if (Tcl_GetIntFromObj(interp, ret, &ch) != TCL_OK) {
         2106  +                Tcl_Close(interp, in);
         2107  +                return TCL_ERROR;
         2108  +            }
         2109  +            kvbuf[i + 12] = (unsigned char) zencode(keys, crc32tab, ch, tmp);
         2110  +        }
         2111  +        Tcl_ResetResult(interp);
         2112  +        init_keys(passwd, keys, crc32tab);
         2113  +        for (i = 0; i < 12 - 2; i++) {
         2114  +            kvbuf[i] = (unsigned char) zencode(keys, crc32tab, kvbuf[i + 12], tmp);
         2115  +        }
         2116  +        kvbuf[i++] = (unsigned char) zencode(keys, crc32tab, crc >> 16, tmp);
         2117  +        kvbuf[i++] = (unsigned char) zencode(keys, crc32tab, crc >> 24, tmp);
         2118  +        len = Tcl_Write(out, (char *) kvbuf, 12);
         2119  +        memset(kvbuf, 0, 24);
         2120  +        if (len != 12) {
         2121  +            Tcl_AppendResult(interp, "write error", (char *) NULL);
         2122  +            Tcl_Close(interp, in);
         2123  +            return TCL_ERROR;
         2124  +        }
         2125  +        memcpy(keys0, keys, sizeof (keys0));
         2126  +        nbytecompr += 12;
         2127  +    }
         2128  +    Tcl_Flush(out);
         2129  +    pos[2] = Tcl_Tell(out);
         2130  +    cmeth = ZIP_COMPMETH_DEFLATED;
         2131  +    memset(&stream, 0, sizeof (stream));
         2132  +    stream.zalloc = Z_NULL;
         2133  +    stream.zfree = Z_NULL;
         2134  +    stream.opaque = Z_NULL;
         2135  +    if (deflateInit2(&stream, 9, Z_DEFLATED, -15, 8, Z_DEFAULT_STRATEGY) != Z_OK) {
         2136  +        Tcl_AppendResult(interp, "compression init error on \"", path, "\"",
         2137  +                 (char *) NULL);
         2138  +        Tcl_Close(interp, in);
         2139  +        return TCL_ERROR;
         2140  +    }
         2141  +    do {
         2142  +    len = Tcl_Read(in, buf, bufsize);
         2143  +    if (len == -1) {
         2144  +        Tcl_AppendResult(interp, "read error on \"", path, "\"",
         2145  +                 (char *) NULL);
         2146  +        deflateEnd(&stream);
         2147  +        Tcl_Close(interp, in);
         2148  +        return TCL_ERROR;
         2149  +    }
         2150  +    stream.avail_in = len;
         2151  +    stream.next_in = (unsigned char *) buf;
         2152  +    flush = Tcl_Eof(in) ? Z_FINISH : Z_NO_FLUSH;
         2153  +    do {
         2154  +        stream.avail_out = sizeof (obuf);
         2155  +        stream.next_out = (unsigned char *) obuf;
         2156  +        len = deflate(&stream, flush);
         2157  +        if (len == Z_STREAM_ERROR) {
         2158  +            Tcl_AppendResult(interp, "deflate error on \"", path, "\"",
         2159  +                     (char *) NULL);
         2160  +            deflateEnd(&stream);
         2161  +            Tcl_Close(interp, in);
         2162  +            return TCL_ERROR;
         2163  +        }
         2164  +        olen = sizeof (obuf) - stream.avail_out;
         2165  +        if (passwd != NULL) {
         2166  +            int i, tmp;
         2167  +
         2168  +            for (i = 0; i < olen; i++) {
         2169  +                obuf[i] = (char) zencode(keys, crc32tab, obuf[i], tmp);
         2170  +            }
         2171  +        }
         2172  +        if (olen && (Tcl_Write(out, obuf, olen) != olen)) {
         2173  +            Tcl_AppendResult(interp, "write error", (char *) NULL);
         2174  +            deflateEnd(&stream);
         2175  +            Tcl_Close(interp, in);
         2176  +            return TCL_ERROR;
         2177  +        }
         2178  +        nbytecompr += olen;
         2179  +    } while (stream.avail_out == 0);
         2180  +    } while (flush != Z_FINISH);
         2181  +    deflateEnd(&stream);
         2182  +    Tcl_Flush(out);
         2183  +    pos[1] = Tcl_Tell(out);
         2184  +    if (nbyte - nbytecompr <= 0) {
         2185  +        /*
         2186  +         * Compressed file larger than input,
         2187  +         * write it again uncompressed.
         2188  +         */
         2189  +        if ((int) Tcl_Seek(in, 0, SEEK_SET) != 0) {
         2190  +            goto seekErr;
         2191  +        }
         2192  +        if ((int) Tcl_Seek(out, pos[2], SEEK_SET) != pos[2]) {
         2193  +seekErr:
         2194  +            Tcl_Close(interp, in);
         2195  +            Tcl_AppendResult(interp, "seek error", (char *) NULL);
         2196  +            return TCL_ERROR;
         2197  +        }
         2198  +        nbytecompr = (passwd != NULL) ? 12 : 0;
         2199  +        while (1) {
         2200  +            len = Tcl_Read(in, buf, bufsize);
         2201  +            if (len == -1) {
         2202  +            Tcl_AppendResult(interp, "read error on \"", path, "\"",
         2203  +                     (char *) NULL);
         2204  +            Tcl_Close(interp, in);
         2205  +            return TCL_ERROR;
         2206  +            } else if (len == 0) {
         2207  +            break;
         2208  +            }
         2209  +            if (passwd != NULL) {
         2210  +            int i, tmp;
         2211  +
         2212  +            for (i = 0; i < len; i++) {
         2213  +                buf[i] = (char) zencode(keys0, crc32tab, buf[i], tmp);
         2214  +            }
         2215  +            }
         2216  +            if (Tcl_Write(out, buf, len) != len) {
         2217  +            Tcl_AppendResult(interp, "write error", (char *) NULL);
         2218  +            Tcl_Close(interp, in);
         2219  +            return TCL_ERROR;
         2220  +            }
         2221  +            nbytecompr += len;
         2222  +        }
         2223  +        cmeth = ZIP_COMPMETH_STORED;
         2224  +        Tcl_Flush(out);
         2225  +        pos[1] = Tcl_Tell(out);
         2226  +        Tcl_TruncateChannel(out, pos[1]);
         2227  +    }
         2228  +    Tcl_Close(interp, in);
         2229  +
         2230  +    z = (ZipEntry *) Tcl_Alloc(sizeof (*z));
         2231  +    z->name = NULL;
         2232  +    z->tnext = NULL;
         2233  +    z->depth = 0;
         2234  +    z->zipfile = NULL;
         2235  +    z->isdir = 0;
         2236  +    z->isenc = (passwd != NULL) ? 1 : 0;
         2237  +    z->offset = pos[0];
         2238  +    z->crc32 = crc;
         2239  +    z->timestamp = mtime;
         2240  +    z->nbyte = nbyte;
         2241  +    z->nbytecompr = nbytecompr;
         2242  +    z->cmeth = cmeth;
         2243  +    z->data = NULL;
         2244  +    hPtr = Tcl_CreateHashEntry(fileHash, zpath, &isNew);
         2245  +    if (!isNew) {
         2246  +        Tcl_AppendResult(interp, "non-unique path name \"", path, "\"",
         2247  +                 (char *) NULL);
         2248  +        Tcl_Free((char *) z);
         2249  +        return TCL_ERROR;
         2250  +    } else {
         2251  +        Tcl_SetHashValue(hPtr, (ClientData) z);
         2252  +        z->name = Tcl_GetHashKey(fileHash, hPtr);
         2253  +        z->next = NULL;
         2254  +    }
         2255  +
         2256  +    /*
         2257  +     * Write final local header information.
         2258  +     */
         2259  +    zip_write_int(buf + ZIP_LOCAL_SIG_OFFS, ZIP_LOCAL_HEADER_SIG);
         2260  +    zip_write_short(buf + ZIP_LOCAL_VERSION_OFFS, ZIP_MIN_VERSION);
         2261  +    zip_write_short(buf + ZIP_LOCAL_FLAGS_OFFS, z->isenc);
         2262  +    zip_write_short(buf + ZIP_LOCAL_COMPMETH_OFFS, z->cmeth);
         2263  +    zip_write_short(buf + ZIP_LOCAL_MTIME_OFFS, ToDosTime(z->timestamp));
         2264  +    zip_write_short(buf + ZIP_LOCAL_MDATE_OFFS, ToDosDate(z->timestamp));
         2265  +    zip_write_int(buf + ZIP_LOCAL_CRC32_OFFS, z->crc32);
         2266  +    zip_write_int(buf + ZIP_LOCAL_COMPLEN_OFFS, z->nbytecompr);
         2267  +    zip_write_int(buf + ZIP_LOCAL_UNCOMPLEN_OFFS, z->nbyte);
         2268  +    zip_write_short(buf + ZIP_LOCAL_PATHLEN_OFFS, zpathlen);
         2269  +    zip_write_short(buf + ZIP_LOCAL_EXTRALEN_OFFS, align);
         2270  +    if ((int) Tcl_Seek(out, pos[0], SEEK_SET) != pos[0]) {
         2271  +        Tcl_DeleteHashEntry(hPtr);
         2272  +        Tcl_Free((char *) z);
         2273  +        Tcl_AppendResult(interp, "seek error", (char *) NULL);
         2274  +        return TCL_ERROR;
         2275  +    }
         2276  +    if (Tcl_Write(out, buf, ZIP_LOCAL_HEADER_LEN) != ZIP_LOCAL_HEADER_LEN) {
         2277  +        Tcl_DeleteHashEntry(hPtr);
         2278  +        Tcl_Free((char *) z);
         2279  +        Tcl_AppendResult(interp, "write error", (char *) NULL);
         2280  +        return TCL_ERROR;
         2281  +    }
         2282  +    Tcl_Flush(out);
         2283  +    if ((int) Tcl_Seek(out, pos[1], SEEK_SET) != pos[1]) {
         2284  +        Tcl_DeleteHashEntry(hPtr);
         2285  +        Tcl_Free((char *) z);
         2286  +        Tcl_AppendResult(interp, "seek error", (char *) NULL);
         2287  +        return TCL_ERROR;
         2288  +    }
         2289  +    return TCL_OK;
         2290  +}
         2291  +
         2292  +/*
         2293  + *-------------------------------------------------------------------------
         2294  + *
         2295  + * ZipFSMkZipOrImgObjCmd --
         2296  + *
         2297  + *      This procedure is creates a new ZIP archive file or image file
         2298  + *        given output filename, input directory of files to be archived,
         2299  + *        optional password, and optional image to be prepended to the
         2300  + *        output ZIP archive file.
         2301  + *
         2302  + * Results:
         2303  + *      A standard Tcl result.
         2304  + *
         2305  + * Side effects:
         2306  + *        A new ZIP archive file or image file is written.
         2307  + *
         2308  + *-------------------------------------------------------------------------
         2309  + */
         2310  +
         2311  +static int
         2312  +ZipFSMkZipOrImgObjCmd(ClientData clientData, Tcl_Interp *interp,
         2313  +                      int isImg, int isList, int objc, Tcl_Obj *const objv[])
         2314  +{
         2315  +    Tcl_Channel out;
         2316  +    int len = 0, pwlen = 0, slen = 0, i, count, ret = TCL_ERROR, lobjc, pos[3];
         2317  +    Tcl_Obj **lobjv, *list = NULL;
         2318  +    ZipEntry *z;
         2319  +    Tcl_HashEntry *hPtr;
         2320  +    Tcl_HashSearch search;
         2321  +    Tcl_HashTable fileHash;
         2322  +    char *strip = NULL, *pw = NULL, pwbuf[264], buf[4096];
         2323  +
         2324  +    if (isList) {
         2325  +        if ((objc < 3) || (objc > (isImg ? 5 : 4))) {
         2326  +            Tcl_WrongNumArgs(interp, 1, objv, isImg ?
         2327  +                             "outfile inlist ?password infile?" :
         2328  +                             "outfile inlist ?password?");
         2329  +            return TCL_ERROR;
         2330  +        }
         2331  +    } else {
         2332  +        if ((objc < 3) || (objc > (isImg ? 6 : 5))) {
         2333  +            Tcl_WrongNumArgs(interp, 1, objv, isImg ?
         2334  +                             "outfile indir ?strip? ?password? ?infile?" :
         2335  +                             "outfile indir ?strip? ?password?");
         2336  +            return TCL_ERROR;
         2337  +        }
         2338  +    }
         2339  +    pwbuf[0] = 0;
         2340  +    if (objc > (isList ? 3 : 4)) {
         2341  +        pw = Tcl_GetString(objv[isList ? 3 : 4]);
         2342  +        pwlen = strlen(pw);
         2343  +        if ((pwlen > 255) || (strchr(pw, 0xff) != NULL)) {
         2344  +            Tcl_SetObjResult(interp,
         2345  +                             Tcl_NewStringObj("illegal password", -1));
         2346  +            return TCL_ERROR;
         2347  +        }
         2348  +    }
         2349  +    if (isList) {
         2350  +        list = objv[2];
         2351  +        Tcl_IncrRefCount(list);
         2352  +    } else {
         2353  +        Tcl_Obj *cmd[3];
         2354  +
         2355  +        cmd[1] = Tcl_NewStringObj("::tcl::zipfs::find", -1);
         2356  +        cmd[2] = objv[2];
         2357  +        cmd[0] = Tcl_NewListObj(2, cmd + 1);
         2358  +        Tcl_IncrRefCount(cmd[0]);
         2359  +        if (Tcl_EvalObjEx(interp, cmd[0], TCL_EVAL_DIRECT) != TCL_OK) {
         2360  +            Tcl_DecrRefCount(cmd[0]);
         2361  +            return TCL_ERROR;
         2362  +        }
         2363  +        Tcl_DecrRefCount(cmd[0]);
         2364  +        list = Tcl_GetObjResult(interp);
         2365  +        Tcl_IncrRefCount(list);
         2366  +    }
         2367  +    if (Tcl_ListObjGetElements(interp, list, &lobjc, &lobjv) != TCL_OK) {
         2368  +        Tcl_DecrRefCount(list);
         2369  +        return TCL_ERROR;
         2370  +    }
         2371  +    if (isList && (lobjc % 2)) {
         2372  +        Tcl_DecrRefCount(list);
         2373  +        Tcl_SetObjResult(interp,
         2374  +                Tcl_NewStringObj("need even number of elements", -1));
         2375  +        return TCL_ERROR;
         2376  +    }
         2377  +    if (lobjc == 0) {
         2378  +        Tcl_DecrRefCount(list);
         2379  +        Tcl_SetObjResult(interp, Tcl_NewStringObj("empty archive", -1));
         2380  +        return TCL_ERROR;
         2381  +    }
         2382  +    out = Tcl_OpenFileChannel(interp, Tcl_GetString(objv[1]), "w", 0755);
         2383  +    if (
         2384  +        (out == NULL)
         2385  +        || (Tcl_SetChannelOption(interp, out, "-translation", "binary") != TCL_OK)
         2386  +        || (Tcl_SetChannelOption(interp, out, "-encoding", "binary") != TCL_OK)
         2387  +    ) {
         2388  +        Tcl_DecrRefCount(list);
         2389  +        Tcl_Close(interp, out);
         2390  +        return TCL_ERROR;
         2391  +    }
         2392  +    if (pwlen <= 0) {
         2393  +        pw = NULL;
         2394  +        pwlen = 0;
         2395  +    }
         2396  +    if (isImg) {
         2397  +        ZipFile *zf, zf0;
         2398  +        int isMounted = 0;
         2399  +        const char *imgName;
         2400  +
         2401  +        if (isList) {
         2402  +            imgName = (objc > 4) ? Tcl_GetString(objv[4]) : Tcl_GetNameOfExecutable();
         2403  +        } else {
         2404  +            imgName = (objc > 5) ? Tcl_GetString(objv[5]) : Tcl_GetNameOfExecutable();
         2405  +        }
         2406  +        if (pwlen) {
         2407  +            i = 0;
         2408  +            len = pwlen;
         2409  +            while (len > 0) {
         2410  +                int ch = pw[len - 1];
         2411  +
         2412  +                pwbuf[i] = (ch & 0x0f) | pwrot[(ch >> 4) & 0x0f];
         2413  +                i++;
         2414  +                len--;
         2415  +            }
         2416  +            pwbuf[i] = i;
         2417  +            ++i;
         2418  +            pwbuf[i++] = (char) ZIP_PASSWORD_END_SIG;
         2419  +            pwbuf[i++] = (char) (ZIP_PASSWORD_END_SIG >> 8);
         2420  +            pwbuf[i++] = (char) (ZIP_PASSWORD_END_SIG >> 16);
         2421  +            pwbuf[i++] = (char) (ZIP_PASSWORD_END_SIG >> 24);
         2422  +            pwbuf[i] = '\0';
         2423  +        }
         2424  +        /* Check for mounted image */
         2425  +        WriteLock();
         2426  +        hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search);
         2427  +        while (hPtr != NULL) {
         2428  +            if ((zf = (ZipFile *) Tcl_GetHashValue(hPtr)) != NULL) {
         2429  +                if (strcmp(zf->name, imgName) == 0) {
         2430  +                    isMounted = 1;
         2431  +                    zf->nopen++;
         2432  +                    break;
         2433  +                }
         2434  +            }
         2435  +            hPtr = Tcl_NextHashEntry(&search);
         2436  +        }
         2437  +        Unlock();
         2438  +        if (!isMounted) {
         2439  +            zf = &zf0;
         2440  +        }
         2441  +        if (isMounted ||
         2442  +            (ZipFSOpenArchive(interp, imgName, 0, zf) == TCL_OK)) {
         2443  +            i = Tcl_Write(out, (char *) zf->data, zf->baseoffsp);
         2444  +            if (i != zf->baseoffsp) {
         2445  +                memset(pwbuf, 0, sizeof (pwbuf));
         2446  +                Tcl_DecrRefCount(list);
         2447  +                Tcl_SetObjResult(interp, Tcl_NewStringObj("write error", -1));
         2448  +                Tcl_Close(interp, out);
         2449  +                if (zf == &zf0) {
         2450  +                    ZipFSCloseArchive(interp, zf);
         2451  +                } else {
         2452  +                    WriteLock();
         2453  +                    zf->nopen--;
         2454  +                    Unlock();
         2455  +                }
         2456  +                return TCL_ERROR;
         2457  +            }
         2458  +            if (zf == &zf0) {
         2459  +                ZipFSCloseArchive(interp, zf);
         2460  +            } else {
         2461  +                WriteLock();
         2462  +                zf->nopen--;
         2463  +                Unlock();
         2464  +            }
         2465  +        } else {
         2466  +            int k, n, m;
         2467  +            Tcl_Channel in;
         2468  +            const char *errMsg = "seek error";
         2469  +
         2470  +            /*
         2471  +             * Fall back to read it as plain file which
         2472  +             * hopefully is a static tclsh or wish binary
         2473  +             * with proper zipfs infrastructure built in.
         2474  +             */
         2475  +            Tcl_ResetResult(interp);
         2476  +            in = Tcl_OpenFileChannel(interp, imgName, "r", 0644);
         2477  +            if (in == NULL) {
         2478  +                memset(pwbuf, 0, sizeof (pwbuf));
         2479  +                Tcl_DecrRefCount(list);
         2480  +                Tcl_Close(interp, out);
         2481  +                return TCL_ERROR;
         2482  +            }
         2483  +            Tcl_SetChannelOption(interp, in, "-translation", "binary");
         2484  +            Tcl_SetChannelOption(interp, in, "-encoding", "binary");
         2485  +            i = Tcl_Seek(in, 0, SEEK_END);
         2486  +            if (i == -1) {
         2487  +cperr:
         2488  +                memset(pwbuf, 0, sizeof (pwbuf));
         2489  +                Tcl_DecrRefCount(list);
         2490  +                Tcl_SetObjResult(interp, Tcl_NewStringObj(errMsg, -1));
         2491  +                Tcl_Close(interp, out);
         2492  +                Tcl_Close(interp, in);
         2493  +                return TCL_ERROR;
         2494  +            }
         2495  +            Tcl_Seek(in, 0, SEEK_SET);
         2496  +            k = 0;
         2497  +            while (k < i) {
         2498  +                m = i - k;
         2499  +                if (m > sizeof (buf)) {
         2500  +                    m = sizeof (buf);
         2501  +                }
         2502  +                n = Tcl_Read(in, buf, m);
         2503  +                if (n == -1) {
         2504  +                    errMsg = "read error";
         2505  +                    goto cperr;
         2506  +                } else if (n == 0) {
         2507  +                    break;
         2508  +                }
         2509  +                m = Tcl_Write(out, buf, n);
         2510  +                if (m != n) {
         2511  +                    errMsg = "write error";
         2512  +                    goto cperr;
         2513  +                }
         2514  +                k += m;
         2515  +            }
         2516  +            Tcl_Close(interp, in);
         2517  +        }
         2518  +        len = strlen(pwbuf);
         2519  +        if (len > 0) {
         2520  +            i = Tcl_Write(out, pwbuf, len);
         2521  +            if (i != len) {
         2522  +                Tcl_DecrRefCount(list);
         2523  +                Tcl_SetObjResult(interp, Tcl_NewStringObj("write error", -1));
         2524  +                Tcl_Close(interp, out);
         2525  +                return TCL_ERROR;
         2526  +            }
         2527  +        }
         2528  +        memset(pwbuf, 0, sizeof (pwbuf));
         2529  +        Tcl_Flush(out);
         2530  +    }
         2531  +    Tcl_InitHashTable(&fileHash, TCL_STRING_KEYS);
         2532  +    pos[0] = Tcl_Tell(out);
         2533  +    if (!isList && (objc > 3)) {
         2534  +        strip = Tcl_GetString(objv[3]);
         2535  +        slen = strlen(strip);
         2536  +    }
         2537  +    for (i = 0; i < lobjc; i += (isList ? 2 : 1)) {
         2538  +        const char *path, *name;
         2539  +
         2540  +        path = Tcl_GetString(lobjv[i]);
         2541  +        if (isList) {
         2542  +            name = Tcl_GetString(lobjv[i + 1]);
         2543  +        } else {
         2544  +            name = path;
         2545  +            if (slen > 0) {
         2546  +                len = strlen(name);
         2547  +                if ((len <= slen) || (strncmp(strip, name, slen) != 0)) {
         2548  +                    continue;
         2549  +                }
         2550  +                name += slen;
         2551  +            }
         2552  +        }
         2553  +        while (name[0] == '/') {
         2554  +            ++name;
         2555  +        }
         2556  +        if (name[0] == '\0') {
         2557  +            continue;
         2558  +        }
         2559  +        if (ZipAddFile(interp, path, name, out, pw, buf, sizeof (buf),
         2560  +                       &fileHash) != TCL_OK) {
         2561  +            goto done;
         2562  +        }
         2563  +    }
         2564  +    pos[1] = Tcl_Tell(out);
         2565  +    count = 0;
         2566  +    for (i = 0; i < lobjc; i += (isList ? 2 : 1)) {
         2567  +        const char *path, *name;
         2568  +
         2569  +        path = Tcl_GetString(lobjv[i]);
         2570  +        if (isList) {
         2571  +            name = Tcl_GetString(lobjv[i + 1]);
         2572  +        } else {
         2573  +            name = path;
         2574  +            if (slen > 0) {
         2575  +                len = strlen(name);
         2576  +                if ((len <= slen) || (strncmp(strip, name, slen) != 0)) {
         2577  +                    continue;
         2578  +                }
         2579  +                name += slen;
         2580  +            }
         2581  +        }
         2582  +        while (name[0] == '/') {
         2583  +            ++name;
         2584  +        }
         2585  +        if (name[0] == '\0') {
         2586  +            continue;
         2587  +        }
         2588  +        hPtr = Tcl_FindHashEntry(&fileHash, name);
         2589  +        if (hPtr == NULL) {
         2590  +            continue;
         2591  +        }
         2592  +        z = (ZipEntry *) Tcl_GetHashValue(hPtr);
         2593  +        len = strlen(z->name);
         2594  +        zip_write_int(buf + ZIP_CENTRAL_SIG_OFFS, ZIP_CENTRAL_HEADER_SIG);
         2595  +        zip_write_short(buf + ZIP_CENTRAL_VERSIONMADE_OFFS, ZIP_MIN_VERSION);
         2596  +        zip_write_short(buf + ZIP_CENTRAL_VERSION_OFFS, ZIP_MIN_VERSION);
         2597  +        zip_write_short(buf + ZIP_CENTRAL_FLAGS_OFFS, z->isenc ? 1 : 0);
         2598  +        zip_write_short(buf + ZIP_CENTRAL_COMPMETH_OFFS, z->cmeth);
         2599  +        zip_write_short(buf + ZIP_CENTRAL_MTIME_OFFS, ToDosTime(z->timestamp));
         2600  +        zip_write_short(buf + ZIP_CENTRAL_MDATE_OFFS, ToDosDate(z->timestamp));
         2601  +        zip_write_int(buf + ZIP_CENTRAL_CRC32_OFFS, z->crc32);
         2602  +        zip_write_int(buf + ZIP_CENTRAL_COMPLEN_OFFS, z->nbytecompr);
         2603  +        zip_write_int(buf + ZIP_CENTRAL_UNCOMPLEN_OFFS, z->nbyte);
         2604  +        zip_write_short(buf + ZIP_CENTRAL_PATHLEN_OFFS, len);
         2605  +        zip_write_short(buf + ZIP_CENTRAL_EXTRALEN_OFFS, 0);
         2606  +        zip_write_short(buf + ZIP_CENTRAL_FCOMMENTLEN_OFFS, 0);
         2607  +        zip_write_short(buf + ZIP_CENTRAL_DISKFILE_OFFS, 0);
         2608  +        zip_write_short(buf + ZIP_CENTRAL_IATTR_OFFS, 0);
         2609  +        zip_write_int(buf + ZIP_CENTRAL_EATTR_OFFS, 0);
         2610  +        zip_write_int(buf + ZIP_CENTRAL_LOCALHDR_OFFS, z->offset - pos[0]);
         2611  +        if (
         2612  +            (Tcl_Write(out, buf, ZIP_CENTRAL_HEADER_LEN) != ZIP_CENTRAL_HEADER_LEN)
         2613  +            || (Tcl_Write(out, z->name, len) != len)
         2614  +        ) {
         2615  +            Tcl_SetObjResult(interp, Tcl_NewStringObj("write error", -1));
         2616  +            goto done;
         2617  +        }
         2618  +        count++;
         2619  +    }
         2620  +    Tcl_Flush(out);
         2621  +    pos[2] = Tcl_Tell(out);
         2622  +    zip_write_int(buf + ZIP_CENTRAL_END_SIG_OFFS, ZIP_CENTRAL_END_SIG);
         2623  +    zip_write_short(buf + ZIP_CENTRAL_DISKNO_OFFS, 0);
         2624  +    zip_write_short(buf + ZIP_CENTRAL_DISKDIR_OFFS, 0);
         2625  +    zip_write_short(buf + ZIP_CENTRAL_ENTS_OFFS, count);
         2626  +    zip_write_short(buf + ZIP_CENTRAL_TOTALENTS_OFFS, count);
         2627  +    zip_write_int(buf + ZIP_CENTRAL_DIRSIZE_OFFS, pos[2] - pos[1]);
         2628  +    zip_write_int(buf + ZIP_CENTRAL_DIRSTART_OFFS, pos[1] - pos[0]);
         2629  +    zip_write_short(buf + ZIP_CENTRAL_COMMENTLEN_OFFS, 0);
         2630  +    if (Tcl_Write(out, buf, ZIP_CENTRAL_END_LEN) != ZIP_CENTRAL_END_LEN) {
         2631  +        Tcl_SetObjResult(interp, Tcl_NewStringObj("write error", -1));
         2632  +        goto done;
         2633  +    }
         2634  +    Tcl_Flush(out);
         2635  +    ret = TCL_OK;
         2636  +done:
         2637  +    if (ret == TCL_OK) {
         2638  +        ret = Tcl_Close(interp, out);
         2639  +    } else {
         2640  +        Tcl_Close(interp, out);
         2641  +    }
         2642  +    Tcl_DecrRefCount(list);
         2643  +    hPtr = Tcl_FirstHashEntry(&fileHash, &search);
         2644  +    while (hPtr != NULL) {
         2645  +        z = (ZipEntry *) Tcl_GetHashValue(hPtr);
         2646  +        Tcl_Free((char *) z);
         2647  +        Tcl_DeleteHashEntry(hPtr);
         2648  +        hPtr = Tcl_NextHashEntry(&search);
         2649  +    }
         2650  +    Tcl_DeleteHashTable(&fileHash);
         2651  +    return ret;
         2652  +}
         2653  +
         2654  +/*
         2655  + *-------------------------------------------------------------------------
         2656  + *
         2657  + * ZipFSMkZipObjCmd --
         2658  + *
         2659  + *      This procedure is invoked to process the "zipfs::mkzip" command.
         2660  + *    See description of ZipFSMkZipOrImgCmd().
         2661  + *
         2662  + * Results:
         2663  + *      A standard Tcl result.
         2664  + *
         2665  + * Side effects:
         2666  + *    See description of ZipFSMkZipOrImgCmd().
         2667  + *
         2668  + *-------------------------------------------------------------------------
         2669  + */
         2670  +
         2671  +static int
         2672  +ZipFSMkZipObjCmd(
         2673  +    ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]
         2674  +) {
         2675  +    return ZipFSMkZipOrImgObjCmd(clientData, interp, 0, 0, objc, objv);
         2676  +}
         2677  +
         2678  +static int
         2679  +ZipFSLMkZipObjCmd(
         2680  +    ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]
         2681  +) {
         2682  +    return ZipFSMkZipOrImgObjCmd(clientData, interp, 0, 1, objc, objv);
         2683  +}
         2684  +
         2685  +/*
         2686  + *-------------------------------------------------------------------------
         2687  + *
         2688  + * ZipFSZipFSOpenArchiveObjCmd --
         2689  + *
         2690  + *      This procedure is invoked to process the "zipfs::mkimg" command.
         2691  + *    See description of ZipFSMkZipOrImgCmd().
         2692  + *
         2693  + * Results:
         2694  + *      A standard Tcl result.
         2695  + *
         2696  + * Side effects:
         2697  + *    See description of ZipFSMkZipOrImgCmd().
         2698  + *
         2699  + *-------------------------------------------------------------------------
         2700  + */
         2701  +
         2702  +static int
         2703  +ZipFSMkImgObjCmd(ClientData clientData, Tcl_Interp *interp,
         2704  +         int objc, Tcl_Obj *const objv[])
         2705  +{
         2706  +    return ZipFSMkZipOrImgObjCmd(clientData, interp, 1, 0, objc, objv);
         2707  +}
         2708  +
         2709  +static int
         2710  +ZipFSLMkImgObjCmd(ClientData clientData, Tcl_Interp *interp,
         2711  +          int objc, Tcl_Obj *const objv[])
         2712  +{
         2713  +    return ZipFSMkZipOrImgObjCmd(clientData, interp, 1, 1, objc, objv);
         2714  +}
         2715  +
         2716  +/*
         2717  + *-------------------------------------------------------------------------
         2718  + *
         2719  + * ZipFSCanonicalObjCmd --
         2720  + *
         2721  + *      This procedure is invoked to process the "zipfs::canonical" command.
         2722  + *    It returns the canonical name for a file within zipfs
         2723  + *
         2724  + * Results:
         2725  + *      Always TCL_OK.
         2726  + *
         2727  + * Side effects:
         2728  + *      None.
         2729  + *
         2730  + *-------------------------------------------------------------------------
         2731  + */
         2732  +
         2733  +static int
         2734  +ZipFSCanonicalObjCmd(
         2735  +    ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]
         2736  +) {
         2737  +    char *mntpoint=NULL;
         2738  +    char *filename=NULL;
         2739  +    char *result;
         2740  +    Tcl_DString dPath;
         2741  +
         2742  +    if (objc != 2 && objc != 3 && objc!=4) {
         2743  +        Tcl_WrongNumArgs(interp, 1, objv, "?mntpnt? filename ?ZIPFS?");
         2744  +        return TCL_ERROR;
         2745  +    }
         2746  +    Tcl_DStringInit(&dPath);
         2747  +    if(objc==2) {
         2748  +        filename = Tcl_GetString(objv[1]);
         2749  +        result=CanonicalPath("",filename,&dPath,1);
         2750  +    } else if (objc==3) {
         2751  +        mntpoint = Tcl_GetString(objv[1]);
         2752  +        filename = Tcl_GetString(objv[2]);
         2753  +        result=CanonicalPath(mntpoint,filename,&dPath,1);
         2754  +    } else {
         2755  +        int zipfs=0;
         2756  +        if(Tcl_GetBooleanFromObj(interp,objv[3],&zipfs)) {
         2757  +            return TCL_ERROR;
         2758  +        }
         2759  +        mntpoint = Tcl_GetString(objv[1]);
         2760  +        filename = Tcl_GetString(objv[2]);
         2761  +        result=CanonicalPath(mntpoint,filename,&dPath,zipfs);
         2762  +    }
         2763  +    Tcl_SetObjResult(interp,Tcl_NewStringObj(result,-1));
         2764  +    return TCL_OK;
         2765  +}
         2766  +
         2767  +/*
         2768  + *-------------------------------------------------------------------------
         2769  + *
         2770  + * ZipFSExistsObjCmd --
         2771  + *
         2772  + *      This procedure is invoked to process the "zipfs::exists" command.
         2773  + *    It tests for the existence of a file in the ZIP filesystem and
         2774  + *    places a boolean into the interp's result.
         2775  + *
         2776  + * Results:
         2777  + *      Always TCL_OK.
         2778  + *
         2779  + * Side effects:
         2780  + *      None.
         2781  + *
         2782  + *-------------------------------------------------------------------------
         2783  + */
         2784  +
         2785  +static int
         2786  +ZipFSExistsObjCmd(
         2787  +    ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]
         2788  +) {
         2789  +    char *filename;
         2790  +    int exists;
         2791  +    Tcl_DString ds;
         2792  +
         2793  +    if (objc != 2) {
         2794  +      Tcl_WrongNumArgs(interp, 1, objv, "filename");
         2795  +      return TCL_ERROR;
         2796  +    }
         2797  +
         2798  +    /* prepend ZIPFS_VOLUME to filename, eliding the final / */
         2799  +    filename = Tcl_GetStringFromObj(objv[1], 0);
         2800  +    Tcl_DStringInit(&ds);
         2801  +    Tcl_DStringAppend(&ds, ZIPFS_VOLUME, ZIPFS_VOLUME_LEN-1);
         2802  +    Tcl_DStringAppend(&ds, filename, -1);
         2803  +    filename = Tcl_DStringValue(&ds);
         2804  +
         2805  +    ReadLock();
         2806  +    exists = ZipFSLookup(filename) != NULL;
         2807  +    Unlock();
         2808  +
         2809  +    Tcl_SetObjResult(interp,Tcl_NewBooleanObj(exists));
         2810  +    return TCL_OK;
         2811  +}
         2812  +
         2813  +/*
         2814  + *-------------------------------------------------------------------------
         2815  + *
         2816  + * ZipFSInfoObjCmd --
         2817  + *
         2818  + *      This procedure is invoked to process the "zipfs::info" command.
         2819  + *    On success, it returns a Tcl list made up of name of ZIP archive
         2820  + *    file, size uncompressed, size compressed, and archive offset of
         2821  + *    a file in the ZIP filesystem.
         2822  + *
         2823  + * Results:
         2824  + *      A standard Tcl result.
         2825  + *
         2826  + * Side effects:
         2827  + *      None.
         2828  + *
         2829  + *-------------------------------------------------------------------------
         2830  + */
         2831  +
         2832  +static int
         2833  +ZipFSInfoObjCmd(
         2834  +    ClientData clientData, Tcl_Interp *interp,int objc, Tcl_Obj *const objv[]
         2835  +) {
         2836  +    char *filename;
         2837  +    ZipEntry *z;
         2838  +
         2839  +    if (objc != 2) {
         2840  +        Tcl_WrongNumArgs(interp, 1, objv, "filename");
         2841  +        return TCL_ERROR;
         2842  +    }
         2843  +    filename = Tcl_GetStringFromObj(objv[1], 0);
         2844  +    ReadLock();
         2845  +    z = ZipFSLookup(filename);
         2846  +    if (z != NULL) {
         2847  +        Tcl_Obj *result = Tcl_GetObjResult(interp);
         2848  +
         2849  +        Tcl_ListObjAppendElement(interp, result,
         2850  +                     Tcl_NewStringObj(z->zipfile->name, -1));
         2851  +        Tcl_ListObjAppendElement(interp, result, Tcl_NewIntObj(z->nbyte));
         2852  +        Tcl_ListObjAppendElement(interp, result, Tcl_NewIntObj(z->nbytecompr));
         2853  +        Tcl_ListObjAppendElement(interp, result, Tcl_NewIntObj(z->offset));
         2854  +    }
         2855  +    Unlock();
         2856  +    return TCL_OK;
         2857  +}
         2858  +
         2859  +/*
         2860  + *-------------------------------------------------------------------------
         2861  + *
         2862  + * ZipFSListObjCmd --
         2863  + *
         2864  + *      This procedure is invoked to process the "zipfs::list" command.
         2865  + *    On success, it returns a Tcl list of files of the ZIP filesystem
         2866  + *    which match a search pattern (glob or regexp).
         2867  + *
         2868  + * Results:
         2869  + *      A standard Tcl result.
         2870  + *
         2871  + * Side effects:
         2872  + *      None.
         2873  + *
         2874  + *-------------------------------------------------------------------------
         2875  + */
         2876  +
         2877  +static int
         2878  +ZipFSListObjCmd(
         2879  +    ClientData clientData, Tcl_Interp *interp,int objc, Tcl_Obj *const objv[]
         2880  +) {
         2881  +    char *pattern = NULL;
         2882  +    Tcl_RegExp regexp = NULL;
         2883  +    Tcl_HashEntry *hPtr;
         2884  +    Tcl_HashSearch search;
         2885  +    Tcl_Obj *result = Tcl_GetObjResult(interp);
         2886  +
         2887  +    if (objc > 3) {
         2888  +        Tcl_WrongNumArgs(interp, 1, objv, "?(-glob|-regexp)? ?pattern?");
         2889  +        return TCL_ERROR;
         2890  +    }
         2891  +    if (objc == 3) {
         2892  +        int n;
         2893  +        char *what = Tcl_GetStringFromObj(objv[1], &n);
         2894  +
         2895  +        if ((n >= 2) && (strncmp(what, "-glob", n) == 0)) {
         2896  +            pattern = Tcl_GetString(objv[2]);
         2897  +        } else if ((n >= 2) && (strncmp(what, "-regexp", n) == 0)) {
         2898  +            regexp = Tcl_RegExpCompile(interp, Tcl_GetString(objv[2]));
         2899  +            if (regexp == NULL) {
         2900  +                return TCL_ERROR;
         2901  +            }
         2902  +        } else {
         2903  +            Tcl_AppendResult(interp, "unknown option \"", what,"\"", (char *) NULL);
         2904  +            return TCL_ERROR;
         2905  +        }
         2906  +    } else if (objc == 2) {
         2907  +        pattern = Tcl_GetStringFromObj(objv[1], 0);
         2908  +    }
         2909  +    ReadLock();
         2910  +    if (pattern != NULL) {
         2911  +        for (
         2912  +            hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search);
         2913  +            hPtr != NULL;
         2914  +            hPtr = Tcl_NextHashEntry(&search)
         2915  +        ) {
         2916  +            ZipEntry *z = (ZipEntry *) Tcl_GetHashValue(hPtr);
         2917  +
         2918  +            if (Tcl_StringMatch(z->name, pattern)) {
         2919  +                Tcl_ListObjAppendElement(interp, result,Tcl_NewStringObj(z->name, -1));
         2920  +            }
         2921  +        }
         2922  +    } else if (regexp != NULL) {
         2923  +        for (
         2924  +            hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search);
         2925  +            hPtr != NULL;
         2926  +            hPtr = Tcl_NextHashEntry(&search)
         2927  +        ) {
         2928  +            ZipEntry *z = (ZipEntry *) Tcl_GetHashValue(hPtr);
         2929  +            if (Tcl_RegExpExec(interp, regexp, z->name, z->name)) {
         2930  +                Tcl_ListObjAppendElement(interp, result,Tcl_NewStringObj(z->name, -1));
         2931  +            }
         2932  +        }
         2933  +    } else {
         2934  +        for (
         2935  +            hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search);
         2936  +            hPtr != NULL;
         2937  +            hPtr = Tcl_NextHashEntry(&search)
         2938  +        ) {
         2939  +            ZipEntry *z = (ZipEntry *) Tcl_GetHashValue(hPtr);
         2940  +
         2941  +            Tcl_ListObjAppendElement(interp, result, Tcl_NewStringObj(z->name, -1));
         2942  +        }
         2943  +    }
         2944  +    Unlock();
         2945  +    return TCL_OK;
         2946  +}
         2947  +
         2948  +#if defined(_WIN32) || defined(_WIN64)
         2949  +#define LIBRARY_SIZE        64
         2950  +static int
         2951  +ToUtf(
         2952  +    const WCHAR *wSrc,
         2953  +    char *dst)
         2954  +{
         2955  +    char *start;
         2956  +
         2957  +    start = dst;
         2958  +    while (*wSrc != '\0') {
         2959  +    dst += Tcl_UniCharToUtf(*wSrc, dst);
         2960  +    wSrc++;
         2961  +    }
         2962  +    *dst = '\0';
         2963  +    return (int) (dst - start);
         2964  +}
         2965  +#endif
         2966  +
         2967  +Tcl_Obj *TclZipfs_TclLibrary(void) {
         2968  +    if(zipfs_literal_tcl_library) {
         2969  +        return Tcl_NewStringObj(zipfs_literal_tcl_library,-1);
         2970  +    } else {
         2971  +        Tcl_Obj *vfsinitscript;
         2972  +        int found=0;
         2973  +
         2974  +        /* Look for the library file system within the executable */
         2975  +        vfsinitscript=Tcl_NewStringObj(ZIPFS_APP_MOUNT "/tcl_library/init.tcl",-1);
         2976  +        Tcl_IncrRefCount(vfsinitscript);
         2977  +        found=Tcl_FSAccess(vfsinitscript,F_OK);
         2978  +        Tcl_DecrRefCount(vfsinitscript);
         2979  +        if(found==TCL_OK) {
         2980  +            zipfs_literal_tcl_library=ZIPFS_APP_MOUNT "/tcl_library";
         2981  +            return Tcl_NewStringObj(zipfs_literal_tcl_library,-1);
         2982  +        }
         2983  +#if defined(_WIN32) || defined(_WIN64)
         2984  +        HMODULE hModule = TclWinGetTclInstance();
         2985  +        WCHAR wName[MAX_PATH + LIBRARY_SIZE];
         2986  +        char dllname[(MAX_PATH + LIBRARY_SIZE) * TCL_UTF_MAX];
         2987  +
         2988  +        if (GetModuleFileNameW(hModule, wName, MAX_PATH) == 0) {
         2989  +            GetModuleFileNameA(hModule, dllname, MAX_PATH);
         2990  +        } else {
         2991  +            ToUtf(wName, dllname);
         2992  +        }
         2993  +        /* Mount zip file and dll before releasing to search */
         2994  +        if(TclZipfs_AppHook_FindTclInit(dllname)==TCL_OK) {
         2995  +            return Tcl_NewStringObj(zipfs_literal_tcl_library,-1);
         2996  +        }
         2997  +#else
         2998  +#ifdef CFG_RUNTIME_DLLFILE
         2999  +        /* Mount zip file and dll before releasing to search */
         3000  +        if(TclZipfs_AppHook_FindTclInit(CFG_RUNTIME_LIBDIR "/" CFG_RUNTIME_DLLFILE)==TCL_OK) {
         3001  +            return Tcl_NewStringObj(zipfs_literal_tcl_library,-1);
         3002  +        }
         3003  +#endif
         3004  +#endif
         3005  +#ifdef CFG_RUNTIME_ZIPFILE
         3006  +        if(TclZipfs_AppHook_FindTclInit(CFG_RUNTIME_LIBDIR "/" CFG_RUNTIME_ZIPFILE)==TCL_OK) {
         3007  +            return Tcl_NewStringObj(zipfs_literal_tcl_library,-1);
         3008  +        }
         3009  +        if(TclZipfs_AppHook_FindTclInit(CFG_RUNTIME_SCRDIR "/" CFG_RUNTIME_ZIPFILE)==TCL_OK) {
         3010  +            return Tcl_NewStringObj(zipfs_literal_tcl_library,-1);
         3011  +        }
         3012  +#endif
         3013  +    }
         3014  +    if(zipfs_literal_tcl_library) {
         3015  +        return Tcl_NewStringObj(zipfs_literal_tcl_library,-1);
         3016  +    }
         3017  +    return NULL;
         3018  +}
         3019  +
         3020  +/*
         3021  + *-------------------------------------------------------------------------
         3022  + *
         3023  + * ZipFSTclLibraryObjCmd --
         3024  + *
         3025  + *      This procedure is invoked to process the "zipfs::root" command. It
         3026  + *      returns the root that all zipfs file systems are mounted under.
         3027  + *
         3028  + * Results:
         3029  + *      A standard Tcl result.
         3030  + *
         3031  + * Side effects:
         3032  + *
         3033  + *-------------------------------------------------------------------------
         3034  + */
         3035  +
         3036  +static int
         3037  +ZipFSTclLibraryObjCmd(ClientData clientData, Tcl_Interp *interp,
         3038  +         int objc, Tcl_Obj *const objv[])
         3039  +{
         3040  +    Tcl_Obj *pResult;
         3041  +
         3042  +    pResult=TclZipfs_TclLibrary();
         3043  +    if(!pResult) {
         3044  +        pResult=Tcl_NewObj();
         3045  +    }
         3046  +    Tcl_SetObjResult(interp,pResult);
         3047  +    return TCL_OK;
         3048  +}
         3049  +
         3050  +/*
         3051  + *-------------------------------------------------------------------------
         3052  + *
         3053  + * ZipChannelClose --
         3054  + *
         3055  + *    This function is called to close a channel.
         3056  + *
         3057  + * Results:
         3058  + *    Always TCL_OK.
         3059  + *
         3060  + * Side effects:
         3061  + *    Resources are free'd.
         3062  + *
         3063  + *-------------------------------------------------------------------------
         3064  + */
         3065  +
         3066  +static int
         3067  +ZipChannelClose(ClientData instanceData, Tcl_Interp *interp)
         3068  +{
         3069  +    ZipChannel *info = (ZipChannel *) instanceData;
         3070  +
         3071  +    if (info->iscompr && (info->ubuf != NULL)) {
         3072  +        Tcl_Free((char *) info->ubuf);
         3073  +        info->ubuf = NULL;
         3074  +    }
         3075  +    if (info->isenc) {
         3076  +        info->isenc = 0;
         3077  +        memset(info->keys, 0, sizeof (info->keys));
         3078  +    }
         3079  +    if (info->iswr) {
         3080  +        ZipEntry *z = info->zipentry;
         3081  +        unsigned char *newdata;
         3082  +
         3083  +        newdata = (unsigned char *) Tcl_AttemptRealloc((char *) info->ubuf, info->nread);
         3084  +        if (newdata != NULL) {
         3085  +            if (z->data != NULL) {
         3086  +                Tcl_Free((char *) z->data);
         3087  +            }
         3088  +            z->data = newdata;
         3089  +            z->nbyte = z->nbytecompr = info->nbyte;
         3090  +            z->cmeth = ZIP_COMPMETH_STORED;
         3091  +            z->timestamp = time(NULL);
         3092  +            z->isdir = 0;
         3093  +            z->isenc = 0;
         3094  +            z->offset = 0;
         3095  +            z->crc32 = 0;
         3096  +        } else {
         3097  +            Tcl_Free((char *) info->ubuf);
         3098  +        }
         3099  +    }
         3100  +    WriteLock();
         3101  +    info->zipfile->nopen--;
         3102  +    Unlock();
         3103  +    Tcl_Free((char *) info);
         3104  +    return TCL_OK;
         3105  +}
         3106  +
         3107  +/*
         3108  + *-------------------------------------------------------------------------
         3109  + *
         3110  + * ZipChannelRead --
         3111  + *
         3112  + *        This function is called to read data from channel.
         3113  + *
         3114  + * Results:
         3115  + *        Number of bytes read or -1 on error with error number set.
         3116  + *
         3117  + * Side effects:
         3118  + *        Data is read and file pointer is advanced.
         3119  + *
         3120  + *-------------------------------------------------------------------------
         3121  + */
         3122  +
         3123  +static int
         3124  +ZipChannelRead(ClientData instanceData, char *buf, int toRead, int *errloc)
         3125  +{
         3126  +    ZipChannel *info = (ZipChannel *) instanceData;
         3127  +    unsigned long nextpos;
         3128  +
         3129  +    if (info->isdir < 0) {
         3130  +        /*
         3131  +         * Special case: when executable combined with ZIP archive file
         3132  +         * read data in front of ZIP, i.e. the executable itself.
         3133  +         */
         3134  +        nextpos = info->nread + toRead;
         3135  +        if (nextpos > info->zipfile->baseoffs) {
         3136  +            toRead = info->zipfile->baseoffs - info->nread;
         3137  +            nextpos = info->zipfile->baseoffs;
         3138  +        }
         3139  +        if (toRead == 0) {
         3140  +            return 0;
         3141  +        }
         3142  +        memcpy(buf, info->zipfile->data, toRead);
         3143  +        info->nread = nextpos;
         3144  +        *errloc = 0;
         3145  +        return toRead;
         3146  +    }
         3147  +    if (info->isdir) {
         3148  +        *errloc = EISDIR;
         3149  +        return -1;
         3150  +    }
         3151  +    nextpos = info->nread + toRead;
         3152  +    if (nextpos > info->nbyte) {
         3153  +        toRead = info->nbyte - info->nread;
         3154  +        nextpos = info->nbyte;
         3155  +    }
         3156  +    if (toRead == 0) {
         3157  +        return 0;
         3158  +    }
         3159  +    if (info->isenc) {
         3160  +        int i, ch;
         3161  +
         3162  +        for (i = 0; i < toRead; i++) {
         3163  +            ch = info->ubuf[i + info->nread];
         3164  +            buf[i] = zdecode(info->keys, crc32tab, ch);
         3165  +        }
         3166  +    } else {
         3167  +        memcpy(buf, info->ubuf + info->nread, toRead);
         3168  +    }
         3169  +    info->nread = nextpos;
         3170  +    *errloc = 0;
         3171  +    return toRead;
         3172  +}
         3173  +
         3174  +/*
         3175  + *-------------------------------------------------------------------------
         3176  + *
         3177  + * ZipChannelWrite --
         3178  + *
         3179  + *    This function is called to write data into channel.
         3180  + *
         3181  + * Results:
         3182  + *    Number of bytes written or -1 on error with error number set.
         3183  + *
         3184  + * Side effects:
         3185  + *    Data is written and file pointer is advanced.
         3186  + *
         3187  + *-------------------------------------------------------------------------
         3188  + */
         3189  +
         3190  +static int
         3191  +ZipChannelWrite(ClientData instanceData, const char *buf,
         3192  +        int toWrite, int *errloc)
         3193  +{
         3194  +    ZipChannel *info = (ZipChannel *) instanceData;
         3195  +    unsigned long nextpos;
         3196  +
         3197  +    if (!info->iswr) {
         3198  +        *errloc = EINVAL;
         3199  +        return -1;
         3200  +    }
         3201  +    nextpos = info->nread + toWrite;
         3202  +    if (nextpos > info->nmax) {
         3203  +        toWrite = info->nmax - info->nread;
         3204  +        nextpos = info->nmax;
         3205  +    }
         3206  +    if (toWrite == 0) {
         3207  +        return 0;
         3208  +    }
         3209  +    memcpy(info->ubuf + info->nread, buf, toWrite);
         3210  +    info->nread = nextpos;
         3211  +    if (info->nread > info->nbyte) {
         3212  +        info->nbyte = info->nread;
         3213  +    }
         3214  +    *errloc = 0;
         3215  +    return toWrite;
         3216  +}
         3217  +
         3218  +/*
         3219  + *-------------------------------------------------------------------------
         3220  + *
         3221  + * ZipChannelSeek --
         3222  + *
         3223  + *        This function is called to position file pointer of channel.
         3224  + *
         3225  + * Results:
         3226  + *        New file position or -1 on error with error number set.
         3227  + *
         3228  + * Side effects:
         3229  + *        File pointer is repositioned according to offset and mode.
         3230  + *
         3231  + *-------------------------------------------------------------------------
         3232  + */
         3233  +
         3234  +static int
         3235  +ZipChannelSeek(ClientData instanceData, long offset, int mode, int *errloc)
         3236  +{
         3237  +    ZipChannel *info = (ZipChannel *) instanceData;
         3238  +    unsigned long end;
         3239  +
         3240  +    if (!info->iswr && (info->isdir < 0)) {
         3241  +        /*
         3242  +         * Special case: when executable combined with ZIP archive file,
         3243  +         * seek within front of ZIP, i.e. the executable itself.
         3244  +         */
         3245  +        end = info->zipfile->baseoffs;
         3246  +    } else if (info->isdir) {
         3247  +        *errloc = EINVAL;
         3248  +        return -1;
         3249  +    } else {
         3250  +        end = info->nbyte;
         3251  +    }
         3252  +    switch (mode) {
         3253  +    case SEEK_CUR:
         3254  +        offset += info->nread;
         3255  +        break;
         3256  +    case SEEK_END:
         3257  +        offset += end;
         3258  +        break;
         3259  +    case SEEK_SET:
         3260  +        break;
         3261  +    default:
         3262  +        *errloc = EINVAL;
         3263  +        return -1;
         3264  +    }
         3265  +    if (offset < 0) {
         3266  +        *errloc = EINVAL;
         3267  +        return -1;
         3268  +    }
         3269  +    if (info->iswr) {
         3270  +        if ((unsigned long) offset > info->nmax) {
         3271  +            *errloc = EINVAL;
         3272  +            return -1;
         3273  +        }
         3274  +        if ((unsigned long) offset > info->nbyte) {
         3275  +            info->nbyte = offset;
         3276  +        }
         3277  +    } else if ((unsigned long) offset > end) {
         3278  +        *errloc = EINVAL;
         3279  +        return -1;
         3280  +    }
         3281  +    info->nread = (unsigned long) offset;
         3282  +    return info->nread;
         3283  +}
         3284  +
         3285  +/*
         3286  + *-------------------------------------------------------------------------
         3287  + *
         3288  + * ZipChannelWatchChannel --
         3289  + *
         3290  + *    This function is called for event notifications on channel.
         3291  + *
         3292  + * Results:
         3293  + *    None.
         3294  + *
         3295  + * Side effects:
         3296  + *    None.
         3297  + *
         3298  + *-------------------------------------------------------------------------
         3299  + */
         3300  +
         3301  +static void
         3302  +ZipChannelWatchChannel(ClientData instanceData, int mask)
         3303  +{
         3304  +    return;
         3305  +}
         3306  +
         3307  +/*
         3308  + *-------------------------------------------------------------------------
         3309  + *
         3310  + * ZipChannelGetFile --
         3311  + *
         3312  + *    This function is called to retrieve OS handle for channel.
         3313  + *
         3314  + * Results:
         3315  + *    Always TCL_ERROR since there's never an OS handle for a
         3316  + *    file within a ZIP archive.
         3317  + *
         3318  + * Side effects:
         3319  + *    None.
         3320  + *
         3321  + *-------------------------------------------------------------------------
         3322  + */
         3323  +
         3324  +static int
         3325  +ZipChannelGetFile(
         3326  +    ClientData instanceData, int direction,ClientData *handlePtr
         3327  +) {
         3328  +    return TCL_ERROR;
         3329  +}
         3330  +
         3331  +/*
         3332  + * The channel type/driver definition used for ZIP archive members.
         3333  + */
         3334  +
         3335  +static Tcl_ChannelType ZipChannelType = {
         3336  +    "zip",                  /* Type name. */
         3337  +#ifdef TCL_CHANNEL_VERSION_4
         3338  +    TCL_CHANNEL_VERSION_4,
         3339  +    ZipChannelClose,        /* Close channel, clean instance data */
         3340  +    ZipChannelRead,         /* Handle read request */
         3341  +    ZipChannelWrite,        /* Handle write request */
         3342  +    ZipChannelSeek,         /* Move location of access point, NULL'able */
         3343  +    NULL,                   /* Set options, NULL'able */
         3344  +    NULL,                   /* Get options, NULL'able */
         3345  +    ZipChannelWatchChannel, /* Initialize notifier */
         3346  +    ZipChannelGetFile,      /* Get OS handle from the channel */
         3347  +    NULL,                   /* 2nd version of close channel, NULL'able */
         3348  +    NULL,                   /* Set blocking mode for raw channel, NULL'able */
         3349  +    NULL,                   /* Function to flush channel, NULL'able */
         3350  +    NULL,                   /* Function to handle event, NULL'able */
         3351  +    NULL,                   /* Wide seek function, NULL'able */
         3352  +    NULL,                   /* Thread action function, NULL'able */
         3353  +#else
         3354  +    NULL,                   /* Set blocking/nonblocking behaviour, NULL'able */
         3355  +    ZipChannelClose,        /* Close channel, clean instance data */
         3356  +    ZipChannelRead,         /* Handle read request */
         3357  +    ZipChannelWrite,        /* Handle write request */
         3358  +    ZipChannelSeek,         /* Move location of access point, NULL'able */
         3359  +    NULL,                   /* Set options, NULL'able */
         3360  +    NULL,                   /* Get options, NULL'able */
         3361  +    ZipChannelWatchChannel, /* Initialize notifier */
         3362  +    ZipChannelGetFile,      /* Get OS handle from the channel */
         3363  +#endif
         3364  +};
         3365  +
         3366  +/*
         3367  + *-------------------------------------------------------------------------
         3368  + *
         3369  + * ZipChannelOpen --
         3370  + *
         3371  + *    This function opens a Tcl_Channel on a file from a mounted ZIP
         3372  + *    archive according to given open mode.
         3373  + *
         3374  + * Results:
         3375  + *    Tcl_Channel on success, or NULL on error.
         3376  + *
         3377  + * Side effects:
         3378  + *    Memory is allocated, the file from the ZIP archive is uncompressed.
         3379  + *
         3380  + *-------------------------------------------------------------------------
         3381  + */
         3382  +
         3383  +static Tcl_Channel
         3384  +ZipChannelOpen(Tcl_Interp *interp, char *filename, int mode, int permissions)
         3385  +{
         3386  +    ZipEntry *z;
         3387  +    ZipChannel *info;
         3388  +    int i, ch, trunc, wr, flags = 0;
         3389  +    char cname[128];
         3390  +
         3391  +    if (
         3392  +        (mode & O_APPEND)
         3393  +        || ((ZipFS.wrmax <= 0) && (mode & (O_WRONLY | O_RDWR)))
         3394  +    ) {
         3395  +        if (interp != NULL) {
         3396  +            Tcl_SetObjResult(interp, Tcl_NewStringObj("unsupported open mode", -1));
         3397  +        }
         3398  +        return NULL;
         3399  +    }
         3400  +    WriteLock();
         3401  +    z = ZipFSLookup(filename);
         3402  +    if (z == NULL) {
         3403  +        if (interp != NULL) {
         3404  +            Tcl_SetObjResult(interp, Tcl_NewStringObj("file not found", -1));
         3405  +            Tcl_AppendResult(interp, " \"", filename, "\"", NULL);
         3406  +        }
         3407  +        goto error;
         3408  +    }
         3409  +    trunc = (mode & O_TRUNC) != 0;
         3410  +    wr = (mode & (O_WRONLY | O_RDWR)) != 0;
         3411  +    if ((z->cmeth != ZIP_COMPMETH_STORED) && (z->cmeth != ZIP_COMPMETH_DEFLATED)) {
         3412  +        ZIPFS_ERROR(interp,"unsupported compression method");
         3413  +        goto error;
         3414  +    }
         3415  +    if (wr && z->isdir) {
         3416  +        ZIPFS_ERROR(interp,"unsupported file type");
         3417  +        goto error;
         3418  +    }
         3419  +    if (!trunc) {
         3420  +        flags |= TCL_READABLE;
         3421  +        if (z->isenc && (z->zipfile->pwbuf[0] == 0)) {
         3422  +            ZIPFS_ERROR(interp,"decryption failed");
         3423  +            goto error;
         3424  +        } else if (wr && (z->data == NULL) && (z->nbyte > ZipFS.wrmax)) {
         3425  +            ZIPFS_ERROR(interp,"file too large");
         3426  +            goto error;
         3427  +        }
         3428  +    } else {
         3429  +        flags = TCL_WRITABLE;
         3430  +    }
         3431  +    info = (ZipChannel *) Tcl_AttemptAlloc(sizeof (*info));
         3432  +    if (info == NULL) {
         3433  +        ZIPFS_ERROR(interp,"out of memory");
         3434  +        goto error;
         3435  +    }
         3436  +    info->zipfile = z->zipfile;
         3437  +    info->zipentry = z;
         3438  +    info->nread = 0;
         3439  +    if (wr) {
         3440  +        flags |= TCL_WRITABLE;
         3441  +        info->iswr = 1;
         3442  +        info->isdir = 0;
         3443  +        info->nmax = ZipFS.wrmax;
         3444  +        info->iscompr = 0;
         3445  +        info->isenc = 0;
         3446  +        info->ubuf = (unsigned char *) Tcl_AttemptAlloc(info->nmax);
         3447  +        if (info->ubuf == NULL) {
         3448  +merror0:
         3449  +            if (info->ubuf != NULL) {
         3450  +                Tcl_Free((char *) info->ubuf);
         3451  +            }
         3452  +            Tcl_Free((char *) info);
         3453  +            ZIPFS_ERROR(interp,"out of memory");
         3454  +            goto error;
         3455  +        }
         3456  +        memset(info->ubuf, 0, info->nmax);
         3457  +        if (trunc) {
         3458  +            info->nbyte = 0;
         3459  +        } else {
         3460  +            if (z->data != NULL) {
         3461  +                unsigned int j = z->nbyte;
         3462  +
         3463  +                if (j > info->nmax) {
         3464  +                    j = info->nmax;
         3465  +                }
         3466  +                memcpy(info->ubuf, z->data, j);
         3467  +                info->nbyte = j;
         3468  +            } else {
         3469  +                unsigned char *zbuf = z->zipfile->data + z->offset;
         3470  +
         3471  +                if (z->isenc) {
         3472  +                    int len = z->zipfile->pwbuf[0];
         3473  +                    char pwbuf[260];
         3474  +
         3475  +                    for (i = 0; i < len; i++) {
         3476  +                        ch = z->zipfile->pwbuf[len - i];
         3477  +                        pwbuf[i] = (ch & 0x0f) | pwrot[(ch >> 4) & 0x0f];
         3478  +                    }
         3479  +                    pwbuf[i] = '\0';
         3480  +                    init_keys(pwbuf, info->keys, crc32tab);
         3481  +                    memset(pwbuf, 0, sizeof (pwbuf));
         3482  +                    for (i = 0; i < 12; i++) {
         3483  +                        ch = info->ubuf[i];
         3484  +                        zdecode(info->keys, crc32tab, ch);
         3485  +                    }
         3486  +                    zbuf += i;
         3487  +                }
         3488  +                if (z->cmeth == ZIP_COMPMETH_DEFLATED) {
         3489  +                    z_stream stream;
         3490  +                    int err;
         3491  +                    unsigned char *cbuf = NULL;
         3492  +
         3493  +                    memset(&stream, 0, sizeof (stream));
         3494  +                    stream.zalloc = Z_NULL;
         3495  +                    stream.zfree = Z_NULL;
         3496  +                    stream.opaque = Z_NULL;
         3497  +                    stream.avail_in = z->nbytecompr;
         3498  +                        if (z->isenc) {
         3499  +                        unsigned int j;
         3500  +
         3501  +                        stream.avail_in -= 12;
         3502  +                        cbuf = (unsigned char *)
         3503  +                            Tcl_AttemptAlloc(stream.avail_in);
         3504  +                        if (cbuf == NULL) {
         3505  +                            goto merror0;
         3506  +                        }
         3507  +                        for (j = 0; j < stream.avail_in; j++) {
         3508  +                            ch = info->ubuf[j];
         3509  +                            cbuf[j] = zdecode(info->keys, crc32tab, ch);
         3510  +                        }
         3511  +                        stream.next_in = cbuf;
         3512  +                    } else {
         3513  +                        stream.next_in = zbuf;
         3514  +                    }
         3515  +                    stream.next_out = info->ubuf;
         3516  +                    stream.avail_out = info->nmax;
         3517  +                    if (inflateInit2(&stream, -15) != Z_OK) goto cerror0;
         3518  +                    err = inflate(&stream, Z_SYNC_FLUSH);
         3519  +                    inflateEnd(&stream);
         3520  +                    if ((err == Z_STREAM_END) || ((err == Z_OK) && (stream.avail_in == 0))) {
         3521  +                        if (cbuf != NULL) {
         3522  +                            memset(info->keys, 0, sizeof (info->keys));
         3523  +                            Tcl_Free((char *) cbuf);
         3524  +                        }
         3525  +                        goto wrapchan;
         3526  +                    }
         3527  +cerror0:
         3528  +                    if (cbuf != NULL) {
         3529  +                        memset(info->keys, 0, sizeof (info->keys));
         3530  +                        Tcl_Free((char *) cbuf);
         3531  +                    }
         3532  +                    if (info->ubuf != NULL) {
         3533  +                        Tcl_Free((char *) info->ubuf);
         3534  +                    }
         3535  +                    Tcl_Free((char *) info);
         3536  +                    ZIPFS_ERROR(interp,"decompression error");
         3537  +                    goto error;
         3538  +                } else if (z->isenc) {
         3539  +                    for (i = 0; i < z->nbyte - 12; i++) {
         3540  +                        ch = zbuf[i];
         3541  +                        info->ubuf[i] = zdecode(info->keys, crc32tab, ch);
         3542  +                    }
         3543  +                } else {
         3544  +                    memcpy(info->ubuf, zbuf, z->nbyte);
         3545  +                }
         3546  +                memset(info->keys, 0, sizeof (info->keys));
         3547  +                goto wrapchan;
         3548  +            }
         3549  +        }
         3550  +    } else if (z->data != NULL) {
         3551  +        flags |= TCL_READABLE;
         3552  +        info->iswr = 0;
         3553  +        info->iscompr = 0;
         3554  +        info->isdir = 0;
         3555  +        info->isenc = 0;
         3556  +        info->nbyte = z->nbyte;
         3557  +        info->nmax = 0;
         3558  +        info->ubuf = z->data;
         3559  +    } else {
         3560  +        flags |= TCL_READABLE;
         3561  +        info->iswr = 0;
         3562  +        info->iscompr = z->cmeth == ZIP_COMPMETH_DEFLATED;
         3563  +        info->ubuf = z->zipfile->data + z->offset;
         3564  +        info->isdir = z->isdir;
         3565  +        info->isenc = z->isenc;
         3566  +        info->nbyte = z->nbyte;
         3567  +        info->nmax = 0;
         3568  +        if (info->isenc) {
         3569  +            int len = z->zipfile->pwbuf[0];
         3570  +            char pwbuf[260];
         3571  +
         3572  +            for (i = 0; i < len; i++) {
         3573  +                ch = z->zipfile->pwbuf[len - i];
         3574  +                pwbuf[i] = (ch & 0x0f) | pwrot[(ch >> 4) & 0x0f];
         3575  +            }
         3576  +            pwbuf[i] = '\0';
         3577  +            init_keys(pwbuf, info->keys, crc32tab);
         3578  +            memset(pwbuf, 0, sizeof (pwbuf));
         3579  +            for (i = 0; i < 12; i++) {
         3580  +                ch = info->ubuf[i];
         3581  +                zdecode(info->keys, crc32tab, ch);
         3582  +            }
         3583  +            info->ubuf += i;
         3584  +        }
         3585  +        if (info->iscompr) {
         3586  +            z_stream stream;
         3587  +            int err;
         3588  +            unsigned char *ubuf = NULL;
         3589  +            unsigned int j;
         3590  +
         3591  +            memset(&stream, 0, sizeof (stream));
         3592  +            stream.zalloc = Z_NULL;
         3593  +            stream.zfree = Z_NULL;
         3594  +            stream.opaque = Z_NULL;
         3595  +            stream.avail_in = z->nbytecompr;
         3596  +            if (info->isenc) {
         3597  +                stream.avail_in -= 12;
         3598  +                ubuf = (unsigned char *) Tcl_AttemptAlloc(stream.avail_in);
         3599  +                if (ubuf == NULL) {
         3600  +                    info->ubuf = NULL;
         3601  +                    goto merror;
         3602  +                }
         3603  +                for (j = 0; j < stream.avail_in; j++) {
         3604  +                    ch = info->ubuf[j];
         3605  +                    ubuf[j] = zdecode(info->keys, crc32tab, ch);
         3606  +                }
         3607  +                stream.next_in = ubuf;
         3608  +                } else {
         3609  +                stream.next_in = info->ubuf;
         3610  +            }
         3611  +            stream.next_out = info->ubuf = (unsigned char *) Tcl_AttemptAlloc(info->nbyte);
         3612  +            if (info->ubuf == NULL) {
         3613  +merror:
         3614  +                if (ubuf != NULL) {
         3615  +                    info->isenc = 0;
         3616  +                    memset(info->keys, 0, sizeof (info->keys));
         3617  +                    Tcl_Free((char *) ubuf);
         3618  +                }
         3619  +                Tcl_Free((char *) info);
         3620  +                if (interp != NULL) {
         3621  +                    Tcl_SetObjResult(interp,
         3622  +                    Tcl_NewStringObj("out of memory", -1));
         3623  +                }
         3624  +                goto error;
         3625  +            }
         3626  +            stream.avail_out = info->nbyte;
         3627  +            if (inflateInit2(&stream, -15) != Z_OK) {
         3628  +                goto cerror;
         3629  +            }
         3630  +            err = inflate(&stream, Z_SYNC_FLUSH);
         3631  +            inflateEnd(&stream);
         3632  +            if ((err == Z_STREAM_END) || ((err == Z_OK) && (stream.avail_in == 0))) {
         3633  +                if (ubuf != NULL) {
         3634  +                    info->isenc = 0;
         3635  +                    memset(info->keys, 0, sizeof (info->keys));
         3636  +                    Tcl_Free((char *) ubuf);
         3637  +                }
         3638  +                goto wrapchan;
         3639  +            }
         3640  +cerror:
         3641  +            if (ubuf != NULL) {
         3642  +                info->isenc = 0;
         3643  +                memset(info->keys, 0, sizeof (info->keys));
         3644  +                Tcl_Free((char *) ubuf);
         3645  +            }
         3646  +            if (info->ubuf != NULL) {
         3647  +                Tcl_Free((char *) info->ubuf);
         3648  +            }
         3649  +            Tcl_Free((char *) info);
         3650  +            ZIPFS_ERROR(interp,"decompression error");
         3651  +            goto error;
         3652  +        }
         3653  +    }
         3654  +wrapchan:
         3655  +    sprintf(cname, "zipfs_%lx_%d", (unsigned long) z->offset, ZipFS.idCount++);
         3656  +    z->zipfile->nopen++;
         3657  +    Unlock();
         3658  +    return Tcl_CreateChannel(&ZipChannelType, cname, (ClientData) info, flags);
         3659  +
         3660  +error:
         3661  +    Unlock();
         3662  +    return NULL;
         3663  +}
         3664  +
         3665  +/*
         3666  + *-------------------------------------------------------------------------
         3667  + *
         3668  + * ZipEntryStat --
         3669  + *
         3670  + *    This function implements the ZIP filesystem specific version
         3671  + *    of the library version of stat.
         3672  + *
         3673  + * Results:
         3674  + *    See stat documentation.
         3675  + *
         3676  + * Side effects:
         3677  + *    See stat documentation.
         3678  + *
         3679  + *-------------------------------------------------------------------------
         3680  + */
         3681  +
         3682  +static int
         3683  +ZipEntryStat(char *path, Tcl_StatBuf *buf)
         3684  +{
         3685  +    ZipEntry *z;
         3686  +    int ret = -1;
         3687  +
         3688  +    ReadLock();
         3689  +    z = ZipFSLookup(path);
         3690  +    if (z == NULL) goto done;
         3691  +
         3692  +    memset(buf, 0, sizeof (Tcl_StatBuf));
         3693  +    if (z->isdir) {
         3694  +        buf->st_mode = S_IFDIR | 0555;
         3695  +    } else {
         3696  +        buf->st_mode = S_IFREG | 0555;
         3697  +    }
         3698  +    buf->st_size = z->nbyte;
         3699  +    buf->st_mtime = z->timestamp;
         3700  +    buf->st_ctime = z->timestamp;
         3701  +    buf->st_atime = z->timestamp;
         3702  +    ret = 0;
         3703  +done:
         3704  +    Unlock();
         3705  +    return ret;
         3706  +}
         3707  +
         3708  +/*
         3709  + *-------------------------------------------------------------------------
         3710  + *
         3711  + * ZipEntryAccess --
         3712  + *
         3713  + *    This function implements the ZIP filesystem specific version
         3714  + *    of the library version of access.
         3715  + *
         3716  + * Results:
         3717  + *    See access documentation.
         3718  + *
         3719  + * Side effects:
         3720  + *    See access documentation.
         3721  + *
         3722  + *-------------------------------------------------------------------------
         3723  + */
         3724  +
         3725  +static int
         3726  +ZipEntryAccess(char *path, int mode)
         3727  +{
         3728  +    ZipEntry *z;
         3729  +
         3730  +    if (mode & 3) return -1;
         3731  +    ReadLock();
         3732  +    z = ZipFSLookup(path);
         3733  +    Unlock();
         3734  +    return (z != NULL) ? 0 : -1;
         3735  +}
         3736  +
         3737  +/*
         3738  + *-------------------------------------------------------------------------
         3739  + *
         3740  + * Zip_FSOpenFileChannelProc --
         3741  + *
         3742  + * Results:
         3743  + *
         3744  + * Side effects:
         3745  + *
         3746  + *-------------------------------------------------------------------------
         3747  + */
         3748  +
         3749  +static Tcl_Channel
         3750  +Zip_FSOpenFileChannelProc(Tcl_Interp *interp, Tcl_Obj *pathPtr,
         3751  +              int mode, int permissions)
         3752  +{
         3753  +    int len;
         3754  +    if (!(pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr))) return NULL;
         3755  +    return ZipChannelOpen(interp, Tcl_GetStringFromObj(pathPtr, &len), mode, permissions);
         3756  +}
         3757  +
         3758  +/*
         3759  + *-------------------------------------------------------------------------
         3760  + *
         3761  + * Zip_FSStatProc --
         3762  + *
         3763  + *    This function implements the ZIP filesystem specific version
         3764  + *    of the library version of stat.
         3765  + *
         3766  + * Results:
         3767  + *    See stat documentation.
         3768  + *
         3769  + * Side effects:
         3770  + *    See stat documentation.
         3771  + *
         3772  + *-------------------------------------------------------------------------
         3773  + */
         3774  +
         3775  +static int
         3776  +Zip_FSStatProc(Tcl_Obj *pathPtr, Tcl_StatBuf *buf)
         3777  +{
         3778  +    int len;
         3779  +    if (!(pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr))) return -1;
         3780  +    return ZipEntryStat(Tcl_GetStringFromObj(pathPtr, &len), buf);
         3781  +}
         3782  +
         3783  +/*
         3784  + *-------------------------------------------------------------------------
         3785  + *
         3786  + * Zip_FSAccessProc --
         3787  + *
         3788  + *    This function implements the ZIP filesystem specific version
         3789  + *    of the library version of access.
         3790  + *
         3791  + * Results:
         3792  + *    See access documentation.
         3793  + *
         3794  + * Side effects:
         3795  + *    See access documentation.
         3796  + *
         3797  + *-------------------------------------------------------------------------
         3798  + */
         3799  +
         3800  +static int
         3801  +Zip_FSAccessProc(Tcl_Obj *pathPtr, int mode)
         3802  +{
         3803  +    int len;
         3804  +    if (!(pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr))) return -1;
         3805  +    return ZipEntryAccess(Tcl_GetStringFromObj(pathPtr, &len), mode);
         3806  +}
         3807  +
         3808  +/*
         3809  + *-------------------------------------------------------------------------
         3810  + *
         3811  + * Zip_FSFilesystemSeparatorProc --
         3812  + *
         3813  + *    This function returns the separator to be used for a given path. The
         3814  + *    object returned should have a refCount of zero
         3815  + *
         3816  + * Results:
         3817  + *    A Tcl object, with a refCount of zero. If the caller needs to retain a
         3818  + *    reference to the object, it should call Tcl_IncrRefCount, and should
         3819  + *    otherwise free the object.
         3820  + *
         3821  + * Side effects:
         3822  + *    None.
         3823  + *
         3824  + *-------------------------------------------------------------------------
         3825  + */
         3826  +
         3827  +static Tcl_Obj *
         3828  +Zip_FSFilesystemSeparatorProc(Tcl_Obj *pathPtr)
         3829  +{
         3830  +    return Tcl_NewStringObj("/", -1);
         3831  +}
         3832  +
         3833  +/*
         3834  + *-------------------------------------------------------------------------
         3835  + *
         3836  + * Zip_FSMatchInDirectoryProc --
         3837  + *
         3838  + *    This routine is used by the globbing code to search a directory for
         3839  + *    all files which match a given pattern.
         3840  + *
         3841  + * Results:
         3842  + *    The return value is a standard Tcl result indicating whether an
         3843  + *    error occurred in globbing. Errors are left in interp, good
         3844  + *    results are lappend'ed to resultPtr (which must be a valid object).
         3845  + *
         3846  + * Side effects:
         3847  + *    None.
         3848  + *
         3849  + *-------------------------------------------------------------------------
         3850  + */
         3851  +static int
         3852  +Zip_FSMatchInDirectoryProc(Tcl_Interp* interp, Tcl_Obj *result,
         3853  +               Tcl_Obj *pathPtr, const char *pattern,
         3854  +               Tcl_GlobTypeData *types)
         3855  +{
         3856  +    Tcl_HashEntry *hPtr;
         3857  +    Tcl_HashSearch search;
         3858  +    Tcl_Obj *normPathPtr;
         3859  +    int scnt, len, l, dirOnly = -1, prefixLen, strip = 0;
         3860  +    char *pat, *prefix, *path;
         3861  +    Tcl_DString dsPref;
         3862  +
         3863  +    if (!(normPathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr))) return -1;
         3864  +
         3865  +    if (types != NULL) {
         3866  +        dirOnly = (types->type & TCL_GLOB_TYPE_DIR) == TCL_GLOB_TYPE_DIR;
         3867  +    }
         3868  +
         3869  +    /* the prefix that gets prepended to results */
         3870  +    prefix = Tcl_GetStringFromObj(pathPtr, &prefixLen);
         3871  +
         3872  +    /* the (normalized) path we're searching */
         3873  +    path = Tcl_GetStringFromObj(normPathPtr, &len);
         3874  +
         3875  +    Tcl_DStringInit(&dsPref);
         3876  +    Tcl_DStringAppend(&dsPref, prefix, prefixLen);
         3877  +
         3878  +    if (strcmp(prefix, path) == 0) {
         3879  +        prefix = NULL;
         3880  +    } else {
         3881  +        strip = len + 1;
         3882  +    }
         3883  +    if (prefix != NULL) {
         3884  +        Tcl_DStringAppend(&dsPref, "/", 1);
         3885  +        prefixLen++;
         3886  +        prefix = Tcl_DStringValue(&dsPref);
         3887  +    }
         3888  +    ReadLock();
         3889  +    if ((types != NULL) && (types->type == TCL_GLOB_TYPE_MOUNT)) {
         3890  +    l = CountSlashes(path);
         3891  +    if (path[len - 1] == '/') {
         3892  +        len--;
         3893  +    } else {
         3894  +        l++;
         3895  +    }
         3896  +    if ((pattern == NULL) || (pattern[0] == '\0')) {
         3897  +        pattern = "*";
         3898  +    }
         3899  +    hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search);
         3900  +    while (hPtr != NULL) {
         3901  +        ZipFile *zf = (ZipFile *) Tcl_GetHashValue(hPtr);
         3902  +
         3903  +        if (zf->mntptlen == 0) {
         3904  +            ZipEntry *z = zf->topents;
         3905  +            while (z != NULL) {
         3906  +                int lenz = strlen(z->name);
         3907  +                if (
         3908  +                    (lenz > len + 1)
         3909  +                    && (strncmp(z->name, path, len) == 0)
         3910  +                    && (z->name[len] == '/')
         3911  +                    && (CountSlashes(z->name) == l)
         3912  +                    && Tcl_StringCaseMatch(z->name + len + 1, pattern, 0)
         3913  +                ) {
         3914  +                    if (prefix != NULL) {
         3915  +                        Tcl_DStringAppend(&dsPref, z->name, lenz);
         3916  +                        Tcl_ListObjAppendElement(
         3917  +                            NULL, result,
         3918  +                            Tcl_NewStringObj(Tcl_DStringValue(&dsPref),
         3919  +                            Tcl_DStringLength(&dsPref))
         3920  +                        );
         3921  +                        Tcl_DStringSetLength(&dsPref, prefixLen);
         3922  +                    } else {
         3923  +                        Tcl_ListObjAppendElement(NULL, result, Tcl_NewStringObj(z->name, lenz));
         3924  +                    }
         3925  +                }
         3926  +                z = z->tnext;
         3927  +            }
         3928  +        } else if (
         3929  +            (zf->mntptlen > len + 1)
         3930  +            && (strncmp(zf->mntpt, path, len) == 0)
         3931  +            && (zf->mntpt[len] == '/')
         3932  +            && (CountSlashes(zf->mntpt) == l)
         3933  +            && Tcl_StringCaseMatch(zf->mntpt + len + 1, pattern, 0)
         3934  +        ) {
         3935  +            if (prefix != NULL) {
         3936  +                Tcl_DStringAppend(&dsPref, zf->mntpt, zf->mntptlen);
         3937  +                Tcl_ListObjAppendElement(NULL, result,
         3938  +                    Tcl_NewStringObj(Tcl_DStringValue(&dsPref),
         3939  +                    Tcl_DStringLength(&dsPref)));
         3940  +                Tcl_DStringSetLength(&dsPref, prefixLen);
         3941  +            } else {
         3942  +                Tcl_ListObjAppendElement(NULL, result,
         3943  +                    Tcl_NewStringObj(zf->mntpt, zf->mntptlen));
         3944  +            }
         3945  +        }
         3946  +        hPtr = Tcl_NextHashEntry(&search);
         3947  +    }
         3948  +    goto end;
         3949  +    }
         3950  +    if ((pattern == NULL) || (pattern[0] == '\0')) {
         3951  +    hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, path);
         3952  +    if (hPtr != NULL) {
         3953  +        ZipEntry *z = (ZipEntry *) Tcl_GetHashValue(hPtr);
         3954  +
         3955  +        if ((dirOnly < 0) ||
         3956  +            (!dirOnly && !z->isdir) ||
         3957  +            (dirOnly && z->isdir)) {
         3958  +        if (prefix != NULL) {
         3959  +            Tcl_DStringAppend(&dsPref, z->name, -1);
         3960  +            Tcl_ListObjAppendElement(NULL, result,
         3961  +                Tcl_NewStringObj(Tcl_DStringValue(&dsPref),
         3962  +                Tcl_DStringLength(&dsPref)));
         3963  +            Tcl_DStringSetLength(&dsPref, prefixLen);
         3964  +        } else {
         3965  +            Tcl_ListObjAppendElement(NULL, result,
         3966  +                Tcl_NewStringObj(z->name, -1));
         3967  +        }
         3968  +        }
         3969  +    }
         3970  +    goto end;
         3971  +    }
         3972  +    l = strlen(pattern);
         3973  +    pat = Tcl_Alloc(len + l + 2);
         3974  +    memcpy(pat, path, len);
         3975  +    while ((len > 1) && (pat[len - 1] == '/')) {
         3976  +        --len;
         3977  +    }
         3978  +    if ((len > 1) || (pat[0] != '/')) {
         3979  +        pat[len] = '/';
         3980  +        ++len;
         3981  +    }
         3982  +    memcpy(pat + len, pattern, l + 1);
         3983  +    scnt = CountSlashes(pat);
         3984  +    for (
         3985  +        hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search);
         3986  +        hPtr != NULL;
         3987  +        hPtr = Tcl_NextHashEntry(&search)
         3988  +    ) {
         3989  +        ZipEntry *z = (ZipEntry *) Tcl_GetHashValue(hPtr);
         3990  +        if (
         3991  +            (dirOnly >= 0) && ((dirOnly && !z->isdir) || (!dirOnly && z->isdir))
         3992  +        ) {
         3993  +            continue;
         3994  +        }
         3995  +        if ((z->depth == scnt) && Tcl_StringCaseMatch(z->name, pat, 0)) {
         3996  +            if (prefix != NULL) {
         3997  +                Tcl_DStringAppend(&dsPref, z->name + strip, -1);
         3998  +                Tcl_ListObjAppendElement(
         3999  +                    NULL, result,
         4000  +                    Tcl_NewStringObj(Tcl_DStringValue(&dsPref),
         4001  +                    Tcl_DStringLength(&dsPref))
         4002  +                );
         4003  +                Tcl_DStringSetLength(&dsPref, prefixLen);
         4004  +            } else {
         4005  +                Tcl_ListObjAppendElement(NULL, result, Tcl_NewStringObj(z->name + strip, -1));
         4006  +            }
         4007  +        }
         4008  +    }
         4009  +    Tcl_Free(pat);
         4010  +end:
         4011  +    Unlock();
         4012  +    Tcl_DStringFree(&dsPref);
         4013  +    return TCL_OK;
         4014  +}
         4015  +
         4016  +/*
         4017  + *-------------------------------------------------------------------------
         4018  + *
         4019  + * Zip_FSPathInFilesystemProc --
         4020  + *
         4021  + *    This function determines if the given path object is in the
         4022  + *    ZIP filesystem.
         4023  + *
         4024  + * Results:
         4025  + *    TCL_OK when the path object is in the ZIP filesystem, -1 otherwise.
         4026  + *
         4027  + * Side effects:
         4028  + *    None.
         4029  + *
         4030  + *-------------------------------------------------------------------------
         4031  + */
         4032  +
         4033  +static int
         4034  +Zip_FSPathInFilesystemProc(Tcl_Obj *pathPtr, ClientData *clientDataPtr)
         4035  +{
         4036  +    Tcl_HashEntry *hPtr;
         4037  +    Tcl_HashSearch search;
         4038  +    ZipFile *zf;
         4039  +    int ret = -1, len;
         4040  +    char *path;
         4041  +
         4042  +    if (!(pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr))) return -1;
         4043  +
         4044  +    path = Tcl_GetStringFromObj(pathPtr, &len);
         4045  +    if(strncmp(path,ZIPFS_VOLUME,ZIPFS_VOLUME_LEN)!=0) {
         4046  +        return -1;
         4047  +    }
         4048  +
         4049  +    len = strlen(path);
         4050  +
         4051  +    ReadLock();
         4052  +    hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, path);
         4053  +    if (hPtr != NULL) {
         4054  +        ret = TCL_OK;
         4055  +        goto endloop;
         4056  +    }
         4057  +    hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search);
         4058  +    while (hPtr != NULL) {
         4059  +        zf = (ZipFile *) Tcl_GetHashValue(hPtr);
         4060  +        if (zf->mntptlen == 0) {
         4061  +            ZipEntry *z = zf->topents;
         4062  +            while (z != NULL) {
         4063  +                int lenz = strlen(z->name);
         4064  +                if (
         4065  +                    (len >= lenz) && (strncmp(path, z->name, lenz) == 0)
         4066  +                ) {
         4067  +                    ret = TCL_OK;
         4068  +                    goto endloop;
         4069  +                }
         4070  +                z = z->tnext;
         4071  +            }
         4072  +        } else if (
         4073  +            (len >= zf->mntptlen) && (strncmp(path, zf->mntpt, zf->mntptlen) == 0)
         4074  +        ) {
         4075  +            ret = TCL_OK;
         4076  +            goto endloop;
         4077  +        }
         4078  +        hPtr = Tcl_NextHashEntry(&search);
         4079  +    }
         4080  +endloop:
         4081  +    Unlock();
         4082  +    return ret;
         4083  +}
         4084  +
         4085  +/*
         4086  + *-------------------------------------------------------------------------
         4087  + *
         4088  + * Zip_FSListVolumesProc --
         4089  + *
         4090  + *    Lists the currently mounted ZIP filesystem volumes.
         4091  + *
         4092  + * Results:
         4093  + *    The list of volumes.
         4094  + *
         4095  + * Side effects:
         4096  + *    None
         4097  + *
         4098  + *-------------------------------------------------------------------------
         4099  + */
         4100  +static Tcl_Obj *
         4101  +Zip_FSListVolumesProc(void) {
         4102  +    return Tcl_NewStringObj(ZIPFS_VOLUME, -1);
         4103  +}
         4104  +
         4105  +/*
         4106  + *-------------------------------------------------------------------------
         4107  + *
         4108  + * Zip_FSFileAttrStringsProc --
         4109  + *
         4110  + *    This function implements the ZIP filesystem dependent 'file attributes'
         4111  + *    subcommand, for listing the set of possible attribute strings.
         4112  + *
         4113  + * Results:
         4114  + *    An array of strings
         4115  + *
         4116  + * Side effects:
         4117  + *    None.
         4118  + *
         4119  + *-------------------------------------------------------------------------
         4120  + */
         4121  +
         4122  +static const char *const *
         4123  +Zip_FSFileAttrStringsProc(Tcl_Obj *pathPtr, Tcl_Obj** objPtrRef)
         4124  +{
         4125  +    static const char *const attrs[] = {
         4126  +    "-uncompsize",
         4127  +    "-compsize",
         4128  +    "-offset",
         4129  +    "-mount",
         4130  +    "-archive",
         4131  +    "-permissions",
         4132  +    NULL,
         4133  +    };
         4134  +    return attrs;
         4135  +}
         4136  +
         4137  +/*
         4138  + *-------------------------------------------------------------------------
         4139  + *
         4140  + * Zip_FSFileAttrsGetProc --
         4141  + *
         4142  + *    This function implements the ZIP filesystem specific
         4143  + *    'file attributes' subcommand, for 'get' operations.
         4144  + *
         4145  + * Results:
         4146  + *    Standard Tcl return code. The object placed in objPtrRef (if TCL_OK
         4147  + *    was returned) is likely to have a refCount of zero. Either way we must
         4148  + *    either store it somewhere (e.g. the Tcl result), or Incr/Decr its
         4149  + *    refCount to ensure it is properly freed.
         4150  + *
         4151  + * Side effects:
         4152  + *    None.
         4153  + *
         4154  + *-------------------------------------------------------------------------
         4155  + */
         4156  +
         4157  +static int
         4158  +Zip_FSFileAttrsGetProc(Tcl_Interp *interp, int index, Tcl_Obj *pathPtr,
         4159  +               Tcl_Obj **objPtrRef)
         4160  +{
         4161  +    int len, ret = TCL_OK;
         4162  +    char *path;
         4163  +    ZipEntry *z;
         4164  +
         4165  +    if (!(pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr))) return -1;
         4166  +    path = Tcl_GetStringFromObj(pathPtr, &len);
         4167  +    ReadLock();
         4168  +    z = ZipFSLookup(path);
         4169  +    if (z == NULL) {
         4170  +        ZIPFS_ERROR(interp,"file not found");
         4171  +        ret = TCL_ERROR;
         4172  +        goto done;
         4173  +    }
         4174  +    switch (index) {
         4175  +        case 0:
         4176  +        *objPtrRef = Tcl_NewIntObj(z->nbyte);
         4177  +        goto done;
         4178  +        case 1:
         4179  +        *objPtrRef= Tcl_NewIntObj(z->nbytecompr);
         4180  +        goto done;
         4181  +        case 2:
         4182  +        *objPtrRef= Tcl_NewLongObj(z->offset);
         4183  +        goto done;
         4184  +        case 3:
         4185  +        *objPtrRef= Tcl_NewStringObj(z->zipfile->mntpt, z->zipfile->mntptlen);
         4186  +        goto done;
         4187  +        case 4:
         4188  +        *objPtrRef= Tcl_NewStringObj(z->zipfile->name, -1);
         4189  +        goto done;
         4190  +        case 5:
         4191  +        *objPtrRef= Tcl_NewStringObj("0555", -1);
         4192  +        goto done;
         4193  +    }
         4194  +    ZIPFS_ERROR(interp,"unknown attribute");
         4195  +    ret = TCL_ERROR;
         4196  +done:
         4197  +    Unlock();
         4198  +    return ret;
         4199  +}
         4200  +
         4201  +/*
         4202  + *-------------------------------------------------------------------------
         4203  + *
         4204  + * Zip_FSFileAttrsSetProc --
         4205  + *
         4206  + *    This function implements the ZIP filesystem specific
         4207  + *    'file attributes' subcommand, for 'set' operations.
         4208  + *
         4209  + * Results:
         4210  + *    Standard Tcl return code.
         4211  + *
         4212  + * Side effects:
         4213  + *    None.
         4214  + *
         4215  + *-------------------------------------------------------------------------
         4216  + */
         4217  +
         4218  +static int
         4219  +Zip_FSFileAttrsSetProc(Tcl_Interp *interp, int index, Tcl_Obj *pathPtr,Tcl_Obj *objPtr)
         4220  +{
         4221  +    if (interp != NULL) {
         4222  +        Tcl_SetObjResult(interp, Tcl_NewStringObj("unsupported operation", -1));
         4223  +    }
         4224  +    return TCL_ERROR;
         4225  +}
         4226  +
         4227  +/*
         4228  + *-------------------------------------------------------------------------
         4229  + *
         4230  + * Zip_FSFilesystemPathTypeProc --
         4231  + *
         4232  + * Results:
         4233  + *
         4234  + * Side effects:
         4235  + *
         4236  + *-------------------------------------------------------------------------
         4237  + */
         4238  +
         4239  +static Tcl_Obj *
         4240  +Zip_FSFilesystemPathTypeProc(Tcl_Obj *pathPtr)
         4241  +{
         4242  +    return Tcl_NewStringObj("zip", -1);
         4243  +}
         4244  +
         4245  +
         4246  +/*
         4247  + *-------------------------------------------------------------------------
         4248  + *
         4249  + * Zip_FSLoadFile --
         4250  + *
         4251  + *        This functions deals with loading native object code. If
         4252  + *        the given path object refers to a file within the ZIP
         4253  + *        filesystem, an approriate error code is returned to delegate
         4254  + *        loading to the caller (by copying the file to temp store
         4255  + *        and loading from there). As fallback when the file refers
         4256  + *        to the ZIP file system but is not present, it is looked up
         4257  + *        relative to the executable and loaded from there when available.
         4258  + *
         4259  + * Results:
         4260  + *        TCL_OK on success, TCL_ERROR otherwise with error message left.
         4261  + *
         4262  + * Side effects:
         4263  + *        Loads native code into the process address space.
         4264  + *
         4265  + *-------------------------------------------------------------------------
         4266  + */
         4267  +
         4268  +static int
         4269  +Zip_FSLoadFile(Tcl_Interp *interp, Tcl_Obj *path, Tcl_LoadHandle *loadHandle,
         4270  +               Tcl_FSUnloadFileProc **unloadProcPtr, int flags)
         4271  +{
         4272  +    Tcl_FSLoadFileProc2 *loadFileProc;
         4273  +#ifdef ANDROID
         4274  +    /*
         4275  +     * Force loadFileProc to native implementation since the
         4276  +     * package manager already extracted the shared libraries
         4277  +     * from the APK at install time.
         4278  +     */
         4279  +
         4280  +    loadFileProc = (Tcl_FSLoadFileProc2 *) tclNativeFilesystem.loadFileProc;
         4281  +    if (loadFileProc != NULL) {
         4282  +        return loadFileProc(interp, path, loadHandle, unloadProcPtr, flags);
         4283  +    }
         4284  +    Tcl_SetErrno(ENOENT);
         4285  +    ZIPFS_ERROR(interp,Tcl_PosixError(interp));
         4286  +    return TCL_ERROR;
         4287  +#else
         4288  +    Tcl_Obj *altPath = NULL;
         4289  +    int ret = TCL_ERROR;
         4290  +
         4291  +    if (Tcl_FSAccess(path, R_OK) == 0) {
         4292  +        /*
         4293  +         * EXDEV should trigger loading by copying to temp store.
         4294  +         */
         4295  +
         4296  +        Tcl_SetErrno(EXDEV);
         4297  +        ZIPFS_ERROR(interp,Tcl_PosixError(interp));
         4298  +        return ret;
         4299  +    } else {
         4300  +        Tcl_Obj *objs[2] = { NULL, NULL };
         4301  +
         4302  +        objs[1] = TclPathPart(interp, path, TCL_PATH_DIRNAME);
         4303  +        if ((objs[1] != NULL) && (Zip_FSAccessProc(objs[1], R_OK) == 0)) {
         4304  +            const char *execName = Tcl_GetNameOfExecutable();
         4305  +
         4306  +            /*
         4307  +             * Shared object is not in ZIP but its path prefix is,
         4308  +             * thus try to load from directory where the executable
         4309  +             * came from.
         4310  +             */
         4311  +            TclDecrRefCount(objs[1]);
         4312  +            objs[1] = TclPathPart(interp, path, TCL_PATH_TAIL);
         4313  +            /*
         4314  +             * Get directory name of executable manually to deal
         4315  +             * with cases where [file dirname [info nameofexecutable]]
         4316  +             * is equal to [info nameofexecutable] due to VFS effects.
         4317  +             */
         4318  +            if (execName != NULL) {
         4319  +                const char *p = strrchr(execName, '/');
         4320  +
         4321  +                if (p > execName + 1) {
         4322  +                    --p;
         4323  +                    objs[0] = Tcl_NewStringObj(execName, p - execName);
         4324  +                }
         4325  +            }
         4326  +            if (objs[0] == NULL) {
         4327  +                objs[0] = TclPathPart(interp, TclGetObjNameOfExecutable(),
         4328  +                                          TCL_PATH_DIRNAME);
         4329  +            }
         4330  +            if (objs[0] != NULL) {
         4331  +#if TCL_RELEASE_SERIAL < 9
         4332  +                altPath = TclJoinPath(2, objs);
         4333  +#else
         4334  +                altPath = TclJoinPath(2, objs, 0);
         4335  +#endif
         4336  +                if (altPath != NULL) {
         4337  +                    Tcl_IncrRefCount(altPath);
         4338  +                    if (Tcl_FSAccess(altPath, R_OK) == 0) {
         4339  +                        path = altPath;
         4340  +                    }
         4341  +                }
         4342  +            }
         4343  +        }
         4344  +        if (objs[0] != NULL) {
         4345  +            Tcl_DecrRefCount(objs[0]);
         4346  +        }
         4347  +        if (objs[1] != NULL) {
         4348  +            Tcl_DecrRefCount(objs[1]);
         4349  +        }
         4350  +    }
         4351  +    loadFileProc = (Tcl_FSLoadFileProc2 *) tclNativeFilesystem.loadFileProc;
         4352  +    if (loadFileProc != NULL) {
         4353  +        ret = loadFileProc(interp, path, loadHandle, unloadProcPtr, flags);
         4354  +    } else {
         4355  +        Tcl_SetErrno(ENOENT);
         4356  +        ZIPFS_ERROR(interp,Tcl_PosixError(interp));
         4357  +    }
         4358  +    if (altPath != NULL) {
         4359  +        Tcl_DecrRefCount(altPath);
         4360  +    }
         4361  +    return ret;
         4362  +#endif
         4363  +}
         4364  +
         4365  +#endif /* HAVE_ZLIB */
         4366  +
         4367  +
         4368  +
         4369  +/*
         4370  + *-------------------------------------------------------------------------
         4371  + *
         4372  + * TclZipfs_Init --
         4373  + *
         4374  + *    Perform per interpreter initialization of this module.
         4375  + *
         4376  + * Results:
         4377  + *    The return value is a standard Tcl result.
         4378  + *
         4379  + * Side effects:
         4380  + *    Initializes this module if not already initialized, and adds
         4381  + *    module related commands to the given interpreter.
         4382  + *
         4383  + *-------------------------------------------------------------------------
         4384  + */
         4385  +
         4386  +MODULE_SCOPE int
         4387  +TclZipfs_Init(Tcl_Interp *interp)
         4388  +{
         4389  +#ifdef HAVE_ZLIB
         4390  +    /* one-time initialization */
         4391  +    WriteLock();
         4392  +    /* Tcl_StaticPackage(interp, "zipfs", TclZipfs_Init, TclZipfs_Init); */
         4393  +    if (!ZipFS.initialized) {
         4394  +        TclZipfs_C_Init();
         4395  +    }
         4396  +    Unlock();
         4397  +    if(interp != NULL) {
         4398  +        static const EnsembleImplMap initMap[] = {
         4399  +            {"mount",      ZipFSMountObjCmd,    NULL, NULL, NULL, 0},
         4400  +            {"mount_data",      ZipFSMountBufferObjCmd,    NULL, NULL, NULL, 0},
         4401  +            {"unmount",      ZipFSUnmountObjCmd,    NULL, NULL, NULL, 0},
         4402  +            {"mkkey",      ZipFSMkKeyObjCmd,    NULL, NULL, NULL, 0},
         4403  +            {"mkimg",      ZipFSMkImgObjCmd,    NULL, NULL, NULL, 0},
         4404  +            {"mkzip",      ZipFSMkZipObjCmd,    NULL, NULL, NULL, 0},
         4405  +            {"lmkimg",      ZipFSLMkImgObjCmd,    NULL, NULL, NULL, 0},
         4406  +            {"lmkzip",      ZipFSLMkZipObjCmd,    NULL, NULL, NULL, 0},
         4407  +            {"exists",      ZipFSExistsObjCmd,    NULL, NULL, NULL, 1},
         4408  +            {"info",      ZipFSInfoObjCmd,    NULL, NULL, NULL, 1},
         4409  +            {"list",      ZipFSListObjCmd,    NULL, NULL, NULL, 1},
         4410  +            {"canonical", ZipFSCanonicalObjCmd, NULL, NULL, NULL, 1},
         4411  +            {"root",      ZipFSRootObjCmd, NULL, NULL, NULL, 1},
         4412  +            {"tcl_library",      ZipFSTclLibraryObjCmd,    NULL, NULL, NULL, 0},
         4413  +
         4414  +            {NULL, NULL, NULL, NULL, NULL, 0}
         4415  +        };
         4416  +        static const char findproc[] =
         4417  +            "namespace eval ::tcl::zipfs::zipfs {}\n"
         4418  +            "proc ::tcl::zipfs::find dir {\n"
         4419  +            " set result {}\n"
         4420  +            " if {[catch {glob -directory $dir -tails -nocomplain * .*} list]} {\n"
         4421  +            "  return $result\n"
         4422  +            " }\n"
         4423  +            " foreach file $list {\n"
         4424  +            "  if {$file eq \".\" || $file eq \"..\"} {\n"
         4425  +            "   continue\n"
         4426  +            "  }\n"
         4427  +            "  set file [file join $dir $file]\n"
         4428  +            "  lappend result $file\n"
         4429  +            "  foreach file [::tcl::zipfs::find $file] {\n"
         4430  +            "   lappend result $file\n"
         4431  +            "  }\n"
         4432  +            " }\n"
         4433  +            " return [lsort $result]\n"
         4434  +            "}\n";
         4435  +        Tcl_EvalEx(interp, findproc, -1, TCL_EVAL_GLOBAL);
         4436  +        Tcl_LinkVar(interp, "::tcl::zipfs::wrmax", (char *) &ZipFS.wrmax,TCL_LINK_INT);
         4437  +        TclMakeEnsemble(interp, "zipfs", initMap);
         4438  +        Tcl_PkgProvide(interp, "zipfs", "2.0");
         4439  +    }
         4440  +    return TCL_OK;
         4441  +#else
         4442  +    ZIPFS_ERROR(interp,"no zlib available");
         4443  +    return TCL_ERROR;
         4444  +#endif
         4445  +}
         4446  +
         4447  +static int TclZipfs_AppHook_FindTclInit(const char *archive){
         4448  +    Tcl_Obj *vfsinitscript;
         4449  +    int found;
         4450  +    if(zipfs_literal_tcl_library) {
         4451  +        return TCL_ERROR;
         4452  +    }
         4453  +    if(TclZipfs_Mount(NULL, ZIPFS_ZIP_MOUNT, archive, NULL)) {
         4454  +        /* Either the file doesn't exist or it is not a zip archive */
         4455  +        return TCL_ERROR;
         4456  +    }
         4457  +    vfsinitscript=Tcl_NewStringObj(ZIPFS_ZIP_MOUNT "/init.tcl",-1);
         4458  +    Tcl_IncrRefCount(vfsinitscript);
         4459  +    found=Tcl_FSAccess(vfsinitscript,F_OK);
         4460  +    Tcl_DecrRefCount(vfsinitscript);
         4461  +    if(found==0) {
         4462  +        zipfs_literal_tcl_library=ZIPFS_ZIP_MOUNT;
         4463  +        return TCL_OK;
         4464  +    }
         4465  +    vfsinitscript=Tcl_NewStringObj(ZIPFS_ZIP_MOUNT "/tcl_library/init.tcl",-1);
         4466  +    Tcl_IncrRefCount(vfsinitscript);
         4467  +    found=Tcl_FSAccess(vfsinitscript,F_OK);
         4468  +    Tcl_DecrRefCount(vfsinitscript);
         4469  +    if(found==0) {
         4470  +        zipfs_literal_tcl_library=ZIPFS_ZIP_MOUNT "/tcl_library";
         4471  +        return TCL_OK;
         4472  +    }
         4473  +    return TCL_ERROR;
         4474  +}
         4475  +
         4476  +#if defined(_WIN32) || defined(_WIN64)
         4477  +int TclZipfs_AppHook(int *argc, TCHAR ***argv)
         4478  +#else
         4479  +int TclZipfs_AppHook(int *argc, char ***argv)
         4480  +#endif
         4481  +{
         4482  +    /*
         4483  +     * Tclkit_MainHook --
         4484  +     * Performs the argument munging for the shell
         4485  +     */
         4486  +    char *archive;
         4487  +
         4488  +    Tcl_FindExecutable(*argv[0]);
         4489  +    archive=(char *)Tcl_GetNameOfExecutable();
         4490  +    TclZipfs_Init(NULL);
         4491  +    /*
         4492  +    ** Look for init.tcl in one of the locations mounted later in this function
         4493  +    */
         4494  +    if(!TclZipfs_Mount(NULL, ZIPFS_APP_MOUNT, archive, NULL)) {
         4495  +        int found;
         4496  +        Tcl_Obj *vfsinitscript;
         4497  +        vfsinitscript=Tcl_NewStringObj(ZIPFS_APP_MOUNT "/main.tcl",-1);
         4498  +        Tcl_IncrRefCount(vfsinitscript);
         4499  +        if(Tcl_FSAccess(vfsinitscript,F_OK)==0) {
         4500  +            /* Startup script should be set before calling Tcl_AppInit */
         4501  +            Tcl_SetStartupScript(vfsinitscript,NULL);
         4502  +        } else {
         4503  +            Tcl_DecrRefCount(vfsinitscript);
         4504  +        }
         4505  +        /* Set Tcl Encodings */
         4506  +        if(!zipfs_literal_tcl_library) {
         4507  +            vfsinitscript=Tcl_NewStringObj(ZIPFS_APP_MOUNT "/tcl_library/init.tcl",-1);
         4508  +            Tcl_IncrRefCount(vfsinitscript);
         4509  +            found=Tcl_FSAccess(vfsinitscript,F_OK);
         4510  +            Tcl_DecrRefCount(vfsinitscript);
         4511  +            if(found==TCL_OK) {
         4512  +                zipfs_literal_tcl_library=ZIPFS_APP_MOUNT "/tcl_library";
         4513  +                return TCL_OK;
         4514  +            }
         4515  +        }
         4516  +    } else if (*argc>1) {
         4517  +#if defined(_WIN32) || defined(_WIN64)
         4518  +        Tcl_DString ds;
         4519  +          strcpy(archive, Tcl_WinTCharToUtf((*argv)[1], -1, &ds));
         4520  +        Tcl_DStringFree(&ds);
         4521  +#else
         4522  +        archive=(*argv)[1];
         4523  +#endif
         4524  +        if(strcmp(archive,"install")==0) {
         4525  +            /* If the first argument is mkzip, run the mkzip program */
         4526  +            Tcl_Obj *vfsinitscript;
         4527  +            /* Run this now to ensure the file is present by the time Tcl_Main wants it */
         4528  +            TclZipfs_TclLibrary();
         4529  +            vfsinitscript=Tcl_NewStringObj(ZIPFS_ZIP_MOUNT "/tcl_library/install.tcl",-1);
         4530  +            Tcl_IncrRefCount(vfsinitscript);
         4531  +            if(Tcl_FSAccess(vfsinitscript,F_OK)==0) {
         4532  +             Tcl_SetStartupScript(vfsinitscript,NULL);
         4533  +            }
         4534  +            return TCL_OK;
         4535  +        } else {
         4536  +            if(!TclZipfs_Mount(NULL, ZIPFS_APP_MOUNT, archive, NULL)) {
         4537  +                int found;
         4538  +                Tcl_Obj *vfsinitscript;
         4539  +                vfsinitscript=Tcl_NewStringObj(ZIPFS_APP_MOUNT "/main.tcl",-1);
         4540  +                Tcl_IncrRefCount(vfsinitscript);
         4541  +                if(Tcl_FSAccess(vfsinitscript,F_OK)==0) {
         4542  +                    /* Startup script should be set before calling Tcl_AppInit */
         4543  +                    Tcl_SetStartupScript(vfsinitscript,NULL);
         4544  +                } else {
         4545  +                    Tcl_DecrRefCount(vfsinitscript);
         4546  +                }
         4547  +                /* Set Tcl Encodings */
         4548  +                vfsinitscript=Tcl_NewStringObj(ZIPFS_APP_MOUNT "/tcl_library/init.tcl",-1);
         4549  +                Tcl_IncrRefCount(vfsinitscript);
         4550  +                found=Tcl_FSAccess(vfsinitscript,F_OK);
         4551  +                Tcl_DecrRefCount(vfsinitscript);
         4552  +                if(found==TCL_OK) {
         4553  +                    zipfs_literal_tcl_library=ZIPFS_APP_MOUNT "/tcl_library";
         4554  +                    return TCL_OK;
         4555  +                }
         4556  +            }
         4557  +        }
         4558  +    }
         4559  +    return TCL_OK;
         4560  +}
         4561  +
         4562  +
         4563  +
         4564  +#ifndef HAVE_ZLIB
         4565  +
         4566  +/*
         4567  + *-------------------------------------------------------------------------
         4568  + *
         4569  + * TclZipfs_Mount, TclZipfs_Unmount --
         4570  + *
         4571  + *    Dummy version when no ZLIB support available.
         4572  + *
         4573  + *-------------------------------------------------------------------------
         4574  + */
         4575  +
         4576  +int
         4577  +TclZipfs_Mount(Tcl_Interp *interp, const char *mntpt, const char *zipname,
         4578  +        const char *passwd)
         4579  +{
         4580  +    return TclZipfs_Init(interp, 1);
         4581  +}
         4582  +
         4583  +int
         4584  +TclZipfs_Unmount(Tcl_Interp *interp, const char *zipname)
         4585  +{
         4586  +    return TclZipfs_Init(interp, 1);
         4587  +}
         4588  +
         4589  +#endif
         4590  +
         4591  +/*
         4592  + * Local Variables:
         4593  + * mode: c
         4594  + * c-basic-offset: 4
         4595  + * fill-column: 78
         4596  + * End:
         4597  + */

Added config.tcl.in.

            1  +###
            2  +# Tcl Parsable version of data from xxxConfig.sh
            3  +###
            4  +name {@[email protected]}
            5  +version {@[email protected]}
            6  +libfile {@[email protected]}
            7  +srcdir  {@[email protected]}
            8  +prefix  {@[email protected]}
            9  +exec_prefix {@[email protected]}
           10  +exeext  {@[email protected]}
           11  +tk      {@[email protected]}
           12  +
           13  +bindir {@[email protected]}
           14  +libdir {@[email protected]}
           15  +includedir {@[email protected]}
           16  +datarootdir	{@[email protected]}
           17  +datadir {@[email protected]}
           18  +mandir  {@[email protected]}
           19  +cleanfiles {@[email protected]}
           20  +
           21  +AR		{@[email protected]}
           22  +CC		{@[email protected]}
           23  +CFLAGS          {@[email protected]}
           24  +CFLAGS_DEBUG	{@[email protected]}
           25  +CFLAGS_OPTIMIZE	{@[email protected]}
           26  +CFLAGS_DEFAULT	{@[email protected]}
           27  +CFLAGS_WARNING	{@[email protected]}
           28  +CPPFLAGS        {@[email protected]}
           29  +DEFS  {@[email protected] @[email protected]}
           30  +EXEEXT		{@[email protected]}
           31  +LDFLAGS {@[email protected]}
           32  +LDFLAGS_DEFAULT	{@[email protected]}
           33  +LIBS    {@[email protected] @[email protected]}
           34  +MAKE_LIB	{@[email protected]}
           35  +MAKE_SHARED_LIB	{@[email protected]}
           36  +MAKE_STATIC_LIB	{@[email protected]}
           37  +MAKE_STUB_LIB	{@[email protected]}
           38  +OBJEXT		{@[email protected]}
           39  +PKG_CFLAGS      {@[email protected]}
           40  +RANLIB		{@[email protected]}
           41  +RANLIB_STUB	{@[email protected]}
           42  +
           43  +SHELL           {@[email protected]}
           44  +
           45  +SHARED_BUILD  {@[email protected]}
           46  +
           47  +SHLIB_CFLAGS	{@[email protected]}
           48  +SHLIB_LD	{@[email protected]}
           49  +SHLIB_LD_LIBS	{@[email protected]}
           50  +SHLIB_SUFFIX  {@[email protected]}
           51  +STLIB_LD	{@[email protected]}
           52  +TCL_DEFS	{@[email protected]}
           53  +TCL_VERSION {@[email protected]}
           54  +TCL_PATCH_LEVEL {@[email protected]}
           55  +TCL_BIN_DIR	{@[email protected]}
           56  +TCL_SRC_DIR	{@[email protected]}
           57  +TEA_TK_EXTENSION {@[email protected]}
           58  +
           59  +TK_VERSION {@[email protected]}
           60  +TK_PATCH_LEVEL {@[email protected]}
           61  +TK_BIN_DIR	{@[email protected]}
           62  +TK_SRC_DIR	{@[email protected]}
           63  +
           64  +TEA_PLATFORM {@[email protected]}
           65  +TEA_WINDOWINGSYSTEM {@[email protected]}
           66  +TEA_SYSTEM {@[email protected]}
           67  +TEACUP_OS {@[email protected]}
           68  +TEACUP_ARCH {@[email protected]}
           69  +TEACUP_TOOLSET {@[email protected]}
           70  +TEACUP_PROFILE {@[email protected]}
           71  +TEACUP_ZIPFILE {@[email protected]@[email protected]@[email protected]}
           72  +
           73  +PRACTCL_DEFS {@[email protected]}
           74  +PRACTCL_TOOLSET {@[email protected]}
           75  +PRACTCL_SHARED_LIB {@[email protected]}
           76  +PRACTCL_STATIC_LIB {@[email protected]}
           77  +PRACTCL_STUB_LIB {@[email protected]}
           78  +PRACTCL_LIBS {@[email protected] @[email protected]}
           79  +PRACTCL_VC_MANIFEST_EMBED_DLL {@[email protected]}
           80  +PRACTCL_VC_MANIFEST_EMBED_EXE {@[email protected]}
           81  +PRACTCL_NAME_LIBRARY {@[email protected]}
           82  +
           83  +PRACTCL_PKG_LIBS {@[email protected]}

Added practcl.tcl.

            1  +###
            2  +# Amalgamated package for practcl
            3  +# Do not edit directly, tweak the source in src/ and rerun
            4  +# build.tcl
            5  +###
            6  +package require Tcl 8.6
            7  +package provide practcl 0.16.3
            8  +namespace eval ::practcl {}
            9  +
           10  +###
           11  +# START: httpwget/wget.tcl
           12  +###
           13  +
           14  +###
           15  +# END: httpwget/wget.tcl
           16  +###
           17  +###
           18  +# START: clay/clay.tcl
           19  +###
           20  +package provide clay 0.8.1
           21  +namespace eval ::clay {
           22  +}
           23  +namespace eval ::clay {
           24  +}
           25  +set ::clay::trace 0
           26  +proc ::clay::PROC {name arglist body {ninja {}}} {
           27  +  if {[info commands $name] ne {}} return
           28  +  proc $name $arglist $body
           29  +  eval $ninja
           30  +}
           31  +if {[info commands ::PROC] eq {}} {
           32  +  namespace eval ::clay { namespace export PROC }
           33  +  namespace eval :: { namespace import ::clay::PROC }
           34  +}
           35  +proc ::clay::_ancestors {resultvar class} {
           36  +  upvar 1 $resultvar result
           37  +  if {$class in $result} {
           38  +    return
           39  +  }
           40  +  lappend result $class
           41  +  foreach aclass [::info class superclasses $class] {
           42  +    _ancestors result $aclass
           43  +  }
           44  +}
           45  +proc ::clay::ancestors {args} {
           46  +  set result {}
           47  +  set queue  {}
           48  +  set metaclasses {}
           49  +
           50  +  foreach class $args {
           51  +    set ancestors($class) {}
           52  +    _ancestors ancestors($class) $class
           53  +  }
           54  +  foreach class [lreverse $args] {
           55  +    foreach aclass $ancestors($class) {
           56  +      if {$aclass in $result} continue
           57  +      set skip 0
           58  +      foreach bclass $args {
           59  +        if {$class eq $bclass} continue
           60  +        if {$aclass in $ancestors($bclass)} {
           61  +          set skip 1
           62  +          break
           63  +        }
           64  +      }
           65  +      if {$skip} continue
           66  +      lappend result $aclass
           67  +    }
           68  +  }
           69  +  foreach class [lreverse $args] {
           70  +    foreach aclass $ancestors($class) {
           71  +      if {$aclass in $result} continue
           72  +      lappend result $aclass
           73  +    }
           74  +  }
           75  +  ###
           76  +  # Screen out classes that do not participate in clay
           77  +  # interactions
           78  +  ###
           79  +  set output {}
           80  +  foreach {item} $result {
           81  +    if {[catch {$item clay noop} err]} {
           82  +      continue
           83  +    }
           84  +    lappend output $item
           85  +  }
           86  +  return $output
           87  +}
           88  +proc ::clay::args_to_dict args {
           89  +  if {[llength $args]==1} {
           90  +    return [lindex $args 0]
           91  +  }
           92  +  return $args
           93  +}
           94  +proc ::clay::args_to_options args {
           95  +  set result {}
           96  +  foreach {var val} [args_to_dict {*}$args] {
           97  +    lappend result [string trim $var -:] $val
           98  +  }
           99  +  return $result
          100  +}
          101  +proc ::clay::dynamic_arguments {ensemble method arglist args} {
          102  +  set idx 0
          103  +  set len [llength $args]
          104  +  if {$len > [llength $arglist]} {
          105  +    ###
          106  +    # Catch if the user supplies too many arguments
          107  +    ###
          108  +    set dargs 0
          109  +    if {[lindex $arglist end] ni {args dictargs}} {
          110  +      return -code error -level 2 "Usage: $ensemble $method [string trim [dynamic_wrongargs_message $arglist]]"
          111  +    }
          112  +  }
          113  +  foreach argdef $arglist {
          114  +    if {$argdef eq "args"} {
          115  +      ###
          116  +      # Perform args processing in the style of tcl
          117  +      ###
          118  +      uplevel 1 [list set args [lrange $args $idx end]]
          119  +      break
          120  +    }
          121  +    if {$argdef eq "dictargs"} {
          122  +      ###
          123  +      # Perform args processing in the style of tcl
          124  +      ###
          125  +      uplevel 1 [list set args [lrange $args $idx end]]
          126  +      ###
          127  +      # Perform args processing in the style of clay
          128  +      ###
          129  +      set dictargs [::clay::args_to_options {*}[lrange $args $idx end]]
          130  +      uplevel 1 [list set dictargs $dictargs]
          131  +      break
          132  +    }
          133  +    if {$idx > $len} {
          134  +      ###
          135  +      # Catch if the user supplies too few arguments
          136  +      ###
          137  +      if {[llength $argdef]==1} {
          138  +        return -code error -level 2 "Usage: $ensemble $method [string trim [dynamic_wrongargs_message $arglist]]"
          139  +      } else {
          140  +        uplevel 1 [list set [lindex $argdef 0] [lindex $argdef 1]]
          141  +      }
          142  +    } else {
          143  +      uplevel 1 [list set [lindex $argdef 0] [lindex $args $idx]]
          144  +    }
          145  +    incr idx
          146  +  }
          147  +}
          148  +proc ::clay::dynamic_wrongargs_message {arglist} {
          149  +  set result ""
          150  +  set dargs 0
          151  +  foreach argdef $arglist {
          152  +    if {$argdef in {args dictargs}} {
          153  +      set dargs 1
          154  +      break
          155  +    }
          156  +    if {[llength $argdef]==1} {
          157  +      append result " $argdef"
          158  +    } else {
          159  +      append result " ?[lindex $argdef 0]?"
          160  +    }
          161  +  }
          162  +  if { $dargs } {
          163  +    append result " ?option value?..."
          164  +  }
          165  +  return $result
          166  +}
          167  +proc ::clay::is_dict { d } {
          168  +  # is it a dict, or can it be treated like one?
          169  +  if {[catch {::dict size $d} err]} {
          170  +    #::set ::errorInfo {}
          171  +    return 0
          172  +  }
          173  +  return 1
          174  +}
          175  +proc ::clay::is_null value {
          176  +  return [expr {$value in {{} NULL}}]
          177  +}
          178  +proc ::clay::leaf args {
          179  +  set marker [string index [lindex $args end] end]
          180  +  set result [path {*}${args}]
          181  +  if {$marker eq "/"} {
          182  +    return $result
          183  +  }
          184  +  return [list {*}[lrange $result 0 end-1] [string trim [string trim [lindex $result end]] /]]
          185  +}
          186  +proc ::clay::K {a b} {set a}
          187  +if {[info commands ::K] eq {}} {
          188  +  namespace eval ::clay { namespace export K }
          189  +  namespace eval :: { namespace import ::clay::K }
          190  +}
          191  +proc ::clay::noop args {}
          192  +if {[info commands ::noop] eq {}} {
          193  +  namespace eval ::clay { namespace export noop }
          194  +  namespace eval :: { namespace import ::clay::noop }
          195  +}
          196  +proc ::clay::path args {
          197  +  set result {}
          198  +  foreach item $args {
          199  +    set item [string trim $item :./]
          200  +    foreach subitem [split $item /] {
          201  +      lappend result [string trim ${subitem}]/
          202  +    }
          203  +  }
          204  +  return $result
          205  +}
          206  +proc ::clay::putb {buffername args} {
          207  +  upvar 1 $buffername buffer
          208  +  switch [llength $args] {
          209  +    1 {
          210  +      append buffer [lindex $args 0] \n
          211  +    }
          212  +    2 {
          213  +      append buffer [string map {*}$args] \n
          214  +    }
          215  +    default {
          216  +      error "usage: putb buffername ?map? string"
          217  +    }
          218  +  }
          219  +}
          220  +if {[info command ::putb] eq {}} {
          221  +  namespace eval ::clay { namespace export putb }
          222  +  namespace eval :: { namespace import ::clay::putb }
          223  +}
          224  +proc ::clay::script_path {} {
          225  +  set path [file dirname [file join [pwd] [info script]]]
          226  +  return $path
          227  +}
          228  +proc ::clay::NSNormalize qualname {
          229  +  if {![string match ::* $qualname]} {
          230  +    set qualname ::clay::classes::$qualname
          231  +  }
          232  +  regsub -all {::+} $qualname "::"
          233  +}
          234  +proc ::clay::uuid_generate args {
          235  +  return [uuid generate]
          236  +}
          237  +namespace eval ::clay {
          238  +  variable option_class {}
          239  +  variable core_classes {::oo::class ::oo::object}
          240  +}
          241  +package require Tcl 8.6 ;# try in pipeline.tcl. Possibly other things.
          242  +if {[info commands irmmd5] eq {}} {
          243  +  if {[catch {package require odielibc}]} {
          244  +    package require md5 2
          245  +  }
          246  +}
          247  +::namespace eval ::clay {
          248  +}
          249  +::namespace eval ::clay::classes {
          250  +}
          251  +::namespace eval ::clay::define {
          252  +}
          253  +::namespace eval ::clay::tree {
          254  +}
          255  +::namespace eval ::clay::dict {
          256  +}
          257  +::namespace eval ::clay::list {
          258  +}
          259  +::namespace eval ::clay::uuid {
          260  +}
          261  +if {![info exists ::clay::idle_destroy]} {
          262  +  set ::clay::idle_destroy {}
          263  +}
          264  +namespace eval ::clay::uuid {
          265  +    namespace export uuid
          266  +}
          267  +proc ::clay::uuid::generate_tcl_machinfo {} {
          268  +  variable machinfo
          269  +  if {[info exists machinfo]} {
          270  +    return $machinfo
          271  +  }
          272  +  lappend machinfo [clock seconds]; # timestamp
          273  +  lappend machinfo [clock clicks];  # system incrementing counter
          274  +  lappend machinfo [info hostname]; # spatial unique id (poor)
          275  +  lappend machinfo [pid];           # additional entropy
          276  +  lappend machinfo [array get ::tcl_platform]
          277  +
          278  +  ###
          279  +  # If we have /dev/urandom just stream 128 bits from that
          280  +  ###
          281  +  if {[file exists /dev/urandom]} {
          282  +    set fin [open /dev/urandom r]
          283  +    binary scan [read $fin 128] H* machinfo
          284  +    close $fin
          285  +  } elseif {[catch {package require nettool}]} {
          286  +    # More spatial information -- better than hostname.
          287  +    # bug 1150714: opening a server socket may raise a warning messagebox
          288  +    #   with WinXP firewall, using ipconfig will return all IP addresses
          289  +    #   including ipv6 ones if available. ipconfig is OK on win98+
          290  +    if {[string equal $::tcl_platform(platform) "windows"]} {
          291  +      catch {exec ipconfig} config
          292  +      lappend machinfo $config
          293  +    } else {
          294  +      catch {
          295  +          set s [socket -server void -myaddr [info hostname] 0]
          296  +          ::clay::K [fconfigure $s -sockname] [close $s]
          297  +      } r
          298  +      lappend machinfo $r
          299  +    }
          300  +
          301  +    if {[package provide Tk] != {}} {
          302  +      lappend machinfo [winfo pointerxy .]
          303  +      lappend machinfo [winfo id .]
          304  +    }
          305  +  } else {
          306  +    ###
          307  +    # If the nettool package works on this platform
          308  +    # use the stream of hardware ids from it
          309  +    ###
          310  +    lappend machinfo {*}[::nettool::hwid_list]
          311  +  }
          312  +  return $machinfo
          313  +}
          314  +if {[info commands irmmd5] ne {}} {
          315  +proc ::clay::uuid::generate {{type {}}} {
          316  +    variable nextuuid
          317  +    set s [irmmd5 "$type [incr nextuuid(type)] [generate_tcl_machinfo]"]
          318  +    foreach {a b} {0 7 8 11 12 15 16 19 20 31} {
          319  +         append r [string range $s $a $b] -
          320  +     }
          321  +     return [string tolower [string trimright $r -]]
          322  +}
          323  +proc ::clay::uuid::short {{type {}}} {
          324  +  variable nextuuid
          325  +  set r [irmmd5 "$type [incr nextuuid(type)] [generate_tcl_machinfo]"]
          326  +  return [string range $r 0 16]
          327  +}
          328  +
          329  +} else {
          330  +package require md5 2
          331  +proc ::clay::uuid::raw {{type {}}} {
          332  +    variable nextuuid
          333  +    set tok [md5::MD5Init]
          334  +    md5::MD5Update $tok "$type [incr nextuuid($type)] [generate_tcl_machinfo]"
          335  +    set r [md5::MD5Final $tok]
          336  +    return $r
          337  +    #return [::clay::uuid::tostring $r]
          338  +}
          339  +proc ::clay::uuid::generate {{type {}}} {
          340  +    return [::clay::uuid::tostring [::clay::uuid::raw  $type]]
          341  +}
          342  +proc ::clay::uuid::short {{type {}}} {
          343  +  set r [::clay::uuid::raw $type]
          344  +  binary scan $r H* s
          345  +  return [string range $s 0 16]
          346  +}
          347  +}
          348  +proc ::clay::uuid::tostring {uuid} {
          349  +    binary scan $uuid H* s
          350  +    foreach {a b} {0 7 8 11 12 15 16 19 20 31} {
          351  +        append r [string range $s $a $b] -
          352  +    }
          353  +    return [string tolower [string trimright $r -]]
          354  +}
          355  +proc ::clay::uuid::fromstring {uuid} {
          356  +    return [binary format H* [string map {- {}} $uuid]]
          357  +}
          358  +proc ::clay::uuid::equal {left right} {
          359  +    set l [fromstring $left]
          360  +    set r [fromstring $right]
          361  +    return [string equal $l $r]
          362  +}
          363  +proc ::clay::uuid {cmd args} {
          364  +    switch -exact -- $cmd {
          365  +        generate {
          366  +           return [::clay::uuid::generate {*}$args]
          367  +        }
          368  +        short {
          369  +          set uuid [::clay::uuid::short {*}$args]
          370  +        }
          371  +        equal {
          372  +            tailcall ::clay::uuid::equal {*}$args
          373  +        }
          374  +        default {
          375  +            return -code error "bad option \"$cmd\":\
          376  +                must be generate or equal"
          377  +        }
          378  +    }
          379  +}
          380  +::clay::PROC ::tcl::dict::getnull {dictionary args} {
          381  +  if {[exists $dictionary {*}$args]} {
          382  +    get $dictionary {*}$args
          383  +  }
          384  +} {
          385  +  namespace ensemble configure dict -map [dict replace\
          386  +      [namespace ensemble configure dict -map] getnull ::tcl::dict::getnull]
          387  +}
          388  +::clay::PROC ::tcl::dict::is_dict { d } {
          389  +  # is it a dict, or can it be treated like one?
          390  +  if {[catch {dict size $d} err]} {
          391  +    #::set ::errorInfo {}
          392  +    return 0
          393  +  }
          394  +  return 1
          395  +} {
          396  +  namespace ensemble configure dict -map [dict replace\
          397  +      [namespace ensemble configure dict -map] is_dict ::tcl::dict::is_dict]
          398  +}
          399  +::clay::PROC ::tcl::dict::rmerge {args} {
          400  +  ::set result [dict create . {}]
          401  +  # Merge b into a, and handle nested dicts appropriately
          402  +  ::foreach b $args {
          403  +    for { k v } $b {
          404  +      ::set field [string trim $k :/]
          405  +      if {![::clay::tree::is_branch $b $k]} {
          406  +        # Element names that end in ":" are assumed to be literals
          407  +        set result $k $v
          408  +      } elseif { [exists $result $k] } {
          409  +        # key exists in a and b?  let's see if both values are dicts
          410  +        # both are dicts, so merge the dicts
          411  +        if { [is_dict [get $result $k]] && [is_dict $v] } {
          412  +          set result $k [rmerge [get $result $k] $v]
          413  +        } else {
          414  +          set result $k $v
          415  +        }
          416  +      } else {
          417  +        set result $k $v
          418  +      }
          419  +    }
          420  +  }
          421  +  return $result
          422  +} {
          423  +  namespace ensemble configure dict -map [dict replace\
          424  +      [namespace ensemble configure dict -map] rmerge ::tcl::dict::rmerge]
          425  +}
          426  +::clay::PROC ::clay::tree::is_branch { dict path } {
          427  +  set field [lindex $path end]
          428  +  if {[string index $field end] eq ":"} {
          429  +    return 0
          430  +  }
          431  +  if {[string index $field 0] eq "."} {
          432  +    return 0
          433  +  }
          434  +  if {[string index $field end] eq "/"} {
          435  +    return 1
          436  +  }
          437  +  return [dict exists $dict {*}$path .]
          438  +}
          439  +::clay::PROC ::clay::tree::print {dict} {
          440  +  ::set result {}
          441  +  ::set level -1
          442  +  ::clay::tree::_dictputb $level result $dict
          443  +  return $result
          444  +}
          445  +::clay::PROC ::clay::tree::_dictputb {level varname dict} {
          446  +  upvar 1 $varname result
          447  +  incr level
          448  +  dict for {field value} $dict {
          449  +    if {$field eq "."} continue
          450  +    if {[clay::tree::is_branch $dict $field]} {
          451  +      putb result "[string repeat "  " $level]$field \{"
          452  +      _dictputb $level result $value
          453  +      putb result "[string repeat "  " $level]\}"
          454  +    } else {
          455  +      putb result "[string repeat "  " $level][list $field $value]"
          456  +    }
          457  +  }
          458  +}
          459  +proc ::clay::tree::sanitize {dict} {
          460  +  ::set result {}
          461  +  ::set level -1
          462  +  ::clay::tree::_sanitizeb {} result $dict
          463  +  return $result
          464  +}
          465  +proc ::clay::tree::_sanitizeb {path varname dict} {
          466  +  upvar 1 $varname result
          467  +  dict for {field value} $dict {
          468  +    if {$field eq "."} continue
          469  +    if {[clay::tree::is_branch $dict $field]} {
          470  +      _sanitizeb [list {*}$path $field] result $value
          471  +    } else {
          472  +      dict set result {*}$path $field $value
          473  +    }
          474  +  }
          475  +}
          476  +proc ::clay::tree::storage {rawpath} {
          477  +  set isleafvar 0
          478  +  set path {}
          479  +  set tail [string index $rawpath end]
          480  +  foreach element $rawpath {
          481  +    set items [split [string trim $element /] /]
          482  +    foreach item $items {
          483  +      if {$item eq {}} continue
          484  +      lappend path $item
          485  +    }
          486  +  }
          487  +  return $path
          488  +}
          489  +proc ::clay::tree::dictset {varname args} {
          490  +  upvar 1 $varname result
          491  +  if {[llength $args] < 2} {
          492  +    error "Usage: ?path...? path value"
          493  +  } elseif {[llength $args]==2} {
          494  +    set rawpath [lindex $args 0]
          495  +  } else {
          496  +    set rawpath  [lrange $args 0 end-1]
          497  +  }
          498  +  set value [lindex $args end]
          499  +  set path [storage $rawpath]
          500  +  set dot .
          501  +  set one {}
          502  +  dict set result $dot $one
          503  +  set dpath {}
          504  +  foreach item [lrange $path 0 end-1] {
          505  +    set field $item
          506  +    lappend dpath [string trim $item /]
          507  +    dict set result {*}$dpath $dot $one
          508  +  }
          509  +  set field [lindex $rawpath end]
          510  +  set ext   [string index $field end]
          511  +  if {$ext eq {:} || ![dict is_dict $value]} {
          512  +    dict set result {*}$path $value
          513  +    return
          514  +  }
          515  +  if {$ext eq {/} && ![dict exists $result {*}$path $dot]} {
          516  +    dict set result {*}$path $dot $one
          517  +  }
          518  +  if {[dict exists $result {*}$path $dot]} {
          519  +    dict set result {*}$path [::clay::tree::merge [dict get $result {*}$path] $value]
          520  +    return
          521  +  }
          522  +  dict set result {*}$path $value
          523  +}
          524  +proc ::clay::tree::dictmerge {varname args} {
          525  +  upvar 1 $varname result
          526  +  set dot .
          527  +  set one {}
          528  +  dict set result $dot $one
          529  +  foreach dict $args {
          530  +    dict for {f v} $dict {
          531  +      set field [string trim $f /]
          532  +      set bbranch [clay::tree::is_branch $dict $f]
          533  +      if {![dict exists $result $field]} {
          534  +        dict set result $field $v
          535  +        if {$bbranch} {
          536  +          dict set result $field [clay::tree::merge $v]
          537  +        } else {
          538  +          dict set result $field $v
          539  +        }
          540  +      } elseif {[dict exists $result $field $dot]} {
          541  +        if {$bbranch} {
          542  +          dict set result $field [clay::tree::merge [dict get $result $field] $v]
          543  +        } else {
          544  +          dict set result $field $v
          545  +        }
          546  +      }
          547  +    }
          548  +  }
          549  +  return $result
          550  +}
          551  +proc ::clay::tree::merge {args} {
          552  +  ###
          553  +  # The result of a merge is always a dict with branches
          554  +  ###
          555  +  set dot .
          556  +  set one {}
          557  +  dict set result $dot $one
          558  +  set argument 0
          559  +  foreach b $args {
          560  +    # Merge b into a, and handle nested dicts appropriately
          561  +    if {![dict is_dict $b]} {
          562  +      error "Element $b is not a dictionary"
          563  +    }
          564  +    dict for { k v } $b {
          565  +      if {$k eq $dot} {
          566  +        dict set result $dot $one
          567  +        continue
          568  +      }
          569  +      set bbranch [is_branch $b $k]
          570  +      set field [string trim $k /]
          571  +      if { ![dict exists $result $field] } {
          572  +        if {$bbranch} {
          573  +          dict set result $field [merge $v]
          574  +        } else {
          575  +          dict set result $field $v
          576  +        }
          577  +      } else {
          578  +        set abranch [dict exists $result $field $dot]
          579  +        if {$abranch && $bbranch} {
          580  +          dict set result $field [merge [dict get $result $field] $v]
          581  +        } else {
          582  +          dict set result $field $v
          583  +          if {$bbranch} {
          584  +            dict set result $field $dot $one
          585  +          }
          586  +        }
          587  +      }
          588  +    }
          589  +  }
          590  +  return $result
          591  +}
          592  +::clay::PROC ::tcl::dict::isnull {dictionary args} {
          593  +  if {![exists $dictionary {*}$args]} {return 1}
          594  +  return [expr {[get $dictionary {*}$args] in {{} NULL null}}]
          595  +} {
          596  +  namespace ensemble configure dict -map [dict replace\
          597  +      [namespace ensemble configure dict -map] isnull ::tcl::dict::isnull]
          598  +}
          599  +::clay::PROC ::clay::ladd {varname args} {
          600  +  upvar 1 $varname var
          601  +  if ![info exists var] {
          602  +      set var {}
          603  +  }
          604  +  foreach item $args {
          605  +    if {$item in $var} continue
          606  +    lappend var $item
          607  +  }
          608  +  return $var
          609  +}
          610  +::clay::PROC ::clay::ldelete {varname args} {
          611  +  upvar 1 $varname var
          612  +  if ![info exists var] {
          613  +      return
          614  +  }
          615  +  foreach item [lsort -unique $args] {
          616  +    while {[set i [lsearch $var $item]]>=0} {
          617  +      set var [lreplace $var $i $i]
          618  +    }
          619  +  }
          620  +  return $var
          621  +}
          622  +::clay::PROC ::clay::lrandom list {
          623  +  set len [llength $list]
          624  +  set idx [expr int(rand()*$len)]
          625  +  return [lindex $list $idx]
          626  +}
          627  +namespace eval ::dictargs {
          628  +}
          629  +if {[info commands ::dictargs::parse] eq {}} {
          630  +  proc ::dictargs::parse {argdef argdict} {
          631  +    set result {}
          632  +    dict for {field info} $argdef {
          633  +      if {![string is alnum [string index $field 0]]} {
          634  +        error "$field is not a simple variable name"
          635  +      }
          636  +      upvar 1 $field _var
          637  +      set aliases {}
          638  +      if {[dict exists $argdict $field]} {
          639  +        set _var [dict get $argdict $field]
          640  +        continue
          641  +      }
          642  +      if {[dict exists $info aliases:]} {
          643  +        set found 0
          644  +        foreach {name} [dict get $info aliases:] {
          645  +          if {[dict exists $argdict $name]} {
          646  +            set _var [dict get $argdict $name]
          647  +            set found 1
          648  +            break
          649  +          }
          650  +        }
          651  +        if {$found} continue
          652  +      }
          653  +      if {[dict exists $info default:]} {
          654  +        set _var [dict get $info default:]
          655  +        continue
          656  +      }
          657  +      set mandatory 1
          658  +      if {[dict exists $info mandatory:]} {
          659  +        set mandatory [dict get $info mandatory:]
          660  +      }
          661  +      if {$mandatory} {
          662  +        error "$field is required"
          663  +      }
          664  +    }
          665  +  }
          666  +}
          667  +proc ::dictargs::proc {name argspec body} {
          668  +  set result {}
          669  +  append result "::dictargs::parse \{$argspec\} \$args" \;
          670  +  append result $body
          671  +  uplevel 1 [list ::proc $name [list [list args [list dictargs $argspec]]] $result]
          672  +}
          673  +proc ::dictargs::method {name argspec body} {
          674  +  set class [lindex [::info level -1] 1]
          675  +  set result {}
          676  +  append result "::dictargs::parse \{$argspec\} \$args" \;
          677  +  append result $body
          678  +  oo::define $class method $name [list [list args [list dictargs $argspec]]] $result
          679  +}
          680  +namespace eval ::clay::dialect {
          681  +  namespace export create
          682  +  foreach {flag test} {
          683  +    tip470 {package vsatisfies [package provide Tcl] 8.7}
          684  +  } {
          685  +    if {![info exists ::clay::dialect::has($flag)]} {
          686  +      set ::clay::dialect::has($flag) [eval $test]
          687  +    }
          688  +  }
          689  +}
          690  +proc ::clay::dialect::Push {class} {
          691  +  ::variable class_stack
          692  +  lappend class_stack $class
          693  +}
          694  +proc ::clay::dialect::Peek {} {
          695  +  ::variable class_stack
          696  +  return [lindex $class_stack end]
          697  +}
          698  +proc ::clay::dialect::Pop {} {
          699  +  ::variable class_stack
          700  +  set class_stack [lrange $class_stack 0 end-1]
          701  +}
          702  +if {$::clay::dialect::has(tip470)} {
          703  +proc ::clay::dialect::current_class {} {
          704  +  return [uplevel 1 self]
          705  +}
          706  +} else {
          707  +proc ::clay::dialect::current_class {} {
          708  +  tailcall Peek
          709  +}
          710  +}
          711  +proc ::clay::dialect::create {name {parent ""}} {
          712  +  variable has
          713  +  set NSPACE [NSNormalize [uplevel 1 {namespace current}] $name]
          714  +  ::namespace eval $NSPACE {::namespace eval define {}}
          715  +  ###
          716  +  # Build the "define" namespace
          717  +  ###
          718  +
          719  +  if {$parent eq ""} {
          720  +    ###
          721  +    # With no "parent" language, begin with all of the keywords in
          722  +    # oo::define
          723  +    ###
          724  +    foreach command [info commands ::oo::define::*] {
          725  +      set procname [namespace tail $command]
          726  +      interp alias {} ${NSPACE}::define::$procname {} \
          727  +        ::clay::dialect::DefineThunk $procname
          728  +    }
          729  +    # Create an empty dynamic_methods proc
          730  +    proc ${NSPACE}::dynamic_methods {class} {}
          731  +    namespace eval $NSPACE {
          732  +      ::namespace export dynamic_methods
          733  +      ::namespace eval define {::namespace export *}
          734  +    }
          735  +    set ANCESTORS {}
          736  +  } else {
          737  +    ###
          738  +    # If we have a parent language, that language already has the
          739  +    # [oo::define] keywords as well as additional keywords and behaviors.
          740  +    # We should begin with that
          741  +    ###
          742  +    set pnspace [NSNormalize [uplevel 1 {namespace current}] $parent]
          743  +    apply [list parent {
          744  +      ::namespace export dynamic_methods
          745  +      ::namespace import -force ${parent}::dynamic_methods
          746  +    } $NSPACE] $pnspace
          747  +
          748  +    apply [list parent {
          749  +      ::namespace import -force ${parent}::define::*
          750  +      ::namespace export *
          751  +    } ${NSPACE}::define] $pnspace
          752  +      set ANCESTORS [list ${pnspace}::object]
          753  +  }
          754  +  ###
          755  +  # Build our dialect template functions
          756  +  ###
          757  +  proc ${NSPACE}::define {oclass args} [string map [list %NSPACE% $NSPACE] {
          758  +  ###
          759  +  # To facilitate library reloading, allow
          760  +  # a dialect to create a class from DEFINE
          761  +  ###
          762  +  set class [::clay::dialect::NSNormalize [uplevel 1 {namespace current}] $oclass]
          763  +    if {[info commands $class] eq {}} {
          764  +      %NSPACE%::class create $class {*}${args}
          765  +    } else {
          766  +      ::clay::dialect::Define %NSPACE% $class {*}${args}
          767  +    }
          768  +}]
          769  +  interp alias {} ${NSPACE}::define::current_class {} \
          770  +    ::clay::dialect::current_class
          771  +  interp alias {} ${NSPACE}::define::aliases {} \
          772  +    ::clay::dialect::Aliases $NSPACE
          773  +  interp alias {} ${NSPACE}::define::superclass {} \
          774  +    ::clay::dialect::SuperClass $NSPACE
          775  +
          776  +  if {[info command ${NSPACE}::class] ne {}} {
          777  +    ::rename ${NSPACE}::class {}
          778  +  }
          779  +  ###
          780  +  # Build the metaclass for our language
          781  +  ###
          782  +  ::oo::class create ${NSPACE}::class {
          783  +    superclass ::clay::dialect::MotherOfAllMetaClasses
          784  +  }
          785  +  # Wire up the create method to add in the extra argument we need; the
          786  +  # MotherOfAllMetaClasses will know what to do with it.
          787  +  ::oo::objdefine ${NSPACE}::class \
          788  +    method create {name {definitionScript ""}} \
          789  +      "next \$name [list ${NSPACE}::define] \$definitionScript"
          790  +
          791  +  ###
          792  +  # Build the mother of all classes. Note that $ANCESTORS is already
          793  +  # guaranteed to be a list in canonical form.
          794  +  ###
          795  +  uplevel #0 [string map [list %NSPACE% [list $NSPACE] %name% [list $name] %ANCESTORS% $ANCESTORS] {
          796  +    %NSPACE%::class create %NSPACE%::object {
          797  +     superclass %ANCESTORS%
          798  +      # Put MOACish stuff in here
          799  +    }
          800  +  }]
          801  +  if { "${NSPACE}::class" ni $::clay::dialect::core_classes } {
          802  +    lappend ::clay::dialect::core_classes "${NSPACE}::class"
          803  +  }
          804  +  if { "${NSPACE}::object" ni $::clay::dialect::core_classes } {
          805  +    lappend ::clay::dialect::core_classes "${NSPACE}::object"
          806  +  }
          807  +}
          808  +proc ::clay::dialect::NSNormalize {namespace qualname} {
          809  +  if {![string match ::* $qualname]} {
          810  +    set qualname ${namespace}::$qualname
          811  +  }
          812  +  regsub -all {::+} $qualname "::"
          813  +}
          814  +proc ::clay::dialect::DefineThunk {target args} {
          815  +  tailcall ::oo::define [Peek] $target {*}$args
          816  +}
          817  +proc ::clay::dialect::Canonical {namespace NSpace class} {
          818  +  namespace upvar $namespace cname cname
          819  +  #if {[string match ::* $class]} {
          820  +  #  return $class
          821  +  #}
          822  +  if {[info exists cname($class)]} {
          823  +    return $cname($class)
          824  +  }
          825  +  if {[info exists ::clay::dialect::cname($class)]} {
          826  +    return $::clay::dialect::cname($class)
          827  +  }
          828  +  if {[info exists ::clay::dialect::cname(${NSpace}::${class})]} {
          829  +    return $::clay::dialect::cname(${NSpace}::${class})
          830  +  }
          831  +  foreach item [list "${NSpace}::$class" "::$class"] {
          832  +    if {[info commands $item] ne {}} {
          833  +      return $item
          834  +    }
          835  +  }
          836  +  return ${NSpace}::$class
          837  +}
          838  +proc ::clay::dialect::Define {namespace class args} {
          839  +  Push $class
          840  +  try {
          841  +  	if {[llength $args]==1} {
          842  +      namespace eval ${namespace}::define [lindex $args 0]
          843  +    } else {
          844  +      ${namespace}::define::[lindex $args 0] {*}[lrange $args 1 end]
          845  +    }
          846  +  	${namespace}::dynamic_methods $class
          847  +  } finally {
          848  +    Pop
          849  +  }
          850  +}
          851  +proc ::clay::dialect::Aliases {namespace args} {
          852  +  set class [Peek]
          853  +  namespace upvar $namespace cname cname
          854  +  set NSpace [join [lrange [split $class ::] 1 end-2] ::]
          855  +  set cname($class) $class
          856  +  foreach name $args {
          857  +    set cname($name) $class
          858  +    #set alias $name
          859  +    set alias [NSNormalize $NSpace $name]
          860  +    # Add a local metaclass reference
          861  +    if {![info exists ::clay::dialect::cname($alias)]} {
          862  +      lappend ::clay::dialect::aliases($class) $alias
          863  +      ##
          864  +      # Add a global reference, first come, first served
          865  +      ##
          866  +      set ::clay::dialect::cname($alias) $class
          867  +    }
          868  +  }
          869  +}
          870  +proc ::clay::dialect::SuperClass {namespace args} {
          871  +  set class [Peek]
          872  +  namespace upvar $namespace class_info class_info
          873  +  dict set class_info($class) superclass 1
          874  +  set ::clay::dialect::cname($class) $class
          875  +  set NSpace [join [lrange [split $class ::] 1 end-2] ::]
          876  +  set unique {}
          877  +  foreach item $args {
          878  +    set Item [Canonical $namespace $NSpace $item]
          879  +    dict set unique $Item $item
          880  +  }
          881  +  set root ${namespace}::object
          882  +  if {$class ne $root} {
          883  +    dict set unique $root $root
          884  +  }
          885  +  tailcall ::oo::define $class superclass {*}[dict keys $unique]
          886  +}
          887  +if {[info command ::clay::dialect::MotherOfAllMetaClasses] eq {}} {
          888  +::oo::class create ::clay::dialect::MotherOfAllMetaClasses {
          889  +  superclass ::oo::class
          890  +  constructor {define definitionScript} {
          891  +    $define [self] {
          892  +      superclass
          893  +    }
          894  +    $define [self] $definitionScript
          895  +  }
          896  +  method aliases {} {
          897  +    if {[info exists ::clay::dialect::aliases([self])]} {
          898  +      return $::clay::dialect::aliases([self])
          899  +    }
          900  +  }
          901  +}
          902  +}
          903  +namespace eval ::clay::dialect {
          904  +  variable core_classes {::oo::class ::oo::object}
          905  +}
          906  +::clay::dialect::create ::clay
          907  +proc ::clay::dynamic_methods class {
          908  +  foreach command [info commands [namespace current]::dynamic_methods_*] {
          909  +    $command $class
          910  +  }
          911  +}
          912  +proc ::clay::dynamic_methods_class {thisclass} {
          913  +  set methods {}
          914  +  set mdata [$thisclass clay find class_typemethod]
          915  +  foreach {method info} $mdata {
          916  +    if {$method eq {.}} continue
          917  +    set method [string trimright $method :/-]
          918  +    if {$method in $methods} continue
          919  +    lappend methods $method
          920  +    set arglist [dict getnull $info arglist]
          921  +    set body    [dict getnull $info body]
          922  +    ::oo::objdefine $thisclass method $method $arglist $body
          923  +  }
          924  +}
          925  +proc ::clay::define::Array {name {values {}}} {
          926  +  set class [current_class]
          927  +  set name [string trim $name :/]
          928  +  $class clay branch array $name
          929  +  dict for {var val} $values {
          930  +    $class clay set array/ $name $var $val
          931  +  }
          932  +}
          933  +proc ::clay::define::Delegate {name info} {
          934  +  set class [current_class]
          935  +  foreach {field value} $info {
          936  +    $class clay set component/ [string trim $name :/]/ $field $value
          937  +  }
          938  +}
          939  +proc ::clay::define::constructor {arglist rawbody} {
          940  +  set body {
          941  +my variable DestroyEvent
          942  +set DestroyEvent 0
          943  +::clay::object_create [self] [info object class [self]]
          944  +# Initialize public variables and options
          945  +my InitializePublic
          946  +  }
          947  +  append body $rawbody
          948  +  set class [current_class]
          949  +  ::oo::define $class constructor $arglist $body
          950  +}
          951  +proc ::clay::define::Class_Method {name arglist body} {
          952  +  set class [current_class]
          953  +  $class clay set class_typemethod/ [string trim $name :/] [dict create arglist $arglist body $body]
          954  +}
          955  +proc ::clay::define::class_method {name arglist body} {
          956  +  set class [current_class]
          957  +  $class clay set class_typemethod/ [string trim $name :/] [dict create arglist $arglist body $body]
          958  +}
          959  +proc ::clay::define::clay {args} {
          960  +  set class [current_class]
          961  +  if {[lindex $args 0] in "cget set branch"} {
          962  +    $class clay {*}$args
          963  +  } else {
          964  +    $class clay set {*}$args
          965  +  }
          966  +}
          967  +proc ::clay::define::destructor rawbody {
          968  +  set body {
          969  +# Run the destructor once and only once
          970  +set self [self]
          971  +my variable DestroyEvent
          972  +if {$DestroyEvent} return
          973  +set DestroyEvent 1
          974  +}
          975  +  append body $rawbody
          976  +  ::oo::define [current_class] destructor $body
          977  +}
          978  +proc ::clay::define::Dict {name {values {}}} {
          979  +  set class [current_class]
          980  +  set name [string trim $name :/]
          981  +  $class clay branch dict $name
          982  +  foreach {var val} $values {
          983  +    $class clay set dict/ $name/ $var $val
          984  +  }
          985  +}
          986  +proc ::clay::define::Option {name args} {
          987  +  set class [current_class]
          988  +  set dictargs {default {}}
          989  +  foreach {var val} [::clay::args_to_dict {*}$args] {
          990  +    dict set dictargs [string trim $var -:/] $val
          991  +  }
          992  +  set name [string trimleft $name -]
          993  +
          994  +  ###
          995  +  # Option Class handling
          996  +  ###
          997  +  set optclass [dict getnull $dictargs class]
          998  +  if {$optclass ne {}} {
          999  +    foreach {f v} [$class clay find option_class $optclass] {
         1000  +      if {![dict exists $dictargs $f]} {
         1001  +        dict set dictargs $f $v
         1002  +      }
         1003  +    }
         1004  +    if {$optclass eq "variable"} {
         1005  +      variable $name [dict getnull $dictargs default]
         1006  +    }
         1007  +  }
         1008  +  foreach {f v} $dictargs {
         1009  +    $class clay set option $name $f $v
         1010  +  }
         1011  +}
         1012  +proc ::clay::define::Method {name argstyle argspec body} {
         1013  +  set class [current_class]
         1014  +  set result {}
         1015  +  switch $argstyle {
         1016  +    dictargs {
         1017  +      append result "::dictargs::parse \{$argspec\} \$args" \;
         1018  +    }
         1019  +  }
         1020  +  append result $body
         1021  +  oo::define $class method $name [list [list args [list dictargs $argspec]]] $result
         1022  +}
         1023  +proc ::clay::define::Option_Class {name args} {
         1024  +  set class [current_class]
         1025  +  set dictargs {default {}}
         1026  +  set name [string trimleft $name -:]
         1027  +  foreach {f v} [::clay::args_to_dict {*}$args] {
         1028  +    $class clay set option_class $name [string trim $f -/:] $v
         1029  +  }
         1030  +}
         1031  +proc ::clay::define::Variable {name {default {}}} {
         1032  +  set class [current_class]
         1033  +  set name [string trimright $name :/]
         1034  +  $class clay set variable/ $name $default
         1035  +}
         1036  +::namespace eval ::clay::define {
         1037  +}
         1038  +proc ::clay::ensemble_methodbody {ensemble einfo} {
         1039  +  set default standard
         1040  +  set preamble {}
         1041  +  set eswitch {}
         1042  +  if {[dict exists $einfo default]} {
         1043  +    set emethodinfo [dict get $einfo default]
         1044  +    set argspec     [dict getnull $emethodinfo argspec]
         1045  +    set realbody    [dict getnull $emethodinfo body]
         1046  +    set argstyle    [dict getnull $emethodinfo argstyle]
         1047  +    if {$argstyle eq "dictargs"} {
         1048  +      set body "\n      ::dictargs::parse \{$argspec\} \$args"
         1049  +    } elseif {[llength $argspec]==1 && [lindex $argspec 0] in {{} args arglist}} {
         1050  +      set body {}
         1051  +    } else {
         1052  +      set body "\n      ::clay::dynamic_arguments $ensemble \$method [list $argspec] {*}\$args"
         1053  +    }
         1054  +    append body "\n      " [string trim $realbody] "      \n"
         1055  +    set default $body
         1056  +    dict unset einfo default
         1057  +  }
         1058  +  foreach {msubmethod esubmethodinfo} [lsort -dictionary -stride 2 $einfo] {
         1059  +    set submethod [string trim $msubmethod :/-]
         1060  +    if {$submethod eq "_body"} continue
         1061  +    if {$submethod eq "_preamble"} {
         1062  +      set preamble [dict getnull $esubmethodinfo body]
         1063  +      continue
         1064  +    }
         1065  +    set argspec     [dict getnull $esubmethodinfo argspec]
         1066  +    set realbody    [dict getnull $esubmethodinfo body]
         1067  +    set argstyle    [dict getnull $esubmethodinfo argstyle]
         1068  +    if {[string length [string trim $realbody]] eq {}} {
         1069  +      dict set eswitch $submethod {}
         1070  +    } else {
         1071  +      if {$argstyle eq "dictargs"} {
         1072  +        set body "\n      ::dictargs::parse \{$argspec\} \$args"
         1073  +      } elseif {[llength $argspec]==1 && [lindex $argspec 0] in {{} args arglist}} {
         1074  +        set body {}
         1075  +      } else {
         1076  +        set body "\n      ::clay::dynamic_arguments $ensemble \$method [list $argspec] {*}\$args"
         1077  +      }
         1078  +      append body "\n      " [string trim $realbody] "      \n"
         1079  +      if {$submethod eq "default"} {
         1080  +        set default $body
         1081  +      } else {
         1082  +        foreach alias [dict getnull $esubmethodinfo aliases] {
         1083  +          dict set eswitch $alias -
         1084  +        }
         1085  +        dict set eswitch $submethod $body
         1086  +      }
         1087  +    }
         1088  +  }
         1089  +  set methodlist [lsort -dictionary [dict keys $eswitch]]
         1090  +  if {![dict exists $eswitch <list>]} {
         1091  +    dict set eswitch <list> {return $methodlist}
         1092  +  }
         1093  +  if {$default eq "standard"} {
         1094  +    set default "error \"unknown method $ensemble \$method. Valid: \$methodlist\""
         1095  +  }
         1096  +  dict set eswitch default $default
         1097  +  set mbody {}
         1098  +
         1099  +  append mbody $preamble \n
         1100  +
         1101  +  append mbody \n [list set methodlist $methodlist]
         1102  +  append mbody \n "set code \[catch {switch -- \$method [list $eswitch]} result opts\]"
         1103  +  append mbody \n {return -options $opts $result}
         1104  +  return $mbody
         1105  +}
         1106  +::proc ::clay::define::Ensemble {rawmethod args} {
         1107  +  if {[llength $args]==2} {
         1108  +    lassign $args argspec body
         1109  +    set argstyle tcl
         1110  +  } elseif {[llength $args]==3} {
         1111  +    lassign $args argstyle argspec body
         1112  +  } else {
         1113  +    error "Usage: Ensemble name ?argstyle? argspec body"
         1114  +  }
         1115  +  set class [current_class]
         1116  +  #if {$::clay::trace>2} {
         1117  +  #  puts [list $class Ensemble $rawmethod $argspec $body]
         1118  +  #}
         1119  +  set mlist [split $rawmethod "::"]
         1120  +  set ensemble [string trim [lindex $mlist 0] :/]
         1121  +  set mensemble ${ensemble}/
         1122  +  if {[llength $mlist]==1 || [lindex $mlist 1] in "_body"} {
         1123  +    set method _body
         1124  +    ###
         1125  +    # Simple method, needs no parsing, but we do need to record we have one
         1126  +    ###
         1127  +    if {$argstyle eq "dictargs"} {
         1128  +      set argspec [list args $argspec]
         1129  +    }
         1130  +    $class clay set method_ensemble/ $mensemble _body [dict create argspec $argspec body $body argstyle $argstyle]
         1131  +    if {$::clay::trace>2} {
         1132  +      puts [list $class clay set method_ensemble/ $mensemble _body ...]
         1133  +    }
         1134  +    set method $rawmethod
         1135  +    if {$::clay::trace>2} {
         1136  +      puts [list $class Ensemble $rawmethod $argspec $body]
         1137  +      set rawbody $body
         1138  +      set body {puts [list [self] $class [self method]]}
         1139  +      append body \n $rawbody
         1140  +    }
         1141  +    if {$argstyle eq "dictargs"} {
         1142  +      set rawbody $body
         1143  +      set body "::dictargs::parse \{$argspec\} \$args\; "
         1144  +      append body $rawbody
         1145  +    }
         1146  +    ::oo::define $class method $rawmethod $argspec $body
         1147  +    return
         1148  +  }
         1149  +  set method [join [lrange $mlist 2 end] "::"]
         1150  +  $class clay set method_ensemble/ $mensemble [string trim [lindex $method 0] :/] [dict create argspec $argspec body $body argstyle $argstyle]
         1151  +  if {$::clay::trace>2} {
         1152  +    puts [list $class clay set method_ensemble/ $mensemble [string trim $method :/]  ...]
         1153  +  }
         1154  +}
         1155  +::oo::define ::clay::class {
         1156  +  method clay {submethod args} {
         1157  +    my variable clay
         1158  +    if {![info exists clay]} {
         1159  +      set clay {}
         1160  +    }
         1161  +    switch $submethod {
         1162  +      ancestors {
         1163  +        tailcall ::clay::ancestors [self]
         1164  +      }
         1165  +      branch {
         1166  +        set path [::clay::tree::storage $args]
         1167  +        if {![dict exists $clay {*}$path .]} {
         1168  +          dict set clay {*}$path . {}
         1169  +        }
         1170  +      }
         1171  +      exists {
         1172  +        if {![info exists clay]} {
         1173  +          return 0
         1174  +        }
         1175  +        set path [::clay::tree::storage $args]
         1176  +        if {[dict exists $clay {*}$path]} {
         1177  +          return 1
         1178  +        }
         1179  +        if {[dict exists $clay {*}[lrange $path 0 end-1] [lindex $path end]:]} {
         1180  +          return 1
         1181  +        }
         1182  +        return 0
         1183  +      }
         1184  +      dump {
         1185  +        return $clay
         1186  +      }
         1187  +      dget {
         1188  +         if {![info exists clay]} {
         1189  +          return {}
         1190  +        }
         1191  +        set path [::clay::tree::storage $args]
         1192  +        if {[dict exists $clay {*}$path]} {
         1193  +          return [dict get $clay {*}$path]
         1194  +        }
         1195  +        if {[dict exists $clay {*}[lrange $path 0 end-1] [lindex $path end]:]} {
         1196  +          return [dict get $clay {*}[lrange $path 0 end-1] [lindex $path end]:]
         1197  +        }
         1198  +        return {}
         1199  +      }
         1200  +      is_branch {
         1201  +        set path [::clay::tree::storage $args]
         1202  +        return [dict exists $clay {*}$path .]
         1203  +      }
         1204  +      getnull -
         1205  +      get {
         1206  +        if {![info exists clay]} {
         1207  +          return {}
         1208  +        }
         1209  +        set path [::clay::tree::storage $args]
         1210  +        if {[llength $path]==0} {
         1211  +          return $clay
         1212  +        }
         1213  +        if {[dict exists $clay {*}$path .]} {
         1214  +          return [::clay::tree::sanitize [dict get $clay {*}$path]]
         1215  +        }
         1216  +        if {[dict exists $clay {*}$path]} {
         1217  +          return [dict get $clay {*}$path]
         1218  +        }
         1219  +        if {[dict exists $clay {*}[lrange $path 0 end-1] [lindex $path end]:]} {
         1220  +          return [dict get $clay {*}[lrange $path 0 end-1] [lindex $path end]:]
         1221  +        }
         1222  +        return {}
         1223  +      }
         1224  +      find {
         1225  +        set path [::clay::tree::storage $args]
         1226  +        if {![info exists clay]} {
         1227  +          set clay {}
         1228  +        }
         1229  +        set clayorder [::clay::ancestors [self]]
         1230  +        set found 0
         1231  +        if {[llength $path]==0} {
         1232  +          set result [dict create . {}]
         1233  +          foreach class $clayorder {
         1234  +            ::clay::tree::dictmerge result [$class clay dump]
         1235  +          }
         1236  +          return [::clay::tree::sanitize $result]
         1237  +        }
         1238  +        foreach class $clayorder {
         1239  +          if {[$class clay exists {*}$path .]} {
         1240  +            # Found a branch break
         1241  +            set found 1
         1242  +            break
         1243  +          }
         1244  +          if {[$class clay exists {*}$path]} {
         1245  +            # Found a leaf. Return that value immediately
         1246  +            return [$class clay get {*}$path]
         1247  +          }
         1248  +          if {[dict exists $clay {*}[lrange $path 0 end-1] [lindex $path end]:]} {
         1249  +            return [dict get $clay {*}[lrange $path 0 end-1] [lindex $path end]:]
         1250  +          }
         1251  +        }
         1252  +        if {!$found} {
         1253  +          return {}
         1254  +        }
         1255  +        set result {}
         1256  +        # Leaf searches return one data field at a time
         1257  +        # Search in our local dict
         1258  +        # Search in the in our list of classes for an answer
         1259  +        foreach class [lreverse $clayorder] {
         1260  +          ::clay::tree::dictmerge result [$class clay dget {*}$path]
         1261  +        }
         1262  +        return [::clay::tree::sanitize $result]
         1263  +      }
         1264  +      merge {
         1265  +        foreach arg $args {
         1266  +          ::clay::tree::dictmerge clay {*}$arg
         1267  +        }
         1268  +      }
         1269  +      noop {
         1270  +        # Do nothing. Used as a sign of clay savviness
         1271  +      }
         1272  +      search {
         1273  +        foreach aclass [::clay::ancestors [self]] {
         1274  +          if {[$aclass clay exists {*}$args]} {
         1275  +            return [$aclass clay get {*}$args]
         1276  +          }
         1277  +        }
         1278  +      }
         1279  +      set {
         1280  +        ::clay::tree::dictset clay {*}$args
         1281  +      }
         1282  +      unset {
         1283  +        dict unset clay {*}$args
         1284  +      }
         1285  +      default {
         1286  +        dict $submethod clay {*}$args
         1287  +      }
         1288  +    }
         1289  +  }
         1290  +}
         1291  +::oo::define ::clay::object {
         1292  +  method clay {submethod args} {
         1293  +    my variable clay claycache clayorder config option_canonical
         1294  +    if {![info exists clay]} {set clay {}}
         1295  +    if {![info exists claycache]} {set claycache {}}
         1296  +    if {![info exists config]} {set config {}}
         1297  +    if {![info exists clayorder] || [llength $clayorder]==0} {
         1298  +      set clayorder {}
         1299  +      if {[dict exists $clay cascade]} {
         1300  +        dict for {f v} [dict get $clay cascade] {
         1301  +          if {$f eq "."} continue
         1302  +          if {[info commands $v] ne {}} {
         1303  +            lappend clayorder $v
         1304  +          }
         1305  +        }
         1306  +      }
         1307  +      lappend clayorder {*}[::clay::ancestors [info object class [self]] {*}[lreverse [info object mixins [self]]]]
         1308  +    }
         1309  +    switch $submethod {
         1310  +      ancestors {
         1311  +        return $clayorder
         1312  +      }
         1313  +      branch {
         1314  +        set path [::clay::tree::storage $args]
         1315  +        if {![dict exists $clay {*}$path .]} {
         1316  +          dict set clay {*}$path . {}
         1317  +        }
         1318  +      }
         1319  +      cache {
         1320  +        set path [lindex $args 0]
         1321  +        set value [lindex $args 1]
         1322  +        dict set claycache $path $value
         1323  +      }
         1324  +      cget {
         1325  +        # Leaf searches return one data field at a time
         1326  +        # Search in our local dict
         1327  +        if {[llength $args]==1} {
         1328  +          set field [string trim [lindex $args 0] -:/]
         1329  +          if {[info exists option_canonical($field)]} {
         1330  +            set field $option_canonical($field)
         1331  +          }
         1332  +          if {[dict exists $config $field]} {
         1333  +            return [dict get $config $field]
         1334  +          }
         1335  +        }
         1336  +        set path [::clay::tree::storage $args]
         1337  +        if {[dict exists $clay {*}$path]} {
         1338  +          return [dict get $clay {*}$path]
         1339  +        }
         1340  +        # Search in our local cache
         1341  +        if {[dict exists $claycache {*}$path]} {
         1342  +          if {[dict exists $claycache {*}$path .]} {
         1343  +            return [dict remove [dict get $claycache {*}$path] .]
         1344  +          } else {
         1345  +            return [dict get $claycache {*}$path]
         1346  +          }
         1347  +        }
         1348  +        # Search in the in our list of classes for an answer
         1349  +        foreach class $clayorder {
         1350  +          if {[$class clay exists {*}$path]} {
         1351  +            set value [$class clay get {*}$path]
         1352  +            dict set claycache {*}$path $value
         1353  +            return $value
         1354  +          }
         1355  +          if {[$class clay exists const {*}$path]} {
         1356  +            set value [$class clay get const {*}$path]
         1357  +            dict set claycache {*}$path $value
         1358  +            return $value
         1359  +          }
         1360  +          if {[$class clay exists option {*}$path default]} {
         1361  +            set value [$class clay get option {*}$path default]
         1362  +            dict set claycache {*}$path $value
         1363  +            return $value
         1364  +          }
         1365  +        }
         1366  +        return {}
         1367  +      }
         1368  +      delegate {
         1369  +        if {![dict exists $clay .delegate <class>]} {
         1370  +          dict set clay .delegate <class> [info object class [self]]
         1371  +        }
         1372  +        if {[llength $args]==0} {
         1373  +          return [dict get $clay .delegate]
         1374  +        }
         1375  +        if {[llength $args]==1} {
         1376  +          set stub <[string trim [lindex $args 0] <>]>
         1377  +          if {![dict exists $clay .delegate $stub]} {
         1378  +            return {}
         1379  +          }
         1380  +          return [dict get $clay .delegate $stub]
         1381  +        }
         1382  +        if {([llength $args] % 2)} {
         1383  +          error "Usage: delegate
         1384  +    OR
         1385  +    delegate stub
         1386  +    OR
         1387  +    delegate stub OBJECT ?stub OBJECT? ..."
         1388  +        }
         1389  +        foreach {stub object} $args {
         1390  +          set stub <[string trim $stub <>]>
         1391  +          dict set clay .delegate $stub $object
         1392  +          oo::objdefine [self] forward ${stub} $object
         1393  +          oo::objdefine [self] export ${stub}
         1394  +        }
         1395  +      }
         1396  +      dump {
         1397  +        # Do a full dump of clay data
         1398  +        set result {}
         1399  +        # Search in the in our list of classes for an answer
         1400  +        foreach class $clayorder {
         1401  +          ::clay::tree::dictmerge result [$class clay dump]
         1402  +        }
         1403  +        ::clay::tree::dictmerge result $clay
         1404  +        return $result
         1405  +      }
         1406  +      ensemble_map {
         1407  +        set ensemble [lindex $args 0]
         1408  +        set mensemble [string trim $ensemble :/]
         1409  +        if {[dict exists $claycache method_ensemble $mensemble]} {
         1410  +          return [clay::tree::sanitize [dict get $claycache method_ensemble $mensemble]]
         1411  +        }
         1412  +        set emap [my clay dget method_ensemble $mensemble]
         1413  +        dict set claycache method_ensemble $mensemble $emap
         1414  +        return [clay::tree::sanitize $emap]
         1415  +      }
         1416  +      eval {
         1417  +        set script [lindex $args 0]
         1418  +        set buffer {}
         1419  +        set thisline {}
         1420  +        foreach line [split $script \n] {
         1421  +          append thisline $line
         1422  +          if {![info complete $thisline]} {
         1423  +            append thisline \n
         1424  +            continue
         1425  +          }
         1426  +          set thisline [string trim $thisline]
         1427  +          if {[string index $thisline 0] eq "#"} continue
         1428  +          if {[string length $thisline]==0} continue
         1429  +          if {[lindex $thisline 0] eq "my"} {
         1430  +            # Line already calls out "my", accept verbatim
         1431  +            append buffer $thisline \n
         1432  +          } elseif {[string range $thisline 0 2] eq "::"} {
         1433  +            # Fully qualified commands accepted verbatim
         1434  +            append buffer $thisline \n
         1435  +          } elseif {
         1436  +            append buffer "my $thisline" \n
         1437  +          }
         1438  +          set thisline {}
         1439  +        }
         1440  +        eval $buffer
         1441  +      }
         1442  +      evolve -
         1443  +      initialize {
         1444  +        my InitializePublic
         1445  +      }
         1446  +      exists {
         1447  +        # Leaf searches return one data field at a time
         1448  +        # Search in our local dict
         1449  +        set path [::clay::tree::storage $args]
         1450  +        if {[dict exists $clay {*}$path]} {
         1451  +          return 1
         1452  +        }
         1453  +        # Search in our local cache
         1454  +        if {[dict exists $claycache {*}$path]} {
         1455  +          return 2
         1456  +        }
         1457  +        set count 2
         1458  +        # Search in the in our list of classes for an answer
         1459  +        foreach class $clayorder {
         1460  +          incr count
         1461  +          if {[$class clay exists {*}$path]} {
         1462  +            return $count
         1463  +          }
         1464  +        }
         1465  +        return 0
         1466  +      }
         1467  +      flush {
         1468  +        set claycache {}
         1469  +        set clayorder [::clay::ancestors [info object class [self]] {*}[lreverse [info object mixins [self]]]]
         1470  +      }
         1471  +      forward {
         1472  +        oo::objdefine [self] forward {*}$args
         1473  +      }
         1474  +      dget {
         1475  +        set path [::clay::tree::storage $args]
         1476  +        if {[llength $path]==0} {
         1477  +          # Do a full dump of clay data
         1478  +          set result {}
         1479  +          # Search in the in our list of classes for an answer
         1480  +          foreach class $clayorder {
         1481  +            ::clay::tree::dictmerge result [$class clay dump]
         1482  +          }
         1483  +          ::clay::tree::dictmerge result $clay
         1484  +          return $result
         1485  +        }
         1486  +        if {[dict exists $clay {*}$path] && ![dict exists $clay {*}$path .]} {
         1487  +          # Path is a leaf
         1488  +          return [dict get $clay {*}$path]
         1489  +        }
         1490  +        # Search in our local cache
         1491  +        if {[my clay search $path value isleaf]} {
         1492  +          return $value
         1493  +        }
         1494  +
         1495  +        set found 0
         1496  +        set branch [dict exists $clay {*}$path .]
         1497  +        foreach class $clayorder {
         1498  +          if {[$class clay exists {*}$path .]} {
         1499  +            set found 1
         1500  +            break
         1501  +          }
         1502  +          if {!$branch && [$class clay exists {*}$path]} {
         1503  +            set result [$class clay dget {*}$path]
         1504  +            my clay cache $path $result
         1505  +            return $result
         1506  +          }
         1507  +        }
         1508  +        # Path is a branch
         1509  +        set result [dict getnull $clay {*}$path]
         1510  +        foreach class $clayorder {
         1511  +          if {![$class clay exists {*}$path .]} continue
         1512  +          ::clay::tree::dictmerge result [$class clay dget {*}$path]
         1513  +        }
         1514  +        #if {[dict exists $clay {*}$path .]} {
         1515  +        #  ::clay::tree::dictmerge result
         1516  +        #}
         1517  +        my clay cache $path $result
         1518  +        return $result
         1519  +      }
         1520  +      getnull -
         1521  +      get {
         1522  +        set path [::clay::tree::storage $args]
         1523  +        if {[llength $path]==0} {
         1524  +          # Do a full dump of clay data
         1525  +          set result {}
         1526  +          # Search in the in our list of classes for an answer
         1527  +          foreach class $clayorder {
         1528  +            ::clay::tree::dictmerge result [$class clay dump]
         1529  +          }
         1530  +          ::clay::tree::dictmerge result $clay
         1531  +          return [::clay::tree::sanitize $result]
         1532  +        }
         1533  +        if {[dict exists $clay {*}$path] && ![dict exists $clay {*}$path .]} {
         1534  +          # Path is a leaf
         1535  +          return [dict get $clay {*}$path]
         1536  +        }
         1537  +        # Search in our local cache
         1538  +        if {[my clay search $path value isleaf]} {
         1539  +          if {!$isleaf} {
         1540  +            return [clay::tree::sanitize $value]
         1541  +          } else {
         1542  +            return $value
         1543  +          }
         1544  +        }
         1545  +        set found 0
         1546  +        set branch [dict exists $clay {*}$path .]
         1547  +        foreach class $clayorder {
         1548  +          if {[$class clay exists {*}$path .]} {
         1549  +            set found 1
         1550  +            break
         1551  +          }
         1552  +          if {!$branch && [$class clay exists {*}$path]} {
         1553  +            set result [$class clay dget {*}$path]
         1554  +            my clay cache $path $result
         1555  +            return $result
         1556  +          }
         1557  +        }
         1558  +        # Path is a branch
         1559  +        set result [dict getnull $clay {*}$path]
         1560  +        #foreach class [lreverse $clayorder] {
         1561  +        #  if {![$class clay exists {*}$path .]} continue
         1562  +        #  ::clay::tree::dictmerge result [$class clay dget {*}$path]
         1563  +        #}
         1564  +        foreach class $clayorder {
         1565  +          if {![$class clay exists {*}$path .]} continue
         1566  +          ::clay::tree::dictmerge result [$class clay dget {*}$path]
         1567  +        }
         1568  +        #if {[dict exists $clay {*}$path .]} {
         1569  +        #  ::clay::tree::dictmerge result [dict get $clay {*}$path]
         1570  +        #}
         1571  +        my clay cache $path $result
         1572  +        return [clay::tree::sanitize $result]
         1573  +      }
         1574  +      leaf {
         1575  +        # Leaf searches return one data field at a time
         1576  +        # Search in our local dict
         1577  +        set path [::clay::tree::storage $args]
         1578  +        if {[dict exists $clay {*}$path .]} {
         1579  +          return [clay::tree::sanitize [dict get $clay {*}$path]]
         1580  +        }
         1581  +        if {[dict exists $clay {*}$path]} {
         1582  +          return [dict get $clay {*}$path]
         1583  +        }
         1584  +        # Search in our local cache
         1585  +        if {[my clay search $path value isleaf]} {
         1586  +          if {!$isleaf} {
         1587  +            return [clay::tree::sanitize $value]
         1588  +          } else {
         1589  +            return $value
         1590  +          }
         1591  +        }
         1592  +        # Search in the in our list of classes for an answer
         1593  +        foreach class $clayorder {
         1594  +          if {[$class clay exists {*}$path]} {
         1595  +            set value [$class clay get {*}$path]
         1596  +            my clay cache $path $value
         1597  +            return $value
         1598  +          }
         1599  +        }
         1600  +      }
         1601  +      merge {
         1602  +        foreach arg $args {
         1603  +          ::clay::tree::dictmerge clay {*}$arg
         1604  +        }
         1605  +      }
         1606  +      mixin {
         1607  +        ###
         1608  +        # Mix in the class
         1609  +        ###
         1610  +        my clay flush
         1611  +        set prior  [info object mixins [self]]
         1612  +        set newmixin {}
         1613  +        foreach item $args {
         1614  +          lappend newmixin ::[string trimleft $item :]
         1615  +        }
         1616  +        set newmap $args
         1617  +        foreach class $prior {
         1618  +          if {$class ni $newmixin} {
         1619  +            set script [$class clay search mixin/ unmap-script]
         1620  +            if {[string length $script]} {
         1621  +              if {[catch $script err errdat]} {
         1622  +                puts stderr "[self] MIXIN ERROR POPPING $class:\n[dict get $errdat -errorinfo]"
         1623  +              }
         1624  +            }
         1625  +          }
         1626  +        }
         1627  +        ::oo::objdefine [self] mixin {*}$args
         1628  +        ###
         1629  +        # Build a compsite map of all ensembles defined by the object's current
         1630  +        # class as well as all of the classes being mixed in
         1631  +        ###
         1632  +        my InitializePublic
         1633  +        foreach class $newmixin {
         1634  +          if {$class ni $prior} {
         1635  +            set script [$class clay search mixin/ map-script]
         1636  +            if {[string length $script]} {
         1637  +              if {[catch $script err errdat]} {
         1638  +                puts stderr "[self] MIXIN ERROR PUSHING $class:\n[dict get $errdat -errorinfo]"
         1639  +              }
         1640  +            }
         1641  +          }
         1642  +        }
         1643  +        foreach class $newmixin {
         1644  +          set script [$class clay search mixin/ react-script]
         1645  +          if {[string length $script]} {
         1646  +            if {[catch $script err errdat]} {
         1647  +              puts stderr "[self] MIXIN ERROR PEEKING $class:\n[dict get $errdat -errorinfo]"
         1648  +            }
         1649  +            break
         1650  +          }
         1651  +        }
         1652  +      }
         1653  +      mixinmap {
         1654  +        if {![dict exists $clay .mixin]} {
         1655  +          dict set clay .mixin {}
         1656  +        }
         1657  +        if {[llength $args]==0} {
         1658  +          return [dict get $clay .mixin]
         1659  +        } elseif {[llength $args]==1} {
         1660  +          return [dict getnull $clay .mixin [lindex $args 0]]
         1661  +        } else {
         1662  +          dict for {slot classes} $args {
         1663  +            dict set clay .mixin $slot $classes
         1664  +          }
         1665  +          set classlist {}
         1666  +          dict for {item class} [dict get $clay .mixin] {
         1667  +            if {$class ne {}} {
         1668  +              lappend classlist $class
         1669  +            }
         1670  +          }
         1671  +          my clay mixin {*}[lreverse $classlist]
         1672  +        }
         1673  +      }
         1674  +      provenance {
         1675  +        if {[dict exists $clay {*}$args]} {
         1676  +          return self
         1677  +        }
         1678  +        foreach class $clayorder {
         1679  +          if {[$class clay exists {*}$args]} {
         1680  +            return $class
         1681  +          }
         1682  +        }
         1683  +        return {}
         1684  +      }
         1685  +      refcount {
         1686  +        my variable refcount
         1687  +        if {![info exists refcount]} {
         1688  +          return 0
         1689  +        }
         1690  +        return $refcount
         1691  +      }
         1692  +      refcount_incr {
         1693  +        my variable refcount
         1694  +        incr refcount
         1695  +      }
         1696  +      refcount_decr {
         1697  +        my variable refcount
         1698  +        incr refcount -1
         1699  +        if {$refcount <= 0} {
         1700  +          ::clay::object_destroy [self]
         1701  +        }
         1702  +      }
         1703  +      replace {
         1704  +        set clay [lindex $args 0]
         1705  +      }
         1706  +      search {
         1707  +        set path [lindex $args 0]
         1708  +        upvar 1 [lindex $args 1] value [lindex $args 2] isleaf
         1709  +        set isleaf [expr {![dict exists $claycache $path .]}]
         1710  +        if {[dict exists $claycache $path]} {
         1711  +          set value [dict get $claycache $path]
         1712  +          return 1
         1713  +        }
         1714  +        return 0
         1715  +      }
         1716  +      source {
         1717  +        source [lindex $args 0]
         1718  +      }
         1719  +      set {
         1720  +        #puts [list [self] clay SET {*}$args]
         1721  +        ::clay::tree::dictset clay {*}$args
         1722  +      }
         1723  +      default {
         1724  +        dict $submethod clay {*}$args
         1725  +      }
         1726  +    }
         1727  +  }
         1728  +  method InitializePublic {} {
         1729  +    my variable clayorder clay claycache config option_canonical
         1730  +    set claycache {}
         1731  +    set clayorder [::clay::ancestors [info object class [self]] {*}[lreverse [info object mixins [self]]]]
         1732  +    if {![info exists clay]} {
         1733  +      set clay {}
         1734  +    }
         1735  +    if {![info exists config]} {
         1736  +      set config {}
         1737  +    }
         1738  +    dict for {var value} [my clay get variable] {
         1739  +      if { $var in {. clay} } continue
         1740  +      set var [string trim $var :/]
         1741  +      my variable $var
         1742  +      if {![info exists $var]} {
         1743  +        if {$::clay::trace>2} {puts [list initialize variable $var $value]}
         1744  +        set $var $value
         1745  +      }
         1746  +    }
         1747  +    dict for {var value} [my clay get dict/] {
         1748  +      if { $var in {. clay} } continue
         1749  +      set var [string trim $var :/]
         1750  +      my variable $var
         1751  +      if {![info exists $var]} {
         1752  +        set $var {}
         1753  +      }
         1754  +      foreach {f v} $value {
         1755  +        if {$f eq "."} continue
         1756  +        if {![dict exists ${var} $f]} {
         1757  +          if {$::clay::trace>2} {puts [list initialize dict $var $f $v]}
         1758  +          dict set ${var} $f $v
         1759  +        }
         1760  +      }
         1761  +    }
         1762  +    foreach {var value} [my clay get array/] {
         1763  +      if { $var in {. clay} } continue
         1764  +      set var [string trim $var :/]
         1765  +      if { $var eq {clay} } continue
         1766  +      my variable $var
         1767  +      if {![info exists $var]} { array set $var {} }
         1768  +      foreach {f v} $value {
         1769  +        if {![array exists ${var}($f)]} {
         1770  +          if {$f eq "."} continue
         1771  +          if {$::clay::trace>2} {puts [list initialize array $var\($f\) $v]}
         1772  +          set ${var}($f) $v
         1773  +        }
         1774  +      }
         1775  +    }
         1776  +    foreach {field info} [my clay get option/] {
         1777  +      if { $field in {. clay} } continue
         1778  +      set field [string trim $field -/:]
         1779  +      foreach alias [dict getnull $info aliases] {
         1780  +        set option_canonical($alias) $field
         1781  +      }
         1782  +      if {[dict exists $config $field]} continue
         1783  +      set getcmd [dict getnull $info default-command]
         1784  +      if {$getcmd ne {}} {
         1785  +        set value [{*}[string map [list %field% $field %self% [namespace which my]] $getcmd]]
         1786  +      } else {
         1787  +        set value [dict getnull $info default]
         1788  +      }
         1789  +      dict set config $field $value
         1790  +      set setcmd [dict getnull $info set-command]
         1791  +      if {$setcmd ne {}} {
         1792  +        {*}[string map [list %field% [list $field] %value% [list $value] %self% [namespace which my]] $setcmd]
         1793  +      }
         1794  +    }
         1795  +    if {[info exists clay]} {
         1796  +      set emap [dict getnull $clay method_ensemble]
         1797  +    } else {
         1798  +      set emap {}
         1799  +    }
         1800  +    foreach class [lreverse $clayorder] {
         1801  +      ###
         1802  +      # Build a compsite map of all ensembles defined by the object's current
         1803  +      # class as well as all of the classes being mixed in
         1804  +      ###
         1805  +      dict for {mensemble einfo} [$class clay get method_ensemble] {
         1806  +        if {$mensemble eq {.}} continue
         1807  +        set ensemble [string trim $mensemble :/]
         1808  +        if {$::clay::trace>2} {puts [list Defining $ensemble from $class]}
         1809  +
         1810  +        dict for {method info} $einfo {
         1811  +          if {$method eq {.}} continue
         1812  +          if {![dict is_dict $info]} {
         1813  +            puts [list WARNING: class: $class method: $method not dict: $info]
         1814  +            continue
         1815  +          }
         1816  +          dict set info source $class
         1817  +          if {$::clay::trace>2} {puts [list Defining $ensemble -> $method from $class - $info]}
         1818  +          dict set emap $ensemble $method $info
         1819  +        }
         1820  +      }
         1821  +    }
         1822  +    foreach {ensemble einfo} $emap {
         1823  +      #if {[dict exists $einfo _body]} continue
         1824  +      set body [::clay::ensemble_methodbody $ensemble $einfo]
         1825  +      if {$::clay::trace>2} {
         1826  +        set rawbody $body
         1827  +        set body {puts [list [self] <object> [self method]]}
         1828  +        append body \n $rawbody
         1829  +      }
         1830  +      oo::objdefine [self] method $ensemble {{method default} args} $body
         1831  +    }
         1832  +  }
         1833  +}
         1834  +::clay::object clay branch array
         1835  +::clay::object clay branch mixin
         1836  +::clay::object clay branch option
         1837  +::clay::object clay branch dict clay
         1838  +::clay::object clay set variable DestroyEvent 0
         1839  +if {[info commands ::cron::object_destroy] eq {}} {
         1840  +  # Provide a noop if we aren't running with the cron scheduler
         1841  +  namespace eval ::cron {}
         1842  +  proc ::cron::object_destroy args {}
         1843  +}
         1844  +::namespace eval ::clay::event {
         1845  +}
         1846  +proc ::clay::cleanup {} {
         1847  +  set count 0
         1848  +  if {![info exists ::clay::idle_destroy]} return
         1849  +  set objlist $::clay::idle_destroy
         1850  +  set ::clay::idle_destroy {}
         1851  +  foreach obj $objlist {
         1852  +    if {![catch {$obj destroy}]} {
         1853  +      incr count
         1854  +    }
         1855  +  }
         1856  +  return $count
         1857  +}
         1858  +proc ::clay::object_create {objname {class {}}} {
         1859  +  #if {$::clay::trace>0} {
         1860  +  #  puts [list $objname CREATE]
         1861  +  #}
         1862  +}
         1863  +proc ::clay::object_rename {object newname} {
         1864  +  if {$::clay::trace>0} {
         1865  +    puts [list $object RENAME -> $newname]
         1866  +  }
         1867  +}
         1868  +proc ::clay::object_destroy args {
         1869  +  if {![info exists ::clay::idle_destroy]} {
         1870  +    set ::clay::idle_destroy {}
         1871  +  }
         1872  +  foreach objname $args {
         1873  +    if {$::clay::trace>0} {
         1874  +      puts [list $objname DESTROY]
         1875  +    }
         1876  +    ::cron::object_destroy $objname
         1877  +    if {$objname in $::clay::idle_destroy} continue
         1878  +    lappend ::clay::idle_destroy $objname
         1879  +  }
         1880  +}
         1881  +proc ::clay::event::cancel {self {task *}} {
         1882  +  variable timer_event
         1883  +  variable timer_script
         1884  +
         1885  +  foreach {id event} [array get timer_event $self:$task] {
         1886  +    ::after cancel $event
         1887  +    set timer_event($id) {}
         1888  +    set timer_script($id) {}
         1889  +  }
         1890  +}
         1891  +proc ::clay::event::generate {self event args} {
         1892  +  set wholist [Notification_list $self $event]
         1893  +  if {$wholist eq {}} return
         1894  +  set dictargs [::oo::meta::args_to_options {*}$args]
         1895  +  set info $dictargs
         1896  +  set strict 0
         1897  +  set debug 0
         1898  +  set sender $self
         1899  +  dict with dictargs {}
         1900  +  dict set info id     [::clay::event::nextid]
         1901  +  dict set info origin $self
         1902  +  dict set info sender $sender
         1903  +  dict set info rcpt   {}
         1904  +  foreach who $wholist {
         1905  +    catch {::clay::event::notify $who $self $event $info}
         1906  +  }
         1907  +}
         1908  +proc ::clay::event::nextid {} {
         1909  +  return "event#[format %0.8x [incr ::clay::event_count]]"
         1910  +}
         1911  +proc ::clay::event::Notification_list {self event {stackvar {}}} {
         1912  +  set notify_list {}
         1913  +  foreach {obj patternlist} [array get ::clay::object_subscribe] {
         1914  +    if {$obj eq $self} continue
         1915  +    if {$obj in $notify_list} continue
         1916  +    set match 0
         1917  +    foreach {objpat eventlist} $patternlist {
         1918  +      if {![string match $objpat $self]} continue
         1919  +      foreach eventpat $eventlist {
         1920  +        if {![string match $eventpat $event]} continue
         1921  +        set match 1
         1922  +        break
         1923  +      }
         1924  +      if {$match} {
         1925  +        break
         1926  +      }
         1927  +    }
         1928  +    if {$match} {
         1929  +      lappend notify_list $obj
         1930  +    }
         1931  +  }
         1932  +  return $notify_list
         1933  +}
         1934  +proc ::clay::event::notify {rcpt sender event eventinfo} {
         1935  +  if {[info commands $rcpt] eq {}} return
         1936  +  if {$::clay::trace} {
         1937  +    puts [list event notify rcpt $rcpt sender $sender event $event info $eventinfo]
         1938  +  }
         1939  +  $rcpt notify $event $sender $eventinfo
         1940  +}
         1941  +proc ::clay::event::process {self handle script} {
         1942  +  variable timer_event
         1943  +  variable timer_script
         1944  +
         1945  +  array unset timer_event $self:$handle
         1946  +  array unset timer_script $self:$handle
         1947  +
         1948  +  set err [catch {uplevel #0 $script} result errdat]
         1949  +  if $err {
         1950  +    puts "BGError: $self $handle $script
         1951  +ERR: $result
         1952  +[dict get $errdat -errorinfo]
         1953  +***"
         1954  +  }
         1955  +}
         1956  +proc ::clay::event::schedule {self handle interval script} {
         1957  +  variable timer_event
         1958  +  variable timer_script
         1959  +  if {$::clay::trace} {
         1960  +    puts [list $self schedule $handle $interval]
         1961  +  }
         1962  +  if {[info exists timer_event($self:$handle)]} {
         1963  +    if {$script eq $timer_script($self:$handle)} {
         1964  +      return
         1965  +    }
         1966  +    ::after cancel $timer_event($self:$handle)
         1967  +  }
         1968  +  set timer_script($self:$handle) $script
         1969  +  set timer_event($self:$handle) [::after $interval [list ::clay::event::process $self $handle $script]]
         1970  +}
         1971  +proc ::clay::event::subscribe {self who event} {
         1972  +  upvar #0 ::clay::object_subscribe($self) subscriptions
         1973  +  if {![info exists subscriptions]} {
         1974  +    set subscriptions {}
         1975  +  }
         1976  +  set match 0
         1977  +  foreach {objpat eventlist} $subscriptions {
         1978  +    if {![string match $objpat $who]} continue
         1979  +    foreach eventpat $eventlist {
         1980  +      if {[string match $eventpat $event]} {
         1981  +        # This rule already exists
         1982  +        return
         1983  +      }
         1984  +    }
         1985  +  }
         1986  +  dict lappend subscriptions $who $event
         1987  +}
         1988  +proc ::clay::event::unsubscribe {self args} {
         1989  +  upvar #0 ::clay::object_subscribe($self) subscriptions
         1990  +  if {![info exists subscriptions]} {
         1991  +    return
         1992  +  }
         1993  +  switch [llength $args] {
         1994  +    1 {
         1995  +      set event [lindex $args 0]
         1996  +      if {$event eq "*"} {
         1997  +        # Shortcut, if the
         1998  +        set subscriptions {}
         1999  +      } else {
         2000  +        set newlist {}
         2001  +        foreach {objpat eventlist} $subscriptions {
         2002  +          foreach eventpat $eventlist {
         2003  +            if {[string match $event $eventpat]} continue
         2004  +            dict lappend newlist $objpat $eventpat
         2005  +          }
         2006  +        }
         2007  +        set subscriptions $newlist
         2008  +      }
         2009  +    }
         2010  +    2 {
         2011  +      set who [lindex $args 0]
         2012  +      set event [lindex $args 1]
         2013  +      if {$who eq "*" && $event eq "*"} {
         2014  +        set subscriptions {}
         2015  +      } else {
         2016  +        set newlist {}
         2017  +        foreach {objpat eventlist} $subscriptions {
         2018  +          if {[string match $who $objpat]} {
         2019  +            foreach eventpat $eventlist {
         2020  +              if {[string match $event $eventpat]} continue
         2021  +              dict lappend newlist $objpat $eventpat
         2022  +            }
         2023  +          }
         2024  +        }
         2025  +        set subscriptions $newlist
         2026  +      }
         2027  +    }
         2028  +  }
         2029  +}
         2030  +namespace eval ::clay {
         2031  +  namespace export *
         2032  +}
         2033  +
         2034  +###
         2035  +# END: clay/clay.tcl
         2036  +###
         2037  +###
         2038  +# START: setup.tcl
         2039  +###
         2040  +package require TclOO
         2041  +set tcllib_path {}
         2042  +foreach path {.. ../.. ../../..} {
         2043  +  foreach path [glob -nocomplain [file join [file normalize $path] tcllib* modules]] {
         2044  +    set tclib_path $path
         2045  +    lappend ::auto_path $path
         2046  +    break
         2047  +  }
         2048  +  if {$tcllib_path ne {}} break
         2049  +}
         2050  +namespace eval ::practcl {
         2051  +}
         2052  +namespace eval ::practcl::OBJECT {
         2053  +}
         2054  +
         2055  +###
         2056  +# END: setup.tcl
         2057  +###
         2058  +###
         2059  +# START: doctool.tcl
         2060  +###
         2061  +namespace eval ::practcl {
         2062  +}
         2063  +proc ::practcl::cat fname {
         2064  +    if {![file exists $fname]} {
         2065  +       return
         2066  +    }
         2067  +    set fin [open $fname r]
         2068  +    set data [read $fin]
         2069  +    close $fin
         2070  +    return $data
         2071  +}
         2072  +proc ::practcl::docstrip text {
         2073  +  set result {}
         2074  +  foreach line [split $text \n] {
         2075  +    append thisline $line \n
         2076  +    if {![info complete $thisline]} continue
         2077  +    set outline $thisline
         2078  +    set thisline {}
         2079  +    if {[string trim $outline] eq {}} {
         2080  +      continue
         2081  +    }
         2082  +    if {[string index [string trim $outline] 0] eq "#"} continue
         2083  +    set cmd [string trim [lindex $outline 0] :]
         2084  +    if {$cmd eq "namespace" && [lindex $outline 1] eq "eval"} {
         2085  +      append result [list {*}[lrange $outline 0 end-1]] " " \{ \n [docstrip [lindex $outline end]]\} \n
         2086  +      continue
         2087  +    }
         2088  +    if {[string match "*::define" $cmd] && [llength $outline]==3} {
         2089  +      append result [list {*}[lrange $outline 0 end-1]] " " \{ \n [docstrip [lindex $outline end]]\} \n
         2090  +      continue
         2091  +    }
         2092  +    if {$cmd eq "oo::class" && [lindex $outline 1] eq "create"} {
         2093  +      append result [list {*}[lrange $outline 0 end-1]] " " \{ \n [docstrip [lindex $outline end]]\} \n
         2094  +      continue
         2095  +    }
         2096  +    append result $outline
         2097  +  }
         2098  +  return $result
         2099  +}
         2100  +proc ::putb {buffername args} {
         2101  +  upvar 1 $buffername buffer
         2102  +  switch [llength $args] {
         2103  +    1 {
         2104  +      append buffer [lindex $args 0] \n
         2105  +    }
         2106  +    2 {
         2107  +      append buffer [string map {*}$args] \n
         2108  +    }
         2109  +    default {
         2110  +      error "usage: putb buffername ?map? string"
         2111  +    }
         2112  +  }
         2113  +}
         2114  +::oo::class create ::practcl::doctool {
         2115  +  constructor {} {
         2116  +    my reset
         2117  +  }
         2118  +  method argspec {argspec} {
         2119  +    set result [dict create]
         2120  +    foreach arg $argspec {
         2121  +      set name [lindex $arg 0]
         2122  +      dict set result $name positional 1
         2123  +      dict set result $name mandatory  1
         2124  +      if {$name in {args dictargs}} {
         2125  +        switch [llength $arg] {
         2126  +          1 {
         2127  +            dict set result $name mandatory 0
         2128  +          }
         2129  +          2 {
         2130  +            dict for {optname optinfo} [lindex $arg 1] {
         2131  +              set optname [string trim $optname -:]
         2132  +              dict set result $optname {positional 1 mandatory 0}
         2133  +              dict for {f v} $optinfo {
         2134  +                dict set result $optname [string trim $f -:] $v
         2135  +              }
         2136  +            }
         2137  +          }
         2138  +          default {
         2139  +            error "Bad argument"
         2140  +          }
         2141  +        }
         2142  +      } else {
         2143  +        switch [llength $arg] {
         2144  +          1 {
         2145  +            dict set result $name mandatory 1
         2146  +          }
         2147  +          2 {
         2148  +            dict set result $name mandatory 0
         2149  +            dict set result $name default   [lindex $arg 1]
         2150  +          }
         2151  +          default {
         2152  +            error "Bad argument"
         2153  +          }
         2154  +        }
         2155  +      }
         2156  +    }
         2157  +    return $result
         2158  +  }
         2159  +  method comment block {
         2160  +    set count 0
         2161  +    set field description
         2162  +    set result [dict create description {}]
         2163  +    foreach line [split $block \n] {
         2164  +      set sline [string trim $line]
         2165  +      set fwidx [string first " " $sline]
         2166  +      if {$fwidx < 0} {
         2167  +        set firstword [string range $sline 0 end]
         2168  +        set restline {}
         2169  +      } else {
         2170  +        set firstword [string range $sline 0 [expr {$fwidx-1}]]
         2171  +        set restline [string range $sline [expr {$fwidx+1}] end]
         2172  +      }
         2173  +      if {[string index $firstword end] eq ":"} {
         2174  +        set field [string tolower [string trim $firstword -:]]
         2175  +        switch $field {
         2176  +          dictargs -
         2177  +          arglist {
         2178  +            set field argspec
         2179  +          }
         2180  +          desc {
         2181  +            set field description
         2182  +          }
         2183  +        }
         2184  +        if {[string length $restline]} {
         2185  +          dict append result $field "$restline\n"
         2186  +        }
         2187  +      } else {
         2188  +        dict append result $field "$line\n"
         2189  +      }
         2190  +    }
         2191  +    return $result
         2192  +  }
         2193  +  method keyword.Annotation {resultvar commentblock type name body} {
         2194  +    upvar 1 $resultvar result
         2195  +    set name [string trim $name :]
         2196  +    if {[dict exists $result $type $name]} {
         2197  +      set info [dict get $result $type $name]
         2198  +    } else {
         2199  +      set info [my comment $commentblock]
         2200  +    }
         2201  +    foreach {f v} $body {
         2202  +      dict set info $f $v
         2203  +    }
         2204  +    dict set result $type $name $info
         2205  +  }
         2206  +  method keyword.Class {resultvar commentblock name body} {
         2207  +    upvar 1 $resultvar result
         2208  +    set name [string trim $name :]
         2209  +    if {[dict exists $result class $name]} {
         2210  +      set info [dict get $result class $name]
         2211  +    } else {
         2212  +      set info [my comment $commentblock]
         2213  +    }
         2214  +    set commentblock {}
         2215  +    foreach line [split $body \n] {
         2216  +      append thisline $line \n
         2217  +      if {![info complete $thisline]} continue
         2218  +      set thisline [string trim $thisline]
         2219  +      if {[string index $thisline 0] eq "#"} {
         2220  +        append commentblock [string trimleft $thisline #] \n
         2221  +        set thisline {}
         2222  +        continue
         2223  +      }
         2224  +      set cmd [string trim [lindex $thisline 0] ":"]
         2225  +      switch $cmd {
         2226  +        Option -
         2227  +        option {
         2228  +          my keyword.Annotation info $commentblock option [lindex $thisline 1] [lindex $thisline 2]
         2229  +          set commentblock {}
         2230  +        }
         2231  +        variable -
         2232  +        Variable {
         2233  +          my keyword.Annotation info $commentblock variable [lindex $thisline 1] [list type scaler default [lindex $thisline 2]]
         2234  +          set commentblock {}
         2235  +        }
         2236  +        Dict -
         2237  +        Array {
         2238  +          set iinfo [lindex $thisline 2]
         2239  +          dict set iinfo type [string tolower $cmd]
         2240  +          my keyword.Annotation info $commentblock variable [lindex $thisline 1] $iinfo
         2241  +          set commentblock {}
         2242  +        }
         2243  +        Componant -
         2244  +        Delegate {
         2245  +          my keyword.Annotation info $commentblock delegate [lindex $thisline 1] [lindex $thisline 2]
         2246  +          set commentblock {}
         2247  +        }
         2248  +        method -
         2249  +        Ensemble {
         2250  +          my keyword.Class_Method info $commentblock  {*}[lrange $thisline 1 end-1]
         2251  +          set commentblock {}
         2252  +        }
         2253  +      }
         2254  +      set thisline {}
         2255  +    }
         2256  +    dict set result class $name $info
         2257  +  }
         2258  +  method keyword.class {resultvar commentblock name body} {
         2259  +    upvar 1 $resultvar result
         2260  +    set name [string trim $name :]
         2261  +    if {[dict exists $result class $name]} {
         2262  +      set info [dict get $result class $name]
         2263  +    } else {
         2264  +      set info [my comment $commentblock]
         2265  +    }
         2266  +    set commentblock {}
         2267  +    foreach line [split $body \n] {
         2268  +      append thisline $line \n
         2269  +      if {![info complete $thisline]} continue
         2270  +      set thisline [string trim $thisline]
         2271  +      if {[string index $thisline 0] eq "#"} {
         2272  +        append commentblock [string trimleft $thisline #] \n
         2273  +        set thisline {}
         2274  +        continue
         2275  +      }
         2276  +      set cmd [string trim [lindex $thisline 0] ":"]
         2277  +      switch $cmd {
         2278  +        Option -
         2279  +        option {
         2280  +          puts [list keyword.Annotation $cmd $thisline]
         2281  +          my keyword.Annotation info $commentblock option [lindex $thisline 1] [lindex $thisline 2]
         2282  +          set commentblock {}
         2283  +        }
         2284  +        variable -
         2285  +        Variable {
         2286  +          my keyword.Annotation info $commentblock variable [lindex $thisline 1] [list default [lindex $thisline 2]]
         2287  +          set commentblock {}
         2288  +        }
         2289  +        Dict -
         2290  +        Array {
         2291  +          set iinfo [lindex $thisline 2]
         2292  +          dict set iinfo type [string tolower $cmd]
         2293  +          my keyword.Annotation info $commentblock variable [lindex $thisline 1] $iinfo
         2294  +          set commentblock {}
         2295  +        }
         2296  +        Componant -
         2297  +        Delegate {
         2298  +          my keyword.Annotation info $commentblock delegate [lindex $thisline 1] [lindex $thisline 2]
         2299  +          set commentblock {}
         2300  +        }
         2301  +        superclass {
         2302  +          dict set info ancestors [lrange $thisline 1 end]
         2303  +          set commentblock {}
         2304  +        }
         2305  +        classmethod -
         2306  +        class_method -
         2307  +        Class_Method {
         2308  +          my keyword.Class_Method info $commentblock  {*}[lrange $thisline 1 end-1]
         2309  +          set commentblock {}
         2310  +        }
         2311  +        destructor -
         2312  +        constructor {
         2313  +          my keyword.method info $commentblock {*}[lrange $thisline 0 end-1]
         2314  +          set commentblock {}
         2315  +        }
         2316  +        method -
         2317  +        Ensemble {
         2318  +          my keyword.method info $commentblock  {*}[lrange $thisline 1 end-1]
         2319  +          set commentblock {}
         2320  +        }
         2321  +      }
         2322  +      set thisline {}
         2323  +    }
         2324  +    dict set result class $name $info
         2325  +  }
         2326  +  method keyword.Class_Method {resultvar commentblock name args} {
         2327  +    upvar 1 $resultvar result
         2328  +    set info [my comment $commentblock]
         2329  +    if {[dict exists $info show_body] && [dict get $info show_body]} {
         2330  +      dict set info internals [lindex $args end]
         2331  +    }
         2332  +    if {[dict exists $info ensemble]} {
         2333  +      dict for {method minfo} [dict get $info ensemble] {
         2334  +        dict set result Class_Method "${name} $method" $minfo
         2335  +      }
         2336  +    } else {
         2337  +      switch [llength $args] {
         2338  +        1 {
         2339  +          set argspec [lindex $args 0]
         2340  +        }
         2341  +        0 {
         2342  +          set argspec dictargs
         2343  +          #set body [lindex $args 0]
         2344  +        }
         2345  +        default {error "could not interpret method $name {*}$args"}
         2346  +      }
         2347  +      if {![dict exists $info argspec]} {
         2348  +        dict set info argspec [my argspec $argspec]
         2349  +      }
         2350  +      dict set result Class_Method [string trim $name :] $info
         2351  +    }
         2352  +  }
         2353  +  method keyword.method {resultvar commentblock name args} {
         2354  +    upvar 1 $resultvar result
         2355  +    set info [my comment $commentblock]
         2356  +    if {[dict exists $info show_body] && [dict get $info show_body]} {
         2357  +      dict set info internals [lindex $args end]
         2358  +    }
         2359  +    if {[dict exists $info ensemble]} {
         2360  +      dict for {method minfo} [dict get $info ensemble] {
         2361  +        dict set result method "\"${name} $method\"" $minfo
         2362  +      }
         2363  +    } else {
         2364  +      switch [llength $args] {
         2365  +        1 {
         2366  +          set argspec [lindex $args 0]
         2367  +        }
         2368  +        0 {
         2369  +          set argspec dictargs
         2370  +          #set body [lindex $args 0]
         2371  +        }
         2372  +        default {error "could not interpret method $name {*}$args"}
         2373  +      }
         2374  +      if {![dict exists $info argspec]} {
         2375  +        dict set info argspec [my argspec $argspec]
         2376  +      }
         2377  +      dict set result method "\"[split [string trim $name :] ::]\"" $info
         2378  +    }
         2379  +  }
         2380  +  method keyword.proc {commentblock name argspec} {
         2381  +    set info [my comment $commentblock]
         2382  +    if {![dict exists $info argspec]} {
         2383  +      dict set info argspec [my argspec $argspec]
         2384  +    }
         2385  +    return $info
         2386  +  }
         2387  +  method reset {} {
         2388  +    my variable coro
         2389  +    set coro [info object namespace [self]]::coro
         2390  +    oo::objdefine [self] forward coro $coro
         2391  +    if {[info command $coro] ne {}} {
         2392  +      rename $coro {}
         2393  +    }
         2394  +    coroutine $coro {*}[namespace code {my Main}]
         2395  +  }
         2396  +  method Main {} {
         2397  +
         2398  +    my variable info
         2399  +    set info [dict create]
         2400  +    yield [info coroutine]
         2401  +    set thisline {}
         2402  +    set commentblock {}
         2403  +    set linec 0
         2404  +    while 1 {
         2405  +      set line [yield]
         2406  +      append thisline $line \n
         2407  +      if {![info complete $thisline]} continue
         2408  +      set thisline [string trim $thisline]
         2409  +      if {[string index $thisline 0] eq "#"} {
         2410  +        append commentblock [string trimleft $thisline #] \n
         2411  +        set thisline {}
         2412  +        continue
         2413  +      }
         2414  +      set cmd [string trim [lindex $thisline 0] ":"]
         2415  +      switch $cmd {
         2416  +        dictargs::proc {
         2417  +          set procinfo [my keyword.proc $commentblock [lindex $thisline 1] [list args [list dictargs [lindex $thisline 2]]]]
         2418  +          if {[dict exists $procinfo show_body] && [dict get $procinfo show_body]} {
         2419  +            dict set procinfo internals [lindex $thisline end]
         2420  +          }
         2421  +          dict set info proc [string trim [lindex $thisline 1] :] $procinfo
         2422  +          set commentblock {}
         2423  +        }
         2424  +        tcllib::PROC -
         2425  +        PROC -
         2426  +        Proc -
         2427  +        proc {
         2428  +          set procinfo [my keyword.proc $commentblock {*}[lrange $thisline 1 2]]
         2429  +          if {[dict exists $procinfo show_body] && [dict get $procinfo show_body]} {
         2430  +            dict set procinfo internals [lindex $thisline end]
         2431  +          }
         2432  +          dict set info proc [string trim [lindex $thisline 1] :] $procinfo
         2433  +          set commentblock {}
         2434  +        }
         2435  +        oo::objdefine {
         2436  +          if {[llength $thisline]==3} {
         2437  +            lassign $thisline tcmd name body
         2438  +            my keyword.Class info $commentblock $name $body
         2439  +          } else {
         2440  +            puts "Warning: bare oo::define in library"
         2441  +          }
         2442  +        }
         2443  +        oo::define {
         2444  +          if {[llength $thisline]==3} {
         2445  +            lassign $thisline tcmd name body
         2446  +            my keyword.class info $commentblock $name $body
         2447  +          } else {
         2448  +            puts "Warning: bare oo::define in library"
         2449  +          }
         2450  +        }
         2451  +        tao::define -
         2452  +        clay::define -
         2453  +        tool::define {
         2454  +          lassign $thisline tcmd name body
         2455  +          my keyword.class info $commentblock $name $body
         2456  +          set commentblock {}
         2457  +        }
         2458  +        oo::class {
         2459  +          lassign $thisline tcmd mthd name body
         2460  +          my keyword.class info $commentblock $name $body
         2461  +          set commentblock {}
         2462  +        }
         2463  +        default {
         2464  +          if {[lindex [split $cmd ::] end] eq "define"} {
         2465  +            lassign $thisline tcmd name body
         2466  +            my keyword.class info $commentblock $name $body
         2467  +            set commentblock {}
         2468  +          }
         2469  +          set commentblock {}
         2470  +        }
         2471  +      }
         2472  +      set thisline {}
         2473  +    }
         2474  +  }
         2475  +  method section.method {keyword method minfo} {
         2476  +    set result {}
         2477  +    set line "\[call $keyword \[cmd $method\]"
         2478  +    if {[dict exists $minfo argspec]} {
         2479  +      dict for {argname arginfo} [dict get $minfo argspec] {
         2480  +        set positional 1
         2481  +        set mandatory  1
         2482  +        set repeating 0
         2483  +        dict with arginfo {}
         2484  +        if {$mandatory==0} {
         2485  +          append line " \[opt \""
         2486  +        } else {
         2487  +          append line " "
         2488  +        }
         2489  +        if {$positional} {
         2490  +          append line "\[arg $argname"
         2491  +        } else {
         2492  +          append line "\[option \"$argname"
         2493  +          if {[dict exists $arginfo type]} {
         2494  +            append line " \[emph [dict get $arginfo type]\]"
         2495  +          } else {
         2496  +            append line " \[emph value\]"
         2497  +          }
         2498  +          append line "\""
         2499  +        }
         2500  +        append line "\]"
         2501  +        if {$mandatory==0} {
         2502  +          if {[dict exists $arginfo default]} {
         2503  +            append line " \[const \"[dict get $arginfo default]\"\]"
         2504  +          }
         2505  +          append line "\"\]"
         2506  +        }
         2507  +        if {$repeating} {
         2508  +          append line " \[opt \[option \"$argname...\"\]\]"
         2509  +        }
         2510  +      }
         2511  +    }
         2512  +    append line \]
         2513  +    putb result $line
         2514  +    if {[dict exists $minfo description]} {
         2515  +      putb result [dict get $minfo description]
         2516  +    }
         2517  +    if {[dict exists $minfo example]} {
         2518  +      putb result "\[para\]Example: \[example [list [dict get $minfo example]]\]"
         2519  +    }
         2520  +    if {[dict exists $minfo internals]} {
         2521  +      putb result "\[para\]Internals: \[example [list [dict get $minfo internals]]\]"
         2522  +    }
         2523  +    return $result
         2524  +  }
         2525  +  method section.annotation {type name iinfo} {
         2526  +    set result "\[call $type \[cmd $name\]\]"
         2527  +    if {[dict exists $iinfo description]} {
         2528  +      putb result [dict get $iinfo description]
         2529  +    }
         2530  +    if {[dict exists $iinfo example]} {
         2531  +      putb result "\[para\]Example: \[example [list [dict get $minfo example]]\]"
         2532  +    }
         2533  +    return $result
         2534  +  }
         2535  +  method section.class {class_name class_info} {
         2536  +    set result {}
         2537  +    putb result "\[subsection \{Class  $class_name\}\]"
         2538  +    if {[dict exists $class_info ancestors]} {
         2539  +      set line "\[emph \"ancestors\"\]:"
         2540  +      foreach {c} [dict get $class_info ancestors] {
         2541  +        append line " \[class [string trim $c :]\]"
         2542  +      }
         2543  +      putb result $line
         2544  +      putb result {[para]}
         2545  +    }
         2546  +    dict for {f v} $class_info {
         2547  +      if {$f in {Class_Method method description ancestors example option variable delegate}} continue
         2548  +      putb result "\[emph \"$f\"\]: $v"
         2549  +      putb result {[para]}
         2550  +    }
         2551  +    if {[dict exists $class_info example]} {
         2552  +      putb result "\[example \{[list [dict get $class_info example]]\}\]"
         2553  +      putb result {[para]}
         2554  +    }
         2555  +    if {[dict exists $class_info description]} {
         2556  +      putb result [dict get $class_info description]
         2557  +      putb result {[para]}
         2558  +    }
         2559  +    dict for {f v} $class_info {
         2560  +      if {$f ni {option variable delegate}} continue
         2561  +      putb result "\[class \{[string totitle $f]\}\]"
         2562  +      #putb result "Methods on the class object itself."
         2563  +      putb result {[list_begin definitions]}
         2564  +      dict for {item iinfo} [dict get $class_info $f] {
         2565  +        putb result [my section.annotation $f $item $iinfo]
         2566  +      }
         2567  +      putb result {[list_end]}
         2568  +      putb result {[para]}
         2569  +    }
         2570  +    if {[dict exists $class_info Class_Method]} {
         2571  +      putb result "\[class \{Class Methods\}\]"
         2572  +      #putb result "Methods on the class object itself."
         2573  +      putb result {[list_begin definitions]}
         2574  +      dict for {method minfo} [dict get $class_info Class_Method] {
         2575  +        putb result [my section.method classmethod $method $minfo]
         2576  +      }
         2577  +      putb result {[list_end]}
         2578  +      putb result {[para]}
         2579  +    }
         2580  +    if {[dict exists $class_info method]} {
         2581  +      putb result "\[class {Methods}\]"
         2582  +      putb result {[list_begin definitions]}
         2583  +      dict for {method minfo} [dict get $class_info method] {
         2584  +        putb result [my section.method method $method $minfo]
         2585  +      }
         2586  +      putb result {[list_end]}
         2587  +      putb result {[para]}
         2588  +    }
         2589  +    return $result
         2590  +  }
         2591  +  method section.command {procinfo} {
         2592  +    set result {}
         2593  +    putb result "\[section \{Commands\}\]"
         2594  +    putb result {[list_begin definitions]}
         2595  +    dict for {method minfo} $procinfo {
         2596  +      putb result [my section.method proc $method $minfo]
         2597  +    }
         2598  +    putb result {[list_end]}
         2599  +    return $result
         2600  +  }
         2601  +  method manpage args {
         2602  +    my variable info
         2603  +    set map {%version% 0.0 %module% {Your_Module_Here}}
         2604  +    set result {}
         2605  +    set header {}
         2606  +    set footer {}
         2607  +    set authors {}
         2608  +    dict with args {}
         2609  +    dict set map %keyword% comment
         2610  +    putb result $map {[%keyword% {-*- tcl -*- doctools manpage}]
         2611  +[vset PACKAGE_VERSION %version%]
         2612  +[manpage_begin %module% n [vset PACKAGE_VERSION]]}
         2613  +    putb result $map $header
         2614  +
         2615  +    dict for {sec_type sec_info} $info {
         2616  +      switch $sec_type {
         2617  +        proc {
         2618  +          putb result [my section.command $sec_info]
         2619  +        }
         2620  +        class {
         2621  +          putb result "\[section Classes\]"
         2622  +          dict for {class_name class_info} $sec_info {
         2623  +            putb result [my section.class $class_name $class_info]
         2624  +          }
         2625  +        }
         2626  +        default {
         2627  +          putb result "\[section [list $sec_type $sec_name]\]"
         2628  +          if {[dict exists $sec_info description]} {
         2629  +            putb result [dict get $sec_info description]
         2630  +          }
         2631  +        }
         2632  +      }
         2633  +    }
         2634  +    if {[llength $authors]} {
         2635  +      putb result {[section AUTHORS]}
         2636  +      foreach {name email} $authors {
         2637  +        putb result "$name \[uri mailto:$email\]\[para\]"
         2638  +      }
         2639  +    }
         2640  +    putb result $footer
         2641  +    putb result {[manpage_end]}
         2642  +    return $result
         2643  +  }
         2644  +  method scan_text {text} {
         2645  +    my variable linecount coro
         2646  +    set linecount 0
         2647  +    foreach line [split $text \n] {
         2648  +      incr linecount
         2649  +      $coro $line
         2650  +    }
         2651  +  }
         2652  +  method scan_file {filename} {
         2653  +    my variable linecount coro
         2654  +    set fin [open $filename r]
         2655  +    set linecount 0
         2656  +    while {[gets $fin line]>=0} {
         2657  +      incr linecount
         2658  +      $coro $line
         2659  +    }
         2660  +    close $fin
         2661  +  }
         2662  +}
         2663  +
         2664  +###
         2665  +# END: doctool.tcl
         2666  +###
         2667  +###
         2668  +# START: buildutil.tcl
         2669  +###
         2670  +proc Proc {name arglist body} {
         2671  +  if {[info command $name] ne {}} return
         2672  +  proc $name $arglist $body
         2673  +}
         2674  +Proc ::noop args {}
         2675  +proc ::practcl::debug args {
         2676  +  #puts $args
         2677  +  ::practcl::cputs ::DEBUG_INFO $args
         2678  +}
         2679  +proc ::practcl::doexec args {
         2680  +  puts [list {*}$args]
         2681  +  exec {*}$args >&@ stdout
         2682  +}
         2683  +proc ::practcl::doexec_in {path args} {
         2684  +  set PWD [pwd]
         2685  +  cd $path
         2686  +  puts [list {*}$args]
         2687  +  exec {*}$args >&@ stdout
         2688  +  cd $PWD
         2689  +}
         2690  +proc ::practcl::dotclexec args {
         2691  +  puts [list [info nameofexecutable] {*}$args]
         2692  +  exec [info nameofexecutable] {*}$args >&@ stdout
         2693  +}
         2694  +proc ::practcl::domake {path args} {
         2695  +  set PWD [pwd]
         2696  +  cd $path
         2697  +  puts [list *** $path ***]
         2698  +  puts [list make {*}$args]
         2699  +  exec make {*}$args >&@ stdout
         2700  +  cd $PWD
         2701  +}
         2702  +proc ::practcl::domake.tcl {path args} {
         2703  +  set PWD [pwd]
         2704  +  cd $path
         2705  +  puts [list *** $path ***]
         2706  +  puts [list make.tcl {*}$args]
         2707  +  exec [info nameofexecutable] make.tcl {*}$args >&@ stdout
         2708  +  cd $PWD
         2709  +}
         2710  +proc ::practcl::fossil {path args} {
         2711  +  set PWD [pwd]
         2712  +  cd $path
         2713  +  puts [list {*}$args]
         2714  +  exec fossil {*}$args >&@ stdout
         2715  +  cd $PWD
         2716  +}
         2717  +proc ::practcl::fossil_status {dir} {
         2718  +  if {[info exists ::fosdat($dir)]} {
         2719  +    return $::fosdat($dir)
         2720  +  }
         2721  +  set result {
         2722  +tags experimental
         2723  +version {}
         2724  +  }
         2725  +  set pwd [pwd]
         2726  +  cd $dir
         2727  +  set info [exec fossil status]
         2728  +  cd $pwd
         2729  +  foreach line [split $info \n] {
         2730  +    if {[lindex $line 0] eq "checkout:"} {
         2731  +      set hash [lindex $line end-3]
         2732  +      set maxdate [lrange $line end-2 end-1]
         2733  +      dict set result hash $hash
         2734  +      dict set result maxdate $maxdate
         2735  +      regsub -all {[^0-9]} $maxdate {} isodate
         2736  +      dict set result isodate $isodate
         2737  +    }
         2738  +    if {[lindex $line 0] eq "tags:"} {
         2739  +      set tags [lrange $line 1 end]
         2740  +      dict set result tags $tags
         2741  +      break
         2742  +    }
         2743  +  }
         2744  +  set ::fosdat($dir) $result
         2745  +  return $result
         2746  +}
         2747  +proc ::practcl::os {} {
         2748  +  return [${::practcl::MAIN} define get TEACUP_OS]
         2749  +}
         2750  +proc ::practcl::mkzip {exename barekit vfspath} {
         2751  +  ::practcl::tcllib_require zipfile::mkzip
         2752  +  ::zipfile::mkzip::mkzip $exename -runtime $barekit -directory $vfspath
         2753  +}
         2754  +proc ::practcl::sort_dict list {
         2755  +  return [::lsort -stride 2 -dictionary $list]
         2756  +}
         2757  +if {[::package vcompare $::tcl_version 8.6] < 0} {
         2758  +  # Approximate ::zipfile::mkzip with exec calls
         2759  +  proc ::practcl::mkzip {exename barekit vfspath} {
         2760  +    set path [file dirname [file normalize $exename]]
         2761  +    set zipfile [file join $path [file rootname $exename].zip]
         2762  +    file copy -force $barekit $exename
         2763  +    set pwd [pwd]
         2764  +    cd $vfspath
         2765  +    exec zip -r $zipfile .
         2766  +    cd $pwd
         2767  +    set fout [open $exename a]
         2768  +    set fin [open $zipfile r]
         2769  +    chan configure $fout -translation binary
         2770  +    chan configure $fin -translation binary
         2771  +    chan copy $fin $fout
         2772  +    chan close $fin
         2773  +    chan close $fout
         2774  +    exec zip -A $exename
         2775  +  }
         2776  +  proc ::practcl::sort_dict list {
         2777  +    set result {}
         2778  +    foreach key [lsort -dictionary [dict keys $list]] {
         2779  +      dict set result $key [dict get $list $key]
         2780  +    }
         2781  +    return $result
         2782  +  }
         2783  +}
         2784  +proc ::practcl::local_os {} {
         2785  +  # If we have already run this command, return
         2786  +  # a cached copy of the data
         2787  +  if {[info exists ::practcl::LOCAL_INFO]} {
         2788  +    return $::practcl::LOCAL_INFO
         2789  +  }
         2790  +  set result [array get ::practcl::CONFIG]
         2791  +  dict set result TEACUP_PROFILE unknown
         2792  +  dict set result TEACUP_OS unknown
         2793  +  dict set result EXEEXT {}
         2794  +  set windows 0
         2795  +  if {$::tcl_platform(platform) eq "windows"} {
         2796  +    set windows 1
         2797  +  }
         2798  +  if {$windows} {
         2799  +    set system "windows"
         2800  +    set arch ix86
         2801  +    dict set result TEACUP_PROFILE win32-ix86
         2802  +    dict set result TEACUP_OS windows
         2803  +    dict set result EXEEXT .exe
         2804  +  } else {
         2805  +    set system [exec uname -s]-[exec uname -r]
         2806  +    set arch unknown
         2807  +    dict set result TEACUP_OS generic
         2808  +  }
         2809  +  dict set result TEA_PLATFORM $system
         2810  +  dict set result TEA_SYSTEM $system
         2811  +  if {[info exists ::SANDBOX]} {
         2812  +    dict set result sandbox $::SANDBOX
         2813  +  }
         2814  +  switch -glob $system {
         2815  +    Linux* {
         2816  +      dict set result TEACUP_OS linux
         2817  +      set arch [exec uname -m]
         2818  +      dict set result TEACUP_PROFILE "linux-glibc2.3-$arch"
         2819  +    }
         2820  +    GNU* {
         2821  +      set arch [exec uname -m]
         2822  +      dict set result TEACUP_OS "gnu"
         2823  +    }
         2824  +    NetBSD-Debian {
         2825  +      set arch [exec uname -m]
         2826  +      dict set result TEACUP_OS "netbsd-debian"
         2827  +    }
         2828  +    OpenBSD-* {
         2829  +      set arch [exec arch -s]
         2830  +      dict set result TEACUP_OS "openbsd"
         2831  +    }
         2832  +    Darwin* {
         2833  +      set arch [exec uname -m]
         2834  +      dict set result TEACUP_OS "macosx"
         2835  +      if {$arch eq "x86_64"} {
         2836  +        dict set result TEACUP_PROFILE "macosx10.5-i386-x86_84"
         2837  +      } else {
         2838  +        dict set result TEACUP_PROFILE "macosx-universal"
         2839  +      }
         2840  +    }
         2841  +    OpenBSD* {
         2842  +      set arch [exec arch -s]
         2843  +      dict set result TEACUP_OS "openbsd"
         2844  +    }
         2845  +  }
         2846  +  if {$arch eq "unknown"} {
         2847  +    catch {set arch [exec uname -m]}
         2848  +  }
         2849  +  switch -glob $arch {
         2850  +    i*86 {
         2851  +      set arch "ix86"
         2852  +    }
         2853  +    amd64 {
         2854  +      set arch "x86_64"
         2855  +    }
         2856  +  }
         2857  +  dict set result TEACUP_ARCH $arch
         2858  +  if {[dict get $result TEACUP_PROFILE] eq "unknown"} {
         2859  +    dict set result TEACUP_PROFILE [dict get $result TEACUP_OS]-$arch
         2860  +  }
         2861  +  set OS [dict get $result TEACUP_OS]
         2862  +  dict set result os $OS
         2863  +
         2864  +  # Look for a local preference file
         2865  +  set pathlist {}
         2866  +  set userhome [file normalize ~/tcl]
         2867  +  set local_install [file join $userhome lib]
         2868  +  switch $OS {
         2869  +    windows {
         2870  +      set userhome [file join [file normalize $::env(LOCALAPPDATA)] Tcl]
         2871  +      if {[file exists c:/Tcl/Teapot]} {
         2872  +        dict set result teapot c:/Tcl/Teapot
         2873  +      }
         2874  +    }
         2875  +    macosx {
         2876  +      set userhome [file join [file normalize {~/Library/Application Support/}] Tcl]
         2877  +      if {[file exists {~/Library/Application Support/ActiveState/Teapot/repository/}]} {
         2878  +        dict set result teapot [file normalize {~/Library/Application Support/ActiveState/Teapot/repository/}]
         2879  +      }
         2880  +      dict set result local_install [file normalize ~/Library/Tcl]
         2881  +      if {![dict exists $result sandbox]} {
         2882  +        dict set result sandbox       [file normalize ~/Library/Tcl/sandbox]
         2883  +      }
         2884  +    }
         2885  +    default {
         2886  +    }
         2887  +  }
         2888  +  dict set result userhome $userhome
         2889  +  # Load user preferences
         2890  +  if {[file exists [file join $userhome practcl.rc]]} {
         2891  +    set dat [::practcl::read_rc_file [file join $userhome practcl.rc]]
         2892  +    foreach {f v} $dat {
         2893  +      dict set result $f $v
         2894  +    }
         2895  +  }
         2896  +  if {![dict exists $result prefix]} {
         2897  +    dict set result prefix   $userhome
         2898  +  }
         2899  +
         2900  +  # Create a default path for the teapot
         2901  +  if {![dict exists $result teapot]} {
         2902  +    dict set result teapot [file join $userhome teapot]
         2903  +  }
         2904  +  # Create a default path for the local sandbox
         2905  +  if {![dict exists $result sandbox]} {
         2906  +    dict set result sandbox [file join $userhome sandbox]
         2907  +  }
         2908  +  # Create a default path for download folder
         2909  +  if {![dict exists $result download]} {
         2910  +    dict set result download [file join $userhome download]
         2911  +  }
         2912  +  # Path to install local packages
         2913  +  if {![dict exists $result local_install]} {
         2914  +    dict set result local_install [file join $userhome lib]
         2915  +  }
         2916  +  if {![dict exists result fossil_mirror] && [::info exists ::env(FOSSIL_MIRROR)]} {
         2917  +    dict set result fossil_mirror $::env(FOSSIL_MIRROR)
         2918  +  }
         2919  +
         2920  +  set ::practcl::LOCAL_INFO $result
         2921  +  return $result
         2922  +}
         2923  +proc ::practcl::config.tcl {path} {
         2924  +   return [read_configuration $path]
         2925  +}
         2926  +proc ::practcl::read_configuration {path} {
         2927  +  dict set result buildpath $path
         2928  +  set result [local_os]
         2929  +  set OS [dict get $result TEACUP_OS]
         2930  +  set windows 0
         2931  +  dict set result USEMSVC 0
         2932  +  if {[file exists [file join $path config.tcl]]} {
         2933  +    # We have a definitive configuration file. Read its content
         2934  +    # and take it as gospel
         2935  +    set cresult [read_rc_file [file join $path config.tcl]]
         2936  +    set cresult [::practcl::de_shell $cresult]
         2937  +    if {[dict exists $cresult srcdir] && ![dict exists $cresult sandbox]} {
         2938  +      dict set cresult sandbox  [file dirname [dict get $cresult srcdir]]
         2939  +    }
         2940  +    set result [dict merge $result [::practcl::de_shell $cresult]]
         2941  +  }
         2942  +  if {[file exists [file join $path config.site]]} {
         2943  +    # No config.tcl file is present but we do seed
         2944  +    dict set result USEMSVC 0
         2945  +    foreach {f v} [::practcl::de_shell [::practcl::read_sh_file [file join $path config.site]]] {
         2946  +      dict set result $f $v
         2947  +      dict set result XCOMPILE_${f} $v
         2948  +    }
         2949  +    dict set result CONFIG_SITE [file join $path config.site]
         2950  +    if {[dict exist $result XCOMPILE_CC] && [regexp mingw [dict get $result XCOMPILE_CC]]} {
         2951  +      set windows 1
         2952  +    }
         2953  +  } elseif {[info exists ::env(VisualStudioVersion)]} {
         2954  +    set windows 1
         2955  +    dict set result USEMSVC 1
         2956  +  }
         2957  +  if {$windows && [dict get $result TEACUP_OS] ne "windows"} {
         2958  +    if {![dict exists exists $result TEACUP_ARCH]} {
         2959  +      dict set result TEACUP_ARCH ix86
         2960  +    }
         2961  +    dict set result TEACUP_PROFILE win32-[dict get $result TEACUP_ARCH]
         2962  +    dict set result TEACUP_OS windows
         2963  +    dict set result EXEEXT .exe
         2964  +  }
         2965  +  return $result
         2966  +}
         2967  +if {$::tcl_platform(platform) eq "windows"} {
         2968  +proc ::practcl::msys_to_tclpath msyspath {
         2969  +  return [exec sh -c "cd $msyspath ; pwd -W"]
         2970  +}
         2971  +proc ::practcl::tcl_to_myspath tclpath {
         2972  +  set path [file normalize $tclpath]
         2973  +  return "/[string index $path 0][string range $path 2 end]"
         2974  +  #return [exec sh -c "cd $tclpath ; pwd"]
         2975  +}
         2976  +} else {
         2977  +proc ::practcl::msys_to_tclpath msyspath {
         2978  +  return [file normalize $msyspath]
         2979  +}
         2980  +proc ::practcl::tcl_to_myspath msyspath {
         2981  +  return [file normalize $msyspath]
         2982  +}
         2983  +}
         2984  +proc ::practcl::tcllib_require {pkg args} {
         2985  +  # Try to load the package from the local environment
         2986  +  if {[catch [list ::package require $pkg {*}$args] err]==0} {
         2987  +    return $err
         2988  +  }
         2989  +  ::practcl::LOCAL tool tcllib env-load
         2990  +  uplevel #0 [list ::package require $pkg {*}$args]
         2991  +}
         2992  +namespace eval ::practcl::platform {
         2993  +}
         2994  +proc ::practcl::platform::tcl_core_options {os} {
         2995  +  ###
         2996  +  # Download our required packages
         2997  +  ###
         2998  +  set tcl_config_opts {}
         2999  +  # Auto-guess options for the local operating system
         3000  +  switch $os {
         3001  +    windows {
         3002  +      #lappend tcl_config_opts --disable-stubs
         3003  +    }
         3004  +    linux {
         3005  +    }
         3006  +    macosx {
         3007  +      lappend tcl_config_opts --enable-corefoundation=yes  --enable-framework=no
         3008  +    }
         3009  +  }
         3010  +  lappend tcl_config_opts --with-tzdata
         3011  +  return $tcl_config_opts
         3012  +}
         3013  +proc ::practcl::platform::tk_core_options {os} {
         3014  +  ###
         3015  +  # Download our required packages
         3016  +  ###
         3017  +  set tk_config_opts {}
         3018  +
         3019  +  # Auto-guess options for the local operating system
         3020  +  switch $os {
         3021  +    windows {
         3022  +    }
         3023  +    linux {
         3024  +      lappend tk_config_opts --enable-xft=no --enable-xss=no
         3025  +    }
         3026  +    macosx {
         3027  +      lappend tk_config_opts --enable-aqua=yes
         3028  +    }
         3029  +  }
         3030  +  return $tk_config_opts
         3031  +}
         3032  +proc ::practcl::read_rc_file {filename {localdat {}}} {
         3033  +  set result $localdat
         3034  +  set fin [open $filename r]
         3035  +  set bufline {}
         3036  +  set rawcount 0
         3037  +  set linecount 0
         3038  +  while {[gets $fin thisline]>=0} {
         3039  +    incr rawcount
         3040  +    append bufline \n $thisline
         3041  +    if {![info complete $bufline]} continue
         3042  +    set line [string trimleft $bufline]
         3043  +    set bufline {}
         3044  +    if {[string index [string trimleft $line] 0] eq "#"} continue
         3045  +    append result \n $line
         3046  +    #incr linecount
         3047  +    #set key [lindex $line 0]
         3048  +    #set value [lindex $line 1]
         3049  +    #dict set result $key $value
         3050  +  }
         3051  +  close $fin
         3052  +  return $result
         3053  +}
         3054  +proc ::practcl::read_sh_subst {line info} {
         3055  +  regsub -all {\x28} $line \x7B line
         3056  +  regsub -all {\x29} $line \x7D line
         3057  +
         3058  +  #set line [string map $key [string trim $line]]
         3059  +  foreach {field value} $info {
         3060  +    catch {set $field $value}
         3061  +  }
         3062  +  if [catch {subst $line} result] {
         3063  +    return {}
         3064  +  }
         3065  +  set result [string trim $result]
         3066  +  return [string trim $result ']
         3067  +}
         3068  +proc ::practcl::read_sh_file {filename {localdat {}}} {
         3069  +  set fin [open $filename r]
         3070  +  set result {}
         3071  +  if {$localdat eq {}} {
         3072  +    set top 1
         3073  +    set local [array get ::env]
         3074  +    dict set local EXE {}
         3075  +  } else {
         3076  +    set top 0
         3077  +    set local $localdat
         3078  +  }
         3079  +  while {[gets $fin line] >= 0} {
         3080  +    set line [string trim $line]
         3081  +    if {[string index $line 0] eq "#"} continue
         3082  +    if {$line eq {}} continue
         3083  +    catch {
         3084  +    if {[string range $line 0 6] eq "export "} {
         3085  +      set eq [string first "=" $line]
         3086  +      set field [string trim [string range $line 6 [expr {$eq - 1}]]]
         3087  +      set value [read_sh_subst [string range $line [expr {$eq+1}] end] $local]
         3088  +      dict set result $field [read_sh_subst $value $local]
         3089  +      dict set local $field $value
         3090  +    } elseif {[string range $line 0 7] eq "include "} {
         3091  +      set subfile [read_sh_subst [string range $line 7 end] $local]
         3092  +      foreach {field value} [read_sh_file $subfile $local] {
         3093  +        dict set result $field $value
         3094  +      }
         3095  +    } else {
         3096  +      set eq [string first "=" $line]
         3097  +      if {$eq > 0} {
         3098  +        set field [read_sh_subst [string range $line 0 [expr {$eq - 1}]] $local]
         3099  +        set value [string trim [string range $line [expr {$eq+1}] end] ']
         3100  +        #set value [read_sh_subst [string range $line [expr {$eq+1}] end] $local]
         3101  +        dict set local $field $value
         3102  +        dict set result $field $value
         3103  +      }
         3104  +    }
         3105  +    } err opts
         3106  +    if {[dict get $opts -code] != 0} {
         3107  +      #puts $opts
         3108  +      puts "Error reading line:\n$line\nerr: $err\n***"
         3109  +      return $err {*}$opts
         3110  +    }
         3111  +  }
         3112  +  return $result
         3113  +}
         3114  +proc ::practcl::read_Config.sh filename {
         3115  +  set fin [open $filename r]
         3116  +  set result {}
         3117  +  set linecount 0
         3118  +  while {[gets $fin line] >= 0} {
         3119  +    set line [string trim $line]
         3120  +    if {[string index $line 0] eq "#"} continue
         3121  +    if {$line eq {}} continue
         3122  +    catch {
         3123  +      set eq [string first "=" $line]
         3124  +      if {$eq > 0} {
         3125  +        set field [string range $line 0 [expr {$eq - 1}]]
         3126  +        set value [string trim [string range $line [expr {$eq+1}] end] ']
         3127  +        #set value [read_sh_subst [string range $line [expr {$eq+1}] end] $local]
         3128  +        dict set result $field $value
         3129  +        incr $linecount
         3130  +      }
         3131  +    } err opts
         3132  +    if {[dict get $opts -code] != 0} {
         3133  +      #puts $opts
         3134  +      puts "Error reading line:\n$line\nerr: $err\n***"
         3135  +      return $err {*}$opts
         3136  +    }
         3137  +  }
         3138  +  return $result
         3139  +}
         3140  +proc ::practcl::read_Makefile filename {
         3141  +  set fin [open $filename r]
         3142  +  set result {}
         3143  +  while {[gets $fin line] >= 0} {
         3144  +    set line [string trim $line]
         3145  +    if {[string index $line 0] eq "#"} continue
         3146  +    if {$line eq {}} continue
         3147  +    catch {
         3148  +      set eq [string first "=" $line]
         3149  +      if {$eq > 0} {
         3150  +        set field [string trim [string range $line 0 [expr {$eq - 1}]]]
         3151  +        set value [string trim [string trim [string range $line [expr {$eq+1}] end] ']]
         3152  +        switch $field {
         3153  +          PKG_LIB_FILE {
         3154  +            dict set result libfile $value
         3155  +          }
         3156  +          srcdir {
         3157  +            if {$value eq "."} {
         3158  +              dict set result srcdir [file dirname $filename]
         3159  +            } else {
         3160  +              dict set result srcdir $value
         3161  +            }
         3162  +          }
         3163  +          PACKAGE_NAME {
         3164  +            dict set result name $value
         3165  +          }
         3166  +          PACKAGE_VERSION {
         3167  +            dict set result version $value
         3168  +          }
         3169  +          LIBS {
         3170  +            dict set result PRACTCL_LIBS $value
         3171  +          }
         3172  +          PKG_LIB_FILE {
         3173  +            dict set result libfile $value
         3174  +          }
         3175  +        }
         3176  +      }
         3177  +    } err opts
         3178  +    if {[dict get $opts -code] != 0} {
         3179  +      #puts $opts
         3180  +      puts "Error reading line:\n$line\nerr: $err\n***"
         3181  +      return $err {*}$opts
         3182  +    }
         3183  +    # the Compile field is about where most TEA files start getting silly
         3184  +    if {$field eq "compile"} {
         3185  +      break
         3186  +    }
         3187  +  }
         3188  +  return $result
         3189  +}
         3190  +proc ::practcl::cputs {varname args} {
         3191  +  upvar 1 $varname buffer
         3192  +  if {[llength $args]==1 && [string length [string trim [lindex $args 0]]] == 0} {
         3193  +
         3194  +  }
         3195  +  if {[info exist buffer]} {
         3196  +    if {[string index $buffer end] ne "\n"} {
         3197  +      append buffer \n
         3198  +    }
         3199  +  } else {
         3200  +    set buffer \n
         3201  +  }
         3202  +  # Trim leading \n's
         3203  +  append buffer [string trimleft [lindex $args 0] \n] {*}[lrange $args 1 end]
         3204  +}
         3205  +proc ::practcl::tcl_to_c {body} {
         3206  +  set result {}
         3207  +  foreach rawline [split $body \n] {
         3208  +    set line [string map [list \" \\\" \\ \\\\] $rawline]
         3209  +    cputs result "\n        \"$line\\n\" \\"
         3210  +  }
         3211  +  return [string trimright $result \\]
         3212  +}
         3213  +proc ::practcl::_tagblock {text {style tcl} {note {}}} {
         3214  +  if {[string length [string trim $text]]==0} {
         3215  +    return {}
         3216  +  }
         3217  +  set output {}
         3218  +  switch $style {
         3219  +    tcl {
         3220  +      ::practcl::cputs output "# BEGIN $note"
         3221  +    }
         3222  +    c {
         3223  +      ::practcl::cputs output "/* BEGIN $note */"
         3224  +    }
         3225  +    default {
         3226  +      ::practcl::cputs output "# BEGIN $note"
         3227  +    }
         3228  +  }
         3229  +  ::practcl::cputs output $text
         3230  +  switch $style {
         3231  +    tcl {
         3232  +      ::practcl::cputs output "# END $note"
         3233  +    }
         3234  +    c {
         3235  +      ::practcl::cputs output "/* END $note */"
         3236  +    }
         3237  +    default {
         3238  +      ::practcl::cputs output "# END $note"
         3239  +    }
         3240  +  }
         3241  +  return $output
         3242  +}
         3243  +proc ::practcl::de_shell {data} {
         3244  +  set values {}
         3245  +  foreach flag {DEFS TCL_DEFS TK_DEFS} {
         3246  +    if {[dict exists $data $flag]} {
         3247  +      #set value {}
         3248  +      #foreach item [dict get $data $flag] {
         3249  +      #  append value " " [string map {{ } {\ }} $item]
         3250  +      #}
         3251  +      dict set values $flag [dict get $data $flag]
         3252  +    }
         3253  +  }
         3254  +  set map {}
         3255  +  lappend map {${PKG_OBJECTS}} %LIBRARY_OBJECTS%
         3256  +  lappend map {$(PKG_OBJECTS)} %LIBRARY_OBJECTS%
         3257  +  lappend map {${PKG_STUB_OBJECTS}} %LIBRARY_STUB_OBJECTS%
         3258  +  lappend map {$(PKG_STUB_OBJECTS)} %LIBRARY_STUB_OBJECTS%
         3259  +
         3260  +  if {[dict exists $data name]} {
         3261  +    lappend map %LIBRARY_NAME% [dict get $data name]
         3262  +    lappend map %LIBRARY_VERSION% [dict get $data version]
         3263  +    lappend map %LIBRARY_VERSION_NODOTS% [string map {. {}} [dict get $data version]]
         3264  +    if {[dict exists $data libprefix]} {
         3265  +      lappend map %LIBRARY_PREFIX% [dict get $data libprefix]
         3266  +    } else {
         3267  +      lappend map %LIBRARY_PREFIX% [dict get $data prefix]
         3268  +    }
         3269  +  }
         3270  +  foreach flag [dict keys $data] {
         3271  +    if {$flag in {TCL_DEFS TK_DEFS DEFS}} continue
         3272  +    set value [string trim [dict get $data $flag] \"]
         3273  +    dict set map "\$\{${flag}\}" $value
         3274  +    dict set map "\$\(${flag}\)" $value
         3275  +    #dict set map "\$${flag}" $value
         3276  +    dict set map "%${flag}%" $value
         3277  +    dict set values $flag [dict get $data $flag]
         3278  +    #dict set map "\$\{${flag}\}" $proj($flag)
         3279  +  }
         3280  +  set changed 1
         3281  +  while {$changed} {
         3282  +    set changed 0
         3283  +    foreach {field value} $values {
         3284  +      if {$field in {TCL_DEFS TK_DEFS DEFS}} continue
         3285  +      dict with values {}
         3286  +      set newval [string map $map $value]
         3287  +      if {$newval eq $value} continue
         3288  +      set changed 1
         3289  +      dict set values $field $newval
         3290  +    }
         3291  +  }
         3292  +  return $values
         3293  +}
         3294  +
         3295  +###
         3296  +# END: buildutil.tcl
         3297  +###
         3298  +###
         3299  +# START: fileutil.tcl
         3300  +###
         3301  +proc ::practcl::grep {pattern {files {}}} {
         3302  +    set result [list]
         3303  +    if {[llength $files] == 0} {
         3304  +            # read from stdin
         3305  +            set lnum 0
         3306  +            while {[gets stdin line] >= 0} {
         3307  +                incr lnum
         3308  +                if {[regexp -- $pattern $line]} {
         3309  +                        lappend result "${lnum}:${line}"
         3310  +                }
         3311  +            }
         3312  +    } else {
         3313  +            foreach filename $files {
         3314  +            set file [open $filename r]
         3315  +            set lnum 0
         3316  +            while {[gets $file line] >= 0} {
         3317  +                incr lnum
         3318  +                if {[regexp -- $pattern $line]} {
         3319  +                    lappend result "${filename}:${lnum}:${line}"
         3320  +                }
         3321  +            }
         3322  +            close $file
         3323  +            }
         3324  +    }
         3325  +    return $result
         3326  +}
         3327  +proc ::practcl::file_lexnormalize {sp} {
         3328  +    set spx [file split $sp]
         3329  +
         3330  +    # Resolution of embedded relative modifiers (., and ..).
         3331  +
         3332  +    if {
         3333  +      ([lsearch -exact $spx . ] < 0) &&
         3334  +      ([lsearch -exact $spx ..] < 0)
         3335  +    } {
         3336  +      # Quick path out if there are no relative modifiers
         3337  +      return $sp
         3338  +    }
         3339  +
         3340  +    set absolute [expr {![string equal [file pathtype $sp] relative]}]
         3341  +    # A volumerelative path counts as absolute for our purposes.
         3342  +
         3343  +    set sp $spx
         3344  +    set np {}
         3345  +    set noskip 1
         3346  +
         3347  +    while {[llength $sp]} {
         3348  +      set ele    [lindex $sp 0]
         3349  +      set sp     [lrange $sp 1 end]
         3350  +      set islast [expr {[llength $sp] == 0}]
         3351  +
         3352  +      if {[string equal $ele ".."]} {
         3353  +          if {
         3354  +            ($absolute  && ([llength $np] >  1)) ||
         3355  +            (!$absolute && ([llength $np] >= 1))
         3356  +          } {
         3357  +            # .. : Remove the previous element added to the
         3358  +            # new path, if there actually is enough to remove.
         3359  +            set np [lrange $np 0 end-1]
         3360  +          }
         3361  +      } elseif {[string equal $ele "."]} {
         3362  +          # Ignore .'s, they stay at the current location
         3363  +          continue
         3364  +      } else {
         3365  +          # A regular element.
         3366  +          lappend np $ele
         3367  +      }
         3368  +    }
         3369  +    if {[llength $np] > 0} {
         3370  +      return [eval [linsert $np 0 file join]]
         3371  +      # 8.5: return [file join {*}$np]
         3372  +    }
         3373  +    return {}
         3374  +}
         3375  +proc ::practcl::file_relative {base dst} {
         3376  +    # Ensure that the link to directory 'dst' is properly done relative to
         3377  +    # the directory 'base'.
         3378  +
         3379  +    if {![string equal [file pathtype $base] [file pathtype $dst]]} {
         3380  +      return -code error "Unable to compute relation for paths of different pathtypes: [file pathtype $base] vs. [file pathtype $dst], ($base vs. $dst)"
         3381  +    }
         3382  +
         3383  +    set base [file_lexnormalize [file join [pwd] $base]]
         3384  +    set dst  [file_lexnormalize [file join [pwd] $dst]]
         3385  +
         3386  +    set save $dst
         3387  +    set base [file split $base]
         3388  +    set dst  [file split $dst]
         3389  +
         3390  +    while {[string equal [lindex $dst 0] [lindex $base 0]]} {
         3391  +      set dst  [lrange $dst  1 end]
         3392  +      set base [lrange $base 1 end]
         3393  +      if {![llength $dst]} {break}
         3394  +    }
         3395  +
         3396  +    set dstlen  [llength $dst]
         3397  +    set baselen [llength $base]
         3398  +
         3399  +    if {($dstlen == 0) && ($baselen == 0)} {
         3400  +      # Cases:
         3401  +      # (a) base == dst
         3402  +
         3403  +      set dst .
         3404  +    } else {
         3405  +      # Cases:
         3406  +      # (b) base is: base/sub = sub
         3407  +      #     dst  is: base     = {}
         3408  +
         3409  +      # (c) base is: base     = {}
         3410  +      #     dst  is: base/sub = sub
         3411  +
         3412  +      while {$baselen > 0} {
         3413  +          set dst [linsert $dst 0 ..]
         3414  +          incr baselen -1
         3415  +      }
         3416  +      # 8.5: set dst [file join {*}$dst]
         3417  +      set dst [eval [linsert $dst 0 file join]]
         3418  +    }
         3419  +
         3420  +    return $dst
         3421  +}
         3422  +proc ::practcl::findByPattern {basedir patterns} {
         3423  +    set queue $basedir
         3424  +    set result {}
         3425  +    while {[llength $queue]} {
         3426  +      set item [lindex $queue 0]
         3427  +      set queue [lrange $queue 1 end]
         3428  +      if {[file isdirectory $item]} {
         3429  +        foreach path [glob -nocomplain [file join $item *]] {
         3430  +          lappend queue $path
         3431  +        }
         3432  +        continue
         3433  +      }
         3434  +      foreach pattern $patterns {
         3435  +        set fname [file tail $item]
         3436  +        if {[string match $pattern $fname]} {
         3437  +          lappend result $item
         3438  +          break
         3439  +        }
         3440  +      }
         3441  +    }
         3442  +    return $result
         3443  +}
         3444  +proc ::practcl::log {fname comment} {
         3445  +  set fname [file normalize $fname]
         3446  +  if {[info exists ::practcl::logchan($fname)]} {
         3447  +    set fout $::practcl::logchan($fname)
         3448  +    after cancel $::practcl::logevent($fname)
         3449  +  } else {
         3450  +    set fout [open $fname a]
         3451  +  }
         3452  +  puts $fout $comment
         3453  +  # Defer close until idle
         3454  +  set ::practcl::logevent($fname) [after idle "close $fout ; unset ::practcl::logchan($fname)"]
         3455  +}
         3456  +
         3457  +###
         3458  +# END: fileutil.tcl
         3459  +###
         3460  +###
         3461  +# START: installutil.tcl
         3462  +###
         3463  +proc ::practcl::_pkgindex_simpleIndex {path} {
         3464  +set buffer {}
         3465  +  set pkgidxfile    [file join $path pkgIndex.tcl]
         3466  +  set modfile       [file join $path [file tail $path].tcl]
         3467  +  set use_pkgindex  [file exists $pkgidxfile]
         3468  +  set tclfiles      {}
         3469  +  set found 0
         3470  +  set mlist [list pkgIndex.tcl index.tcl [file tail $modfile] version_info.tcl]
         3471  +  foreach file [glob -nocomplain [file join $path *.tcl]] {
         3472  +    if {[file tail $file] ni $mlist} {
         3473  +      #puts [list NONMODFILE $file]
         3474  +      return {}
         3475  +    }
         3476  +  }
         3477  +  foreach file [glob -nocomplain [file join $path *.tcl]] {
         3478  +    if { [file tail $file] == "version_info.tcl" } continue
         3479  +    set fin [open $file r]
         3480  +    set dat [read $fin]
         3481  +    close $fin
         3482  +    if {![regexp "package provide" $dat]} continue
         3483  +    set fname [file rootname [file tail $file]]
         3484  +    # Look for a package provide statement
         3485  +    foreach line [split $dat \n] {
         3486  +      set line [string trim $line]
         3487  +      if { [string range $line 0 14] != "package provide" } continue
         3488  +      set package [lindex $line 2]
         3489  +      set version [lindex $line 3]
         3490  +      if {[string index $package 0] in "\$ \[ @"} continue
         3491  +      if {[string index $version 0] in "\$ \[ @"} continue
         3492  +      #puts "PKGLINE $line"
         3493  +      append buffer "package ifneeded $package $version \[list source \[file join %DIR% [file tail $file]\]\]" \n
         3494  +      break
         3495  +    }
         3496  +  }
         3497  +  return $buffer
         3498  +}
         3499  +proc ::practcl::_pkgindex_directory {path} {
         3500  +  set buffer {}
         3501  +  set pkgidxfile    [file join $path pkgIndex.tcl]
         3502  +  set modfile       [file join $path [file tail $path].tcl]
         3503  +  set use_pkgindex  [file exists $pkgidxfile]
         3504  +  set tclfiles      {}
         3505  +  if {$use_pkgindex && [file exists $modfile]} {
         3506  +    set use_pkgindex 0
         3507  +    set mlist [list pkgIndex.tcl [file tail $modfile]]
         3508  +    foreach file [glob -nocomplain [file join $path *.tcl]] {
         3509  +      lappend tclfiles [file tail $file]
         3510  +      if {[file tail $file] in $mlist} continue
         3511  +      incr use_pkgindex
         3512  +    }
         3513  +  }
         3514  +  if {!$use_pkgindex} {
         3515  +    # No pkgIndex file, read the source
         3516  +    foreach file [glob -nocomplain $path/*.tm] {
         3517  +      set file [file normalize $file]
         3518  +      set fname [file rootname [file tail $file]]
         3519  +      ###
         3520  +      # We used to be able to ... Assume the package is correct in the filename
         3521  +      # No hunt for a "package provides"
         3522  +      ###
         3523  +      set package [lindex [split $fname -] 0]
         3524  +      set version [lindex [split $fname -] 1]
         3525  +      ###
         3526  +      # Read the file, and override assumptions as needed
         3527  +      ###
         3528  +      set fin [open $file r]
         3529  +      set dat [read $fin]
         3530  +      close $fin
         3531  +      # Look for a teapot style Package statement
         3532  +      foreach line [split $dat \n] {
         3533  +        set line [string trim $line]
         3534  +        if { [string range $line 0 9] != "# Package " } continue
         3535  +        set package [lindex $line 2]
         3536  +        set version [lindex $line 3]
         3537  +        break
         3538  +      }
         3539  +      # Look for a package provide statement
         3540  +      foreach line [split $dat \n] {
         3541  +        set line [string trim $line]
         3542  +        if { [string range $line 0 14] != "package provide" } continue
         3543  +        set package [lindex $line 2]
         3544  +        set version [lindex $line 3]
         3545  +        break
         3546  +      }
         3547  +      if {[string trim $version] ne {}} {
         3548  +        append buffer "package ifneeded $package $version \[list source \[file join \$dir [file tail $file]\]\]" \n
         3549  +      }
         3550  +    }
         3551  +    foreach file [glob -nocomplain $path/*.tcl] {
         3552  +      if { [file tail $file] == "version_info.tcl" } continue
         3553  +      set fin [open $file r]
         3554  +      set dat [read $fin]
         3555  +      close $fin
         3556  +      if {![regexp "package provide" $dat]} continue
         3557  +      set fname [file rootname [file tail $file]]
         3558  +      # Look for a package provide statement
         3559  +      foreach line [split $dat \n] {
         3560  +        set line [string trim $line]
         3561  +        if { [string range $line 0 14] != "package provide" } continue
         3562  +        set package [lindex $line 2]
         3563  +        set version [lindex $line 3]
         3564  +        if {[string index $package 0] in "\$ \[ @"} continue
         3565  +        if {[string index $version 0] in "\$ \[ @"} continue
         3566  +        append buffer "package ifneeded $package $version \[list source \[file join \$dir [file tail $file]\]\]" \n
         3567  +        break
         3568  +      }
         3569  +    }
         3570  +    return $buffer
         3571  +  }
         3572  +  set fin [open $pkgidxfile r]
         3573  +  set dat [read $fin]
         3574  +  close $fin
         3575  +  set trace 0
         3576  +  #if {[file tail $path] eq "tool"} {
         3577  +  #  set trace 1
         3578  +  #}
         3579  +  set thisline {}
         3580  +  foreach line [split $dat \n] {
         3581  +    append thisline $line \n
         3582  +    if {![info complete $thisline]} continue
         3583  +    set line [string trim $line]
         3584  +    if {[string length $line]==0} {
         3585  +      set thisline {} ; continue
         3586  +    }
         3587  +    if {[string index $line 0] eq "#"} {
         3588  +      set thisline {} ; continue
         3589  +    }
         3590  +    if {[regexp "if.*catch.*package.*Tcl.*return" $thisline]} {
         3591  +      if {$trace} {puts "[file dirname $pkgidxfile] Ignoring $thisline"}
         3592  +      set thisline {} ; continue
         3593  +    }
         3594  +    if {[regexp "if.*package.*vsatisfies.*package.*provide.*return" $thisline]} {
         3595  +      if {$trace} { puts "[file dirname $pkgidxfile] Ignoring $thisline" }
         3596  +      set thisline {} ; continue
         3597  +    }
         3598  +    if {![regexp "package.*ifneeded" $thisline]} {
         3599  +      # This package index contains arbitrary code
         3600  +      # source instead of trying to add it to the master
         3601  +      # package index
         3602  +      if {$trace} { puts "[file dirname $pkgidxfile] Arbitrary code $thisline" }
         3603  +      return {source [file join $dir pkgIndex.tcl]}
         3604  +    }
         3605  +    append buffer $thisline \n
         3606  +    set thisline {}
         3607  +  }
         3608  +  if {$trace} {puts [list [file dirname $pkgidxfile] $buffer]}
         3609  +  return $buffer
         3610  +}
         3611  +proc ::practcl::_pkgindex_path_subdir {path} {
         3612  +  set result {}
         3613  +  if {[file exists [file join $path src build.tcl]]} {
         3614  +    # Tool style module, don't dive into subdirectories
         3615  +    return $path
         3616  +  }
         3617  +  foreach subpath [glob -nocomplain [file join $path *]] {
         3618  +    if {[file isdirectory $subpath]} {
         3619  +      if {[file tail $subpath] eq "build" && [file exists [file join $subpath build.tcl]]} continue
         3620  +      lappend result $subpath {*}[_pkgindex_path_subdir $subpath]
         3621  +    }
         3622  +  }
         3623  +  return $result
         3624  +}
         3625  +proc ::practcl::pkgindex_path {args} {
         3626  +  set stack {}
         3627  +  set buffer {
         3628  +lappend ::PATHSTACK $dir
         3629  +set IDXPATH [lindex $::PATHSTACK end]
         3630  +  }
         3631  +  set preindexed {}
         3632  +  foreach base $args {
         3633  +    set base [file normalize $base]
         3634  +    set paths {}
         3635  +    foreach dir [glob -nocomplain [file join $base *]] {
         3636  +      set thisdir [file tail $dir]
         3637  +      if {$thisdir eq "teapot"} continue
         3638  +      if {$thisdir eq "pkgs"} {
         3639  +        foreach subdir [glob -nocomplain [file join $dir *]] {
         3640  +          set thissubdir [file tail $subdir]
         3641  +          set skip 0
         3642  +          foreach file {pkgIndex.tcl tclIndex} {
         3643  +            if {[file exists [file join $subdir $file]]} {
         3644  +              set skip 1
         3645  +              append buffer "set dir \[file join \$::IDXPATH [list $thisdir] [list $thissubdir]\] \; "
         3646  +              append buffer "source \[file join \$dir ${file}\]" \n
         3647  +            }
         3648  +          }
         3649  +          if {$skip} continue
         3650  +          lappend paths {*}[::practcl::_pkgindex_path_subdir $subdir]
         3651  +        }
         3652  +        continue
         3653  +      }
         3654  +      lappend paths $dir {*}[::practcl::_pkgindex_path_subdir $dir]
         3655  +    }
         3656  +    append buffer ""
         3657  +    set i    [string length  $base]
         3658  +    # Build a list of all of the paths
         3659  +    if {[llength $paths]} {
         3660  +      foreach path $paths {
         3661  +        if {$path eq $base} continue
         3662  +        set path_indexed($path) 0
         3663  +      }
         3664  +    } else {
         3665  +      puts [list WARNING: NO PATHS FOUND IN $base]
         3666  +    }
         3667  +    set path_indexed($base) 1
         3668  +    set path_indexed([file join $base boot tcl]) 1
         3669  +    append buffer \n {# SINGLE FILE MODULES BEGIN} \n {set dir [lindex $::PATHSTACK end]} \n
         3670  +    foreach path $paths {
         3671  +      if {$path_indexed($path)} continue
         3672  +      set thisdir [file_relative $base $path]
         3673  +      set simpleIdx [_pkgindex_simpleIndex $path]
         3674  +      if {[string length $simpleIdx]==0} continue
         3675  +      incr path_indexed($path)
         3676  +      if {[string length $simpleIdx]} {
         3677  +        incr path_indexed($path)
         3678  +        append buffer [string map [list %DIR% "\$dir \{$thisdir\}"] [string trimright $simpleIdx]] \n
         3679  +      }
         3680  +    }
         3681  +    append buffer {# SINGLE FILE MODULES END} \n
         3682  +    foreach path $paths {
         3683  +      if {$path_indexed($path)} continue
         3684  +      set thisdir [file_relative $base $path]
         3685  +      set idxbuf [::practcl::_pkgindex_directory $path]
         3686  +      if {[string length $idxbuf]} {
         3687  +        incr path_indexed($path)
         3688  +        append buffer "set dir \[set PKGDIR \[file join \[lindex \$::PATHSTACK end\] $thisdir\]\]" \n
         3689  +        append buffer [string map {$dir $PKGDIR} [string trimright $idxbuf]] \n
         3690  +      }
         3691  +    }
         3692  +  }
         3693  +  append buffer {
         3694  +set dir [lindex $::PATHSTACK end]
         3695  +set ::PATHSTACK [lrange $::PATHSTACK 0 end-1]
         3696  +}
         3697  +  return $buffer
         3698  +}
         3699  +proc ::practcl::installDir {d1 d2} {
         3700  +  puts [format {%*sCreating %s} [expr {4 * [info level]}] {} [file tail $d2]]
         3701  +  file delete -force -- $d2
         3702  +  file mkdir $d2
         3703  +
         3704  +  foreach ftail [glob -directory $d1 -nocomplain -tails *] {
         3705  +    set f [file join $d1 $ftail]
         3706  +    if {[file isdirectory $f] && [string compare CVS $ftail]} {
         3707  +      installDir $f [file join $d2 $ftail]
         3708  +    } elseif {[file isfile $f]} {
         3709  +	    file copy -force $f [file join $d2 $ftail]
         3710  +	    if {$::tcl_platform(platform) eq {unix}} {
         3711  +        file attributes [file join $d2 $ftail] -permissions 0644
         3712  +	    } else {
         3713  +        file attributes [file join $d2 $ftail] -readonly 1
         3714  +	    }
         3715  +    }
         3716  +  }
         3717  +
         3718  +  if {$::tcl_platform(platform) eq {unix}} {
         3719  +    file attributes $d2 -permissions 0755
         3720  +  } else {
         3721  +    file attributes $d2 -readonly 1
         3722  +  }
         3723  +}
         3724  +proc ::practcl::copyDir {d1 d2 {toplevel 1}} {
         3725  +  #if {$toplevel} {
         3726  +  #  puts [list ::practcl::copyDir $d1 -> $d2]
         3727  +  #}
         3728  +  #file delete -force -- $d2
         3729  +  file mkdir $d2
         3730  +  if {[file isfile $d1]} {
         3731  +    file copy -force $d1 $d2
         3732  +    set ftail [file tail $d1]
         3733  +    if {$::tcl_platform(platform) eq {unix}} {
         3734  +      file attributes [file join $d2 $ftail] -permissions 0644
         3735  +    } else {
         3736  +      file attributes [file join $d2 $ftail] -readonly 1
         3737  +    }
         3738  +  } else {
         3739  +    foreach ftail [glob -directory $d1 -nocomplain -tails *] {
         3740  +      set f [file join $d1 $ftail]
         3741  +      if {[file isdirectory $f] && [string compare CVS $ftail]} {
         3742  +        copyDir $f [file join $d2 $ftail] 0
         3743  +      } elseif {[file isfile $f]} {
         3744  +        file copy -force $f [file join $d2 $ftail]
         3745  +        if {$::tcl_platform(platform) eq {unix}} {
         3746  +          file attributes [file join $d2 $ftail] -permissions 0644
         3747  +        } else {
         3748  +          file attributes [file join $d2 $ftail] -readonly 1
         3749  +        }
         3750  +      }
         3751  +    }
         3752  +  }
         3753  +}
         3754  +proc ::practcl::buildModule {modpath} {
         3755  +  set buildscript [file join $modpath build build.tcl]
         3756  +  if {![file exists $buildscript]} return
         3757  +  set pkgIndexFile [file join $modpath pkgIndex.tcl]
         3758  +  if {[file exists $pkgIndexFile]} {
         3759  +    set latest 0
         3760  +    foreach file [::practcl::findByPattern [file dirname $buildscript] *.tcl] {
         3761  +      set mtime [file mtime $file]
         3762  +      if {$mtime>$latest} {
         3763  +        set latest $mtime
         3764  +      }
         3765  +    }
         3766  +    set IdxTime [file mtime $pkgIndexFile]
         3767  +    if {$latest<$IdxTime} return
         3768  +  }
         3769  +  ::practcl::dotclexec $buildscript
         3770  +}
         3771  +proc ::practcl::installModule {modpath DEST} {
         3772  +  set dpath  [file join $DEST modules [file tail $modpath]]
         3773  +  #puts [list ::practcl::installModule $modpath -> $dpath]
         3774  +  if {[file exists [file join $modpath index.tcl]]} {
         3775  +    # IRM/Tao style modules non-amalgamated
         3776  +    ::practcl::installDir $modpath $dpath
         3777  +    return
         3778  +  }
         3779  +  if {[file exists [file join $modpath build build.tcl]]} {
         3780  +    buildModule $modpath
         3781  +  }
         3782  +  set files [glob -nocomplain [file join $modpath *.tcl]]
         3783  +  if {[llength $files]} {
         3784  +    if {[llength $files]>1} {
         3785  +      if {![file exists [file join $modpath pkgIndex.tcl]]} {
         3786  +        pkg_mkIndex $modpath
         3787  +      }
         3788  +    }
         3789  +    file delete -force $dpath
         3790  +    file mkdir $dpath
         3791  +    foreach file $files {
         3792  +      file copy $file $dpath
         3793  +    }
         3794  +  }
         3795  +  if {[file exists [file join $modpath htdocs]]} {
         3796  +    ::practcl::copyDir [file join $modpath htdocs] [file join $dpath htdocs]
         3797  +  }
         3798  +}
         3799  +
         3800  +###
         3801  +# END: installutil.tcl
         3802  +###
         3803  +###
         3804  +# START: makeutil.tcl
         3805  +###
         3806  +proc ::practcl::trigger {args} {
         3807  +  ::practcl::LOCAL make trigger {*}$args
         3808  +  foreach {name obj} [::practcl::LOCAL make objects] {
         3809  +    set ::make($name) [$obj do]
         3810  +  }
         3811  +}
         3812  +proc ::practcl::depends {args} {
         3813  +  ::practcl::LOCAL make depends {*}$args
         3814  +}
         3815  +proc ::practcl::target {name info {action {}}} {
         3816  +  set obj [::practcl::LOCAL make task $name $info $action]
         3817  +  set ::make($name) 0
         3818  +  set filename [$obj define get filename]
         3819  +  if {$filename ne {}} {
         3820  +    set ::target($name) $filename
         3821  +  }
         3822  +}
         3823  +
         3824  +###
         3825  +# END: makeutil.tcl
         3826  +###
         3827  +###
         3828  +# START: class metaclass.tcl
         3829  +###
         3830  +::clay::define ::practcl::metaclass {
         3831  +  method _MorphPatterns {} {
         3832  +    return {{@[email protected]} {::practcl::@na[email protected]} {::practcl::*@[email protected]} {::practcl::*@[email protected]*}}
         3833  +  }
         3834  +  method define {submethod args} {
         3835  +    my variable define
         3836  +    switch $submethod {
         3837  +      dump {
         3838  +        return [array get define]
         3839  +      }
         3840  +      add {
         3841  +        set field [lindex $args 0]
         3842  +        if {![info exists define($field)]} {
         3843  +          set define($field) {}
         3844  +        }
         3845  +        foreach arg [lrange $args 1 end] {
         3846  +          if {$arg ni $define($field)} {
         3847  +            lappend define($field) $arg
         3848  +          }
         3849  +        }
         3850  +        return $define($field)
         3851  +      }
         3852  +      remove {
         3853  +        set field [lindex $args 0]
         3854  +        if {![info exists define($field)]} {
         3855  +          return
         3856  +        }
         3857  +        set rlist [lrange $args 1 end]
         3858  +        set olist $define($field)
         3859  +        set nlist {}
         3860  +        foreach arg $olist {
         3861  +          if {$arg in $rlist} continue
         3862  +          lappend nlist $arg
         3863  +        }
         3864  +        set define($field) $nlist
         3865  +        return $nlist
         3866  +      }
         3867  +      exists {
         3868  +        set field [lindex $args 0]
         3869  +        return [info exists define($field)]
         3870  +      }
         3871  +      getnull -
         3872  +      get -
         3873  +      cget {
         3874  +        set field [lindex $args 0]
         3875  +        if {[info exists define($field)]} {
         3876  +          return $define($field)
         3877  +        }
         3878  +        return [lindex $args 1]
         3879  +      }
         3880  +      set {
         3881  +        if {[llength $args]==1} {
         3882  +          set arglist [lindex $args 0]
         3883  +        } else {
         3884  +          set arglist $args
         3885  +        }
         3886  +        array set define $arglist
         3887  +        if {[dict exists $arglist class]} {
         3888  +          my select
         3889  +        }
         3890  +      }
         3891  +      default {
         3892  +        array $submethod define {*}$args
         3893  +      }
         3894  +    }
         3895  +  }
         3896  +  method graft args {
         3897  +    return [my clay delegate {*}$args]
         3898  +  }
         3899  +  method initialize {} {}
         3900  +  method link {command args} {
         3901  +    my variable links
         3902  +    switch $command {
         3903  +      object {
         3904  +        foreach obj $args {
         3905  +          foreach linktype [$obj linktype] {
         3906  +            my link add $linktype $obj
         3907  +          }
         3908  +        }
         3909  +      }
         3910  +      add {
         3911  +        ###
         3912  +        # Add a link to an object that was externally created
         3913  +        ###
         3914  +        if {[llength $args] ne 2} { error "Usage: link add LINKTYPE OBJECT"}
         3915  +        lassign $args linktype object
         3916  +        if {[info exists links($linktype)] && $object in $links($linktype)} {
         3917  +          return
         3918  +        }
         3919  +        lappend links($linktype) $object
         3920  +      }
         3921  +      remove {
         3922  +        set object [lindex $args 0]
         3923  +        if {[llength $args]==1} {
         3924  +          set ltype *
         3925  +        } else {
         3926  +          set ltype [lindex $args 1]
         3927  +        }
         3928  +        foreach {linktype elements} [array get links $ltype] {
         3929  +          if {$object in $elements} {
         3930  +            set nlist {}
         3931  +            foreach e $elements {
         3932  +              if { $object ne $e } { lappend nlist $e }
         3933  +            }
         3934  +            set links($linktype) $nlist
         3935  +          }
         3936  +        }
         3937  +      }
         3938  +      list {
         3939  +        if {[llength $args]==0} {
         3940  +          return [array get links]
         3941  +        }
         3942  +        if {[llength $args] != 1} { error "Usage: link list LINKTYPE"}
         3943  +        set linktype [lindex $args 0]
         3944  +        if {![info exists links($linktype)]} {
         3945  +          return {}
         3946  +        }
         3947  +        return $links($linktype)
         3948  +      }
         3949  +      dump {
         3950  +        return [array get links]
         3951  +      }
         3952  +    }
         3953  +  }
         3954  +  method morph classname {
         3955  +    my variable define
         3956  +    if {$classname ne {}} {
         3957  +      set map [list @[email protected] $classname]
         3958  +      foreach pattern [string map $map [my _MorphPatterns]] {
         3959  +        set pattern [string trim $pattern]
         3960  +        set matches [info commands $pattern]
         3961  +        if {![llength $matches]} continue
         3962  +        set class [lindex $matches 0]
         3963  +        break
         3964  +      }
         3965  +      set mixinslot {}
         3966  +      foreach {slot pattern} {
         3967  +        distribution ::practcl::distribution*
         3968  +        product      ::practcl::product*
         3969  +        toolset      ::practcl::toolset*
         3970  +      } {
         3971  +        if {[string match $pattern $class]} {
         3972  +           set mixinslot $slot
         3973  +           break
         3974  +        }
         3975  +      }
         3976  +      if {$mixinslot ne {}} {
         3977  +        my clay mixinmap $mixinslot $class
         3978  +      } elseif {[info command $class] ne {}} {
         3979  +        if {[info object class [self]] ne $class} {
         3980  +          ::oo::objdefine [self] class $class
         3981  +          ::practcl::debug [self] morph $class
         3982  +           my define set class $class
         3983  +        }
         3984  +      } else {
         3985  +        error "[self] Could not detect class for $classname"
         3986  +      }
         3987  +    }
         3988  +    if {[::info exists define(oodefine)]} {
         3989  +      ::oo::objdefine [self] $define(oodefine)
         3990  +      #unset define(oodefine)
         3991  +    }
         3992  +  }
         3993  +  method script script {
         3994  +    eval $script
         3995  +  }
         3996  +  method select {} {
         3997  +    my variable define
         3998  +    if {[info exists define(class)]} {
         3999  +      my morph $define(class)
         4000  +    } else {
         4001  +      if {[::info exists define(oodefine)]} {
         4002  +        ::oo::objdefine [self] $define(oodefine)
         4003  +        #unset define(oodefine)
         4004  +      }
         4005  +    }
         4006  +  }
         4007  +  method source filename {
         4008  +    source $filename
         4009  +  }
         4010  +}
         4011  +
         4012  +###
         4013  +# END: class metaclass.tcl
         4014  +###
         4015  +###
         4016  +# START: class toolset baseclass.tcl
         4017  +###
         4018  +::clay::define ::practcl::toolset {
         4019  +  method config.sh {} {
         4020  +    return [my read_configuration]
         4021  +  }
         4022  +  method BuildDir {PWD} {
         4023  +    set name [my define get name]
         4024  +    set debug [my define get debug 0]
         4025  +    if {[my <project> define get LOCAL 0]} {
         4026  +      return [my define get builddir [file join $PWD local $name]]
         4027  +    }
         4028  +    if {$debug} {
         4029  +      return [my define get builddir [file join $PWD debug $name]]
         4030  +    } else {
         4031  +      return [my define get builddir [file join $PWD pkg $name]]
         4032  +    }
         4033  +  }
         4034  +  method MakeDir {srcdir} {
         4035  +    return $srcdir
         4036  +  }
         4037  +  method read_configuration {} {
         4038  +    my variable conf_result
         4039  +    if {[info exists conf_result]} {
         4040  +      return $conf_result
         4041  +    }
         4042  +    set result {}
         4043  +    set name [my define get name]
         4044  +    set PWD $::CWD
         4045  +    set builddir [my define get builddir]
         4046  +    my unpack
         4047  +    set srcdir [my define get srcdir]
         4048  +    if {![file exists $builddir]} {
         4049  +      my Configure
         4050  +    }
         4051  +    set filename [file join $builddir config.tcl]
         4052  +    # Project uses the practcl template. Use the leavings from autoconf
         4053  +    if {[file exists $filename]} {
         4054  +      set dat [::practcl::read_configuration $builddir]
         4055  +      foreach {item value} [::practcl::sort_dict $dat] {
         4056  +        dict set result $item $value
         4057  +      }
         4058  +      set conf_result $result
         4059  +      return $result
         4060  +    }
         4061  +    set filename [file join $builddir ${name}Config.sh]
         4062  +    if {[file exists $filename]} {
         4063  +      set l [expr {[string length $name]+1}]
         4064  +      foreach {field dat} [::practcl::read_Config.sh $filename] {
         4065  +        set field [string tolower $field]
         4066  +        if {[string match ${name}_* $field]} {
         4067  +          set field [string range $field $l end]
         4068  +        }
         4069  +        switch $field {
         4070  +          version {
         4071  +            dict set result pkg_vers $dat
         4072  +          }
         4073  +          lib_file {
         4074  +            set field libfile
         4075  +          }
         4076  +        }
         4077  +        dict set result $field $dat
         4078  +      }
         4079  +      set conf_result $result
         4080  +      return $result
         4081  +    }
         4082  +    ###
         4083  +    # Oh man... we have to guess
         4084  +    ###
         4085  +    if {![file exists [file join $builddir Makefile]]} {
         4086  +      my Configure
         4087  +    }
         4088  +    set filename [file join $builddir Makefile]
         4089  +    if {![file exists $filename]} {
         4090  +      error "Could not locate any configuration data in $srcdir"
         4091  +    }
         4092  +    foreach {field dat} [::practcl::read_Makefile $filename] {
         4093  +      dict set result $field $dat
         4094  +    }
         4095  +    if {![dict exists $result PRACTCL_PKG_LIBS] && [dict exists $result LIBS]} {
         4096  +      dict set result PRACTCL_PKG_LIBS [dict get $result LIBS]
         4097  +    }
         4098  +    set conf_result $result
         4099  +    cd $PWD
         4100  +    return $result
         4101  +  }
         4102  +  method build-cflags {PROJECT DEFS namevar versionvar defsvar} {
         4103  +    upvar 1 $namevar name $versionvar version NAME NAME $defsvar defs
         4104  +    set name [string tolower [${PROJECT} define get name [${PROJECT} define get pkg_name]]]
         4105  +    set NAME [string toupper $name]
         4106  +    set version [${PROJECT} define get version [${PROJECT} define get pkg_vers]]
         4107  +    if {$version eq {}} {
         4108  +      set version 0.1a
         4109  +    }
         4110  +    set defs $DEFS
         4111  +    foreach flag {
         4112  +      -DPACKAGE_NAME
         4113  +      -DPACKAGE_VERSION
         4114  +      -DPACKAGE_TARNAME
         4115  +      -DPACKAGE_STRING
         4116  +    } {
         4117  +      if {[set i [string first $flag $defs]] >= 0} {
         4118  +        set j [string first -D $flag [expr {$i+[string length $flag]}]]
         4119  +        set predef [string range $defs 0 [expr {$i-1}]]
         4120  +        set postdef [string range $defs $j end]
         4121  +        set defs "$predef $postdef"
         4122  +      }
         4123  +    }
         4124  +    append defs " -DPACKAGE_NAME=\"${name}\" -DPACKAGE_VERSION=\"${version}\""
         4125  +    append defs " -DPACKAGE_TARNAME=\"${name}\" -DPACKAGE_STRING=\"${name}\x5c\x20${version}\""
         4126  +    return $defs
         4127  +  }
         4128  +  method critcl args {
         4129  +    if {![info exists critcl]} {
         4130  +      ::practcl::LOCAL tool critcl env-load
         4131  +      set critcl [file join [::practcl::LOCAL tool critcl define get srcdir] main.tcl
         4132  +    }
         4133  +    set srcdir [my SourceRoot]
         4134  +    set PWD [pwd]
         4135  +    cd $srcdir
         4136  +    ::practcl::dotclexec $critcl {*}$args
         4137  +    cd $PWD
         4138  +  }
         4139  +}
         4140  +oo::objdefine ::practcl::toolset {
         4141  +  # Perform the selection for the toolset mixin
         4142  +  method select object {
         4143  +    ###
         4144  +    # Select the toolset to use for this project
         4145  +    ###
         4146  +    if {[$object define exists toolset]} {
         4147  +      return [$object define get toolset]
         4148  +    }
         4149  +    set class [$object define get toolset]
         4150  +    if {$class ne {}} {
         4151  +      $object clay mixinmap toolset $class
         4152  +    } else {
         4153  +      if {[info exists ::env(VisualStudioVersion)]} {
         4154  +        $object clay mixinmap toolset ::practcl::toolset.msvc
         4155  +      } else {
         4156  +        $object clay mixinmap toolset ::practcl::toolset.gcc
         4157  +      }
         4158  +    }
         4159  +  }
         4160  +}
         4161  +
         4162  +###
         4163  +# END: class toolset baseclass.tcl
         4164  +###
         4165  +###
         4166  +# START: class toolset gcc.tcl
         4167  +###
         4168  +::clay::define ::practcl::toolset.gcc {
         4169  +  superclass ::practcl::toolset
         4170  +  method Autoconf {} {
         4171  +    ###
         4172  +    # Re-run autoconf for this project
         4173  +    # Not a good idea in practice... but in the right hands it can be useful
         4174  +    ###
         4175  +    set pwd [pwd]
         4176  +    set srcdir [file normalize [my define get srcdir]]
         4177  +    set localsrcdir [my MakeDir $srcdir]
         4178  +    cd $localsrcdir
         4179  +    foreach template {configure.ac configure.in} {
         4180  +      set input [file join $srcdir $template]
         4181  +      if {[file exists $input]} {
         4182  +        puts "autoconf -f $input > [file join $srcdir configure]"
         4183  +        exec autoconf -f $input > [file join $srcdir configure]
         4184  +      }
         4185  +    }
         4186  +    cd $pwd
         4187  +  }
         4188  +  method BuildDir {PWD} {
         4189  +    set name [my define get name]
         4190  +    set debug [my define get debug 0]
         4191  +    if {[my <project> define get LOCAL 0]} {
         4192  +      return [my define get builddir [file join $PWD local $name]]
         4193  +    }
         4194  +    if {$debug} {
         4195  +      return [my define get builddir [file join $PWD debug $name]]
         4196  +    } else {
         4197  +      return [my define get builddir [file join $PWD pkg $name]]
         4198  +    }
         4199  +  }
         4200  +  method ConfigureOpts {} {
         4201  +    set opts {}
         4202  +    set builddir [my define get builddir]
         4203  +
         4204  +    if {[my define get broken_destroot 0]} {
         4205  +      set PREFIX [my <project> define get prefix_broken_destdir]
         4206  +    } else {
         4207  +      set PREFIX [my <project> define get prefix]
         4208  +    }
         4209  +    switch [my define get name] {
         4210  +      tcl {
         4211  +        set opts [::practcl::platform::tcl_core_options [my <project> define get TEACUP_OS]]
         4212  +      }
         4213  +      tk {
         4214  +        set opts [::practcl::platform::tk_core_options  [my <project> define get TEACUP_OS]]
         4215  +      }
         4216  +    }
         4217  +    if {[my <project> define get CONFIG_SITE] != {}} {
         4218  +      lappend opts --host=[my <project> define get HOST]
         4219  +    }
         4220  +    set inside_msys [string is true -strict [my <project> define get MSYS_ENV 0]]
         4221  +    lappend opts --with-tclsh=[info nameofexecutable]
         4222  +
         4223  +    if {[my define get tk 0]} {
         4224  +      if {![my <project> define get LOCAL 0]} {
         4225  +        set obj [my <project> tclcore]
         4226  +        if {$obj ne {}} {
         4227  +          if {$inside_msys} {
         4228  +            lappend opts --with-tcl=[::practcl::file_relative [file normalize $builddir] [$obj define get builddir]]
         4229  +          } else {
         4230  +            lappend opts --with-tcl=[file normalize [$obj define get builddir]]
         4231  +          }
         4232  +        }
         4233  +        set obj [my <project> tkcore]
         4234  +        if {$obj ne {}} {
         4235  +          if {$inside_msys} {
         4236  +            lappend opts --with-tk=[::practcl::file_relative [file normalize $builddir] [$obj define get builddir]]
         4237  +          } else {
         4238  +            lappend opts --with-tk=[file normalize [$obj define get builddir]]
         4239  +          }
         4240  +        }
         4241  +      } else {
         4242  +        lappend opts --with-tcl=[file join $PREFIX lib]
         4243  +        lappend opts --with-tk=[file join $PREFIX lib]
         4244  +      }
         4245  +    } else {
         4246  +      if {![my <project> define get LOCAL 0]} {
         4247  +        set obj [my <project> tclcore]
         4248  +        if {$obj ne {}} {
         4249  +          if {$inside_msys} {
         4250  +            lappend opts --with-tcl=[::practcl::file_relative [file normalize $builddir] [$obj define get builddir]]
         4251  +          } else {
         4252  +            lappend opts --with-tcl=[file normalize [$obj define get builddir]]
         4253  +          }
         4254  +        }
         4255  +      } else {
         4256  +        lappend opts --with-tcl=[file join $PREFIX lib]
         4257  +      }
         4258  +    }
         4259  +
         4260  +    lappend opts {*}[my define get config_opts]
         4261  +    if {![regexp -- "--prefix" $opts]} {
         4262  +      lappend opts --prefix=$PREFIX --exec-prefix=$PREFIX
         4263  +    }
         4264  +    if {[my define get debug 0]} {
         4265  +      lappend opts --enable-symbols=true
         4266  +    }
         4267  +    #--exec_prefix=$PREFIX
         4268  +    #if {$::tcl_platform(platform) eq "windows"} {
         4269  +    #  lappend opts --disable-64bit
         4270  +    #}
         4271  +    if {[my define get static 1]} {
         4272  +      lappend opts --disable-shared
         4273  +      #--disable-stubs
         4274  +      #
         4275  +    } else {
         4276  +      lappend opts --enable-shared
         4277  +    }
         4278  +    return $opts
         4279  +  }
         4280  +  method MakeDir {srcdir} {
         4281  +    set localsrcdir $srcdir
         4282  +    if {[file exists [file join $srcdir generic]]} {
         4283  +      my define add include_dir [file join $srcdir generic]
         4284  +    }
         4285  +    set os [my <project> define get TEACUP_OS]
         4286  +    switch $os {
         4287  +      windows {
         4288  +        if {[file exists [file join $srcdir win]]} {
         4289  +          my define add include_dir [file join $srcdir win]
         4290  +        }
         4291  +        if {[file exists [file join $srcdir win Makefile.in]]} {
         4292  +          set localsrcdir [file join $srcdir win]
         4293  +        }
         4294  +      }
         4295  +      macosx {
         4296  +        if {[file exists [file join $srcdir unix Makefile.in]]} {
         4297  +          set localsrcdir [file join $srcdir unix]
         4298  +        }
         4299  +      }
         4300  +      default {
         4301  +        if {[file exists [file join $srcdir $os]]} {
         4302  +          my define add include_dir [file join $srcdir $os]
         4303  +        }
         4304  +        if {[file exists [file join $srcdir unix]]} {
         4305  +          my define add include_dir [file join $srcdir unix]
         4306  +        }
         4307  +        if {[file exists [file join $srcdir $os Makefile.in]]} {
         4308  +          set localsrcdir [file join $srcdir $os]
         4309  +        } elseif {[file exists [file join $srcdir unix Makefile.in]]} {
         4310  +          set localsrcdir [file join $srcdir unix]
         4311  +        }
         4312  +      }
         4313  +    }
         4314  +    return $localsrcdir
         4315  +  }
         4316  +  Ensemble make::autodetect {} {
         4317  +    set srcdir [my define get srcdir]
         4318  +    set localsrcdir [my MakeDir $srcdir]
         4319  +    if {$localsrcdir eq {}} {
         4320  +      set localsrcdir $srcdir
         4321  +    }
         4322  +    if {$srcdir eq $localsrcdir} {
         4323  +      if {![file exists [file join $srcdir tclconfig install-sh]]} {
         4324  +        # ensure we have tclconfig with all of the trimmings
         4325  +        set teapath {}
         4326  +        if {[file exists [file join $srcdir .. tclconfig install-sh]]} {
         4327  +          set teapath [file join $srcdir .. tclconfig]
         4328  +        } else {
         4329  +          set tclConfigObj [::practcl::LOCAL tool tclconfig]
         4330  +          $tclConfigObj load
         4331  +          set teapath [$tclConfigObj define get srcdir]
         4332  +        }
         4333  +        set teapath [file normalize $teapath]
         4334  +        #file mkdir [file join $srcdir tclconfig]
         4335  +        if {[catch {file link -symbolic [file join $srcdir tclconfig] $teapath}]} {
         4336  +          ::practcl::copyDir [file join $teapath] [file join $srcdir tclconfig]
         4337  +        }
         4338  +      }
         4339  +    }
         4340  +    set builddir [my define get builddir]
         4341  +    file mkdir $builddir
         4342  +    if {![file exists [file join $localsrcdir configure]]} {
         4343  +      if {[file exists [file join $localsrcdir autogen.sh]]} {
         4344  +        cd $localsrcdir
         4345  +        catch {exec sh autogen.sh >>& [file join $builddir autoconf.log]}
         4346  +        cd $::CWD
         4347  +      }
         4348  +    }
         4349  +    set opts [my ConfigureOpts]
         4350  +    if {[file exists [file join $builddir autoconf.log]]} {
         4351  +      file delete [file join $builddir autoconf.log]
         4352  +    }
         4353  +    ::practcl::debug [list PKG [my define get name] CONFIGURE {*}$opts]
         4354  +    ::practcl::log   [file join $builddir autoconf.log] [list  CONFIGURE {*}$opts]
         4355  +    cd $builddir
         4356  +    if {[my <project> define get CONFIG_SITE] ne {}} {
         4357  +      set ::env(CONFIG_SITE) [my <project> define get CONFIG_SITE]
         4358  +    }
         4359  +    catch {exec sh [file join $localsrcdir configure] {*}$opts >>& [file join $builddir autoconf.log]}
         4360  +    cd $::CWD
         4361  +  }
         4362  +  Ensemble make::clean {} {
         4363  +    set builddir [file normalize [my define get builddir]]
         4364  +    catch {::practcl::domake $builddir clean}
         4365  +  }
         4366  +  Ensemble make::compile {} {
         4367  +    set name [my define get name]
         4368  +    set srcdir [my define get srcdir]
         4369  +    if {[my define get static 1]} {
         4370  +      puts "BUILDING Static $name $srcdir"
         4371  +    } else {
         4372  +      puts "BUILDING Dynamic $name $srcdir"
         4373  +    }
         4374  +    cd $::CWD
         4375  +    set builddir [file normalize [my define get builddir]]
         4376  +    file mkdir $builddir
         4377  +    if {![file exists [file join $builddir Makefile]]} {
         4378  +      my Configure
         4379  +    }
         4380  +    if {[file exists [file join $builddir make.tcl]]} {
         4381  +      if {[my define get debug 0]} {
         4382  +        ::practcl::domake.tcl $builddir debug all
         4383  +      } else {
         4384  +        ::practcl::domake.tcl $builddir all
         4385  +      }
         4386  +    } else {
         4387  +      ::practcl::domake $builddir all
         4388  +    }
         4389  +  }
         4390  +  Ensemble make::install DEST {
         4391  +    set PWD [pwd]
         4392  +    set builddir [my define get builddir]
         4393  +    if {[my <project> define get LOCAL 0] || $DEST eq {}} {
         4394  +      if {[file exists [file join $builddir make.tcl]]} {
         4395  +        puts "[self] Local INSTALL (Practcl)"
         4396  +        ::practcl::domake.tcl $builddir install
         4397  +      } elseif {[my define get broken_destroot 0] == 0} {
         4398  +        puts "[self] Local INSTALL (TEA)"
         4399  +        ::practcl::domake $builddir install
         4400  +      }
         4401  +    } else {
         4402  +      if {[file exists [file join $builddir make.tcl]]} {
         4403  +        # Practcl builds can inject right to where we need them
         4404  +        puts "[self] VFS INSTALL $DEST (Practcl)"
         4405  +        ::practcl::domake.tcl $builddir install-package $DEST
         4406  +      } elseif {[my define get broken_destroot 0] == 0} {
         4407  +        # Most modern TEA projects understand DESTROOT in the makefile
         4408  +        puts "[self] VFS INSTALL $DEST (TEA)"
         4409  +        ::practcl::domake $builddir install DESTDIR=[::practcl::file_relative $builddir $DEST]
         4410  +      } else {
         4411  +        # But some require us to do an install into a fictitious filesystem
         4412  +        # and then extract the gooey parts within.
         4413  +        # (*cough*) TkImg
         4414  +        set PREFIX [my <project> define get prefix]
         4415  +        set BROKENROOT [::practcl::msys_to_tclpath [my <project> define get prefix_broken_destdir]]
         4416  +        file delete -force $BROKENROOT
         4417  +        file mkdir $BROKENROOT
         4418  +        ::practcl::domake $builddir $install
         4419  +        ::practcl::copyDir $BROKENROOT  [file join $DEST [string trimleft $PREFIX /]]
         4420  +        file delete -force $BROKENROOT
         4421  +      }
         4422  +    }
         4423  +    cd $PWD
         4424  +  }
         4425  +  method build-compile-sources {PROJECT COMPILE CPPCOMPILE INCLUDES} {
         4426  +    set objext [my define get OBJEXT o]
         4427  +    set EXTERN_OBJS {}
         4428  +    set OBJECTS {}
         4429  +    set result {}
         4430  +    set builddir [$PROJECT define get builddir]
         4431  +    file mkdir [file join $builddir objs]
         4432  +    set debug [$PROJECT define get debug 0]
         4433  +
         4434  +    set task {}
         4435  +    ###
         4436  +    # Compile the C sources
         4437  +    ###
         4438  +    ::practcl::debug ### COMPILE PRODUCTS
         4439  +    foreach {ofile info} [${PROJECT} project-compile-products] {
         4440  +      ::practcl::debug $ofile $info
         4441  +      if {[dict exists $info library]} {
         4442  +        #dict set task $ofile done 1
         4443  +        continue
         4444  +      }
         4445  +      # Products with no cfile aren't compiled
         4446  +      if {![dict exists $info cfile] || [set cfile [dict get $info cfile]] eq {}} {
         4447  +        #dict set task $ofile done 1
         4448  +        continue
         4449  +      }
         4450  +      set ofile [file rootname $ofile]
         4451  +      dict set task $ofile done 0
         4452  +      if {[dict exists $info external] && [dict get $info external]==1} {
         4453  +        dict set task $ofile external 1
         4454  +      } else {
         4455  +        dict set task $ofile external 0
         4456  +      }
         4457  +      set cfile [dict get $info cfile]
         4458  +      if {$debug} {
         4459  +        set ofilename [file join $builddir objs [file rootname [file tail $ofile]].debug.${objext}]
         4460  +      } else {
         4461  +        set ofilename [file join $builddir objs [file tail $ofile]].${objext}
         4462  +      }
         4463  +      dict set task $ofile source $cfile
         4464  +      dict set task $ofile objfile $ofilename
         4465  +      if {![dict exist $info command]} {
         4466  +        if {[file extension $cfile] in {.c++ .cpp}} {
         4467  +          set cmd $CPPCOMPILE
         4468  +        } else {
         4469  +          set cmd $COMPILE
         4470  +        }
         4471  +        if {[dict exists $info extra]} {
         4472  +          append cmd " [dict get $info extra]"
         4473  +        }
         4474  +        append cmd " $INCLUDES"
         4475  +        append cmd " -c $cfile"
         4476  +        append cmd " -o $ofilename"
         4477  +        dict set task $ofile command $cmd
         4478  +      }
         4479  +    }
         4480  +    set completed 0
         4481  +    while {$completed==0} {
         4482  +      set completed 1
         4483  +      foreach {ofile info} $task {
         4484  +        set waiting {}
         4485  +        if {[dict exists $info done] && [dict get $info done]} continue
         4486  +        ::practcl::debug COMPILING $ofile $info
         4487  +        set filename [dict get $info objfile]
         4488  +        if {[file exists $filename] && [file mtime $filename]>[file mtime [dict get $info source]]} {
         4489  +          lappend result $filename
         4490  +          dict set task $ofile done 1
         4491  +          continue
         4492  +        }
         4493  +        if {[dict exists $info depend]} {
         4494  +          foreach file [dict get $info depend] {
         4495  +            if {[dict exists $task $file command] && [dict exists $task $file done] && [dict get $task $file done] != 1} {
         4496  +              set waiting $file
         4497  +              break
         4498  +            }
         4499  +          }
         4500  +        }
         4501  +        if {$waiting ne {}} {
         4502  +          set completed 0
         4503  +          puts "$ofile waiting for $waiting"
         4504  +          continue
         4505  +        }
         4506  +        if {[dict exists $info command]} {
         4507  +          set cmd [dict get $info command]
         4508  +          puts "$cmd"
         4509  +          exec {*}$cmd >&@ stdout
         4510  +        }
         4511  +        if {[file exists $filename]} {
         4512  +          lappend result $filename
         4513  +          dict set task $ofile done 1
         4514  +          continue
         4515  +        }
         4516  +        error "Failed to produce $filename"
         4517  +      }
         4518  +    }
         4519  +    return $result
         4520  +  }
         4521  +method build-Makefile {path PROJECT} {
         4522  +  array set proj [$PROJECT define dump]
         4523  +  set path $proj(builddir)
         4524  +  cd $path
         4525  +  set includedir .
         4526  +  set objext [my define get OBJEXT o]
         4527  +
         4528  +  #lappend includedir [::practcl::file_relative $path $proj(TCL_INCLUDES)]
         4529  +  lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(TCL_SRC_DIR) generic]]]
         4530  +  lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(srcdir) generic]]]
         4531  +  foreach include [$PROJECT toolset-include-directory] {
         4532  +    set cpath [::practcl::file_relative $path [file normalize $include]]
         4533  +    if {$cpath ni $includedir} {
         4534  +      lappend includedir $cpath
         4535  +    }
         4536  +  }
         4537  +  set INCLUDES  "-I[join $includedir " -I"]"
         4538  +  set NAME [string toupper $proj(name)]
         4539  +  set result {}
         4540  +  set products {}
         4541  +  set libraries {}
         4542  +  set thisline {}
         4543  +  ::practcl::cputs result "${NAME}_DEFS = $proj(DEFS)\n"
         4544  +  ::practcl::cputs result "${NAME}_INCLUDES = -I\"[join $includedir "\" -I\""]\"\n"
         4545  +  ::practcl::cputs result "${NAME}_COMPILE = \$(CC) \$(CFLAGS) \$(PKG_CFLAGS) \$(${NAME}_DEFS) \$(${NAME}_INCLUDES) \$(INCLUDES) \$(AM_CPPFLAGS) \$(CPPFLAGS) \$(AM_CFLAGS)"
         4546  +  ::practcl::cputs result "${NAME}_CPPCOMPILE = \$(CXX) \$(CFLAGS) \$(PKG_CFLAGS) \$(${NAME}_DEFS) \$(${NAME}_INCLUDES) \$(INCLUDES) \$(AM_CPPFLAGS) \$(CPPFLAGS) \$(AM_CFLAGS)"
         4547  +
         4548  +  foreach {ofile info} [$PROJECT project-compile-products] {
         4549  +    dict set products $ofile $info
         4550  +    set fname [file rootname ${ofile}].${objext}
         4551  +    if {[dict exists $info library]} {
         4552  +lappend libraries $ofile
         4553  +continue
         4554  +    }
         4555  +    if {[dict exists $info depend]} {
         4556  +      ::practcl::cputs result "\n${fname}: [dict get $info depend]"
         4557  +    } else {
         4558  +      ::practcl::cputs result "\n${fname}:"
         4559  +    }
         4560  +    set cfile [dict get $info cfile]
         4561  +    if {[file extension $cfile] in {.c++ .cpp}} {
         4562  +      set cmd "\t\$\(${NAME}_CPPCOMPILE\)"
         4563  +    } else {
         4564  +      set cmd "\t\$\(${NAME}_COMPILE\)"
         4565  +    }
         4566  +    if {[dict exists $info extra]} {
         4567  +      append cmd " [dict get $info extra]"
         4568  +    }
         4569  +    append cmd " -c [dict get $info cfile] -o \[email protected]\n\t"
         4570  +    ::practcl::cputs result  $cmd
         4571  +  }
         4572  +
         4573  +  set map {}
         4574  +  lappend map %LIBRARY_NAME% $proj(name)
         4575  +  lappend map %LIBRARY_VERSION% $proj(version)
         4576  +  lappend map %LIBRARY_VERSION_NODOTS% [string map {. {}} $proj(version)]
         4577  +  lappend map %LIBRARY_PREFIX% [$PROJECT define getnull libprefix]
         4578  +
         4579  +  if {[string is true [$PROJECT define get SHARED_BUILD]]} {
         4580  +    set outfile [$PROJECT define get libfile]
         4581  +  } else {
         4582  +    set outfile [$PROJECT shared_library]
         4583  +  }
         4584  +  $PROJECT define set shared_library $outfile
         4585  +  ::practcl::cputs result "
         4586  +${NAME}_SHLIB = $outfile
         4587  +${NAME}_OBJS = [dict keys $products]
         4588  +"
         4589  +
         4590  +  #lappend map %OUTFILE% {\[$]@}
         4591  +  lappend map %OUTFILE% $outfile
         4592  +  lappend map %LIBRARY_OBJECTS% "\$(${NAME}_OBJS)"
         4593  +  ::practcl::cputs result "$outfile: \$(${NAME}_OBJS)"
         4594  +  ::practcl::cputs result "\t[string map $map [$PROJECT define get PRACTCL_SHARED_LIB]]"
         4595  +  if {[$PROJECT define get PRACTCL_VC_MANIFEST_EMBED_DLL] ni {: {}}} {
         4596  +    ::practcl::cputs result "\t[string map $map [$PROJECT define get PRACTCL_VC_MANIFEST_EMBED_DLL]]"
         4597  +  }
         4598  +  ::practcl::cputs result {}
         4599  +  if {[string is true [$PROJECT define get SHARED_BUILD]]} {
         4600  +    #set outfile [$PROJECT static_library]
         4601  +    set outfile $proj(name).a
         4602  +  } else {
         4603  +    set outfile [$PROJECT define get libfile]
         4604  +  }
         4605  +  $PROJECT define set static_library $outfile
         4606  +  dict set map %OUTFILE% $outfile
         4607  +  ::practcl::cputs result "$outfile: \$(${NAME}_OBJS)"
         4608  +  ::practcl::cputs result "\t[string map $map [$PROJECT define get PRACTCL_STATIC_LIB]]"
         4609  +  ::practcl::cputs result {}
         4610  +  return $result
         4611  +}
         4612  +method build-library {outfile PROJECT} {
         4613  +  array set proj [$PROJECT define dump]
         4614  +  set path $proj(builddir)
         4615  +  cd $path
         4616  +  set includedir .
         4617  +  #lappend includedir [::practcl::file_relative $path $proj(TCL_INCLUDES)]
         4618  +  lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(TCL_SRC_DIR) generic]]]
         4619  +  if {[$PROJECT define get TEA_PRIVATE_TCL_HEADERS 0]} {
         4620  +    if {[$PROJECT define get TEA_PLATFORM] eq "windows"} {
         4621  +      lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(TCL_SRC_DIR) win]]]
         4622  +    } else {
         4623  +      lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(TCL_SRC_DIR) unix]]]
         4624  +    }
         4625  +  }
         4626  +
         4627  +  lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(srcdir) generic]]]
         4628  +
         4629  +  if {[$PROJECT define get tk 0]} {
         4630  +    lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(TK_SRC_DIR) generic]]]
         4631  +    lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(TK_SRC_DIR) ttk]]]
         4632  +    lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(TK_SRC_DIR) xlib]]]
         4633  +    if {[$PROJECT define get TEA_PRIVATE_TK_HEADERS 0]} {
         4634  +      if {[$PROJECT define get TEA_PLATFORM] eq "windows"} {
         4635  +        lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(TK_SRC_DIR) win]]]
         4636  +      } else {
         4637  +        lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(TK_SRC_DIR) unix]]]
         4638  +      }
         4639  +    }
         4640  +    lappend includedir [::practcl::file_relative $path [file normalize $proj(TK_BIN_DIR)]]
         4641  +  }
         4642  +  foreach include [$PROJECT toolset-include-directory] {
         4643  +    set cpath [::practcl::file_relative $path [file normalize $include]]
         4644  +    if {$cpath ni $includedir} {
         4645  +      lappend includedir $cpath
         4646  +    }
         4647  +  }
         4648  +  my build-cflags $PROJECT $proj(DEFS) name version defs
         4649  +  set NAME [string toupper $name]
         4650  +  set debug [$PROJECT define get debug 0]
         4651  +  set os [$PROJECT define get TEACUP_OS]
         4652  +
         4653  +  set INCLUDES  "-I[join $includedir " -I"]"
         4654  +  if {$debug} {
         4655  +    set COMPILE "$proj(CC) $proj(CFLAGS_DEBUG) -ggdb \
         4656  +$proj(CFLAGS_WARNING) $INCLUDES $defs"
         4657  +
         4658  +    if {[info exists proc(CXX)]} {
         4659  +      set COMPILECPP "$proj(CXX) $defs $INCLUDES $proj(CFLAGS_DEBUG) -ggdb \
         4660  +  $defs $proj(CFLAGS_WARNING)"
         4661  +    } else {
         4662  +      set COMPILECPP $COMPILE
         4663  +    }
         4664  +  } else {
         4665  +    set COMPILE "$proj(CC) $proj(CFLAGS) $defs"
         4666  +
         4667  +    if {[info exists proc(CXX)]} {
         4668  +      set COMPILECPP "$proj(CXX) $defs $proj(CFLAGS)"
         4669  +    } else {
         4670  +      set COMPILECPP $COMPILE
         4671  +    }
         4672  +  }
         4673  +
         4674  +  set products [my build-compile-sources $PROJECT $COMPILE $COMPILECPP $INCLUDES]
         4675  +
         4676  +  set map {}
         4677  +  lappend map %LIBRARY_NAME% $proj(name)
         4678  +  lappend map %LIBRARY_VERSION% $proj(version)
         4679  +  lappend map %LIBRARY_VERSION_NODOTS% [string map {. {}} $proj(version)]
         4680  +  lappend map %OUTFILE% $outfile
         4681  +  lappend map %LIBRARY_OBJECTS% $products
         4682  +  lappend map {${CFLAGS}} "$proj(CFLAGS_DEFAULT) $proj(CFLAGS_WARNING)"
         4683  +
         4684  +  if {[string is true [$PROJECT define get SHARED_BUILD 1]]} {
         4685  +    set cmd [$PROJECT define get PRACTCL_SHARED_LIB]
         4686  +    append cmd " [$PROJECT define get PRACTCL_LIBS]"
         4687  +    set cmd [string map $map $cmd]
         4688  +    puts $cmd
         4689  +    exec {*}$cmd >&@ stdout
         4690  +    if {[$PROJECT define get PRACTCL_VC_MANIFEST_EMBED_DLL] ni {: {}}} {
         4691  +      set cmd [string map $map [$PROJECT define get PRACTCL_VC_MANIFEST_EMBED_DLL]]
         4692  +      puts $cmd
         4693  +      exec {*}$cmd >&@ stdout
         4694  +    }
         4695  +  } else {
         4696  +    set cmd [string map $map [$PROJECT define get PRACTCL_STATIC_LIB]]
         4697  +    puts $cmd
         4698  +    exec {*}$cmd >&@ stdout
         4699  +  }
         4700  +  set ranlib [$PROJECT define get RANLIB]
         4701  +  if {$ranlib ni {{} :}} {
         4702  +    catch {exec $ranlib $outfile}
         4703  +  }
         4704  +}
         4705  +method build-tclsh {outfile PROJECT {path {auto}}} {
         4706  +  if {[my define get tk 0] && [my define get static_tk 0]} {
         4707  +    puts " BUILDING STATIC TCL/TK EXE $PROJECT"
         4708  +    set TKOBJ  [$PROJECT tkcore]
         4709  +    if {[info command $TKOBJ] eq {}} {
         4710  +      set TKOBJ ::noop
         4711  +      $PROJECT define set static_tk 0
         4712  +    } else {
         4713  +      ::practcl::toolset select $TKOBJ
         4714  +      array set TK  [$TKOBJ read_configuration]
         4715  +      set do_tk [$TKOBJ define get static]
         4716  +      $PROJECT define set static_tk $do_tk
         4717  +      $PROJECT define set tk $do_tk
         4718  +      set TKSRCDIR [$TKOBJ define get srcdir]
         4719  +    }
         4720  +  } else {
         4721  +    puts " BUILDING STATIC TCL EXE $PROJECT"
         4722  +    set TKOBJ ::noop
         4723  +    my define set static_tk 0
         4724  +  }
         4725  +  set TCLOBJ [$PROJECT tclcore]
         4726  +  ::practcl::toolset select $TCLOBJ
         4727  +  set PKG_OBJS {}
         4728  +  foreach item [$PROJECT link list core.library] {
         4729  +    if {[string is true [$item define get static]]} {
         4730  +      lappend PKG_OBJS $item
         4731  +    }
         4732  +  }
         4733  +  foreach item [$PROJECT link list package] {
         4734  +    if {[string is true [$item define get static]]} {
         4735  +      lappend PKG_OBJS $item
         4736  +    }
         4737  +  }
         4738  +  array set TCL [$TCLOBJ read_configuration]
         4739  +  if {$path in {{} auto}} {
         4740  +    set path [file dirname [file normalize $outfile]]
         4741  +  }
         4742  +  if {$path eq "."} {
         4743  +    set path [pwd]
         4744  +  }
         4745  +  cd $path
         4746  +  ###
         4747  +  # For a static Tcl shell, we need to build all local sources
         4748  +  # with the same DEFS flags as the tcl core was compiled with.
         4749  +  # The DEFS produced by a TEA extension aren't intended to operate
         4750  +  # with the internals of a staticly linked Tcl
         4751  +  ###
         4752  +  my build-cflags $PROJECT $TCL(defs) name version defs
         4753  +  set debug [$PROJECT define get debug 0]
         4754  +  set NAME [string toupper $name]
         4755  +  set result {}
         4756  +  set libraries {}
         4757  +  set thisline {}
         4758  +  set OBJECTS {}
         4759  +  set EXTERN_OBJS {}
         4760  +  foreach obj $PKG_OBJS {
         4761  +    $obj compile
         4762  +    set config($obj) [$obj read_configuration]
         4763  +  }
         4764  +  set os [$PROJECT define get TEACUP_OS]
         4765  +  set TCLSRCDIR [$TCLOBJ define get srcdir]
         4766  +
         4767  +  set includedir .
         4768  +  foreach include [$TCLOBJ toolset-include-directory] {
         4769  +    set cpath [::practcl::file_relative $path [file normalize $include]]
         4770  +    if {$cpath ni $includedir} {
         4771  +      lappend includedir $cpath
         4772  +    }
         4773  +  }
         4774  +  lappend includedir [::practcl::file_relative $path [file normalize ../tcl/compat/zlib]]
         4775  +  if {[$PROJECT define get static_tk]} {
         4776  +    lappend includedir [::practcl::file_relative $path [file normalize [file join $TKSRCDIR generic]]]
         4777  +    lappend includedir [::practcl::file_relative $path [file normalize [file join $TKSRCDIR ttk]]]
         4778  +    lappend includedir [::practcl::file_relative $path [file normalize [file join $TKSRCDIR xlib]]]
         4779  +    lappend includedir [::practcl::file_relative $path [file normalize $TKSRCDIR]]
         4780  +  }
         4781  +
         4782  +  foreach include [$PROJECT toolset-include-directory] {
         4783  +    set cpath [::practcl::file_relative $path [file normalize $include]]
         4784  +    if {$cpath ni $includedir} {
         4785  +      lappend includedir $cpath
         4786  +    }
         4787  +  }
         4788  +
         4789  +  set INCLUDES  "-I[join $includedir " -I"]"
         4790  +  if {$debug} {
         4791  +      set COMPILE "$TCL(cc) $TCL(shlib_cflags) $TCL(cflags_debug) -ggdb \
         4792  +$TCL(cflags_warning) $TCL(extra_cflags)"
         4793  +  } else {
         4794  +      set COMPILE "$TCL(cc) $TCL(shlib_cflags) $TCL(cflags_optimize) \
         4795  +$TCL(cflags_warning) $TCL(extra_cflags)"
         4796  +  }
         4797  +  append COMPILE " " $defs
         4798  +  lappend OBJECTS {*}[my build-compile-sources $PROJECT $COMPILE $COMPILE $INCLUDES]
         4799  +
         4800  +  set TCLSRC [file normalize $TCLSRCDIR]
         4801  +
         4802  +  if {[${PROJECT} define get TEACUP_OS] eq "windows"} {
         4803  +    set windres [$PROJECT define get RC windres]
         4804  +    set RSOBJ [file join $path objs tclkit.res.o]
         4805  +    set RCSRC [${PROJECT} define get kit_resource_file]
         4806  +    set RCMAN [${PROJECT} define get kit_manifest_file]
         4807  +    set RCICO [${PROJECT} define get kit_icon_file]
         4808  +
         4809  +    set cmd [list $windres -o $RSOBJ -DSTATIC_BUILD --include [::practcl::file_relative $path [file join $TCLSRC generic]]]
         4810  +    if {[$PROJECT define get static_tk]} {
         4811  +      if {$RCSRC eq {} || ![file exists $RCSRC]} {
         4812  +        set RCSRC [file join $TKSRCDIR win rc wish.rc]
         4813  +      }
         4814  +      if {$RCMAN eq {} || ![file exists $RCMAN]} {
         4815  +        set RCMAN [file join [$TKOBJ define get builddir] wish.exe.manifest]
         4816  +      }
         4817  +      if {$RCICO eq {} || ![file exists $RCICO]} {
         4818  +        set RCICO [file join $TKSRCDIR win rc wish.ico]
         4819  +      }
         4820  +      set TKSRC [file normalize $TKSRCDIR]
         4821  +      lappend cmd --include [::practcl::file_relative $path [file join $TKSRC generic]] \
         4822  +        --include [::practcl::file_relative $path [file join $TKSRC win]] \
         4823  +        --include [::practcl::file_relative $path [file join $TKSRC win rc]]
         4824  +    } else {
         4825  +      if {$RCSRC eq {} || ![file exists $RCSRC]} {
         4826  +        set RCSRC [file join $TCLSRCDIR win tclsh.rc]
         4827  +      }
         4828  +      if {$RCMAN eq {} || ![file exists $RCMAN]} {
         4829  +        set RCMAN [file join [$TCLOBJ define get builddir] tclsh.exe.manifest]
         4830  +      }
         4831  +      if {$RCICO eq {} || ![file exists $RCICO]} {
         4832  +        set RCICO [file join $TCLSRCDIR win tclsh.ico]
         4833  +      }
         4834  +    }
         4835  +    foreach item [${PROJECT} define get resource_include] {
         4836  +      lappend cmd --include [::practcl::file_relative $path [file normalize $item]]
         4837  +    }
         4838  +    lappend cmd [file tail $RCSRC]
         4839  +    if {![file exists [file join $path [file tail $RCSRC]]]} {
         4840  +      file copy -force $RCSRC [file join $path [file tail $RCSRC]]
         4841  +    }
         4842  +    if {![file exists [file join $path [file tail $RCMAN]]]} {
         4843  +      file copy -force $RCMAN [file join $path [file tail $RCMAN]]
         4844  +    }
         4845  +    if {![file exists [file join $path [file tail $RCICO]]]} {
         4846  +      file copy -force $RCICO [file join $path [file tail $RCICO]]
         4847  +    }
         4848  +    ::practcl::doexec {*}$cmd
         4849  +    lappend OBJECTS $RSOBJ
         4850  +  }
         4851  +  puts "***"
         4852  +  set cmd "$TCL(cc)"
         4853  +  if {$debug} {
         4854  +   append cmd " $TCL(cflags_debug)"
         4855  +  } else {
         4856  +   append cmd " $TCL(cflags_optimize)"
         4857  +  }
         4858  +  append cmd " $TCL(ld_flags)"
         4859  +  if {$debug} {
         4860  +   append cmd " $TCL(ldflags_debug)"
         4861  +  } else {
         4862  +   append cmd " $TCL(ldflags_optimize)"
         4863  +  }
         4864  +
         4865  +  append cmd " $OBJECTS"
         4866  +  append cmd " $EXTERN_OBJS"
         4867  +  if {$debug && $os eq "windows"} {
         4868  +    ###
         4869  +    # There is bug in the core's autoconf and the value for
         4870  +    # tcl_build_lib_spec does not have the 'g' suffix
         4871  +    ###
         4872  +    append cmd " -L[file dirname $TCL(build_stub_lib_path)] -ltcl86g"
         4873  +    if {[$PROJECT define get static_tk]} {
         4874  +      append cmd " -L[file dirname $TK(build_stub_lib_path)] -ltk86g"
         4875  +    }
         4876  +  } else {
         4877  +    append cmd " $TCL(build_lib_spec)"
         4878  +    if {[$PROJECT define get static_tk]} {
         4879  +      append cmd  " $TK(build_lib_spec)"
         4880  +    }
         4881  +  }
         4882  +  foreach obj $PKG_OBJS {
         4883  +    append cmd " [$obj linker-products $config($obj)]"
         4884  +  }
         4885  +  set LIBS {}
         4886  +  foreach item $TCL(libs) {
         4887  +    if {[string range $item 0 1] eq "-l" && $item in $LIBS } continue
         4888  +    lappend LIBS $item
         4889  +  }
         4890  +  if {[$PROJECT define get static_tk]} {
         4891  +    foreach item $TK(libs) {
         4892  +      if {[string range $item 0 1] eq "-l" && $item in $LIBS } continue
         4893  +      lappend LIBS $item
         4894  +    }
         4895  +  }
         4896  +  if {[info exists TCL(extra_libs)]} {
         4897  +    foreach item $TCL(extra_libs) {
         4898  +      if {[string range $item 0 1] eq "-l" && $item in $LIBS } continue
         4899  +      lappend LIBS $item
         4900  +    }
         4901  +  }
         4902  +  foreach obj $PKG_OBJS {
         4903  +    puts [list Checking $obj for external dependencies]
         4904  +    foreach item [$obj linker-external $config($obj)] {
         4905  +      puts [list $obj adds $item]
         4906  +      if {[string range $item 0 1] eq "-l" && $item in $LIBS } continue
         4907  +      lappend LIBS $item
         4908  +    }
         4909  +  }
         4910  +  append cmd " ${LIBS}"
         4911  +  foreach obj $PKG_OBJS {
         4912  +    puts [list Checking $obj for additional link items]
         4913  +    foreach item [$obj linker-extra $config($obj)] {
         4914  +      append cmd $item
         4915  +    }
         4916  +  }
         4917  +  if {$debug && $os eq "windows"} {
         4918  +    append cmd " -L[file dirname $TCL(build_stub_lib_path)] ${TCL(stub_lib_flag)}"
         4919  +    if {[$PROJECT define get static_tk]} {
         4920  +      append cmd " -L[file dirname $TK(build_stub_lib_path)] ${TK(stub_lib_flag)}"
         4921  +    }
         4922  +  } else {
         4923  +    append cmd " $TCL(build_stub_lib_spec)"
         4924  +    if {[$PROJECT define get static_tk]} {
         4925  +      append cmd " $TK(build_stub_lib_spec)"
         4926  +    }
         4927  +  }
         4928  +  if {[info exists TCL(cc_search_flags)]} {
         4929  +    append cmd " $TCL(cc_search_flags)"
         4930  +  }
         4931  +  append cmd " -o $outfile "
         4932  +  if {$os eq "windows"} {
         4933  +    set LDFLAGS_CONSOLE {-mconsole -pipe -static-libgcc}
         4934  +    set LDFLAGS_WINDOW  {-mwindows -pipe -static-libgcc}
         4935  +    append cmd " $LDFLAGS_CONSOLE"
         4936  +  }
         4937  +  puts "LINK: $cmd"
         4938  +  exec {*}[string map [list "\n" " " "  " " "] $cmd] >&@ stdout
         4939  +}
         4940  +}
         4941  +
         4942  +###
         4943  +# END: class toolset gcc.tcl
         4944  +###
         4945  +###
         4946  +# START: class toolset msvc.tcl
         4947  +###
         4948  +::clay::define ::practcl::toolset.msvc {
         4949  +  superclass ::practcl::toolset
         4950  +  method BuildDir {PWD} {
         4951  +    set srcdir [my define get srcdir]
         4952  +    return $srcdir
         4953  +  }
         4954  +  Ensemble make::autodetect {} {
         4955  +  }
         4956  +  Ensemble make::clean {} {
         4957  +    set PWD [pwd]
         4958  +    set srcdir [my define get srcdir]
         4959  +    cd $srcdir
         4960  +    catch {::practcl::doexec nmake -f makefile.vc clean}
         4961  +    cd $PWD
         4962  +  }
         4963  +  Ensemble make::compile {} {
         4964  +    set srcdir [my define get srcdir]
         4965  +    if {[my define get static 1]} {
         4966  +      puts "BUILDING Static $name $srcdir"
         4967  +    } else {
         4968  +      puts "BUILDING Dynamic $name $srcdir"
         4969  +    }
         4970  +    cd $srcdir
         4971  +    if {[file exists [file join $srcdir make.tcl]]} {
         4972  +      if {[my define get debug 0]} {
         4973  +        ::practcl::domake.tcl $srcdir debug all
         4974  +      } else {
         4975  +        ::practcl::domake.tcl $srcdir all
         4976  +      }
         4977  +    } else {
         4978  +      if {[file exists [file join $srcdir makefile.vc]]} {
         4979  +        ::practcl::doexec nmake -f makefile.vc INSTALLDIR=[my <project> define get installdir]  {*}[my NmakeOpts] release
         4980  +      } elseif {[file exists [file join $srcdir win makefile.vc]]} {
         4981  +        cd [file join $srcdir win]
         4982  +        ::practcl::doexec nmake -f makefile.vc INSTALLDIR=[my <project> define get installdir]  {*}[my NmakeOpts] release
         4983  +      } else {
         4984  +        error "No make.tcl or makefile.vc found for project $name"
         4985  +      }
         4986  +    }
         4987  +  }
         4988  +  Ensemble make::install DEST {
         4989  +    set PWD [pwd]
         4990  +    set srcdir [my define get srcdir]
         4991  +    cd $srcdir
         4992  +    if {$DEST eq {}} {
         4993  +      error "No destination given"
         4994  +    }
         4995  +    if {[my <project> define get LOCAL 0] || $DEST eq {}} {
         4996  +      if {[file exists [file join $srcdir make.tcl]]} {
         4997  +        # Practcl builds can inject right to where we need them
         4998  +        puts "[self] Local Install (Practcl)"
         4999  +        ::practcl::domake.tcl $srcdir install
         5000  +      } else {
         5001  +        puts "[self] Local Install (Nmake)"
         5002  +        ::practcl::doexec nmake -f makefile.vc {*}[my NmakeOpts] install
         5003  +      }
         5004  +    } else {
         5005  +      if {[file exists [file join $srcdir make.tcl]]} {
         5006  +        # Practcl builds can inject right to where we need them
         5007  +        puts "[self] VFS INSTALL $DEST (Practcl)"
         5008  +        ::practcl::domake.tcl $srcdir install-package $DEST
         5009  +      } else {
         5010  +        puts "[self] VFS INSTALL $DEST"
         5011  +        ::practcl::doexec nmake -f makefile.vc INSTALLDIR=$DEST {*}[my NmakeOpts] install
         5012  +      }
         5013  +    }
         5014  +    cd $PWD
         5015  +  }
         5016  +  method MakeDir {srcdir} {
         5017  +    set localsrcdir $srcdir
         5018  +    if {[file exists [file join $srcdir generic]]} {
         5019  +      my define add include_dir [file join $srcdir generic]
         5020  +    }
         5021  +    if {[file exists [file join $srcdir win]]} {
         5022  +       my define add include_dir [file join $srcdir win]
         5023  +    }
         5024  +    if {[file exists [file join $srcdir makefile.vc]]} {
         5025  +      set localsrcdir [file join $srcdir win]
         5026  +    }
         5027  +    return $localsrcdir
         5028  +  }
         5029  +  method NmakeOpts {} {
         5030  +    set opts {}
         5031  +    set builddir [file normalize [my define get builddir]]
         5032  +
         5033  +    if {[my <project> define exists tclsrcdir]} {
         5034  +      ###
         5035  +      # On Windows we are probably running under MSYS, which doesn't deal with
         5036  +      # spaces in filename well
         5037  +      ###
         5038  +      set TCLSRCDIR  [::practcl::file_relative [file normalize $builddir] [file normalize [file join $::CWD [my <project> define get tclsrcdir] ..]]]
         5039  +      set TCLGENERIC [::practcl::file_relative [file normalize $builddir] [file normalize [file join $::CWD [my <project> define get tclsrcdir] .. generic]]]
         5040  +      lappend opts TCLDIR=[file normalize $TCLSRCDIR]
         5041  +      #--with-tclinclude=$TCLGENERIC
         5042  +    }
         5043  +    if {[my <project> define exists tksrcdir]} {
         5044  +      set TKSRCDIR  [::practcl::file_relative [file normalize $builddir] [file normalize [file join $::CWD [my <project> define get tksrcdir] ..]]]
         5045  +      set TKGENERIC [::practcl::file_relative [file normalize $builddir] [file normalize [file join $::CWD [my <project> define get tksrcdir] .. generic]]]
         5046  +      #lappend opts --with-tk=$TKSRCDIR --with-tkinclude=$TKGENERIC
         5047  +      lappend opts TKDIR=[file normalize $TKSRCDIR]
         5048  +    }
         5049  +    return $opts
         5050  +  }
         5051  +}
         5052  +
         5053  +###
         5054  +# END: class toolset msvc.tcl
         5055  +###
         5056  +###
         5057  +# START: class target.tcl
         5058  +###
         5059  +::clay::define ::practcl::make_obj {
         5060  +  superclass ::practcl::metaclass
         5061  +  constructor {module_object name info {action_body {}}} {
         5062  +    my variable define triggered domake
         5063  +    set triggered 0
         5064  +    set domake 0
         5065  +    set define(name) $name
         5066  +    set define(action) {}
         5067  +    array set define $info
         5068  +    my select
         5069  +    my initialize
         5070  +    foreach {stub obj} [$module_object child organs] {
         5071  +      my graft $stub $obj
         5072  +    }
         5073  +    if {$action_body ne {}} {
         5074  +      set define(action) $action_body
         5075  +    }
         5076  +  }
         5077  +  method do {} {
         5078  +    my variable domake
         5079  +    return $domake
         5080  +  }
         5081  +  method check {} {
         5082  +    my variable needs_make domake
         5083  +    if {$domake} {
         5084  +      return 1
         5085  +    }
         5086  +    if {[info exists needs_make]} {
         5087  +      return $needs_make
         5088  +    }
         5089  +    set make_objects [my <module> make objects]
         5090  +    set needs_make 0
         5091  +    foreach item [my define get depends] {
         5092  +      if {![dict exists $make_objects $item]} continue
         5093  +      set depobj [dict get $make_objects $item]
         5094  +      if {$depobj eq [self]} {
         5095  +        puts "WARNING [self] depends on itself"
         5096  +        continue
         5097  +      }
         5098  +      if {[$depobj check]} {
         5099  +        set needs_make 1
         5100  +      }
         5101  +    }
         5102  +    if {!$needs_make} {
         5103  +      foreach filename [my output] {
         5104  +        if {$filename ne {} && ![file exists $filename]} {
         5105  +          set needs_make 1
         5106  +        }
         5107  +      }
         5108  +    }
         5109  +    return $needs_make
         5110  +  }
         5111  +  method output {} {
         5112  +    set result {}
         5113  +    set filename [my define get filename]
         5114  +    if {$filename ne {}} {
         5115  +      lappend result $filename
         5116  +    }
         5117  +    foreach filename [my define get files] {
         5118  +      if {$filename ne {}} {
         5119  +        lappend result $filename
         5120  +      }
         5121  +    }
         5122  +    return $result
         5123  +  }
         5124  +  method reset {} {
         5125  +    my variable triggered domake needs_make
         5126  +    set triggerd 0
         5127  +    set domake 0
         5128  +    set needs_make 0
         5129  +  }
         5130  +  method triggers {} {
         5131  +    my variable triggered domake define
         5132  +    if {$triggered} {
         5133  +      return $domake
         5134  +    }
         5135  +    set triggered 1
         5136  +    set make_objects [my <module> make objects]
         5137  +
         5138  +    foreach item [my define get depends] {
         5139  +      if {![dict exists $make_objects $item]} continue
         5140  +      set depobj [dict get $make_objects $item]
         5141  +      if {$depobj eq [self]} {
         5142  +        puts "WARNING [self] triggers itself"
         5143  +        continue
         5144  +      } else {
         5145  +        set r [$depobj check]
         5146  +        if {$r} {
         5147  +          $depobj triggers
         5148  +        }
         5149  +      }
         5150  +    }
         5151  +    set domake 1
         5152  +    my <module> make trigger {*}[my define get triggers]
         5153  +  }
         5154  +}
         5155  +