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