Patch title: Release 92 bulk changes
Abstract:
File: /language/stream/zlib.pli
Key:
    Removed line
    Added line
# 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
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 (inflateEnd drv:r)<>0
      status := failure
    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:deflate "deflate" "zlib"
      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
  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 deflate := gzip or (options option "deflate")
    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 GzipHeader h
      h id1 := 1Fh ; h id2 := 8Bh ; h cm := 8 ; h flg := 0 ; h xfl := 2 ; h os := 255
      s raw_write addressof:h GzipHeader:size
      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
        return failure:"not a gzip stream"
      if h:cm<>8
        return failure
        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
      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 (inflateInit2 drv:r (shunt deflate -15 15))<>0
        return failure
      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