TEA (tclconfig) Source Code

Check-in [3785abe658]
Login
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2018 Conference, Houston/TX, US, Oct 15-19
Send your abstracts to tclconference@googlegroups.com
or submit via the online form by Aug 20.

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

Overview
Comment:New version of practcl.tcl from tcllib.

New version of the tclZipfs.c file. Now an identical file is checked into set core itself.

Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | practcl
Files: files | file ages | folders
SHA3-256:3785abe65886471e7fbb566d5b8d96130302007bc9fe551292b2a95917e3c8c7
User & Date: hypnotoad 2018-01-16 23:27:26
Context
2018-01-17
00:22
Separated the indexing of zip contents from the opening of the zip file stream check-in: af56cbe24a user: hypnotoad tags: practcl
2018-01-16
23:27
New version of practcl.tcl from tcllib.

New version of the tclZipfs.c file. Now an identical file is checked into set core itself. check-in: 3785abe658 user: hypnotoad tags: practcl

2018-01-11
19:38
Updated practcl from tcllib check-in: f6a89ef414 user: hypnotoad tags: practcl
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to compat/tclZipfs.c.

6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
..
34
35
36
37
38
39
40

41










42
43

44
45
46
47
48

49
50
51
52
53
54
55
...
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
...
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
...
307
308
309
310
311
312
313
314



































































315
316
317
318
319
320
321
....
1042
1043
1044
1045
1046
1047
1048



















1049
1050
1051
1052
1053
1054
1055
....
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
....
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
....
2586
2587
2588
2589
2590
2591
2592






















































2593
2594
2595
2596
2597
2598
2599
....
3927
3928
3929
3930
3931
3932
3933

3934
3935
3936
3937
3938
3939
3940
3941
3942
3943
3944
3945
3946
3947
3948
3949
3950
3951
3952
3953
3954
3955
3956
3957
3958
3959
3960
3961
3962
3963
3964
3965
3966
3967
3968
3969
3970
3971
3972
3973
3974
3975
3976
3977
3978
3979
3980
3981
3982
3983
....
3992
3993
3994
3995
3996
3997
3998

3999
4000
4001
4002
4003
4004
4005
4006
4007
4008
4009
4010
4011
4012
4013
4014
4015
4016
4017
4018
4019
4020
4021
....
4121
4122
4123
4124
4125
4126
4127
4128
4129
4130
4131
4132
4133
4134
4135
....
4194
4195
4196
4197
4198
4199
4200
4201
4202
4203
4204
4205
4206
4207
4208
4209
4210
4211
4212
4213
4214
4215
4216
4217
4218
4219
4220
4221
4222
4223
4224
4225
4226
4227
4228
4229
4230
4231
4232
4233
4234
4235
4236
4237
4238
4239
4240
4241
4242
4243
4244
4245
 *
 * Coptright (c) 2016-2017 Sean Woods <yoda@etoyoc.com>
 * Copyright (c) 2013-2015 Christian Werner <chw@ch-werner.de>
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * This file is almost verbatim to the implementation from the tcl core
 * The prefix is modified because certain bug fixes for unc paths are not in
 * for a core that requires this file
 */

#include "tclInt.h"
#include "tclFileSystem.h"

#if !defined(_WIN32) && !defined(_WIN64)
#include <sys/mman.h>
................................................................................
#define MAP_FILE 0
#endif

#ifdef HAVE_ZLIB
#include "zlib.h"
#include "crypt.h"


/*










** Pre TIP430 style zipfs prefix
** //zipfs:/ doesn't work straight out of the box on either windows or Unix

*/
#define ZIPFS_VOLUME      "zipfs:/"
#define ZIPFS_VOLUME_LEN  7
#define ZIPFS_APP_MOUNT   "zipfs:/app"
#define ZIPFS_ZIP_MOUNT   "zipfs:/lib/tcl"

/*
 * Various constants and offsets found in ZIP archive files
 */

#define ZIP_SIG_LEN                     4

