Tweaks to build

the zvfs.c file as a separate tool.

generic/tclZipTools.c

@@ -0,0 +1,996 @@
+/*
+** Copyright (c) 2000 D. Richard Hipp
+** Copyright (c) 2007 PDQ Interfaces Inc.
+** Copyright (c) 2014 Sean Woods
+**
+** This file is now released under the BSD style license
+** outlined in the included file license.terms.
+**
+*************************************************************************
+**
+** Utilities to Create, Modify and Introspect Zip files
+** Originally distributed as part of ZipVfs.c, split into
+** Their own file for clarity.
+**
+** This version has been modified to run under Tcl 8.6
+**
+*/
+#include "tcl.h"
+#include <ctype.h>
+#include <zlib.h>
+#include <errno.h>
+#include <string.h>
+#include <sys/stat.h>
+#include <time.h>
+
+/*
+** Size of the decompression input buffer
+*/
+#define COMPR_BUF_SIZE   8192
+static int maptolower=0;
+static int openarch=0;  /* Set to 1 when opening archive. */
+
+/*
+** All static variables are collected into a structure named "local".
+** That way, it is clear in the code when we are using a static
+** variable because its name begins with "local.".
+*/
+static struct {
+  Tcl_HashTable fileHash;     /* One entry for each file in the ZVFS.  The
+                              ** The key is the virtual filename.  The data
+                              ** an an instance of the ZvfsFile structure. */
+  Tcl_HashTable archiveHash;  /* One entry for each archive.  Key is the name. 
+                              ** data is the ZvfsArchive structure */
+  int isInit;                 /* True after initialization */
+} local;
+
+/*
+** Each ZIP archive file that is mounted is recorded as an instance
+** of this structure
+*/
+typedef struct ZvfsArchive {
+  char *zName;              /* Name of the archive */
+  char *zMountPoint;        /* Where this archive is mounted */
+  struct ZvfsFile *pFiles;  /* List of files in that archive */
+} ZvfsArchive;
+
+/*
+** Particulars about each virtual file are recorded in an instance
+** of the following structure.
+*/
+typedef struct ZvfsFile {
+  char *zName;              /* The full pathname of the virtual file */
+  ZvfsArchive *pArchive;    /* The ZIP archive holding this file data */
+  int iOffset;              /* Offset into the ZIP archive of the data */
+  int nByte;                /* Uncompressed size of the virtual file */
+  int nByteCompr;           /* Compressed size of the virtual file */
+  time_t timestamp;            /* Modification time */
+  int isdir;		    /* Set to 2 if directory, or 1 if mount */
+  int depth; 		    /* Number of slashes in path. */
+  int permissions;          /* File permissions. */
+  struct ZvfsFile *pNext;      /* Next file in the same archive */
+  struct ZvfsFile *pNextName;  /* A doubly-linked list of files with the same */
+  struct ZvfsFile *pPrevName;  /*  name.  Only the first is in local.fileHash */
+} ZvfsFile;
+
+/*
+** Information about each file within a ZIP archive is stored in
+** an instance of the following structure.  A list of these structures
+** forms a table of contents for the archive.
+*/
+typedef struct ZFile ZFile;
+struct ZFile {
+  char *zName;         /* Name of the file */
+  int isSpecial;       /* Not really a file in the ZIP archive */
+  int dosTime;         /* Modification time (DOS format) */
+  int dosDate;         /* Modification date (DOS format) */
+  int iOffset;         /* Offset into the ZIP archive of the data */
+  int nByte;           /* Uncompressed size of the virtual file */
+  int nByteCompr;      /* Compressed size of the virtual file */
+  int nExtra;          /* Extra space in the TOC header */
+  int iCRC;            /* Cyclic Redundancy Check of the data */
+  int permissions;     /* File permissions. */
+  int flags;		    /* Deletion = bit 0. */
+  ZFile *pNext;        /* Next file in the same archive */
+};
+
+/*
+** Macros to read 16-bit and 32-bit big-endian integers into the
+** native format of this local processor.  B is an array of
+** characters and the integer begins at the N-th character of
+** the array.
+*/
+#define INT16(B, N) (B[N] + (B[N+1]<<8))
+#define INT32(B, N) (INT16(B,N) + (B[N+2]<<16) + (B[N+3]<<24))
+
+static int ZvfsAppendObjCmd( void *NotUsed, Tcl_Interp *interp, int objc, Tcl_Obj *const* objv);
+static int ZvfsAddObjCmd( void *NotUsed, Tcl_Interp *interp, int objc, Tcl_Obj *const* objv);
+static int ZvfsDumpObjCmd( void *NotUsed, Tcl_Interp *interp, int objc, Tcl_Obj *const* objv);
+static int ZvfsStartObjCmd( void *NotUsed, Tcl_Interp *interp, int objc, Tcl_Obj *const* objv);
+
+/*
+** Write a 16- or 32-bit integer as little-endian into the given buffer.
+*/
+static void put16(char *z, int v){
+  z[0] = v & 0xff;
+  z[1] = (v>>8) & 0xff;
+}
+static void put32(char *z, int v){
+  z[0] = v & 0xff;
+  z[1] = (v>>8) & 0xff;
+  z[2] = (v>>16) & 0xff;
+  z[3] = (v>>24) & 0xff;
+}
+
+/*
+** Make a new ZFile structure with space to hold a name of the number of
+** characters given.  Return a pointer to the new structure.
+*/
+static ZFile *newZFile(int nName, ZFile **ppList){
+  ZFile *pNew;
+
+  pNew = (ZFile*)Tcl_Alloc( sizeof(*pNew) + nName + 1 );
+  memset(pNew, 0, sizeof(*pNew));
+  pNew->zName = (char*)&pNew[1];
+  pNew->pNext = *ppList;
+  *ppList = pNew;
+  return pNew;
+}
+
+/*
+** Delete an entire list of ZFile structures
+*/
+static void deleteZFileList(ZFile *pList){
+  ZFile *pNext;
+  while( pList ){
+    pNext = pList->pNext;
+    Tcl_Free((char*)pList);
+    pList = pNext;
+  }
+}
+
+/* Convert DOS time to unix time. */
+static void UnixTimeDate(struct tm *tm, int *dosDate, int *dosTime){
+  *dosDate = ((((tm->tm_year-80)<<9)&0xfe00) | (((tm->tm_mon+1)<<5)&0x1e0) | (tm->tm_mday&0x1f));
+  *dosTime = (((tm->tm_hour<<11)&0xf800) | ((tm->tm_min<<5)&0x7e0) | (tm->tm_sec&0x1f));
+}
+
+/* Convert DOS time to unix time. */
+static time_t DosTimeDate(int dosDate, int dosTime){
+  time_t now;
+  struct tm *tm;
+  now=time(NULL);
+  tm = localtime(&now);
+  tm->tm_year=(((dosDate&0xfe00)>>9) + 80);
+  tm->tm_mon=((dosDate&0x1e0)>>5);
+  tm->tm_mday=(dosDate & 0x1f);
+  tm->tm_hour=(dosTime&0xf800)>>11;
+  tm->tm_min=(dosTime&0x7e0)>>5;
+  tm->tm_sec=(dosTime&0x1f);
+  return mktime(tm);
+}
+
+/*
+** Translate a DOS time and date stamp into a human-readable string.
+*/
+static void translateDosTimeDate(char *zStr, int dosDate, int dosTime){
+  static char *zMonth[] = { "nil",
+    "Jan", "Feb", "Mar", "Apr", "May", "Jun",
+    "Jul", "Aug", "Sep", "Oct", "Nov", "Dec",
+  };
+ 
+  sprintf(zStr, "%02d-%s-%d %02d:%02d:%02d", 
+    dosDate & 0x1f,
+    zMonth[ ((dosDate&0x1e0)>>5) ],
+    ((dosDate&0xfe00)>>9) + 1980,
+    (dosTime&0xf800)>>11,
+    (dosTime&0x7e)>>5,
+    dosTime&0x1f
+  );
+}
+
+/* Return count of char ch in str */
+static int strchrcnt(char *str, char ch) {
+  int cnt=0;
+  char *cp=str;
+  while ((cp=strchr(cp,ch))) { cp++; cnt++; }
+  return cnt;
+}
+
+
+int ZvfsReadTOCStart(
+  Tcl_Interp *interp,    /* Leave error messages in this interpreter */
+  Tcl_Channel chan,
+  ZFile **pList,
+  int *iStart
+) {
+  char *zArchiveName = 0;    /* A copy of zArchive */
+  int nFile;                 /* Number of files in the archive */
+  int iPos;                  /* Current position in the archive file */
+  ZvfsArchive *pArchive;     /* The ZIP archive being mounted */
+  Tcl_HashEntry *pEntry;     /* Hash table entry */
+  int isNew;                 /* Flag to tell use when a hash entry is new */
+  unsigned char zBuf[100];   /* Space into which to read from the ZIP archive */
+  Tcl_HashSearch zSearch;   /* Search all mount points */
+  ZFile *p;
+  int zipStart;
+
+  if (!chan) {
+    return TCL_ERROR;
+  }
+  if (Tcl_SetChannelOption(interp, chan, "-translation", "binary") != TCL_OK){
+    return TCL_ERROR;
+  }
+  if (Tcl_SetChannelOption(interp, chan, "-encoding", "binary") != TCL_OK) {
+    return TCL_ERROR;
+  }
+
+  /* Read the "End Of Central Directory" record from the end of the
+  ** ZIP archive.
+  */
+  iPos = Tcl_Seek(chan, -22, SEEK_END);
+  Tcl_Read(chan, zBuf, 22);
+  if (memcmp(zBuf, "\120\113\05\06", 4)) {
+    /* Tcl_AppendResult(interp, "not a ZIP archive", NULL); */
+    return TCL_BREAK;
+  }
+
+  /* Compute the starting location of the directory for the ZIP archive
+  ** in iPos then seek to that location.
+  */
+  zipStart = iPos;
+  nFile = INT16(zBuf,8);
+  iPos -= INT32(zBuf,12);
+  Tcl_Seek(chan, iPos, SEEK_SET);
+
+  while(1) {
+    int lenName;            /* Length of the next filename */
+    int lenExtra;           /* Length of "extra" data for next file */
+    int iData;              /* Offset to start of file data */
+    int dosTime;
+    int dosDate;
+    int isdir;
+    ZvfsFile *pZvfs;        /* A new virtual file */
+    char *zFullPath;        /* Full pathname of the virtual file */
+    char zName[1024];       /* Space to hold the filename */
+
+    if (nFile-- <= 0 ){
+	break;
+    }
+    /* Read the next directory entry.  Extract the size of the filename,
+    ** the size of the "extra" information, and the offset into the archive
+    ** file of the file data.
+    */
+    Tcl_Read(chan, zBuf, 46);
+    if (memcmp(zBuf, "\120\113\01\02", 4)) {
+      Tcl_AppendResult(interp, "ill-formed central directory entry", NULL);
+      return TCL_ERROR;
+    }
+    lenName = INT16(zBuf,28);
+    lenExtra = INT16(zBuf,30) + INT16(zBuf,32);
+    iData = INT32(zBuf,42);
+    if (iData<zipStart) {
+        zipStart = iData;
+    }
+
+    p = newZFile(lenName, pList);
+    if (!p) break;
+
+    Tcl_Read(chan, p->zName, lenName);
+    p->zName[lenName] = 0;
+    if (lenName>0 && p->zName[lenName-1] == '/') {
+	p->isSpecial = 1;
+    }
+    p->dosDate = INT16(zBuf, 14);
+    p->dosTime = INT16(zBuf, 12);
+    p->nByteCompr = INT32(zBuf, 20);
+    p->nByte = INT32(zBuf, 24);
+    p->nExtra = INT32(zBuf, 28);
+    p->iCRC = INT32(zBuf, 32);
+
+    if (nFile < 0)
+	break;
+
+    /* Skip over the extra information so that the next read will be from
+    ** the beginning of the next directory entry.
+    */
+    Tcl_Seek(chan, lenExtra, SEEK_CUR);
+  }
+  *iStart = zipStart;
+  return TCL_OK;
+}
+
+/************************************************************************/
+/************************************************************************/
+/************************************************************************/
+
+/*
+** Implement the zvfs::dump command
+**
+**    zvfs::dump  ARCHIVE
+**
+** Each entry in the list returned is of the following form:
+**
+**   {FILENAME  DATE-TIME  SPECIAL-FLAG  OFFSET  SIZE  COMPRESSED-SIZE}
+**
+*/
+static int ZvfsDumpObjCmd(
+  void *NotUsed,             /* Client data for this command */
+  Tcl_Interp *interp,        /* The interpreter used to report errors */
+  int objc,                  /* Number of arguments */
+  Tcl_Obj *const* objv       /* Values of all arguments */
+){
+  char *zFilename;
+  Tcl_Channel chan;
+  ZFile *pList;
+  int rc,zipstart;
+  Tcl_Obj *pResult;
+
+  if( objc!=2 ){
+    Tcl_WrongNumArgs(interp, 1, objv, "FILENAME");
+    return TCL_ERROR;
+  }
+  zFilename = Tcl_GetString(objv[1]);
+  chan = Tcl_OpenFileChannel(interp, zFilename, "r", 0);
+  if( chan==0 ) return TCL_ERROR;
+  rc = ZvfsReadTOCStart(interp, chan, &pList,&zipstart);
+  if( rc==TCL_ERROR ){
+    deleteZFileList(pList);
+    return rc;
+  }
+  Tcl_Close(interp, chan);
+  pResult = Tcl_GetObjResult(interp);
+  while( pList ){
+    Tcl_Obj *pEntry = Tcl_NewObj();
+    ZFile *pNext;
+    char zDateTime[100];
+    Tcl_ListObjAppendElement(interp, pEntry, Tcl_NewStringObj(pList->zName,-1));
+    translateDosTimeDate(zDateTime, pList->dosDate, pList->dosTime);
+    Tcl_ListObjAppendElement(interp, pEntry, Tcl_NewStringObj(zDateTime, -1));
+    Tcl_ListObjAppendElement(interp, pEntry, Tcl_NewIntObj(pList->isSpecial));
+    Tcl_ListObjAppendElement(interp, pEntry, Tcl_NewIntObj(pList->iOffset));
+    Tcl_ListObjAppendElement(interp, pEntry, Tcl_NewIntObj(pList->nByte));
+    Tcl_ListObjAppendElement(interp, pEntry, Tcl_NewIntObj(pList->nByteCompr));
+    Tcl_ListObjAppendElement(interp, pResult, pEntry);
+    pNext = pList->pNext;
+    Tcl_Free((char*)pList);
+    pList = pList->pNext;
+  }
+  return TCL_OK;
+}
+
+/*
+** Write a file record into a ZIP archive at the current position of
+** the write cursor for channel "chan".  Add a ZFile record for the file
+** to *ppList.  If an error occurs, leave an error message on interp
+** and return TCL_ERROR.  Otherwise return TCL_OK.
+*/
+static int writeFile(
+  Tcl_Interp *interp,     /* Leave an error message here */
+  Tcl_Channel out,        /* Write the file here */
+  Tcl_Channel in,         /* Read data from this file */
+  char *zSrc,             /* Name the new ZIP file entry this */
+  char *zDest,            /* Name the new ZIP file entry this */
+  ZFile **ppList          /* Put a ZFile struct for the new file here */
+){
+  z_stream stream;
+  ZFile *p;
+  int iEndOfData;
+  int nameLen;
+  int skip;
+  int toOut;
+  char zHdr[30];
+  char zInBuf[100000];
+  char zOutBuf[100000];
+  struct tm *tm;
+  time_t now;
+  struct stat stat;
+
+  /* Create a new ZFile structure for this file.
+   * TODO: fill in date/time etc.
+  */
+  nameLen = strlen(zDest);
+  p = newZFile(nameLen, ppList);
+  strcpy(p->zName, zDest);
+  p->isSpecial = 0;
+  Tcl_Stat(zSrc, &stat);
+  now=stat.st_mtime;
+  tm = localtime(&now);
+  UnixTimeDate(tm, &p->dosDate, &p->dosTime);
+  p->iOffset = Tcl_Tell(out);
+  p->nByte = 0;
+  p->nByteCompr = 0;
+  p->nExtra = 0;
+  p->iCRC = 0;
+  p->permissions = stat.st_mode;
+
+  /* Fill in as much of the header as we know.
+  */
+  put32(&zHdr[0], 0x04034b50);
+  put16(&zHdr[4], 0x0014);
+  put16(&zHdr[6], 0);
+  put16(&zHdr[8], 8);
+  put16(&zHdr[10], p->dosTime);
+  put16(&zHdr[12], p->dosDate);
+  put16(&zHdr[26], nameLen);
+  put16(&zHdr[28], 0);
+
+  /* Write the header and filename.
+  */
+  Tcl_Write(out, zHdr, 30);
+  Tcl_Write(out, zDest, nameLen);
+
+  /* The first two bytes that come out of the deflate compressor are
+  ** some kind of header that ZIP does not use.  So skip the first two
+  ** output bytes.
+  */
+  skip = 2;
+
+  /* Write the compressed file.  Compute the CRC as we progress.
+  */
+  stream.zalloc = (alloc_func)0;
+  stream.zfree = (free_func)0;
+  stream.opaque = 0;
+  stream.avail_in = 0;
+  stream.next_in = zInBuf;
+  stream.avail_out = sizeof(zOutBuf);
+  stream.next_out = zOutBuf;
+#if 1
+  deflateInit(&stream, 9);
+#else
+  {
+    int i, err, WSIZE = 0x8000, windowBits, level=6;
+    for (i = ((unsigned)WSIZE), windowBits = 0; i != 1; i >>= 1, ++windowBits);
+    err = deflateInit2(&stream, level, Z_DEFLATED, -windowBits, 8, 0);
+
+  }
+#endif
+  p->iCRC = crc32(0, 0, 0);
+  while( !Tcl_Eof(in) ){
+    if( stream.avail_in==0 ){
+      int amt = Tcl_Read(in, zInBuf, sizeof(zInBuf));
+      if( amt<=0 ) break;
+      p->iCRC = crc32(p->iCRC, zInBuf, amt);
+      stream.avail_in = amt;
+      stream.next_in = zInBuf;
+    }
+    deflate(&stream, 0);
+    toOut = sizeof(zOutBuf) - stream.avail_out;
+    if( toOut>skip ){
+      Tcl_Write(out, &zOutBuf[skip], toOut - skip);
+      skip = 0;
+    }else{
+      skip -= toOut;
+    }
+    stream.avail_out = sizeof(zOutBuf);
+    stream.next_out = zOutBuf;
+  }
+  do{
+    stream.avail_out = sizeof(zOutBuf);
+    stream.next_out = zOutBuf;
+    deflate(&stream, Z_FINISH);
+    toOut = sizeof(zOutBuf) - stream.avail_out;
+    if( toOut>skip ){
+      Tcl_Write(out, &zOutBuf[skip], toOut - skip);
+      skip = 0;
+    }else{
+      skip -= toOut;
+    }
+  }while( stream.avail_out==0 );
+  p->nByte = stream.total_in;
+  p->nByteCompr = stream.total_out - 2;
+  deflateEnd(&stream);
+  Tcl_Flush(out);
+
+  /* Remember were we are in the file.  Then go back and write the
+  ** header, now that we know the compressed file size.
+  */
+  iEndOfData = Tcl_Tell(out);
+  Tcl_Seek(out, p->iOffset, SEEK_SET);
+  put32(&zHdr[14], p->iCRC);
+  put32(&zHdr[18], p->nByteCompr);
+  put32(&zHdr[22], p->nByte);
+  Tcl_Write(out, zHdr, 30);
+  Tcl_Seek(out, iEndOfData, SEEK_SET);
+
+  /* Close the input file.
+  */
+  Tcl_Close(interp, in);
+
+  /* Finished!
+  */
+  return TCL_OK;
+}
+
+/*
+** The arguments are two lists of ZFile structures sorted by iOffset.
+** Either or both list may be empty.  This routine merges the two
+** lists together into a single sorted list and returns a pointer
+** to the head of the unified list.
+**
+** This is part of the merge-sort algorithm.
+*/
+static ZFile *mergeZFiles(ZFile *pLeft, ZFile *pRight){
+  ZFile fakeHead;
+  ZFile *pTail;
+
+  pTail = &fakeHead;
+  while( pLeft && pRight ){
+    ZFile *p;
+    if( pLeft->iOffset <= pRight->iOffset ){
+      p = pLeft;
+      pLeft = p->pNext;
+    }else{
+      p = pRight;
+      pRight = p->pNext;
+    }
+    pTail->pNext = p;
+    pTail = p;
+  }
+  if( pLeft ){
+    pTail->pNext = pLeft;
+  }else if( pRight ){
+    pTail->pNext = pRight;
+  }else{
+    pTail->pNext = 0;
+  }
+  return fakeHead.pNext;
+}
+
+/*
+** Sort a ZFile list so in accending order by iOffset.
+*/
+static ZFile *sortZFiles(ZFile *pList){
+# define NBIN 30
+  int i;
+  ZFile *p;
+  ZFile *aBin[NBIN+1];
+
+  for(i=0; i<=NBIN; i++) aBin[i] = 0;
+  while( pList ){
+    p = pList;
+    pList = p->pNext;
+    p->pNext = 0;
+    for(i=0; i<NBIN && aBin[i]; i++){
+      p = mergeZFiles(aBin[i],p);
+      aBin[i] = 0;
+    }
+    aBin[i] = aBin[i] ? mergeZFiles(aBin[i], p) : p;
+  }
+  p = 0;
+  for(i=0; i<=NBIN; i++){
+    if( aBin[i]==0 ) continue;
+    p = mergeZFiles(p, aBin[i]);
+  }
+  return p;
+}
+
+/*
+** Write a ZIP archive table of contents to the given
+** channel.
+*/
+static void writeTOC(Tcl_Channel chan, ZFile *pList){
+  int iTocStart, iTocEnd;
+  int nEntry = 0;
+  int i;
+  char zBuf[100];
+
+  iTocStart = Tcl_Tell(chan);
+  for(; pList; pList=pList->pNext){
+    if( pList->isSpecial ) continue;
+    put32(&zBuf[0], 0x02014b50);
+    put16(&zBuf[4], 0x0317);
+    put16(&zBuf[6], 0x0014);
+    put16(&zBuf[8], 0);
+    put16(&zBuf[10], pList->nByte>pList->nByteCompr ? 0x0008 : 0x0000);
+    put16(&zBuf[12], pList->dosTime);
+    put16(&zBuf[14], pList->dosDate);
+    put32(&zBuf[16], pList->iCRC);
+    put32(&zBuf[20], pList->nByteCompr);
+    put32(&zBuf[24], pList->nByte);
+    put16(&zBuf[28], strlen(pList->zName));
+    put16(&zBuf[30], 0);
+    put16(&zBuf[32], pList->nExtra);
+    put16(&zBuf[34], 1);
+    put16(&zBuf[36], 0);
+    put32(&zBuf[38], pList->permissions<<16);
+    put32(&zBuf[42], pList->iOffset);
+    Tcl_Write(chan, zBuf, 46);
+    Tcl_Write(chan, pList->zName, strlen(pList->zName));
+    for(i=pList->nExtra; i>0; i-=40){
+      int toWrite = i<40 ? i : 40;
+      Tcl_Write(chan,"                                             ",toWrite);
+    }
+    nEntry++;
+  }
+  iTocEnd = Tcl_Tell(chan);
+  put32(&zBuf[0], 0x06054b50);
+  put16(&zBuf[4], 0);
+  put16(&zBuf[6], 0);
+  put16(&zBuf[8], nEntry);
+  put16(&zBuf[10], nEntry);
+  put32(&zBuf[12], iTocEnd - iTocStart);
+  put32(&zBuf[16], iTocStart);
+  put16(&zBuf[20], 0);
+  Tcl_Write(chan, zBuf, 22);
+  Tcl_Flush(chan);
+}
+
+
+/*
+** Implementation of the zvfs::append command.
+**
+**    zvfs::append ARCHIVE (SOURCE DESTINATION)*
+**
+** This command reads SOURCE files and appends them (using the name
+** DESTINATION) to the zip archive named ARCHIVE.  A new zip archive
+** is created if it does not already exist.  If ARCHIVE refers to a
+** file which exists but is not a zip archive, then this command
+** turns ARCHIVE into a zip archive by appending the necessary
+** records and the table of contents.  Treat all files as binary.
+**
+** Note: No dup checking is done, so multiple occurances of the
+** same file is allowed.
+*/
+static int ZvfsAppendObjCmd(
+  void *NotUsed,             /* Client data for this command */
+  Tcl_Interp *interp,        /* The interpreter used to report errors */
+  int objc,                  /* Number of arguments */
+  Tcl_Obj *const* objv       /* Values of all arguments */
+){
+  char *zArchive;
+  Tcl_Channel chan;
+  ZFile *pList = NULL, *pToc;
+  int rc = TCL_OK, i,zipstart;
+
+  /* Open the archive and read the table of contents
+  */
+  if( objc<2 || (objc&1)!=0 ){
+    Tcl_WrongNumArgs(interp, 1, objv, "ARCHIVE (SRC DEST)+");
+    return TCL_ERROR;
+  }
+
+  zArchive = Tcl_GetString(objv[1]);
+  chan = Tcl_OpenFileChannel(interp, zArchive, "r+", 0644);
+  if( chan==0 ) {
+    chan = Tcl_OpenFileChannel(interp, zArchive, "w+", 0644);
+  }
+  if( chan==0 ) return TCL_ERROR;
+  if(  Tcl_SetChannelOption(interp, chan, "-translation", "binary")
+	  || Tcl_SetChannelOption(interp, chan, "-encoding", "binary")
+    ){
+      /* this should never happen */
+      Tcl_Close(0, chan);
+      return TCL_ERROR;
+  }
+
+  if (Tcl_Seek(chan, 0, SEEK_END) == 0) {
+      /* Null file is ok, we're creating new one. */
+  } else {
+    Tcl_Seek(chan, 0, SEEK_SET);
+    rc = ZvfsReadTOCStart(interp, chan, &pList,&zipstart);
+    if( rc==TCL_ERROR ){
+      deleteZFileList(pList);
+      Tcl_Close(interp, chan);
+      return rc;
+    } else rc=TCL_OK;
+  }
+
+  /* Move the file pointer to the start of
+  ** the table of contents.
+  */
+  for(pToc=pList; pToc; pToc=pToc->pNext){
+    if( pToc->isSpecial && strcmp(pToc->zName,"*TOC*")==0 ) break;
+  }
+  if( pToc ){
+    Tcl_Seek(chan, pToc->iOffset, SEEK_SET);
+  }else{
+    Tcl_Seek(chan, 0, SEEK_END);
+  }
+
+  /* Add new files to the end of the archive.
+  */
+  for(i=2; rc==TCL_OK && i<objc; i+=2){
+    char *zSrc = Tcl_GetString(objv[i]);
+    char *zDest = Tcl_GetString(objv[i+1]);
+    Tcl_Channel in;
+    /* Open the file that is to be added to the ZIP archive
+     */
+    in = Tcl_OpenFileChannel(interp, zSrc, "r", 0);
+    if( in==0 ){
+      break;
+    }
+    if(  Tcl_SetChannelOption(interp, in, "-translation", "binary")
+	  || Tcl_SetChannelOption(interp, in, "-encoding", "binary")
+      ){
+        /* this should never happen */
+        Tcl_Close(0, in);
+	rc = TCL_ERROR;
+        break;
+    }
+
+    rc = writeFile(interp, chan, in, zSrc, zDest, &pList);
+  }
+
+  /* Write the table of contents at the end of the archive.
+  */
+  if (rc == TCL_OK) {
+    pList = sortZFiles(pList);
+    writeTOC(chan, pList);
+  }
+
+  /* Close the channel and exit */
+  deleteZFileList(pList);
+  Tcl_Close(interp, chan);
+  return rc;
+}
+
+static CONST char *
+GetExtension( CONST char *name)
+{
+    CONST char *p, *lastSep;
+#ifdef __WIN32__
+    lastSep = NULL;
+    for (p = name; *p != '\0'; p++) {
+	if (strchr("/\\:", *p) != NULL) {
+	    lastSep = p;
+	}
+    }
+#else
+    lastSep = strrchr(name, '/');
+#endif
+    p = strrchr(name, '.');
+    if ((p != NULL) && (lastSep != NULL) && (lastSep > p)) {
+	p = NULL;
+    }
+    return p;
+}
+
+/*
+** Implementation of the zvfs::add command.
+**
+**    zvfs::add ?-fconfigure optpairs? ARCHIVE FILE1 FILE2 ... 
+**
+** This command is similar to append in that it adds files to the zip
+** archive named ARCHIVE, however file names are relative the current directory.
+** In addition, fconfigure is used to apply  option pairs to set upon opening
+** of each file.  Otherwise, default translation is allowed
+** for those file extensions listed in the ::zvfs::auto_ext var.
+** Binary translation will be used for unknown extensions.
+**
+** NOTE Use '-fconfigure {}' to use auto translation for all.
+*/
+static int ZvfsAddObjCmd(
+  void *NotUsed,             /* Client data for this command */
+  Tcl_Interp *interp,        /* The interpreter used to report errors */
+  int objc,                  /* Number of arguments */
+  Tcl_Obj *CONST* objv       /* Values of all arguments */
+){
+  char *zArchive;
+  Tcl_Channel chan;
+  ZFile *pList = NULL, *pToc;
+  int rc = TCL_OK, i, j, oLen;
+  char *zOpts = NULL;
+  Tcl_Obj *confOpts = NULL;
+  int tobjc;
+  Tcl_Obj **tobjv;
+  Tcl_Obj *varObj = NULL;
+  int zipstart;
+  
+  /* Open the archive and read the table of contents
+  */
+  if (objc>3) {
+      zOpts =  Tcl_GetStringFromObj(objv[1], &oLen);
+      if (!strncmp("-fconfigure", zOpts, oLen)) {
+	  confOpts = objv[2];
+          if (TCL_OK != Tcl_ListObjGetElements(interp, confOpts, &tobjc, &tobjv) || (tobjc%2)) {
+	    return TCL_ERROR;
+	  }
+	  objc -= 2;
+	  objv += 2;
+      }
+  }
+  if( objc==2) {
+      return TCL_OK;
+  }
+
+  if( objc<3) {
+    Tcl_WrongNumArgs(interp, 1, objv, "?-fconfigure OPTPAIRS? ARCHIVE FILE1 FILE2 ..");
+    return TCL_ERROR;
+  }
+  zArchive = Tcl_GetString(objv[1]);
+  chan = Tcl_OpenFileChannel(interp, zArchive, "r+", 0644);
+  if( chan==0 ) {
+    chan = Tcl_OpenFileChannel(interp, zArchive, "w+", 0644);
+  }
+  if( chan==0 ) return TCL_ERROR;
+  if(  Tcl_SetChannelOption(interp, chan, "-translation", "binary")
+	  || Tcl_SetChannelOption(interp, chan, "-encoding", "binary")
+    ){
+      /* this should never happen */
+      Tcl_Close(0, chan);
+      return TCL_ERROR;
+  }
+
+  if (Tcl_Seek(chan, 0, SEEK_END) == 0) {
+      /* Null file is ok, we're creating new one. */
+  } else {
+    Tcl_Seek(chan, 0, SEEK_SET);
+    rc = ZvfsReadTOCStart(interp, chan, &pList,&zipstart);
+    if( rc==TCL_ERROR ){
+      deleteZFileList(pList);
+      Tcl_Close(interp, chan);
+      return rc;
+    } else rc=TCL_OK;
+  }
+
+  /* Move the file pointer to the start of
+  ** the table of contents.
+  */
+  for(pToc=pList; pToc; pToc=pToc->pNext){
+    if( pToc->isSpecial && strcmp(pToc->zName,"*TOC*")==0 ) break;
+  }
+  if( pToc ){
+    Tcl_Seek(chan, pToc->iOffset, SEEK_SET);
+  }else{
+    Tcl_Seek(chan, 0, SEEK_END);
+  }
+
+  /* Add new files to the end of the archive.
+  */
+  for(i=2; rc==TCL_OK && i<objc; i++){
+    char *zSrc = Tcl_GetString(objv[i]);
+    Tcl_Channel in;
+    /* Open the file that is to be added to the ZIP archive
+     */
+    in = Tcl_OpenFileChannel(interp, zSrc, "r", 0);
+    if( in==0 ){
+      break;
+    }
+    if (confOpts == NULL) {
+	CONST char *ext = GetExtension(zSrc);
+	if (ext != NULL) {
+	    /* Use auto translation for known text files. */
+	    if (varObj == NULL) {
+	        varObj=Tcl_GetVar2Ex(interp, "::zvfs::auto_ext", NULL, TCL_GLOBAL_ONLY);
+	    }
+	    if (varObj && TCL_OK != Tcl_ListObjGetElements(interp, varObj, &tobjc, &tobjv)) {
+		for (j=0; j<tobjc; j++) {
+		    if (!strcmp(ext, Tcl_GetString(tobjv[j]))) {
+		       break;
+		    }	       
+		}
+		if (j>=tobjc) {
+		       ext = NULL;
+		}
+
+	    }
+	}
+	if (ext == NULL) {
+	   if (( Tcl_SetChannelOption(interp, in, "-translation", "binary")
+		|| Tcl_SetChannelOption(interp, in, "-encoding", "binary"))
+	  ) {
+	    /* this should never happen */
+	    Tcl_Close(0, in);
+	    rc = TCL_ERROR;
+	    break;
+	  }
+	}
+    } else {
+	for (j=0; j<tobjc; j+=2) {
+	  if (Tcl_SetChannelOption(interp, in, Tcl_GetString(tobjv[j]), Tcl_GetString(tobjv[j+1]))) {
+	    Tcl_Close(0, in);
+	    rc = TCL_ERROR;
+	    break;
+	  }
+	}
+
+    }
+    if (rc == TCL_OK)
+	rc = writeFile(interp, chan, in, zSrc, zSrc, &pList);
+  }
+
+  /* Write the table of contents at the end of the archive.
+  */
+  if (rc == TCL_OK) {
+      pList = sortZFiles(pList);
+      writeTOC(chan, pList);
+  }
+
+  /* Close the channel and exit */
+  deleteZFileList(pList);
+  Tcl_Close(interp, chan);
+  return rc;
+}
+
+/*
+** Implementation of the zvfs::start command.
+**
+**    zvfs::start ARCHIVE
+**
+** This command strips returns the offset of zip data.
+**
+*/
+static int ZvfsStartObjCmd(
+void *NotUsed,             /* Client data for this command */
+Tcl_Interp *interp,        /* The interpreter used to report errors */
+int objc,                  /* Number of arguments */
+Tcl_Obj *CONST* objv       /* Values of all arguments */
+) {
+    char *zArchive;
+    Tcl_Channel chan;
+    ZFile *pList = NULL, *pToc;
+    int rc = TCL_OK, i, j, oLen;
+    char *zOpts = NULL;
+    Tcl_Obj *confOpts = NULL;
+    int tobjc;
+    Tcl_Obj **tobjv;
+    Tcl_Obj *varObj = NULL;
+    int zipStart;
+
+    /* Open the archive and read the table of contents
+    */
+    if( objc != 2) {
+        Tcl_WrongNumArgs(interp, 1, objv, "ARCHIVE");
+        return TCL_ERROR;
+    }
+    zArchive = Tcl_GetString(objv[1]);
+    chan = Tcl_OpenFileChannel(interp, zArchive, "r", 0644);
+    if( chan==0 ) return TCL_ERROR;
+    if(  Tcl_SetChannelOption(interp, chan, "-translation", "binary")
+    || Tcl_SetChannelOption(interp, chan, "-encoding", "binary")
+    ){
+        /* this should never happen */
+        Tcl_Close(0, chan);
+        return TCL_ERROR;
+    }
+
+    if (Tcl_Seek(chan, 0, SEEK_END) == 0) {
+        Tcl_SetObjResult(interp, Tcl_NewIntObj(0));
+        return TCL_OK;
+    } else {
+        Tcl_Seek(chan, 0, SEEK_SET);
+        rc = ZvfsReadTOCStart(interp, chan, &pList, &zipStart);
+        if( rc!=TCL_OK ){
+            deleteZFileList(pList);
+            Tcl_Close(interp, chan);
+            Tcl_AppendResult(interp, "not an archive", 0);
+            return TCL_ERROR;
+        }
+    }
+
+    /* Close the channel and exit */
+    deleteZFileList(pList);
+    Tcl_Close(interp, chan);
+    Tcl_SetObjResult(interp, Tcl_NewIntObj(zipStart));
+    return TCL_OK;
+}
+
+
+int ZvfsTools_Init(Tcl_Interp *interp){
+#ifdef USE_TCL_STUBS
+  if( Tcl_InitStubs(interp,"8.0",0)==0 ){
+    return TCL_ERROR;
+  }
+#endif
+  Tcl_CreateObjCommand(interp, "::zvfs::addlist", ZvfsAppendObjCmd, 0, 0);
+  Tcl_CreateObjCommand(interp, "::zvfs::add", ZvfsAddObjCmd, 0, 0);
+  Tcl_CreateObjCommand(interp, "::zvfs::dump", ZvfsDumpObjCmd, 0, 0);
+  Tcl_CreateObjCommand(interp, "::zvfs::start", ZvfsStartObjCmd, 0, 0);
+  Tcl_SetVar(interp, "::zvfs::auto_ext", ".tcl .tk .itcl .htcl .txt .c .h .tht", TCL_GLOBAL_ONLY);
+  Tcl_PkgProvide(interp, "zvfsctools", "1.0"); 
+  return TCL_OK;
+}
+
+int ZvfsTools_SafeInit(Tcl_Interp *interp){
+#ifdef USE_TCL_STUBS
+  if( Tcl_InitStubs(interp,"8.0",0)==0 ){
+    return TCL_ERROR;
+  }
+#endif
+  Tcl_SetVar(interp, "::zvfs::auto_ext", ".tcl .tk .itcl .htcl .txt .c .h .tht", TCL_GLOBAL_ONLY);
+  Tcl_CreateObjCommand(interp, "::zvfs::dump", ZvfsDumpObjCmd, 0, 0);
+  Tcl_PkgProvide(interp, "zvfsctools", "1.0");
+
+  return TCL_OK;
+}

