Posted to tcl by patthoyts at Fri Oct 17 12:51:26 GMT 2008view raw

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