/* Local header of ZIP archive member (at very beginning of each member). */
................................................................................
typedef struct ZipFile {
    char *name;               /* Archive name */
    Tcl_Channel chan;         /* Channel handle or NULL */
    unsigned char *data;      /* Memory mapped or malloc'ed file */
    long length;              /* Length of memory mapped file */
    unsigned char *tofree;    /* Non-NULL if malloc'ed file */
    int nfiles;               /* Number of files in archive */
    int baseoffs;             /* Archive start */
    int baseoffsp;            /* Password start */
    int centoffs;             /* Archive directory start */
    char pwbuf[264];          /* Password buffer */
#if defined(_WIN32) || defined(_WIN64)
    HANDLE mh;
#endif
    int nopen;                /* Number of open files on archive */
    struct ZipEntry *entries; /* List of files in archive */
    struct ZipEntry *topents; /* List of top-level dirs in archive */
#if HAS_DRIVES
    int mntdrv;                  /* Drive letter of mount point */
#endif
    int mntptlen;             /* Length of mount point */
    char mntpt[1];            /* Mount point */
................................................................................
    0x10, 0x90, 0x50, 0xd0, 0x30, 0xb0, 0x70, 0xf0
};

/*
 * Table to compute CRC32.
 */

static const unsigned long crc32tab[256] = {
    0x00000000, 0x77073096, 0xee0e612c, 0x990951ba, 0x076dc419,
    0x706af48f, 0xe963a535, 0x9e6495a3, 0x0edb8832, 0x79dcb8a4,
    0xe0d5e91e, 0x97d2d988, 0x09b64c2b, 0x7eb17cbd, 0xe7b82d07,
    0x90bf1d91, 0x1db71064, 0x6ab020f2, 0xf3b97148, 0x84be41de,
    0x1adad47d, 0x6ddde4eb, 0xf4d4b551, 0x83d385c7, 0x136c9856,
    0x646ba8c0, 0xfd62f97a, 0x8a65c9ec, 0x14015c4f, 0x63066cd9,
    0xfa0f3d63, 0x8d080df5, 0x3b6e20c8, 0x4c69105e, 0xd56041e4,
................................................................................
    0xcdd70693, 0x54de5729, 0x23d967bf, 0xb3667a2e, 0xc4614ab8,
    0x5d681b02, 0x2a6f2b94, 0xb40bbe37, 0xc30c8ea1, 0x5a05df1b,
    0x2d02ef8d,
};

const char *zipfs_literal_tcl_library=NULL;

Tcl_Obj *TclZipfs_TclLibrary(void);




































































 
/*
 *-------------------------------------------------------------------------
 *
 * ReadLock, WriteLock, Unlock --
 *
................................................................................
    }
    return TCL_OK;

error:
    ZipFSCloseArchive(interp, zf);
    return TCL_ERROR;
}



















 
/*
 *-------------------------------------------------------------------------
 *
 * TclZipfs_Mount --
 *
 *      This procedure is invoked to mount a given ZIP archive file on
................................................................................
    unsigned char *q;
#if HAS_DRIVES
    int drive = 0;
#endif

    ReadLock();
    if (!ZipFS.initialized) {
        ZIPFS_ERROR(interp,"not initialized");
        Unlock();
        return TCL_ERROR;
    }
    if (zipname == NULL) {
        Tcl_HashSearch search;
        int ret = TCL_OK;

        i = 0;
        hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search);
................................................................................
    if (Tcl_Write(out, buf, len) != len) {
wrerr:
    Tcl_AppendResult(interp, "write error", (char *) NULL);
    Tcl_Close(interp, in);
    return TCL_ERROR;
    }
    if ((len + pos[0]) & 3) {
        char abuf[8];

        /*
         * Align payload to next 4-byte boundary using a dummy extra
         * entry similar to the zipalign tool from Android's SDK.
         */
        align = 4 + ((len + pos[0]) & 3);
        zip_write_short(abuf, 0xffff);
        zip_write_short(abuf + 2, align - 4);
        zip_write_int(abuf + 4, 0x03020100);
        if (Tcl_Write(out, abuf, align) != align) {
            goto wrerr;
        }
    }
    if (passwd != NULL) {
        int i, ch, tmp;
        unsigned char kvbuf[24];
        Tcl_Obj *ret;
................................................................................
            Tcl_ListObjAppendElement(interp, result, Tcl_NewStringObj(z->name, -1));
        }
    }
    Unlock();
    return TCL_OK;
}























