generic/tclZipVfs.c

@@ -160,7 +160,7 @@ static time_t DosTimeDate(int dosDate, int dosTime){
 }
 
 /* Return count of char ch in str */
-int strchrcnt(char *str, char ch) {
+static int strchrcnt(char *str, char ch) {
   int cnt=0;
   char *cp=str;
   while ((cp=strchr(cp,ch))) { cp++; cnt++; }

library/zvfstools/zvfstools.tcl

@@ -90,119 +90,6 @@ proc ::zvfs::walk {base {excludes ""} {match *} {path {}}} {
     return $result
 }
 
-# zvfs::add_file_to_archive --
-#
-#        Add a single file to a zip archive. The zipchan channel should
-#        already be open and binary. You may provide a comment for the
-#        file The return value is the central directory record that
-#        will need to be used when finalizing the zip archive.
-#
-# FIX ME: should  handle the current offset for non-seekable channels
-#
-proc ::zvfs::add_file_to_archive {zipchan base path {comment ""}} {
-    set fullpath [file join $base $path]
-    set mtime [timet_to_dos [file mtime $fullpath]]
-    if {[file isdirectory $fullpath]} {
-        append path /
-    }
-    set utfpath [encoding convertto utf-8 $path]
-    set utfcomment [encoding convertto utf-8 $comment]
-    set flags [expr {(1<<11)}] ;# utf-8 comment and path
-    set method 0               ;# store 0, deflate 8
-    set attr 0                 ;# text or binary (default binary)
-    set version 20             ;# minumum version req'd to extract
-    set extra ""
-    set crc 0
-    set size 0
-    set csize 0
-    set data ""
-    set seekable [expr {[tell $zipchan] != -1}]
-    if {[file isdirectory $fullpath]} {
-        set attrex 0x41ff0010  ;# 0o040777 (drwxrwxrwx)
-    } elseif {[file executable $fullpath]} {
-        set attrex 0x81ff0080  ;# 0o100777 (-rwxrwxrwx)
-    } else {
-        set attrex 0x81b60020  ;# 0o100666 (-rw-rw-rw-)
-        if {[file extension $fullpath] in {".tcl" ".txt" ".c"}} {
-            set attr 1         ;# text
-        }
-    }
-  
-    if {[file isfile $fullpath]} {
-        set size [file size $fullpath]
-        if {!$seekable} {set flags [expr {$flags | (1 << 3)}]}
-    }
-  
-    set offset [tell $zipchan]
-    set local [binary format a4sssiiiiss PK\03\04 \
-                   $version $flags $method $mtime $crc $csize $size \
-                   [string length $utfpath] [string length $extra]]
-    append local $utfpath $extra
-    puts -nonewline $zipchan $local
-
-    if {[file isfile $fullpath]} {
-        # If the file is under 2MB then zip in one chunk, otherwize we use
-        # streaming to avoid requiring excess memory. This helps to prevent
-        # storing re-compressed data that may be larger than the source when
-        # handling PNG or JPEG or nested ZIP files.
-        if {$size < 0x00200000} {
-            set fin [::open $fullpath rb]
-            setbinary $fin
-            set data [::read $fin]
-            set crc [::zlib crc32 $data]
-            set cdata [::zlib deflate $data]
-            if {[string length $cdata] < $size} {
-                set method 8
-                set data $cdata
-            }
-            close $fin
-            set csize [string length $data]
-            puts -nonewline $zipchan $data
-        } else {
-            set method 8
-            set fin [::open $fullpath rb]
-            setbinary $fin
-            set zlib [::zlib stream deflate]
-            while {![eof $fin]} {
-                set data [read $fin 4096]
-                set crc [zlib crc32 $data $crc]
-                $zlib put $data
-                if {[string length [set zdata [$zlib get]]]} {
-                    incr csize [string length $zdata]
-                    puts -nonewline $zipchan $zdata
-                }
-            }
-            close $fin
-            $zlib finalize
-            set zdata [$zlib get]
-            incr csize [string length $zdata]
-            puts -nonewline $zipchan $zdata
-            $zlib close
-        }
-    
-        if {$seekable} {
-            # update the header if the output is seekable
-            set local [binary format a4sssiiii PK\03\04 \
-                           $version $flags $method $mtime $crc $csize $size]
-            set current [tell $zipchan]
-            seek $zipchan $offset
-            puts -nonewline $zipchan $local
-            seek $zipchan $current
-        } else {
-            # Write a data descriptor record
-            set ddesc [binary format a4iii PK\7\8 $crc $csize $size]
-            puts -nonewline $zipchan $ddesc
-        }
-    }
-  
-    set hdr [binary format a4ssssiiiisssssii PK\01\02 0x0317 \
-                 $version $flags $method $mtime $crc $csize $size \
-                 [string length $utfpath] [string length $extra]\
-                 [string length $utfcomment] 0 $attr $attrex $offset]
-    append hdr $utfpath $extra $utfcomment
-    return $hdr
-}
-
 # zvfs::mkzip --
 #
 #        Create a zip archive in 'filename'. If a file already exists it will be
@@ -262,32 +149,25 @@ if {[file exists [file join [info script] main.tcl]] } {
   source [file join [info script] main.tcl]
 }
       }
-      append zkd \x1A
+      ::append zkd \x1A
       puts -nonewline $zf $zkd
   }
