Posted to tcl by patthoyts at Fri Oct 17 12:51:26 GMT 2008view raw
- ::set HEADER { -*- tcl -*-
- @echo off
- echo %~0 %~f0
- 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
- # Copyright (C) 2005 Pat Thoyts <patthoyts@users.sourceforge.net>
- 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