/*
 *-------------------------------------------------------------------------
 *
 * ZipFSTclLibraryObjCmd --
 *
 *      This procedure is invoked to process the "zipfs::root" command. It
 *      returns the root that all zipfs file systems are mounted under.
................................................................................
    if (altPath != NULL) {
        Tcl_DecrRefCount(altPath);
    }
    return ret;
#endif
}


 
/*
 * Define the ZIP filesystem dispatch table.
 */

MODULE_SCOPE const Tcl_Filesystem zipfsFilesystem;

const Tcl_Filesystem zipfsFilesystem = {
    "zipfs",
    sizeof (Tcl_Filesystem),
    TCL_FILESYSTEM_VERSION_2,
    Zip_FSPathInFilesystemProc,
    NULL, /* dupInternalRepProc */
    NULL, /* freeInternalRepProc */
    NULL, /* internalToNormalizedProc */
    NULL, /* createInternalRepProc */
    NULL, /* normalizePathProc */
    Zip_FSFilesystemPathTypeProc,
    Zip_FSFilesystemSeparatorProc,
    Zip_FSStatProc,
    Zip_FSAccessProc,
    Zip_FSOpenFileChannelProc,
    Zip_FSMatchInDirectoryProc,
    NULL, /* utimeProc */
    NULL, /* linkProc */
    Zip_FSListVolumesProc,
    Zip_FSFileAttrStringsProc,
    Zip_FSFileAttrsGetProc,
    Zip_FSFileAttrsSetProc,
    NULL, /* createDirectoryProc */
    NULL, /* removeDirectoryProc */
    NULL, /* deleteFileProc */
    NULL, /* copyFileProc */
    NULL, /* renameFileProc */
    NULL, /* copyDirectoryProc */
    NULL, /* lstatProc */
    (Tcl_FSLoadFileProc *) Zip_FSLoadFile,
    NULL, /* getCwdProc */
    NULL, /* chdirProc*/
};

#endif /* HAVE_ZLIB */
 
/*
 *-------------------------------------------------------------------------
 *
 * TclZipfs_Init --
 *
 *    Perform per interpreter initialization of this module.
 *
................................................................................
 */

MODULE_SCOPE int
TclZipfs_Init(Tcl_Interp *interp)
{
#ifdef HAVE_ZLIB
    /* one-time initialization */

    Tcl_StaticPackage(interp, "zipfs", TclZipfs_Init, TclZipfs_Init);
    if (!ZipFS.initialized) {
    WriteLock();
#ifdef TCL_THREADS
    static const Tcl_Time t = { 0, 0 };
    /*
     * Inflate condition variable.
     */
    Tcl_MutexLock(&ZipFSMutex);
    Tcl_ConditionWait(&ZipFSCond, &ZipFSMutex, &t);
    Tcl_MutexUnlock(&ZipFSMutex);
#endif
    Tcl_FSRegister(NULL, &zipfsFilesystem);
    Tcl_InitHashTable(&ZipFS.fileHash, TCL_STRING_KEYS);
    Tcl_InitHashTable(&ZipFS.zipHash, TCL_STRING_KEYS);
    ZipFS.initialized = ZipFS.idCount = 1;
    }
    Unlock();
    if(interp != NULL) {
        static const EnsembleImplMap initMap[] = {
            {"mount",      ZipFSMountObjCmd,    NULL, NULL, NULL, 0},
            {"unmount",      ZipFSUnmountObjCmd,    NULL, NULL, NULL, 0},
            {"mkkey",      ZipFSMkKeyObjCmd,    NULL, NULL, NULL, 0},
................................................................................
    /*
     * Tclkit_MainHook --
     * Performs the argument munging for the shell
     */
    char *archive;

    Tcl_FindExecutable(*argv[0]);
    archive=Tcl_GetNameOfExecutable();
    TclZipfs_Init(NULL);
    /*
    ** Look for init.tcl in one of the locations mounted later in this function
    */
    if(!TclZipfs_Mount(NULL, archive, ZIPFS_APP_MOUNT, NULL)) {
        int found;
        Tcl_Obj *vfsinitscript;
................................................................................
                }
            }
        }
    }
    return TCL_OK;
}