+  close $zf
 
   set count 0
   set cd ""
 
   if {$opts(-directory) ne ""} {
-      set paths [walk $opts(-directory) $opts(-exclude)]
+    set paths [walk $opts(-directory) $opts(-exclude)]
+    set zippathlist {}
+    foreach path $paths {
+      if {[file isdirectory [file join $opts(-directory) $path]]} continue
+      lappend zippathlist [file join $opts(-directory) $path] $path
+    }
+    ::zvfs::addlist $filename {*}$zippathlist
   } else {
-      set paths [glob -nocomplain {*}$args]
+    ::zvfs::add $filename {*}[glob -nocomplain {*}$args]
   }
-  foreach path $paths {
-      append cd [add_file_to_archive $zf $opts(-directory) $path]
-      incr count
-  }
-  set cdoffset [tell $zf]
-  set endrec [binary format a4ssssiis PK\05\06 0 0 \
-                  $count $count [string length $cd] $cdoffset\
-                  [string length $opts(-comment)]]
-  append endrec $opts(-comment)
-  puts -nonewline $zf $cd
-  puts -nonewline $zf $endrec
-  close $zf
-
-  return
 }
 
 ###

unix/Makefile.in

@@ -285,7 +285,7 @@ LIBS		= @TCL_LIBS@
 DEPEND_SWITCHES	= ${CFLAGS} -I${UNIX_DIR} -I${GENERIC_DIR} \
 ${AC_FLAGS} ${PROTO_FLAGS} ${EXTRA_CFLAGS} @EXTRA_CC_SWITCHES@
 
