makeziptm.cmd

RS from Tcl chatroom, 2008-10-17: Here is a Windows cmd script that allows to make a "zipkit", a ZIPped Tclkit. Pat Thoyts wrote: To make tkchat.zkit I

 cd tkchat.vfs
 zip -r ..\tkchat.zip
 cd ..
 makeziptm tkchat.zip tkchat.zkit

If you rename it .tm it can be a tcl module, for instance a tls.tm module can be built using this.

::set HEADER { -*- tcl -*-
@echo off
if "%OS%" == "Windows_NT" goto WinNT
tclsh "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
goto EOF
:WinNT
@rem this works for XP - probably not for 2k or NT
tclsh "%~f0" %*
goto EOF
}

# [make_zip_tm /zipfile/ /outfile/]
# Prefixes the specified zipfile with the tclmodule mounter stub and writes
# out 'outfile'
#
# [make_sfx_zip /zipfile/ /outfile/ /sfxstub/]
# Adds an arbitrary 'sfx' to a zip file, and adjusts the central directory
# and file items to compensate for this extra data.

proc make_zip_tm { zipfile outfile } {
    set sfx_stub {#!/usr/bin/env tclkit
# This is a zip-based Tcl Module
package require vfs::zip
vfs::zip::Mount [info script] [info script]
if {[file exists [file join [info script] main.tcl]]} {
    source [file join [info script] main.tcl]
}
    }
    append sfx_stub \x1A
    make_sfx_zip $zipfile $outfile $sfx_stub
}

proc make_sfx_zip { zipfile outfile sfx_stub } {
    
    set in [open $zipfile r]
    fconfigure $in -translation binary -encoding binary
    
    set out [open $outfile w+]
    fconfigure $out -translation binary -encoding binary
    
    puts -nonewline $out $sfx_stub
    
    set offset [tell $out]
    
    lappend report "sfx stub size: $offset"
    
    fcopy $in $out

    set size [tell $out]
    
    # Now seek in $out to find the end of directory signature:
    # The structure itself is 24 bytes long, followed by a maximum of
    # 64Kbytes text
    
    if { $size < 65559 } {
        set seek 0
    } else {
        set seek [expr { $size - 65559 } ]
    }
    #flush $out
    seek $out $seek
    #puts "$seek [tell $out]"
    
    set data [read $out]
    set start_of_end [string last "\x50\x4b\x05\x06" $data]
    
    set start_of_end [expr {$start_of_end + $seek}]
    lappend report "SEO: $start_of_end ([expr {$start_of_end-$size}])\
        [string length $data]"
    
    seek $out $start_of_end
    set end_of_ctrl_dir [read $out]
    
    binary scan $end_of_ctrl_dir issssiis \
        eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \
        eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) \
        eocd(comment_len)
    
    lappend report "End of central directory: [array get eocd]"
    
    seek $out [expr {$start_of_end+16}]
    
    #adjust offset of start of central directory by the length of our sfx stub
    puts -nonewline $out [binary format i [expr {$eocd(diroffset)+$offset}]]
    flush $out
    
    seek $out $start_of_end
    set end_of_ctrl_dir [read $out]
    binary scan $end_of_ctrl_dir issssiis \
        eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \
        eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) \
        eocd(comment_len)
    
    lappend report "New dir offset: $eocd(diroffset)"
    lappend report "Adjusting $eocd(totalnum) zip file items."
    
    seek $out $eocd(diroffset)
    for {set i 0} {$i <$eocd(totalnum)} {incr i} {
        set current_file [tell $out]
        set fileheader [read $out 46]
        binary scan $fileheader is2sss2ii2s3ssii \
            x(sig) x(version) x(flags) x(method) \
            x(date) x(crc32) x(sizes) x(lengths) \
            x(diskno) x(iattr) x(eattr) x(offset)
        
        if { $x(sig) != 33639248 } {
            error "Bad file header signature at item $i: $x(sig)"
        }
        
        foreach size $x(lengths) var {filename extrafield comment} {
            if { $size > 0 } {
                set x($var) [read $out $size]
            } else {
                set x($var) ""
            }
        }
        set next_file [tell $out]
        lappend report "file $i: $x(offset) $x(sizes) $x(filename)"
        
        seek $out [expr {$current_file+42}]
        puts -nonewline $out [binary format i [expr {$x(offset)+$offset}]]
        
        #verify:
        flush $out
        seek $out $current_file
        set fileheader [read $out 46]
        lappend report "old $x(offset) + $offset"
        binary scan $fileheader is2sss2ii2s3ssii \
            x(sig) x(version) x(flags) x(method) \
            x(date) x(crc32) x(sizes) x(lengths) \
            x(diskno) x(iattr) x(eattr) x(offset)
        lappend report "new $x(offset)"
        
        seek $out $next_file
    }
    #puts [join $report \n]
}

if {!$tcl_interactive} {
    set r [catch {eval [linsert $argv 0 make_zip_tm]} err]
    puts $err
    exit $r
}

# --- end ---
# \
:EOF

LV So, tell us about a zipkit. Will a normal tclkit run a zipkit? If the file is renamed to end in a .tm, is there thought about having package require be able to read and process the file like regular tcl script Tcl Modules?

PT zipkits can be run using tclkit or ActiveTcl. Just like a normal starkit except that you dont need metakit and its a bit less efficient than a metakit-based vfs. Using a kit or zkip as a Tcl module is just a matter of adjusting the kit startup such that when sourced the kit makes its packages available. A number of such package tclkits are already available. If they are renamed to .tm files and placed in the right location then tcl can load them (assuming the vfs support is present).


See also