Tcl_Obj *TclZipfs_TclLibrary(void) {
    if(zipfs_literal_tcl_library) {
        return Tcl_NewStringObj(zipfs_literal_tcl_library,-1);
    } else {
#if defined(_WIN32) || defined(_WIN64)
        HMODULE hModule = TclWinGetTclInstance();
        WCHAR wName[MAX_PATH + LIBRARY_SIZE];
        char dllname[(MAX_PATH + LIBRARY_SIZE) * TCL_UTF_MAX];

        if (GetModuleFileNameW(hModule, wName, MAX_PATH) == 0) {
            GetModuleFileNameA(hModule, dllname, MAX_PATH);
        } else {
            ToUtf(wName, dllname);
        }
        /* Mount zip file and dll before releasing to search */
        if(TclZipfs_AppHook_FindTclInit(dllname)==TCL_OK) {
            return Tcl_NewStringObj(zipfs_literal_tcl_library,-1);
        }
#else
#ifdef CFG_RUNTIME_LIBDIR
        /* Mount zip file and dll before releasing to search */
        if(TclZipfs_AppHook_FindTclInit(CFG_RUNTIME_LIBDIR "/" CFG_RUNTIME_DLLFILE)==TCL_OK) {
            return Tcl_NewStringObj(zipfs_literal_tcl_library,-1);
        }
        if(TclZipfs_AppHook_FindTclInit(CFG_RUNTIME_LIBDIR "/" CFG_RUNTIME_ZIPFILE)==TCL_OK) {
            return Tcl_NewStringObj(zipfs_literal_tcl_library,-1);
        }
        if(TclZipfs_AppHook_FindTclInit(CFG_RUNTIME_SCRDIR "/" CFG_RUNTIME_ZIPFILE)==TCL_OK) {
            return Tcl_NewStringObj(zipfs_literal_tcl_library,-1);
        }
#endif
#endif
    }
    if(zipfs_literal_tcl_library) {
        return Tcl_NewStringObj(zipfs_literal_tcl_library,-1);
    }
    return NULL;
}
 

#ifndef HAVE_ZLIB
 
/*
 *-------------------------------------------------------------------------
 *







|
|
|







 







>

>
>
>
>
>
>
>
>
>
>


>





>







 







|
|
|
|



|







 







|







 







|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







 







|
<
<







 







|









|







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







 







>
|
<
<
<
|
<

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<







 







>
|

<
|
<
<
<
<
<
<
<
<
<
<
<
<







 







|







 







<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<







6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
..
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
...
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
...
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
...
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
....
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
....
1179
1180
1181
1182
1183
1184
1185
1186


1187
1188
1189
1190
1191
1192
1193
....
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
....
2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
2700
2701
2702
2703
2704
2705
2706
2707
2708
2709
2710
2711
2712
2713
2714
2715
2716
2717
2718
2719
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
2746
2747
2748
2749
2750
....
4078
4079
4080
4081
4082
4083
4084
4085
4086



4087

4088




































4089
4090
4091
4092
4093
4094
4095
....
4104
4105
4106
4107
4108
4109
4110
4111
4112
4113

4114












4115
4116
4117
4118
4119
4120
4121
....
4221
4222
4223
4224
4225
4226
4227
4228
4229
4230
4231
4232
4233
4234
4235
....
4294
4295
4296
4297
4298
4299
4300






































4301
4302
4303
4304
4305
4306
4307
 *
 * Coptright (c) 2016-2017 Sean Woods <yoda@etoyoc.com>
 * Copyright (c) 2013-2015 Christian Werner <chw@ch-werner.de>
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * This file is distributed in two ways:
 *   generic/tclZipfs.c file in the TIP430 enabled tcl cores
 *   compat/tclZipfs.c file in the tclconfig (TEA) file system, for pre-tip430 projects
 */

#include "tclInt.h"
#include "tclFileSystem.h"

#if !defined(_WIN32) && !defined(_WIN64)
#include <sys/mman.h>
................................................................................
#define MAP_FILE 0
#endif

#ifdef HAVE_ZLIB
#include "zlib.h"
#include "crypt.h"