-TCLSH_OBJS = tclAppInit.o tclZipVfs.o tclZipVfsBoot.o
+TCLSH_OBJS = tclAppInit.o tclZipVfs.o tclZipVfsBoot.o tclZipTools.o
 
 TCLTEST_OBJS = tclTestInit.o tclTest.o tclTestObj.o tclTestProcBodyObj.o \
 	tclThreadTest.o tclUnixTest.o
@@ -662,14 +662,14 @@ basekit.vfs:
 	    "$(UNIX_DIR)/basekit.vfs/boot/tcl" "$(TOP_DIR)"  unix
 
 # Builds an executable directly from the Tcl sources
-${BASEKIT_EXE}: ${TCLSH_OBJS} ${OBJS} ${ZLIB_OBJS} basekit.vfs
+${BASEKIT_EXE}: ${TCLSH_OBJS} ${OBJS} ${ZLIB_OBJS} ${TCL_EXE} basekit.vfs
 
 	${CC} ${CFLAGS} ${LDFLAGS} \
 		${TCLSH_OBJS} ${OBJS} ${ZLIB_OBJS} \
 		${LIBS} @EXTRA_TCLSH_LIBS@ \
 		${CC_SEARCH_FLAGS} -o ${BASEKIT_EXE}_bare
-	@echo zipping...
-	@$(TCL_EXE) ../tools/mkzip.tcl ${BASEKIT_EXE} \
+	@echo zipping... $(TCL_EXE)
+	./$(TCL_EXE) ../tools/mkzip.tcl ${BASEKIT_EXE} \
 		-runtime ${BASEKIT_EXE}_bare \
 		-directory basekit.vfs
 	chmod a+x ${BASEKIT_EXE}	
