# 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
|