#ifdef CFG_RUNTIME_DLLFILE
/*
** We are compiling as part of the core.
** TIP430 style zipfs prefix
*/
#define ZIPFS_VOLUME      "//zipfs:/"
#define ZIPFS_VOLUME_LEN  9
#define ZIPFS_APP_MOUNT   "//zipfs:/app"
#define ZIPFS_ZIP_MOUNT   "//zipfs:/lib/tcl"
#else
/*
** We are compiling from the /compat folder of tclconfig
** Pre TIP430 style zipfs prefix
** //zipfs:/ doesn't work straight out of the box on either windows or Unix
** without other changes made to tip 430
*/
#define ZIPFS_VOLUME      "zipfs:/"
#define ZIPFS_VOLUME_LEN  7
#define ZIPFS_APP_MOUNT   "zipfs:/app"
#define ZIPFS_ZIP_MOUNT   "zipfs:/lib/tcl"
#endif
/*
 * Various constants and offsets found in ZIP archive files
 */

#define ZIP_SIG_LEN                     4

/* Local header of ZIP archive member (at very beginning of each member). */
................................................................................
typedef struct ZipFile {
    char *name;               /* Archive name */
    Tcl_Channel chan;         /* Channel handle or NULL */
    unsigned char *data;      /* Memory mapped or malloc'ed file */
    long length;              /* Length of memory mapped file */
    unsigned char *tofree;    /* Non-NULL if malloc'ed file */
    int nfiles;               /* Number of files in archive */
    unsigned long baseoffs;             /* Archive start */
    long baseoffsp;            /* Password start */
    unsigned long centoffs;             /* Archive directory start */
    unsigned char pwbuf[264];          /* Password buffer */
#if defined(_WIN32) || defined(_WIN64)
    HANDLE mh;
#endif
    unsigned long nopen;                /* Number of open files on archive */
    struct ZipEntry *entries; /* List of files in archive */
    struct ZipEntry *topents; /* List of top-level dirs in archive */
#if HAS_DRIVES
    int mntdrv;                  /* Drive letter of mount point */
#endif
    int mntptlen;             /* Length of mount point */
    char mntpt[1];            /* Mount point */
................................................................................
    0x10, 0x90, 0x50, 0xd0, 0x30, 0xb0, 0x70, 0xf0
};

/*
 * Table to compute CRC32.
 */

static const z_crc_t crc32tab[256] = {
    0x00000000, 0x77073096, 0xee0e612c, 0x990951ba, 0x076dc419,
    0x706af48f, 0xe963a535, 0x9e6495a3, 0x0edb8832, 0x79dcb8a4,
    0xe0d5e91e, 0x97d2d988, 0x09b64c2b, 0x7eb17cbd, 0xe7b82d07,
    0x90bf1d91, 0x1db71064, 0x6ab020f2, 0xf3b97148, 0x84be41de,
    0x1adad47d, 0x6ddde4eb, 0xf4d4b551, 0x83d385c7, 0x136c9856,
    0x646ba8c0, 0xfd62f97a, 0x8a65c9ec, 0x14015c4f, 0x63066cd9,
    0xfa0f3d63, 0x8d080df5, 0x3b6e20c8, 0x4c69105e, 0xd56041e4,
................................................................................
    0xcdd70693, 0x54de5729, 0x23d967bf, 0xb3667a2e, 0xc4614ab8,
    0x5d681b02, 0x2a6f2b94, 0xb40bbe37, 0xc30c8ea1, 0x5a05df1b,
    0x2d02ef8d,
};

const char *zipfs_literal_tcl_library=NULL;

/* Function prototypes */
int TclZipfs_Mount(Tcl_Interp *interp, const char *zipname, const char *mntpt,const char *passwd);
static int TclZipfs_AppHook_FindTclInit(const char *archive);
static int Zip_FSPathInFilesystemProc(Tcl_Obj *pathPtr, ClientData *clientDataPtr);
static Tcl_Obj *Zip_FSFilesystemPathTypeProc(Tcl_Obj *pathPtr);
static Tcl_Obj *Zip_FSFilesystemSeparatorProc(Tcl_Obj *pathPtr);
static int Zip_FSStatProc(Tcl_Obj *pathPtr, Tcl_StatBuf *buf);
static int Zip_FSAccessProc(Tcl_Obj *pathPtr, int mode);
static Tcl_Channel Zip_FSOpenFileChannelProc(
    Tcl_Interp *interp, Tcl_Obj *pathPtr,
    int mode, int permissions
);
static int Zip_FSMatchInDirectoryProc(
    Tcl_Interp* interp, Tcl_Obj *result,
    Tcl_Obj *pathPtr, const char *pattern,
    Tcl_GlobTypeData *types
);
static Tcl_Obj *Zip_FSListVolumesProc(void);
static const char *const *Zip_FSFileAttrStringsProc(Tcl_Obj *pathPtr, Tcl_Obj** objPtrRef);
static int Zip_FSFileAttrsGetProc(
    Tcl_Interp *interp, int index, Tcl_Obj *pathPtr,
    Tcl_Obj **objPtrRef
);
static int Zip_FSFileAttrsSetProc(Tcl_Interp *interp, int index, Tcl_Obj *pathPtr,Tcl_Obj *objPtr);
static int Zip_FSLoadFile(Tcl_Interp *interp, Tcl_Obj *path, Tcl_LoadHandle *loadHandle,
               Tcl_FSUnloadFileProc **unloadProcPtr, int flags);
