Version 5 of makeziptm.cmd

Updated 2008-10-17 14:46:34 by LV

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 a regular tcl script Tcl Module?