# Copyright Hubert Tonneau hubert.tonneau@pliant.cx # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License version 2 # as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # version 2 along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
scope "/pliant/language/stream/" module "ring.pli"
# win32 DLL provided in Win32 Pliant tarball # was picked in zlib114dll.zip on http://www.winimage.com/zLibDll/
constant zlib os_zlib_filename constant version "1.1.3" constant undocumented true
constant pliant_alloc os_api<>"win32" constant buggy true
type z_stream_s packed
field Address next_in field Int avail_in field Int total_in
field Address next_out field Int avail_out field Int total_out
field Address msg internal_state
field Address zalloc zfree opaque field Int data_type field Int adler field Int reserved
if undocumented constant Z_DEFLATED 8 constant Z_DEFAULT_STRATEGY 0
if undocumented function deflateInit2_ stream level method window mem strategy version len -> err arg_rw z_stream_s stream ; arg Int level method window mem strategy ; arg CStr version ; arg Int len err external zlib "deflateInit2_" else function deflateInit_ stream level version len -> err arg_rw z_stream_s stream ; arg Int level ; arg CStr version ; arg Int len err external zlib "deflateInit_"
if undocumented function deflateInit2 stream level method window mem strategy -> err arg_rw z_stream_s stream ; arg Int level method window mem strategy ; arg Int err err := deflateInit2_ stream level method window mem strategy version z_stream_s:size else function deflateInit stream level -> err arg_rw z_stream_s stream ; arg Int level ; arg Int err err := deflateInit_ stream level version z_stream_s:size
function deflate stream flush -> ret arg_rw z_stream_s stream ; arg Int flush ; arg Int ret external zlib "deflate"
function deflateEnd stream -> err arg_rw z_stream_s stream ; arg Int err external zlib "deflateEnd"
if undocumented function inflateInit2_ stream window version len -> err arg_rw z_stream_s stream ; arg Int window ; arg CStr version ; arg Int len err external zlib "inflateInit2_" else function inflateInit_ stream version len -> err arg_rw z_stream_s stream ; arg CStr version ; arg Int len err external zlib "inflateInit_"
if undocumented function inflateInit2 stream window -> err arg_rw z_stream_s stream ; arg Int window ; arg Int err err := inflateInit2_ stream window version z_stream_s:size else function inflateInit stream -> err arg_rw z_stream_s stream ; arg Int err err := inflateInit_ stream version z_stream_s:size
function inflate stream flush arg_rw z_stream_s stream ; arg Int flush external zlib "inflate"
function inflateReset stream arg_rw z_stream_s stream external zlib "inflateReset"
function inflateEnd stream -> err arg_rw z_stream_s stream ; arg Int err external zlib "inflateEnd"
if undocumented
type GzipHeader packed field uInt8 id1 id2 field uInt8 cm flg field uInt32_li mtime field uInt8 xfl os
gvar (Array uInt 256) crc_table function init_table for (var Int n) 0 255 var uInt c := n for (var Int k) 0 7 if (c .and. 1)<>0 c := 0EDB88320h .xor. (c\2) else c := c\2 crc_table n := c init_table
function crc32_update old_crc adr size -> new_crc arg uInt old_crc new_crc ; arg Address adr ; arg Int size var uInt c := old_crc .xor. 0FFFFFFFFh for (var Int n) 0 size-1 var uInt b := (adr translate Byte n) map uInt8 var Int u := (c .xor. b) .and. 0FFh c := crc_table:u .xor. (c\2^8) new_crc := c .xor. 0FFFFFFFFh
if undocumented
type ZipHeader field uInt32_li signature # 0 field uInt16_li version # 4 field uInt16_li flags # 6 field uInt16_li compression # 8 field uInt16_li time # 10 field uInt16_li date # 12 field uInt32_li crc # 14 field uInt32_li compressed_size # 18 field uInt32_li clear_size # 22 field uInt16_li name_length # 26 field uInt16_li extra_length # 28
type ZipTail field uInt32_li signature # 0 field uInt32_li crc # 4 field uInt32_li compressed_size # 8 field uInt32_li uncompressed_size # 12
#----------------------------------------------------------------
type CompressZlibStreamDriver field Link:Stream s field z_stream_s w field z_stream_s r field Int flags if undocumented field CBool gzip field CBool zip field CBool deflate field uInt w_crc w_size field uInt r_crc r_size field Int zip_flags <- 0 field Str name field DateTime datetime
|
field Str comment
|
StreamDriver maybe CompressZlibStreamDriver
method drv read buf mini maxi -> red oarg_rw CompressZlibStreamDriver drv ; arg Address buf ; arg Int mini maxi red if undocumented and (drv:zip_flags .and. 2^16)<>0 return 0 drv:r next_out := buf drv:r avail_out := maxi part inflate while maxi-drv:r:avail_out<mini if drv:s:atend drv:r next_in := null drv:r avail_in := 0 var Int old_avail_out := drv:r:avail_out inflate drv:r 4 # Z_FINISH if drv:r:avail_out=old_avail_out leave inflate else drv:r next_in := drv:s:stream_read_cur drv:r avail_in := (cast drv:s:stream_read_stop Int)-(cast drv:s:stream_read_cur Int) var Int old_avail_in := drv:r:avail_in ; var Int old_avail_out := drv:r:avail_out inflate drv:r 0 drv:s stream_read_cur := drv:r:next_in if drv:r:avail_in=old_avail_in and drv:r:avail_out=old_avail_out leave inflate red := maxi-drv:r:avail_out if undocumented and drv:gzip drv r_crc := crc32_update drv:r_crc buf red drv r_size += red
method drv write buf mini maxi -> written oarg_rw CompressZlibStreamDriver drv ; arg Address buf ; arg Int mini maxi written drv:w next_in := buf drv:w avail_in := maxi part deflate while maxi-drv:w:avail_in<mini if drv:s:stream_write_cur=drv:s:stream_write_stop drv:s flush anytime if drv:s=failure leave deflate else drv:w next_out := drv:s stream_write_cur drv:w avail_out := (cast drv:s:stream_write_stop Int)-(cast drv:s:stream_write_cur Int) var Int old_avail_in := drv:w:avail_in ; var Int old_avail_out := drv:w:avail_out deflate drv:w 0 # Z_NO_FLUSH drv:s stream_write_cur := drv:w next_out if drv:w:avail_in=old_avail_in and drv:w:avail_out=old_avail_out leave deflate written := maxi-drv:w:avail_in if undocumented and drv:gzip drv w_crc := crc32_update drv:w_crc buf written drv w_size += written
method drv flush level -> status oarg_rw CompressZlibStreamDriver drv ; arg Int level ; arg Status status if (drv:flags .and. out)=0 return success drv:w next_in := null drv:w avail_in := 0 part deflate while true if drv:s:stream_write_cur=drv:s:stream_write_stop drv:s flush anytime if drv:s=failure leave deflate else drv:w next_out := drv:s:stream_write_cur drv:w avail_out := (cast drv:s:stream_write_stop Int)-(cast drv:s:stream_write_cur Int) var Int old_avail_out := drv:w:avail_out deflate drv:w (shunt level=end 4 2) # Z_FINISH Z_SYNC_FLUSH drv:s stream_write_cur := drv:w next_out if drv:w:avail_out=old_avail_out leave deflate if level<>end drv:s flush level status := shunt drv:s=success success failure
method drv close -> status oarg_rw CompressZlibStreamDriver drv ; arg ExtendedStatus status status := success if (drv:flags .and. in)<>0 if not undocumented or (drv:zip_flags .and. 2^16)=0 if (inflateEnd drv:r)<>0 status := failure if undocumented and drv:gzip drv:s raw_read addressof:(var uInt32 crc) uInt32:size drv:s raw_read addressof:(var uInt32 isize) uInt32:size if isize%2n^32<>drv:r_size%2n^32 or crc<>drv:r_crc status := failure if undocumented and drv:zip and (drv:zip_flags .and. 8)<>0 drv:s raw_read addressof:(var ZipTail tail) ZipTail:size if (drv:flags .and. out)<>0 if (deflateEnd drv:w)<>0 status := failure if undocumented and drv:gzip var uInt32 crc := drv w_crc ; drv:s raw_write addressof:crc uInt32:size var uInt32 isize := drv w_size; drv:s raw_write addressof:isize uInt32:size
method drv query command stream answer -> status oarg_rw CompressZlibStreamDriver drv ; arg Str command ; arg_rw Stream stream ; arg_w Str answer ; arg ExtendedStatus status if command="encoding" if undocumented answer := shunt drv:gzip "gzip" drv:zip "zip" drv:deflate "deflate" "zlib" else answer := "zlib" status := success eif undocumented and command="name" answer := drv name status := success eif undocumented and command="datetime" answer := string drv:datetime status := success
|
eif undocumented and command="comment" answer := drv comment status := success
|
else status := drv:s:stream_driver query command drv:s answer
method drv configure command stream -> status oarg_rw CompressZlibStreamDriver drv ; arg Str command ; arg_rw Stream stream ; arg ExtendedStatus status status := drv:s:stream_driver configure command drv:s
#----------------------------------------------------------------
type CompressZlibFileSystem void FileSystem maybe CompressZlibFileSystem
if pliant_alloc
function pliant_zalloc opaque items size -> adr arg Address opaque ; arg uInt items size ; arg Address adr external_calling_convention if buggy var Address ptr := memory_allocate items*size+2*uInt:size null ptr map uInt := 763F526Ch ptr map uInt 1 := 946E0497h adr := ptr translate uInt 2 else adr := memory_allocate items*size null function pliant_zfree opaque adr arg Address opaque ; arg Address adr external_calling_convention if buggy var Address ptr := adr translate uInt -2 if (ptr map uInt)=763F526Ch and (ptr map uInt 1)=946E0497h ptr map uInt := AC76EF15h ptr map uInt 1 := 037356C1h memory_free ptr else (var Stream s) open "file:/tmp/zlib_bug.log" append+safe s writeline string:datetime+(shunt (ptr map uInt)=AC76EF15h and (ptr map uInt 1)=037356C1h " twice" "wrong") s close else memory_free adr
method fs open name options flags stream support -> status oarg_rw CompressZlibFileSystem fs ; arg Str name options ; arg Int flags ; arg_rw Stream stream support ; arg ExtendedStatus status if undocumented var CBool gzip := options option "gzip" var CBool zip := options option "zip" var CBool deflate := gzip or zip or (options option "deflate") var Int level := options option "level" Int var Link:Stream s if exists:support s :> support else var Link:Stream s :> new Stream s open name options (flags .and. in+out+append+safe) if s=failure return failure var Link:CompressZlibStreamDriver drv :> new CompressZlibStreamDriver if (flags .and. out)<>0 if (options option "header" Str)<>"" s writeline (options option "header" Str) s writeline "" if undocumented and gzip
|
var Str comment := options option "comment" Str
|
var GzipHeader h
|
h id1 := 1Fh ; h id2 := 8Bh ; h cm := 8 ; h flg := 0 ; h xfl := 2 ; h os := 255
|
h id1 := 1Fh ; h id2 := 8Bh ; h cm := 8 ; h flg := shunt comment:len<>0 2^4 0 ; h xfl := 2 ; h os := 255
|
s raw_write addressof:h GzipHeader:size
|
if comment:len<>0 s writechars comment s writechars character:0
|
drv w_crc := 0 ; drv w_size := 0 memory_clear (addressof drv:w) z_stream_s:size drv:w data_type := 2 if pliant_alloc drv:w zalloc := (the_function pliant_zalloc Address uInt uInt -> Address) executable drv:w zfree := (the_function pliant_zfree Address Address) executable if undocumented if (deflateInit2 drv:w (shunt level=defined level -1) Z_DEFLATED (shunt deflate -15 15) 8 Z_DEFAULT_STRATEGY)<>0 return failure else if (deflateInit drv:w (shunt level=defined level -1))<>0 return failure if (flags .and. in)<>0 if (options option "header") while s:readline<>"" void if undocumented and gzip s raw_read addressof:(var GzipHeader h) GzipHeader:size if h:id1<>1Fh or h:id2<>8Bh return failure:"not a gzip stream" if h:cm<>8 return failure:"no at gzip stream" if (h:flg .and. 2^2)<>0 # FEXTRA s raw_read addressof:(var uInt16_li xlen) 2 while xlen>=0 and not s:atend s read_available (var Address adr) (var Int size) xlen xlen -= size if (h:flg .and. 2^3)<>0 # FNAME while { s raw_read addressof:(var uInt8 ch) 1 ; ch<>0 and not s:atend } void if (h:flg .and. 2^4)<>0 # COMMENT while { s raw_read addressof:(var uInt8 ch) 1 ; ch<>0 and not s:atend }
|
void
|
drv comment += character ch
|
if (h:flg .and. 2^1)<>0 # FHCRC s raw_read addressof:(var uInt16 crc16) 2 drv r_crc := 0 ; drv r_size := 0 if undocumented and zip s raw_read addressof:(var ZipHeader zh) ZipHeader:size if zh:signature<>04034B50h return failure:"not a zip stream" drv zip_flags := zh flags if zh:compressed_size=0 and zh:clear_size=0 and (zh:flags .and. 8)=0 drv zip_flags += 2^16 drv:name resize zh:name_length drv datetime := datetime 1980+zh:date\2^9 zh:date\2^5%2^4 zh:date%2^5 zh:time\2^11 zh:time\2^5%2^6 zh:time%2^5*2 0 s raw_read drv:name:characters zh:name_length for (var Int i) 1 zh:extra_length s raw_read addressof:(var Byte drop) 1 memory_clear (addressof drv:r) z_stream_s:size drv:r data_type := 2 if pliant_alloc drv:r zalloc := (the_function pliant_zalloc Address uInt uInt -> Address) executable drv:r zfree := (the_function pliant_zfree Address Address) executable if undocumented if (drv:zip_flags .and. 2^16)=0 if (inflateInit2 drv:r (shunt deflate -15 15))<>0 return failure else if (inflateInit drv:r)<>0 return failure drv s :> s drv flags := flags if undocumented drv gzip := gzip drv zip := zip drv deflate := deflate stream stream_driver :> drv status := success
gvar CompressZlibFileSystem compress_zlib_file_system pliant_multi_file_system mount "zlib:" "" compress_zlib_file_system if undocumented pliant_multi_file_system mount "deflate:" "" "deflate" compress_zlib_file_system pliant_multi_file_system mount "gzip:" "" "gzip" compress_zlib_file_system pliant_multi_file_system mount "zip:" "" "zip" compress_zlib_file_system
|