static void TclZipfs_C_Init(void);

/*
 * Define the ZIP filesystem dispatch table.
 */

MODULE_SCOPE const Tcl_Filesystem zipfsFilesystem;

const Tcl_Filesystem zipfsFilesystem = {
    "zipfs",
    sizeof (Tcl_Filesystem),
    TCL_FILESYSTEM_VERSION_2,
    Zip_FSPathInFilesystemProc,
    NULL, /* dupInternalRepProc */
    NULL, /* freeInternalRepProc */
    NULL, /* internalToNormalizedProc */
    NULL, /* createInternalRepProc */
    NULL, /* normalizePathProc */
    Zip_FSFilesystemPathTypeProc,
    Zip_FSFilesystemSeparatorProc,
    Zip_FSStatProc,
    Zip_FSAccessProc,
    Zip_FSOpenFileChannelProc,
    Zip_FSMatchInDirectoryProc,
    NULL, /* utimeProc */
    NULL, /* linkProc */
    Zip_FSListVolumesProc,
    Zip_FSFileAttrStringsProc,
    Zip_FSFileAttrsGetProc,
    Zip_FSFileAttrsSetProc,
    NULL, /* createDirectoryProc */
    NULL, /* removeDirectoryProc */
    NULL, /* deleteFileProc */
    NULL, /* copyFileProc */
    NULL, /* renameFileProc */
    NULL, /* copyDirectoryProc */
    NULL, /* lstatProc */
    (Tcl_FSLoadFileProc *) Zip_FSLoadFile,
    NULL, /* getCwdProc */
    NULL, /* chdirProc*/
};


 
/*
 *-------------------------------------------------------------------------
 *
 * ReadLock, WriteLock, Unlock --
 *
................................................................................
    }
    return TCL_OK;

error:
    ZipFSCloseArchive(interp, zf);
    return TCL_ERROR;
}

static void TclZipfs_C_Init(void) {
    static const Tcl_Time t = { 0, 0 };
    if (!ZipFS.initialized) {
#ifdef TCL_THREADS
        /*
         * Inflate condition variable.
         */
        Tcl_MutexLock(&ZipFSMutex);
        Tcl_ConditionWait(&ZipFSCond, &ZipFSMutex, &t);
        Tcl_MutexUnlock(&ZipFSMutex);
#endif
        Tcl_FSRegister(NULL, &zipfsFilesystem);
        Tcl_InitHashTable(&ZipFS.fileHash, TCL_STRING_KEYS);
        Tcl_InitHashTable(&ZipFS.zipHash, TCL_STRING_KEYS);
        ZipFS.initialized = ZipFS.idCount = 1;
    }
}

 
/*
 *-------------------------------------------------------------------------
 *
 * TclZipfs_Mount --
 *
 *      This procedure is invoked to mount a given ZIP archive file on
................................................................................
    unsigned char *q;
#if HAS_DRIVES
    int drive = 0;
#endif

    ReadLock();
    if (!ZipFS.initialized) {
        TclZipfs_C_Init();


    }
    if (zipname == NULL) {
        Tcl_HashSearch search;
        int ret = TCL_OK;

        i = 0;
        hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search);
................................................................................
    if (Tcl_Write(out, buf, len) != len) {
wrerr:
    Tcl_AppendResult(interp, "write error", (char *) NULL);
    Tcl_Close(interp, in);
    return TCL_ERROR;
    }
    if ((len + pos[0]) & 3) {
        unsigned char abuf[8];

        /*
         * Align payload to next 4-byte boundary using a dummy extra
         * entry similar to the zipalign tool from Android's SDK.
         */
        align = 4 + ((len + pos[0]) & 3);
        zip_write_short(abuf, 0xffff);
        zip_write_short(abuf + 2, align - 4);
        zip_write_int(abuf + 4, 0x03020100);
        if (Tcl_Write(out, (const char *)abuf, align) != align) {
            goto wrerr;
        }
    }
    if (passwd != NULL) {
        int i, ch, tmp;
        unsigned char kvbuf[24];
        Tcl_Obj *ret;
................................................................................
            Tcl_ListObjAppendElement(interp, result, Tcl_NewStringObj(z->name, -1));
        }
    }
    Unlock();
    return TCL_OK;
}


