Index: .project ================================================================== --- .project +++ .project @@ -1,8 +1,8 @@ - tcl8.7 + tcl8 DELETED compat/float.h Index: compat/float.h ================================================================== --- compat/float.h +++ /dev/null @@ -1,14 +0,0 @@ -/* - * float.h -- - * - * This is a dummy header file to #include in Tcl when there - * is no float.h in /usr/include. Right now this file is empty: - * Tcl contains #ifdefs to deal with the lack of definitions; - * all it needs is for the #include statement to work. - * - * Copyright (c) 1993 The Regents of the University of California. - * Copyright (c) 1994 Sun Microsystems, Inc. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - */ Index: doc/Object.3 ================================================================== --- doc/Object.3 +++ doc/Object.3 @@ -255,11 +255,11 @@ .PP The \fBincr\fR command first gets an integer from \fIx\fR's value by calling \fBTcl_GetIntFromObj\fR. This procedure checks whether the value is already an integer value. Since it is not, it converts the value -by setting the value's \fIinternalRep.longValue\fR member +by setting the value's internal representation to the integer \fB123\fR and setting the value's \fItypePtr\fR to point to the integer Tcl_ObjType structure. Both representations are now valid. \fBincr\fR increments the value's integer internal representation Index: doc/SaveResult.3 ================================================================== --- doc/SaveResult.3 +++ doc/SaveResult.3 @@ -52,13 +52,13 @@ state is to be restored. So long as one of the latter two routines is called, Tcl will take care of memory management. .PP The second triplet stores the snapshot of only the interpreter result (not its complete state) in memory allocated by the caller. -These routines are passed a pointer to a \fBTcl_SavedResult\fR structure +These routines are passed a pointer to \fBTcl_SavedResult\fR that is used to store enough information to restore the interpreter result. -This structure can be allocated on the stack of the calling +\fBTcl_SavedResult\fR can be allocated on the stack of the calling procedure. These routines do not save the state of any error information in the interpreter (e.g. the \fB\-errorcode\fR or \fB\-errorinfo\fR return options, when an error is in progress). .PP Because the routines \fBTcl_SaveInterpState\fR, Index: doc/tclsh.1 ================================================================== --- doc/tclsh.1 +++ doc/tclsh.1 @@ -141,9 +141,18 @@ if \fBtcl_prompt2\fR is not set then no prompt is output for incomplete commands. .SH "STANDARD CHANNELS" .PP See \fBTcl_StandardChannels\fR for more explanations. +.SH ZIPVFS +.PP +When a zipfile is concatenated to the end of a \fBtclsh\fR, on +startup the contents of the zip archive will be mounted as the +virtual file system /zvfs. If a top level directory tcl8.6 is +present in the zip archive, it will become the directory loaded +as env(TCL_LIBRARY). If a file named \fBmain.tcl\fR is present +in the top level directory of the zip archive, it will be sourced +instead of the shell's normal command line handing. .SH "SEE ALSO" auto_path(n), encoding(n), env(n), fconfigure(n) .SH KEYWORDS application, argument, interpreter, prompt, script file, shell ADDED doc/zipfs.3 Index: doc/zipfs.3 ================================================================== --- /dev/null +++ doc/zipfs.3 @@ -0,0 +1,46 @@ +'\" +'\" Copyright (c) 2015 Jan Nijtmans +'\" Copyright (c) 2015 Christian Werner +'\" Copyright (c) 2017 Sean Woods +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +.TH Tclzipfs 3 8.7 Tcl "Tcl Library Procedures" +.so man.macros +.BS +.SH NAME +Tclzipfs_Mount, Tclzipfs_Unmount \- handle ZIP files as VFS +.SH SYNOPSIS +.nf +.sp +int +\fBTclzipfs_Mount\fR(\fIinterp, zipname, mntpt, passwd\fR) +.sp +int +\fBTclzipfs_Unmount\fR(\fIinterp, zipname\fR) +.SH ARGUMENTS +.AS Tcl_Interp **termPtr +.AP Tcl_Interp *interp in +Interpreter in which the zip file system is mounted. The interpreter's result is +modified to hold the result or error message from the script. +.AP "const char" *zipname in +Name of a zipfile. +.AP "const char" *mntpt in +Name of a mount point. +.AP "const char" *passwd in +An (optional) password. +.BE +.SH DESCRIPTION +\fBTclzipfs_Mount()\fR mount the ZIP archive \fIzipname\fR on the mount +point given in \fImntpt\fR using the optional ZIP password \fIpasswd\fR. +Errors during that process are reported in the interpreter \fIinterp\fR. +If \fIzipname\fR is a NULL pointer, information on all currently mounted +ZIP file systems is written into \fIinterp\fR's result as a sequence of +mount points and ZIP file names. +.PP +\fBTclzipfs_Unmount()\fR undoes the effect of \fBTclzipfs_Mount()\fR, +i.e. it unmounts the mounted ZIP archive file \fIzipname\fR. Errors are +reported in the interpreter \fIinterp\fR. +.SH KEYWORDS +compress, filesystem, zip ADDED doc/zipfs.n Index: doc/zipfs.n ================================================================== --- /dev/null +++ doc/zipfs.n @@ -0,0 +1,119 @@ +'\" +'\" Copyright (c) 2015 Jan Nijtmans +'\" Copyright (c) 2015 Christian Werner +'\" Copyright (c) 2015 Sean Woods +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +.TH zipfs n 1.0 Zipfs "zipfs Commands" +.so man.macros +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +zipfs \- Mount and work with ZIP files within Tcl +.SH SYNOPSIS +.nf +\fBpackage require zipfs \fR?\fB1.0\fR? +.sp +\fBzipfs exists\fR \fIfilename\fR +\fBzipfs find\fR \fIdir\fR +\fBzipfs info\fR \fIfilename\fR +\fBzipfs list\fR \fB?(-glob|-regexp)?\fR \fI?pattern?\fR +\fBzipfs mkimg\fR \fIoutfile\fR \fIindir\fR \fI?strip?\fR \fI?password?\fR \fI?infile?\fR +\fBzipfs mkkey\fR \fIpassword\fR +\fBzipfs mkzip\fR \fIoutfile\fR \fIindir\fR \fI?strip?\fR \fI?password?\fR +\fBzipfs mount\fR \fI?zipfile?\fR \fI?mountpoint?\fR \fI?password?\fR +\fBzipfs unmount\fR \fIzipfile\fR +.fi +.BE +.SH DESCRIPTION +.PP +The \fBzipfs\fR package provides tcl with the ability to mount +the contents of a zip file as a virtual file system. +.TP +\fBzipfs exists\fR \fIfilename\fR +. +Return 1 if the given filename exists in the mounted zipfs and 0 if it does not. +.TP +\fBzipfs find\fR \fIdir\fR +. +Recursively lists files including and below the directory \fIdir\fR. +The result list consists of relative path names starting from the +given directory. This command is also used by the \fBzipfs mkzip\fR +and \fBzipfs mkimg\fR commands. +.TP +\fBzipfs info\fR \fIfile\fR +. +Return information about the given file in the mounted zipfs. The information +consists of (1) the name of the ZIP archive file that contains the file, +(2) the size of the file after decompressions, (3) the compressed size of +the file, and (4) the offset of the compressed data in the ZIP archive file. +.RS +.PP +Note: querying the mount point gives the start of zip data offset in (4), +which can be used to truncate the zip info off an executable. +.RE +.TP +\fBzipfs list\fR \fB?(-glob|-regexp)?\fR \fI?pattern?\fR +. +Return a list of all files in the mounted zipfs. The order of the names +in the list is arbitrary. +.TP +\fBzipfs mkimg\fR \fIoutfile\fR \fIindir\fR \fI?strip?\fR \fI?password?\fR \fI?infile?\fR +. +Creates an image (potentially a new executable file) similar to +\fBzipfs mkzip\fR. If the \fIinfile\fR parameter is specified, +this file is prepended in front of the ZIP archive, otherwise the file +returned by \fBTcl_NameOfExecutable(3)\fR (i.e. the executable file of +the running process) is used. If the \fIpassword\fR parameter is not empty, +an obfuscated version of that password is placed between the image and ZIP +chunks of the output file and the contents of the ZIP chunk are protected +with that password. +.RS +.PP +Caution: highly experimental, not usable on Android, only partially tested +on Linux and Windows. +.RE +.TP +\fBzipfs mkkey\fR \fIpassword\fR +. +For the clear text \fIpassword\fR argument an obfuscated string version +is returned with the same format used in the \fBzipfs mkimg\fR command. +.TP +\fBzipfs mkzip\fR \fIoutfile\fR \fIindir\fR \fI?strip?\fR \fI?password?\fR +. +Creates a ZIP archive file named \fIoutfile\fR from the contents of the input +directory \fIindir\fR (contained regular files only) with optional ZIP +password \fIpassword\fR. While processing the files below \fIindir\fR the +optional file name prefix given in \fIstrip\fR is stripped off the beginning +of the respective file name. +.RS +.PP +Caution: the choice of the \fIindir\fR parameter +(less the optional stripped prefix) determines the later root name of the +archive's content. +.RE +.TP +\fBzipfs mount ?\fIzipfile\fR? ?\fImountpoint\fR? ?\fIpassword\fR? +. +The \fBzipfs mount\fR command mounts a ZIP archive file as a VFS. +After this command executes, files contained in \fIzipfile\fR +will appear to Tcl to be regular files at the mount point. +.RS +.PP +With no \fImountpoint\fR, returns the mount point for \fIzipfile\fR. +With no \fIzipfile\fR, return all zipfile/mount pairs. +If \fImountpoint\fR is specified as an empty string, mount on file path. +.RE +.TP +\fBzipfs unmount \fIzipfile\fR +. +Unmounts a previously mounted ZIP archive file \fIzipfile\fR. +.SH "SEE ALSO" +tclsh(1), file(n), zlib(n) +.SH "KEYWORDS" +compress, filesystem, zip +'\" Local Variables: +'\" mode: nroff +'\" End: Index: generic/tcl.decls ================================================================== --- generic/tcl.decls +++ generic/tcl.decls @@ -467,11 +467,10 @@ CONST84_RETURN char *Tcl_ErrnoMsg(int err) } declare 129 { int Tcl_Eval(Tcl_Interp *interp, const char *script) } -# This is obsolete, use Tcl_FSEvalFile declare 130 { int Tcl_EvalFile(Tcl_Interp *interp, const char *fileName) } declare 131 { int Tcl_EvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr) @@ -778,12 +777,11 @@ int Tcl_ScanElement(const char *src, int *flagPtr) } declare 219 { int Tcl_ScanCountedElement(const char *src, int length, int *flagPtr) } -# Obsolete -declare 220 { +declare 220 {deprecated {}} { int Tcl_SeekOld(Tcl_Channel chan, int offset, int mode) } declare 221 { int Tcl_ServiceAll(void) } @@ -866,12 +864,11 @@ Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc) } declare 245 { int Tcl_StringMatch(const char *str, const char *pattern) } -# Obsolete -declare 246 { +declare 246 {deprecated {}} { int Tcl_TellOld(Tcl_Channel chan) } declare 247 { int Tcl_TraceVar(Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData) @@ -943,14 +940,14 @@ int Tcl_DumpActiveMemory(const char *fileName) } declare 266 { void Tcl_ValidateAllMemory(const char *file, int line) } -declare 267 { +declare 267 {deprecated {see TIP #422}} { void Tcl_AppendResultVA(Tcl_Interp *interp, va_list argList) } -declare 268 { +declare 268 {deprecated {see TIP #422}} { void Tcl_AppendStringsToObjVA(Tcl_Obj *objPtr, va_list argList) } declare 269 { char *Tcl_HashStats(Tcl_HashTable *tablePtr) } @@ -974,20 +971,20 @@ # TIP #268: The internally used new Require function is in slot 573. declare 274 { CONST84_RETURN char *Tcl_PkgRequire(Tcl_Interp *interp, const char *name, const char *version, int exact) } -declare 275 { +declare 275 {deprecated {see TIP #422}} { void Tcl_SetErrorCodeVA(Tcl_Interp *interp, va_list argList) } -declare 276 { +declare 276 {deprecated {see TIP #422}} { int Tcl_VarEvalVA(Tcl_Interp *interp, va_list argList) } declare 277 { Tcl_Pid Tcl_WaitPid(Tcl_Pid pid, int *statPtr, int options) } -declare 278 { +declare 278 {deprecated {see TIP #422}} { TCL_NORETURN void Tcl_PanicVA(const char *format, va_list argList) } declare 279 { void Tcl_GetVersion(int *major, int *minor, int *patchLevel, int *type) } @@ -2333,12 +2330,21 @@ ClientData callbackData) } # ----- BASELINE -- FOR -- 8.7.0 ----- # - - +# TIP #430 +declare 632 { + int TclZipfs_Mount(Tcl_Interp *interp, const char *zipname, const char *mntpt, + const char *passwd) +} +declare 633 { + int TclZipfs_Unmount(Tcl_Interp *interp, const char *zipname) +} +declare 634 { + int TclZipfs_AppHook(int *argc, char ***argv) +} ############################################################################## # Define the platform specific public Tcl interface. These functions are only # available on the designated platform. Index: generic/tcl.h ================================================================== --- generic/tcl.h +++ generic/tcl.h @@ -1342,12 +1342,12 @@ */ typedef struct { void *next; /* Search position for underlying hash * table. */ - int epoch; /* Epoch marker for dictionary being searched, - * or -1 if search has terminated. */ + unsigned int epoch; /* Epoch marker for dictionary being searched, + * or 0 if search has terminated. */ Tcl_Dict dictionaryPtr; /* Reference to dictionary being searched. */ } Tcl_DictSearch; /* *---------------------------------------------------------------------------- @@ -2407,18 +2407,31 @@ int exact, int magic); const char * TclTomMathInitializeStubs(Tcl_Interp *interp, const char *version, int epoch, int revision); #ifdef USE_TCL_STUBS -#define Tcl_InitStubs(interp, version, exact) \ - (Tcl_InitStubs)(interp, version, \ +#if TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE +# define Tcl_InitStubs(interp, version, exact) \ + (Tcl_InitStubs)(interp, version, \ (exact)|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16), \ TCL_STUB_MAGIC) #else -#define Tcl_InitStubs(interp, version, exact) \ - Tcl_PkgInitStubsCheck(interp, version, \ - (exact)|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16)) +# define Tcl_InitStubs(interp, version, exact) \ + (Tcl_InitStubs)(interp, TCL_PATCH_LEVEL, \ + 1|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16), \ + TCL_STUB_MAGIC) +#endif +#else +#if TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE +# define Tcl_InitStubs(interp, version, exact) \ + Tcl_PkgInitStubsCheck(interp, version, \ + (exact)|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16)) +#else +# define Tcl_InitStubs(interp, version, exact) \ + Tcl_PkgInitStubsCheck(interp, TCL_PATCH_LEVEL, \ + 1|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16)) +#endif #endif /* * Public functions that are not accessible via the stubs table. * Tcl_GetMemoryInfo is needed for AOLserver. [Bug 1868171] Index: generic/tclBasic.c ================================================================== --- generic/tclBasic.c +++ generic/tclBasic.c @@ -988,10 +988,13 @@ #ifdef HAVE_ZLIB if (TclZlibInit(interp) != TCL_OK) { Tcl_Panic("%s", TclGetString(Tcl_GetObjResult(interp))); } + if (TclZipfs_Init(interp) != TCL_OK) { + Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp))); + } #endif TOP_CB(iPtr) = NULL; return interp; } @@ -7720,11 +7723,11 @@ if (!(iPtr->flags & RAND_SEED_INITIALIZED)) { iPtr->flags |= RAND_SEED_INITIALIZED; /* - * To ensure different seeds in different threads (bug #416643), + * To ensure different seeds in different threads (bug #416643), * take into consideration the thread this interp is running in. */ iPtr->randSeed = TclpGetClicks() + (PTR2INT(Tcl_GetCurrentThread())<<12); Index: generic/tclCmdMZ.c ================================================================== --- generic/tclCmdMZ.c +++ generic/tclCmdMZ.c @@ -307,11 +307,11 @@ if (offset == 0) { eflags = 0; } else if (offset > stringLength) { eflags = TCL_REG_NOTBOL; - } else if (Tcl_GetUniChar(objPtr, offset-1) == (Tcl_UniChar)'\n') { + } else if (Tcl_GetUniChar(objPtr, offset-1) == '\n') { eflags = 0; } else { eflags = TCL_REG_NOTBOL; } @@ -1214,17 +1214,26 @@ */ Tcl_InitHashTable(&charReuseTable, TCL_ONE_WORD_KEYS); for ( ; stringPtr < end; stringPtr += len) { + int fullchar; len = TclUtfToUniChar(stringPtr, &ch); + fullchar = ch; + +#if TCL_UTF_MAX == 4 + if (!len) { + len += TclUtfToUniChar(stringPtr, &ch); + fullchar = (((fullchar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000; + } +#endif /* * Assume Tcl_UniChar is an integral type... */ - hPtr = Tcl_CreateHashEntry(&charReuseTable, INT2PTR((int) ch), + hPtr = Tcl_CreateHashEntry(&charReuseTable, INT2PTR(fullchar), &isNew); if (isNew) { TclNewStringObj(objPtr, stringPtr, len); /* @@ -1812,12 +1821,20 @@ } goto str_is_done; } end = string1 + length1; for (; string1 < end; string1 += length2, failat++) { + int fullchar; length2 = TclUtfToUniChar(string1, &ch); - if (!chcomp(ch)) { + fullchar = ch; +#if TCL_UTF_MAX == 4 + if (!length2) { + length2 = TclUtfToUniChar(string1, &ch); + fullchar = (((fullchar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000; + } +#endif + if (!chcomp(fullchar)) { result = 0; break; } } } Index: generic/tclDecls.h ================================================================== --- generic/tclDecls.h +++ generic/tclDecls.h @@ -667,11 +667,12 @@ EXTERN int Tcl_ScanElement(const char *src, int *flagPtr); /* 219 */ EXTERN int Tcl_ScanCountedElement(const char *src, int length, int *flagPtr); /* 220 */ -EXTERN int Tcl_SeekOld(Tcl_Channel chan, int offset, int mode); +TCL_DEPRECATED("") +int Tcl_SeekOld(Tcl_Channel chan, int offset, int mode); /* 221 */ EXTERN int Tcl_ServiceAll(void); /* 222 */ EXTERN int Tcl_ServiceEvent(int flags); /* 223 */ @@ -739,11 +740,12 @@ Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc); /* 245 */ EXTERN int Tcl_StringMatch(const char *str, const char *pattern); /* 246 */ -EXTERN int Tcl_TellOld(Tcl_Channel chan); +TCL_DEPRECATED("") +int Tcl_TellOld(Tcl_Channel chan); /* 247 */ EXTERN int Tcl_TraceVar(Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 248 */ @@ -810,14 +812,16 @@ /* 265 */ EXTERN int Tcl_DumpActiveMemory(const char *fileName); /* 266 */ EXTERN void Tcl_ValidateAllMemory(const char *file, int line); /* 267 */ -EXTERN void Tcl_AppendResultVA(Tcl_Interp *interp, +TCL_DEPRECATED("see TIP #422") +void Tcl_AppendResultVA(Tcl_Interp *interp, va_list argList); /* 268 */ -EXTERN void Tcl_AppendStringsToObjVA(Tcl_Obj *objPtr, +TCL_DEPRECATED("see TIP #422") +void Tcl_AppendStringsToObjVA(Tcl_Obj *objPtr, va_list argList); /* 269 */ EXTERN char * Tcl_HashStats(Tcl_HashTable *tablePtr); /* 270 */ EXTERN CONST84_RETURN char * Tcl_ParseVar(Tcl_Interp *interp, @@ -836,18 +840,21 @@ /* 274 */ EXTERN CONST84_RETURN char * Tcl_PkgRequire(Tcl_Interp *interp, const char *name, const char *version, int exact); /* 275 */ -EXTERN void Tcl_SetErrorCodeVA(Tcl_Interp *interp, +TCL_DEPRECATED("see TIP #422") +void Tcl_SetErrorCodeVA(Tcl_Interp *interp, va_list argList); /* 276 */ -EXTERN int Tcl_VarEvalVA(Tcl_Interp *interp, va_list argList); +TCL_DEPRECATED("see TIP #422") +int Tcl_VarEvalVA(Tcl_Interp *interp, va_list argList); /* 277 */ EXTERN Tcl_Pid Tcl_WaitPid(Tcl_Pid pid, int *statPtr, int options); /* 278 */ -EXTERN TCL_NORETURN void Tcl_PanicVA(const char *format, va_list argList); +TCL_DEPRECATED("see TIP #422") +TCL_NORETURN void Tcl_PanicVA(const char *format, va_list argList); /* 279 */ EXTERN void Tcl_GetVersion(int *major, int *minor, int *patchLevel, int *type); /* 280 */ EXTERN void Tcl_InitMemory(Tcl_Interp *interp); @@ -1829,10 +1836,19 @@ EXTERN Tcl_Channel Tcl_OpenTcpServerEx(Tcl_Interp *interp, const char *service, const char *host, unsigned int flags, Tcl_TcpAcceptProc *acceptProc, ClientData callbackData); +/* 632 */ +EXTERN int TclZipfs_Mount(Tcl_Interp *interp, + const char *zipname, const char *mntpt, + const char *passwd); +/* 633 */ +EXTERN int TclZipfs_Unmount(Tcl_Interp *interp, + const char *zipname); +/* 634 */ +EXTERN int TclZipfs_AppHook(int *argc, char ***argv); typedef struct { const struct TclPlatStubs *tclPlatStubs; const struct TclIntStubs *tclIntStubs; const struct TclIntPlatStubs *tclIntPlatStubs; @@ -2084,11 +2100,11 @@ void (*tcl_RegExpRange) (Tcl_RegExp regexp, int index, CONST84 char **startPtr, CONST84 char **endPtr); /* 215 */ void (*tcl_Release) (ClientData clientData); /* 216 */ void (*tcl_ResetResult) (Tcl_Interp *interp); /* 217 */ int (*tcl_ScanElement) (const char *src, int *flagPtr); /* 218 */ int (*tcl_ScanCountedElement) (const char *src, int length, int *flagPtr); /* 219 */ - int (*tcl_SeekOld) (Tcl_Channel chan, int offset, int mode); /* 220 */ + TCL_DEPRECATED_API("") int (*tcl_SeekOld) (Tcl_Channel chan, int offset, int mode); /* 220 */ int (*tcl_ServiceAll) (void); /* 221 */ int (*tcl_ServiceEvent) (int flags); /* 222 */ void (*tcl_SetAssocData) (Tcl_Interp *interp, const char *name, Tcl_InterpDeleteProc *proc, ClientData clientData); /* 223 */ void (*tcl_SetChannelBufferSize) (Tcl_Channel chan, int sz); /* 224 */ int (*tcl_SetChannelOption) (Tcl_Interp *interp, Tcl_Channel chan, const char *optionName, const char *newValue); /* 225 */ @@ -2110,11 +2126,11 @@ void (*tcl_SourceRCFile) (Tcl_Interp *interp); /* 241 */ int (*tcl_SplitList) (Tcl_Interp *interp, const char *listStr, int *argcPtr, CONST84 char ***argvPtr); /* 242 */ void (*tcl_SplitPath) (const char *path, int *argcPtr, CONST84 char ***argvPtr); /* 243 */ void (*tcl_StaticPackage) (Tcl_Interp *interp, const char *pkgName, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc); /* 244 */ int (*tcl_StringMatch) (const char *str, const char *pattern); /* 245 */ - int (*tcl_TellOld) (Tcl_Channel chan); /* 246 */ + TCL_DEPRECATED_API("") int (*tcl_TellOld) (Tcl_Channel chan); /* 246 */ int (*tcl_TraceVar) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 247 */ int (*tcl_TraceVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 248 */ char * (*tcl_TranslateFileName) (Tcl_Interp *interp, const char *name, Tcl_DString *bufferPtr); /* 249 */ int (*tcl_Ungets) (Tcl_Channel chan, const char *str, int len, int atHead); /* 250 */ void (*tcl_UnlinkVar) (Tcl_Interp *interp, const char *varName); /* 251 */ @@ -2131,22 +2147,22 @@ ClientData (*tcl_VarTraceInfo2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *procPtr, ClientData prevClientData); /* 262 */ int (*tcl_Write) (Tcl_Channel chan, const char *s, int slen); /* 263 */ void (*tcl_WrongNumArgs) (Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], const char *message); /* 264 */ int (*tcl_DumpActiveMemory) (const char *fileName); /* 265 */ void (*tcl_ValidateAllMemory) (const char *file, int line); /* 266 */ - void (*tcl_AppendResultVA) (Tcl_Interp *interp, va_list argList); /* 267 */ - void (*tcl_AppendStringsToObjVA) (Tcl_Obj *objPtr, va_list argList); /* 268 */ + TCL_DEPRECATED_API("see TIP #422") void (*tcl_AppendResultVA) (Tcl_Interp *interp, va_list argList); /* 267 */ + TCL_DEPRECATED_API("see TIP #422") void (*tcl_AppendStringsToObjVA) (Tcl_Obj *objPtr, va_list argList); /* 268 */ char * (*tcl_HashStats) (Tcl_HashTable *tablePtr); /* 269 */ CONST84_RETURN char * (*tcl_ParseVar) (Tcl_Interp *interp, const char *start, CONST84 char **termPtr); /* 270 */ CONST84_RETURN char * (*tcl_PkgPresent) (Tcl_Interp *interp, const char *name, const char *version, int exact); /* 271 */ CONST84_RETURN char * (*tcl_PkgPresentEx) (Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); /* 272 */ int (*tcl_PkgProvide) (Tcl_Interp *interp, const char *name, const char *version); /* 273 */ CONST84_RETURN char * (*tcl_PkgRequire) (Tcl_Interp *interp, const char *name, const char *version, int exact); /* 274 */ - void (*tcl_SetErrorCodeVA) (Tcl_Interp *interp, va_list argList); /* 275 */ - int (*tcl_VarEvalVA) (Tcl_Interp *interp, va_list argList); /* 276 */ + TCL_DEPRECATED_API("see TIP #422") void (*tcl_SetErrorCodeVA) (Tcl_Interp *interp, va_list argList); /* 275 */ + TCL_DEPRECATED_API("see TIP #422") int (*tcl_VarEvalVA) (Tcl_Interp *interp, va_list argList); /* 276 */ Tcl_Pid (*tcl_WaitPid) (Tcl_Pid pid, int *statPtr, int options); /* 277 */ - TCL_NORETURN1 void (*tcl_PanicVA) (const char *format, va_list argList); /* 278 */ + TCL_DEPRECATED_API("see TIP #422") TCL_NORETURN1 void (*tcl_PanicVA) (const char *format, va_list argList); /* 278 */ void (*tcl_GetVersion) (int *major, int *minor, int *patchLevel, int *type); /* 279 */ void (*tcl_InitMemory) (Tcl_Interp *interp); /* 280 */ Tcl_Channel (*tcl_StackChannel) (Tcl_Interp *interp, const Tcl_ChannelType *typePtr, ClientData instanceData, int mask, Tcl_Channel prevChan); /* 281 */ int (*tcl_UnstackChannel) (Tcl_Interp *interp, Tcl_Channel chan); /* 282 */ Tcl_Channel (*tcl_GetStackedChannel) (Tcl_Channel chan); /* 283 */ @@ -2496,10 +2512,13 @@ int (*tcl_LoadFile) (Tcl_Interp *interp, Tcl_Obj *pathPtr, const char *const symv[], int flags, void *procPtrs, Tcl_LoadHandle *handlePtr); /* 627 */ void * (*tcl_FindSymbol) (Tcl_Interp *interp, Tcl_LoadHandle handle, const char *symbol); /* 628 */ int (*tcl_FSUnloadFile) (Tcl_Interp *interp, Tcl_LoadHandle handlePtr); /* 629 */ void (*tcl_ZlibStreamSetCompressionDictionary) (Tcl_ZlibStream zhandle, Tcl_Obj *compressionDictionaryObj); /* 630 */ Tcl_Channel (*tcl_OpenTcpServerEx) (Tcl_Interp *interp, const char *service, const char *host, unsigned int flags, Tcl_TcpAcceptProc *acceptProc, ClientData callbackData); /* 631 */ + int (*tclZipfs_Mount) (Tcl_Interp *interp, const char *zipname, const char *mntpt, const char *passwd); /* 632 */ + int (*tclZipfs_Unmount) (Tcl_Interp *interp, const char *zipname); /* 633 */ + int (*tclZipfs_AppHook) (int *argc, char ***argv); /* 634 */ } TclStubs; extern const TclStubs *tclStubsPtr; #ifdef __cplusplus @@ -3790,10 +3809,16 @@ (tclStubsPtr->tcl_FSUnloadFile) /* 629 */ #define Tcl_ZlibStreamSetCompressionDictionary \ (tclStubsPtr->tcl_ZlibStreamSetCompressionDictionary) /* 630 */ #define Tcl_OpenTcpServerEx \ (tclStubsPtr->tcl_OpenTcpServerEx) /* 631 */ +#define TclZipfs_Mount \ + (tclStubsPtr->tclZipfs_Mount) /* 632 */ +#define TclZipfs_Unmount \ + (tclStubsPtr->tclZipfs_Unmount) /* 633 */ +#define TclZipfs_AppHook \ + (tclStubsPtr->tclZipfs_AppHook) /* 634 */ #endif /* defined(USE_TCL_STUBS) */ /* !END!: Do not edit above this line. */ Index: generic/tclDictObj.c ================================================================== --- generic/tclDictObj.c +++ generic/tclDictObj.c @@ -139,11 +139,11 @@ * created. */ ChainEntry *entryChainTail; /* Other end of linked list of all entries in * the dictionary. Used for doing traversal of * the entries in the order that they are * created. */ - int epoch; /* Epoch counter */ + unsigned int epoch; /* Epoch counter */ size_t refCount; /* Reference counter (see above) */ Tcl_Obj *chain; /* Linked list used for invalidating the * string representations of updated nested * dictionaries. */ } Dict; @@ -388,11 +388,11 @@ /* * Initialise other fields. */ - newDict->epoch = 0; + newDict->epoch = 1; newDict->chain = NULL; newDict->refCount = 1; /* * Store in the object. @@ -485,19 +485,18 @@ static void UpdateStringOfDict( Tcl_Obj *dictPtr) { -#define LOCAL_SIZE 20 - int localFlags[LOCAL_SIZE], *flagPtr = NULL; +#define LOCAL_SIZE 64 + char localFlags[LOCAL_SIZE], *flagPtr = NULL; Dict *dict = DICT(dictPtr); ChainEntry *cPtr; Tcl_Obj *keyPtr, *valuePtr; int i, length, bytesNeeded = 0; const char *elem; char *dst; - const int maxFlags = UINT_MAX / sizeof(int); /* * This field is the most useful one in the whole hash structure, and it * is not exposed by any API function... */ @@ -515,14 +514,12 @@ * Pass 1: estimate space, gather flags. */ if (numElems <= LOCAL_SIZE) { flagPtr = localFlags; - } else if (numElems > maxFlags) { - Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } else { - flagPtr = ckalloc(numElems * sizeof(int)); + flagPtr = ckalloc(numElems); } for (i=0,cPtr=dict->entryChainHead; inextPtr) { /* * Assume that cPtr is never NULL since we know the number of array * elements already. @@ -708,11 +705,11 @@ * as possible to allow the conversion code, in particular * Tcl_GetStringFromObj, to use that old internalRep. */ TclFreeIntRep(objPtr); - dict->epoch = 0; + dict->epoch = 1; dict->chain = NULL; dict->refCount = 1; DICT(objPtr) = dict; objPtr->internalRep.twoPtrValue.ptr2 = NULL; objPtr->typePtr = &tclDictType; @@ -1107,11 +1104,11 @@ } dict = DICT(dictPtr); cPtr = dict->entryChainHead; if (cPtr == NULL) { - searchPtr->epoch = -1; + searchPtr->epoch = 0; *donePtr = 1; } else { *donePtr = 0; searchPtr->dictionaryPtr = (Tcl_Dict) dict; searchPtr->epoch = dict->epoch; @@ -1168,11 +1165,11 @@ /* * If the searh is done; we do no work. */ - if (searchPtr->epoch == -1) { + if (!searchPtr->epoch) { *donePtr = 1; return; } /* @@ -1225,12 +1222,12 @@ Tcl_DictObjDone( Tcl_DictSearch *searchPtr) /* Pointer to a hash search context. */ { Dict *dict; - if (searchPtr->epoch != -1) { - searchPtr->epoch = -1; + if (searchPtr->epoch) { + searchPtr->epoch = 0; dict = (Dict *) searchPtr->dictionaryPtr; if (dict->refCount-- <= 1) { DeleteDict(dict); } } @@ -1378,11 +1375,11 @@ TclNewObj(dictPtr); TclInvalidateStringRep(dictPtr); dict = ckalloc(sizeof(Dict)); InitChainTable(dict); - dict->epoch = 0; + dict->epoch = 1; dict->chain = NULL; dict->refCount = 1; DICT(dictPtr) = dict; dictPtr->internalRep.twoPtrValue.ptr2 = NULL; dictPtr->typePtr = &tclDictType; @@ -1428,11 +1425,11 @@ TclDbNewObj(dictPtr, file, line); TclInvalidateStringRep(dictPtr); dict = ckalloc(sizeof(Dict)); InitChainTable(dict); - dict->epoch = 0; + dict->epoch = 1; dict->chain = NULL; dict->refCount = 1; DICT(dictPtr) = dict; dictPtr->internalRep.twoPtrValue.ptr2 = NULL; dictPtr->typePtr = &tclDictType; Index: generic/tclExecute.c ================================================================== --- generic/tclExecute.c +++ generic/tclExecute.c @@ -1331,16 +1331,16 @@ TclStackAlloc( Tcl_Interp *interp, int numBytes) { Interp *iPtr = (Interp *) interp; - int numWords = (numBytes + (sizeof(Tcl_Obj *) - 1))/sizeof(Tcl_Obj *); + int numWords; if (iPtr == NULL || iPtr->execEnvPtr == NULL) { return (void *) ckalloc(numBytes); } - + numWords = (numBytes + (sizeof(Tcl_Obj *) - 1))/sizeof(Tcl_Obj *); return (void *) StackAllocWords(interp, numWords); } void * TclStackRealloc( Index: generic/tclFileName.c ================================================================== --- generic/tclFileName.c +++ generic/tclFileName.c @@ -1879,11 +1879,11 @@ */ separators = "/\\"; } else if (tclPlatform == TCL_PLATFORM_UNIX) { - if (pathPrefix == NULL && tail[0] == '/') { + if (pathPrefix == NULL && tail[0] == '/' && tail[1] != '/') { pathPrefix = Tcl_NewStringObj(tail, 1); tail++; Tcl_IncrRefCount(pathPrefix); } } Index: generic/tclHash.c ================================================================== --- generic/tclHash.c +++ generic/tclHash.c @@ -983,15 +983,21 @@ static void RebuildTable( register Tcl_HashTable *tablePtr) /* Table to enlarge. */ { - int oldSize, count, index; - Tcl_HashEntry **oldBuckets; + int count, index, oldSize = tablePtr->numBuckets; + Tcl_HashEntry **oldBuckets = tablePtr->buckets; register Tcl_HashEntry **oldChainPtr, **newChainPtr; register Tcl_HashEntry *hPtr; const Tcl_HashKeyType *typePtr; + + /* Avoid outgrowing capability of the memory allocators */ + if (oldSize > (int)(UINT_MAX / (4 * sizeof(Tcl_HashEntry *)))) { + tablePtr->rebuildSize = INT_MAX; + return; + } if (tablePtr->keyType == TCL_STRING_KEYS) { typePtr = &tclStringHashKeyType; } else if (tablePtr->keyType == TCL_ONE_WORD_KEYS) { typePtr = &tclOneWordHashKeyType; @@ -1000,13 +1006,10 @@ typePtr = tablePtr->typePtr; } else { typePtr = &tclArrayHashKeyType; } - oldSize = tablePtr->numBuckets; - oldBuckets = tablePtr->buckets; - /* * Allocate and initialize the new bucket array, and set up hashing * constants for new array size. */ Index: generic/tclIOUtil.c ================================================================== --- generic/tclIOUtil.c +++ generic/tclIOUtil.c @@ -410,11 +410,10 @@ TclDStringAppendObj(cwdPtr, cwd); Tcl_DecrRefCount(cwd); return Tcl_DStringValue(cwdPtr); } -/* Obsolete */ int Tcl_EvalFile( Tcl_Interp *interp, /* Interpreter in which to process file. */ const char *fileName) /* Name of file to process. Tilde-substitution * will be performed on this name. */ Index: generic/tclIndexObj.c ================================================================== --- generic/tclIndexObj.c +++ generic/tclIndexObj.c @@ -874,11 +874,12 @@ const char *message) /* Error message to print after the leading * objects in objv. The message may be * NULL. */ { Tcl_Obj *objPtr; - int i, len, elemLen, flags; + int i, len, elemLen; + char flags; Interp *iPtr = (Interp *) interp; const char *elementStr; /* * [incr Tcl] does something fairly horrific when generating error Index: generic/tclInt.decls ================================================================== --- generic/tclInt.decls +++ generic/tclInt.decls @@ -48,11 +48,11 @@ void TclCleanupCommand(Command *cmdPtr) } declare 7 { int TclCopyAndCollapse(int count, const char *src, char *dst) } -declare 8 { +declare 8 {deprecated {}} { int TclCopyChannelOld(Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, int toRead, Tcl_Obj *cmdPtr) } # TclCreatePipeline unofficially exported for use by BLT. @@ -71,11 +71,11 @@ void TclDeleteCompiledLocalVars(Interp *iPtr, CallFrame *framePtr) } declare 12 { void TclDeleteVars(Interp *iPtr, TclVarHashTable *tablePtr) } -# Removed in 8.5 +# Removed in 8.5: #declare 13 { # int TclDoGlob(Tcl_Interp *interp, char *separators, # Tcl_DString *headPtr, char *tail, Tcl_GlobTypeData *types) #} declare 14 { @@ -86,11 +86,11 @@ # void TclExpandParseValue(ParseValue *pvPtr, int needed) # } declare 16 { void TclExprFloatError(Tcl_Interp *interp, double value) } -# Removed in 8.4 +# Removed in 8.4: #declare 17 { # int TclFileAttrsCmd(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) #} #declare 18 { # int TclFileCopyCmd(Tcl_Interp *interp, int argc, char **argv) @@ -121,11 +121,11 @@ } # Removed in 8.1: # declare 26 { # char *TclGetCwd(Tcl_Interp *interp) # } -# Removed in 8.5 +# Removed in 8.5: #declare 27 { # int TclGetDate(char *p, unsigned long now, long zone, # unsigned long *timePtr) #} declare 28 { @@ -145,11 +145,11 @@ } declare 32 { int TclGetFrame(Tcl_Interp *interp, const char *str, CallFrame **framePtrPtr) } -# Removed in Tcl 8.5 +# Removed in 8.5: #declare 33 { # TclCmdProcType TclGetInterpProc(void) #} declare 34 { int TclGetIntForIndex(Tcl_Interp *interp, Tcl_Obj *objPtr, @@ -158,11 +158,11 @@ # Removed in 8.4b2: #declare 35 { # Tcl_Obj *TclGetIndexedScalar(Tcl_Interp *interp, int localIndex, # int flags) #} -# Removed in 8.6a2 +# Removed in 8.6a2: #declare 36 { # int TclGetLong(Tcl_Interp *interp, const char *str, long *longPtr) #} declare 37 { int TclGetLoadedPackages(Tcl_Interp *interp, const char *targetName) @@ -183,11 +183,11 @@ Tcl_Command TclGetOriginalCommand(Tcl_Command command) } declare 42 { CONST86 char *TclpGetUserHome(const char *name, Tcl_DString *bufferPtr) } -# Removed in Tcl 8.5a2 +# Removed in 8.5a2: #declare 43 { # int TclGlobalInvoke(Tcl_Interp *interp, int argc, CONST84 char **argv, # int flags) #} declare 44 { @@ -218,11 +218,11 @@ Namespace *nsPtr) } declare 51 { int TclInterpInit(Tcl_Interp *interp) } -# Removed in Tcl 8.5a2 +# Removed in 8.5a2: #declare 52 { # int TclInvoke(Tcl_Interp *interp, int argc, CONST84 char **argv, # int flags) #} declare 53 { @@ -271,11 +271,11 @@ } declare 64 { int TclObjInvoke(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags) } -# Removed in Tcl 8.5a2 +# Removed in 8.5a2: #declare 65 { # int TclObjInvokeGlobal(Tcl_Interp *interp, int objc, # Tcl_Obj *const objv[], int flags) #} #declare 66 { @@ -311,13 +311,11 @@ unsigned long TclpGetClicks(void) } declare 76 { unsigned long TclpGetSeconds(void) } - -# deprecated -declare 77 { +declare 77 {deprecated {}} { void TclpGetTime(Tcl_Time *time) } # Removed in 8.6: #declare 78 { # int TclpGetTimeZone(unsigned long time) @@ -378,11 +376,11 @@ const char *procName) } declare 93 { void TclProcDeleteProc(ClientData clientData) } -# Removed in Tcl 8.5: +# Removed in 8.5: #declare 94 { # int TclProcInterpProc(ClientData clientData, Tcl_Interp *interp, # int argc, const char **argv) #} # Replaced by Tcl_FSStat in 8.4: @@ -417,11 +415,11 @@ } declare 103 { int TclSockGetPort(Tcl_Interp *interp, const char *str, const char *proto, int *portPtr) } -declare 104 { +declare 104 {deprecated {}} { int TclSockMinimumBuffersOld(int sock, int size) } # Replaced by Tcl_FSStat in 8.4: #declare 105 { # int TclStat(const char *path, Tcl_StatBuf *buf) @@ -530,11 +528,11 @@ Tcl_ResolveCompiledVarProc *compiledVarProc) } declare 132 { int TclpHasSockets(Tcl_Interp *interp) } -declare 133 { +declare 133 {deprecated {}} { struct tm *TclpGetDate(const time_t *time, int useGMT) } # Removed in 8.5 #declare 134 { # size_t TclpStrftime(char *s, size_t maxsize, const char *format, @@ -623,16 +621,14 @@ int status) } declare 157 { Var *TclVarTraceExists(Tcl_Interp *interp, const char *varName) } -# REMOVED (except from stub table) - use public Tcl_SetStartupScript() -declare 158 { +declare 158 {deprecated {use public Tcl_SetStartupScript()}} { void TclSetStartupScriptFileName(const char *filename) } -# REMOVED (except from stub table) - use public Tcl_GetStartupScript() -declare 159 { +declare 159 {deprecated {use public Tcl_GetStartupScript()}} { const char *TclGetStartupScriptFileName(void) } #declare 160 { # int TclpMatchFilesTypes(Tcl_Interp *interp, char *separators, # Tcl_DString *dirPtr, char *pattern, char *tail, @@ -674,17 +670,14 @@ declare 166 { int TclListObjSetElement(Tcl_Interp *interp, Tcl_Obj *listPtr, int index, Tcl_Obj *valuePtr) } -# VFS-aware versions of Tcl*StartupScriptFileName (158 and 159 above) -# REMOVED (except from stub table) - use public Tcl_SetStartupScript() -declare 167 { +declare 167 {deprecated {use public Tcl_SetStartupScript()}} { void TclSetStartupScriptPath(Tcl_Obj *pathPtr) } -# REMOVED (except from stub table) - use public Tcl_GetStartupScript() -declare 168 { +declare 168 {deprecated {use public Tcl_GetStartupScript()}} { Tcl_Obj *TclGetStartupScriptPath(void) } # variant of Tcl_UtfNCmp that takes n as bytes, not chars declare 169 { int TclpUtfNcmp2(const char *s1, const char *s2, unsigned long n) @@ -728,11 +721,10 @@ } declare 177 { void TclVarErrMsg(Tcl_Interp *interp, const char *part1, const char *part2, const char *operation, const char *reason) } -# TIP 338 made these public - now declared in tcl.h too declare 178 { void Tcl_SetStartupScript(Tcl_Obj *pathPtr, const char *encodingName) } declare 179 { Tcl_Obj *Tcl_GetStartupScript(const char **encodingNamePtr) @@ -746,16 +738,14 @@ #declare 181 { # Tcl_Obj *TclDbNewListObjDirect(int objc, Tcl_Obj **objv, # const char *file, int line) #} -# TclpGmtime and TclpLocaltime promoted to the generic interface from unix - -declare 182 { +declare 182 {deprecated {}} { struct tm *TclpLocaltime(const time_t *clock) } -declare 183 { +declare 183 {deprecated {}} { struct tm *TclpGmtime(const time_t *clock) } # For the new "Thread Storage" subsystem. @@ -935,14 +925,11 @@ int *newPtr) } declare 235 { void TclInitVarHashTable(TclVarHashTable *tablePtr, Namespace *nsPtr) } - - -# TIP 337 made this one public -declare 236 { +declare 236 {deprecated {use Tcl_BackgroundException}} { void TclBackgroundException(Tcl_Interp *interp, int code) } # TIP #285: Script cancellation support. declare 237 { @@ -1088,11 +1075,11 @@ } # new for 8.4.20+/8.5.12+ Cygwin only declare 10 win { Tcl_DirEntry *TclpReaddir(DIR *dir) } -# Removed in 8.3.1 (for Win32s only) +# Removed in 8.3.1 (for Win32s only): #declare 10 win { # int TclWinSynchSpawn(void *args, int type, void **trans, Tcl_Pid *pidPtr) #} # Pipe channel functions @@ -1138,11 +1125,10 @@ TclFile TclpOpenFile(const char *fname, int mode) } declare 20 win { void TclWinAddProcess(HANDLE hProcess, DWORD id) } -# new for 8.4.20+/8.5.12+ declare 21 win { char *TclpInetNtoa(struct in_addr addr) } # removed permanently for 8.4 #declare 21 win { Index: generic/tclInt.h ================================================================== --- generic/tclInt.h +++ generic/tclInt.h @@ -2920,11 +2920,11 @@ MODULE_SCOPE void TclDeleteNamespaceVars(Namespace *nsPtr); MODULE_SCOPE int TclFindDictElement(Tcl_Interp *interp, const char *dict, int dictLength, const char **elementPtr, const char **nextPtr, int *sizePtr, int *literalPtr); -/* TIP #280 - Modified token based evulation, with line information. */ +/* TIP #280 - Modified token based evaluation, with line information. */ MODULE_SCOPE int TclEvalEx(Tcl_Interp *interp, const char *script, int numBytes, int flags, int line, int *clNextOuter, const char *outerScript); MODULE_SCOPE Tcl_ObjCmdProc TclFileAttrsCmd; MODULE_SCOPE Tcl_ObjCmdProc TclFileCopyCmd; @@ -3143,11 +3143,11 @@ MODULE_SCOPE void TclRemoveScriptLimitCallbacks(Tcl_Interp *interp); MODULE_SCOPE int TclReToGlob(Tcl_Interp *interp, const char *reStr, int reStrLen, Tcl_DString *dsPtr, int *flagsPtr, int *quantifiersFoundPtr); MODULE_SCOPE int TclScanElement(const char *string, int length, - int *flagPtr); + char *flagPtr); MODULE_SCOPE void TclSetBgErrorHandler(Tcl_Interp *interp, Tcl_Obj *cmdPrefix); MODULE_SCOPE void TclSetBignumIntRep(Tcl_Obj *objPtr, mp_int *bignumValue); MODULE_SCOPE int TclSetBooleanFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); @@ -3211,16 +3211,24 @@ #ifdef TCL_WIDE_CLICKS MODULE_SCOPE Tcl_WideInt TclpGetWideClicks(void); MODULE_SCOPE double TclpWideClicksToNanoseconds(Tcl_WideInt clicks); #endif MODULE_SCOPE int TclZlibInit(Tcl_Interp *interp); +MODULE_SCOPE int TclZipfsInit(Tcl_Interp *interp); +MODULE_SCOPE int TclZipfsMount(Tcl_Interp *interp, const char *zipname, + const char *mntpt, const char *passwd); +MODULE_SCOPE int TclZipfsUnmount(Tcl_Interp *interp, const char *zipname); MODULE_SCOPE void * TclpThreadCreateKey(void); MODULE_SCOPE void TclpThreadDeleteKey(void *keyPtr); MODULE_SCOPE void TclpThreadSetMasterTSD(void *tsdKeyPtr, void *ptr); MODULE_SCOPE void * TclpThreadGetMasterTSD(void *tsdKeyPtr); MODULE_SCOPE void TclErrorStackResetIf(Tcl_Interp *interp, const char *msg, int length); +/* Tip 430 */ +MODULE_SCOPE int TclZipfs_Init(Tcl_Interp *interp); +MODULE_SCOPE int TclZipfs_SafeInit(Tcl_Interp *interp); + /* *---------------------------------------------------------------- * Command procedures in the generic core: *---------------------------------------------------------------- @@ -4481,11 +4489,11 @@ # define TclUniCharNcmp Tcl_UniCharNcmp #endif /* WORDS_BIGENDIAN */ /* *---------------------------------------------------------------- - * Macro used by the Tcl core to increment a namespace's export export epoch + * Macro used by the Tcl core to increment a namespace's export epoch * counter. The ANSI C "prototype" for this macro is: * * MODULE_SCOPE void TclInvalidateNsCmdLookup(Namespace *nsPtr); *---------------------------------------------------------------- */ Index: generic/tclIntDecls.h ================================================================== --- generic/tclIntDecls.h +++ generic/tclIntDecls.h @@ -73,11 +73,12 @@ EXTERN void TclCleanupCommand(Command *cmdPtr); /* 7 */ EXTERN int TclCopyAndCollapse(int count, const char *src, char *dst); /* 8 */ -EXTERN int TclCopyChannelOld(Tcl_Interp *interp, +TCL_DEPRECATED("") +int TclCopyChannelOld(Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, int toRead, Tcl_Obj *cmdPtr); /* 9 */ EXTERN int TclCreatePipeline(Tcl_Interp *interp, int argc, const char **argv, Tcl_Pid **pidArrayPtr, @@ -216,11 +217,12 @@ /* 75 */ EXTERN unsigned long TclpGetClicks(void); /* 76 */ EXTERN unsigned long TclpGetSeconds(void); /* 77 */ -EXTERN void TclpGetTime(Tcl_Time *time); +TCL_DEPRECATED("") +void TclpGetTime(Tcl_Time *time); /* Slot 78 is reserved */ /* Slot 79 is reserved */ /* Slot 80 is reserved */ /* 81 */ EXTERN char * TclpRealloc(char *ptr, unsigned int size); @@ -265,11 +267,12 @@ EXTERN void TclSetupEnv(Tcl_Interp *interp); /* 103 */ EXTERN int TclSockGetPort(Tcl_Interp *interp, const char *str, const char *proto, int *portPtr); /* 104 */ -EXTERN int TclSockMinimumBuffersOld(int sock, int size); +TCL_DEPRECATED("") +int TclSockMinimumBuffersOld(int sock, int size); /* Slot 105 is reserved */ /* Slot 106 is reserved */ /* Slot 107 is reserved */ /* 108 */ EXTERN void TclTeardownNamespace(Namespace *nsPtr); @@ -348,11 +351,12 @@ Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc); /* 132 */ EXTERN int TclpHasSockets(Tcl_Interp *interp); /* 133 */ -EXTERN struct tm * TclpGetDate(const time_t *time, int useGMT); +TCL_DEPRECATED("") +struct tm * TclpGetDate(const time_t *time, int useGMT); /* Slot 134 is reserved */ /* Slot 135 is reserved */ /* Slot 136 is reserved */ /* Slot 137 is reserved */ /* 138 */ @@ -399,13 +403,15 @@ int status); /* 157 */ EXTERN Var * TclVarTraceExists(Tcl_Interp *interp, const char *varName); /* 158 */ -EXTERN void TclSetStartupScriptFileName(const char *filename); +TCL_DEPRECATED("use public Tcl_SetStartupScript()") +void TclSetStartupScriptFileName(const char *filename); /* 159 */ -EXTERN const char * TclGetStartupScriptFileName(void); +TCL_DEPRECATED("use public Tcl_GetStartupScript()") +const char * TclGetStartupScriptFileName(void); /* Slot 160 is reserved */ /* 161 */ EXTERN int TclChannelTransform(Tcl_Interp *interp, Tcl_Channel chan, Tcl_Obj *cmdObjPtr); /* 162 */ @@ -420,13 +426,15 @@ /* 166 */ EXTERN int TclListObjSetElement(Tcl_Interp *interp, Tcl_Obj *listPtr, int index, Tcl_Obj *valuePtr); /* 167 */ -EXTERN void TclSetStartupScriptPath(Tcl_Obj *pathPtr); +TCL_DEPRECATED("use public Tcl_SetStartupScript()") +void TclSetStartupScriptPath(Tcl_Obj *pathPtr); /* 168 */ -EXTERN Tcl_Obj * TclGetStartupScriptPath(void); +TCL_DEPRECATED("use public Tcl_GetStartupScript()") +Tcl_Obj * TclGetStartupScriptPath(void); /* 169 */ EXTERN int TclpUtfNcmp2(const char *s1, const char *s2, unsigned long n); /* 170 */ EXTERN int TclCheckInterpTraces(Tcl_Interp *interp, @@ -462,13 +470,15 @@ /* 179 */ EXTERN Tcl_Obj * Tcl_GetStartupScript(const char **encodingNamePtr); /* Slot 180 is reserved */ /* Slot 181 is reserved */ /* 182 */ -EXTERN struct tm * TclpLocaltime(const time_t *clock); +TCL_DEPRECATED("") +struct tm * TclpLocaltime(const time_t *clock); /* 183 */ -EXTERN struct tm * TclpGmtime(const time_t *clock); +TCL_DEPRECATED("") +struct tm * TclpGmtime(const time_t *clock); /* Slot 184 is reserved */ /* Slot 185 is reserved */ /* Slot 186 is reserved */ /* Slot 187 is reserved */ /* Slot 188 is reserved */ @@ -568,11 +578,12 @@ const char *key, int *newPtr); /* 235 */ EXTERN void TclInitVarHashTable(TclVarHashTable *tablePtr, Namespace *nsPtr); /* 236 */ -EXTERN void TclBackgroundException(Tcl_Interp *interp, int code); +TCL_DEPRECATED("use Tcl_BackgroundException") +void TclBackgroundException(Tcl_Interp *interp, int code); /* 237 */ EXTERN int TclResetCancellation(Tcl_Interp *interp, int force); /* 238 */ EXTERN int TclNRInterpProc(ClientData clientData, Tcl_Interp *interp, int objc, @@ -650,11 +661,11 @@ void (*tclAllocateFreeObjects) (void); /* 3 */ void (*reserved4)(void); int (*tclCleanupChildren) (Tcl_Interp *interp, int numPids, Tcl_Pid *pidPtr, Tcl_Channel errorChan); /* 5 */ void (*tclCleanupCommand) (Command *cmdPtr); /* 6 */ int (*tclCopyAndCollapse) (int count, const char *src, char *dst); /* 7 */ - int (*tclCopyChannelOld) (Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, int toRead, Tcl_Obj *cmdPtr); /* 8 */ + TCL_DEPRECATED_API("") int (*tclCopyChannelOld) (Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, int toRead, Tcl_Obj *cmdPtr); /* 8 */ int (*tclCreatePipeline) (Tcl_Interp *interp, int argc, const char **argv, Tcl_Pid **pidArrayPtr, TclFile *inPipePtr, TclFile *outPipePtr, TclFile *errFilePtr); /* 9 */ int (*tclCreateProc) (Tcl_Interp *interp, Namespace *nsPtr, const char *procName, Tcl_Obj *argsPtr, Tcl_Obj *bodyPtr, Proc **procPtrPtr); /* 10 */ void (*tclDeleteCompiledLocalVars) (Interp *iPtr, CallFrame *framePtr); /* 11 */ void (*tclDeleteVars) (Interp *iPtr, TclVarHashTable *tablePtr); /* 12 */ void (*reserved13)(void); @@ -719,11 +730,11 @@ void (*reserved72)(void); void (*reserved73)(void); void (*tclpFree) (char *ptr); /* 74 */ unsigned long (*tclpGetClicks) (void); /* 75 */ unsigned long (*tclpGetSeconds) (void); /* 76 */ - void (*tclpGetTime) (Tcl_Time *time); /* 77 */ + TCL_DEPRECATED_API("") void (*tclpGetTime) (Tcl_Time *time); /* 77 */ void (*reserved78)(void); void (*reserved79)(void); void (*reserved80)(void); char * (*tclpRealloc) (char *ptr, unsigned int size); /* 81 */ void (*reserved82)(void); @@ -746,11 +757,11 @@ void (*reserved99)(void); void (*reserved100)(void); CONST86 char * (*tclSetPreInitScript) (const char *string); /* 101 */ void (*tclSetupEnv) (Tcl_Interp *interp); /* 102 */ int (*tclSockGetPort) (Tcl_Interp *interp, const char *str, const char *proto, int *portPtr); /* 103 */ - int (*tclSockMinimumBuffersOld) (int sock, int size); /* 104 */ + TCL_DEPRECATED_API("") int (*tclSockMinimumBuffersOld) (int sock, int size); /* 104 */ void (*reserved105)(void); void (*reserved106)(void); void (*reserved107)(void); void (*tclTeardownNamespace) (Namespace *nsPtr); /* 108 */ int (*tclUpdateReturnInfo) (Interp *iPtr); /* 109 */ @@ -775,11 +786,11 @@ void (*tcl_PopCallFrame) (Tcl_Interp *interp); /* 128 */ int (*tcl_PushCallFrame) (Tcl_Interp *interp, Tcl_CallFrame *framePtr, Tcl_Namespace *nsPtr, int isProcCallFrame); /* 129 */ int (*tcl_RemoveInterpResolvers) (Tcl_Interp *interp, const char *name); /* 130 */ void (*tcl_SetNamespaceResolvers) (Tcl_Namespace *namespacePtr, Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc); /* 131 */ int (*tclpHasSockets) (Tcl_Interp *interp); /* 132 */ - struct tm * (*tclpGetDate) (const time_t *time, int useGMT); /* 133 */ + TCL_DEPRECATED_API("") struct tm * (*tclpGetDate) (const time_t *time, int useGMT); /* 133 */ void (*reserved134)(void); void (*reserved135)(void); void (*reserved136)(void); void (*reserved137)(void); CONST84_RETURN char * (*tclGetEnv) (const char *name, Tcl_DString *valuePtr); /* 138 */ @@ -800,21 +811,21 @@ Tcl_Obj * (*tclGetLibraryPath) (void); /* 153 */ void (*reserved154)(void); void (*reserved155)(void); void (*tclRegError) (Tcl_Interp *interp, const char *msg, int status); /* 156 */ Var * (*tclVarTraceExists) (Tcl_Interp *interp, const char *varName); /* 157 */ - void (*tclSetStartupScriptFileName) (const char *filename); /* 158 */ - const char * (*tclGetStartupScriptFileName) (void); /* 159 */ + TCL_DEPRECATED_API("use public Tcl_SetStartupScript()") void (*tclSetStartupScriptFileName) (const char *filename); /* 158 */ + TCL_DEPRECATED_API("use public Tcl_GetStartupScript()") const char * (*tclGetStartupScriptFileName) (void); /* 159 */ void (*reserved160)(void); int (*tclChannelTransform) (Tcl_Interp *interp, Tcl_Channel chan, Tcl_Obj *cmdObjPtr); /* 161 */ void (*tclChannelEventScriptInvoker) (ClientData clientData, int flags); /* 162 */ const void * (*tclGetInstructionTable) (void); /* 163 */ void (*tclExpandCodeArray) (void *envPtr); /* 164 */ void (*tclpSetInitialEncodings) (void); /* 165 */ int (*tclListObjSetElement) (Tcl_Interp *interp, Tcl_Obj *listPtr, int index, Tcl_Obj *valuePtr); /* 166 */ - void (*tclSetStartupScriptPath) (Tcl_Obj *pathPtr); /* 167 */ - Tcl_Obj * (*tclGetStartupScriptPath) (void); /* 168 */ + TCL_DEPRECATED_API("use public Tcl_SetStartupScript()") void (*tclSetStartupScriptPath) (Tcl_Obj *pathPtr); /* 167 */ + TCL_DEPRECATED_API("use public Tcl_GetStartupScript()") Tcl_Obj * (*tclGetStartupScriptPath) (void); /* 168 */ int (*tclpUtfNcmp2) (const char *s1, const char *s2, unsigned long n); /* 169 */ int (*tclCheckInterpTraces) (Tcl_Interp *interp, const char *command, int numChars, Command *cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *const objv[]); /* 170 */ int (*tclCheckExecutionTraces) (Tcl_Interp *interp, const char *command, int numChars, Command *cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *const objv[]); /* 171 */ int (*tclInThreadExit) (void); /* 172 */ int (*tclUniCharMatch) (const Tcl_UniChar *string, int strLen, const Tcl_UniChar *pattern, int ptnLen, int flags); /* 173 */ @@ -824,12 +835,12 @@ void (*tclVarErrMsg) (Tcl_Interp *interp, const char *part1, const char *part2, const char *operation, const char *reason); /* 177 */ void (*tcl_SetStartupScript) (Tcl_Obj *pathPtr, const char *encodingName); /* 178 */ Tcl_Obj * (*tcl_GetStartupScript) (const char **encodingNamePtr); /* 179 */ void (*reserved180)(void); void (*reserved181)(void); - struct tm * (*tclpLocaltime) (const time_t *clock); /* 182 */ - struct tm * (*tclpGmtime) (const time_t *clock); /* 183 */ + TCL_DEPRECATED_API("") struct tm * (*tclpLocaltime) (const time_t *clock); /* 182 */ + TCL_DEPRECATED_API("") struct tm * (*tclpGmtime) (const time_t *clock); /* 183 */ void (*reserved184)(void); void (*reserved185)(void); void (*reserved186)(void); void (*reserved187)(void); void (*reserved188)(void); @@ -878,11 +889,11 @@ int (*tclGetNamespaceFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Namespace **nsPtrPtr); /* 231 */ int (*tclEvalObjEx) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags, const CmdFrame *invoker, int word); /* 232 */ void (*tclGetSrcInfoForPc) (CmdFrame *contextPtr); /* 233 */ Var * (*tclVarHashCreateVar) (TclVarHashTable *tablePtr, const char *key, int *newPtr); /* 234 */ void (*tclInitVarHashTable) (TclVarHashTable *tablePtr, Namespace *nsPtr); /* 235 */ - void (*tclBackgroundException) (Tcl_Interp *interp, int code); /* 236 */ + TCL_DEPRECATED_API("use Tcl_BackgroundException") void (*tclBackgroundException) (Tcl_Interp *interp, int code); /* 236 */ int (*tclResetCancellation) (Tcl_Interp *interp, int force); /* 237 */ int (*tclNRInterpProc) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 238 */ int (*tclNRInterpProcCore) (Tcl_Interp *interp, Tcl_Obj *procNameObj, int skip, ProcErrorProc *errorProc); /* 239 */ int (*tclNRRunCallbacks) (Tcl_Interp *interp, int result, struct NRE_callback *rootPtr); /* 240 */ int (*tclNREvalObjEx) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags, const CmdFrame *invoker, int word); /* 241 */ @@ -1354,11 +1365,11 @@ #undef TclSetStartupScriptFileName #undef TclGetStartupScriptPath #undef TclSetStartupScriptPath #undef TclBackgroundException -#if defined(USE_TCL_STUBS) && defined(TCL_NO_DEPRECATED) +#if defined(USE_TCL_STUBS) # undef Tcl_SetStartupScript # define Tcl_SetStartupScript \ (tclStubsPtr->tcl_SetStartupScript) /* 622 */ # undef Tcl_GetStartupScript # define Tcl_GetStartupScript \ Index: generic/tclListObj.c ================================================================== --- generic/tclListObj.c +++ generic/tclListObj.c @@ -1955,12 +1955,12 @@ static void UpdateStringOfList( Tcl_Obj *listPtr) /* List object with string rep to update. */ { -# define LOCAL_SIZE 20 - int localFlags[LOCAL_SIZE], *flagPtr = NULL; +# define LOCAL_SIZE 64 + char localFlags[LOCAL_SIZE], *flagPtr = NULL; List *listRepPtr = ListRepPtr(listPtr); int numElems = listRepPtr->elemCount; int i, length, bytesNeeded = 0; const char *elem; char *dst; @@ -1993,11 +1993,11 @@ } else { /* * We know numElems <= LIST_MAX, so this is safe. */ - flagPtr = ckalloc(numElems * sizeof(int)); + flagPtr = ckalloc(numElems); } elemPtrs = &listRepPtr->elements; for (i = 0; i < numElems; i++) { flagPtr[i] = (i ? TCL_DONT_QUOTE_HASH : 0); elem = TclGetStringFromObj(elemPtrs[i], &length); Index: generic/tclMain.c ================================================================== --- generic/tclMain.c +++ generic/tclMain.c @@ -264,22 +264,18 @@ * Test for the existence of the rc file before trying to read it. */ c = Tcl_OpenFileChannel(NULL, fullName, "r", 0); if (c != NULL) { - Tcl_Obj *fullNameObj = Tcl_NewStringObj(fullName, -1); - Tcl_Close(NULL, c); - Tcl_IncrRefCount(fullNameObj); - if (Tcl_FSEvalFileEx(interp, fullNameObj, NULL) != TCL_OK) { + if (Tcl_EvalFile(interp, fullName) != TCL_OK) { chan = Tcl_GetStdChannel(TCL_STDERR); if (chan) { Tcl_WriteObj(chan, Tcl_GetObjResult(interp)); Tcl_WriteChars(chan, "\n", 1); } } - Tcl_DecrRefCount(fullNameObj); } } Tcl_DStringFree(&temp); } } Index: generic/tclOO.c ================================================================== --- generic/tclOO.c +++ generic/tclOO.c @@ -536,11 +536,12 @@ * ---------------------------------------------------------------------- * * AllocObject -- * * Allocate an object of basic type. Does not splice the object into its - * class's instance list. + * class's instance list. The caller must set the classPtr on the object, + * either to a class or to NULL. * * ---------------------------------------------------------------------- */ static Object * @@ -1699,10 +1700,12 @@ */ AllocClass(interp, oPtr); oPtr->selfCls = classPtr; TclOOAddToSubclasses(oPtr->classPtr, fPtr->objectCls); + } else { + oPtr->classPtr = NULL; } /* * Run constructors, except when objc < 0 (a special flag case used for * object cloning only). Index: generic/tclPkg.c ================================================================== --- generic/tclPkg.c +++ generic/tclPkg.c @@ -416,11 +416,11 @@ void *clientDataPtr) { Interp *iPtr = (Interp *) interp; Package *pkgPtr; PkgAvail *availPtr, *bestPtr, *bestStablePtr; - char *availVersion, *bestVersion; + char *availVersion, *bestVersion, *bestStableVersion; /* Internal rep. of versions */ int availStable, code, satisfies, pass; char *script, *pkgVersionI; Tcl_DString command; @@ -464,10 +464,11 @@ */ bestPtr = NULL; bestStablePtr = NULL; bestVersion = NULL; + bestStableVersion = NULL; for (availPtr = pkgPtr->availPtr; availPtr != NULL; availPtr = availPtr->nextPtr) { if (CheckVersionAndConvert(interp, availPtr->version, &availVersion, &availStable) != TCL_OK) { @@ -478,63 +479,85 @@ */ continue; } - if (bestPtr != NULL) { - int res = CompareVersions(availVersion, bestVersion, NULL); - - /* - * Note: Use internal reps! - */ - - if (res <= 0) { - /* - * The version of the package sought is not as good as the - * currently selected version. Ignore it. - */ - - ckfree(availVersion); - availVersion = NULL; - continue; - } - } - - /* - * We have found a version which is better than our max. - */ - + /* Check satisfaction of requirements before considering the current version further. */ if (reqc > 0) { - /* Check satisfaction of requirements. */ - satisfies = SomeRequirementSatisfied(availVersion, reqc, reqv); if (!satisfies) { ckfree(availVersion); availVersion = NULL; continue; } } - bestPtr = availPtr; - - if (bestVersion != NULL) { - ckfree(bestVersion); - } - bestVersion = availVersion; - - /* - * If this new best version is stable then it also has to be - * better than the max stable version found so far. - */ - - if (availStable) { + if (bestPtr != NULL) { + int res = CompareVersions(availVersion, bestVersion, NULL); + + /* + * Note: Used internal reps in the comparison! + */ + + if (res > 0) { + /* + * The version of the package sought is better than the + * currently selected version. + */ + goto newbest; + } + } else { + newbest: + /* We have found a version which is better than our max. */ + + bestPtr = availPtr; + CheckVersionAndConvert(interp, bestPtr->version, &bestVersion, NULL); + } + + if (!availStable) { + ckfree(availVersion); + availVersion = NULL; + continue; + } + + if (bestStablePtr != NULL) { + int res = CompareVersions(availVersion, bestStableVersion, NULL); + + /* + * Note: Used internal reps in the comparison! + */ + + if (res > 0) { + /* + * This stable version of the package sought is better + * than the currently selected stable version. + */ + goto newstable; + } + } else { + newstable: + /* We have found a stable version which is better than our max stable. */ bestStablePtr = availPtr; + CheckVersionAndConvert(interp, bestStablePtr->version, &bestStableVersion, NULL); } - } + + ckfree(availVersion); + availVersion = NULL; + } /* end for */ + + /* + * Clean up memorized internal reps, if any. + */ if (bestVersion != NULL) { ckfree(bestVersion); + bestVersion = NULL; + } + + if (bestStableVersion != NULL) { + ckfree(bestStableVersion); + bestStableVersion = NULL; } /* * Now choose a version among the two best. For 'latest' we simply * take (actually keep) the best. For 'stable' we take the best Index: generic/tclPkgConfig.c ================================================================== --- generic/tclPkgConfig.c +++ generic/tclPkgConfig.c @@ -103,10 +103,12 @@ {"libdir,runtime", CFG_RUNTIME_LIBDIR}, {"bindir,runtime", CFG_RUNTIME_BINDIR}, {"scriptdir,runtime", CFG_RUNTIME_SCRDIR}, {"includedir,runtime", CFG_RUNTIME_INCDIR}, {"docdir,runtime", CFG_RUNTIME_DOCDIR}, + {"dllfile,runtime", CFG_RUNTIME_DLLFILE}, + {"zipfile,runtime", CFG_RUNTIME_ZIPFILE}, /* Installation paths to various stuff */ {"libdir,install", CFG_INSTALL_LIBDIR}, {"bindir,install", CFG_INSTALL_BINDIR}, Index: generic/tclProc.c ================================================================== --- generic/tclProc.c +++ generic/tclProc.c @@ -391,17 +391,17 @@ Tcl_Obj *argsPtr, /* Description of arguments. */ Tcl_Obj *bodyPtr, /* Command body. */ Proc **procPtrPtr) /* Returns: pointer to proc data. */ { Interp *iPtr = (Interp *) interp; - const char **argArray = NULL; register Proc *procPtr; - int i, length, result, numArgs; - const char *args, *bytes, *p; + int i, result, numArgs, plen; + const char *bytes, *argname, *argnamei; + char argnamelast; register CompiledLocal *localPtr = NULL; - Tcl_Obj *defPtr; + Tcl_Obj *defPtr, *errorObj, **argArray; int precompiled = 0; if (bodyPtr->typePtr == &tclProcBodyType) { /* * Because the body is a TclProProcBody, the actual body is already @@ -434,10 +434,11 @@ * identical. Note that we don't use Tcl_DuplicateObj since we would * not want any bytecode internal representation. */ if (Tcl_IsShared(bodyPtr)) { + int length; Tcl_Obj *sharedBodyPtr = bodyPtr; bytes = TclGetStringFromObj(bodyPtr, &length); bodyPtr = Tcl_NewStringObj(bytes, length); @@ -471,16 +472,13 @@ /* * Break up the argument list into argument specifiers, then process each * argument specifier. If the body is precompiled, processing is limited * to checking that the parsed argument is consistent with the one stored * in the Proc. - * - * THIS FAILS IF THE ARG LIST OBJECT'S STRING REP CONTAINS NULS. */ - args = TclGetStringFromObj(argsPtr, &length); - result = Tcl_SplitList(interp, args, &numArgs, &argArray); + result = Tcl_ListObjGetElements(interp , argsPtr ,&numArgs ,&argArray); if (result != TCL_OK) { goto procError; } if (precompiled) { @@ -500,77 +498,74 @@ } for (i = 0; i < numArgs; i++) { int fieldCount, nameLength; size_t valueLength; - const char **fieldValues; + Tcl_Obj **fieldValues; /* * Now divide the specifier up into name and default. */ - result = Tcl_SplitList(interp, argArray[i], &fieldCount, + result = Tcl_ListObjGetElements(interp, argArray[i], &fieldCount, &fieldValues); if (result != TCL_OK) { goto procError; } if (fieldCount > 2) { - ckfree(fieldValues); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "too many fields in argument specifier \"%s\"", - argArray[i])); + errorObj = Tcl_NewStringObj( + "too many fields in argument specifier \"", -1); + Tcl_AppendObjToObj(errorObj, argArray[i]); + Tcl_AppendToObj(errorObj, "\"", -1); + Tcl_SetObjResult(interp, errorObj); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "FORMALARGUMENTFORMAT", NULL); goto procError; } - if ((fieldCount == 0) || (*fieldValues[0] == 0)) { - ckfree(fieldValues); + if ((fieldCount == 0) || (fieldValues[0]->length == 0)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "argument with no name", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "FORMALARGUMENTFORMAT", NULL); goto procError; } - nameLength = strlen(fieldValues[0]); + nameLength = Tcl_NumUtfChars(Tcl_GetString(fieldValues[0]), fieldValues[0]->length); if (fieldCount == 2) { - valueLength = strlen(fieldValues[1]); + valueLength = Tcl_NumUtfChars(Tcl_GetString(fieldValues[1]), + fieldValues[1]->length); } else { valueLength = 0; } /* * Check that the formal parameter name is a scalar. */ - p = fieldValues[0]; - while (*p != '\0') { - if (*p == '(') { - const char *q = p; - do { - q++; - } while (*q != '\0'); - q--; - if (*q == ')') { /* We have an array element. */ + argname = Tcl_GetStringFromObj(fieldValues[0], &plen); + argnamei = argname; + argnamelast = argname[plen-1]; + while (plen--) { + if (argnamei[0] == '(') { + if (argnamelast == ')') { /* We have an array element. */ Tcl_SetObjResult(interp, Tcl_ObjPrintf( "formal parameter \"%s\" is an array element", - fieldValues[0])); - ckfree(fieldValues); + Tcl_GetString(fieldValues[0]))); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "FORMALARGUMENTFORMAT", NULL); goto procError; } - } else if ((*p == ':') && (*(p+1) == ':')) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "formal parameter \"%s\" is not a simple name", - fieldValues[0])); - ckfree(fieldValues); + } else if ((argnamei[0] == ':') && (argnamei[1] == ':')) { + errorObj = Tcl_NewStringObj("formal parameter \"", -1); + Tcl_AppendObjToObj(errorObj, fieldValues[0]); + Tcl_AppendToObj(errorObj, "\" is not a simple name", -1); + Tcl_SetObjResult(interp, errorObj); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "FORMALARGUMENTFORMAT", NULL); goto procError; } - p++; + argnamei = Tcl_UtfNext(argnamei); } if (precompiled) { /* * Compare the parsed argument with the stored one. Note that the @@ -582,19 +577,18 @@ * precompiled procs is VAR_TEMPORARY (also unchanged). It is * needed later when retrieving the variable names. */ if ((localPtr->nameLength != nameLength) - || (strcmp(localPtr->name, fieldValues[0])) + || (Tcl_UtfNcmp(localPtr->name, argname, nameLength)) || (localPtr->frameIndex != i) || !(localPtr->flags & VAR_ARGUMENT) || (localPtr->defValuePtr == NULL && fieldCount == 2) || (localPtr->defValuePtr != NULL && fieldCount != 2)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "procedure \"%s\": formal parameter %d is " "inconsistent with precompiled body", procName, i)); - ckfree(fieldValues); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "BYTECODELIES", NULL); goto procError; } @@ -605,16 +599,17 @@ if (localPtr->defValuePtr != NULL) { const char *tmpPtr = TclGetString(localPtr->defValuePtr); size_t tmpLength = localPtr->defValuePtr->length; if ((valueLength != tmpLength) || - strncmp(fieldValues[1], tmpPtr, tmpLength)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "procedure \"%s\": formal parameter \"%s\" has " - "default value inconsistent with precompiled body", - procName, fieldValues[0])); - ckfree(fieldValues); + Tcl_UtfNcmp(Tcl_GetString(fieldValues[1]), tmpPtr, tmpLength)) { + errorObj = Tcl_ObjPrintf( + "procedure \"%s\": formal parameter \"" ,procName); + Tcl_AppendObjToObj(errorObj, fieldValues[0]); + Tcl_AppendToObj(errorObj, "\" has " + "default value inconsistent with precompiled body", -1); + Tcl_SetObjResult(interp, errorObj); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "BYTECODELIES", NULL); goto procError; } } @@ -630,44 +625,40 @@ /* * Allocate an entry in the runtime procedure frame's array of * local variables for the argument. */ - localPtr = ckalloc(TclOffset(CompiledLocal, name) + nameLength+1); + localPtr = ckalloc(TclOffset(CompiledLocal, name) + fieldValues[0]->length +1); if (procPtr->firstLocalPtr == NULL) { procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr; } else { procPtr->lastLocalPtr->nextPtr = localPtr; procPtr->lastLocalPtr = localPtr; } localPtr->nextPtr = NULL; - localPtr->nameLength = nameLength; + localPtr->nameLength = Tcl_NumUtfChars(argname, fieldValues[0]->length); localPtr->frameIndex = i; localPtr->flags = VAR_ARGUMENT; localPtr->resolveInfo = NULL; if (fieldCount == 2) { - localPtr->defValuePtr = - Tcl_NewStringObj(fieldValues[1], valueLength); + localPtr->defValuePtr = fieldValues[1]; Tcl_IncrRefCount(localPtr->defValuePtr); } else { localPtr->defValuePtr = NULL; } - memcpy(localPtr->name, fieldValues[0], nameLength + 1); + memcpy(localPtr->name, argname, fieldValues[0]->length + 1); if ((i == numArgs - 1) && (localPtr->nameLength == 4) && (localPtr->name[0] == 'a') && (strcmp(localPtr->name, "args") == 0)) { localPtr->flags |= VAR_IS_ARGS; } } - - ckfree(fieldValues); } *procPtrPtr = procPtr; - ckfree(argArray); return TCL_OK; procError: if (precompiled) { procPtr->refCount--; @@ -684,13 +675,10 @@ ckfree(localPtr); } ckfree(procPtr); } - if (argArray != NULL) { - ckfree(argArray); - } return TCL_ERROR; } /* *---------------------------------------------------------------------- Index: generic/tclScan.c ================================================================== --- generic/tclScan.c +++ generic/tclScan.c @@ -883,13 +883,21 @@ case 'c': /* * Scan a single Unicode character. */ - string += TclUtfToUniChar(string, &sch); + offset = TclUtfToUniChar(string, &sch); + i = (int)sch; +#if TCL_UTF_MAX == 4 + if (!offset) { + offset = Tcl_UtfToUniChar(string, &sch); + i = (((i<<10) & 0x0FFC00) + 0x10000) + (sch & 0x3FF); + } +#endif + string += offset; if (!(flags & SCAN_SUPPRESS)) { - objPtr = Tcl_NewIntObj((int)sch); + objPtr = Tcl_NewIntObj(i); Tcl_IncrRefCount(objPtr); CLANG_ASSERT(objs); objs[objIndex++] = objPtr; } break; Index: generic/tclStringObj.c ================================================================== --- generic/tclStringObj.c +++ generic/tclStringObj.c @@ -3240,44 +3240,48 @@ try++; } return -1; } + /* + * Check if we have two strings of single-byte characters. If we have, we + * can use strstr() to do the search. Note that we can sometimes have + * multibyte characters when the string could be minimally represented + * using single byte characters; we can't assume that a mismatch here + * means no match. + */ + lh = Tcl_GetCharLength(haystack); - if (haystack->bytes && (lh == haystack->length)) { - /* haystack is all single-byte chars */ - - if (needle->bytes && (ln == needle->length)) { - /* needle is also all single-byte chars */ - char *found = strstr(haystack->bytes + start, needle->bytes); - - if (found) { - return (found - haystack->bytes); - } else { - return -1; - } - } else { - /* - * Cannot find substring with a multi-byte char inside - * a string with no multi-byte chars. - */ + if (haystack->bytes && (lh == haystack->length) && needle->bytes + && (ln == needle->length)) { + /* + * Both haystack and needle are all single-byte chars. + */ + + char *found = strstr(haystack->bytes + start, needle->bytes); + + if (found) { + return (found - haystack->bytes); + } else { return -1; } } else { + /* + * Do the search on the unicode representation for simplicity. + */ + Tcl_UniChar *try, *end, *uh; Tcl_UniChar *un = Tcl_GetUnicodeFromObj(needle, &ln); uh = Tcl_GetUnicodeFromObj(haystack, &lh); end = uh + lh; - try = uh + start; - while (try + ln <= end) { - if ((*try == *un) - && (0 == memcmp(try+1, un+1, (ln-1)*sizeof(Tcl_UniChar)))) { + for (try = uh + start; try + ln <= end; try++) { + if ((*try == *un) && (0 == + memcmp(try + 1, un + 1, (ln-1) * sizeof(Tcl_UniChar)))) { return (try - uh); } - try++; } return -1; } } @@ -3456,11 +3460,10 @@ /* * Create a non-empty, pure unicode value, so we can coax * Tcl_SetObjLength into growing the unicode rep buffer. */ - ch = 0; objPtr = Tcl_NewUnicodeObj(&ch, 1); Tcl_SetObjLength(objPtr, stringPtr->numChars); to = Tcl_GetUnicode(objPtr); while (--src >= from) { *to++ = *src; @@ -3559,11 +3562,11 @@ int numBytes, int numAppendChars) { String *stringPtr = GET_STRING(objPtr); int needed, numOrigChars = 0; - Tcl_UniChar *dst; + Tcl_UniChar *dst, unichar = 0; if (stringPtr->hasUnicode) { numOrigChars = stringPtr->numChars; } if (numAppendChars == -1) { @@ -3582,11 +3585,12 @@ stringPtr->numChars = needed; } else { numAppendChars = 0; } for (dst=stringPtr->unicode + numOrigChars; numAppendChars-- > 0; dst++) { - bytes += TclUtfToUniChar(bytes, dst); + bytes += TclUtfToUniChar(bytes, &unichar); + *dst = unichar; } *dst = 0; } /* Index: generic/tclStubInit.c ================================================================== --- generic/tclStubInit.c +++ generic/tclStubInit.c @@ -70,10 +70,15 @@ # define TclWinSetSockOpt 0 # define TclWinNToHS 0 # define TclBNInitBignumFromWideUInt 0 # define TclBNInitBignumFromWideInt 0 # define TclBNInitBignumFromLong 0 +# define Tcl_AppendResultVA 0 +# define Tcl_AppendStringsToObjVA 0 +# define Tcl_SetErrorCodeVA 0 +# define Tcl_PanicVA 0 +# define Tcl_VarEvalVA 0 #else #define TclSetStartupScriptPath setStartupScriptPath static void TclSetStartupScriptPath(Tcl_Obj *path) { Tcl_SetStartupScript(path, NULL); @@ -1534,8 +1539,11 @@ Tcl_LoadFile, /* 627 */ Tcl_FindSymbol, /* 628 */ Tcl_FSUnloadFile, /* 629 */ Tcl_ZlibStreamSetCompressionDictionary, /* 630 */ Tcl_OpenTcpServerEx, /* 631 */ + TclZipfs_Mount, /* 632 */ + TclZipfs_Unmount, /* 633 */ + TclZipfs_AppHook, /* 634 */ }; /* !END!: Do not edit above this line. */ Index: generic/tclUtil.c ================================================================== --- generic/tclUtil.c +++ generic/tclUtil.c @@ -972,11 +972,11 @@ const char *src, /* String to convert to Tcl list element. */ int length, /* Number of bytes in src, or -1. */ int *flagPtr) /* Where to store information to guide * Tcl_ConvertElement. */ { - int flags = CONVERT_ANY; + char flags = CONVERT_ANY; int numBytes = TclScanElement(src, length, &flags); *flagPtr = flags; return numBytes; } @@ -1013,11 +1013,11 @@ int TclScanElement( const char *src, /* String to convert to Tcl list element. */ int length, /* Number of bytes in src, or -1. */ - int *flagPtr) /* Where to store information to guide + char *flagPtr) /* Where to store information to guide * Tcl_ConvertElement. */ { const char *p = src; int nestingLevel = 0; /* Brace nesting count */ int forbidNone = 0; /* Do not permit CONVERT_NONE mode. Something @@ -1545,15 +1545,14 @@ char * Tcl_Merge( int argc, /* How many strings to merge. */ const char *const *argv) /* Array of string values. */ { -#define LOCAL_SIZE 20 - int localFlags[LOCAL_SIZE], *flagPtr = NULL; +#define LOCAL_SIZE 64 + char localFlags[LOCAL_SIZE], *flagPtr = NULL; int i, bytesNeeded = 0; char *result, *dst; - const int maxFlags = UINT_MAX / sizeof(int); /* * Handle empty list case first, so logic of the general case can be * simpler. */ @@ -1568,26 +1567,12 @@ * Pass 1: estimate space, gather flags. */ if (argc <= LOCAL_SIZE) { flagPtr = localFlags; - } else if (argc > maxFlags) { - /* - * We cannot allocate a large enough flag array to format this list in - * one pass. We could imagine converting this routine to a multi-pass - * implementation, but for sizeof(int) == 4, the limit is a max of - * 2^30 list elements and since each element is at least one byte - * formatted, and requires one byte space between it and the next one, - * that a minimum space requirement of 2^31 bytes, which is already - * INT_MAX. If we tried to format a list of > maxFlags elements, we're - * just going to overflow the size limits on the formatted string - * anyway, so just issue that same panic early. - */ - - Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } else { - flagPtr = ckalloc(argc * sizeof(int)); + flagPtr = ckalloc(argc); } for (i = 0; i < argc; i++) { flagPtr[i] = ( i ? TCL_DONT_QUOTE_HASH : 0 ); bytesNeeded += TclScanElement(argv[i], -1, &flagPtr[i]); if (bytesNeeded < 0) { @@ -2715,11 +2700,11 @@ const char *element) /* String to append. Must be * null-terminated. */ { char *dst = dsPtr->string + dsPtr->length; int needSpace = TclNeedSpace(dsPtr->string, dst); - int flags = needSpace ? TCL_DONT_QUOTE_HASH : 0; + char flags = needSpace ? TCL_DONT_QUOTE_HASH : 0; int newSize = dsPtr->length + needSpace + TclScanElement(element, -1, &flags); /* * Allocate a larger buffer for the string if the current one isn't large ADDED generic/tclZipfs.c Index: generic/tclZipfs.c ================================================================== --- /dev/null +++ generic/tclZipfs.c @@ -0,0 +1,3957 @@ +/* + * tclZipfs.c -- + * + * Implementation of the ZIP filesystem used in TIP 430 + * Adapted from the implentation for AndroWish. + * + * Coptright (c) 2016-2017 Sean Woods + * Copyright (c) 2013-2015 Christian Werner + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +#include "tclInt.h" +#include "tclFileSystem.h" + +#if !defined(_WIN32) && !defined(_WIN64) +#include +#endif +#include +#include +#include +#include +#include +#include + +#ifdef HAVE_ZLIB +#include "zlib.h" +#include "crypt.h" + +#define ZIPFS_VOLUME "//zipfs:/" +#define ZIPFS_APP_MOUNT "//zipfs:/app" +#define ZIPFS_ZIP_MOUNT "//zipfs:/lib/tcl" + +#define ZIPFS_VOLUME_LEN 9 + +/* + * Various constants and offsets found in ZIP archive files + */ + +#define ZIP_SIG_LEN 4 + +/* Local header of ZIP archive member (at very beginning of each member). */ +#define ZIP_LOCAL_HEADER_SIG 0x04034b50 +#define ZIP_LOCAL_HEADER_LEN 30 +#define ZIP_LOCAL_SIG_OFFS 0 +#define ZIP_LOCAL_VERSION_OFFS 4 +#define ZIP_LOCAL_FLAGS_OFFS 6 +#define ZIP_LOCAL_COMPMETH_OFFS 8 +#define ZIP_LOCAL_MTIME_OFFS 10 +#define ZIP_LOCAL_MDATE_OFFS 12 +#define ZIP_LOCAL_CRC32_OFFS 14 +#define ZIP_LOCAL_COMPLEN_OFFS 18 +#define ZIP_LOCAL_UNCOMPLEN_OFFS 22 +#define ZIP_LOCAL_PATHLEN_OFFS 26 +#define ZIP_LOCAL_EXTRALEN_OFFS 28 + +/* Central header of ZIP archive member at end of ZIP file. */ +#define ZIP_CENTRAL_HEADER_SIG 0x02014b50 +#define ZIP_CENTRAL_HEADER_LEN 46 +#define ZIP_CENTRAL_SIG_OFFS 0 +#define ZIP_CENTRAL_VERSIONMADE_OFFS 4 +#define ZIP_CENTRAL_VERSION_OFFS 6 +#define ZIP_CENTRAL_FLAGS_OFFS 8 +#define ZIP_CENTRAL_COMPMETH_OFFS 10 +#define ZIP_CENTRAL_MTIME_OFFS 12 +#define ZIP_CENTRAL_MDATE_OFFS 14 +#define ZIP_CENTRAL_CRC32_OFFS 16 +#define ZIP_CENTRAL_COMPLEN_OFFS 20 +#define ZIP_CENTRAL_UNCOMPLEN_OFFS 24 +#define ZIP_CENTRAL_PATHLEN_OFFS 28 +#define ZIP_CENTRAL_EXTRALEN_OFFS 30 +#define ZIP_CENTRAL_FCOMMENTLEN_OFFS 32 +#define ZIP_CENTRAL_DISKFILE_OFFS 34 +#define ZIP_CENTRAL_IATTR_OFFS 36 +#define ZIP_CENTRAL_EATTR_OFFS 38 +#define ZIP_CENTRAL_LOCALHDR_OFFS 42 + +/* Central end signature at very end of ZIP file. */ +#define ZIP_CENTRAL_END_SIG 0x06054b50 +#define ZIP_CENTRAL_END_LEN 22 +#define ZIP_CENTRAL_END_SIG_OFFS 0 +#define ZIP_CENTRAL_DISKNO_OFFS 4 +#define ZIP_CENTRAL_DISKDIR_OFFS 6 +#define ZIP_CENTRAL_ENTS_OFFS 8 +#define ZIP_CENTRAL_TOTALENTS_OFFS 10 +#define ZIP_CENTRAL_DIRSIZE_OFFS 12 +#define ZIP_CENTRAL_DIRSTART_OFFS 16 +#define ZIP_CENTRAL_COMMENTLEN_OFFS 20 + +#define ZIP_MIN_VERSION 20 +#define ZIP_COMPMETH_STORED 0 +#define ZIP_COMPMETH_DEFLATED 8 + +#define ZIP_PASSWORD_END_SIG 0x5a5a4b50 + +/* + * Macros to read and write 16 and 32 bit integers from/to ZIP archives. + */ + +#define zip_read_int(p) \ + ((p)[0] | ((p)[1] << 8) | ((p)[2] << 16) | ((p)[3] << 24)) +#define zip_read_short(p) \ + ((p)[0] | ((p)[1] << 8)) + +#define zip_write_int(p, v) \ + (p)[0] = (v) & 0xff; (p)[1] = ((v) >> 8) & 0xff; \ + (p)[2] = ((v) >> 16) & 0xff; (p)[3] = ((v) >> 24) & 0xff; +#define zip_write_short(p, v) \ + (p)[0] = (v) & 0xff; (p)[1] = ((v) >> 8) & 0xff; + +/* + * Windows drive letters. + */ + +#if defined(_WIN32) || defined(_WIN64) +#define HAS_DRIVES 1 +static const char drvletters[] = + "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"; +#else +#define HAS_DRIVES 0 +#endif + +/* + * Mutex to protect localtime(3) when no reentrant version available. + */ + +#if !defined(_WIN32) && !defined(_WIN64) +#ifndef HAVE_LOCALTIME_R +#ifdef TCL_THREADS +TCL_DECLARE_MUTEX(localtimeMutex) +#endif +#endif +#endif + +/* + * In-core description of mounted ZIP archive file. + */ + +typedef struct ZipFile { + char *name; /* Archive name */ + Tcl_Channel chan; /* Channel handle or NULL */ + unsigned char *data; /* Memory mapped or malloc'ed file */ + long length; /* Length of memory mapped file */ + unsigned char *tofree; /* Non-NULL if malloc'ed file */ + int nfiles; /* Number of files in archive */ + int baseoffs; /* Archive start */ + int baseoffsp; /* Password start */ + int centoffs; /* Archive directory start */ + char pwbuf[264]; /* Password buffer */ +#if defined(_WIN32) || defined(_WIN64) + HANDLE mh; +#endif + int nopen; /* Number of open files on archive */ + struct ZipEntry *entries; /* List of files in archive */ + struct ZipEntry *topents; /* List of top-level dirs in archive */ +#if HAS_DRIVES + int mntdrv; /* Drive letter of mount point */ +#endif + int mntptlen; /* Length of mount point */ + char mntpt[1]; /* Mount point */ +} ZipFile; + +/* + * In-core description of file contained in mounted ZIP archive. + */ + +typedef struct ZipEntry { + char *name; /* The full pathname of the virtual file */ + ZipFile *zipfile; /* The ZIP file holding this virtual file */ + long offset; /* Data offset into memory mapped ZIP file */ + int nbyte; /* Uncompressed size of the virtual file */ + int nbytecompr; /* Compressed size of the virtual file */ + int cmeth; /* Compress method */ + int isdir; /* Set to 1 if directory */ + int depth; /* Number of slashes in path. */ + int crc32; /* CRC-32 */ + int timestamp; /* Modification time */ + int isenc; /* True if data is encrypted */ + unsigned char *data; /* File data if written */ + struct ZipEntry *next; /* Next file in the same archive */ + struct ZipEntry *tnext; /* Next top-level dir in archive */ +} ZipEntry; + +/* + * File channel for file contained in mounted ZIP archive. + */ + +typedef struct ZipChannel { + ZipFile *zipfile; /* The ZIP file holding this channel */ + ZipEntry *zipentry; /* Pointer back to virtual file */ + unsigned long nmax; /* Max. size for write */ + unsigned long nbyte; /* Number of bytes of uncompressed data */ + unsigned long nread; /* Pos of next byte to be read from the channel */ + unsigned char *ubuf; /* Pointer to the uncompressed data */ + int iscompr; /* True if data is compressed */ + int isdir; /* Set to 1 if directory */ + int isenc; /* True if data is encrypted */ + int iswr; /* True if open for writing */ + unsigned long keys[3]; /* Key for decryption */ +} ZipChannel; + +/* + * Global variables. + * + * Most are kept in single ZipFS struct. When build with threading + * support this struct is protected by the ZipFSMutex (see below). + * + * The "fileHash" component is the process wide global table of all known + * ZIP archive members in all mounted ZIP archives. + * + * The "zipHash" components is the process wide global table of all mounted + * ZIP archive files. + */ + +static struct { + int initialized; /* True when initialized */ + int lock; /* RW lock, see below */ + int waiters; /* RW lock, see below */ + int wrmax; /* Maximum write size of a file */ + int idCount; /* Counter for channel names */ + Tcl_HashTable fileHash; /* File name to ZipEntry mapping */ + Tcl_HashTable zipHash; /* Mount to ZipFile mapping */ +} ZipFS = { + 0, 0, 0, 0, 0, +}; + +/* + * For password rotation. + */ + +static const char pwrot[16] = { + 0x00, 0x80, 0x40, 0xc0, 0x20, 0xa0, 0x60, 0xe0, + 0x10, 0x90, 0x50, 0xd0, 0x30, 0xb0, 0x70, 0xf0 +}; + +/* + * Table to compute CRC32. + */ + +static const unsigned 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, + 0xa2677172, 0x3c03e4d1, 0x4b04d447, 0xd20d85fd, 0xa50ab56b, + 0x35b5a8fa, 0x42b2986c, 0xdbbbc9d6, 0xacbcf940, 0x32d86ce3, + 0x45df5c75, 0xdcd60dcf, 0xabd13d59, 0x26d930ac, 0x51de003a, + 0xc8d75180, 0xbfd06116, 0x21b4f4b5, 0x56b3c423, 0xcfba9599, + 0xb8bda50f, 0x2802b89e, 0x5f058808, 0xc60cd9b2, 0xb10be924, + 0x2f6f7c87, 0x58684c11, 0xc1611dab, 0xb6662d3d, 0x76dc4190, + 0x01db7106, 0x98d220bc, 0xefd5102a, 0x71b18589, 0x06b6b51f, + 0x9fbfe4a5, 0xe8b8d433, 0x7807c9a2, 0x0f00f934, 0x9609a88e, + 0xe10e9818, 0x7f6a0dbb, 0x086d3d2d, 0x91646c97, 0xe6635c01, + 0x6b6b51f4, 0x1c6c6162, 0x856530d8, 0xf262004e, 0x6c0695ed, + 0x1b01a57b, 0x8208f4c1, 0xf50fc457, 0x65b0d9c6, 0x12b7e950, + 0x8bbeb8ea, 0xfcb9887c, 0x62dd1ddf, 0x15da2d49, 0x8cd37cf3, + 0xfbd44c65, 0x4db26158, 0x3ab551ce, 0xa3bc0074, 0xd4bb30e2, + 0x4adfa541, 0x3dd895d7, 0xa4d1c46d, 0xd3d6f4fb, 0x4369e96a, + 0x346ed9fc, 0xad678846, 0xda60b8d0, 0x44042d73, 0x33031de5, + 0xaa0a4c5f, 0xdd0d7cc9, 0x5005713c, 0x270241aa, 0xbe0b1010, + 0xc90c2086, 0x5768b525, 0x206f85b3, 0xb966d409, 0xce61e49f, + 0x5edef90e, 0x29d9c998, 0xb0d09822, 0xc7d7a8b4, 0x59b33d17, + 0x2eb40d81, 0xb7bd5c3b, 0xc0ba6cad, 0xedb88320, 0x9abfb3b6, + 0x03b6e20c, 0x74b1d29a, 0xead54739, 0x9dd277af, 0x04db2615, + 0x73dc1683, 0xe3630b12, 0x94643b84, 0x0d6d6a3e, 0x7a6a5aa8, + 0xe40ecf0b, 0x9309ff9d, 0x0a00ae27, 0x7d079eb1, 0xf00f9344, + 0x8708a3d2, 0x1e01f268, 0x6906c2fe, 0xf762575d, 0x806567cb, + 0x196c3671, 0x6e6b06e7, 0xfed41b76, 0x89d32be0, 0x10da7a5a, + 0x67dd4acc, 0xf9b9df6f, 0x8ebeeff9, 0x17b7be43, 0x60b08ed5, + 0xd6d6a3e8, 0xa1d1937e, 0x38d8c2c4, 0x4fdff252, 0xd1bb67f1, + 0xa6bc5767, 0x3fb506dd, 0x48b2364b, 0xd80d2bda, 0xaf0a1b4c, + 0x36034af6, 0x41047a60, 0xdf60efc3, 0xa867df55, 0x316e8eef, + 0x4669be79, 0xcb61b38c, 0xbc66831a, 0x256fd2a0, 0x5268e236, + 0xcc0c7795, 0xbb0b4703, 0x220216b9, 0x5505262f, 0xc5ba3bbe, + 0xb2bd0b28, 0x2bb45a92, 0x5cb36a04, 0xc2d7ffa7, 0xb5d0cf31, + 0x2cd99e8b, 0x5bdeae1d, 0x9b64c2b0, 0xec63f226, 0x756aa39c, + 0x026d930a, 0x9c0906a9, 0xeb0e363f, 0x72076785, 0x05005713, + 0x95bf4a82, 0xe2b87a14, 0x7bb12bae, 0x0cb61b38, 0x92d28e9b, + 0xe5d5be0d, 0x7cdcefb7, 0x0bdbdf21, 0x86d3d2d4, 0xf1d4e242, + 0x68ddb3f8, 0x1fda836e, 0x81be16cd, 0xf6b9265b, 0x6fb077e1, + 0x18b74777, 0x88085ae6, 0xff0f6a70, 0x66063bca, 0x11010b5c, + 0x8f659eff, 0xf862ae69, 0x616bffd3, 0x166ccf45, 0xa00ae278, + 0xd70dd2ee, 0x4e048354, 0x3903b3c2, 0xa7672661, 0xd06016f7, + 0x4969474d, 0x3e6e77db, 0xaed16a4a, 0xd9d65adc, 0x40df0b66, + 0x37d83bf0, 0xa9bcae53, 0xdebb9ec5, 0x47b2cf7f, 0x30b5ffe9, + 0xbdbdf21c, 0xcabac28a, 0x53b39330, 0x24b4a3a6, 0xbad03605, + 0xcdd70693, 0x54de5729, 0x23d967bf, 0xb3667a2e, 0xc4614ab8, + 0x5d681b02, 0x2a6f2b94, 0xb40bbe37, 0xc30c8ea1, 0x5a05df1b, + 0x2d02ef8d, +}; + +/* + *------------------------------------------------------------------------- + * + * ReadLock, WriteLock, Unlock -- + * + * POSIX like rwlock functions to support multiple readers + * and single writer on internal structs. + * + * Limitations: + * - a read lock cannot be promoted to a write lock + * - a write lock may not be nested + * + *------------------------------------------------------------------------- + */ + +TCL_DECLARE_MUTEX(ZipFSMutex) + +#ifdef TCL_THREADS + +static Tcl_Condition ZipFSCond; + +static void +ReadLock(void) +{ + Tcl_MutexLock(&ZipFSMutex); + while (ZipFS.lock < 0) { + ZipFS.waiters++; + Tcl_ConditionWait(&ZipFSCond, &ZipFSMutex, NULL); + ZipFS.waiters--; + } + ZipFS.lock++; + Tcl_MutexUnlock(&ZipFSMutex); +} + +static void +WriteLock(void) +{ + Tcl_MutexLock(&ZipFSMutex); + while (ZipFS.lock != 0) { + ZipFS.waiters++; + Tcl_ConditionWait(&ZipFSCond, &ZipFSMutex, NULL); + ZipFS.waiters--; + } + ZipFS.lock = -1; + Tcl_MutexUnlock(&ZipFSMutex); +} + +static void +Unlock(void) +{ + Tcl_MutexLock(&ZipFSMutex); + if (ZipFS.lock > 0) { + --ZipFS.lock; + } else if (ZipFS.lock < 0) { + ZipFS.lock = 0; + } + if ((ZipFS.lock == 0) && (ZipFS.waiters > 0)) { + Tcl_ConditionNotify(&ZipFSCond); + } + Tcl_MutexUnlock(&ZipFSMutex); +} + +#else + +#define ReadLock() do {} while (0) +#define WriteLock() do {} while (0) +#define Unlock() do {} while (0) + +#endif + +/* + *------------------------------------------------------------------------- + * + * DosTimeDate, ToDosTime, ToDosDate -- + * + * Functions to perform conversions between DOS time stamps + * and POSIX time_t. + * + *------------------------------------------------------------------------- + */ + +static time_t +DosTimeDate(int dosDate, int dosTime) +{ + struct tm tm; + time_t ret; + + memset(&tm, 0, sizeof (tm)); + tm.tm_year = (((dosDate & 0xfe00) >> 9) + 80); + tm.tm_mon = ((dosDate & 0x1e0) >> 5) - 1; + tm.tm_mday = dosDate & 0x1f; + tm.tm_hour = (dosTime & 0xf800) >> 11; + tm.tm_min = (dosTime & 0x7e) >> 5; + tm.tm_sec = (dosTime & 0x1f) << 1; + ret = mktime(&tm); + if (ret == (time_t) -1) { + /* fallback to 1980-01-01T00:00:00+00:00 (DOS epoch) */ + ret = (time_t) 315532800; + } + return ret; +} + +static int +ToDosTime(time_t when) +{ + struct tm *tmp, tm; + +#ifdef TCL_THREADS +#if defined(_WIN32) || defined(_WIN64) + /* Win32 uses thread local storage */ + tmp = localtime(&when); + tm = *tmp; +#else +#ifdef HAVE_LOCALTIME_R + tmp = &tm; + localtime_r(&when, tmp); +#else + Tcl_MutexLock(&localtimeMutex); + tmp = localtime(&when); + tm = *tmp; + Tcl_MutexUnlock(&localtimeMutex); +#endif +#endif +#else + tmp = localtime(&when); + tm = *tmp; +#endif + return (tm.tm_hour << 11) | (tm.tm_min << 5) | (tm.tm_sec >> 1); +} + +static int +ToDosDate(time_t when) +{ + struct tm *tmp, tm; + +#ifdef TCL_THREADS +#if defined(_WIN32) || defined(_WIN64) + /* Win32 uses thread local storage */ + tmp = localtime(&when); + tm = *tmp; +#else +#ifdef HAVE_LOCALTIME_R + tmp = &tm; + localtime_r(&when, tmp); +#else + Tcl_MutexLock(&localtimeMutex); + tmp = localtime(&when); + tm = *tmp; + Tcl_MutexUnlock(&localtimeMutex); +#endif +#endif +#else + tmp = localtime(&when); + tm = *tmp; +#endif + return ((tm.tm_year - 80) << 9) | ((tm.tm_mon + 1) << 5) | tm.tm_mday; +} + +/* + *------------------------------------------------------------------------- + * + * CountSlashes -- + * + * This function counts the number of slashes in a pathname string. + * + * Results: + * Number of slashes found in string. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static int +CountSlashes(const char *string) +{ + int count = 0; + const char *p = string; + + while (*p != '\0') { + if (*p == '/') { + count++; + } + p++; + } + return count; +} + +/* + *------------------------------------------------------------------------- + * + * CanonicalPath -- + * + * This function computes the canonical path from a directory + * and file name components into the specified Tcl_DString. + * + * Results: + * Returns the pointer to the canonical path contained in the + * specified Tcl_DString. + * + * Side effects: + * Modifies the specified Tcl_DString. + * + *------------------------------------------------------------------------- + */ + +static char * +CanonicalPath(const char *root, const char *tail, Tcl_DString *dsPtr,int ZIPFSPATH) +{ + char *path; + char *result; + int i, j, c, isunc = 0, isvfs=0, n=0; +#if HAS_DRIVES + int zipfspath=1; + if ((tail[0] != '\0') && (strchr(drvletters, tail[0]) != NULL) && + (tail[1] == ':')) { + tail += 2; + zipfspath=0; + } + /* UNC style path */ + if (tail[0] == '\\') { + root = ""; + ++tail; + zipfspath=0; + } + if (tail[0] == '\\') { + root = "/"; + ++tail; + zipfspath=0; + } + if(zipfspath) { +#endif + /* UNC style path */ + if(root && strncmp(root,ZIPFS_VOLUME,ZIPFS_VOLUME_LEN)==0) { + isvfs=1; + } else if (tail && strncmp(tail,ZIPFS_VOLUME,ZIPFS_VOLUME_LEN) == 0) { + isvfs=2; + } + if(isvfs!=1) { + if ((root[0] == '/') && (root[1] == '/')) { + isunc = 1; + } + } +#if HAS_DRIVES + } +#endif + if(isvfs!=2) { + if (tail[0] == '/') { + if(isvfs!=1) { + root = ""; + } + ++tail; + isunc = 0; + } + if (tail[0] == '/') { + if(isvfs!=1) { + root = "/"; + } + ++tail; + isunc = 1; + } + } + i = strlen(root); + j = strlen(tail); + if(isvfs==1) { + if(i>ZIPFS_VOLUME_LEN) { + Tcl_DStringSetLength(dsPtr, i + j + 1); + path = Tcl_DStringValue(dsPtr); + memcpy(path, root, i); + path[i++] = '/'; + memcpy(path + i, tail, j); + } else { + Tcl_DStringSetLength(dsPtr, i + j); + path = Tcl_DStringValue(dsPtr); + memcpy(path, root, i); + memcpy(path + i, tail, j); + } + } else if(isvfs==2) { + Tcl_DStringSetLength(dsPtr, j); + path = Tcl_DStringValue(dsPtr); + memcpy(path, tail, j); + } else { + if (ZIPFSPATH) { + Tcl_DStringSetLength(dsPtr, i + j + ZIPFS_VOLUME_LEN); + path = Tcl_DStringValue(dsPtr); + memcpy(path, ZIPFS_VOLUME, ZIPFS_VOLUME_LEN); + memcpy(path + ZIPFS_VOLUME_LEN + i , tail, j); + } else { + Tcl_DStringSetLength(dsPtr, i + j + 1); + path = Tcl_DStringValue(dsPtr); + memcpy(path, root, i); + path[i++] = '/'; + memcpy(path + i, tail, j); + } + } +#if HAS_DRIVES + for (i = 0; path[i] != '\0'; i++) { + if (path[i] == '\\') { + path[i] = '/'; + } + } +#endif + if(ZIPFSPATH) { + n=ZIPFS_VOLUME_LEN; + } else { + n=0; + } + for (i = j = n; (c = path[i]) != '\0'; i++) { + if (c == '/') { + int c2 = path[i + 1]; + if (c2 == '/') { + continue; + } + if (c2 == '.') { + int c3 = path[i + 2]; + if ((c3 == '/') || (c3 == '\0')) { + i++; + continue; + } + if ((c3 == '.') && + ((path[i + 3] == '/') || (path [i + 3] == '\0'))) { + i += 2; + while ((j > 0) && (path[j - 1] != '/')) { + j--; + } + if (j > isunc) { + --j; + while ((j > 1 + isunc) && (path[j - 2] == '/')) { + j--; + } + } + continue; + } + } + } + path[j++] = c; + } + if (j == 0) { + path[j++] = '/'; + } + path[j] = 0; + Tcl_DStringSetLength(dsPtr, j); + result=Tcl_DStringValue(dsPtr); + return result; +} + + + +/* + *------------------------------------------------------------------------- + * + * ZipFSLookup -- + * + * This function returns the ZIP entry struct corresponding to + * the ZIP archive member of the given file name. + * + * Results: + * Returns the pointer to ZIP entry struct or NULL if the + * the given file name could not be found in the global list + * of ZIP archive members. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static ZipEntry * +ZipFSLookup(char *filename) +{ + Tcl_HashEntry *hPtr; + ZipEntry *z; + Tcl_DString ds; + Tcl_DStringInit(&ds); + hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, filename); + z = hPtr ? (ZipEntry *) Tcl_GetHashValue(hPtr) : NULL; + Tcl_DStringFree(&ds); + return z; +} + +#ifdef NEVER_USED + +/* + *------------------------------------------------------------------------- + * + * ZipFSLookupMount -- + * + * This function returns an indication if the given file name + * corresponds to a mounted ZIP archive file. + * + * Results: + * Returns true, if the given file name is a mounted ZIP archive file. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSLookupMount(char *filename) +{ + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + ZipFile *zf; + int match = 0; + hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); + while (hPtr != NULL) { + if ((zf = (ZipFile *) Tcl_GetHashValue(hPtr)) != NULL) { + if (strcmp(zf->mntpt, filename) == 0) { + match = 1; + break; + } + } + hPtr = Tcl_NextHashEntry(&search); + } + return match; +} +#endif + +/* + *------------------------------------------------------------------------- + * + * ZipFSCloseArchive -- + * + * This function closes a mounted ZIP archive file. + * + * Results: + * None. + * + * Side effects: + * A memory mapped ZIP archive is unmapped, allocated memory is + * released. + * + *------------------------------------------------------------------------- + */ + +static void +ZipFSCloseArchive(Tcl_Interp *interp, ZipFile *zf) +{ +#if defined(_WIN32) || defined(_WIN64) + if ((zf->data != NULL) && (zf->tofree == NULL)) { + UnmapViewOfFile(zf->data); + zf->data = NULL; + } + if (zf->mh != INVALID_HANDLE_VALUE) { + CloseHandle(zf->mh); + } +#else + if ((zf->data != MAP_FAILED) && (zf->tofree == NULL)) { + munmap(zf->data, zf->length); + zf->data = MAP_FAILED; + } +#endif + if (zf->tofree != NULL) { + Tcl_Free((char *) zf->tofree); + zf->tofree = NULL; + } + Tcl_Close(interp, zf->chan); + zf->chan = NULL; +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSOpenArchive -- + * + * This function opens a ZIP archive file for reading. An attempt + * is made to memory map that file. Otherwise it is read into + * an allocated memory buffer. The ZIP archive header is verified + * and must be valid for the function to succeed. When "needZip" + * is zero an embedded ZIP archive in an executable file is accepted. + * + * Results: + * TCL_OK on success, TCL_ERROR otherwise with an error message + * placed into the given "interp" if it is not NULL. + * + * Side effects: + * ZIP archive is memory mapped or read into allocated memory, + * the given ZipFile struct is filled with information about + * the ZIP archive file. + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSOpenArchive(Tcl_Interp *interp, const char *zipname, int needZip, + ZipFile *zf) +{ + int i; + ClientData handle; + unsigned char *p, *q; + +#if defined(_WIN32) || defined(_WIN64) + zf->data = NULL; + zf->mh = INVALID_HANDLE_VALUE; +#else + zf->data = MAP_FAILED; +#endif + zf->length = 0; + zf->nfiles = 0; + zf->baseoffs = zf->baseoffsp = 0; + zf->tofree = NULL; + zf->pwbuf[0] = 0; + zf->chan = Tcl_OpenFileChannel(interp, zipname, "r", 0); + if (zf->chan == NULL) { + return TCL_ERROR; + } + if (Tcl_GetChannelHandle(zf->chan, TCL_READABLE, &handle) != TCL_OK) { + if (Tcl_SetChannelOption(interp, zf->chan, "-translation", "binary") + != TCL_OK) { + goto error; + } + if (Tcl_SetChannelOption(interp, zf->chan, "-encoding", "binary") + != TCL_OK) { + goto error; + } + zf->length = Tcl_Seek(zf->chan, 0, SEEK_END); + if ((zf->length <= 0) || (zf->length > 64 * 1024 * 1024)) { + if (interp) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("illegal file size", -1)); + } + goto error; + } + Tcl_Seek(zf->chan, 0, SEEK_SET); + zf->tofree = zf->data = (unsigned char *) Tcl_AttemptAlloc(zf->length); + if (zf->tofree == NULL) { + if (interp) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("out of memory", -1)); + } + goto error; + } + i = Tcl_Read(zf->chan, (char *) zf->data, zf->length); + if (i != zf->length) { + if (interp) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("file read error", -1)); + } + goto error; + } + Tcl_Close(interp, zf->chan); + zf->chan = NULL; + } else { +#if defined(_WIN32) || defined(_WIN64) + zf->length = GetFileSize((HANDLE) handle, 0); + if ((zf->length == INVALID_FILE_SIZE) || + (zf->length < ZIP_CENTRAL_END_LEN)) { + if (interp != NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("invalid file size", -1)); + } + goto error; + } + zf->mh = CreateFileMapping((HANDLE) handle, 0, PAGE_READONLY, 0, + zf->length, 0); + if (zf->mh == INVALID_HANDLE_VALUE) { + if (interp != NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("file mapping failed", -1)); + } + goto error; + } + zf->data = MapViewOfFile(zf->mh, FILE_MAP_READ, 0, 0, zf->length); + if (zf->data == NULL) { + if (interp != NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("file mapping failed", -1)); + } + goto error; + } +#else + zf->length = lseek((int) (long) handle, 0, SEEK_END); + if ((zf->length == -1) || (zf->length < ZIP_CENTRAL_END_LEN)) { + if (interp != NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("invalid file size", -1)); + } + goto error; + } + lseek((int) (long) handle, 0, SEEK_SET); + zf->data = (unsigned char *) mmap(0, zf->length, PROT_READ, + MAP_FILE | MAP_PRIVATE, + (int) (long) handle, 0); + if (zf->data == MAP_FAILED) { + if (interp != NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("file mapping failed", -1)); + } + goto error; + } +#endif + } + p = zf->data + zf->length - ZIP_CENTRAL_END_LEN; + while (p >= zf->data) { + if (*p == (ZIP_CENTRAL_END_SIG & 0xFF)) { + if (zip_read_int(p) == ZIP_CENTRAL_END_SIG) { + break; + } + p -= ZIP_SIG_LEN; + } else { + --p; + } + } + if (p < zf->data) { + if (!needZip) { + zf->baseoffs = zf->baseoffsp = zf->length; + return TCL_OK; + } + if (interp != NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("wrong end signature", -1)); + } + goto error; + } + zf->nfiles = zip_read_short(p + ZIP_CENTRAL_ENTS_OFFS); + if (zf->nfiles == 0) { + if (!needZip) { + zf->baseoffs = zf->baseoffsp = zf->length; + return TCL_OK; + } + if (interp != NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("empty archive", -1)); + } + goto error; + } + q = zf->data + zip_read_int(p + ZIP_CENTRAL_DIRSTART_OFFS); + p -= zip_read_int(p + ZIP_CENTRAL_DIRSIZE_OFFS); + if ((p < zf->data) || (p > (zf->data + zf->length)) || + (q < zf->data) || (q > (zf->data + zf->length))) { + if (!needZip) { + zf->baseoffs = zf->baseoffsp = zf->length; + return TCL_OK; + } + if (interp != NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("archive directory not found", -1)); + } + goto error; + } + zf->baseoffs = zf->baseoffsp = p - q; + zf->centoffs = p - zf->data; + q = p; + for (i = 0; i < zf->nfiles; i++) { + int pathlen, comlen, extra; + + if ((q + ZIP_CENTRAL_HEADER_LEN) > (zf->data + zf->length)) { + if (interp != NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("wrong header length", -1)); + } + goto error; + } + if (zip_read_int(q) != ZIP_CENTRAL_HEADER_SIG) { + if (interp != NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("wrong header signature", -1)); + } + goto error; + } + pathlen = zip_read_short(q + ZIP_CENTRAL_PATHLEN_OFFS); + comlen = zip_read_short(q + ZIP_CENTRAL_FCOMMENTLEN_OFFS); + extra = zip_read_short(q + ZIP_CENTRAL_EXTRALEN_OFFS); + q += pathlen + comlen + extra + ZIP_CENTRAL_HEADER_LEN; + } + q = zf->data + zf->baseoffs; + if ((zf->baseoffs >= 6) && + (zip_read_int(q - 4) == ZIP_PASSWORD_END_SIG)) { + i = q[-5]; + if (q - 5 - i > zf->data) { + zf->pwbuf[0] = i; + memcpy(zf->pwbuf + 1, q - 5 - i, i); + zf->baseoffsp -= i ? (5 + i) : 0; + } + } + return TCL_OK; + +error: + ZipFSCloseArchive(interp, zf); + return TCL_ERROR; +} + +/* + *------------------------------------------------------------------------- + * + * TclZipfs_Mount -- + * + * This procedure is invoked to mount a given ZIP archive file on + * a given mountpoint with optional ZIP password. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * A ZIP archive file is read, analyzed and mounted, resources are + * allocated. + * + *------------------------------------------------------------------------- + */ + +int +TclZipfs_Mount(Tcl_Interp *interp, const char *zipname, const char *mntpt, + const char *passwd) +{ + int i, pwlen, isNew; + ZipFile *zf, zf0; + ZipEntry *z; + Tcl_HashEntry *hPtr; + Tcl_DString ds, fpBuf; + unsigned char *q; + + ReadLock(); + if (!ZipFS.initialized) { + if (interp != NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("not initialized", -1)); + } + Unlock(); + return TCL_ERROR; + } + if (zipname == NULL) { + Tcl_HashSearch search; + int ret = TCL_OK; + + i = 0; + hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); + while (hPtr != NULL) { + if ((zf = (ZipFile *) Tcl_GetHashValue(hPtr)) != NULL) { + if (interp != NULL) { + Tcl_AppendElement(interp, zf->mntpt); + Tcl_AppendElement(interp, zf->name); + } + ++i; + } + hPtr = Tcl_NextHashEntry(&search); + } + if (interp == NULL) { + ret = (i > 0) ? TCL_OK : TCL_BREAK; + } + Unlock(); + return ret; + } + if (mntpt == NULL) { + if (interp == NULL) { + Unlock(); + return TCL_OK; + } + hPtr = Tcl_FindHashEntry(&ZipFS.zipHash, zipname); + if (hPtr != NULL) { + if ((zf = Tcl_GetHashValue(hPtr)) != NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj(zf->mntpt, zf->mntptlen)); + } + } + Unlock(); + return TCL_OK; + } + Unlock(); + pwlen = 0; + if (passwd != NULL) { + pwlen = strlen(passwd); + if ((pwlen > 255) || (strchr(passwd, 0xff) != NULL)) { + if (interp) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("illegal password", -1)); + } + return TCL_ERROR; + } + } + if (ZipFSOpenArchive(interp, zipname, 1, &zf0) != TCL_OK) { + return TCL_ERROR; + } + /* + * Mount point can come from Tcl_GetNameOfExecutable() + * which sometimes is a relative or otherwise denormalized path. + * But an absolute name is needed as mount point here. + */ + WriteLock(); + hPtr = Tcl_CreateHashEntry(&ZipFS.zipHash, zipname, &isNew); + if (!isNew) { + zf = (ZipFile *) Tcl_GetHashValue(hPtr); + if (interp != NULL) { + Tcl_AppendResult(interp, "already mounted on \"", zf->mntptlen ? + zf->mntpt : "/", "\"", (char *) NULL); + } + Unlock(); + ZipFSCloseArchive(interp, &zf0); + return TCL_ERROR; + } + if (strcmp(mntpt, "/") == 0) { + mntpt = ""; + } + zf = (ZipFile *) Tcl_AttemptAlloc(sizeof (*zf) + strlen(mntpt) + 1); + if (zf == NULL) { + if (interp != NULL) { + Tcl_AppendResult(interp, "out of memory", (char *) NULL); + } + Unlock(); + ZipFSCloseArchive(interp, &zf0); + return TCL_ERROR; + } + *zf = zf0; + zf->name = Tcl_GetHashKey(&ZipFS.zipHash, hPtr); + strcpy(zf->mntpt, mntpt); + zf->mntptlen = strlen(zf->mntpt); + zf->entries = NULL; + zf->topents = NULL; + zf->nopen = 0; + Tcl_SetHashValue(hPtr, (ClientData) zf); + if ((zf->pwbuf[0] == 0) && pwlen) { + int k = 0; + i = pwlen; + zf->pwbuf[k++] = i; + while (i > 0) { + zf->pwbuf[k] = (passwd[i - 1] & 0x0f) | + pwrot[(passwd[i - 1] >> 4) & 0x0f]; + k++; + i--; + } + zf->pwbuf[k] = '\0'; + } + if (mntpt[0] != '\0') { + z = (ZipEntry *) Tcl_Alloc(sizeof (*z)); + z->name = NULL; + z->tnext = NULL; + z->depth = CountSlashes(mntpt); + z->zipfile = zf; + z->isdir = 1; + z->isenc = 0; + z->offset = zf->baseoffs; + z->crc32 = 0; + z->timestamp = 0; + z->nbyte = z->nbytecompr = 0; + z->cmeth = ZIP_COMPMETH_STORED; + z->data = NULL; + hPtr = Tcl_CreateHashEntry(&ZipFS.fileHash, mntpt, &isNew); + if (!isNew) { + /* skip it */ + Tcl_Free((char *) z); + } else { + Tcl_SetHashValue(hPtr, (ClientData) z); + z->name = Tcl_GetHashKey(&ZipFS.fileHash, hPtr); + z->next = zf->entries; + zf->entries = z; + } + } + q = zf->data + zf->centoffs; + Tcl_DStringInit(&fpBuf); + Tcl_DStringInit(&ds); + for (i = 0; i < zf->nfiles; i++) { + int pathlen, comlen, extra, isdir = 0, dosTime, dosDate, nbcompr, offs; + unsigned char *lq, *gq = NULL; + char *fullpath, *path; + + pathlen = zip_read_short(q + ZIP_CENTRAL_PATHLEN_OFFS); + comlen = zip_read_short(q + ZIP_CENTRAL_FCOMMENTLEN_OFFS); + extra = zip_read_short(q + ZIP_CENTRAL_EXTRALEN_OFFS); + Tcl_DStringSetLength(&ds, 0); + Tcl_DStringAppend(&ds, (char *) q + ZIP_CENTRAL_HEADER_LEN, pathlen); + path = Tcl_DStringValue(&ds); + if ((pathlen > 0) && (path[pathlen - 1] == '/')) { + Tcl_DStringSetLength(&ds, pathlen - 1); + path = Tcl_DStringValue(&ds); + isdir = 1; + } + if ((strcmp(path, ".") == 0) || (strcmp(path, "..") == 0)) { + goto nextent; + } + lq = zf->data + zf->baseoffs + + zip_read_int(q + ZIP_CENTRAL_LOCALHDR_OFFS); + if ((lq < zf->data) || (lq > (zf->data + zf->length))) { + goto nextent; + } + nbcompr = zip_read_int(lq + ZIP_LOCAL_COMPLEN_OFFS); + if (!isdir && (nbcompr == 0) && + (zip_read_int(lq + ZIP_LOCAL_UNCOMPLEN_OFFS) == 0) && + (zip_read_int(lq + ZIP_LOCAL_CRC32_OFFS) == 0)) { + gq = q; + nbcompr = zip_read_int(gq + ZIP_CENTRAL_COMPLEN_OFFS); + } + offs = (lq - zf->data) + + ZIP_LOCAL_HEADER_LEN + + zip_read_short(lq + ZIP_LOCAL_PATHLEN_OFFS) + + zip_read_short(lq + ZIP_LOCAL_EXTRALEN_OFFS); + if ((offs + nbcompr) > zf->length) { + goto nextent; + } + if (!isdir && (mntpt[0] == '\0') && !CountSlashes(path)) { +#ifdef ANDROID + /* + * When mounting the ZIP archive on the root directory try + * to remap top level regular files of the archive to + * /assets/.root/... since this directory should not be + * in a valid APK due to the leading dot in the file name + * component. This trick should make the files + * AndroidManifest.xml, resources.arsc, and classes.dex + * visible to Tcl. + */ + Tcl_DString ds2; + + Tcl_DStringInit(&ds2); + Tcl_DStringAppend(&ds2, "assets/.root/", -1); + Tcl_DStringAppend(&ds2, path, -1); + hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, Tcl_DStringValue(&ds2)); + if (hPtr != NULL) { + /* should not happen but skip it anyway */ + Tcl_DStringFree(&ds2); + goto nextent; + } + Tcl_DStringSetLength(&ds, 0); + Tcl_DStringAppend(&ds, Tcl_DStringValue(&ds2), + Tcl_DStringLength(&ds2)); + path = Tcl_DStringValue(&ds); + Tcl_DStringFree(&ds2); +#else + /* + * Regular files skipped when mounting on root. + */ + goto nextent; +#endif + } + Tcl_DStringSetLength(&fpBuf, 0); + fullpath = CanonicalPath(mntpt, path, &fpBuf, 1); + z = (ZipEntry *) Tcl_Alloc(sizeof (*z)); + z->name = NULL; + z->tnext = NULL; + z->depth = CountSlashes(fullpath); + z->zipfile = zf; + z->isdir = isdir; + z->isenc = (zip_read_short(lq + ZIP_LOCAL_FLAGS_OFFS) & 1) + && (nbcompr > 12); + z->offset = offs; + if (gq != NULL) { + z->crc32 = zip_read_int(gq + ZIP_CENTRAL_CRC32_OFFS); + dosDate = zip_read_short(gq + ZIP_CENTRAL_MDATE_OFFS); + dosTime = zip_read_short(gq + ZIP_CENTRAL_MTIME_OFFS); + z->timestamp = DosTimeDate(dosDate, dosTime); + z->nbyte = zip_read_int(gq + ZIP_CENTRAL_UNCOMPLEN_OFFS); + z->cmeth = zip_read_short(gq + ZIP_CENTRAL_COMPMETH_OFFS); + } else { + z->crc32 = zip_read_int(lq + ZIP_LOCAL_CRC32_OFFS); + dosDate = zip_read_short(lq + ZIP_LOCAL_MDATE_OFFS); + dosTime = zip_read_short(lq + ZIP_LOCAL_MTIME_OFFS); + z->timestamp = DosTimeDate(dosDate, dosTime); + z->nbyte = zip_read_int(lq + ZIP_LOCAL_UNCOMPLEN_OFFS); + z->cmeth = zip_read_short(lq + ZIP_LOCAL_COMPMETH_OFFS); + } + z->nbytecompr = nbcompr; + z->data = NULL; + hPtr = Tcl_CreateHashEntry(&ZipFS.fileHash, fullpath, &isNew); + if (!isNew) { + /* should not happen but skip it anyway */ + Tcl_Free((char *) z); + } else { + Tcl_SetHashValue(hPtr, (ClientData) z); + z->name = Tcl_GetHashKey(&ZipFS.fileHash, hPtr); + z->next = zf->entries; + zf->entries = z; + if (isdir && (mntpt[0] == '\0') && (z->depth == 1)) { + z->tnext = zf->topents; + zf->topents = z; + } + if (!z->isdir && (z->depth > 1)) { + char *dir, *end; + ZipEntry *zd; + + Tcl_DStringSetLength(&ds, strlen(z->name) + 8); + Tcl_DStringSetLength(&ds, 0); + Tcl_DStringAppend(&ds, z->name, -1); + dir = Tcl_DStringValue(&ds); + end = strrchr(dir, '/'); + while ((end != NULL) && (end != dir)) { + Tcl_DStringSetLength(&ds, end - dir); + hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, dir); + if (hPtr != NULL) { + break; + } + zd = (ZipEntry *) Tcl_Alloc(sizeof (*zd)); + zd->name = NULL; + zd->tnext = NULL; + zd->depth = CountSlashes(dir); + zd->zipfile = zf; + zd->isdir = 1; + zd->isenc = 0; + zd->offset = z->offset; + zd->crc32 = 0; + zd->timestamp = z->timestamp; + zd->nbyte = zd->nbytecompr = 0; + zd->cmeth = ZIP_COMPMETH_STORED; + zd->data = NULL; + hPtr = Tcl_CreateHashEntry(&ZipFS.fileHash, dir, &isNew); + if (!isNew) { + /* should not happen but skip it anyway */ + Tcl_Free((char *) zd); + } else { + Tcl_SetHashValue(hPtr, (ClientData) zd); + zd->name = Tcl_GetHashKey(&ZipFS.fileHash, hPtr); + zd->next = zf->entries; + zf->entries = zd; + if ((mntpt[0] == '\0') && (zd->depth == 1)) { + zd->tnext = zf->topents; + zf->topents = zd; + } + } + end = strrchr(dir, '/'); + } + } + } +nextent: + q += pathlen + comlen + extra + ZIP_CENTRAL_HEADER_LEN; + } + Unlock(); + Tcl_DStringFree(&fpBuf); + Tcl_DStringFree(&ds); + Tcl_FSMountsChanged(NULL); + return TCL_OK; +} + +/* + *------------------------------------------------------------------------- + * + * TclZipfs_Unmount -- + * + * This procedure is invoked to unmount a given ZIP archive. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * A mounted ZIP archive file is unmounted, resources are free'd. + * + *------------------------------------------------------------------------- + */ + +int +TclZipfs_Unmount(Tcl_Interp *interp, const char *zipname) +{ + ZipFile *zf; + ZipEntry *z, *znext; + Tcl_HashEntry *hPtr; + int ret = TCL_OK, unmounted = 0; + + WriteLock(); + if (!ZipFS.initialized) { + goto done; + } + hPtr = Tcl_FindHashEntry(&ZipFS.zipHash, zipname); + if (hPtr == NULL) { + /* don't report error */ + goto done; + } + zf = (ZipFile *) Tcl_GetHashValue(hPtr); + if (zf->nopen > 0) { + if (interp != NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("filesystem is busy", -1)); + } + ret = TCL_ERROR; + goto done; + } + Tcl_DeleteHashEntry(hPtr); + for (z = zf->entries; z; z = znext) { + znext = z->next; + hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, z->name); + if (hPtr) { + Tcl_DeleteHashEntry(hPtr); + } + if (z->data != NULL) { + Tcl_Free((char *) z->data); + } + Tcl_Free((char *) z); + } + ZipFSCloseArchive(interp, zf); + Tcl_Free((char *) zf); + unmounted = 1; +done: + Unlock(); + if (unmounted) { + Tcl_FSMountsChanged(NULL); + } + return ret; +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSMountObjCmd -- + * + * This procedure is invoked to process the "zipfs::mount" command. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * A ZIP archive file is mounted, resources are allocated. + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSMountObjCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]) +{ + if (objc > 4) { + Tcl_WrongNumArgs(interp, 1, objv, + "?zipfile? ?mountpoint? ?password?"); + return TCL_ERROR; + } + return TclZipfs_Mount(interp, (objc > 1) ? Tcl_GetString(objv[1]) : NULL, + (objc > 2) ? Tcl_GetString(objv[2]) : NULL, + (objc > 3) ? Tcl_GetString(objv[3]) : NULL); +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSUnmountObjCmd -- + * + * This procedure is invoked to process the "zipfs::unmount" command. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * A mounted ZIP archive file is unmounted, resources are free'd. + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSUnmountObjCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]) +{ + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "zipfile"); + return TCL_ERROR; + } + return TclZipfs_Unmount(interp, Tcl_GetString(objv[1])); +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSMkKeyObjCmd -- + * + * This procedure is invoked to process the "zipfs::mkkey" command. + * It produces a rotated password to be embedded into an image file. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSMkKeyObjCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]) +{ + int len, i = 0; + char *pw, pwbuf[264]; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "password"); + return TCL_ERROR; + } + pw = Tcl_GetString(objv[1]); + len = strlen(pw); + if (len == 0) { + return TCL_OK; + } + if ((len > 255) || (strchr(pw, 0xff) != NULL)) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("illegal password", -1)); + return TCL_ERROR; + } + while (len > 0) { + int ch = pw[len - 1]; + + pwbuf[i] = (ch & 0x0f) | pwrot[(ch >> 4) & 0x0f]; + i++; + len--; + } + pwbuf[i] = i; + ++i; + pwbuf[i++] = (char) ZIP_PASSWORD_END_SIG; + pwbuf[i++] = (char) (ZIP_PASSWORD_END_SIG >> 8); + pwbuf[i++] = (char) (ZIP_PASSWORD_END_SIG >> 16); + pwbuf[i++] = (char) (ZIP_PASSWORD_END_SIG >> 24); + pwbuf[i] = '\0'; + Tcl_AppendResult(interp, pwbuf, (char *) NULL); + return TCL_OK; +} + +/* + *------------------------------------------------------------------------- + * + * ZipAddFile -- + * + * This procedure is used by ZipFSMkZipOrImgCmd() to add a single + * file to the output ZIP archive file being written. A ZipEntry + * struct about the input file is added to the given fileHash table + * for later creation of the central ZIP directory. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Input file is read and (compressed and) written to the output + * ZIP archive file. + * + *------------------------------------------------------------------------- + */ + +static int +ZipAddFile(Tcl_Interp *interp, const char *path, const char *name, + Tcl_Channel out, const char *passwd, + char *buf, int bufsize, Tcl_HashTable *fileHash) +{ + Tcl_Channel in; + Tcl_HashEntry *hPtr; + ZipEntry *z; + z_stream stream; + const char *zpath; + int nbyte, nbytecompr, len, crc, flush, pos[3], zpathlen, olen; + int mtime = 0, isNew, align = 0, cmeth; + unsigned long keys[3], keys0[3]; + char obuf[4096]; + + zpath = name; + while (zpath != NULL && zpath[0] == '/') { + zpath++; + } + if ((zpath == NULL) || (zpath[0] == '\0')) { + return TCL_OK; + } + zpathlen = strlen(zpath); + if (zpathlen + ZIP_CENTRAL_HEADER_LEN > bufsize) { + Tcl_AppendResult(interp, "path too long for \"", path, "\"", + (char *) NULL); + return TCL_ERROR; + } + in = Tcl_OpenFileChannel(interp, path, "r", 0); + if ((in == NULL) || + (Tcl_SetChannelOption(interp, in, "-translation", "binary") + != TCL_OK) || + (Tcl_SetChannelOption(interp, in, "-encoding", "binary") + != TCL_OK)) { +#if defined(_WIN32) || defined(_WIN64) + /* hopefully a directory */ + if (strcmp("permission denied", Tcl_PosixError(interp)) == 0) { + Tcl_Close(interp, in); + return TCL_OK; + } +#endif + Tcl_Close(interp, in); + return TCL_ERROR; + } else { + Tcl_Obj *pathObj = Tcl_NewStringObj(path, -1); + Tcl_StatBuf statBuf; + + Tcl_IncrRefCount(pathObj); + if (Tcl_FSStat(pathObj, &statBuf) != -1) { + mtime = statBuf.st_mtime; + } + Tcl_DecrRefCount(pathObj); + } + Tcl_ResetResult(interp); + crc = 0; + nbyte = nbytecompr = 0; + while ((len = Tcl_Read(in, buf, bufsize)) > 0) { + crc = crc32(crc, (unsigned char *) buf, len); + nbyte += len; + } + if (len == -1) { + if (nbyte == 0) { + if (strcmp("illegal operation on a directory", + Tcl_PosixError(interp)) == 0) { + Tcl_Close(interp, in); + return TCL_OK; + } + } + Tcl_AppendResult(interp, "read error on \"", path, "\"", + (char *) NULL); + Tcl_Close(interp, in); + return TCL_ERROR; + } + if (Tcl_Seek(in, 0, SEEK_SET) == -1) { + Tcl_AppendResult(interp, "seek error on \"", path, "\"", + (char *) NULL); + Tcl_Close(interp, in); + return TCL_ERROR; + } + pos[0] = Tcl_Tell(out); + memset(buf, '\0', ZIP_LOCAL_HEADER_LEN); + memcpy(buf + ZIP_LOCAL_HEADER_LEN, zpath, zpathlen); + len = zpathlen + ZIP_LOCAL_HEADER_LEN; + if (Tcl_Write(out, buf, len) != len) { +wrerr: + Tcl_AppendResult(interp, "write error", (char *) NULL); + Tcl_Close(interp, in); + return TCL_ERROR; + } + if ((len + pos[0]) & 3) { + char abuf[8]; + + /* + * Align payload to next 4-byte boundary using a dummy extra + * entry similar to the zipalign tool from Android's SDK. + */ + align = 4 + ((len + pos[0]) & 3); + zip_write_short(abuf, 0xffff); + zip_write_short(abuf + 2, align - 4); + zip_write_int(abuf + 4, 0x03020100); + if (Tcl_Write(out, abuf, align) != align) { + goto wrerr; + } + } + if (passwd != NULL) { + int i, ch, tmp; + unsigned char kvbuf[24]; + Tcl_Obj *ret; + + init_keys(passwd, keys, crc32tab); + for (i = 0; i < 12 - 2; i++) { + if (Tcl_EvalEx(interp, "expr int(rand() * 256) % 256", -1, 0) != TCL_OK) { + Tcl_AppendResult(interp, "PRNG error", (char *) NULL); + Tcl_Close(interp, in); + return TCL_ERROR; + } + ret = Tcl_GetObjResult(interp); + if (Tcl_GetIntFromObj(interp, ret, &ch) != TCL_OK) { + Tcl_Close(interp, in); + return TCL_ERROR; + } + kvbuf[i + 12] = (unsigned char) zencode(keys, crc32tab, ch, tmp); + } + Tcl_ResetResult(interp); + init_keys(passwd, keys, crc32tab); + for (i = 0; i < 12 - 2; i++) { + kvbuf[i] = (unsigned char) zencode(keys, crc32tab, + kvbuf[i + 12], tmp); + } + kvbuf[i++] = (unsigned char) zencode(keys, crc32tab, crc >> 16, tmp); + kvbuf[i++] = (unsigned char) zencode(keys, crc32tab, crc >> 24, tmp); + len = Tcl_Write(out, (char *) kvbuf, 12); + memset(kvbuf, 0, 24); + if (len != 12) { + Tcl_AppendResult(interp, "write error", (char *) NULL); + Tcl_Close(interp, in); + return TCL_ERROR; + } + memcpy(keys0, keys, sizeof (keys0)); + nbytecompr += 12; + } + Tcl_Flush(out); + pos[2] = Tcl_Tell(out); + cmeth = ZIP_COMPMETH_DEFLATED; + memset(&stream, 0, sizeof (stream)); + stream.zalloc = Z_NULL; + stream.zfree = Z_NULL; + stream.opaque = Z_NULL; + if (deflateInit2(&stream, 9, Z_DEFLATED, -15, 8, Z_DEFAULT_STRATEGY) + != Z_OK) { + Tcl_AppendResult(interp, "compression init error on \"", path, "\"", + (char *) NULL); + Tcl_Close(interp, in); + return TCL_ERROR; + } + do { + len = Tcl_Read(in, buf, bufsize); + if (len == -1) { + Tcl_AppendResult(interp, "read error on \"", path, "\"", + (char *) NULL); + deflateEnd(&stream); + Tcl_Close(interp, in); + return TCL_ERROR; + } + stream.avail_in = len; + stream.next_in = (unsigned char *) buf; + flush = Tcl_Eof(in) ? Z_FINISH : Z_NO_FLUSH; + do { + stream.avail_out = sizeof (obuf); + stream.next_out = (unsigned char *) obuf; + len = deflate(&stream, flush); + if (len == Z_STREAM_ERROR) { + Tcl_AppendResult(interp, "deflate error on \"", path, "\"", + (char *) NULL); + deflateEnd(&stream); + Tcl_Close(interp, in); + return TCL_ERROR; + } + olen = sizeof (obuf) - stream.avail_out; + if (passwd != NULL) { + int i, tmp; + + for (i = 0; i < olen; i++) { + obuf[i] = (char) zencode(keys, crc32tab, obuf[i], tmp); + } + } + if (olen && (Tcl_Write(out, obuf, olen) != olen)) { + Tcl_AppendResult(interp, "write error", (char *) NULL); + deflateEnd(&stream); + Tcl_Close(interp, in); + return TCL_ERROR; + } + nbytecompr += olen; + } while (stream.avail_out == 0); + } while (flush != Z_FINISH); + deflateEnd(&stream); + Tcl_Flush(out); + pos[1] = Tcl_Tell(out); + if (nbyte - nbytecompr <= 0) { + /* + * Compressed file larger than input, + * write it again uncompressed. + */ + if ((int) Tcl_Seek(in, 0, SEEK_SET) != 0) { + goto seekErr; + } + if ((int) Tcl_Seek(out, pos[2], SEEK_SET) != pos[2]) { +seekErr: + Tcl_Close(interp, in); + Tcl_AppendResult(interp, "seek error", (char *) NULL); + return TCL_ERROR; + } + nbytecompr = (passwd != NULL) ? 12 : 0; + while (1) { + len = Tcl_Read(in, buf, bufsize); + if (len == -1) { + Tcl_AppendResult(interp, "read error on \"", path, "\"", + (char *) NULL); + Tcl_Close(interp, in); + return TCL_ERROR; + } else if (len == 0) { + break; + } + if (passwd != NULL) { + int i, tmp; + + for (i = 0; i < len; i++) { + buf[i] = (char) zencode(keys0, crc32tab, buf[i], tmp); + } + } + if (Tcl_Write(out, buf, len) != len) { + Tcl_AppendResult(interp, "write error", (char *) NULL); + Tcl_Close(interp, in); + return TCL_ERROR; + } + nbytecompr += len; + } + cmeth = ZIP_COMPMETH_STORED; + Tcl_Flush(out); + pos[1] = Tcl_Tell(out); + Tcl_TruncateChannel(out, pos[1]); + } + Tcl_Close(interp, in); + + z = (ZipEntry *) Tcl_Alloc(sizeof (*z)); + z->name = NULL; + z->tnext = NULL; + z->depth = 0; + z->zipfile = NULL; + z->isdir = 0; + z->isenc = (passwd != NULL) ? 1 : 0; + z->offset = pos[0]; + z->crc32 = crc; + z->timestamp = mtime; + z->nbyte = nbyte; + z->nbytecompr = nbytecompr; + z->cmeth = cmeth; + z->data = NULL; + hPtr = Tcl_CreateHashEntry(fileHash, zpath, &isNew); + if (!isNew) { + Tcl_AppendResult(interp, "non-unique path name \"", path, "\"", + (char *) NULL); + Tcl_Free((char *) z); + return TCL_ERROR; + } else { + Tcl_SetHashValue(hPtr, (ClientData) z); + z->name = Tcl_GetHashKey(fileHash, hPtr); + z->next = NULL; + } + + /* + * Write final local header information. + */ + zip_write_int(buf + ZIP_LOCAL_SIG_OFFS, ZIP_LOCAL_HEADER_SIG); + zip_write_short(buf + ZIP_LOCAL_VERSION_OFFS, ZIP_MIN_VERSION); + zip_write_short(buf + ZIP_LOCAL_FLAGS_OFFS, z->isenc); + zip_write_short(buf + ZIP_LOCAL_COMPMETH_OFFS, z->cmeth); + zip_write_short(buf + ZIP_LOCAL_MTIME_OFFS, ToDosTime(z->timestamp)); + zip_write_short(buf + ZIP_LOCAL_MDATE_OFFS, ToDosDate(z->timestamp)); + zip_write_int(buf + ZIP_LOCAL_CRC32_OFFS, z->crc32); + zip_write_int(buf + ZIP_LOCAL_COMPLEN_OFFS, z->nbytecompr); + zip_write_int(buf + ZIP_LOCAL_UNCOMPLEN_OFFS, z->nbyte); + zip_write_short(buf + ZIP_LOCAL_PATHLEN_OFFS, zpathlen); + zip_write_short(buf + ZIP_LOCAL_EXTRALEN_OFFS, align); + if ((int) Tcl_Seek(out, pos[0], SEEK_SET) != pos[0]) { + Tcl_DeleteHashEntry(hPtr); + Tcl_Free((char *) z); + Tcl_AppendResult(interp, "seek error", (char *) NULL); + return TCL_ERROR; + } + if (Tcl_Write(out, buf, ZIP_LOCAL_HEADER_LEN) != ZIP_LOCAL_HEADER_LEN) { + Tcl_DeleteHashEntry(hPtr); + Tcl_Free((char *) z); + Tcl_AppendResult(interp, "write error", (char *) NULL); + return TCL_ERROR; + } + Tcl_Flush(out); + if ((int) Tcl_Seek(out, pos[1], SEEK_SET) != pos[1]) { + Tcl_DeleteHashEntry(hPtr); + Tcl_Free((char *) z); + Tcl_AppendResult(interp, "seek error", (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSMkZipOrImgObjCmd -- + * + * This procedure is creates a new ZIP archive file or image file + * given output filename, input directory of files to be archived, + * optional password, and optional image to be prepended to the + * output ZIP archive file. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * A new ZIP archive file or image file is written. + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSMkZipOrImgObjCmd(ClientData clientData, Tcl_Interp *interp, + int isImg, int isList, int objc, Tcl_Obj *const objv[]) +{ + Tcl_Channel out; + int len = 0, pwlen = 0, slen = 0, i, count, ret = TCL_ERROR, lobjc, pos[3]; + Tcl_Obj **lobjv, *list = NULL; + ZipEntry *z; + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + Tcl_HashTable fileHash; + char *strip = NULL, *pw = NULL, pwbuf[264], buf[4096]; + + if (isList) { + if ((objc < 3) || (objc > (isImg ? 5 : 4))) { + Tcl_WrongNumArgs(interp, 1, objv, isImg ? + "outfile inlist ?password infile?" : + "outfile inlist ?password?"); + return TCL_ERROR; + } + } else { + if ((objc < 3) || (objc > (isImg ? 6 : 5))) { + Tcl_WrongNumArgs(interp, 1, objv, isImg ? + "outfile indir ?strip? ?password? ?infile?" : + "outfile indir ?strip? ?password?"); + return TCL_ERROR; + } + } + pwbuf[0] = 0; + if (objc > (isList ? 3 : 4)) { + pw = Tcl_GetString(objv[isList ? 3 : 4]); + pwlen = strlen(pw); + if ((pwlen > 255) || (strchr(pw, 0xff) != NULL)) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("illegal password", -1)); + return TCL_ERROR; + } + } + if (isList) { + list = objv[2]; + Tcl_IncrRefCount(list); + } else { + Tcl_Obj *cmd[3]; + + cmd[1] = Tcl_NewStringObj("::zipfs::find", -1); + cmd[2] = objv[2]; + cmd[0] = Tcl_NewListObj(2, cmd + 1); + Tcl_IncrRefCount(cmd[0]); + if (Tcl_EvalObjEx(interp, cmd[0], TCL_EVAL_DIRECT) != TCL_OK) { + Tcl_DecrRefCount(cmd[0]); + return TCL_ERROR; + } + Tcl_DecrRefCount(cmd[0]); + list = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(list); + } + if (Tcl_ListObjGetElements(interp, list, &lobjc, &lobjv) != TCL_OK) { + Tcl_DecrRefCount(list); + return TCL_ERROR; + } + if (isList && (lobjc % 2)) { + Tcl_DecrRefCount(list); + Tcl_SetObjResult(interp, + Tcl_NewStringObj("need even number of elements", -1)); + return TCL_ERROR; + } + if (lobjc == 0) { + Tcl_DecrRefCount(list); + Tcl_SetObjResult(interp, Tcl_NewStringObj("empty archive", -1)); + return TCL_ERROR; + } + out = Tcl_OpenFileChannel(interp, Tcl_GetString(objv[1]), "w", 0755); + if ((out == NULL) || + (Tcl_SetChannelOption(interp, out, "-translation", "binary") + != TCL_OK) || + (Tcl_SetChannelOption(interp, out, "-encoding", "binary") + != TCL_OK)) { + Tcl_DecrRefCount(list); + Tcl_Close(interp, out); + return TCL_ERROR; + } + if (isImg) { + ZipFile zf0; + const char *imgName; + + if (isList) { + imgName = (objc > 4) ? Tcl_GetString(objv[4]) : + Tcl_GetNameOfExecutable(); + } else { + imgName = (objc > 5) ? Tcl_GetString(objv[5]) : + Tcl_GetNameOfExecutable(); + } + if (ZipFSOpenArchive(interp, imgName, 0, &zf0) != TCL_OK) { + Tcl_DecrRefCount(list); + Tcl_Close(interp, out); + return TCL_ERROR; + } + if ((pw != NULL) && pwlen) { + i = 0; + len = pwlen; + while (len > 0) { + int ch = pw[len - 1]; + + pwbuf[i] = (ch & 0x0f) | pwrot[(ch >> 4) & 0x0f]; + i++; + len--; + } + pwbuf[i] = i; + ++i; + pwbuf[i++] = (char) ZIP_PASSWORD_END_SIG; + pwbuf[i++] = (char) (ZIP_PASSWORD_END_SIG >> 8); + pwbuf[i++] = (char) (ZIP_PASSWORD_END_SIG >> 16); + pwbuf[i++] = (char) (ZIP_PASSWORD_END_SIG >> 24); + pwbuf[i] = '\0'; + } + i = Tcl_Write(out, (char *) zf0.data, zf0.baseoffsp); + if (i != zf0.baseoffsp) { + Tcl_DecrRefCount(list); + Tcl_SetObjResult(interp, Tcl_NewStringObj("write error", -1)); + Tcl_Close(interp, out); + ZipFSCloseArchive(interp, &zf0); + return TCL_ERROR; + } + ZipFSCloseArchive(interp, &zf0); + len = strlen(pwbuf); + if (len > 0) { + i = Tcl_Write(out, pwbuf, len); + if (i != len) { + Tcl_DecrRefCount(list); + Tcl_SetObjResult(interp, Tcl_NewStringObj("write error", -1)); + Tcl_Close(interp, out); + return TCL_ERROR; + } + } + memset(pwbuf, 0, sizeof (pwbuf)); + Tcl_Flush(out); + } + Tcl_InitHashTable(&fileHash, TCL_STRING_KEYS); + pos[0] = Tcl_Tell(out); + if (!isList && (objc > 3)) { + strip = Tcl_GetString(objv[3]); + slen = strlen(strip); + } + for (i = 0; i < lobjc; i += (isList ? 2 : 1)) { + const char *path, *name; + + path = Tcl_GetString(lobjv[i]); + if (isList) { + name = Tcl_GetString(lobjv[i + 1]); + } else { + name = path; + if (slen > 0) { + len = strlen(name); + if ((len <= slen) || (strncmp(strip, name, slen) != 0)) { + continue; + } + name += slen; + } + } + while (name[0] == '/') { + ++name; + } + if (name[0] == '\0') { + continue; + } + if (ZipAddFile(interp, path, name, out, pw, buf, sizeof (buf), + &fileHash) != TCL_OK) { + goto done; + } + } + pos[1] = Tcl_Tell(out); + count = 0; + for (i = 0; i < lobjc; i += (isList ? 2 : 1)) { + const char *path, *name; + + path = Tcl_GetString(lobjv[i]); + if (isList) { + name = Tcl_GetString(lobjv[i + 1]); + } else { + name = path; + if (slen > 0) { + len = strlen(name); + if ((len <= slen) || (strncmp(strip, name, slen) != 0)) { + continue; + } + name += slen; + } + } + while (name[0] == '/') { + ++name; + } + if (name[0] == '\0') { + continue; + } + hPtr = Tcl_FindHashEntry(&fileHash, name); + if (hPtr == NULL) { + continue; + } + z = (ZipEntry *) Tcl_GetHashValue(hPtr); + len = strlen(z->name); + zip_write_int(buf + ZIP_CENTRAL_SIG_OFFS, ZIP_CENTRAL_HEADER_SIG); + zip_write_short(buf + ZIP_CENTRAL_VERSIONMADE_OFFS, ZIP_MIN_VERSION); + zip_write_short(buf + ZIP_CENTRAL_VERSION_OFFS, ZIP_MIN_VERSION); + zip_write_short(buf + ZIP_CENTRAL_FLAGS_OFFS, z->isenc ? 1 : 0); + zip_write_short(buf + ZIP_CENTRAL_COMPMETH_OFFS, z->cmeth); + zip_write_short(buf + ZIP_CENTRAL_MTIME_OFFS, ToDosTime(z->timestamp)); + zip_write_short(buf + ZIP_CENTRAL_MDATE_OFFS, ToDosDate(z->timestamp)); + zip_write_int(buf + ZIP_CENTRAL_CRC32_OFFS, z->crc32); + zip_write_int(buf + ZIP_CENTRAL_COMPLEN_OFFS, z->nbytecompr); + zip_write_int(buf + ZIP_CENTRAL_UNCOMPLEN_OFFS, z->nbyte); + zip_write_short(buf + ZIP_CENTRAL_PATHLEN_OFFS, len); + zip_write_short(buf + ZIP_CENTRAL_EXTRALEN_OFFS, 0); + zip_write_short(buf + ZIP_CENTRAL_FCOMMENTLEN_OFFS, 0); + zip_write_short(buf + ZIP_CENTRAL_DISKFILE_OFFS, 0); + zip_write_short(buf + ZIP_CENTRAL_IATTR_OFFS, 0); + zip_write_int(buf + ZIP_CENTRAL_EATTR_OFFS, 0); + zip_write_int(buf + ZIP_CENTRAL_LOCALHDR_OFFS, z->offset - pos[0]); + if ((Tcl_Write(out, buf, ZIP_CENTRAL_HEADER_LEN) != + ZIP_CENTRAL_HEADER_LEN) || + (Tcl_Write(out, z->name, len) != len)) { + Tcl_SetObjResult(interp, Tcl_NewStringObj("write error", -1)); + goto done; + } + count++; + } + Tcl_Flush(out); + pos[2] = Tcl_Tell(out); + zip_write_int(buf + ZIP_CENTRAL_END_SIG_OFFS, ZIP_CENTRAL_END_SIG); + zip_write_short(buf + ZIP_CENTRAL_DISKNO_OFFS, 0); + zip_write_short(buf + ZIP_CENTRAL_DISKDIR_OFFS, 0); + zip_write_short(buf + ZIP_CENTRAL_ENTS_OFFS, count); + zip_write_short(buf + ZIP_CENTRAL_TOTALENTS_OFFS, count); + zip_write_int(buf + ZIP_CENTRAL_DIRSIZE_OFFS, pos[2] - pos[1]); + zip_write_int(buf + ZIP_CENTRAL_DIRSTART_OFFS, pos[1] - pos[0]); + zip_write_short(buf + ZIP_CENTRAL_COMMENTLEN_OFFS, 0); + if (Tcl_Write(out, buf, ZIP_CENTRAL_END_LEN) != ZIP_CENTRAL_END_LEN) { + Tcl_SetObjResult(interp, Tcl_NewStringObj("write error", -1)); + goto done; + } + Tcl_Flush(out); + ret = TCL_OK; +done: + if (ret == TCL_OK) { + ret = Tcl_Close(interp, out); + } else { + Tcl_Close(interp, out); + } + Tcl_DecrRefCount(list); + hPtr = Tcl_FirstHashEntry(&fileHash, &search); + while (hPtr != NULL) { + z = (ZipEntry *) Tcl_GetHashValue(hPtr); + Tcl_Free((char *) z); + Tcl_DeleteHashEntry(hPtr); + hPtr = Tcl_FirstHashEntry(&fileHash, &search); + } + Tcl_DeleteHashTable(&fileHash); + return ret; +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSMkZipObjCmd -- + * + * This procedure is invoked to process the "zipfs::mkzip" command. + * See description of ZipFSMkZipOrImgCmd(). + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See description of ZipFSMkZipOrImgCmd(). + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSMkZipObjCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]) +{ + return ZipFSMkZipOrImgObjCmd(clientData, interp, 0, 0, objc, objv); +} + +static int +ZipFSLMkZipObjCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]) +{ + return ZipFSMkZipOrImgObjCmd(clientData, interp, 0, 1, objc, objv); +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSMkImgObjCmd -- + * + * This procedure is invoked to process the "zipfs::mkimg" command. + * See description of ZipFSMkZipOrImgCmd(). + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See description of ZipFSMkZipOrImgCmd(). + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSMkImgObjCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]) +{ + return ZipFSMkZipOrImgObjCmd(clientData, interp, 1, 0, objc, objv); +} + +static int +ZipFSLMkImgObjCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]) +{ + return ZipFSMkZipOrImgObjCmd(clientData, interp, 1, 1, objc, objv); +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSExistsObjCmd -- + * + * This procedure is invoked to process the "zipfs::exists" command. + * It tests for the existence of a file in the ZIP filesystem and + * places a boolean into the interp's result. + * + * Results: + * Always TCL_OK. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSCanonicalObjCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]) +{ + char *mntpoint=NULL; + char *filename=NULL; + char *result; + Tcl_DString dPath; + + if (objc != 2 && objc != 3 && objc!=4) { + Tcl_WrongNumArgs(interp, 1, objv, "?mntpnt? filename ?ZIPFS?"); + return TCL_ERROR; + } + Tcl_DStringInit(&dPath); + if(objc==2) { + filename = Tcl_GetString(objv[1]); + result=CanonicalPath("",filename,&dPath,1); + } else if (objc==3) { + mntpoint = Tcl_GetString(objv[1]); + filename = Tcl_GetString(objv[2]); + result=CanonicalPath(mntpoint,filename,&dPath,1); + } else { + int zipfs=0; + if(Tcl_GetBooleanFromObj(interp,objv[3],&zipfs)) { + return TCL_ERROR; + } + mntpoint = Tcl_GetString(objv[1]); + filename = Tcl_GetString(objv[2]); + result=CanonicalPath(mntpoint,filename,&dPath,zipfs); + } + Tcl_SetObjResult(interp,Tcl_NewStringObj(result,-1)); + return TCL_OK; +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSExistsObjCmd -- + * + * This procedure is invoked to process the "zipfs::exists" command. + * It tests for the existence of a file in the ZIP filesystem and + * places a boolean into the interp's result. + * + * Results: + * Always TCL_OK. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSExistsObjCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]) +{ + char *filename; + int exists; + Tcl_DString ds; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "filename"); + return TCL_ERROR; + } + + /* prepend ZIPFS_VOLUME to filename, eliding the final / */ + filename = Tcl_GetStringFromObj(objv[1], 0); + Tcl_DStringInit(&ds); + Tcl_DStringAppend(&ds, ZIPFS_VOLUME, ZIPFS_VOLUME_LEN-1); + Tcl_DStringAppend(&ds, filename, -1); + filename = Tcl_DStringValue(&ds); + + ReadLock(); + exists = ZipFSLookup(filename) != NULL; + Unlock(); + + Tcl_SetObjResult(interp,Tcl_NewBooleanObj(exists)); + return TCL_OK; +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSInfoObjCmd -- + * + * This procedure is invoked to process the "zipfs::info" command. + * On success, it returns a Tcl list made up of name of ZIP archive + * file, size uncompressed, size compressed, and archive offset of + * a file in the ZIP filesystem. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSInfoObjCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]) +{ + char *filename; + ZipEntry *z; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "filename"); + return TCL_ERROR; + } + filename = Tcl_GetStringFromObj(objv[1], 0); + ReadLock(); + z = ZipFSLookup(filename); + if (z != NULL) { + Tcl_Obj *result = Tcl_GetObjResult(interp); + + Tcl_ListObjAppendElement(interp, result, + Tcl_NewStringObj(z->zipfile->name, -1)); + Tcl_ListObjAppendElement(interp, result, Tcl_NewIntObj(z->nbyte)); + Tcl_ListObjAppendElement(interp, result, Tcl_NewIntObj(z->nbytecompr)); + Tcl_ListObjAppendElement(interp, result, Tcl_NewIntObj(z->offset)); + } + Unlock(); + return TCL_OK; +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSListObjCmd -- + * + * This procedure is invoked to process the "zipfs::list" command. + * On success, it returns a Tcl list of files of the ZIP filesystem + * which match a search pattern (glob or regexp). + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSListObjCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]) +{ + char *pattern = NULL; + Tcl_RegExp regexp = NULL; + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + Tcl_Obj *result = Tcl_GetObjResult(interp); + + if (objc > 3) { + Tcl_WrongNumArgs(interp, 1, objv, "?(-glob|-regexp)? ?pattern?"); + return TCL_ERROR; + } + if (objc == 3) { + int n; + char *what = Tcl_GetStringFromObj(objv[1], &n); + + if ((n >= 2) && (strncmp(what, "-glob", n) == 0)) { + pattern = Tcl_GetString(objv[2]); + } else if ((n >= 2) && (strncmp(what, "-regexp", n) == 0)) { + regexp = Tcl_RegExpCompile(interp, Tcl_GetString(objv[2])); + if (regexp == NULL) { + return TCL_ERROR; + } + } else { + Tcl_AppendResult(interp, "unknown option \"", what, + "\"", (char *) NULL); + return TCL_ERROR; + } + } else if (objc == 2) { + pattern = Tcl_GetStringFromObj(objv[1], 0); + } + ReadLock(); + if (pattern != NULL) { + for (hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + ZipEntry *z = (ZipEntry *) Tcl_GetHashValue(hPtr); + + if (Tcl_StringMatch(z->name, pattern)) { + Tcl_ListObjAppendElement(interp, result, + Tcl_NewStringObj(z->name, -1)); + } + } + } else if (regexp != NULL) { + for (hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + ZipEntry *z = (ZipEntry *) Tcl_GetHashValue(hPtr); + + if (Tcl_RegExpExec(interp, regexp, z->name, z->name)) { + Tcl_ListObjAppendElement(interp, result, + Tcl_NewStringObj(z->name, -1)); + } + } + } else { + for (hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + ZipEntry *z = (ZipEntry *) Tcl_GetHashValue(hPtr); + + Tcl_ListObjAppendElement(interp, result, + Tcl_NewStringObj(z->name, -1)); + } + } + Unlock(); + return TCL_OK; +} + +/* + *------------------------------------------------------------------------- + * + * ZipChannelClose -- + * + * This function is called to close a channel. + * + * Results: + * Always TCL_OK. + * + * Side effects: + * Resources are free'd. + * + *------------------------------------------------------------------------- + */ + +static int +ZipChannelClose(ClientData instanceData, Tcl_Interp *interp) +{ + ZipChannel *info = (ZipChannel *) instanceData; + + if (info->iscompr && (info->ubuf != NULL)) { + Tcl_Free((char *) info->ubuf); + info->ubuf = NULL; + } + if (info->isenc) { + info->isenc = 0; + memset(info->keys, 0, sizeof (info->keys)); + } + if (info->iswr) { + ZipEntry *z = info->zipentry; + unsigned char *newdata; + + newdata = (unsigned char *) + Tcl_AttemptRealloc((char *) info->ubuf, info->nread); + if (newdata != NULL) { + if (z->data != NULL) { + Tcl_Free((char *) z->data); + } + z->data = newdata; + z->nbyte = z->nbytecompr = info->nbyte; + z->cmeth = ZIP_COMPMETH_STORED; + z->timestamp = time(NULL); + z->isdir = 0; + z->isenc = 0; + z->offset = 0; + z->crc32 = 0; + } else { + Tcl_Free((char *) info->ubuf); + } + } + WriteLock(); + info->zipfile->nopen--; + Unlock(); + Tcl_Free((char *) info); + return TCL_OK; +} + +/* + *------------------------------------------------------------------------- + * + * ZipChannelRead -- + * + * This function is called to read data from channel. + * + * Results: + * Number of bytes read or -1 on error with error number set. + * + * Side effects: + * Data is read and file pointer is advanced. + * + *------------------------------------------------------------------------- + */ + +static int +ZipChannelRead(ClientData instanceData, char *buf, int toRead, int *errloc) +{ + ZipChannel *info = (ZipChannel *) instanceData; + unsigned long nextpos; + + if (info->isdir) { + *errloc = EISDIR; + return -1; + } + nextpos = info->nread + toRead; + if (nextpos > info->nbyte) { + toRead = info->nbyte - info->nread; + nextpos = info->nbyte; + } + if (toRead == 0) { + return 0; + } + if (info->isenc) { + int i, ch; + + for (i = 0; i < toRead; i++) { + ch = info->ubuf[i + info->nread]; + buf[i] = zdecode(info->keys, crc32tab, ch); + } + } else { + memcpy(buf, info->ubuf + info->nread, toRead); + } + info->nread = nextpos; + *errloc = 0; + return toRead; +} + +/* + *------------------------------------------------------------------------- + * + * ZipChannelWrite -- + * + * This function is called to write data into channel. + * + * Results: + * Number of bytes written or -1 on error with error number set. + * + * Side effects: + * Data is written and file pointer is advanced. + * + *------------------------------------------------------------------------- + */ + +static int +ZipChannelWrite(ClientData instanceData, const char *buf, + int toWrite, int *errloc) +{ + ZipChannel *info = (ZipChannel *) instanceData; + unsigned long nextpos; + + if (!info->iswr) { + *errloc = EINVAL; + return -1; + } + nextpos = info->nread + toWrite; + if (nextpos > info->nmax) { + toWrite = info->nmax - info->nread; + nextpos = info->nmax; + } + if (toWrite == 0) { + return 0; + } + memcpy(info->ubuf + info->nread, buf, toWrite); + info->nread = nextpos; + if (info->nread > info->nbyte) { + info->nbyte = info->nread; + } + *errloc = 0; + return toWrite; +} + +/* + *------------------------------------------------------------------------- + * + * ZipChannelSeek -- + * + * This function is called to position file pointer of channel. + * + * Results: + * New file position or -1 on error with error number set. + * + * Side effects: + * File pointer is repositioned according to offset and mode. + * + *------------------------------------------------------------------------- + */ + +static int +ZipChannelSeek(ClientData instanceData, long offset, int mode, int *errloc) +{ + ZipChannel *info = (ZipChannel *) instanceData; + + if (info->isdir) { + *errloc = EINVAL; + return -1; + } + switch (mode) { + case SEEK_CUR: + offset += info->nread; + break; + case SEEK_END: + offset += info->nbyte; + break; + case SEEK_SET: + break; + default: + *errloc = EINVAL; + return -1; + } + if (offset < 0) { + *errloc = EINVAL; + return -1; + } + if (info->iswr) { + if ((unsigned long) offset > info->nmax) { + *errloc = EINVAL; + return -1; + } + if ((unsigned long) offset > info->nbyte) { + info->nbyte = offset; + } + } else if ((unsigned long) offset > info->nbyte) { + *errloc = EINVAL; + return -1; + } + info->nread = (unsigned long) offset; + return info->nread; +} + +/* + *------------------------------------------------------------------------- + * + * ZipChannelWatchChannel -- + * + * This function is called for event notifications on channel. + * + * Results: + * None. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static void +ZipChannelWatchChannel(ClientData instanceData, int mask) +{ + return; +} + +/* + *------------------------------------------------------------------------- + * + * ZipChannelGetFile -- + * + * This function is called to retrieve OS handle for channel. + * + * Results: + * Always TCL_ERROR since there's never an OS handle for a + * file within a ZIP archive. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static int +ZipChannelGetFile(ClientData instanceData, int direction, + ClientData *handlePtr) +{ + return TCL_ERROR; +} + +/* + * The channel type/driver definition used for ZIP archive members. + */ + +static Tcl_ChannelType ZipChannelType = { + "zip", /* Type name. */ +#ifdef TCL_CHANNEL_VERSION_4 + TCL_CHANNEL_VERSION_4, + ZipChannelClose, /* Close channel, clean instance data */ + ZipChannelRead, /* Handle read request */ + ZipChannelWrite, /* Handle write request */ + ZipChannelSeek, /* Move location of access point, NULL'able */ + NULL, /* Set options, NULL'able */ + NULL, /* Get options, NULL'able */ + ZipChannelWatchChannel, /* Initialize notifier */ + ZipChannelGetFile, /* Get OS handle from the channel */ + NULL, /* 2nd version of close channel, NULL'able */ + NULL, /* Set blocking mode for raw channel, NULL'able */ + NULL, /* Function to flush channel, NULL'able */ + NULL, /* Function to handle event, NULL'able */ + NULL, /* Wide seek function, NULL'able */ + NULL, /* Thread action function, NULL'able */ +#else + NULL, /* Set blocking/nonblocking behaviour, NULL'able */ + ZipChannelClose, /* Close channel, clean instance data */ + ZipChannelRead, /* Handle read request */ + ZipChannelWrite, /* Handle write request */ + ZipChannelSeek, /* Move location of access point, NULL'able */ + NULL, /* Set options, NULL'able */ + NULL, /* Get options, NULL'able */ + ZipChannelWatchChannel, /* Initialize notifier */ + ZipChannelGetFile, /* Get OS handle from the channel */ +#endif +}; + +/* + *------------------------------------------------------------------------- + * + * ZipChannelOpen -- + * + * This function opens a Tcl_Channel on a file from a mounted ZIP + * archive according to given open mode. + * + * Results: + * Tcl_Channel on success, or NULL on error. + * + * Side effects: + * Memory is allocated, the file from the ZIP archive is uncompressed. + * + *------------------------------------------------------------------------- + */ + +static Tcl_Channel +ZipChannelOpen(Tcl_Interp *interp, char *filename, int mode, int permissions) +{ + ZipEntry *z; + ZipChannel *info; + int i, ch, trunc, wr, flags = 0; + char cname[128]; + + if ((mode & O_APPEND) || + ((ZipFS.wrmax <= 0) && (mode & (O_WRONLY | O_RDWR)))) { + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj("unsupported open mode", -1)); + } + return NULL; + } + WriteLock(); + z = ZipFSLookup(filename); + if (z == NULL) { + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj("file not found", -1)); + Tcl_AppendResult(interp, " \"", filename, "\"", NULL); + } + goto error; + } + trunc = (mode & O_TRUNC) != 0; + wr = (mode & (O_WRONLY | O_RDWR)) != 0; + if ((z->cmeth != ZIP_COMPMETH_STORED) && + (z->cmeth != ZIP_COMPMETH_DEFLATED)) { + if (interp != NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("unsupported compression method", -1)); + } + goto error; + } + if (wr && z->isdir) { + if (interp != NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("unsupported file type", -1)); + } + goto error; + } + if (!trunc) { + flags |= TCL_READABLE; + if (z->isenc && (z->zipfile->pwbuf[0] == 0)) { + if (interp != NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("decryption failed", -1)); + } + goto error; + } else if (wr && (z->data == NULL) && (z->nbyte > ZipFS.wrmax)) { + if (interp != NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("file too large", -1)); + } + goto error; + } + } else { + flags = TCL_WRITABLE; + } + info = (ZipChannel *) Tcl_AttemptAlloc(sizeof (*info)); + if (info == NULL) { + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj("out of memory", -1)); + } + goto error; + } + info->zipfile = z->zipfile; + info->zipentry = z; + info->nread = 0; + if (wr) { + flags |= TCL_WRITABLE; + info->iswr = 1; + info->isdir = 0; + info->nmax = ZipFS.wrmax; + info->iscompr = 0; + info->isenc = 0; + info->ubuf = (unsigned char *) Tcl_AttemptAlloc(info->nmax); + if (info->ubuf == NULL) { +merror0: + if (info->ubuf != NULL) { + Tcl_Free((char *) info->ubuf); + } + Tcl_Free((char *) info); + if (interp != NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("out of memory", -1)); + } + goto error; + } + memset(info->ubuf, 0, info->nmax); + if (trunc) { + info->nbyte = 0; + } else { + if (z->data != NULL) { + unsigned int j = z->nbyte; + + if (j > info->nmax) { + j = info->nmax; + } + memcpy(info->ubuf, z->data, j); + info->nbyte = j; + } else { + unsigned char *zbuf = z->zipfile->data + z->offset; + + if (z->isenc) { + int len = z->zipfile->pwbuf[0]; + char pwbuf[260]; + + for (i = 0; i < len; i++) { + ch = z->zipfile->pwbuf[len - i]; + pwbuf[i] = (ch & 0x0f) | pwrot[(ch >> 4) & 0x0f]; + } + pwbuf[i] = '\0'; + init_keys(pwbuf, info->keys, crc32tab); + memset(pwbuf, 0, sizeof (pwbuf)); + for (i = 0; i < 12; i++) { + ch = info->ubuf[i]; + zdecode(info->keys, crc32tab, ch); + } + zbuf += i; + } + if (z->cmeth == ZIP_COMPMETH_DEFLATED) { + z_stream stream; + int err; + unsigned char *cbuf = NULL; + + memset(&stream, 0, sizeof (stream)); + stream.zalloc = Z_NULL; + stream.zfree = Z_NULL; + stream.opaque = Z_NULL; + stream.avail_in = z->nbytecompr; + if (z->isenc) { + unsigned int j; + + stream.avail_in -= 12; + cbuf = (unsigned char *) + Tcl_AttemptAlloc(stream.avail_in); + if (cbuf == NULL) { + goto merror0; + } + for (j = 0; j < stream.avail_in; j++) { + ch = info->ubuf[j]; + cbuf[j] = zdecode(info->keys, crc32tab, ch); + } + stream.next_in = cbuf; + } else { + stream.next_in = zbuf; + } + stream.next_out = info->ubuf; + stream.avail_out = info->nmax; + if (inflateInit2(&stream, -15) != Z_OK) { + goto cerror0; + } + err = inflate(&stream, Z_SYNC_FLUSH); + inflateEnd(&stream); + if ((err == Z_STREAM_END) || + ((err == Z_OK) && (stream.avail_in == 0))) { + if (cbuf != NULL) { + memset(info->keys, 0, sizeof (info->keys)); + Tcl_Free((char *) cbuf); + } + goto wrapchan; + } +cerror0: + if (cbuf != NULL) { + memset(info->keys, 0, sizeof (info->keys)); + Tcl_Free((char *) cbuf); + } + if (info->ubuf != NULL) { + Tcl_Free((char *) info->ubuf); + } + Tcl_Free((char *) info); + if (interp != NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("decompression error", -1)); + } + goto error; + } else if (z->isenc) { + for (i = 0; i < z->nbyte - 12; i++) { + ch = zbuf[i]; + info->ubuf[i] = zdecode(info->keys, crc32tab, ch); + } + } else { + memcpy(info->ubuf, zbuf, z->nbyte); + } + memset(info->keys, 0, sizeof (info->keys)); + goto wrapchan; + } + } + } else if (z->data != NULL) { + flags |= TCL_READABLE; + info->iswr = 0; + info->iscompr = 0; + info->isdir = 0; + info->isenc = 0; + info->nbyte = z->nbyte; + info->nmax = 0; + info->ubuf = z->data; + } else { + flags |= TCL_READABLE; + info->iswr = 0; + info->iscompr = z->cmeth == ZIP_COMPMETH_DEFLATED; + info->ubuf = z->zipfile->data + z->offset; + info->isdir = z->isdir; + info->isenc = z->isenc; + info->nbyte = z->nbyte; + info->nmax = 0; + if (info->isenc) { + int len = z->zipfile->pwbuf[0]; + char pwbuf[260]; + + for (i = 0; i < len; i++) { + ch = z->zipfile->pwbuf[len - i]; + pwbuf[i] = (ch & 0x0f) | pwrot[(ch >> 4) & 0x0f]; + } + pwbuf[i] = '\0'; + init_keys(pwbuf, info->keys, crc32tab); + memset(pwbuf, 0, sizeof (pwbuf)); + for (i = 0; i < 12; i++) { + ch = info->ubuf[i]; + zdecode(info->keys, crc32tab, ch); + } + info->ubuf += i; + } + if (info->iscompr) { + z_stream stream; + int err; + unsigned char *ubuf = NULL; + unsigned int j; + + memset(&stream, 0, sizeof (stream)); + stream.zalloc = Z_NULL; + stream.zfree = Z_NULL; + stream.opaque = Z_NULL; + stream.avail_in = z->nbytecompr; + if (info->isenc) { + stream.avail_in -= 12; + ubuf = (unsigned char *) Tcl_AttemptAlloc(stream.avail_in); + if (ubuf == NULL) { + info->ubuf = NULL; + goto merror; + } + for (j = 0; j < stream.avail_in; j++) { + ch = info->ubuf[j]; + ubuf[j] = zdecode(info->keys, crc32tab, ch); + } + stream.next_in = ubuf; + } else { + stream.next_in = info->ubuf; + } + stream.next_out = info->ubuf = + (unsigned char *) Tcl_AttemptAlloc(info->nbyte); + if (info->ubuf == NULL) { +merror: + if (ubuf != NULL) { + info->isenc = 0; + memset(info->keys, 0, sizeof (info->keys)); + Tcl_Free((char *) ubuf); + } + Tcl_Free((char *) info); + if (interp != NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("out of memory", -1)); + } + goto error; + } + stream.avail_out = info->nbyte; + if (inflateInit2(&stream, -15) != Z_OK) { + goto cerror; + } + err = inflate(&stream, Z_SYNC_FLUSH); + inflateEnd(&stream); + if ((err == Z_STREAM_END) || + ((err == Z_OK) && (stream.avail_in == 0))) { + if (ubuf != NULL) { + info->isenc = 0; + memset(info->keys, 0, sizeof (info->keys)); + Tcl_Free((char *) ubuf); + } + goto wrapchan; + } +cerror: + if (ubuf != NULL) { + info->isenc = 0; + memset(info->keys, 0, sizeof (info->keys)); + Tcl_Free((char *) ubuf); + } + if (info->ubuf != NULL) { + Tcl_Free((char *) info->ubuf); + } + Tcl_Free((char *) info); + if (interp != NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("decompression error", -1)); + } + goto error; + } + } +wrapchan: + sprintf(cname, "zipfs_%lx_%d", (unsigned long) z->offset, ZipFS.idCount++); + z->zipfile->nopen++; + Unlock(); + return Tcl_CreateChannel(&ZipChannelType, cname, (ClientData) info, flags); + +error: + Unlock(); + return NULL; +} + +/* + *------------------------------------------------------------------------- + * + * ZipEntryStat -- + * + * This function implements the ZIP filesystem specific version + * of the library version of stat. + * + * Results: + * See stat documentation. + * + * Side effects: + * See stat documentation. + * + *------------------------------------------------------------------------- + */ + +static int +ZipEntryStat(char *path, Tcl_StatBuf *buf) +{ + ZipEntry *z; + int ret = -1; + + ReadLock(); + z = ZipFSLookup(path); + if (z == NULL) { + goto done; + } + memset(buf, 0, sizeof (Tcl_StatBuf)); + if (z->isdir) { + buf->st_mode = S_IFDIR | 0555; + } else { + buf->st_mode = S_IFREG | 0555; + } + buf->st_size = z->nbyte; + buf->st_mtime = z->timestamp; + buf->st_ctime = z->timestamp; + buf->st_atime = z->timestamp; + ret = 0; +done: + Unlock(); + return ret; +} + +/* + *------------------------------------------------------------------------- + * + * ZipEntryAccess -- + * + * This function implements the ZIP filesystem specific version + * of the library version of access. + * + * Results: + * See access documentation. + * + * Side effects: + * See access documentation. + * + *------------------------------------------------------------------------- + */ + +static int +ZipEntryAccess(char *path, int mode) +{ + ZipEntry *z; + + if (mode & 3) { + return -1; + } + ReadLock(); + z = ZipFSLookup(path); + Unlock(); + return (z != NULL) ? 0 : -1; +} + +/* + *------------------------------------------------------------------------- + * + * Zip_FSOpenFileChannelProc -- + * + * Results: + * + * Side effects: + * + *------------------------------------------------------------------------- + */ + +static Tcl_Channel +Zip_FSOpenFileChannelProc(Tcl_Interp *interp, Tcl_Obj *pathPtr, + int mode, int permissions) +{ + int len; + + if (!(pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr))) return NULL; + + return ZipChannelOpen(interp, Tcl_GetStringFromObj(pathPtr, &len), + mode, permissions); +} + +/* + *------------------------------------------------------------------------- + * + * Zip_FSStatProc -- + * + * This function implements the ZIP filesystem specific version + * of the library version of stat. + * + * Results: + * See stat documentation. + * + * Side effects: + * See stat documentation. + * + *------------------------------------------------------------------------- + */ + +static int +Zip_FSStatProc(Tcl_Obj *pathPtr, Tcl_StatBuf *buf) +{ + int len; + + if (!(pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr))) return -1; + + return ZipEntryStat(Tcl_GetStringFromObj(pathPtr, &len), buf); +} + +/* + *------------------------------------------------------------------------- + * + * Zip_FSAccessProc -- + * + * This function implements the ZIP filesystem specific version + * of the library version of access. + * + * Results: + * See access documentation. + * + * Side effects: + * See access documentation. + * + *------------------------------------------------------------------------- + */ + +static int +Zip_FSAccessProc(Tcl_Obj *pathPtr, int mode) +{ + int len; + + if (!(pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr))) return -1; + + return ZipEntryAccess(Tcl_GetStringFromObj(pathPtr, &len), mode); +} + +/* + *------------------------------------------------------------------------- + * + * Zip_FSFilesystemSeparatorProc -- + * + * This function returns the separator to be used for a given path. The + * object returned should have a refCount of zero + * + * Results: + * A Tcl object, with a refCount of zero. If the caller needs to retain a + * reference to the object, it should call Tcl_IncrRefCount, and should + * otherwise free the object. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static Tcl_Obj * +Zip_FSFilesystemSeparatorProc(Tcl_Obj *pathPtr) +{ + return Tcl_NewStringObj("/", -1); +} + +/* + *------------------------------------------------------------------------- + * + * Zip_FSMatchInDirectoryProc -- + * + * This routine is used by the globbing code to search a directory for + * all files which match a given pattern. + * + * Results: + * The return value is a standard Tcl result indicating whether an + * error occurred in globbing. Errors are left in interp, good + * results are lappend'ed to resultPtr (which must be a valid object). + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ +static int +Zip_FSMatchInDirectoryProc(Tcl_Interp* interp, Tcl_Obj *result, + Tcl_Obj *pathPtr, const char *pattern, + Tcl_GlobTypeData *types) +{ + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + Tcl_Obj *normPathPtr; + int scnt, len, l, dirOnly = -1, prefixLen, strip = 0; + char *pat, *prefix, *path; + Tcl_DString dsPref; + + if (!(normPathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr))) return -1; + + if (types != NULL) { + dirOnly = (types->type & TCL_GLOB_TYPE_DIR) == TCL_GLOB_TYPE_DIR; + } + + /* the prefix that gets prepended to results */ + prefix = Tcl_GetStringFromObj(pathPtr, &prefixLen); + + /* the (normalized) path we're searching */ + path = Tcl_GetStringFromObj(normPathPtr, &len); + + Tcl_DStringInit(&dsPref); + Tcl_DStringAppend(&dsPref, prefix, prefixLen); + + if (strcmp(prefix, path) == 0) { + prefix = NULL; + } else { + strip = len + 1; + } + if (prefix != NULL) { + Tcl_DStringAppend(&dsPref, "/", 1); + prefixLen++; + prefix = Tcl_DStringValue(&dsPref); + } + ReadLock(); + if ((types != NULL) && (types->type == TCL_GLOB_TYPE_MOUNT)) { + l = CountSlashes(path); + if (path[len - 1] == '/') { + len--; + } else { + l++; + } + if ((pattern == NULL) || (pattern[0] == '\0')) { + pattern = "*"; + } + hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); + while (hPtr != NULL) { + ZipFile *zf = (ZipFile *) Tcl_GetHashValue(hPtr); + + if (zf->mntptlen == 0) { + ZipEntry *z = zf->topents; + while (z != NULL) { + int lenz = strlen(z->name); + if ((lenz > len + 1) && + (strncmp(z->name, path, len) == 0) && + (z->name[len] == '/') && + (CountSlashes(z->name) == l) && + Tcl_StringCaseMatch(z->name + len + 1, pattern, 0)) { + if (prefix != NULL) { + Tcl_DStringAppend(&dsPref, z->name, lenz); + Tcl_ListObjAppendElement(NULL, result, + Tcl_NewStringObj(Tcl_DStringValue(&dsPref), + Tcl_DStringLength(&dsPref))); + Tcl_DStringSetLength(&dsPref, prefixLen); + } else { + Tcl_ListObjAppendElement(NULL, result, + Tcl_NewStringObj(z->name, lenz)); + } + } + z = z->tnext; + } + } else if ((zf->mntptlen > len + 1) && + (strncmp(zf->mntpt, path, len) == 0) && + (zf->mntpt[len] == '/') && + (CountSlashes(zf->mntpt) == l) && + Tcl_StringCaseMatch(zf->mntpt + len + 1, pattern, 0)) { + if (prefix != NULL) { + Tcl_DStringAppend(&dsPref, zf->mntpt, zf->mntptlen); + Tcl_ListObjAppendElement(NULL, result, + Tcl_NewStringObj(Tcl_DStringValue(&dsPref), + Tcl_DStringLength(&dsPref))); + Tcl_DStringSetLength(&dsPref, prefixLen); + } else { + Tcl_ListObjAppendElement(NULL, result, + Tcl_NewStringObj(zf->mntpt, zf->mntptlen)); + } + } + hPtr = Tcl_NextHashEntry(&search); + } + goto end; + } + if ((pattern == NULL) || (pattern[0] == '\0')) { + hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, path); + if (hPtr != NULL) { + ZipEntry *z = (ZipEntry *) Tcl_GetHashValue(hPtr); + + if ((dirOnly < 0) || + (!dirOnly && !z->isdir) || + (dirOnly && z->isdir)) { + if (prefix != NULL) { + Tcl_DStringAppend(&dsPref, z->name, -1); + Tcl_ListObjAppendElement(NULL, result, + Tcl_NewStringObj(Tcl_DStringValue(&dsPref), + Tcl_DStringLength(&dsPref))); + Tcl_DStringSetLength(&dsPref, prefixLen); + } else { + Tcl_ListObjAppendElement(NULL, result, + Tcl_NewStringObj(z->name, -1)); + } + } + } + goto end; + } + l = strlen(pattern); + pat = Tcl_Alloc(len + l + 2); + memcpy(pat, path, len); + while ((len > 1) && (pat[len - 1] == '/')) { + --len; + } + if ((len > 1) || (pat[0] != '/')) { + pat[len] = '/'; + ++len; + } + memcpy(pat + len, pattern, l + 1); + scnt = CountSlashes(pat); + for (hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + ZipEntry *z = (ZipEntry *) Tcl_GetHashValue(hPtr); + if ((dirOnly >= 0) && + ((dirOnly && !z->isdir) || (!dirOnly && z->isdir))) { + continue; + } + if ((z->depth == scnt) && Tcl_StringCaseMatch(z->name, pat, 0)) { + if (prefix != NULL) { + Tcl_DStringAppend(&dsPref, z->name + strip, -1); + Tcl_ListObjAppendElement(NULL, result, + Tcl_NewStringObj(Tcl_DStringValue(&dsPref), + Tcl_DStringLength(&dsPref))); + Tcl_DStringSetLength(&dsPref, prefixLen); + } else { + Tcl_ListObjAppendElement(NULL, result, + Tcl_NewStringObj(z->name + strip, -1)); + } + } + } + Tcl_Free(pat); +end: + Unlock(); + Tcl_DStringFree(&dsPref); + return TCL_OK; +} + +/* + *------------------------------------------------------------------------- + * + * Zip_FSPathInFilesystemProc -- + * + * This function determines if the given path object is in the + * ZIP filesystem. + * + * Results: + * TCL_OK when the path object is in the ZIP filesystem, -1 otherwise. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static int +Zip_FSPathInFilesystemProc(Tcl_Obj *pathPtr, ClientData *clientDataPtr) +{ + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + ZipFile *zf; + int ret = -1, len; + char *path; + + if (!(pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr))) return -1; + + path = Tcl_GetStringFromObj(pathPtr, &len); + if(strncmp(path,ZIPFS_VOLUME,ZIPFS_VOLUME_LEN)!=0) { + return -1; + } + + len = strlen(path); + + ReadLock(); + hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, path); + if (hPtr != NULL) { + ret = TCL_OK; + goto endloop; + } + hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); + while (hPtr != NULL) { + zf = (ZipFile *) Tcl_GetHashValue(hPtr); + if (zf->mntptlen == 0) { + ZipEntry *z = zf->topents; + while (z != NULL) { + int lenz = strlen(z->name); + + if ((len >= lenz) && + (strncmp(path, z->name, lenz) == 0)) { + ret = TCL_OK; + goto endloop; + } + z = z->tnext; + } + } else if ((len >= zf->mntptlen) && + (strncmp(path, zf->mntpt, zf->mntptlen) == 0)) { + ret = TCL_OK; + goto endloop; + } + hPtr = Tcl_NextHashEntry(&search); + } +endloop: + Unlock(); + return ret; +} + +/* + *------------------------------------------------------------------------- + * + * Zip_FSListVolumesProc -- + * + * Lists the currently mounted ZIP filesystem volumes. + * + * Results: + * The list of volumes. + * + * Side effects: + * None + * + *------------------------------------------------------------------------- + */ +static Tcl_Obj * +Zip_FSListVolumesProc(void) { + return Tcl_NewStringObj(ZIPFS_VOLUME, -1); +} + +/* + *------------------------------------------------------------------------- + * + * Zip_FSFileAttrStringsProc -- + * + * This function implements the ZIP filesystem dependent 'file attributes' + * subcommand, for listing the set of possible attribute strings. + * + * Results: + * An array of strings + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static const char *const * +Zip_FSFileAttrStringsProc(Tcl_Obj *pathPtr, Tcl_Obj** objPtrRef) +{ + static const char *const attrs[] = { + "-uncompsize", + "-compsize", + "-offset", + "-mount", + "-archive", + "-permissions", + NULL, + }; + + return attrs; +} + +/* + *------------------------------------------------------------------------- + * + * Zip_FSFileAttrsGetProc -- + * + * This function implements the ZIP filesystem specific + * 'file attributes' subcommand, for 'get' operations. + * + * Results: + * Standard Tcl return code. The object placed in objPtrRef (if TCL_OK + * was returned) is likely to have a refCount of zero. Either way we must + * either store it somewhere (e.g. the Tcl result), or Incr/Decr its + * refCount to ensure it is properly freed. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static int +Zip_FSFileAttrsGetProc(Tcl_Interp *interp, int index, Tcl_Obj *pathPtr, + Tcl_Obj **objPtrRef) +{ + int len, ret = TCL_OK; + char *path; + ZipEntry *z; + + if (!(pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr))) return -1; + + path = Tcl_GetStringFromObj(pathPtr, &len); + ReadLock(); + z = ZipFSLookup(path); + if (z == NULL) { + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj("file not found", -1)); + } + ret = TCL_ERROR; + goto done; + } + switch (index) { + case 0: + *objPtrRef = Tcl_NewIntObj(z->nbyte); + goto done; + case 1: + *objPtrRef= Tcl_NewIntObj(z->nbytecompr); + goto done; + case 2: + *objPtrRef= Tcl_NewLongObj(z->offset); + goto done; + case 3: + *objPtrRef= Tcl_NewStringObj(z->zipfile->mntpt, -1); + goto done; + case 4: + *objPtrRef= Tcl_NewStringObj(z->zipfile->name, -1); + goto done; + case 5: + *objPtrRef= Tcl_NewStringObj("0555", -1); + goto done; + } + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj("unknown attribute", -1)); + } + ret = TCL_ERROR; +done: + Unlock(); + return ret; +} + +/* + *------------------------------------------------------------------------- + * + * Zip_FSFileAttrsSetProc -- + * + * This function implements the ZIP filesystem specific + * 'file attributes' subcommand, for 'set' operations. + * + * Results: + * Standard Tcl return code. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static int +Zip_FSFileAttrsSetProc(Tcl_Interp *interp, int index, Tcl_Obj *pathPtr, + Tcl_Obj *objPtr) +{ + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj("unsupported operation", -1)); + } + return TCL_ERROR; +} + +/* + *------------------------------------------------------------------------- + * + * Zip_FSFilesystemPathTypeProc -- + * + * Results: + * + * Side effects: + * + *------------------------------------------------------------------------- + */ + +static Tcl_Obj * +Zip_FSFilesystemPathTypeProc(Tcl_Obj *pathPtr) +{ + return Tcl_NewStringObj("zip", -1); +} + + +/* + *------------------------------------------------------------------------- + * + * Zip_FSLoadFile -- + * + * This functions deals with loading native object code. If + * the given path object refers to a file within the ZIP + * filesystem, an approriate error code is returned to delegate + * loading to the caller (by copying the file to temp store + * and loading from there). As fallback when the file refers + * to the ZIP file system but is not present, it is looked up + * relative to the executable and loaded from there when available. + * + * Results: + * TCL_OK on success, -1 otherwise with error number set. + * + * Side effects: + * Loads native code into the process address space. + * + *------------------------------------------------------------------------- + */ + +static int +Zip_FSLoadFile(Tcl_Interp *interp, Tcl_Obj *path, Tcl_LoadHandle *loadHandle, + Tcl_FSUnloadFileProc **unloadProcPtr, int flags) +{ + Tcl_FSLoadFileProc2 *loadFileProc; +#ifdef ANDROID + /* + * Force loadFileProc to native implementation since the + * package manger already extracted the shared libraries + * from the APK at install time. + */ + + loadFileProc = (Tcl_FSLoadFileProc2 *) tclNativeFilesystem.loadFileProc; + if (loadFileProc != NULL) { + return loadFileProc(interp, path, loadHandle, unloadProcPtr, flags); + } + Tcl_SetErrno(ENOENT); + return -1; +#else + Tcl_Obj *altPath = NULL; + int ret = -1; + + if (Tcl_FSAccess(path, R_OK) == 0) { + /* + * EXDEV should trigger loading by copying to temp store. + */ + Tcl_SetErrno(EXDEV); + return ret; + } else { + Tcl_Obj *objs[2] = { NULL, NULL }; + + objs[1] = TclPathPart(interp, path, TCL_PATH_DIRNAME); + if ((objs[1] != NULL) && (Zip_FSAccessProc(objs[1], R_OK) == 0)) { + const char *execName = Tcl_GetNameOfExecutable(); + + /* + * Shared object is not in ZIP but its path prefix is, + * thus try to load from directory where the executable + * came from. + */ + TclDecrRefCount(objs[1]); + objs[1] = TclPathPart(interp, path, TCL_PATH_TAIL); + /* + * Get directory name of executable manually to deal + * with cases where [file dirname [info nameofexecutable]] + * is equal to [info nameofexecutable] due to VFS effects. + */ + if (execName != NULL) { + const char *p = strrchr(execName, '/'); + + if (p > execName + 1) { + --p; + objs[0] = Tcl_NewStringObj(execName, p - execName); + } + } + if (objs[0] == NULL) { + objs[0] = TclPathPart(interp, TclGetObjNameOfExecutable(), + TCL_PATH_DIRNAME); + } + if (objs[0] != NULL) { + altPath = TclJoinPath(2, objs); + if (altPath != NULL) { + Tcl_IncrRefCount(altPath); + if (Tcl_FSAccess(altPath, R_OK) == 0) { + path = altPath; + } + } + } + } + if (objs[0] != NULL) { + Tcl_DecrRefCount(objs[0]); + } + if (objs[1] != NULL) { + Tcl_DecrRefCount(objs[1]); + } + } + loadFileProc = (Tcl_FSLoadFileProc2 *) tclNativeFilesystem.loadFileProc; + if (loadFileProc != NULL) { + ret = loadFileProc(interp, path, loadHandle, unloadProcPtr, flags); + } else { + Tcl_SetErrno(ENOENT); + } + if (altPath != NULL) { + Tcl_DecrRefCount(altPath); + } + return ret; +#endif +} + + +/* + * Define the ZIP filesystem dispatch table. + */ + +MODULE_SCOPE const Tcl_Filesystem zipfsFilesystem; + +const Tcl_Filesystem zipfsFilesystem = { + "zipfs", + sizeof (Tcl_Filesystem), + TCL_FILESYSTEM_VERSION_2, + Zip_FSPathInFilesystemProc, + NULL, /* dupInternalRepProc */ + NULL, /* freeInternalRepProc */ + NULL, /* internalToNormalizedProc */ + NULL, /* createInternalRepProc */ + NULL, /* normalizePathProc */ + Zip_FSFilesystemPathTypeProc, + Zip_FSFilesystemSeparatorProc, + Zip_FSStatProc, + Zip_FSAccessProc, + Zip_FSOpenFileChannelProc, + Zip_FSMatchInDirectoryProc, + NULL, /* utimeProc */ + NULL, /* linkProc */ + Zip_FSListVolumesProc, + Zip_FSFileAttrStringsProc, + Zip_FSFileAttrsGetProc, + Zip_FSFileAttrsSetProc, + NULL, /* createDirectoryProc */ + NULL, /* removeDirectoryProc */ + NULL, /* deleteFileProc */ + NULL, /* copyFileProc */ + NULL, /* renameFileProc */ + NULL, /* copyDirectoryProc */ + NULL, /* lstatProc */ + (Tcl_FSLoadFileProc *) Zip_FSLoadFile, + NULL, /* getCwdProc */ + NULL, /* chdirProc*/ +}; + +#endif /* HAVE_ZLIB */ + + + +/* + *------------------------------------------------------------------------- + * + * TclZipfs_Init -- + * + * Perform per interpreter initialization of this module. + * + * Results: + * The return value is a standard Tcl result. + * + * Side effects: + * Initializes this module if not already initialized, and adds + * module related commands to the given interpreter. + * + *------------------------------------------------------------------------- + */ + +MODULE_SCOPE int +TclZipfs_Init(Tcl_Interp *interp) +{ +#ifdef HAVE_ZLIB + /* one-time initialization */ + WriteLock(); + Tcl_StaticPackage(interp, "zipfs", TclZipfs_Init, TclZipfs_Init); + if (!ZipFS.initialized) { +#ifdef TCL_THREADS + static const Tcl_Time t = { 0, 0 }; + /* + * Inflate condition variable. + */ + Tcl_MutexLock(&ZipFSMutex); + Tcl_ConditionWait(&ZipFSCond, &ZipFSMutex, &t); + Tcl_MutexUnlock(&ZipFSMutex); +#endif + Tcl_FSRegister(NULL, &zipfsFilesystem); + Tcl_InitHashTable(&ZipFS.fileHash, TCL_STRING_KEYS); + Tcl_InitHashTable(&ZipFS.zipHash, TCL_STRING_KEYS); + ZipFS.initialized = ZipFS.idCount = 1; + } + Unlock(); + if(interp != NULL) { + static const EnsembleImplMap initMap[] = { + {"mount", ZipFSMountObjCmd, NULL, NULL, NULL, 0}, + {"unmount", ZipFSUnmountObjCmd, NULL, NULL, NULL, 0}, + {"mkkey", ZipFSMkKeyObjCmd, NULL, NULL, NULL, 0}, + {"mkimg", ZipFSMkImgObjCmd, NULL, NULL, NULL, 0}, + {"mkzip", ZipFSMkZipObjCmd, NULL, NULL, NULL, 0}, + {"lmkimg", ZipFSLMkImgObjCmd, NULL, NULL, NULL, 0}, + {"lmkzip", ZipFSLMkZipObjCmd, NULL, NULL, NULL, 0}, + {"exists", ZipFSExistsObjCmd, NULL, NULL, NULL, 1}, + {"info", ZipFSInfoObjCmd, NULL, NULL, NULL, 1}, + {"list", ZipFSListObjCmd, NULL, NULL, NULL, 1}, + {"canonical", ZipFSCanonicalObjCmd, NULL, NULL, NULL, 1}, + {NULL, NULL, NULL, NULL, NULL, 0} + }; + static const char findproc[] = + "namespace eval zipfs {}\n" + "proc ::zipfs::find dir {\n" + " set result {}\n" + " if {[catch {glob -directory $dir -tails -nocomplain * .*} list]} {\n" + " return $result\n" + " }\n" + " foreach file $list {\n" + " if {$file eq \".\" || $file eq \"..\"} {\n" + " continue\n" + " }\n" + " set file [file join $dir $file]\n" + " lappend result $file\n" + " foreach file [::zipfs::find $file] {\n" + " lappend result $file\n" + " }\n" + " }\n" + " return [lsort $result]\n" + "}\n"; + Tcl_EvalEx(interp, findproc, -1, TCL_EVAL_GLOBAL); + Tcl_LinkVar(interp, "::zipfs::wrmax", (char *) &ZipFS.wrmax, + TCL_LINK_INT); + TclMakeEnsemble(interp, "zipfs", initMap); + Tcl_PkgProvide(interp, "zipfs", "2.0"); + } + return TCL_OK; +#else + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj("no zlib available", -1)); + } + return TCL_ERROR; +#endif +} + +static int TclZipfs_AppHook_FindTclInit(const char *archive){ + Tcl_Obj *vfsinitscript; + int found; + if(TclZipfs_Mount(NULL, archive, ZIPFS_ZIP_MOUNT, NULL)) { + /* Either the file doesn't exist or it is not a zip archive */ + return TCL_ERROR; + } + vfsinitscript=Tcl_NewStringObj(ZIPFS_ZIP_MOUNT "/init.tcl",-1); + Tcl_IncrRefCount(vfsinitscript); + found=Tcl_FSAccess(vfsinitscript,F_OK); + if(found==0) { + return TCL_OK; + } + Tcl_DecrRefCount(vfsinitscript); + vfsinitscript=Tcl_NewStringObj(ZIPFS_ZIP_MOUNT "/tcl_library/init.tcl",-1); + Tcl_IncrRefCount(vfsinitscript); + found=Tcl_FSAccess(vfsinitscript,F_OK); + if(found==0) { + return TCL_OK; + } + return TCL_ERROR; +} + +int TclZipfs_AppHook(int *argc, char ***argv){ + /* + * Tclkit_MainHook -- + * Performs the argument munging for the shell + */ + + CONST char *archive; + Tcl_FindExecutable(*argv[0]); + archive=Tcl_GetNameOfExecutable(); + TclZipfs_Init(NULL); + TclSetPreInitScript( +"foreach {path} {\n" +" {" ZIPFS_APP_MOUNT "/tcl_library}\n" +" {" ZIPFS_ZIP_MOUNT "/tcl_library}\n" +"} {\n" +" if {![file exists [file join $path init.tcl]]} continue\n" +" set ::tcl_library $path\n" +" break\n" +"}\n" +"foreach {path} {\n" +" {" ZIPFS_APP_MOUNT "/tk_library}\n" +" {" ZIPFS_ZIP_MOUNT "/tk_library}\n" +" {" ZIPFS_VOLUME "lib/tk/tk_library}\n" +"} {\n" +" if {[file exists [file join $path init.tcl]]} continue\n" +" set ::tk_library $path\n" +" break\n" +"}\n" + ); + if(!TclZipfs_Mount(NULL, archive, ZIPFS_APP_MOUNT, NULL)) { + int found; + Tcl_Obj *vfsinitscript; + vfsinitscript=Tcl_NewStringObj(ZIPFS_APP_MOUNT "/main.tcl",-1); + Tcl_IncrRefCount(vfsinitscript); + if(Tcl_FSAccess(vfsinitscript,F_OK)==0) { + /* Startup script should be set before calling Tcl_AppInit */ + Tcl_SetStartupScript(vfsinitscript,NULL); + } else { + Tcl_DecrRefCount(vfsinitscript); + } + /* Set Tcl Encodings */ + vfsinitscript=Tcl_NewStringObj(ZIPFS_APP_MOUNT "/tcl_library/init.tcl",-1); + Tcl_IncrRefCount(vfsinitscript); + found=Tcl_FSAccess(vfsinitscript,F_OK); + Tcl_DecrRefCount(vfsinitscript); + if(found==TCL_OK) { + return TCL_OK; + } + } + /* Mount zip file and dll before releasing to search */ + if(TclZipfs_AppHook_FindTclInit(CFG_RUNTIME_ZIPFILE)==TCL_OK) { + return TCL_OK; + } + if(TclZipfs_AppHook_FindTclInit(CFG_RUNTIME_PATH "/" CFG_RUNTIME_ZIPFILE)==TCL_OK) { + return TCL_OK; + } + if(TclZipfs_AppHook_FindTclInit(CFG_RUNTIME_PATH "/" CFG_RUNTIME_DLLFILE)==TCL_OK) { + return TCL_OK; + } + return TCL_OK; +} + + +#ifndef HAVE_ZLIB + +/* + *------------------------------------------------------------------------- + * + * TclZipfs_Mount, TclZipfs_Unmount -- + * + * Dummy version when no ZLIB support available. + * + *------------------------------------------------------------------------- + */ + +int +TclZipfs_Mount(Tcl_Interp *interp, const char *zipname, const char *mntpt, + const char *passwd) +{ + return TclZipfs_Init(interp, 1); +} + +int +TclZipfs_Unmount(Tcl_Interp *interp, const char *zipname) +{ + return TclZipfs_Init(interp, 1); +} + +#endif + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: library/init.tcl ================================================================== --- library/init.tcl +++ library/init.tcl @@ -833,6 +833,10 @@ if {[file tail $s] ni {. ..}} { file copy -force -- $s [file join $dest [file tail $s]] } } return +} +if {[file exists [file join $::tcl_library pkgIndex.tcl]]} { + set dir $::tcl_library + source [file join $::tcl_library pkgIndex.tcl] } Index: library/opt/optparse.tcl ================================================================== --- library/opt/optparse.tcl +++ library/opt/optparse.tcl @@ -6,14 +6,14 @@ # WARNING: This code will go away in a future release # of Tcl. It is NOT supported and you should not rely # on it. If your code does rely on this package you # may directly incorporate this code into your application. -package require Tcl 8.2 +package require Tcl 8.5- # When this version number changes, update the pkgIndex.tcl file # and the install directory in the Makefiles. -package provide opt 0.4.6 +package provide opt 0.4.7 namespace eval ::tcl { # Exported APIs namespace export OptKeyRegister OptKeyDelete OptKeyError OptKeyParse \ Index: library/opt/pkgIndex.tcl ================================================================== --- library/opt/pkgIndex.tcl +++ library/opt/pkgIndex.tcl @@ -6,7 +6,7 @@ # information so that packages will be loaded automatically # in response to "package require" commands. When this # script is sourced, the variable $dir must contain the # full path name of this file's directory. -if {![package vsatisfies [package provide Tcl] 8.2]} {return} -package ifneeded opt 0.4.6 [list source [file join $dir optparse.tcl]] +if {![package vsatisfies [package provide Tcl] 8.5-]} {return} +package ifneeded opt 0.4.7 [list source [file join $dir optparse.tcl]] ADDED library/pkgIndex.tcl Index: library/pkgIndex.tcl ================================================================== --- /dev/null +++ library/pkgIndex.tcl @@ -0,0 +1,16 @@ +### +# Package manifest for all Tcl packages included in the /library file system +### +foreach {package version file} { + http 2.8.12 {http http.tcl} + http 1.0 {http1.0 http.tcl} + msgcat 1.6.1 {msgcat msgcat.tcl} + opt 0.4.7 {opt optparse.tcl} + platform 1.0.14 {platform platform.tcl} + platform::shell 1.1.4 {platform shell.tcl} + tcltest 2.4.1 {tcltest tcltest.tcl} +} { + package ifneeded $package $version [list source [file join $dir {*}$file]] +} +# Opt is the odd man out +package ifneeded opt 0.4.7 [list source [file join $dir opt optparse.tcl]] Index: library/tcltest/pkgIndex.tcl ================================================================== --- library/tcltest/pkgIndex.tcl +++ library/tcltest/pkgIndex.tcl @@ -6,7 +6,7 @@ # information so that packages will be loaded automatically # in response to "package require" commands. When this # script is sourced, the variable $dir must contain the # full path name of this file's directory. -if {![package vsatisfies [package provide Tcl] 8.5]} {return} -package ifneeded tcltest 2.4.0 [list source [file join $dir tcltest.tcl]] +if {![package vsatisfies [package provide Tcl] 8.5-]} {return} +package ifneeded tcltest 2.4.1 [list source [file join $dir tcltest.tcl]] Index: library/tcltest/tcltest.tcl ================================================================== --- library/tcltest/tcltest.tcl +++ library/tcltest/tcltest.tcl @@ -20,11 +20,11 @@ namespace eval tcltest { # When the version number changes, be sure to update the pkgIndex.tcl file, # and the install directory in the Makefiles. When the minor version # changes (new feature) be sure to update the man page as well. - variable Version 2.4.0 + variable Version 2.4.1 # Compatibility support for dumb variables defined in tcltest 1 # Do not use these. Call [package provide Tcl] and [info patchlevel] # yourself. You don't need tcltest to wrap it for you. variable version [package provide Tcl] Index: tests/package.test ================================================================== --- tests/package.test +++ tests/package.test @@ -18,22 +18,23 @@ } ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] -testConstraint testpreferstable [llength [info commands testpreferstable]] - # Do all this in a slave interp to avoid garbaging the package list set i [interp create] tcltest::loadIntoSlaveInterpreter $i {*}$argv +load {} Tcltest $i interp eval $i { namespace import -force ::tcltest::* -package forget {*}[package names] +#package forget {*}[package names] set oldPkgUnknown [package unknown] package unknown {} set oldPath $auto_path set auto_path "" + +testConstraint testpreferstable [llength [info commands testpreferstable]] test package-1.1 {pkg::create gives error on insufficient args} -body { ::pkg::create } -returnCodes error -match glob -result {wrong # args: should be "*"} test package-1.2 {pkg::create gives error on bad args} -body { @@ -137,51 +138,51 @@ } -body { foreach i {1.4 3.4 2.3 2.4 2.2} { package ifneeded t $i "set x $i; package provide t $i" } package require t - return $x + set x } -result {3.4} test package-3.2 {Tcl_PkgRequire procedure, picking best version} -setup { package forget t set x xxx } -body { foreach i {1.4 3.4 2.3 2.4 2.2 3.5 3.2} { package ifneeded t $i "set x $i; package provide t $i" } package require t - return $x + set x } -result {3.5} test package-3.3 {Tcl_PkgRequire procedure, picking best version} -setup { package forget t set x xxx } -body { foreach i {3.5 2.1 2.3} { package ifneeded t $i "set x $i; package provide t $i" } package require t 2.2 - return $x + set x } -result {2.3} test package-3.4 {Tcl_PkgRequire procedure, picking best version} -setup { package forget t set x xxx } -body { foreach i {1.4 3.4 2.3 2.4 2.2} { package ifneeded t $i "set x $i; package provide t $i" } package require -exact t 2.3 - return $x + set x } -result {2.3} test package-3.5 {Tcl_PkgRequire procedure, picking best version} -setup { package forget t set x xxx } -body { foreach i {1.4 3.4 2.3 2.4 2.2} { package ifneeded t $i "set x $i; package provide t $i" } package require t 2.1 - return $x + set x } -result {2.4} test package-3.6 {Tcl_PkgRequire procedure, can't find suitable version} -setup { package forget t } -returnCodes error -body { package unknown {} @@ -236,11 +237,11 @@ package forget t set x xxx } -body { package ifneeded t 1.2 "package forget t; set x 1.2; package provide t 1.2" package require t 1.2 - return $x + set x } -result {1.2} test package-3.13 {Tcl_PkgRequire procedure, "package unknown" support} -setup { package forget t set x xxx } -body { @@ -254,11 +255,11 @@ foreach i {1.4 3.4 2.3 2.4 2.2} { package ifneeded t $i "set x $i" } package unknown pkgUnknown package require -exact t 1.5 - return $x + set x } -cleanup { package unknown {} } -result {t 1.5-1.5} test package-3.14 {Tcl_PkgRequire procedure, "package unknown" support} -setup { package forget t @@ -281,11 +282,11 @@ global x set x $args package provide [lindex $args 0] 2.0 } package require {a b} - return $x + set x } -cleanup { package unknown {} } -result {{a b} 0-} test package-3.16 {Tcl_PkgRequire procedure, "package unknown" error} -setup { package forget t @@ -573,73 +574,119 @@ package require -exact demo 1.2 } -returnCodes error -cleanup { package forget demo } -result {version conflict for package "demo": have 1.2.3, need exactly 1.2} test package-3.50 {Tcl_PkgRequire procedure, picking best stable version} -constraints testpreferstable -setup { + interp create child + load {} Tcltest child + child eval { testpreferstable package forget t set x xxx + } } -body { + child eval { foreach i {1.4 3.4 4.0a1 2.3 2.4 2.2} { package ifneeded t $i "set x $i; package provide t $i" } package require t - return $x + set x + } +} -cleanup { + interp delete child } -result {3.4} test package-3.51 {Tcl_PkgRequire procedure, picking best stable version} -setup { package forget t set x xxx } -body { foreach i {1.2b1 1.2 1.3a2 1.3} { package ifneeded t $i "set x $i; package provide t $i" } package require t - return $x + set x } -result {1.3} test package-3.52 {Tcl_PkgRequire procedure, picking best stable version} -setup { package forget t set x xxx } -body { foreach i {1.2b1 1.2 1.3 1.3a2} { package ifneeded t $i "set x $i; package provide t $i" } package require t - return $x + set x } -result {1.3} +test pkg-3.53 {Tcl_PkgRequire procedure, picking best stable version} -constraints testpreferstable -setup { + testpreferstable + package forget t + set x xxx +} -body { + foreach i {1.2b1 1.1} { + package ifneeded t $i "set x $i; package provide t $i" + } + package require t + set x +} -result {1.1} + test package-4.1 {Tcl_PackageCmd procedure} -returnCodes error -body { package } -result {wrong # args: should be "package option ?arg ...?"} -test package-4.2 {Tcl_PackageCmd procedure, "forget" option} { +test package-4.2 {Tcl_PackageCmd procedure, "forget" option} -setup { + interp create child +} -body { + child eval { package forget {*}[package names] package names -} {} -test package-4.3 {Tcl_PackageCmd procedure, "forget" option} { + } +} -cleanup { + interp delete child +} -result {} +test package-4.3 {Tcl_PackageCmd procedure, "forget" option} -setup { + interp create child +} -body { + child eval { package forget {*}[package names] package forget foo -} {} + } +} -cleanup { + interp delete child +} -result {} test package-4.4 {Tcl_PackageCmd procedure, "forget" option} -setup { + interp create child + child eval { package forget {*}[package names] set result {} + } } -body { + child eval { package ifneeded t 1.1 {first script} package ifneeded t 2.3 {second script} package ifneeded x 1.4 {x's script} lappend result [lsort [package names]] [package versions t] package forget t lappend result [lsort [package names]] [package versions t] + } +} -cleanup { + interp delete child } -result {{t x} {1.1 2.3} x {}} test package-4.5 {Tcl_PackageCmd procedure, "forget" option} -setup { + interp create child + child eval { package forget {*}[package names] + } } -body { + child eval { package ifneeded a 1.1 {first script} package ifneeded b 2.3 {second script} package ifneeded c 1.4 {third script} package forget set result [list [lsort [package names]]] package forget a c lappend result [lsort [package names]] + } +} -cleanup { + interp delete child } -result {{a b c} b} test package-4.5.1 {Tcl_PackageCmd procedure, "forget" option} -body { # Test for Bug 415273 package ifneeded a 1 "I should have been forgotten" package forget no-such-package a @@ -654,32 +701,59 @@ package ifneeded a b c d } -returnCodes error -result {wrong # args: should be "package ifneeded package version ?script?"} test package-4.8 {Tcl_PackageCmd procedure, "ifneeded" option} -body { package ifneeded t xyz } -returnCodes error -result {expected version number but got "xyz"} -test package-4.9 {Tcl_PackageCmd procedure, "ifneeded" option} { +test package-4.9 {Tcl_PackageCmd procedure, "ifneeded" option} -setup { + interp create child +} -body { + child eval { package forget {*}[package names] list [package ifneeded foo 1.1] [package names] -} {{} {}} + } +} -cleanup { + interp delete child +} -result {{} {}} test package-4.10 {Tcl_PackageCmd procedure, "ifneeded" option} -setup { - package forget t + interp create child + child eval { + package forget {*}[package names] + } } -body { + child eval { package ifneeded t 1.4 "script for t 1.4" list [package names] [package ifneeded t 1.4] [package versions t] + } +} -cleanup { + interp delete child } -result {t {script for t 1.4} 1.4} test package-4.11 {Tcl_PackageCmd procedure, "ifneeded" option} -setup { - package forget t + interp create child + child eval { + package forget {*}[package names] + } } -body { + child eval { package ifneeded t 1.4 "script for t 1.4" list [package ifneeded t 1.5] [package names] [package versions t] + } +} -cleanup { + interp delete child } -result {{} t 1.4} test package-4.12 {Tcl_PackageCmd procedure, "ifneeded" option} -setup { - package forget t + interp create child + child eval { + package forget {*}[package names] + } } -body { + child eval { package ifneeded t 1.4 "script for t 1.4" package ifneeded t 1.4 "second script for t 1.4" list [package ifneeded t 1.4] [package names] [package versions t] + } +} -cleanup { + interp delete child } -result {{second script for t 1.4} t 1.4} test package-4.13 {Tcl_PackageCmd procedure, "ifneeded" option} -setup { package forget t } -body { package ifneeded t 1.4 "script for t 1.4" @@ -688,22 +762,35 @@ list [package ifneeded t 1.2] [package versions t] } -result {{second script} {1.4 1.2 3.1}} test package-4.14 {Tcl_PackageCmd procedure, "names" option} -body { package names a } -returnCodes error -result {wrong # args: should be "package names"} -test package-4.15 {Tcl_PackageCmd procedure, "names" option} { +test package-4.15 {Tcl_PackageCmd procedure, "names" option} -setup { + interp create child +} -body { + child eval { package forget {*}[package names] package names -} {} + } +} -cleanup { + interp delete child +} -result {} test package-4.16 {Tcl_PackageCmd procedure, "names" option} -setup { + interp create child + child eval { package forget {*}[package names] + } } -body { + child eval { package ifneeded x 1.2 {dummy} package provide x 1.3 package provide y 2.4 catch {package require z 47.16} lsort [package names] + } +} -cleanup { + interp delete child } -result {x y} test package-4.17 {Tcl_PackageCmd procedure, "provide" option} -body { package provide } -returnCodes error -result {wrong # args: should be "package provide package ?version?"} test package-4.18 {Tcl_PackageCmd procedure, "provide" option} -body { @@ -1237,15 +1324,13 @@ } finally { interp delete $ip } } -test package-13.0 {package prefer defaults} -constraints testpreferstable -setup { - testpreferstable -} -body { +test package-13.0 {package prefer defaults} -body { prefer -} -result stable +} -result [expr {[string match {*[ab]*} [package provide Tcl]] ? "latest" : "stable"}] test package-13.1 {package prefer defaults} -body { set ::env(TCL_PKG_PREFER_LATEST) stable ;# value not relevant! prefer } -cleanup { unset -nocomplain ::env(TCL_PKG_PREFER_LATEST) @@ -1258,27 +1343,29 @@ package prefer foo } -result {bad preference "foo": must be latest or stable} test package-15.0 {set, keep} -constraints testpreferstable -setup { testpreferstable -} -body {package prefer stable} -result stable +} -body {package prefer} -result stable test package-15.1 {set stable, keep} -constraints testpreferstable -setup { testpreferstable -} -body {prefer stable} -result {stable stable} +} -body {package prefer stable} -result stable test package-15.2 {set latest, change} -constraints testpreferstable -setup { testpreferstable -} -body {prefer latest} -result {stable latest} +} -body {package prefer latest} -result latest test package-15.3 {set latest, keep} -constraints testpreferstable -setup { testpreferstable } -body { - prefer latest latest -} -result {stable latest latest} + package prefer latest + package prefer latest +} -result latest test package-15.4 {set stable, rejected} -constraints testpreferstable -setup { testpreferstable } -body { - prefer latest stable -} -result {stable latest latest} + package prefer latest + package prefer stable +} -result latest rename prefer {} set auto_path $oldPath package unknown $oldPkgUnknown Index: tests/split.test ================================================================== --- tests/split.test +++ tests/split.test @@ -68,10 +68,13 @@ split "12,34,56," {,} } {12 34 56 {}} test split-1.14 {basic split commands} { split ",12,,,34,56," {,} } {{} 12 {} {} 34 56 {}} +test split-1.15 {basic split commands} -body { + split "a\U01f4a9b" {} +} -result "a \U01f4a9 b" test split-2.1 {split errors} { list [catch split msg] $msg $errorCode } {1 {wrong # args: should be "split string ?splitChars?"} {TCL WRONGARGS}} test split-2.2 {split errors} { Index: tests/string.test ================================================================== --- tests/string.test +++ tests/string.test @@ -26,10 +26,15 @@ testConstraint testindexobj [expr {[info commands testindexobj] != {}}] # Used for constraining memory leak tests testConstraint memory [llength [info commands memory]] +proc representationpoke s { + set r [::tcl::unsupported::representation $s] + list [lindex $r 3] [string match {*, string representation "*"} $r] +} + test string-1.1 {error conditions} { list [catch {string gorp a b} msg] $msg } {1 {unknown or ambiguous subcommand "gorp": must be bytelength, cat, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} test string-1.2 {error conditions} { list [catch {string} msg] $msg @@ -222,10 +227,17 @@ # strings was incorrect, leading to an index returned by [string first] # which pointed past the end of the string. set uchar \u057e ;# character with two-byte encoding in utf-8 string first % %#$uchar$uchar#$uchar$uchar#% 3 } 8 +test string-4.16 {string first, normal string vs pure unicode string} { + set s hello + regexp ll $s m + # Representation checks are canaries + list [representationpoke $s] [representationpoke $m] \ + [string first $m $s] +} {{string 1} {string 0} 2} test string-5.1 {string index} { list [catch {string index} msg] $msg } {1 {wrong # args: should be "string index string charIndex"}} test string-5.2 {string index} { @@ -1683,44 +1695,44 @@ set x abc set y de string reverse $x$y } edcba test string-24.5 {string reverse command - shared unicode string} { - set x abcde\udead + set x abcde\ud0ad string reverse $x -} \udeadedcba +} \ud0adedcba test string-24.6 {string reverse command - unshared string} { set x abc - set y de\udead + set y de\ud0ad string reverse $x$y -} \udeadedcba +} \ud0adedcba test string-24.7 {string reverse command - simple case} { string reverse a } a test string-24.8 {string reverse command - simple case} { - string reverse \udead -} \udead + string reverse \ud0ad +} \ud0ad test string-24.9 {string reverse command - simple case} { string reverse {} } {} test string-24.10 {string reverse command - corner case} { - set x \ubeef\udead + set x \ubeef\ud0ad string reverse $x -} \udead\ubeef +} \ud0ad\ubeef test string-24.11 {string reverse command - corner case} { set x \ubeef - set y \udead + set y \ud0ad string reverse $x$y -} \udead\ubeef +} \ud0ad\ubeef test string-24.12 {string reverse command - corner case} { set x \ubeef - set y \udead + set y \ud0ad string is ascii [string reverse $x$y] } 0 test string-24.13 {string reverse command - pure Unicode string} { - string reverse [string range \ubeef\udead\ubeef\udead\ubeef\udead 1 5] -} \udead\ubeef\udead\ubeef\udead + string reverse [string range \ubeef\ud0ad\ubeef\ud0ad\ubeef\ud0ad 1 5] +} \ud0ad\ubeef\ud0ad\ubeef\ud0ad test string-24.14 {string reverse command - pure bytearray} { binary scan [string reverse [binary format H* 010203]] H* x set x } 030201 test string-24.15 {string reverse command - pure bytearray} { @@ -2040,17 +2052,15 @@ } -cleanup { unset e f } -body { tcl::unsupported::representation [string cat $e $f $e $f [list x]] } -match glob -result {*no string representation} - - - + # cleanup rename MemStress {} catch {rename foo {}} ::tcltest::cleanupTests return # Local Variables: # mode: tcl # End: Index: tests/stringObj.test ================================================================== --- tests/stringObj.test +++ tests/stringObj.test @@ -478,14 +478,17 @@ } fooo test stringObj-15.8 {Tcl_Append*ToObj: self appends} testobj { teststringobj set 1 foo teststringobj appendself2 1 3 } foo - if {[testConstraint testobj]} { testobj freeallvars } # cleanup ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# End: Index: tests/utf.test ================================================================== --- tests/utf.test +++ tests/utf.test @@ -66,14 +66,14 @@ test utf-2.7 {Tcl_UtfToUniChar: lead (3-byte) followed by 2 trail} testbytestring { string length [testbytestring "\xE4\xb9\x8e"] } {1} test utf-2.8 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} -constraints {fullutf testbytestring} -body { string length [testbytestring "\xF0\x90\x80\x80"] -} -result {1} +} -result {2} test utf-2.9 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} -constraints {fullutf testbytestring} -body { string length [testbytestring "\xF4\x8F\xBF\xBF"] -} -result {1} +} -result {2} test utf-2.10 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail, underflow} testbytestring { string length [testbytestring "\xF0\x8F\xBF\xBF"] } {4} test utf-2.11 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail, overflow} testbytestring { string length [testbytestring "\xF4\x90\x80\x80"] ADDED tests/zipfs.test Index: tests/zipfs.test ================================================================== --- /dev/null +++ tests/zipfs.test @@ -0,0 +1,170 @@ +# The file tests the tclZlib.c file. +# +# This file contains a collection of tests for one or more of the Tcl built-in +# commands. Sourcing this file into Tcl runs the tests and generates output +# for errors. No output means no errors were found. +# +# Copyright (c) 1996-1998 by Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# +# See the file "license.terms" for information on usage and redistribution of +# this file, and for a DISCLAIMER OF ALL WARRANTIES. + +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.1 + namespace import -force ::tcltest::* +} + +testConstraint zipfs [expr {[llength [info commands zlib]] && [regexp tcltest [info nameofexecutable]]}] + +# Removed in tip430 - zipfs is no longer a static package +#test zipfs-0.0 {zipfs basics} -constraints zipfs -body { +# load {} zipfs +#} -result {} + +test zipfs-0.1 {zipfs basics} -constraints zipfs -body { + package require zipfs +} -result {1.0} + +test zipfs-0.1 {zipfs basics} -constraints zipfs -body { + expr {"//zipfs:/" in [file volumes]} +} -result 1 + +test zipfs-0.2 {zipfs basics} -constraints zipfs -body { + string match //zipfs:/* $tcl_library +} -result 1 + +test zipfs-0.3 {zipfs basics: glob} -constraints zipfs -body { + set pwd [pwd] + cd $tcl_library + lsort [glob -dir . http*] +} -cleanup { + cd $pwd +} -result {./http ./http1.0} + +test zipfs-0.4 {zipfs basics: glob} -constraints zipfs -body { + set pwd [pwd] + cd $tcl_library + lsort [glob -dir [pwd] http*] +} -cleanup { + cd $pwd +} -result [list $tcl_library/http $tcl_library/http1.0] + +test zipfs-0.5 {zipfs basics: glob} -constraints zipfs -body { + lsort [glob -dir $tcl_library http*] +} -result [list $tcl_library/http $tcl_library/http1.0] + +test zipfs-0.6 {zipfs basics: glob} -constraints zipfs -body { + lsort [glob $tcl_library/http*] +} -result [list $tcl_library/http $tcl_library/http1.0] + +test zipfs-0.7 {zipfs basics: glob} -constraints zipfs -body { + lsort [glob -tails -dir $tcl_library http*] +} -result {http http1.0} + +test zipfs-0.8 {zipfs basics: glob} -constraints zipfs -body { + lsort [glob -nocomplain -tails -types d -dir $tcl_library http*] +} -result {http http1.0} + +test zipfs-0.9 {zipfs basics: glob} -constraints zipfs -body { + lsort [glob -nocomplain -tails -types f -dir $tcl_library http*] +} -result {} + + +test zipfs-1.3 {zipfs errors} -constraints zipfs -returnCodes error -body { + zipfs mount a b c d e f +} -result {wrong # args: should be "zipfs mount ?zipfile? ?mountpoint? ?password?"} + +test zipfs-1.4 {zipfs errors} -constraints zipfs -returnCodes error -body { + zipfs unmount a b c d e f +} -result {wrong # args: should be "zipfs unmount zipfile"} + +test zipfs-1.5 {zipfs errors} -constraints zipfs -returnCodes error -body { + zipfs mkkey a b c d e f +} -result {wrong # args: should be "zipfs mkkey password"} + +test zipfs-1.6 {zipfs errors} -constraints zipfs -returnCodes error -body { + zipfs mkimg a b c d e f +} -result {wrong # args: should be "zipfs mkimg outfile indir ?strip? ?password? ?infile?"} + +test zipfs-1.7 {zipfs errors} -constraints zipfs -returnCodes error -body { + zipfs mkzip a b c d e f +} -result {wrong # args: should be "zipfs mkzip outfile indir ?strip? ?password?"} + +test zipfs-1.8 {zipfs errors} -constraints zipfs -returnCodes error -body { + zipfs exists a b c d e f +} -result {wrong # args: should be "zipfs exists filename"} + +test zipfs-1.9 {zipfs errors} -constraints zipfs -returnCodes error -body { + zipfs info a b c d e f +} -result {wrong # args: should be "zipfs info filename"} + +test zipfs-1.10 {zipfs errors} -constraints zipfs -returnCodes error -body { + zipfs list a b c d e f +} -result {wrong # args: should be "zipfs list ?(-glob|-regexp)? ?pattern?"} + +test zipfs-2.1 {zipfs mkzip empty archive} -constraints zipfs -returnCodes error -body { + zipfs mkzip /tmp/abc.zip $tcl_library/xxxx ;# FIXME: test independence +} -result {empty archive} + +test zipfs-2.2 {zipfs mkzip} -constraints zipfs -body { + set pwd [pwd] + cd $tcl_library/encoding + zipfs mkzip /tmp/abc.zip . + zipfs mount /tmp/abc.zip //zipfs:/abc ;# FIXME: test independence + zipfs list -glob //zipfs:/abc/cp850.* +} -cleanup { + cd $pwd +} -result {//zipfs:/abc/cp850.enc} + +test zipfs-2.3 {zipfs info} -constraints zipfs -body { + zipfs info //zipfs:/abc/cp850.enc +} -result [list /tmp/abc.zip 1090 527 39318] ;# FIXME: result depends on content of encodings dir + +test zipfs-2.4 {zipfs data} -constraints zipfs -body { + set zipfd [open //zipfs:/abc/cp850.enc] ;# FIXME: leave open - see later test + read $zipfd +} -result {# Encoding file: cp850, single-byte +S +003F 0 1 +00 +0000000100020003000400050006000700080009000A000B000C000D000E000F +0010001100120013001400150016001700180019001A001B001C001D001E001F +0020002100220023002400250026002700280029002A002B002C002D002E002F +0030003100320033003400350036003700380039003A003B003C003D003E003F +0040004100420043004400450046004700480049004A004B004C004D004E004F +0050005100520053005400550056005700580059005A005B005C005D005E005F +0060006100620063006400650066006700680069006A006B006C006D006E006F +0070007100720073007400750076007700780079007A007B007C007D007E007F +00C700FC00E900E200E400E000E500E700EA00EB00E800EF00EE00EC00C400C5 +00C900E600C600F400F600F200FB00F900FF00D600DC00F800A300D800D70192 +00E100ED00F300FA00F100D100AA00BA00BF00AE00AC00BD00BC00A100AB00BB +2591259225932502252400C100C200C000A9256325512557255D00A200A52510 +25142534252C251C2500253C00E300C3255A25542569256625602550256C00A4 +00F000D000CA00CB00C8013100CD00CE00CF2518250C2588258400A600CC2580 +00D300DF00D400D200F500D500B500FE00DE00DA00DB00D900FD00DD00AF00B4 +00AD00B1201700BE00B600A700F700B800B000A800B700B900B300B225A000A0 +} ;# FIXME: result depends on content of encodings dir + +test zipfs-2.5 {zipfs exists} -constraints zipfs -body { + zipfs exists /abc/cp850.enc +} -result 1 + +test zipfs-2.6 {zipfs unmount while busy} -constraints zipfs -body { + zipfs unmount /tmp/abc.zip +} -returnCodes error -result {filesystem is busy} + +test zipfs-2.7 {zipfs unmount} -constraints zipfs -body { + close $zipfd + zipfs unmount /tmp/abc.zip + zipfs exists /abc/cp850.enc +} -cleanup { + file delete /tmp/abc.zip ;# FIXME: test independence +} -result 0 + +::tcltest::cleanupTests +return + +# Local Variables: +# mode: tcl +# End: ADDED tools/mkVfs.tcl Index: tools/mkVfs.tcl ================================================================== --- /dev/null +++ tools/mkVfs.tcl @@ -0,0 +1,99 @@ +proc cat fname { + set fname [open $fname r] + set data [read $fname] + close $fname + return $data +} + +proc pkgIndexDir {root fout d1} { + + puts [format {%*sIndexing %s} [expr {4 * [info level]}] {} \ + [file tail $d1]] + set idx [string length $root] + foreach ftail [glob -directory $d1 -nocomplain -tails *] { + set f [file join $d1 $ftail] + if {[file isdirectory $f] && [string compare CVS $ftail]} { + pkgIndexDir $root $fout $f + } elseif {[file tail $f] eq "pkgIndex.tcl"} { + puts $fout "set dir \${VFSROOT}[string range $d1 $idx end]" + puts $fout [cat $f] + } + } +} + +### +# Script to build the VFS file system +### +proc copyDir {d1 d2} { + + puts [format {%*sCreating %s} [expr {4 * [info level]}] {} \ + [file tail $d2]] + + file delete -force -- $d2 + file mkdir $d2 + + foreach ftail [glob -directory $d1 -nocomplain -tails *] { + set f [file join $d1 $ftail] + if {[file isdirectory $f] && [string compare CVS $ftail]} { + copyDir $f [file join $d2 $ftail] + } elseif {[file isfile $f]} { + file copy -force $f [file join $d2 $ftail] + if {$::tcl_platform(platform) eq {unix}} { + file attributes [file join $d2 $ftail] -permissions 0644 + } else { + file attributes [file join $d2 $ftail] -readonly 1 + } + } + } + + if {$::tcl_platform(platform) eq {unix}} { + file attributes $d2 -permissions 0755 + } else { + file attributes $d2 -readonly 1 + } +} + +if {[llength $argv] < 3} { + puts "Usage: VFS_ROOT TCLSRC_ROOT PLATFORM" + exit 1 +} +set TCL_SCRIPT_DIR [lindex $argv 0] +set TCLSRC_ROOT [lindex $argv 1] +set PLATFORM [lindex $argv 2] +set TKDLL [lindex $argv 3] +set TKVER [lindex $argv 4] + +puts "Building [file tail $TCL_SCRIPT_DIR] for $PLATFORM" +copyDir ${TCLSRC_ROOT}/library ${TCL_SCRIPT_DIR} + +if {$PLATFORM == "windows"} { + set ddedll [glob -nocomplain ${TCLSRC_ROOT}/win/tcldde*.dll] + puts "DDE DLL $ddedll" + if {$ddedll != {}} { + file copy $ddedll ${TCL_SCRIPT_DIR}/dde + } + set regdll [glob -nocomplain ${TCLSRC_ROOT}/win/tclreg*.dll] + puts "REG DLL $ddedll" + if {$regdll != {}} { + file copy $regdll ${TCL_SCRIPT_DIR}/reg + } +} else { + # Remove the dde and reg package paths + file delete -force ${TCL_SCRIPT_DIR}/dde + file delete -force ${TCL_SCRIPT_DIR}/reg +} + +# For the following packages, cat their pkgIndex files to tclIndex +file attributes ${TCL_SCRIPT_DIR}/tclIndex -readonly 0 +set fout [open ${TCL_SCRIPT_DIR}/tclIndex a] +puts $fout {# +# MANIFEST OF INCLUDED PACKAGES +# +set VFSROOT $dir +} +if {$TKDLL ne {} && [file exists $TKDLL]} { + file copy $TKDLL ${TCL_SCRIPT_DIR} + puts $fout [list package ifneeded Tk $TKVER "load \$dir $TKDLL"] +} +pkgIndexDir ${TCL_SCRIPT_DIR} $fout ${TCL_SCRIPT_DIR} +close $fout Index: unix/Makefile.in ================================================================== --- unix/Makefile.in +++ unix/Makefile.in @@ -240,10 +240,12 @@ ZLIB_DIR = ${COMPAT_DIR}/zlib ZLIB_INCLUDE = @ZLIB_INCLUDE@ CC = @CC@ +OBJEXT = @OBJEXT@ + #CC = purify -best-effort @CC@ -DPURIFY # Flags to be passed to installManPage to control how the manpages should be # installed (symlinks, compression, package name suffix). MAN_FLAGS = @MAN_FLAGS@ @@ -306,11 +308,11 @@ tclPreserve.o tclProc.o tclRegexp.o \ tclResolve.o tclResult.o tclScan.o tclStringObj.o \ tclStrToD.o tclThread.o \ tclThreadAlloc.o tclThreadJoin.o tclThreadStorage.o tclStubInit.o \ tclTimer.o tclTrace.o tclUtf.o tclUtil.o tclVar.o tclZlib.o \ - tclTomMathInterface.o + tclTomMathInterface.o tclZipfs.o OO_OBJS = tclOO.o tclOOBasic.o tclOOCall.o tclOODefineCmds.o tclOOInfo.o \ tclOOMethod.o tclOOStubInit.o TOMMATH_OBJS = bncore.o bn_reverse.o bn_fast_s_mp_mul_digs.o \ @@ -461,11 +463,12 @@ $(GENERIC_DIR)/tclTimer.c \ $(GENERIC_DIR)/tclTrace.c \ $(GENERIC_DIR)/tclUtil.c \ $(GENERIC_DIR)/tclVar.c \ $(GENERIC_DIR)/tclAssembly.c \ - $(GENERIC_DIR)/tclZlib.c + $(GENERIC_DIR)/tclZlib.c \ + $(GENERIC_DIR)/tclZipfs.c OO_SRCS = \ $(GENERIC_DIR)/tclOO.c \ $(GENERIC_DIR)/tclOOBasic.c \ $(GENERIC_DIR)/tclOOCall.c \ @@ -614,10 +617,46 @@ # things like "make depend". SRCS = $(GENERIC_SRCS) $(TOMMATH_SRCS) $(UNIX_SRCS) $(NOTIFY_SRCS) \ $(OO_SRCS) $(STUB_SRCS) @PLAT_SRCS@ @ZLIB_SRCS@ +### +# Tip 430 - ZipFS Modifications +### + +TCL_ZIP_FILE = @TCL_ZIP_FILE@ +TCL_VFS_PATH = libtcl.vfs/tcl_library +TCL_VFS_ROOT = libtcl.vfs + +HOST_CC = @CC_FOR_BUILD@ +HOST_EXEEXT = @EXEEXT_FOR_BUILD@ +HOST_OBJEXT = @OBJEXT_FOR_BUILD@ +ZIPFS_BUILD = @ZIPFS_BUILD@ +NATIVE_ZIP = @ZIP_PROG@ +SHARED_BUILD = @SHARED_BUILD@ +INSTALL_LIBRARIES = @INSTALL_LIBRARIES@ +INSTALL_MSGS = @INSTALL_MSGS@ + +# Minizip +MINIZIP_OBJS = \ + adler32.$(HOST_OBJEXT) \ + compress.$(HOST_OBJEXT) \ + crc32.$(HOST_OBJEXT) \ + deflate.$(HOST_OBJEXT) \ + infback.$(HOST_OBJEXT) \ + inffast.$(HOST_OBJEXT) \ + inflate.$(HOST_OBJEXT) \ + inftrees.$(HOST_OBJEXT) \ + ioapi.$(HOST_OBJEXT) \ + trees.$(HOST_OBJEXT) \ + uncompr.$(HOST_OBJEXT) \ + zip.$(HOST_OBJEXT) \ + zutil.$(HOST_OBJEXT) \ + minizip.$(HOST_OBJEXT) + +ZIP_INSTALL_OBJS = minizip${EXEEXT_FOR_BUILD} + #-------------------------------------------------------------------------- # Start of rules #-------------------------------------------------------------------------- all: binaries libraries doc packages @@ -626,15 +665,27 @@ libraries: doc: +tclzipfile: ${TCL_ZIP_FILE} + + +${TCL_ZIP_FILE}: ${ZIP_INSTALL_OBJS} + rm -rf ${TCL_VFS_ROOT} + mkdir -p ${TCL_VFS_PATH} + cp -a ../library/* ${TCL_VFS_PATH} + cd ${TCL_VFS_ROOT} ; ../minizip${EXEEXT_FOR_BUILD} -o ../${TCL_ZIP_FILE} `find . -type f` + # The following target is configured by autoconf to generate either a shared # library or non-shared library for Tcl. -${LIB_FILE}: ${STUB_LIB_FILE} ${OBJS} +${LIB_FILE}: ${STUB_LIB_FILE} ${OBJS} ${TCL_ZIP_FILE} rm -f $@ @MAKE_LIB@ +ifeq (${ZIPFS_BUILD},1) + cat ${TCL_ZIP_FILE} >> ${LIB_FILE} +endif ${STUB_LIB_FILE}: ${STUB_LIB_OBJS} @if test "x${LIB_FILE}" = "xlibtcl${MAJOR_VERSION}.${MINOR_VERSION}.dll"; then \ (cd ${TOP_DIR}/win; ${MAKE} winextensions); \ fi @@ -664,11 +715,12 @@ #tclConfig.h: $(UNIX_DIR)/tclConfig.h.in # $(SHELL) config.status clean: clean-packages rm -rf *.a *.o libtcl* core errs *~ \#* TAGS *.E a.out \ - errors ${TCL_EXE} ${TCLTEST_EXE} lib.exp Tcl @DTRACE_HDR@ + errors ${TCL_EXE} ${TCLTEST_EXE} lib.exp Tcl @DTRACE_HDR@ \ + minizip${EXEEXT_FOR_BUILD} *.${HOST_OBJEXT} cd dltest ; $(MAKE) clean distclean: distclean-packages clean rm -rf Makefile config.status config.cache config.log tclConfig.sh \ tclConfig.h *.plist Tcl.framework tcl.pc @@ -774,11 +826,11 @@ #-------------------------------------------------------------------------- # Installation rules #-------------------------------------------------------------------------- -INSTALL_BASE_TARGETS = install-binaries install-libraries install-msgs $(INSTALL_TZDATA) +INSTALL_BASE_TARGETS = install-binaries $(INSTALL_LIBRARIES) $(INSTALL_MSGS) $(INSTALL_TZDATA) INSTALL_DOC_TARGETS = install-doc INSTALL_PACKAGE_TARGETS = install-packages INSTALL_DEV_TARGETS = install-headers INSTALL_EXTRA_TARGETS = @EXTRA_INSTALL@ INSTALL_TARGETS = $(INSTALL_BASE_TARGETS) $(INSTALL_DOC_TARGETS) $(INSTALL_DEV_TARGETS) \ @@ -818,10 +870,29 @@ @EXTRA_INSTALL_BINARIES@ @echo "Installing pkg-config file to $(LIB_INSTALL_DIR)/pkgconfig/" @$(INSTALL_DATA_DIR) $(LIB_INSTALL_DIR)/pkgconfig @$(INSTALL_DATA) tcl.pc $(LIB_INSTALL_DIR)/pkgconfig/tcl.pc +install-libraries-zipfs-shared: libraries + @for i in "$(SCRIPT_INSTALL_DIR)"; \ + do \ + if [ ! -d "$$i" ] ; then \ + echo "Making directory $$i"; \ + $(INSTALL_DATA_DIR) "$$i"; \ + else true; \ + fi; \ + done; + @echo "Installing library files to $(SCRIPT_INSTALL_DIR)/"; + @for i in \ + $(UNIX_DIR)/tclAppInit.c @LDAIX_SRC@ @DTRACE_SRC@; \ + do \ + $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"; \ + done; + +install-libraries-zipfs-static: install-libraries-zipfs-shared + $(INSTALL_DATA) ${TCL_ZIP_FILE} "$(LIB_INSTALL_DIR)" ;\ + install-libraries: libraries @for i in "$(SCRIPT_INSTALL_DIR)"; \ do \ if [ ! -d "$$i" ] ; then \ echo "Making directory $$i"; \ @@ -855,12 +926,12 @@ do \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/opt0.4; \ done; @echo "Installing package msgcat 1.6.1 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/msgcat-1.6.1.tm; - @echo "Installing package tcltest 2.4.0 as a Tcl Module"; - @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.4.0.tm; + @echo "Installing package tcltest 2.4.1 as a Tcl Module"; + @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.4.1.tm; @echo "Installing package platform 1.0.14 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/platform/platform.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/platform-1.0.14.tm; @echo "Installing package platform::shell 1.1.4 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/platform/shell.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/platform/shell-1.1.4.tm; @@ -872,10 +943,11 @@ @if [ -n "$(TCL_MODULE_PATH)" -a -f $(TOP_DIR)/library/tm.tcl ]; then \ echo "Customizing tcl module path"; \ echo "if {![interp issafe]} { ::tcl::tm::roots {$(TCL_MODULE_PATH)} }" >> \ "$(SCRIPT_INSTALL_DIR)"/tm.tcl; \ fi + end install-tzdata: @for i in tzdata; \ do \ if [ ! -d "$(SCRIPT_INSTALL_DIR)"/$$i ] ; then \ @@ -1279,10 +1351,12 @@ -DCFG_RUNTIME_LIBDIR="\"$(libdir)\"" \ -DCFG_RUNTIME_BINDIR="\"$(bindir)\"" \ -DCFG_RUNTIME_SCRDIR="\"$(TCL_LIBRARY)\"" \ -DCFG_RUNTIME_INCDIR="\"$(includedir)\"" \ -DCFG_RUNTIME_DOCDIR="\"$(mandir)\"" \ + -DCFG_RUNTIME_DLLFILE="\"$(TCL_LIB_FILE)\"" \ + -DCFG_RUNTIME_ZIPFILE="\"$(TCL_ZIP_FILE)\"" \ \ $(GENERIC_DIR)/tclPkgConfig.c tclPosixStr.o: $(GENERIC_DIR)/tclPosixStr.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclPosixStr.c @@ -1327,10 +1401,17 @@ $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclVar.c tclZlib.o: $(GENERIC_DIR)/tclZlib.c $(CC) -c $(CC_SWITCHES) $(ZLIB_INCLUDE) $(GENERIC_DIR)/tclZlib.c +tclZipfs.o: $(GENERIC_DIR)/tclZipfs.c + $(CC) -c $(CC_SWITCHES) \ + -DCFG_RUNTIME_DLLFILE="\"$(TCL_LIB_FILE)\"" \ + -DCFG_RUNTIME_ZIPFILE="\"$(TCL_ZIP_FILE)\"" \ + -DCFG_RUNTIME_PATH="\"$(DLL_INSTALL_DIR)\"" \ + $(ZLIB_INCLUDE) -I$(ZLIB_DIR)/contrib/minizip $(GENERIC_DIR)/tclZipfs.c + tclTest.o: $(GENERIC_DIR)/tclTest.c $(IOHDR) $(TCLREHDRS) $(CC) -c $(APP_CC_SWITCHES) $(GENERIC_DIR)/tclTest.c tclTestObj.o: $(GENERIC_DIR)/tclTestObj.c $(MATHHDRS) $(CC) -c $(APP_CC_SWITCHES) $(GENERIC_DIR)/tclTestObj.c @@ -1733,10 +1814,78 @@ tclOOStubLib.o: $(GENERIC_DIR)/tclOOStubLib.c $(CC) -c $(STUB_CC_SWITCHES) $(GENERIC_DIR)/tclOOStubLib.c .c.o: $(CC) -c $(CC_SWITCHES) $< + +#-------------------------------------------------------------------------- +# Minizip implementation +#-------------------------------------------------------------------------- +adler32.$(HOST_OBJEXT): + $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/adler32.c + +compress.$(HOST_OBJEXT): + $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/compress.c + +crc32.$(HOST_OBJEXT): + $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/crc32.c + +deflate.$(HOST_OBJEXT): + $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/deflate.c + +ioapi.$(HOST_OBJEXT): + $(HOST_CC) -o $@ -I$(ZLIB_DIR) -I$(ZLIB_DIR)/contrib/minizip -c $(ZLIB_DIR)/contrib/minizip/ioapi.c + +infback.$(HOST_OBJEXT): + $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/infback.c + +inffast.$(HOST_OBJEXT): + $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/inffast.c + +inflate.$(HOST_OBJEXT): + $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/inflate.c + +inftrees.$(HOST_OBJEXT): + $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/inftrees.c + +trees.$(HOST_OBJEXT): + $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/trees.c + +uncompr.$(HOST_OBJEXT): + $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/uncompr.c + +zip.$(HOST_OBJEXT): + $(HOST_CC) -o $@ -I$(ZLIB_DIR) -I$(ZLIB_DIR)/contrib/minizip -c $(ZLIB_DIR)/contrib/minizip/zip.c + +zutil.$(HOST_OBJEXT): + $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/zutil.c + +minizip.$(HOST_OBJEXT): + $(HOST_CC) -o $@ -I$(ZLIB_DIR) -I$(ZLIB_DIR)/contrib/minizip -c $(ZLIB_DIR)/contrib/minizip/minizip.c + +minizip${EXEEXT_FOR_BUILD}: $(MINIZIP_OBJS) + $(HOST_CC) -o $@ $(MINIZIP_OBJS) + +tclvfs.zip: minizip${EXEEXT_FOR_BUILD} + rm -rf $(TCL_VFS_ROOT) + mkdir -p $(TCL_VFS_PATH) + @for i in "$(TCL_VFS_PATH)"; \ + do \ + if [ ! -d "$$i" ] ; then \ + echo "Making directory $$i"; \ + $(INSTALL_DATA_DIR) "$$i"; \ + else true; \ + fi; \ + done; + cp -a ../library/* $(TCL_VFS_PATH) + (cd $TCL_VFS ROOT ; ./minizip${EXEEXT_FOR_BUILD} -o ../tclvfs.zip `find . -type f`) + +zipsetupstub.$(HOST_OBJEXT): $(COMPAT_DIR)/zipsetupstub.c + $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(COMPAT_DIR)/zipsetupstub.c + +zipsetupstub${EXEEXT_FOR_BUILD}: zipsetupstub.$(HOST_OBJEXT) + $(HOST_CC) -o $@ zipsetupstub.$(HOST_OBJEXT) #-------------------------------------------------------------------------- # Bundled Package targets #-------------------------------------------------------------------------- @@ -2142,8 +2291,9 @@ .PHONY: tclLibObjs tcltest-real test-tcl gdb-test ro-test trace-test xttest .PHONY: topDirName gendate gentommath_h trace-shell checkdoc .PHONY: install-tzdata install-msgs .PHONY: packages configure-packages test-packages clean-packages .PHONY: dist-packages distclean-packages install-packages +.PHONY: iinstall-libraries-zipfs-shared install-libraries-zipfs-static tclzipfile #-------------------------------------------------------------------------- # DO NOT DELETE THIS LINE -- make depend depends on it. Index: unix/configure ================================================================== --- unix/configure +++ unix/configure @@ -656,16 +656,23 @@ TCL_STUB_LIB_FLAG TCL_STUB_LIB_FILE TCL_LIB_SPEC TCL_LIB_FLAG TCL_LIB_FILE +TCL_ZIP_FILE PKG_CFG_ARGS TCL_YEAR TCL_PATCH_LEVEL TCL_MINOR_VERSION TCL_MAJOR_VERSION TCL_VERSION +INSTALL_MSGS +INSTALL_LIBRARIES +ZIPFS_BUILD +EXEEXT_FOR_BUILD +CC_FOR_BUILD +ZIP_PROG DTRACE LDFLAGS_DEFAULT CFLAGS_DEFAULT INSTALL_STUB_LIB DLL_INSTALL_DIR @@ -697,10 +704,11 @@ RANLIB ZLIB_INCLUDE ZLIB_SRCS ZLIB_OBJS TCLSH_PROG +SHARED_BUILD TCL_THREADS EGREP GREP CPP OBJEXT @@ -746,11 +754,12 @@ PACKAGE_STRING PACKAGE_VERSION PACKAGE_TARNAME PACKAGE_NAME PATH_SEPARATOR -SHELL' +SHELL +OBJEXT_FOR_BUILD' ac_subst_files='' ac_user_opts=' enable_option_checking enable_man_symlinks enable_man_compression @@ -766,10 +775,11 @@ enable_symbols enable_langinfo enable_dll_unloading with_tzdata enable_dtrace +enable_zipfs enable_framework ' ac_precious_vars='build_alias host_alias target_alias @@ -1406,10 +1416,11 @@ --enable-symbols build with debugging symbols (default: off) --enable-langinfo use nl_langinfo if possible to determine encoding at startup, otherwise use old heuristic (default: on) --enable-dll-unloading enable the 'unload' command (default: on) --enable-dtrace build with DTrace support (default: off) + --enable-zipfs build with Zipfs support (default: on) --enable-framework package shared libraries in MacOSX frameworks (default: off) Optional Packages: --with-PACKAGE[=ARG] use PACKAGE [ARG=yes] @@ -2328,10 +2339,11 @@ TCL_PATCH_LEVEL="a2" VERSION=${TCL_VERSION} EXTRA_INSTALL_BINARIES=${EXTRA_INSTALL_BINARIES:-"@:"} EXTRA_BUILD_HTML=${EXTRA_BUILD_HTML:-"@:"} +TCL_ZIP_FILE=libtcl_${TCL_MAJOR_VERSION}_${TCL_MINOR_VERSION}_${TCL_PATCH_LEVEL}.zip #------------------------------------------------------------------------ # Setup configure arguments for bundled packages #------------------------------------------------------------------------ @@ -3270,10 +3282,11 @@ #endif _ACEOF ;; esac + #-------------------------------------------------------------------- # Supply substitutes for missing POSIX header files. Special notes: # - stdlib.h doesn't define strtol, strtoul, or # strtod insome versions of SunOS @@ -3730,20 +3743,10 @@ if test $tcl_cv_dirent_h = no; then $as_echo "#define NO_DIRENT_H 1" >>confdefs.h fi - - ac_fn_c_check_header_mongrel "$LINENO" "float.h" "ac_cv_header_float_h" "$ac_includes_default" -if test "x$ac_cv_header_float_h" = xyes; then : - -else - -$as_echo "#define NO_FLOAT_H 1" >>confdefs.h - -fi - ac_fn_c_check_header_mongrel "$LINENO" "values.h" "ac_cv_header_values_h" "$ac_includes_default" if test "x$ac_cv_header_values_h" = xyes; then : else @@ -4541,10 +4544,11 @@ SHARED_BUILD=0 $as_echo "#define STATIC_BUILD 1" >>confdefs.h fi + #-------------------------------------------------------------------- # Look for a native installed tclsh binary (if available) # If one cannot be found then use the binary we build (fails for @@ -10147,10 +10151,163 @@ fi fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_ok" >&5 $as_echo "$tcl_ok" >&6; } + +#-------------------------------------------------------------------- +# Zipfs support +#-------------------------------------------------------------------- + +# +# Find a native zip implementation +# + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for zip" >&5 +$as_echo_n "checking for zip... " >&6; } + if ${ac_cv_path_zip+:} false; then : + $as_echo_n "(cached) " >&6 +else + + search_path=`echo ${PATH} | sed -e 's/:/ /g'` + for dir in $search_path ; do + for j in `ls -r $dir/zip 2> /dev/null` \ + `ls -r $dir/zip 2> /dev/null` ; do + if test x"$ac_cv_path_zip" = x ; then + if test -f "$j" ; then + ac_cv_path_zip=$j + break + fi + fi + done + done + +fi + + + if test -f "$ac_cv_path_zip" ; then + ZIP_PROG="$ac_cv_path_zip" + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ZIP_PROG" >&5 +$as_echo "$ZIP_PROG" >&6; } + else + # It is not an error if an installed version of Zip can't be located. + ZIP_PROG="" + { $as_echo "$as_me:${as_lineno-$LINENO}: result: No zip found on PATH" >&5 +$as_echo "No zip found on PATH" >&6; } + fi + + + +# +# Find a native compiler +# +# Put a plausible default for CC_FOR_BUILD in Makefile. +if test -z "$CC_FOR_BUILD"; then + if test "x$cross_compiling" = "xno"; then + CC_FOR_BUILD='$(CC)' + else + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for gcc" >&5 +$as_echo_n "checking for gcc... " >&6; } + if ${ac_cv_path_cc+:} false; then : + $as_echo_n "(cached) " >&6 +else + + search_path=`echo ${PATH} | sed -e 's/:/ /g'` + for dir in $search_path ; do + for j in `ls -r $dir/gcc 2> /dev/null` \ + `ls -r $dir/gcc 2> /dev/null` ; do + if test x"$ac_cv_path_cc" = x ; then + if test -f "$j" ; then + ac_cv_path_cc=$j + break + fi + fi + done + done + +fi + + fi +fi + +# Also set EXEEXT_FOR_BUILD. +if test "x$cross_compiling" = "xno"; then + EXEEXT_FOR_BUILD='$(EXEEXT)' + OBJEXT_FOR_BUILD='$(OBJEXT)' +else + OBJEXT_FOR_BUILD='.no' + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for build system executable suffix" >&5 +$as_echo_n "checking for build system executable suffix... " >&6; } +if ${bfd_cv_build_exeext+:} false; then : + $as_echo_n "(cached) " >&6 +else + rm -f conftest* + echo 'int main () { return 0; }' > conftest.c + bfd_cv_build_exeext= + ${CC_FOR_BUILD} -o conftest conftest.c 1>&5 2>&5 + for file in conftest.*; do + case $file in + *.c | *.o | *.obj | *.ilk | *.pdb) ;; + *) bfd_cv_build_exeext=`echo $file | sed -e s/conftest//` ;; + esac + done + rm -f conftest* + test x"${bfd_cv_build_exeext}" = x && bfd_cv_build_exeext=no +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $bfd_cv_build_exeext" >&5 +$as_echo "$bfd_cv_build_exeext" >&6; } + EXEEXT_FOR_BUILD="" + test x"${bfd_cv_build_exeext}" != xno && EXEEXT_FOR_BUILD=${bfd_cv_build_exeext} +fi + + +if test "$ZIP_PROG" = ""; then + ZIP_PROG='./minizip${EXEEXT_FOR_BUILD}' +fi + +# Check whether --enable-zipfs was given. +if test "${enable_zipfs+set}" = set; then : + enableval=$enable_zipfs; tcl_ok=$enableval +else + tcl_ok=yes +fi + + if test "$tcl_ok" = "yes" -o "${TCL_THREADS}" = 1; then + ZIPFS_BUILD=1 + else + ZIPFS_BUILD=0 + fi + # Do checking message here to not mess up interleaved configure output + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for building with zipfs" >&5 +$as_echo_n "checking for building with zipfs... " >&6; } + if test "${ZIPFS_BUILD}" = 1; then + if test "${SHARED_BUILD}" = 0; then + ZIPFS_BUILD=2; + +$as_echo "#define ZIPFS_BUILD 2" >>confdefs.h + + INSTALL_LIBRARIES=install-libraries-zipfs-static + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +$as_echo "yes" >&6; } + else + +$as_echo "#define ZIPFS_BUILD 1" >>confdefs.h +\ + INSTALL_LIBRARIES=install-libraries-zipfs-shared + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +$as_echo "yes" >&6; } + fi + else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } + INSTALL_LIBRARIES=install-libraries + INSTALL_MSGS=install-msgs + fi + + + + #-------------------------------------------------------------------- # The check below checks whether the cpuid instruction is usable. #-------------------------------------------------------------------- @@ -10373,10 +10530,11 @@ #------------------------------------------------------------------------ # tclConfig.sh refers to this by a different name #------------------------------------------------------------------------ TCL_SHARED_BUILD=${SHARED_BUILD} + Index: unix/configure.ac ================================================================== --- unix/configure.ac +++ unix/configure.ac @@ -28,10 +28,11 @@ TCL_PATCH_LEVEL="a2" VERSION=${TCL_VERSION} EXTRA_INSTALL_BINARIES=${EXTRA_INSTALL_BINARIES:-"@:"} EXTRA_BUILD_HTML=${EXTRA_BUILD_HTML:-"@:"} +TCL_ZIP_FILE=libtcl_${TCL_MAJOR_VERSION}_${TCL_MINOR_VERSION}_${TCL_PATCH_LEVEL}.zip #------------------------------------------------------------------------ # Setup configure arguments for bundled packages #------------------------------------------------------------------------ @@ -83,10 +84,11 @@ CFLAGS="" fi AC_PROG_CC AC_C_INLINE + #-------------------------------------------------------------------- # Supply substitutes for missing POSIX header files. Special notes: # - stdlib.h doesn't define strtol, strtoul, or # strtod insome versions of SunOS @@ -787,10 +789,60 @@ RANLIB='/usr/ccs/bin/ranlib' fi fi fi AC_MSG_RESULT([$tcl_ok]) + +#-------------------------------------------------------------------- +# Zipfs support +#-------------------------------------------------------------------- + +# +# Find a native zip implementation +# +SC_PROG_ZIP + +# +# Find a native compiler +# +AX_CC_FOR_BUILD + +if test "$ZIP_PROG" = ""; then + ZIP_PROG='./minizip${EXEEXT_FOR_BUILD}' +fi + +AC_ARG_ENABLE(zipfs, + AC_HELP_STRING([--enable-zipfs], + [build with Zipfs support (default: on)]), + [tcl_ok=$enableval], [tcl_ok=yes]) + if test "$tcl_ok" = "yes" -o "${TCL_THREADS}" = 1; then + ZIPFS_BUILD=1 + else + ZIPFS_BUILD=0 + fi + # Do checking message here to not mess up interleaved configure output + AC_MSG_CHECKING([for building with zipfs]) + if test "${ZIPFS_BUILD}" = 1; then + if test "${SHARED_BUILD}" = 0; then + ZIPFS_BUILD=2; + AC_DEFINE(ZIPFS_BUILD, 2, [Are we building with zipfs enabled?]) + INSTALL_LIBRARIES=install-libraries-zipfs-static + AC_MSG_RESULT([yes]) + else + AC_DEFINE(ZIPFS_BUILD, 1, [Are we building with zipfs enabled?])\ + INSTALL_LIBRARIES=install-libraries-zipfs-shared + AC_MSG_RESULT([yes]) + fi + else + AC_MSG_RESULT([no]) + INSTALL_LIBRARIES=install-libraries + INSTALL_MSGS=install-msgs + fi + AC_SUBST(ZIPFS_BUILD) + AC_SUBST(INSTALL_LIBRARIES) + AC_SUBST(INSTALL_MSGS) + #-------------------------------------------------------------------- # The check below checks whether the cpuid instruction is usable. #-------------------------------------------------------------------- @@ -958,10 +1010,11 @@ AC_SUBST(TCL_MINOR_VERSION) AC_SUBST(TCL_PATCH_LEVEL) AC_SUBST(TCL_YEAR) AC_SUBST(PKG_CFG_ARGS) +AC_SUBST(TCL_ZIP_FILE) AC_SUBST(TCL_LIB_FILE) AC_SUBST(TCL_LIB_FLAG) AC_SUBST(TCL_LIB_SPEC) AC_SUBST(TCL_STUB_LIB_FILE) AC_SUBST(TCL_STUB_LIB_FLAG) Index: unix/tcl.m4 ================================================================== --- unix/tcl.m4 +++ unix/tcl.m4 @@ -274,10 +274,11 @@ # # Substitutes the following vars: # TCL_BIN_DIR # TCL_SRC_DIR # TCL_LIB_FILE +# TCL_ZIP_FILE #------------------------------------------------------------------------ AC_DEFUN([SC_LOAD_TCLCONFIG], [ AC_MSG_CHECKING([for existence of ${TCL_BIN_DIR}/tclConfig.sh]) @@ -287,10 +288,11 @@ else AC_MSG_RESULT([could not find ${TCL_BIN_DIR}/tclConfig.sh]) fi # eval is required to do the TCL_DBGX substitution + eval "TCL_ZIP_FILE=\"${TCL_ZIP_FILE}\"" eval "TCL_LIB_FILE=\"${TCL_LIB_FILE}\"" eval "TCL_STUB_LIB_FILE=\"${TCL_STUB_LIB_FILE}\"" # If the TCL_BIN_DIR is the build directory (not the install directory), # then set the common variable name to the value of the build variables. @@ -334,10 +336,11 @@ AC_SUBST(TCL_VERSION) AC_SUBST(TCL_PATCH_LEVEL) AC_SUBST(TCL_BIN_DIR) AC_SUBST(TCL_SRC_DIR) + AC_SUBST(TCL_ZIP_FILE) AC_SUBST(TCL_LIB_FILE) AC_SUBST(TCL_LIB_FLAG) AC_SUBST(TCL_LIB_SPEC) AC_SUBST(TCL_STUB_LIB_FILE) @@ -540,10 +543,11 @@ else AC_MSG_RESULT([static]) SHARED_BUILD=0 AC_DEFINE(STATIC_BUILD, 1, [Is this a static build?]) fi + AC_SUBST(SHARED_BUILD) ]) #------------------------------------------------------------------------ # SC_ENABLE_FRAMEWORK -- # @@ -2076,11 +2080,10 @@ if test $tcl_cv_dirent_h = no; then AC_DEFINE(NO_DIRENT_H, 1, [Do we have ?]) fi - AC_CHECK_HEADER(float.h, , [AC_DEFINE(NO_FLOAT_H, 1, [Do we have ?])]) AC_CHECK_HEADER(values.h, , [AC_DEFINE(NO_VALUES_H, 1, [Do we have ?])]) AC_CHECK_HEADER(stdlib.h, tcl_ok=1, tcl_ok=0) AC_EGREP_HEADER(strtol, stdlib.h, , tcl_ok=0) AC_EGREP_HEADER(strtoul, stdlib.h, , tcl_ok=0) AC_EGREP_HEADER(strtod, stdlib.h, , tcl_ok=0) @@ -3012,8 +3015,111 @@ [Use compat implementation of getaddrinfo() and friends]) AC_LIBOBJ([fake-rfc2553]) AC_CHECK_FUNC(strlcpy) fi ]) + +#------------------------------------------------------------------------ +# SC_PROG_ZIP +# Locate a zip encoder installed on the system path, or none. +# +# Arguments: +# none +# +# Results: +# Substitutes the following vars: +# ZIP_PROG +#------------------------------------------------------------------------ + +AC_DEFUN([SC_PROG_ZIP], [ + AC_MSG_CHECKING([for zip]) + AC_CACHE_VAL(ac_cv_path_zip, [ + search_path=`echo ${PATH} | sed -e 's/:/ /g'` + for dir in $search_path ; do + for j in `ls -r $dir/zip 2> /dev/null` \ + `ls -r $dir/zip 2> /dev/null` ; do + if test x"$ac_cv_path_zip" = x ; then + if test -f "$j" ; then + ac_cv_path_zip=$j + break + fi + fi + done + done + ]) + + if test -f "$ac_cv_path_zip" ; then + ZIP_PROG="$ac_cv_path_zip" + AC_MSG_RESULT([$ZIP_PROG]) + else + # It is not an error if an installed version of Zip can't be located. + ZIP_PROG="" + AC_MSG_RESULT([No zip found on PATH]) + fi + AC_SUBST(ZIP_PROG) +]) + +#------------------------------------------------------------------------ +# SC_CC_FOR_BUILD +# For cross compiles, locate a C compiler that can generate native binaries. +# +# Arguments: +# none +# +# Results: +# Substitutes the following vars: +# CC_FOR_BUILD +# EXEEXT_FOR_BUILD +#------------------------------------------------------------------------ + +dnl Get a default for CC_FOR_BUILD to put into Makefile. +AC_DEFUN([AX_CC_FOR_BUILD], +[# Put a plausible default for CC_FOR_BUILD in Makefile. +if test -z "$CC_FOR_BUILD"; then + if test "x$cross_compiling" = "xno"; then + CC_FOR_BUILD='$(CC)' + else + AC_MSG_CHECKING([for gcc]) + AC_CACHE_VAL(ac_cv_path_cc, [ + search_path=`echo ${PATH} | sed -e 's/:/ /g'` + for dir in $search_path ; do + for j in `ls -r $dir/gcc 2> /dev/null` \ + `ls -r $dir/gcc 2> /dev/null` ; do + if test x"$ac_cv_path_cc" = x ; then + if test -f "$j" ; then + ac_cv_path_cc=$j + break + fi + fi + done + done + ]) + fi +fi +AC_SUBST(CC_FOR_BUILD) +# Also set EXEEXT_FOR_BUILD. +if test "x$cross_compiling" = "xno"; then + EXEEXT_FOR_BUILD='$(EXEEXT)' + OBJEXT_FOR_BUILD='$(OBJEXT)' +else + OBJEXT_FOR_BUILD='.no' + AC_CACHE_CHECK([for build system executable suffix], bfd_cv_build_exeext, + [rm -f conftest* + echo 'int main () { return 0; }' > conftest.c + bfd_cv_build_exeext= + ${CC_FOR_BUILD} -o conftest conftest.c 1>&5 2>&5 + for file in conftest.*; do + case $file in + *.c | *.o | *.obj | *.ilk | *.pdb) ;; + *) bfd_cv_build_exeext=`echo $file | sed -e s/conftest//` ;; + esac + done + rm -f conftest* + test x"${bfd_cv_build_exeext}" = x && bfd_cv_build_exeext=no]) + EXEEXT_FOR_BUILD="" + test x"${bfd_cv_build_exeext}" != xno && EXEEXT_FOR_BUILD=${bfd_cv_build_exeext} +fi +AC_SUBST(EXEEXT_FOR_BUILD)])dnl +AC_SUBST(OBJEXT_FOR_BUILD)])dnl # Local Variables: # mode: autoconf # End: Index: unix/tclAppInit.c ================================================================== --- unix/tclAppInit.c +++ unix/tclAppInit.c @@ -77,10 +77,12 @@ XtToolkitInitialize(); #endif #ifdef TCL_LOCAL_MAIN_HOOK TCL_LOCAL_MAIN_HOOK(&argc, &argv); +#else + TclZipfs_AppHook(&argc, &argv); #endif Tcl_Main(argc, argv, TCL_LOCAL_APPINIT); return 0; /* Needed only to prevent compiler warning. */ } Index: unix/tclConfig.h.in ================================================================== --- unix/tclConfig.h.in +++ unix/tclConfig.h.in @@ -293,13 +293,10 @@ #undef NO_DLFCN_H /* Do we have fd_set? */ #undef NO_FD_SET -/* Do we have ? */ -#undef NO_FLOAT_H - /* Do we have fstatfs()? */ #undef NO_FSTATFS /* Do we have gettimeofday()? */ #undef NO_GETTOD Index: unix/tclConfig.sh.in ================================================================== --- unix/tclConfig.sh.in +++ unix/tclConfig.sh.in @@ -36,10 +36,13 @@ # Flag, 1: we built a shared lib, 0 we didn't TCL_SHARED_BUILD=@TCL_SHARED_BUILD@ # The name of the Tcl library (may be either a .a file or a shared library): TCL_LIB_FILE='@TCL_LIB_FILE@' + +# The name of a zip containing the /library and /encodings (may be either a .zip file or a shared library): +TCL_ZIP_FILE='@TCL_ZIP_FILE@' # Additional libraries to use when linking Tcl. TCL_LIBS='@TCL_LIBS@' # Top-level directory in which Tcl's platform-independent files are Index: unix/tclUnixPort.h ================================================================== --- unix/tclUnixPort.h +++ unix/tclUnixPort.h @@ -179,16 +179,13 @@ * for an alternative definition. If no other alternative is available we use * a reasonable guess. *--------------------------------------------------------------------------- */ -#ifndef NO_FLOAT_H -# include -#else +#include #ifndef NO_VALUES_H # include -#endif #endif #ifndef FLT_MAX # ifdef MAXFLOAT # define FLT_MAX MAXFLOAT Index: win/Makefile.in ================================================================== --- win/Makefile.in +++ win/Makefile.in @@ -134,10 +134,15 @@ DOTVER = @TCL_MAJOR_VERSION@.@TCL_MINOR_VERSION@ DDEVER = @TCL_DDE_MAJOR_VERSION@@TCL_DDE_MINOR_VERSION@ DDEDOTVER = @TCL_DDE_MAJOR_VERSION@.@TCL_DDE_MINOR_VERSION@ REGVER = @TCL_REG_MAJOR_VERSION@@TCL_REG_MINOR_VERSION@ REGDOTVER = @TCL_REG_MAJOR_VERSION@.@TCL_REG_MINOR_VERSION@ + +TCL_ZIP_FILE = @TCL_ZIP_FILE@ +TCL_VFS_PATH = libtcl.vfs/tcl_library +TCL_VFS_ROOT = libtcl.vfs + TCL_STUB_LIB_FILE = @TCL_STUB_LIB_FILE@ TCL_DLL_FILE = @TCL_DLL_FILE@ TCL_LIB_FILE = @TCL_LIB_FILE@ DDE_DLL_FILE = tcldde$(DDEVER)${DLLSUFFIX} @@ -194,10 +199,47 @@ MKDIR = mkdir -p SHELL = @SHELL@ RM = rm -f COPY = cp +### +# Tip 430 - ZipFS Modifications +### + +TCL_ZIP_FILE = @TCL_ZIP_FILE@ +TCL_VFS_PATH = libtcl.vfs/tcl_library +TCL_VFS_ROOT = libtcl.vfs + +HOST_CC = @CC_FOR_BUILD@ +HOST_EXEEXT = @EXEEXT_FOR_BUILD@ +HOST_OBJEXT = @OBJEXT_FOR_BUILD@ +ZIPFS_BUILD = @ZIPFS_BUILD@ +NATIVE_ZIP = @ZIP_PROG@ +SHARED_BUILD = @SHARED_BUILD@ +INSTALL_MSGS = @INSTALL_MSGS@ +INSTALL_LIBRARIES = @INSTALL_LIBRARIES@ + +# Minizip +MINIZIP_OBJS = \ + adler32.$(HOST_OBJEXT) \ + compress.$(HOST_OBJEXT) \ + crc32.$(HOST_OBJEXT) \ + deflate.$(HOST_OBJEXT) \ + infback.$(HOST_OBJEXT) \ + inffast.$(HOST_OBJEXT) \ + inflate.$(HOST_OBJEXT) \ + inftrees.$(HOST_OBJEXT) \ + ioapi.$(HOST_OBJEXT) \ + iowin32.$(HOST_OBJEXT) \ + trees.$(HOST_OBJEXT) \ + uncompr.$(HOST_OBJEXT) \ + zip.$(HOST_OBJEXT) \ + zutil.$(HOST_OBJEXT) \ + minizip.$(HOST_OBJEXT) + +ZIP_INSTALL_OBJS = minizip${EXEEXT_FOR_BUILD} + CC_SWITCHES = ${CFLAGS} ${CFLAGS_WARNING} ${TCL_SHLIB_CFLAGS} \ -I"${ZLIB_DIR_NATIVE}" -I"${GENERIC_DIR_NATIVE}" \ -DMP_PREC=4 -I"${TOMMATH_DIR_NATIVE}" -I"${WIN_DIR_NATIVE}" \ ${AC_FLAGS} ${COMPILE_DEBUG_FLAGS} ${NO_DEPRECATED_FLAGS} @@ -300,10 +342,11 @@ tclTomMathInterface.$(OBJEXT) \ tclTrace.$(OBJEXT) \ tclUtf.$(OBJEXT) \ tclUtil.$(OBJEXT) \ tclVar.$(OBJEXT) \ + tclZipfs.$(OBJEXT) \ tclZlib.$(OBJEXT) TOMMATH_OBJS = \ bncore.${OBJEXT} \ bn_reverse.${OBJEXT} \ @@ -431,13 +474,21 @@ libraries: doc: +tclzipfile: ${TCL_ZIP_FILE} + +${TCL_ZIP_FILE}: ${ZIP_INSTALL_OBJS} + rm -rf ${TCL_VFS_ROOT} + mkdir -p ${TCL_VFS_PATH} + cp -a ../library/* ${TCL_VFS_PATH} + cd ${TCL_VFS_ROOT} ; ../minizip${EXEEXT_FOR_BUILD} -o ../${TCL_ZIP_FILE} `find . -type f` + $(TCLSH): $(TCLSH_OBJS) @LIBRARIES@ $(TCL_STUB_LIB_FILE) tclsh.$(RES) $(CC) $(CFLAGS) $(TCLSH_OBJS) $(TCL_LIB_FILE) $(TCL_STUB_LIB_FILE) $(LIBS) \ - tclsh.$(RES) $(CC_EXENAME) $(LDFLAGS_CONSOLE) + tclsh.$(RES) $(CC_EXENAME) $(LDFLAGS_CONSOLE) @VC_MANIFEST_EMBED_EXE@ cat32.$(OBJEXT): cat.c $(CC) -c $(CC_SWITCHES) @DEPARG@ $(CC_OBJNAME) @@ -450,14 +501,17 @@ ${TCL_STUB_LIB_FILE}: ${STUB_OBJS} @$(RM) ${TCL_STUB_LIB_FILE} @MAKE_STUB_LIB@ ${STUB_OBJS} @POST_MAKE_LIB@ -${TCL_DLL_FILE}: ${TCL_OBJS} tcl.$(RES) @ZLIB_DLL_FILE@ +${TCL_DLL_FILE}: ${TCL_OBJS} tcl.$(RES) @ZLIB_DLL_FILE@ ${TCL_ZIP_FILE} @$(RM) ${TCL_DLL_FILE} $(TCL_LIB_FILE) @MAKE_DLL@ ${TCL_OBJS} tcl.$(RES) $(SHLIB_LD_LIBS) @VC_MANIFEST_EMBED_DLL@ +ifeq (${ZIPFS_BUILD},1) + cat ${TCL_ZIP_FILE} >> ${TCL_DLL_FILE} +endif ${TCL_LIB_FILE}: ${TCL_OBJS} ${DDE_OBJS} ${REG_OBJS} @$(RM) ${TCL_LIB_FILE} @MAKE_LIB@ ${TCL_OBJS} ${DDE_OBJS} ${REG_OBJS} @POST_MAKE_LIB@ @@ -498,10 +552,19 @@ testMain.${OBJEXT}: tclAppInit.c $(CC) -c $(CC_SWITCHES) -DTCL_TEST @DEPARG@ $(CC_OBJNAME) tclMain2.${OBJEXT}: tclMain.c $(CC) -c $(CC_SWITCHES) -DBUILD_tcl -DTCL_ASCII_MAIN @DEPARG@ $(CC_OBJNAME) + +# TIP #430, ZipFS Support +tclZipfs.${OBJEXT}: $(GENERIC_DIR)/tclZipfs.c + $(CC) -c $(CC_SWITCHES) -DBUILD_tcl \ + -DCFG_RUNTIME_DLLFILE="\"$(TCL_LIB_FILE)\"" \ + -DCFG_RUNTIME_ZIPFILE="\"$(TCL_ZIP_FILE)\"" \ + -DCFG_RUNTIME_PATH="\"$(DLL_INSTALL_DIR)\"" \ + $(ZLIB_INCLUDE) -I$(ZLIB_DIR)/contrib/minizip @DEPARG@ $(CC_OBJNAME) + # TIP #59, embedding of configuration information into the binary library. # # Part of Tcl's configuration information are the paths where it was installed # and where it will look for its libraries (which can be different). We derive @@ -520,10 +583,12 @@ -DCFG_RUNTIME_LIBDIR=\"$(libdir_native)\" \ -DCFG_RUNTIME_BINDIR=\"$(bindir_native)\" \ -DCFG_RUNTIME_SCRDIR=\"$(TCL_LIBRARY_NATIVE)\" \ -DCFG_RUNTIME_INCDIR=\"$(includedir_native)\" \ -DCFG_RUNTIME_DOCDIR=\"$(mandir_native)\" \ + -DCFG_RUNTIME_DLLFILE="\"$(TCL_LIB_FILE)\"" \ + -DCFG_RUNTIME_ZIPFILE="\"$(TCL_ZIP_FILE)\"" \ -DBUILD_tcl \ @DEPARG@ $(CC_OBJNAME) # The following objects are part of the stub library and should not be built # as DLL objects but none of the symbols should be exported @@ -543,10 +608,83 @@ $(CC) -c $(CC_SWITCHES) -DBUILD_tcl @DEPARG@ $(CC_OBJNAME) .rc.$(RES): $(RC) @RC_OUT@ $@ @RC_TYPE@ @RC_DEFINES@ @RC_INCLUDE@ "$(GENERIC_DIR_NATIVE)" @RC_INCLUDE@ "$(WIN_DIR_NATIVE)" @DEPARG@ + + +#-------------------------------------------------------------------------- +# Minizip implementation +#-------------------------------------------------------------------------- +adler32.$(HOST_OBJEXT): + $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/adler32.c + +compress.$(HOST_OBJEXT): + $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/compress.c + +crc32.$(HOST_OBJEXT): + $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/crc32.c + +deflate.$(HOST_OBJEXT): + $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/deflate.c + +ioapi.$(HOST_OBJEXT): + $(HOST_CC) -o $@ -I$(ZLIB_DIR) -I$(ZLIB_DIR)/contrib/minizip -c $(ZLIB_DIR)/contrib/minizip/ioapi.c + +iowin32.$(HOST_OBJEXT): + $(HOST_CC) -o $@ -I$(ZLIB_DIR) -I$(ZLIB_DIR)/contrib/minizip -c $(ZLIB_DIR)/contrib/minizip/iowin32.c + +infback.$(HOST_OBJEXT): + $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/infback.c + +inffast.$(HOST_OBJEXT): + $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/inffast.c + +inflate.$(HOST_OBJEXT): + $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/inflate.c + +inftrees.$(HOST_OBJEXT): + $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/inftrees.c + +trees.$(HOST_OBJEXT): + $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/trees.c + +uncompr.$(HOST_OBJEXT): + $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/uncompr.c + +zip.$(HOST_OBJEXT): + $(HOST_CC) -o $@ -I$(ZLIB_DIR) -I$(ZLIB_DIR)/contrib/minizip -c $(ZLIB_DIR)/contrib/minizip/zip.c + +zutil.$(HOST_OBJEXT): + $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/zutil.c + +minizip.$(HOST_OBJEXT): + $(HOST_CC) -o $@ -I$(ZLIB_DIR) -I$(ZLIB_DIR)/contrib/minizip -c $(ZLIB_DIR)/contrib/minizip/minizip.c + +minizip${EXEEXT_FOR_BUILD}: $(MINIZIP_OBJS) + $(HOST_CC) -o $@ $(MINIZIP_OBJS) + +tclvfs.zip: minizip${EXEEXT_FOR_BUILD} + rm -rf $(TCL_VFS_ROOT) + mkdir -p $(TCL_VFS_PATH) + @for i in "$(TCL_VFS_PATH)"; \ + do \ + if [ ! -d "$$i" ] ; then \ + echo "Making directory $$i"; \ + $(INSTALL_DATA_DIR) "$$i"; \ + else true; \ + fi; \ + done; + cp -a ../library/* $(TCL_VFS_PATH) + (cd $TCL_VFS ROOT ; ./minizip${EXEEXT_FOR_BUILD} -o ../tclvfs.zip `find . -type f`) + +zipsetupstub.$(HOST_OBJEXT): $(COMPAT_DIR)/zipsetupstub.c + $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(COMPAT_DIR)/zipsetupstub.c + +zipsetupstub${EXEEXT_FOR_BUILD}: zipsetupstub.$(HOST_OBJEXT) + $(HOST_CC) -o $@ zipsetupstub.$(HOST_OBJEXT) + # The following target generates the file generic/tclDate.c from the yacc # grammar found in generic/tclGetDate.y. This is only run by hand as yacc is # not available in all environments. The name of the .c file is different than # the name of the .y file so that make doesn't try to automatically regenerate # the .c file. @@ -618,10 +756,29 @@ @if [ -f $(REG_LIB_FILE) ]; then \ echo Installing $(REG_LIB_FILE); \ $(COPY) $(REG_LIB_FILE) $(LIB_INSTALL_DIR)/reg${REGDOTVER}; \ fi +install-libraries-zipfs-shared: libraries + @for i in "$(SCRIPT_INSTALL_DIR)"; \ + do \ + if [ ! -d "$$i" ] ; then \ + echo "Making directory $$i"; \ + $(INSTALL_DATA_DIR) "$$i"; \ + else true; \ + fi; \ + done; + @echo "Installing library files to $(SCRIPT_INSTALL_DIR)/"; + @for i in \ + $(UNIX_DIR)/tclAppInit.c @LDAIX_SRC@ @DTRACE_SRC@; \ + do \ + $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"; \ + done; + +install-libraries-zipfs-static: install-libraries-zipfs-shared + $(INSTALL_DATA) ${TCL_ZIP_FILE} "$(LIB_INSTALL_DIR)" ;\ + install-libraries: libraries install-tzdata install-msgs @for i in "$$($(CYGPATH) $(prefix)/lib)" "$(INCLUDE_INSTALL_DIR)" \ $(SCRIPT_INSTALL_DIR); \ do \ if [ ! -d $$i ] ; then \ @@ -750,14 +907,15 @@ clean: cleanhelp clean-packages $(RM) *.lib *.a *.exp *.dll *.$(RES) *.${OBJEXT} *~ \#* TAGS a.out $(RM) $(TCLSH) $(CAT32) $(RM) *.pch *.ilk *.pdb + minizip${EXEEXT_FOR_BUILD} *.${HOST_OBJEXT} distclean: distclean-packages clean $(RM) Makefile config.status config.cache config.log tclConfig.sh \ - tcl.hpj config.status.lineno + tcl.hpj config.status.lineno tclsh.exe.manifest # # Bundled package targets # @@ -882,7 +1040,8 @@ .PHONY: install-binaries install-libraries install-tzdata install-msgs .PHONY: install-doc install-private-headers test test-tcl runtest shell .PHONY: gdb depend cleanhelp clean distclean packages install-packages .PHONY: test-packages clean-packages distclean-packages genstubs html .PHONY: html-tcl html-tk +.PHONY: iinstall-libraries-zipfs-shared install-libraries-zipfs-static tclzipfile # DO NOT DELETE THIS LINE -- make depend depends on it. Index: win/configure ================================================================== --- win/configure +++ win/configure @@ -685,10 +685,11 @@ TCL_IMPORT_LIB_FILE TCL_STATIC_LIB_FLAG TCL_STATIC_LIB_FILE TCL_LIB_FLAG TCL_LIB_FILE +TCL_ZIP_FILE TCL_EXE PKG_CFG_ARGS TCL_PATCH_LEVEL TCL_MINOR_VERSION TCL_MAJOR_VERSION @@ -697,19 +698,26 @@ TCL_WIN_VERSION VC_MANIFEST_EMBED_EXE VC_MANIFEST_EMBED_DLL LDFLAGS_DEFAULT CFLAGS_DEFAULT +INSTALL_MSGS +INSTALL_LIBRARIES +ZIPFS_BUILD +EXEEXT_FOR_BUILD +CC_FOR_BUILD +ZIP_PROG ZLIB_OBJS ZLIB_LIBS ZLIB_DLL_FILE CFLAGS_WARNING CFLAGS_OPTIMIZE CFLAGS_DEBUG DL_LIBS CELIB_DIR CYGPATH +SHARED_BUILD TCL_THREADS SET_MAKE RC RANLIB AR @@ -758,20 +766,22 @@ PACKAGE_STRING PACKAGE_VERSION PACKAGE_TARNAME PACKAGE_NAME PATH_SEPARATOR -SHELL' +SHELL +OBJEXT_FOR_BUILD' ac_subst_files='' ac_user_opts=' enable_option_checking enable_threads with_encoding enable_shared enable_64bit enable_wince with_celib +enable_zipfs enable_symbols enable_embedded_manifest ' ac_precious_vars='build_alias host_alias @@ -1391,10 +1401,11 @@ --enable-FEATURE[=ARG] include FEATURE [ARG=yes] --enable-threads build with threads (default: on) --enable-shared build and link with shared libraries (default: on) --enable-64bit enable 64bit support (where applicable) --enable-wince enable Win/CE support (where applicable) + --enable-zipfs build with Zipfs support (default: on) --enable-symbols build with debugging symbols (default: off) --enable-embedded-manifest embed manifest if possible (default: yes) Optional Packages: @@ -2114,10 +2125,12 @@ TCL_REG_MAJOR_VERSION=1 TCL_REG_MINOR_VERSION=3 REGVER=$TCL_REG_MAJOR_VERSION$TCL_REG_MINOR_VERSION PKG_CFG_ARGS=$@ + +TCL_ZIP_FILE=libtcl_${TCL_MAJOR_VERSION}_${TCL_MINOR_VERSION}_${TCL_PATCH_LEVEL}.zip #------------------------------------------------------------------------ # Empty slate for bundled packages, to avoid stale configuration #------------------------------------------------------------------------ rm -Rf pkgs @@ -3769,10 +3782,11 @@ $as_echo "#define STATIC_BUILD 1" >>confdefs.h fi + #-------------------------------------------------------------------- # The statements below define a collection of compile flags. This # macro depends on the value of SHARED_BUILD, and should be called # after SC_ENABLE_SHARED checks the configure switches. @@ -4825,10 +4839,164 @@ fi fi + + +#-------------------------------------------------------------------- +# Zipfs support +#-------------------------------------------------------------------- + +# +# Find a native zip implementation +# + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for zip" >&5 +$as_echo_n "checking for zip... " >&6; } + if ${ac_cv_path_zip+:} false; then : + $as_echo_n "(cached) " >&6 +else + + search_path=`echo ${PATH} | sed -e 's/:/ /g'` + for dir in $search_path ; do + for j in `ls -r $dir/zip 2> /dev/null` \ + `ls -r $dir/zip 2> /dev/null` ; do + if test x"$ac_cv_path_zip" = x ; then + if test -f "$j" ; then + ac_cv_path_zip=$j + break + fi + fi + done + done + +fi + + + if test -f "$ac_cv_path_zip" ; then + ZIP_PROG="$ac_cv_path_zip" + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ZIP_PROG" >&5 +$as_echo "$ZIP_PROG" >&6; } + else + # It is not an error if an installed version of Zip can't be located. + ZIP_PROG="" + { $as_echo "$as_me:${as_lineno-$LINENO}: result: No zip found on PATH" >&5 +$as_echo "No zip found on PATH" >&6; } + fi + + + +# +# Find a native compiler +# +# Put a plausible default for CC_FOR_BUILD in Makefile. +if test -z "$CC_FOR_BUILD"; then + if test "x$cross_compiling" = "xno"; then + CC_FOR_BUILD='$(CC)' + else + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for gcc" >&5 +$as_echo_n "checking for gcc... " >&6; } + if ${ac_cv_path_cc+:} false; then : + $as_echo_n "(cached) " >&6 +else + + search_path=`echo ${PATH} | sed -e 's/:/ /g'` + for dir in $search_path ; do + for j in `ls -r $dir/gcc 2> /dev/null` \ + `ls -r $dir/gcc 2> /dev/null` ; do + if test x"$ac_cv_path_cc" = x ; then + if test -f "$j" ; then + ac_cv_path_cc=$j + break + fi + fi + done + done + +fi + + fi +fi + +# Also set EXEEXT_FOR_BUILD. +if test "x$cross_compiling" = "xno"; then + EXEEXT_FOR_BUILD='$(EXEEXT)' + OBJEXT_FOR_BUILD='$(OBJEXT)' +else + OBJEXT_FOR_BUILD='.no' + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for build system executable suffix" >&5 +$as_echo_n "checking for build system executable suffix... " >&6; } +if ${bfd_cv_build_exeext+:} false; then : + $as_echo_n "(cached) " >&6 +else + rm -f conftest* + echo 'int main () { return 0; }' > conftest.c + bfd_cv_build_exeext= + ${CC_FOR_BUILD} -o conftest conftest.c 1>&5 2>&5 + for file in conftest.*; do + case $file in + *.c | *.o | *.obj | *.ilk | *.pdb) ;; + *) bfd_cv_build_exeext=`echo $file | sed -e s/conftest//` ;; + esac + done + rm -f conftest* + test x"${bfd_cv_build_exeext}" = x && bfd_cv_build_exeext=no +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $bfd_cv_build_exeext" >&5 +$as_echo "$bfd_cv_build_exeext" >&6; } + EXEEXT_FOR_BUILD="" + test x"${bfd_cv_build_exeext}" != xno && EXEEXT_FOR_BUILD=${bfd_cv_build_exeext} +fi + + +if test "$ZIP_PROG" = ""; then + ZIP_PROG='./minizip${EXEEXT_FOR_BUILD}' +fi + +# Check whether --enable-zipfs was given. +if test "${enable_zipfs+set}" = set; then : + enableval=$enable_zipfs; tcl_ok=$enableval +else + tcl_ok=yes +fi + + if test "$tcl_ok" = "yes" -o "${TCL_THREADS}" = 1; then + ZIPFS_BUILD=1 + else + ZIPFS_BUILD=0 + fi + # Do checking message here to not mess up interleaved configure output + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for building with zipfs" >&5 +$as_echo_n "checking for building with zipfs... " >&6; } + if test "${ZIPFS_BUILD}" = 1; then + if test "${SHARED_BUILD}" = 0; then + ZIPFS_BUILD=2; + +$as_echo "#define ZIPFS_BUILD 2" >>confdefs.h + + INSTALL_LIBRARIES=install-libraries-zipfs-static + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +$as_echo "yes" >&6; } + else + +$as_echo "#define ZIPFS_BUILD 1" >>confdefs.h +\ + INSTALL_LIBRARIES=install-libraries-zipfs-shared + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +$as_echo "yes" >&6; } + fi + else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } + INSTALL_LIBRARIES=install-libraries + INSTALL_MSGS=install-msgs + fi + + + + #-------------------------------------------------------------------- # Perform additinal compiler tests. #-------------------------------------------------------------------- @@ -5203,10 +5371,11 @@ *) TCL_RELEASE_LEVEL=2 ;; esac TCL_WIN_VERSION="$TCL_VERSION.$TCL_RELEASE_LEVEL.`echo $TCL_PATCH_LEVEL | tr -d ab.`" # X86|AMD64|IA64 for manifest + Index: win/configure.ac ================================================================== --- win/configure.ac +++ win/configure.ac @@ -27,10 +27,12 @@ TCL_REG_MINOR_VERSION=3 REGVER=$TCL_REG_MAJOR_VERSION$TCL_REG_MINOR_VERSION PKG_CFG_ARGS=$@ +TCL_ZIP_FILE=libtcl_${TCL_MAJOR_VERSION}_${TCL_MINOR_VERSION}_${TCL_PATCH_LEVEL}.zip + #------------------------------------------------------------------------ # Empty slate for bundled packages, to avoid stale configuration #------------------------------------------------------------------------ rm -Rf pkgs @@ -171,10 +173,61 @@ if test "$tcl_cv_uintptr_t" != none; then AC_DEFINE_UNQUOTED([uintptr_t], [$tcl_cv_uintptr_t], [Unsigned integer type wide enough to hold a pointer.]) fi ]) + + +#-------------------------------------------------------------------- +# Zipfs support +#-------------------------------------------------------------------- + +# +# Find a native zip implementation +# +SC_PROG_ZIP + +# +# Find a native compiler +# +AX_CC_FOR_BUILD + +if test "$ZIP_PROG" = ""; then + ZIP_PROG='./minizip${EXEEXT_FOR_BUILD}' +fi + +AC_ARG_ENABLE(zipfs, + AC_HELP_STRING([--enable-zipfs], + [build with Zipfs support (default: on)]), + [tcl_ok=$enableval], [tcl_ok=yes]) + if test "$tcl_ok" = "yes" -o "${TCL_THREADS}" = 1; then + ZIPFS_BUILD=1 + else + ZIPFS_BUILD=0 + fi + # Do checking message here to not mess up interleaved configure output + AC_MSG_CHECKING([for building with zipfs]) + if test "${ZIPFS_BUILD}" = 1; then + if test "${SHARED_BUILD}" = 0; then + ZIPFS_BUILD=2; + AC_DEFINE(ZIPFS_BUILD, 2, [Are we building with zipfs enabled?]) + INSTALL_LIBRARIES=install-libraries-zipfs-static + AC_MSG_RESULT([yes]) + else + AC_DEFINE(ZIPFS_BUILD, 1, [Are we building with zipfs enabled?])\ + INSTALL_LIBRARIES=install-libraries-zipfs-shared + AC_MSG_RESULT([yes]) + fi + else + AC_MSG_RESULT([no]) + INSTALL_LIBRARIES=install-libraries + INSTALL_MSGS=install-msgs + fi + AC_SUBST(ZIPFS_BUILD) + AC_SUBST(INSTALL_LIBRARIES) + AC_SUBST(INSTALL_MSGS) + #-------------------------------------------------------------------- # Perform additinal compiler tests. #-------------------------------------------------------------------- @@ -368,10 +421,11 @@ AC_SUBST(TCL_MINOR_VERSION) AC_SUBST(TCL_PATCH_LEVEL) AC_SUBST(PKG_CFG_ARGS) AC_SUBST(TCL_EXE) +AC_SUBST(TCL_ZIP_FILE) AC_SUBST(TCL_LIB_FILE) AC_SUBST(TCL_LIB_FLAG) AC_SUBST(TCL_STATIC_LIB_FILE) AC_SUBST(TCL_STATIC_LIB_FLAG) AC_SUBST(TCL_IMPORT_LIB_FILE) Index: win/makefile.vc ================================================================== --- win/makefile.vc +++ win/makefile.vc @@ -342,10 +342,11 @@ $(TMP_DIR)\tclTomMathInterface.obj \ $(TMP_DIR)\tclTrace.obj \ $(TMP_DIR)\tclUtf.obj \ $(TMP_DIR)\tclUtil.obj \ $(TMP_DIR)\tclVar.obj \ + $(TMP_DIR)\tclZipfs.obj \ $(TMP_DIR)\tclZlib.obj ZLIBOBJS = \ $(TMP_DIR)\adler32.obj \ $(TMP_DIR)\compress.obj \ @@ -956,10 +957,14 @@ $(cc32) $(TCL_CFLAGS) -Fo$@ $? $(TMP_DIR)\tclZlib.obj: $(GENERICDIR)\tclZlib.c $(cc32) $(TCL_CFLAGS) -I$(COMPATDIR)\zlib -DBUILD_tcl -Fo$@ $? +### TIP #430 ZipFS Support +$(TMP_DIR)\zipfs.obj: $(GENERICDIR)\zipfs.c + $(cc32) $(TCL_CFLAGS) -I$(COMPATDIR)\zlib -I$(COMPATDIR)\zlib\contrib\minizip -DBUILD_tcl -Fo$@ $? + $(TMP_DIR)\tclPkgConfig.obj: $(GENERICDIR)\tclPkgConfig.c $(cc32) -DBUILD_tcl $(TCL_CFLAGS) \ -DCFG_INSTALL_LIBDIR="\"$(LIB_INSTALL_DIR:\=\\)\"" \ -DCFG_INSTALL_BINDIR="\"$(BIN_INSTALL_DIR:\=\\)\"" \ -DCFG_INSTALL_SCRDIR="\"$(SCRIPT_INSTALL_DIR:\=\\)\"" \ Index: win/tcl.dsp ================================================================== --- win/tcl.dsp +++ win/tcl.dsp @@ -148,14 +148,10 @@ # End Source File # Begin Source File SOURCE=..\compat\fixstrtod.c # End Source File -# Begin Source File - -SOURCE=..\compat\float.h -# End Source File # Begin Source File SOURCE=..\compat\gettod.c # End Source File # Begin Source File Index: win/tcl.hpj.in ================================================================== --- win/tcl.hpj.in +++ win/tcl.hpj.in @@ -3,13 +3,13 @@ [OPTIONS] HCW=0 LCID=0x409 0x0 0x0 ;English (United States) REPORT=Yes TITLE=Tcl/Tk Reference Manual -CNT=tcl86.cnt +CNT=tcl87.cnt COPYRIGHT=Copyright © 2000 Ajuba Solutions -HLP=tcl86.hlp +HLP=tcl87.hlp [FILES] tcl.rtf [WINDOWS] Index: win/tcl.m4 ================================================================== --- win/tcl.m4 +++ win/tcl.m4 @@ -249,10 +249,11 @@ # # Substitutes the following vars: # TCL_BIN_DIR # TCL_SRC_DIR # TCL_LIB_FILE +# TCL_ZIP_FILE # #------------------------------------------------------------------------ AC_DEFUN([SC_LOAD_TCLCONFIG], [ AC_MSG_CHECKING([for existence of ${TCL_BIN_DIR}/tclConfig.sh]) @@ -281,10 +282,11 @@ # # eval is required to do the TCL_DBGX substitution # + eval "TCL_ZIP_FILE=\"${TCL_ZIP_FILE}\"" eval "TCL_LIB_FILE=\"${TCL_LIB_FILE}\"" eval "TCL_LIB_FLAG=\"${TCL_LIB_FLAG}\"" eval "TCL_LIB_SPEC=\"${TCL_LIB_SPEC}\"" eval "TCL_STUB_LIB_FILE=\"${TCL_STUB_LIB_FILE}\"" @@ -293,10 +295,11 @@ AC_SUBST(TCL_VERSION) AC_SUBST(TCL_BIN_DIR) AC_SUBST(TCL_SRC_DIR) + AC_SUBST(TCL_ZIP_FILE) AC_SUBST(TCL_LIB_FILE) AC_SUBST(TCL_LIB_FLAG) AC_SUBST(TCL_LIB_SPEC) AC_SUBST(TCL_STUB_LIB_FILE) @@ -378,10 +381,11 @@ else AC_MSG_RESULT([static]) SHARED_BUILD=0 AC_DEFINE(STATIC_BUILD, 1, [Is this a static build?]) fi + AC_SUBST(SHARED_BUILD) ]) #------------------------------------------------------------------------ # SC_ENABLE_THREADS -- # @@ -1295,5 +1299,109 @@ fi AC_MSG_RESULT([$result]) AC_SUBST(VC_MANIFEST_EMBED_DLL) AC_SUBST(VC_MANIFEST_EMBED_EXE) ]) + + +#------------------------------------------------------------------------ +# SC_PROG_ZIP +# Locate a zip encoder installed on the system path, or none. +# +# Arguments: +# none +# +# Results: +# Substitutes the following vars: +# ZIP_PROG +#------------------------------------------------------------------------ + +AC_DEFUN([SC_PROG_ZIP], [ + AC_MSG_CHECKING([for zip]) + AC_CACHE_VAL(ac_cv_path_zip, [ + search_path=`echo ${PATH} | sed -e 's/:/ /g'` + for dir in $search_path ; do + for j in `ls -r $dir/zip 2> /dev/null` \ + `ls -r $dir/zip 2> /dev/null` ; do + if test x"$ac_cv_path_zip" = x ; then + if test -f "$j" ; then + ac_cv_path_zip=$j + break + fi + fi + done + done + ]) + + if test -f "$ac_cv_path_zip" ; then + ZIP_PROG="$ac_cv_path_zip" + AC_MSG_RESULT([$ZIP_PROG]) + else + # It is not an error if an installed version of Zip can't be located. + ZIP_PROG="" + AC_MSG_RESULT([No zip found on PATH]) + fi + AC_SUBST(ZIP_PROG) +]) + +#------------------------------------------------------------------------ +# SC_CC_FOR_BUILD +# For cross compiles, locate a C compiler that can generate native binaries. +# +# Arguments: +# none +# +# Results: +# Substitutes the following vars: +# CC_FOR_BUILD +# EXEEXT_FOR_BUILD +#------------------------------------------------------------------------ + +dnl Get a default for CC_FOR_BUILD to put into Makefile. +AC_DEFUN([AX_CC_FOR_BUILD], +[# Put a plausible default for CC_FOR_BUILD in Makefile. +if test -z "$CC_FOR_BUILD"; then + if test "x$cross_compiling" = "xno"; then + CC_FOR_BUILD='$(CC)' + else + AC_MSG_CHECKING([for gcc]) + AC_CACHE_VAL(ac_cv_path_cc, [ + search_path=`echo ${PATH} | sed -e 's/:/ /g'` + for dir in $search_path ; do + for j in `ls -r $dir/gcc 2> /dev/null` \ + `ls -r $dir/gcc 2> /dev/null` ; do + if test x"$ac_cv_path_cc" = x ; then + if test -f "$j" ; then + ac_cv_path_cc=$j + break + fi + fi + done + done + ]) + fi +fi +AC_SUBST(CC_FOR_BUILD) +# Also set EXEEXT_FOR_BUILD. +if test "x$cross_compiling" = "xno"; then + EXEEXT_FOR_BUILD='$(EXEEXT)' + OBJEXT_FOR_BUILD='$(OBJEXT)' +else + OBJEXT_FOR_BUILD='.no' + AC_CACHE_CHECK([for build system executable suffix], bfd_cv_build_exeext, + [rm -f conftest* + echo 'int main () { return 0; }' > conftest.c + bfd_cv_build_exeext= + ${CC_FOR_BUILD} -o conftest conftest.c 1>&5 2>&5 + for file in conftest.*; do + case $file in + *.c | *.o | *.obj | *.ilk | *.pdb) ;; + *) bfd_cv_build_exeext=`echo $file | sed -e s/conftest//` ;; + esac + done + rm -f conftest* + test x"${bfd_cv_build_exeext}" = x && bfd_cv_build_exeext=no]) + EXEEXT_FOR_BUILD="" + test x"${bfd_cv_build_exeext}" != xno && EXEEXT_FOR_BUILD=${bfd_cv_build_exeext} +fi +AC_SUBST(EXEEXT_FOR_BUILD)])dnl +AC_SUBST(OBJEXT_FOR_BUILD)])dnl Index: win/tclAppInit.c ================================================================== --- win/tclAppInit.c +++ win/tclAppInit.c @@ -122,10 +122,12 @@ } } #ifdef TCL_LOCAL_MAIN_HOOK TCL_LOCAL_MAIN_HOOK(&argc, &argv); +#else + TclZipfs_AppHook(&argc, &argv); #endif Tcl_Main(argc, argv, TCL_LOCAL_APPINIT); return 0; /* Needed only to prevent compiler warning. */ } Index: win/tclConfig.sh.in ================================================================== --- win/tclConfig.sh.in +++ win/tclConfig.sh.in @@ -38,10 +38,13 @@ # Flag, 1: we built a shared lib, 0 we didn't TCL_SHARED_BUILD=@TCL_SHARED_BUILD@ # The name of the Tcl library (may be either a .a file or a shared library): TCL_LIB_FILE='@TCL_LIB_FILE@' + +# The name of a zip containing the /library and /encodings (may be either a .zip file or a shared library): +TCL_ZIP_FILE='@TCL_ZIP_FILE@' # Flag to indicate whether shared libraries need export files. TCL_NEEDS_EXP_FILE=@TCL_NEEDS_EXP_FILE@ # String that can be evaluated to generate the part of the export file Index: win/tclWinThrd.c ================================================================== --- win/tclWinThrd.c +++ win/tclWinThrd.c @@ -11,12 +11,10 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclWinInt.h" -#include - /* Workaround for mingw versions which don't provide this in float.h */ #ifndef _MCW_EM # define _MCW_EM 0x0008001F /* Error masks */ # define _MCW_RC 0x00000300 /* Rounding */ # define _MCW_PC 0x00030000 /* Precision */