Philip Quaife 30 Oct 05, I have toyed with a tcl only installer some time ago, here is the code for inflating compressed files from a zip archive.
I lifted the code from AMSN, not sure of the copyright. Check with developer before distributing.
I changed the code to take a string and return decompressed string. I also have bracketed the expr and it runs in acceptable time. Enough speed that you could use it to uncompress the zlib dll from a SXE file and then use the dll to uncompress the rest of the archive.
NEM AMSN is distributed under the GPL. See also zlib.
#
# Lifted from AMSN (http://amsn.sf.net}
#
#
proc zip/inflate { stream } {
#status_log "reading from file $stream\n"
set time [clock clicks]
zip/reset
#--- Some sort of header starts the block not zlib block header
set def ""
binary scan [zip/read $stream 20] b* zlib
if {0} {
puts "read header"
set CMF [string range $zlib 0 7]
set FLG [string range $zlib 8 15]
insLog DEBUG "CMF = $CMF\nFLG = $FLG\n" read
if { [binary format b* $CMF] != "\x78" || [string range $FLG 5 5] != 0 } {
insLog ERROR "Compression of the zlib data is in an unknown format\n" error
return -1
}
binary scan [binary format b* [string range $zlib 0 15]] S FCHECK
#status_log "FCHECK is such that CMF_FLG = $FCHECK\n" red
if { [expr {$FCHECK % 31} ] != 0 } {
#status_log "FCHECK is not a multiple of 31, corrupted data\n"
return -1
}
#--- End of header
}
set bfinal "0"# set idx 16
set idx 0
set len 160
while { $bfinal != "1" } {
set bfinal [string range $zlib $idx $idx]
incr idx
binary scan [binary format b* [string range $zlib $idx [expr {$idx + 1}]]] c btype
set idx [expr $idx + 2]
#status_log "Reading compressed block, with compression type $btype and final bloc = $bfinal\n"
if { $btype == 0 } {
if { [expr $idx % 8] != 0 } {
set idx [expr {$idx + 8 - ( $idx % 8)}]
}
binary scan [string range $zlib $idx [expr {$idx + 31}]] SS len nlen
set idx [expr {$idx + 32}]
if { [string map { "0" "1" } $bnlen] != $blen } {
#status_log "Len and NLen does not match : [string range $zlib [expr {$idx -32}] [expr {$idx - 17}]] --- [string range $zlib [expr {$idx -16}] [expr {$idx - 1}]]\nValues are $len and $nlen\n" red
return -1
} else {
binary scan [string range $zlib $idx [expr {$idx + 1}]] S len
}
#status_log "Reading uncompressed block with length $len from index $idx to [expr $idx + 3 + $len]\n"
set def "${def}[string range $zlib [expr {$idx + 4}] [expr {$idx + 3 + $len}]]"
set idx [expr {$idx + 3 + $len}]
} elseif { $btype == 3 } {
#status_log "Got reserved word 11 for compression type : error\n" error
return -1
} else {
if { $btype == 2 } {
#status_log "Got Huffman's dynamic compression block, processing\n"
#set time [clock clicks]
binary scan [binary format b* [string range $zlib $idx [expr {$idx + 4}]]] c hlit
set idx [expr {$idx + 5}]
set hlit [expr {$hlit + 257}]
binary scan [binary format b* [string range $zlib $idx [expr {$idx + 4}]]] c hdist
set idx [expr {$idx + 5}]
incr hdist
binary scan [binary format b* [string range $zlib $idx [expr {$idx + 3}]]] c hclen
set idx [expr {$idx + 4}]
set hclen [expr {$hclen + 4}]
#status_log "Got hlit = $hlit \nhdist = $hdist\nhclen = $hclen\n"
set codelengths [list 16 17 18 0 8 7 9 6 10 5 11 4 12 3 13 2 14 1 15]
for { set i 0 } { $i < [expr {$hclen * 3}] } { set i [expr {$i + 3}]} {
if { $idx > $len - 3 } {
binary scan [zip/read $stream 30] b* tmp
set zlib "[string range $zlib $idx end]$tmp"
set idx 0
set len [string length $zlib]
}
binary scan [binary format b* [string range $zlib $idx [expr {$idx + 2}]]] c clen([lindex $codelengths [expr {$i / 3}]])
set idx [expr {$idx + 3}]
}
#status_log "Read the codelengths, idx = $idx -- len = $len --- zlib = $zlib\ncodelengths = \n[array get clen]\n"
array set huffcodes [zip/createcodes [array get clen] 7 18]
#status_log "huffcodes = [array get huffcodes]\n"
#status_log "binary : [string range $zlib $idx [expr $idx + 100]]\n\n"
set inc 0
set index 0
while { $index < $hlit } {
if { $idx > $len - 7 } {
binary scan [zip/read $stream 30] b* tmp
set zlib "[string range $zlib $idx end]$tmp"
set idx 0
set len [string length $zlib]
}
set bin [string range $zlib $idx [expr {$idx + $inc}]]
if { [info exists huffcodes($bin)] } {
# #status_log "Found a length, for litteral value $index = $huffcodes($bin)\n"
set idx [expr {$idx + $inc + 1}]
if { $huffcodes($bin) < 16 } {
set litclen($index) $huffcodes($bin)
incr index
} elseif { $huffcodes($bin) == 16 } {
set tocopy $litclen([expr {$index - 1}])
binary scan [binary format b* [string range $zlib $idx [expr {$idx + 1}]]] c length
set length [expr {$length + 3}]
incr idx
incr idx
# #status_log "Copying value $tocopy into the next $length codes starting from $index\n"
for { set t 0 } { $t < $length } { incr t } {
# #status_log "Literal length $index, copied value : $tocopy\n"
set litclen($index) $tocopy
incr index
}
} elseif { $huffcodes($bin) == 17 } {
binary scan [binary format b* [string range $zlib $idx [expr {$idx + 2}]]] c length
set length [expr {$length + 3}]
set idx [expr {$idx + 3}]
# #status_log "Copying value 0 into the next $length codes starting from $index\n"
for { set t 0 } { $t < $length } { incr t } {
# #status_log "Literal length $index, copied value : 0\n"
set litclen($index) 0
incr index
}
} else {
binary scan [binary format b* [string range $zlib $idx [expr {$idx + 6}]]] c length
set length [expr {$length + 11}]
set idx [expr {$idx + 7}]
# #status_log "Copying value 0 into the next $length codes starting from $index\n"
for { set t 0 } { $t < $length } { incr t } {
# #status_log "Literal length $index, copied value : 0\n"
set litclen($index) 0
incr index
}
}
set inc 0
} else {
incr inc
if { $inc > 7 } {
#status_log "Erreur.. l'increment a depasse 7.. \ndump :\nindex = $idx - increment = $inc, index = $index, $hlit\nmemoire = [string range $zlib [expr $idx ] [expr $idx + $inc ]]\n"
return -1
}
}
}
array set litval [zip/createcodes [array get litclen] 18 $hlit]
set inc 0
set index 0
while { $index < $hdist } {
if { $idx > $len - 7 } {
binary scan [zip/read $stream 30] b* tmp
set zlib "[string range $zlib $idx end]$tmp"
set idx 0
set len [string length $zlib]
}
set bin [string range $zlib $idx [expr {$idx + $inc}]]
if { [info exists huffcodes($bin)] } {
# #status_log "Found a length, for distance value $index = $huffcodes($bin)\n"
set idx [expr {$idx + $inc + 1}]
if { $huffcodes($bin) < 16 } {
set distclen($index) $huffcodes($bin)
incr index
} elseif { $huffcodes($bin) == 16 } {
set tocopy $distclen([expr {$index - 1}])
binary scan [binary format b* [string range $zlib $idx [expr {$idx + 1}]]] c length
set length [expr {$length + 3}]
incr idx 2
# #status_log "Copying value $tocopy into the next $length codes starting from $index\n"
for { set t 0 } { $t < $length } { incr t } {
# #status_log "distance length $index, copied value : $tocopy\n"
set distclen($index) $tocopy
incr index
}
} elseif { $huffcodes($bin) == 17 } {
binary scan [binary format b* [string range $zlib $idx [expr {$idx + 2}]]] c length
set length [expr {$length + 3}]
set idx [expr {$idx + 3}]
# #status_log "Copying value 0 into the next $length codes starting from $index\n"
for { set t 0 } { $t < $length } { incr t } {
# #status_log "distance length $index, copied value : 0\n"
set distclen($index) 0
incr index
}
} else {
binary scan [binary format b* [string range $zlib $idx [expr {$idx + 6}]]] c length
set length [expr {$length + 11}]
set idx [expr {$idx + 7}]
# #status_log "Copying value 0 into the next $length codes starting from $index\n"
for { set t 0 } { $t < $length } { incr t } {
# #status_log "distance length $index, copied value : 0\n"
set distclen($index) 0
incr index
}
}
set inc 0
} else {
incr inc
if { $inc > 7 } {
#status_log "Erreur.. l'increment a depasse 7.. \ndump :\nindex = $idx - increment = $inc, index = $index, $hlit\nmemoire = [string range $zlib [expr $idx ] [expr $idx + $inc ]]\n"
return -1
}
}
}
array set distval [zip/createcodes [array get distclen] 18 $hdist]
} else {
#status_log "Got Huffman's compressed block, processing\n"
array set litval [zip/createcodes [zip/fill_length lit] 18 287]
array set distval [zip/createcodes [zip/fill_length dist] 18 32]
}
# status_log "Time for processing header: expr [clock clicks - $time]\n"
############################################################################################################
set inc 0
set index [string length $def]
#set time [clock clicks]
for { } { 1 } { } {
if { $idx > $len - 15 } {
binary scan [zip/read $stream 30] b* tmp
set zlib "[string range $zlib $idx end]$tmp"
set idx 0
set len [string length $zlib]
}
set bin [string range $zlib $idx [expr {$idx + $inc}]]
#status_log "time for string range : [time "string range $zlib $idx [expr {$idx + $inc}]"]\n"
#status_log "Time for infoexits : [time "info exists litval($bin)"] --- bin = $bin\n"
if { [info exists litval($bin)] } {
set out $litval($bin)
#status_log "Found a length in index $index, for output = $out\n"
set idx [expr {$idx + $inc + 1}]
if { $out < 256 } {
set def "${def}[binary format c $out]"
incr index
#status_log "Time for literal value : [expr [clock clicks] - $time]\n"
} elseif { $out == 256 } {
#status_log "FOUND END OF BLOCK\n" red
break
} else {
#status_log "Need to move backward distance $out -- processing\n"
#set time [clock clicks]
if { $idx > $len - 5 } {
binary scan [zip/read $stream 30] b* tmp
set zlib "[string range $zlib $idx end]$tmp"
set idx 0
set len [string length $zlib]
}
if { $out < 265 } {
set plus 0
set length [expr {$out - 254}]
} elseif { $out == 285 } {
set plus 0
set length 258
} elseif { $out > 264 && $out < 269 } {
binary scan [binary format b* [string range $zlib $idx $idx]] c plus
incr idx
set length [expr {(($out - 265) * 2) + $plus + 11}]
} elseif { $out > 268 && $out < 273} {
binary scan [binary format b* [string range $zlib $idx [expr {$idx + 1}]]] c plus
incr idx 2
set length [expr {(($out - 269) * 4) + $plus + 19}]
} elseif { $out > 272 && $out < 277 } {
binary scan [binary format b* [string range $zlib $idx [expr {$idx + 2}]]] c plus
set idx [expr {$idx + 3}]
set length [expr {(($out - 273) * 8) + $plus + 35}]
} elseif { $out > 276 && $out < 281 } {
binary scan [binary format b* [string range $zlib $idx [expr {$idx + 3}]]] c plus
set idx [expr {$idx + 4}]
set length [expr {(($out - 277) * 16) + $plus + 67}]
} else {
binary scan [binary format b* [string range $zlib $idx [expr {$idx + 4}]]] c plus
set idx [expr {$idx + 5}]
set length [expr {(($out - 281) * 32) + $plus + 131}]
}
#status_log "time for ifelses : [expr [clock clicks] - $time]"
#status_log "Found length $length with added $plus\n"
set out2 -1
set inc2 0
while { $out2 == -1 } {
if { $idx > $len - 15 } {
binary scan [zip/read $stream 30] b* tmp
set zlib "[string range $zlib $idx end]$tmp"
set idx 0
set len [string length $zlib]
}
set bin [string range $zlib $idx [expr {$idx + $inc2}]]
if { [info exists distval($bin)] } {
set out2 $distval($bin)
#status_log "Found a distance code $out2\n"
set idx [expr {$idx + $inc2 + 1}]
} else {
incr inc2
if { $inc2 > 15 } {
#status_log "Erreur.. l'increment a depasse 15.. \ndump :\nindex = $idx - increment = $inc2, index = $index, $hlit\nmemoire = [string range $zlib [expr $idx ] [expr $idx + $inc2 ]]\n"
return -1
}
}
}
if { $idx > $len - 13 } {
binary scan [zip/read $stream 30] b* tmp
set zlib "[string range $zlib $idx end]$tmp"
set idx 0
set len [string length $zlib]
}
if { $out2 < 4 } {
set plus 0
set distance [expr {$out2 + 1}]
} elseif { $out2 == 4 || $out2 == 5} {
binary scan [binary format b* [string range $zlib $idx $idx]] c plus
set plus [expr $plus % 256]
incr idx
set distance [expr {(($out2 - 4) * 2) + $plus + 5}]
} elseif { $out2 == 6 || $out2 == 7} {
binary scan [binary format b* [string range $zlib $idx [expr {$idx + 1}]]] c plus
set plus [expr {$plus % 256}]
incr idx 2
set distance [expr {(($out2 - 6) * 4) + $plus + 9}]
} elseif { $out2 == 8 || $out2 == 9 } {
binary scan [binary format b* [string range $zlib $idx [expr {$idx + 2}]]] c plus
set plus [expr {$plus % 256}]
set idx [expr {$idx + 3}]
set distance [expr {(($out2 - 8) * 8) + $plus + 17}]
} elseif { $out2 == 10 || $out2 == 11} {
binary scan [binary format b* [string range $zlib $idx [expr {$idx + 3}]]] c plus
set plus [expr {$plus % 256}]
set idx [expr {$idx + 4}]
set distance [expr {(($out2 - 10) * 16) + $plus + 33}]
} elseif {$out2 == 12 || $out2 == 13 } {
binary scan [binary format b* [string range $zlib $idx [expr {$idx + 4}]]] c plus
set plus [expr {$plus % 256}]
set idx [expr {$idx + 5}]
set distance [expr {(($out2 - 12) * 32) + $plus + 65}]
} elseif {$out2 == 14 || $out2 == 15 } {
binary scan [binary format b* [string range $zlib $idx [expr {$idx + 5}]]] c plus
set plus [expr {$plus % 256}]
set idx [expr {$idx + 6}]
set distance [expr {(($out2 - 14) * 64) + $plus + 129}]
} elseif {$out2 == 16 || $out2 == 17 } {
binary scan [binary format b* [string range $zlib $idx [expr {$idx + 6}]]] c plus
set plus [expr {$plus % 256}]
set idx [expr {$idx + 7}]
set distance [expr {(($out2 - 16) * 128) + $plus + 257}]
} elseif {$out2 == 18 || $out2 == 19 } {
binary scan [binary format b* [string range $zlib $idx [expr {$idx + 7}]]] c plus
set plus [expr {$plus % 256}]
set idx [expr {$idx + 8}]
set distance [expr {(($out2 - 18) * 256) + $plus + 513}]
} elseif {$out2 == 20 || $out2 == 21 } {
binary scan [binary format b* [string range $zlib $idx [expr {$idx + 8}]]] s plus
set plus [expr {$plus % 65536}]
set idx [expr {$idx + 9}]
set distance [expr {(($out2 - 20) * 512) + $plus + 1025}]
} elseif {$out2 == 22 || $out2 == 23 } {
binary scan [binary format b* [string range $zlib $idx [expr {$idx + 9}]]] s plus
set plus [expr {$plus % 65536}]
set idx [expr {$idx + 10}]
set distance [expr {(($out2 - 22) * 1024) + $plus + 2049}]
} elseif {$out2 == 24 || $out2 == 25 } {
binary scan [binary format b* [string range $zlib $idx [expr {$idx + 10}]]] s plus
set plus [expr {$plus % 65536}]
set idx [expr {$idx + 11}]
set distance [expr {(($out2 - 24) * 2048) + $plus + 4097}]
} elseif {$out2 == 26 || $out2 == 27 } {
binary scan [binary format b* [string range $zlib $idx [expr {$idx + 11}]]] s plus
set plus [expr {$plus % 65536}]
set idx [expr {$idx + 12}]
set distance [expr {(($out2 - 26) * 4096) + $plus + 8193}]
} elseif {$out2 == 28 || $out2 == 29 } {
binary scan [binary format b* [string range $zlib $idx [expr {$idx + 12}]]] s plus
set plus [expr {$plus % 65536}]
set idx [expr {$idx + 13}]
set distance [expr {(($out2 - 28) * 8192) + $plus + 16385}]
}
# #status_log "Found distance $distance with added $plus\n"
set tocopy [string range $def [expr {$index - $distance}] $index]
while { [string length $tocopy] <= $length } {
set tocopy "${tocopy}${tocopy}"
}
set tocopy [string range $tocopy 0 [expr {$length -1}]]
set def "${def}$tocopy"
set index [expr {$index + $length}]
#status_log "Time for distance : [expr [clock clicks] - $time]\n"
}
set inc 0# set time clock clicks
} else {
incr inc
}
}
}
}
#status_log "Finished reading and uncompressing zlib blocks of data\n" blue
#status_log "Time for zlib: [expr [clock clicks] - $time]\n"
return $def
}
proc zip/createcodes { oclen maxbits maxcode } {
array set clen $oclen
# set clen [list 3 3 3 3 3 2 4 4]
foreach c [array names clen] {
if {[info exists bl_count($clen($c))] } {
incr bl_count($clen($c))
} else {
set bl_count($clen($c)) 1
}
}
set code 0
set bl_count(0) 0;
#status_log "bl_cout = [array get bl_count]\n"
for { set bits 1 } { $bits <= $maxbits } {incr bits} {
if { ![info exists bl_count([expr {$bits - 1}])] } {
set bl_count([expr {$bits - 1}]) 0
}
set code [expr {($code + $bl_count([expr $bits - 1])) << 1}];
set next_code($bits) $code;
}
#status_log "code = $code\nnext_code = [array get next_code]\n"
for {set n 0} { $n <= $maxcode} {incr n} {
if { [info exists clen($n)]} {
set len $clen($n)
} else {
set len 0
}
if { $len != 0} {
binary scan [binary format s $next_code($len)] b$len bin
# #status_log "$len = $next_code($len) = $bin = [zip/invert $bin]\n"
set bin [zip/invert $bin]
set codes($bin) $n
incr next_code($len)
}
}
return [array get codes]
}
proc zip/invert { bin } {
set out ""
for { set i [expr {[string length $bin] - 1}] } { $i >= 0 } { incr i -1} {
set out "$out[string index $bin $i]"
}
return $out
}
proc zip/fill_length { type } {
set out ""
switch $type {
"lit" {
for { set i 0 } { $i <= 287 } { incr i } {
if { $i <= 143 } {
set out "$out $i 8"
} elseif { $i <= 255 } {
set out "$out $i 9"
} elseif { $i <= 279 } {
set out "$out $i 7"
} else {
set out "$out $i 8"
}
}
}
"dist" {
for { set i 0 } { $i <= 31} { incr i } {
set out "$out $i 5"
}
}
}
return $out
}
variable zip/tell 0
proc zip/reset {} {variable zip/tell ; set zip/tell 0}
proc zip/read {stream cnt} {
variable zip/tell
set ret [string range $stream ${zip/tell} [expr {${zip/tell} + $cnt -1}]]
if {${zip/tell} > [string length $stream]} {
insLog ERROR zip/read past end of file at ${zip/tell} ([string length $stream])
#error "EOF"
}
incr zip/tell $cnt
set ret
}
package provide tclzlib 0.1