Tcl_Obj *TclZipfs_TclLibrary(void) {
    if(zipfs_literal_tcl_library) {
        return Tcl_NewStringObj(zipfs_literal_tcl_library,-1);
    } else {
        Tcl_Obj *vfsinitscript;
        int found=0;
        
        /* Look for the library file system within the executable */
        vfsinitscript=Tcl_NewStringObj(ZIPFS_APP_MOUNT "/tcl_library/init.tcl",-1);
        Tcl_IncrRefCount(vfsinitscript);
        found=Tcl_FSAccess(vfsinitscript,F_OK);
        Tcl_DecrRefCount(vfsinitscript);
        if(found==TCL_OK) {
            zipfs_literal_tcl_library=ZIPFS_APP_MOUNT "/tcl_library";
            return Tcl_NewStringObj(zipfs_literal_tcl_library,-1);
        }
#if defined(_WIN32) || defined(_WIN64)
        HMODULE hModule = TclWinGetTclInstance();
        WCHAR wName[MAX_PATH + LIBRARY_SIZE];
        char dllname[(MAX_PATH + LIBRARY_SIZE) * TCL_UTF_MAX];

        if (GetModuleFileNameW(hModule, wName, MAX_PATH) == 0) {
            GetModuleFileNameA(hModule, dllname, MAX_PATH);
        } else {
            ToUtf(wName, dllname);
        }
        /* Mount zip file and dll before releasing to search */
        if(TclZipfs_AppHook_FindTclInit(dllname)==TCL_OK) {
            return Tcl_NewStringObj(zipfs_literal_tcl_library,-1);
        }
#else
#ifdef CFG_RUNTIME_DLLFILE
        /* Mount zip file and dll before releasing to search */
        if(TclZipfs_AppHook_FindTclInit(CFG_RUNTIME_LIBDIR "/" CFG_RUNTIME_DLLFILE)==TCL_OK) {
            return Tcl_NewStringObj(zipfs_literal_tcl_library,-1);
        }
#endif
#endif
#ifdef CFG_RUNTIME_ZIPFILE
        if(TclZipfs_AppHook_FindTclInit(CFG_RUNTIME_LIBDIR "/" CFG_RUNTIME_ZIPFILE)==TCL_OK) {
            return Tcl_NewStringObj(zipfs_literal_tcl_library,-1);
        }
        if(TclZipfs_AppHook_FindTclInit(CFG_RUNTIME_SCRDIR "/" CFG_RUNTIME_ZIPFILE)==TCL_OK) {
            return Tcl_NewStringObj(zipfs_literal_tcl_library,-1);
        }
#endif
    }
    if(zipfs_literal_tcl_library) {
        return Tcl_NewStringObj(zipfs_literal_tcl_library,-1);
    }
    return NULL;
}

/*
 *-------------------------------------------------------------------------
 *
 * ZipFSTclLibraryObjCmd --
 *
 *      This procedure is invoked to process the "zipfs::root" command. It
 *      returns the root that all zipfs file systems are mounted under.
................................................................................
    if (altPath != NULL) {
        Tcl_DecrRefCount(altPath);
    }
    return ret;
#endif
}

#endif /* HAVE_ZLIB */




 






































/*
 *-------------------------------------------------------------------------
 *
 * TclZipfs_Init --
 *
 *    Perform per interpreter initialization of this module.
 *
................................................................................
 */

