1# mkzipkit.tcl -
2#
3#	Convert a zip archive into a Tcl Module or zipkit file
4#	by adding a SFX header that can enable TclKit to mount
5#	the archive. This provides an alternative to Metakit-based
6#	starkits.
7#
8# Copyright (c) 2004 Pascal Scheffers
9# Copyright (c) 2006-2008 Pat Thoyts <patthoyts@users.sourceforge.net>
10
11# The default module prefix
12variable SFX_STUB [format {#!/bin/sh
13# %c
14exec tclsh "$0" ${1+"$@"}
15# This is a zip-based Tcl Module
16package require vfs::zip
17vfs::zip::Mount [info script] [info script]
18if {[file exists [file join [info script] main.tcl]]} {
19    source [file join [info script] main.tcl]
20}
21} 0x5C]
22
23# mkzipkit --
24#
25#	Prefixes the specified zip archive with the tclmodule mount stub
26#	and writes out to outfile
27#
28proc mkzipkit { zipfile outfile {stubfile {}}} {
29    variable SFX_STUB
30    if {$stubfile eq {}} {
31        set stub $SFX_STUB
32    } else {
33        set f [open $stubfile r]
34        fconfigure $f -translation binary -encoding binary -eofchar {}
35        set stub [read $f]
36        close $f
37    }
38    append stub \x1A
39    make_sfx $zipfile $outfile $stub
40}
41
42# make_sfx --
43#
44#	Adds an arbitrary 'sfx' to a zip file, and adjusts the central
45#	directory and file items to compensate for this extra data.
46#
47proc make_sfx { zipfile outfile sfx_stub } {
48
49    set in [open $zipfile r]
50    fconfigure $in -translation binary -encoding binary
51
52    set out [open $outfile w+]
53    fconfigure $out -translation binary -encoding binary
54
55    puts -nonewline $out $sfx_stub
56
57    set offset [tell $out]
58
59    lappend report "sfx stub size: $offset"
60
61    fcopy $in $out
62
63    set size [tell $out]
64
65    # Now seek in $out to find the end of directory signature:
66    # The structure itself is 24 bytes long, followed by a maximum of
67    # 64Kbytes text
68
69    if { $size < 65559 } {
70        set seek 0
71    } else {
72        set seek [expr { $size - 65559 } ]
73    }
74    #flush $out
75    seek $out $seek
76    #puts "$seek [tell $out]"
77
78    set data [read $out]
79    set start_of_end [string last "\x50\x4b\x05\x06" $data]
80
81    set start_of_end [expr {$start_of_end + $seek}]
82    lappend report "SEO: $start_of_end ([expr {$start_of_end-$size}])\
83        [string length $data]"
84
85    seek $out $start_of_end
86    set end_of_ctrl_dir [read $out]
87
88    binary scan $end_of_ctrl_dir issssiis \
89        eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \
90        eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) \
91        eocd(comment_len)
92
93    lappend report "End of central directory: [array get eocd]"
94
95    seek $out [expr {$start_of_end+16}]
96
97    #adjust offset of start of central directory by the length of our sfx stub
98    puts -nonewline $out [binary format i [expr {$eocd(diroffset)+$offset}]]
99    flush $out
100
101    seek $out $start_of_end
102    set end_of_ctrl_dir [read $out]
103    binary scan $end_of_ctrl_dir issssiis \
104        eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \
105        eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) \
106        eocd(comment_len)
107
108    lappend report "New dir offset: $eocd(diroffset)"
109    lappend report "Adjusting $eocd(totalnum) zip file items."
110
111    seek $out $eocd(diroffset)
112    for {set i 0} {$i <$eocd(totalnum)} {incr i} {
113        set current_file [tell $out]
114        set fileheader [read $out 46]
115        binary scan $fileheader is2sss2ii2s3ssii \
116            x(sig) x(version) x(flags) x(method) \
117            x(date) x(crc32) x(sizes) x(lengths) \
118            x(diskno) x(iattr) x(eattr) x(offset)
119
120        if { $x(sig) != 33639248 } {
121            error "Bad file header signature at item $i: $x(sig)"
122        }
123
124        foreach size $x(lengths) var {filename extrafield comment} {
125            if { $size > 0 } {
126                set x($var) [read $out $size]
127            } else {
128                set x($var) ""
129            }
130        }
131        set next_file [tell $out]
132        lappend report "file $i: $x(offset) $x(sizes) $x(filename)"
133
134        seek $out [expr {$current_file+42}]
135        puts -nonewline $out [binary format i [expr {$x(offset)+$offset}]]
136
137        # verify:
138        flush $out
139        seek $out $current_file
140        set fileheader [read $out 46]
141        lappend report "old $x(offset) + $offset"
142        binary scan $fileheader is2sss2ii2s3ssii \
143            x(sig) x(version) x(flags) x(method) \
144            x(date) x(crc32) x(sizes) x(lengths) \
145            x(diskno) x(iattr) x(eattr) x(offset)
146        lappend report "new $x(offset)"
147
148        seek $out $next_file
149    }
150    #puts [join $report \n]
151}
152
153if {[llength $argv] < 2} {
154    puts stderr "usage: $argv0 inputfile outputfile ?stubfile?"
155    exit 1
156}
157
158eval [linsert $argv 0 mkzipkit]
159