@@ -890,6 +890,10 @@ install-libraries: libraries
 	@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;
 
+
+	@echo "Installing package zvfstools 0.1 as a Tcl Module";
+	@$(INSTALL_DATA) $(TOP_DIR)/library/zvfstools/zvfstools.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.6/zvfstools-0.1.tm;
+
 	@echo "Installing encoding files to $(SCRIPT_INSTALL_DIR)/encoding/";
 	@for i in $(TOP_DIR)/library/encoding/*.enc ; do \
 		$(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/encoding; \
@@ -1362,6 +1366,9 @@ tclZipVfs.o:  $(GENERIC_DIR)/tclZipVfs.c
 tclZipVfsBoot.o:  $(GENERIC_DIR)/tclZipVfsBoot.c
 	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclZipVfsBoot.c
 
+tclZipTools.o:  $(GENERIC_DIR)/tclZipTools.c
+	$(CC) -c $(CC_SWITCHES) $(ZLIB_INCLUDE) $(GENERIC_DIR)/tclZipTools.c
+
 tclZlib.o: $(GENERIC_DIR)/tclZlib.c
 	$(CC) -c $(CC_SWITCHES) $(ZLIB_INCLUDE) $(GENERIC_DIR)/tclZlib.c
 

unix/tclAppInit.c

@@ -43,6 +43,8 @@ MODULE_SCOPE int main(int, char **);
 MODULE_SCOPE int Tcl_Zvfs_Boot(const char *,const char *,const char *);
 MODULE_SCOPE int Zvfs_Init(Tcl_Interp *);
 MODULE_SCOPE int Zvfs_SafeInit(Tcl_Interp *);
+MODULE_SCOPE int ZvfsTools_Init(Tcl_Interp *);
+MODULE_SCOPE int ZvfsTools_SafeInit(Tcl_Interp *);
 
 /*
  * The following #if block allows you to change how Tcl finds the startup
@@ -123,6 +125,10 @@ Tcl_AppInit(
     if(Zvfs_Init(interp) == TCL_ERROR) {
 	return TCL_ERROR;
     }
+    Tcl_StaticPackage(interp, "zvfsctools", ZvfsTools_Init, ZvfsTools_SafeInit);
+    if(ZvfsTools_Init(interp) == TCL_ERROR) {
+	return TCL_ERROR;
+    }
 #ifdef TCL_XT_TEST
     if (Tclxttest_Init(interp) == TCL_ERROR) {
 	return TCL_ERROR;