/pliant/language/stream/zlib.pli
 
 1  # Copyright  Hubert Tonneau  hubert.tonneau@pliant.cx 
 2  # 
 3  # This program is free software; you can redistribute it and/or 
 4  # modify it under the terms of the GNU General Public License version 2 
 5  # as published by the Free Software Foundation. 
 6  # 
 7  # This program is distributed in the hope that it will be useful, 
 8  # but WITHOUT ANY WARRANTY; without even the implied warranty of 
 9  # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the 
 10  # GNU General Public License for more details. 
 11  # 
 12  # You should have received a copy of the GNU General Public License 
 13  # version 2 along with this program; if not, write to the Free Software 
 14  # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA. 
 15   
 16  scope "/pliant/language/stream/" 
 17  module "ring.pli" 
 18   
 19  # win32 DLL provided in Win32 Pliant tarball 
 20  # was picked in zlib114dll.zip on http://www.winimage.com/zLibDll/ 
 21   
 22  constant zlib os_zlib_filename 
 23  constant version "1.1.3" 
 24  constant undocumented true 
 25   
 26  constant pliant_alloc os_api<>"win32" 
 27  constant buggy true 
 28   
 29   
 30  type z_stream_s 
 31    packed 
 32   
 33    field Address next_in 
 34    field Int avail_in 
 35    field Int total_in 
 36   
 37    field Address next_out 
 38    field Int avail_out 
 39    field Int total_out 
 40   
 41    field Address msg internal_state 
 42   
 43    field Address zalloc zfree opaque 
 44     
 45    field Int data_type 
 46    field Int adler 
 47    field Int reserved 
 48   
 49   
 50  if undocumented 
 51    constant Z_DEFLATED 8 
 52    constant Z_DEFAULT_STRATEGY 0 
 53   
 54   
 55  if undocumented 
 56    function deflateInit2_ stream level method window mem strategy version len -> err 
 57      arg_rw z_stream_s stream ; arg Int level method window mem strategy ; arg CStr version ; arg Int len err 
 58      external zlib "deflateInit2_" 
 59  else 
 60    function deflateInit_ stream level version len -> err 
 61      arg_rw z_stream_s stream ; arg Int level ; arg CStr version ; arg Int len err 
 62      external zlib "deflateInit_" 
 63   
 64  if undocumented 
 65    function deflateInit2 stream level method window mem strategy -> err 
 66      arg_rw z_stream_s stream ; arg Int level method window mem strategy ; arg Int err 
 67      err := deflateInit2_ stream level method window mem strategy version z_stream_s:size 
 68  else 
 69    function deflateInit stream level -> err 
 70      arg_rw z_stream_s stream ; arg Int level ; arg Int err 
 71      err := deflateInit_ stream level version z_stream_s:size 
 72   
 73  function deflate stream flush -> ret 
 74    arg_rw z_stream_s stream ; arg Int flush ; arg Int ret 
 75    external zlib "deflate" 
 76   
 77  function deflateEnd stream -> err 
 78    arg_rw z_stream_s stream ; arg Int err 
 79    external zlib "deflateEnd" 
 80   
 81   
 82  if undocumented 
 83    function inflateInit2_ stream window version len -> err 
 84      arg_rw z_stream_s stream ; arg Int window ; arg CStr version ; arg Int len err 
 85      external zlib "inflateInit2_" 
 86  else 
 87    function inflateInit_ stream version len -> err 
 88      arg_rw z_stream_s stream ; arg CStr version ; arg Int len err 
 89      external zlib "inflateInit_" 
 90   
 91  if undocumented 
 92    function inflateInit2 stream window -> err 
 93      arg_rw z_stream_s stream ; arg Int window ; arg Int err 
 94      err := inflateInit2_ stream window version z_stream_s:size 
 95  else 
 96    function inflateInit stream -> err 
 97      arg_rw z_stream_s stream ; arg Int err 
 98      err := inflateInit_ stream version z_stream_s:size 
 99   
 100  function inflate stream flush 
 101    arg_rw z_stream_s stream ; arg Int flush 
 102    external zlib "inflate" 
 103   
 104  function inflateReset stream 
 105    arg_rw z_stream_s stream 
 106    external zlib "inflateReset" 
 107   
 108  function inflateEnd stream -> err 
 109    arg_rw z_stream_s stream ; arg Int err 
 110    external zlib "inflateEnd" 
 111   
 112   
 113  if undocumented 
 114   
 115    type GzipHeader 
 116      packed 
 117      field uInt8 id1 id2 
 118      field uInt8 cm flg 
 119      field uInt32_li mtime 
 120      field uInt8 xfl os 
 121   
 122    gvar (Array uInt 256) crc_table 
 123    function init_table 
 124      for (var Int n) 0 255 
 125        var uInt := n 
 126        for (var Int k) 0 7 
 127          if (.and. 1)<>0 
 128            := 0EDB88320h .xor. (c\2) 
 129          else 
 130            := c\2 
 131        crc_table := c 
 132    init_table 
 133   
 134    function crc32_update old_crc adr size -> new_crc 
 135      arg uInt old_crc new_crc ; arg Address adr ; arg Int size 
 136      var uInt := old_crc .xor. 0FFFFFFFFh 
 137      for (var Int n) size-1 
 138        var uInt := (adr translate Byte n) map uInt8 
 139        var Int := (.xor. b) .and. 0FFh 
 140        := crc_table:.xor. (c\2^8) 
 141      new_crc := .xor. 0FFFFFFFFh 
 142   
 143   
 144  if undocumented 
 145   
 146    type ZipHeader 
 147      field uInt32_li signature # 0 
 148      field uInt16_li version # 4 
 149      field uInt16_li flags # 6 
 150      field uInt16_li compression # 8 
 151      field uInt16_li time # 10 
 152      field uInt16_li date # 12 
 153      field uInt32_li crc # 14 
 154      field uInt32_li compressed_size # 18 
 155      field uInt32_li clear_size # 22 
 156      field uInt16_li name_length # 26 
 157      field uInt16_li extra_length # 28 
 158   
 159    type ZipTail 
 160      field uInt32_li signature # 0 
 161      field uInt32_li crc # 4 
 162      field uInt32_li compressed_size # 8 
 163      field uInt32_li uncompressed_size # 12 
 164   
 165   
 166 
 
 167   
 168   
 169  type CompressZlibStreamDriver 
 170    field Link:Stream s 
 171    field z_stream_s w 
 172    field z_stream_s r 
 173    field Int flags 
 174    if undocumented 
 175      field CBool gzip 
 176      field CBool zip 
 177      field CBool deflate 
 178      field uInt w_crc w_size 
 179      field uInt r_crc r_size 
 180      field Int zip_flags <- 0 
 181      field Str name 
 182      field DateTime datetime 
 183      field Str comment 
 184  StreamDriver maybe CompressZlibStreamDriver 
 185   
 186   
 187  method drv read buf mini maxi -> red 
 188    oarg_rw CompressZlibStreamDriver drv ; arg Address buf ; arg Int mini maxi red 
 189    if undocumented and (drv:zip_flags .and. 2^16)<>0 
 190      return 0 
 191    drv:next_out := buf 
 192    drv:avail_out := maxi 
 193    part inflate 
 194      while maxi-drv:r:avail_out<mini 
 195        if drv:s:atend 
 196          drv:next_in := null 
 197          drv:avail_in := 0 
 198          var Int old_avail_out := drv:r:avail_out 
 199          inflate drv:# Z_FINISH 
 200          if drv:r:avail_out=old_avail_out 
 201            leave inflate 
 202        else 
 203          drv:next_in := drv:s:stream_read_cur 
 204          drv:avail_in := (cast drv:s:stream_read_stop Int)-(cast drv:s:stream_read_cur Int) 
 205          var Int old_avail_in := drv:r:avail_in ; var Int old_avail_out := drv:r:avail_out 
 206          inflate drv:0 
 207          drv:stream_read_cur := drv:r:next_in 
 208          if drv:r:avail_in=old_avail_in and drv:r:avail_out=old_avail_out 
 209            leave inflate 
 210    red := maxi-drv:r:avail_out 
 211    if undocumented and drv:gzip 
 212      drv r_crc := crc32_update drv:r_crc buf red 
 213      drv r_size += red 
 214   
 215   
 216  method drv write buf mini maxi -> written 
 217    oarg_rw CompressZlibStreamDriver drv ; arg Address buf ; arg Int mini maxi written 
 218    drv:next_in := buf 
 219    drv:avail_in := maxi 
 220    part deflate 
 221      while maxi-drv:w:avail_in<mini 
 222        if drv:s:stream_write_cur=drv:s:stream_write_stop 
 223          drv:flush anytime 
 224          if drv:s=failure 
 225            leave deflate 
 226        else 
 227          drv:next_out := drv:stream_write_cur 
 228          drv:avail_out := (cast drv:s:stream_write_stop Int)-(cast drv:s:stream_write_cur Int) 
 229          var Int old_avail_in := drv:w:avail_in ; var Int old_avail_out := drv:w:avail_out 
 230          deflate drv:# Z_NO_FLUSH 
 231          drv:stream_write_cur := drv:next_out 
 232          if drv:w:avail_in=old_avail_in and drv:w:avail_out=old_avail_out 
 233            leave deflate 
 234    written := maxi-drv:w:avail_in 
 235    if undocumented and drv:gzip 
 236      drv w_crc := crc32_update drv:w_crc buf written 
 237      drv w_size += written 
 238   
 239   
 240  method drv flush level -> status 
 241    oarg_rw CompressZlibStreamDriver drv ; arg Int level ; arg Status status 
 242    if (drv:flags .and. out)=0 
 243      return success 
 244    drv:next_in := null 
 245    drv:avail_in := 0 
 246    part deflate 
 247      while true 
 248        if drv:s:stream_write_cur=drv:s:stream_write_stop 
 249          drv:flush anytime 
 250          if drv:s=failure 
 251            leave deflate 
 252        else 
 253          drv:next_out := drv:s:stream_write_cur 
 254          drv:avail_out := (cast drv:s:stream_write_stop Int)-(cast drv:s:stream_write_cur Int) 
 255          var Int old_avail_out := drv:w:avail_out 
 256          deflate drv:w (shunt level=end 4 2) # Z_FINISH Z_SYNC_FLUSH 
 257          drv:stream_write_cur := drv:next_out 
 258          if drv:w:avail_out=old_avail_out 
 259            leave deflate 
 260    if level<>end 
 261      drv:flush level 
 262    status := shunt drv:s=success success failure 
 263   
 264   
 265  method drv close -> status 
 266    oarg_rw CompressZlibStreamDriver drv ; arg ExtendedStatus status 
 267    status := success 
 268    if (drv:flags .and. in)<>0 
 269      if not undocumented or (drv:zip_flags .and. 2^16)=0 
 270        if (inflateEnd drv:r)<>0 
 271          status := failure 
 272      if undocumented and drv:gzip 
 273        drv:raw_read addressof:(var uInt32 crc) uInt32:size 
 274        drv:raw_read addressof:(var uInt32 isize) uInt32:size 
 275        if isize%2n^32<>drv:r_size%2n^32 or crc<>drv:r_crc 
 276          status := failure 
 277      if undocumented and drv:zip and (drv:zip_flags .and. 8)<>0 
 278        drv:raw_read addressof:(var ZipTail tail) ZipTail:size 
 279    if (drv:flags .and. out)<>0 
 280      if (deflateEnd drv:w)<>0 
 281        status := failure 
 282      if undocumented and drv:gzip 
 283        var uInt32 crc := drv w_crc ; drv:raw_write addressof:crc uInt32:size 
 284        var uInt32 isize := drv w_size; drv:raw_write addressof:isize uInt32:size 
 285   
 286   
 287  method drv query command stream answer -> status 
 288    oarg_rw CompressZlibStreamDriver drv ; arg Str command ; arg_rw Stream stream ; arg_w Str answer ; arg ExtendedStatus status  
 289    if command="encoding" 
 290      if undocumented 
 291        answer := shunt drv:gzip "gzip" drv:zip "zip" drv:deflate "deflate" "zlib" 
 292      else 
 293        answer := "zlib" 
 294      status := success 
 295    eif undocumented and command="name" 
 296      answer := drv name 
 297      status := success 
 298    eif undocumented and command="datetime" 
 299      answer := string drv:datetime 
 300      status := success 
 301    eif undocumented and command="comment" 
 302      answer := drv comment 
 303      status := success 
 304    else 
 305      status := drv:s:stream_driver query command drv:answer 
 306   
 307   
 308  method drv configure command stream -> status 
 309    oarg_rw CompressZlibStreamDriver drv ; arg Str command ; arg_rw Stream stream ; arg ExtendedStatus status 
 310    status := drv:s:stream_driver configure command drv:s 
 311   
 312   
 313 
 
 314   
 315   
 316  type CompressZlibFileSystem 
 317    void 
 318  FileSystem maybe CompressZlibFileSystem 
 319   
 320   
 321  if pliant_alloc 
 322   
 323    function pliant_zalloc opaque items size -> adr 
 324      arg Address opaque ; arg uInt items size ; arg Address adr 
 325      external_calling_convention 
 326      if buggy 
 327        var Address ptr := memory_allocate items*size+2*uInt:size null 
 328        ptr map uInt := 763F526Ch 
 329        ptr map uInt := 946E0497h 
 330        adr := ptr translate uInt 2 
 331      else 
 332        adr := memory_allocate items*size null 
 333     
 334    function pliant_zfree opaque adr 
 335      arg Address opaque ; arg Address adr 
 336      external_calling_convention 
 337      if buggy 
 338        var Address ptr := adr translate uInt -2 
 339        if (ptr map uInt)=763F526Ch and (ptr map uInt 1)=946E0497h 
 340          ptr map uInt := AC76EF15h 
 341          ptr map uInt := 037356C1h 
 342          memory_free ptr 
 343        else 
 344          (var Stream s) open "file:/tmp/zlib_bug.log" append+safe 
 345          writeline string:datetime+(shunt (ptr map uInt)=AC76EF15h and (ptr map uInt 1)=037356C1h " twice" "wrong") 
 346          close 
 347      else 
 348        memory_free adr 
 349   
 350   
 351  method fs open name options flags stream support -> status 
 352    oarg_rw CompressZlibFileSystem fs ; arg Str name options ; arg Int flags ; arg_rw Stream stream support ; arg ExtendedStatus status 
 353    if undocumented 
 354      var CBool gzip := options option "gzip" 
 355      var CBool zip := options option "zip" 
 356      var CBool deflate := gzip or zip or (options option "deflate") 
 357    var Int level := options option "level" Int 
 358    var Link:Stream s 
 359    if exists:support 
 360      :> support 
 361    else 
 362      var Link:Stream :> new Stream 
 363      open name options (flags .and. in+out+append+safe) 
 364      if s=failure 
 365        return failure 
 366    var Link:CompressZlibStreamDriver drv :> new CompressZlibStreamDriver 
 367    if (flags .and. out)<>0 
 368      if (options option "header" Str)<>"" 
 369        writeline (options option "header" Str) 
 370        writeline "" 
 371      if undocumented and gzip 
 372        var Str comment := options option "comment" Str 
 373        var GzipHeader h 
 374        id1 := 1Fh ; id2 := 8Bh ; cm := 8 ; flg := shunt comment:len<>0 2^4 0 ; xfl := 2 ; os := 255 
 375        raw_write addressof:GzipHeader:size 
 376        if comment:len<>0 
 377          writechars comment 
 378          writechars character:0 
 379        drv w_crc := 0 ; drv w_size := 0 
 380      memory_clear (addressof drv:w) z_stream_s:size 
 381      drv:data_type := 2 
 382      if pliant_alloc 
 383        drv:zalloc := (the_function pliant_zalloc Address uInt uInt -> Address) executable 
 384        drv:zfree := (the_function pliant_zfree Address Address) executable 
 385      if undocumented 
 386        if (deflateInit2 drv:w (shunt level=defined level -1) Z_DEFLATED (shunt deflate -15 15) 8 Z_DEFAULT_STRATEGY)<>0 
 387          return failure 
 388      else 
 389        if (deflateInit drv:w (shunt level=defined level -1))<>0 
 390          return failure 
 391    if (flags .and. in)<>0 
 392      if (options option "header") 
 393        while s:readline<>"" 
 394          void 
 395      if undocumented and gzip 
 396        raw_read addressof:(var GzipHeader h) GzipHeader:size 
 397        if h:id1<>1Fh or h:id2<>8Bh 
 398          return failure:"not a gzip stream" 
 399        if h:cm<>8 
 400          return failure:"no at gzip stream" 
 401        if (h:flg .and. 2^2)<># FEXTRA 
 402          raw_read addressof:(var uInt16_li xlen) 2 
 403          while xlen>=and not s:atend 
 404            read_available (var Address adr) (var Int size) xlen 
 405            xlen -= size 
 406        if (h:flg .and. 2^3)<># FNAME 
 407          while { raw_read addressof:(var uInt8 ch) 1 ; ch<>and not s:atend } 
 408            void 
 409        if (h:flg .and. 2^4)<># COMMENT 
 410          while { raw_read addressof:(var uInt8 ch) 1 ; ch<>and not s:atend } 
 411            drv comment += character ch 
 412        if (h:flg .and. 2^1)<># FHCRC 
 413          raw_read addressof:(var uInt16 crc16) 2 
 414        drv r_crc := 0 ; drv r_size := 0 
 415      if undocumented and zip 
 416        raw_read addressof:(var ZipHeader zh) ZipHeader:size 
 417        if zh:signature<>04034B50h 
 418          return failure:"not a zip stream" 
 419        drv zip_flags := zh flags 
 420        if zh:compressed_size=and zh:clear_size=and (zh:flags .and. 8)=0 
 421          drv zip_flags += 2^16 
 422        drv:name resize zh:name_length 
 423        drv datetime := datetime 1980+zh:date\2^zh:date\2^5%2^zh:date%2^zh:time\2^11 zh:time\2^5%2^zh:time%2^5*2 0 
 424        raw_read drv:name:characters zh:name_length 
 425        for (var Int i) zh:extra_length 
 426          raw_read addressof:(var Byte drop) 1 
 427      memory_clear (addressof drv:r) z_stream_s:size 
 428      drv:data_type := 2 
 429      if pliant_alloc 
 430        drv:zalloc := (the_function pliant_zalloc Address uInt uInt -> Address) executable 
 431        drv:zfree := (the_function pliant_zfree Address Address) executable 
 432      if undocumented 
 433        if (drv:zip_flags .and. 2^16)=0 
 434          if (inflateInit2 drv:r (shunt deflate -15 15))<>0 
 435            return failure 
 436      else 
 437        if (inflateInit drv:r)<>0 
 438          return failure 
 439    drv :> s 
 440    drv flags := flags 
 441    if undocumented 
 442      drv gzip := gzip 
 443      drv zip := zip 
 444      drv deflate := deflate 
 445    stream stream_driver :> drv 
 446    status := success 
 447   
 448   
 449  gvar CompressZlibFileSystem compress_zlib_file_system 
 450  pliant_multi_file_system mount "zlib:" "" compress_zlib_file_system 
 451  if undocumented 
 452    pliant_multi_file_system mount "deflate:" "" "deflate" compress_zlib_file_system 
 453    pliant_multi_file_system mount "gzip:" "" "gzip" compress_zlib_file_system 
 454    pliant_multi_file_system mount "zip:" "" "zip" compress_zlib_file_system