MODULE_SCOPE int
TclZipfs_Init(Tcl_Interp *interp)
{
#ifdef HAVE_ZLIB
    /* one-time initialization */
    WriteLock();
    /* Tcl_StaticPackage(interp, "zipfs", TclZipfs_Init, TclZipfs_Init); */
    if (!ZipFS.initialized) {

        TclZipfs_C_Init();












    }
    Unlock();
    if(interp != NULL) {
        static const EnsembleImplMap initMap[] = {
            {"mount",      ZipFSMountObjCmd,    NULL, NULL, NULL, 0},
            {"unmount",      ZipFSUnmountObjCmd,    NULL, NULL, NULL, 0},
            {"mkkey",      ZipFSMkKeyObjCmd,    NULL, NULL, NULL, 0},
................................................................................
    /*
     * Tclkit_MainHook --
     * Performs the argument munging for the shell
     */
    char *archive;

    Tcl_FindExecutable(*argv[0]);
    archive=(char *)Tcl_GetNameOfExecutable();
    TclZipfs_Init(NULL);
    /*
    ** Look for init.tcl in one of the locations mounted later in this function
    */
    if(!TclZipfs_Mount(NULL, archive, ZIPFS_APP_MOUNT, NULL)) {
        int found;
        Tcl_Obj *vfsinitscript;
................................................................................
                }
            }
        }
    }
    return TCL_OK;
}







































 

#ifndef HAVE_ZLIB
 
/*
 *-------------------------------------------------------------------------
 *

Changes to practcl.tcl.

5450
5451
5452
5453
5454
5455
5456
5457
5458
5459
5460
5461
5462
5463
5464
....
5824
5825
5826
5827
5828
5829
5830
5831
5832
5833
5834
5835
5836
5837
5838
5839
5840
5841
5842

5843
5844
5845
5846
5847
5848
5849

  method clean {} {
    set builddir [file normalize [my define get builddir]]
    if {![file exists $builddir]} return
    if {[file exists [file join $builddir make.tcl]]} {
      ::practcl::domake.tcl $builddir clean
    } else {
      ::practcl::domake $builddir clean
    }
  }

 method env-install {} {
    ###
    # Handle tea installs
    ###
................................................................................
  }

  method env-install {} {
    my unpack
    set os [::practcl::local_os]
    switch [my define get name] {
      tcl {
        set options [::practcl::platform::tcl_core_options $os]
      }
      tk {
        set options [::practcl::platform::tk_core_options $os]
      }
      default {
        set options {}
      }
    }
    set prefix [my <project> define get prefix [file normalize [file join ~ tcl]]]
    lappend options --prefix $prefix --exec-prefix $prefix
    my define set config_opts $options

    my go
    my compile
    ::practcl::domake [my define get builddir] install
  }

  method go {} {
    set name [my define get name]







|







 







|


|








>







5450
5451
5452
5453
5454
5455
5456
5457
5458
5459
5460
5461
5462
5463
5464
....
5824
5825
5826
5827
5828
5829
5830
5831
5832
5833
5834
5835
5836
5837
5838
5839
5840
5841
5842
5843
5844
5845
5846
5847
5848
5849
5850

  method clean {} {
    set builddir [file normalize [my define get builddir]]
    if {![file exists $builddir]} return
    if {[file exists [file join $builddir make.tcl]]} {
      ::practcl::domake.tcl $builddir clean
    } else {
      catch {::practcl::domake $builddir clean}
    }
  }

 method env-install {} {
    ###
    # Handle tea installs
    ###
................................................................................
  }

  method env-install {} {
    my unpack
    set os [::practcl::local_os]
    switch [my define get name] {
      tcl {
        set options [::practcl::platform::tcl_core_options [dict get $os TEACUP_OS]]
      }
      tk {
        set options [::practcl::platform::tk_core_options  [dict get $os TEACUP_OS]]
      }
      default {
        set options {}
      }
    }
    set prefix [my <project> define get prefix [file normalize [file join ~ tcl]]]
    lappend options --prefix $prefix --exec-prefix $prefix
    my define set config_opts $options
    puts [list [self] OS [dict get $os TEACUP_OS] options $options]
    my go
    my compile
    ::practcl::domake [my define get builddir] install
  }

  method go {} {
    set name [my define get name]