/pliant/util/encoding/zlib.pli
 
 1  abstract 
 2    [This is Pliant zlib implementation according to RFC 1950 (deflate) and RFC 1951 (zlib)] 
 3    eol ; highlight "only uncompressing is implemented, and it's not yet a Pliant filesystem" 
 4   
 5  module "/pliant/language/compiler.pli" 
 6  module "/pliant/language/stream.pli" 
 7   
 8   
 9 
 
 10   
 11   
 12  type BitStream 
 13    field Address buffer 
 14    field Int size # number of bits 
 15    field Int offset # in bits 
 16    field Pointer:Stream stream  
 17   
 18  method b bind s 
 19    arg_rw BitStream b ; arg_rw Stream s 
 20    b stream :> s 
 21    b size := 0 
 22    b offset := 0 
 23   
 24  method b read n -> v 
 25    arg_rw BitStream b ; arg Int n ; arg uInt v 
 26    if b:offset+n<=b:size 
 27      v := ((b:buffer translate Byte b:offset\8) map uInt) \ 2^(b:offset .and. 7) .and. (2^n-1) 
 28      b offset += n 
 29    eif b:offset=b:size 
 30      b:stream read_available b:buffer b:size 
 31      b size *= 8 
 32      b offset := 0 
 33      v := b read n 
 34    else 
 35      var Int avail := b:size-b:offset 
 36      v := (b read avail)+(b read n-avail)*2^avail 
 37   
 38  method b unbind 
 39    arg_rw BitStream b 
 40    var Int remain := (b:size-b:offset)\8 
 41    b:stream stream_read_cur := b:stream:stream_read_cur translate Byte -remain 
 42   
 43   
 44 
 
 45   
 46   
 47  constant huffman_max_bits 15 # Huffman codes must not have more than huffman_max_bits bits 
 48   
 49  type HuffmanData 
 50    void 
 51   
 52  type HuffmanNode 
 53    field Link:HuffmanData zero one 
 54   
 55  type HuffmanLeaf 
 56    field Int letter 
 57   
 58  HuffmanData maybe HuffmanNode 
 59  HuffmanData maybe HuffmanLeaf 
 60   
 61  type Huffman 
 62    field Link:HuffmanData root 
 63   
 64   
 65  method hd check -> ok 
 66    oarg HuffmanData hd ; arg CBool ok 
 67    if addressof:hd=null 
 68      ok := false 
 69    eif (entry_type addressof:hd)=HuffmanNode 
 70      var Link:HuffmanNode n :> addressof:hd omap HuffmanNode 
 71      ok := n:zero:check and n:one:check 
 72    else 
 73      ok := (entry_type addressof:hd)=HuffmanLeaf 
 74   
 75  method h define letter code length -> status 
 76    arg_rw Huffman h ; arg Int letter code length ; arg Status status 
 77    var (Pointer Link:HuffmanData) ptr :>> h root 
 78    for (var Int i) 1 length 
 79      if addressof:ptr=null 
 80        ptr :> new HuffmanNode 
 81      if (entry_type addressof:ptr)<>HuffmanNode 
 82        return failure 
 83      var Pointer:HuffmanNode n :> addressof:ptr map HuffmanNode 
 84      if (code .and. 2^(huffman_max_bits-i))<>0 
 85        ptr :>> n one 
 86      else 
 87        ptr :>> n zero 
 88    var Link:HuffmanLeaf nl :> new HuffmanLeaf 
 89    nl letter := letter 
 90    ptr :> nl 
 91    status := success 
 92   
 93  method h setup lengths -> status 
 94    arg_rw Huffman h ; arg Array:Int lengths ; arg Status status 
 95    for (var Int i) 0 lengths:size-1 
 96      if lengths:i<0 or lengths:i>huffman_max_bits 
 97        return failure 
 98    h root :> null map HuffmanData 
 99    var Int code := 0 
 100    for (var Int length) 1 huffman_max_bits 
 101      for (var Int letter) 0 lengths:size-1 
 102        if lengths:letter=length 
 103          h define letter code length 
 104          code += 2^(huffman_max_bits-length) 
 105    status := shunt code=2^huffman_max_bits and h:root:check success failure 
 106   
 107  method h setup_default_letters -> status 
 108    arg_rw Huffman h ; arg Status status 
 109    (var Array:Int lengths) size := 288 
 110    for (var Int i) 0 lengths:size-1 
 111      lengths i := shunt i<=143 8 i<=255 9 i<=279 7 8 
 112    status := h setup lengths 
 113   
 114  method h setup_default_distances -> status 
 115    arg_rw Huffman h ; arg Status status 
 116    (var Array:Int lengths) size := 32 
 117    for (var Int i) 0 lengths:size-1 
 118      lengths i := 5 
 119    status := h setup lengths 
 120   
 121  method h read_letter bs -> letter 
 122    arg Huffman h ; arg_rw BitStream bs ; arg Int letter 
 123    var Pointer:HuffmanData cur :> h root 
 124    while (entry_type addressof:cur)=HuffmanNode 
 125      var Pointer:HuffmanNode n :> addressof:cur map HuffmanNode 
 126      if (bs read 1)=1 
 127        cur :> n one 
 128      else 
 129        cur :> n zero 
 130    letter := (addressof:cur omap HuffmanLeaf) letter 
 131   
 132  method h setup_custom size encoding bs -> status 
 133    arg_rw Huffman h ; arg Int size ; arg Huffman encoding ; arg_rw BitStream bs ; arg Status status 
 134    (var Array:Int lengths) size := size 
 135    var Int i := 0 
 136    while i<lengths:size 
 137      var Int code := encoding read_letter bs 
 138      if code<16 
 139        lengths i := code 
 140        i += 1 
 141      eif code=16 
 142        var Int count := 3+(bs read 2) 
 143        for (var Int j) 1 count 
 144          lengths i := lengths i-1 
 145          i += 1 
 146      eif code=17 
 147        var Int count := 3+(bs read 3) 
 148        for (var Int j) 1 count 
 149          lengths i := 0 
 150          i += 1 
 151      eif code=18 
 152        var Int count := 11+(bs read 7) 
 153        for (var Int j) 1 count 
 154          lengths i := 0 
 155          i += 1 
 156      else 
 157        return failure 
 158    status := h setup lengths 
 159   
 160   
 161 
 
 162   
 163   
 164  constant deflate_bufsize 2^15 
 165   
 166  type DeflateBuffer 
 167    field Int start stop 
 168    field (Array Byte deflate_bufsize) buffer 
 169    field Pointer:Stream out_stream ; field Intn bytes_count 
 170    field Int crc_type ; field uInt alder32 
 171   
 172  function alder32_update crc buf size 
 173    arg_rw uInt crc ; arg Address buf ; arg Int size 
 174    var Int s1 := crc .and. 0FFFFh 
 175    var Int s2 := (crc .and. 0FFFF0000h)\2^16 
 176    for (var Int i) 0 size-1 
 177      var Int b := (buf translate Byte i) map uInt8 
 178      s1 := (s1+b)%65521 
 179      s2 := (s2+s1)%65521 
 180    crc := s1+(s2*2^16) 
 181   
 182  method db flush_some 
 183    arg_rw DeflateBuffer db 
 184    check db:start>=0 and db:start<=deflate_bufsize and  db:stop>=db:start and db:stop<=deflate_bufsize 
 185    var Int step := (min db:stop deflate_bufsize)-db:start 
 186    db:out_stream raw_write ((addressof db:buffer) translate Byte db:start) step 
 187    db start += step 
 188    if db:start>=deflate_bufsize 
 189      db start -= deflate_bufsize 
 190      db stop -= deflate_bufsize 
 191    db bytes_count += step 
 192     
 193  method db setup out_stream crc_type 
 194    arg_w DeflateBuffer db ; arg_rw Stream out_stream ; arg Int crc_type 
 195    db start := 0 ; db stop := 0 ; db bytes_count := 0 
 196    db out_stream :> out_stream 
 197    db crc_type := crc_type ; db alder32 := 1 
 198   
 199  method db terminate bytes_count crc 
 200    arg_rw DeflateBuffer db ; arg_w Intn bytes_count ; arg_w uInt32 crc 
 201    while db:start<>db:stop 
 202      db flush_some 
 203    bytes_count := db bytes_count 
 204    if db:crc_type=1 
 205      crc := db alder32 
 206   
 207  method db write adr size charbychar 
 208    arg_rw DeflateBuffer db ; arg Address adr ; arg Int size ; arg CBool charbychar 
 209    check db:start>=0 and db:start<=deflate_bufsize and  db:stop>=db:start and db:stop<=deflate_bufsize 
 210    var Int written := 0 
 211    while written<size 
 212      var Int step := min size-written deflate_bufsize-db:stop 
 213      if not charbychar 
 214        memory_copy (adr translate Byte written) ((addressof db:buffer) translate Byte db:stop) step 
 215      else 
 216        for (var Int i) 0 step-1 
 217          ((addressof db:buffer) translate Byte db:stop+i) map uInt8 := (adr translate Byte written+i) map uInt8 
 218      if db:crc_type=1 
 219        alder32_update db:alder32 (adr translate Byte written) step 
 220      db stop += step 
 221      if db:stop>=deflate_bufsize 
 222        db flush_some 
 223      written += step 
 224      
 225   
 226  method db write adr size 
 227    arg_rw DeflateBuffer db ; arg Address adr ; arg Int size 
 228    db write adr size false 
 229   
 230  method db status -> s 
 231    arg DeflateBuffer db ; arg Status s 
 232    s := shunt db:out_stream=success success failure 
 233   
 234   
 235 
 
 236   
 237   
 238  function letter_length letter bs -> length 
 239    arg Int letter ; arg_rw BitStream bs ; arg Int length 
 240    if letter<=264 
 241      length := letter-264+10 
 242    eif letter<285 
 243      var Int extra := (letter-261)\4 
 244      length := 3+2^(extra+2)+(letter-261-extra*4)*2^extra+(bs read extra) 
 245    eif letter=285 
 246      length := 258 
 247    else 
 248      length := undefined 
 249   
 250  function distance distances bs -> dist 
 251    arg Huffman distances ; arg_rw BitStream bs ; arg Int dist 
 252    var uInt code := distances read_letter bs 
 253    if code<4 
 254      dist := 1+code 
 255    eif code<30 
 256      var Int extra := (code-2)\2 
 257      dist := 1+2^(extra+1)+(code-2-extra*2)*2^extra+(bs read extra) 
 258    else 
 259      dist := undefined 
 260   
 261   
 262  function deflate_uncompress src dest crc_type bytes_count crc -> status 
 263    arg_rw Stream src dest ; arg Int crc_type ; arg_w Intn bytes_count ; arg_w uInt32 crc ; arg Status status 
 264    (var BitStream bs) bind src 
 265    var DeflateBuffer buf ; buf setup dest crc_type 
 266    part deflate_one_block 
 267      var Int bfinal := bs read 1 
 268      var Int btype := bs read 2 
 269      if btype=0 # no compression 
 270        bs unbind 
 271        src raw_read addressof:(var uInt16_li len) uInt16:size 
 272        src raw_read addressof:(var uInt16_li nlen) uInt16:size 
 273        if nlen<>(len .xor. 0FFFFh) 
 274          return failure 
 275        while len>0 
 276          src read_available (var Address adr) (var Int size) len 
 277          buf write adr size 
 278          len -= size 
 279        bs bind src 
 280      eif btype=1 or btype=2 # compressed with fixed Huffman codes 
 281        var Huffman letters distances ; var Status status1 status2 
 282        if btype=1 
 283          status1 := letters setup_default_letters 
 284          status2 := distances setup_default_distances 
 285        eif btype=2 
 286          var uInt hlit := bs read 5 
 287          var uInt hdist := bs read 5 
 288          var uInt hclen := bs read 4 
 289          (var Array:Int lengths) size := 19 
 290          for (var Int i) 0 lengths:size-1 
 291            var Int order := shunt i<3 16+i i=3 0 i%2=1 9-i\2 6+i\2 
 292            if i<hclen+4 
 293              lengths order := bs read 3 
 294            else 
 295              lengths order := 0 
 296          if ((var Huffman encoding) setup lengths)=failure 
 297            return failure 
 298          status1 := letters setup_custom hlit+257 encoding bs 
 299          status2 := distances setup_custom hdist+1 encoding bs 
 300        if status1=failure or status2=failure 
 301          return failure 
 302        part deflate_one_letter 
 303          var Int letter := letters read_letter bs 
 304          if letter<256 
 305            var uInt8 letter8 := letter 
 306            buf write addressof:letter8 1 
 307          eif letter>256 
 308            var Int length := letter_length letter bs 
 309            var Int dist := distance distances bs 
 310            if length=undefined or dist=undefined 
 311              return failure 
 312            while length>0 
 313              var Int offset := buf:stop-dist 
 314              if offset<0 
 315                offset += deflate_bufsize 
 316              var Int step := min length deflate_bufsize-offset 
 317              buf write ((addressof buf:buffer) translate Byte offset) step dist<Int:size 
 318              length -= step 
 319          else 
 320            leave deflate_one_letter 
 321          restart deflate_one_letter 
 322      else # error 
 323        return failure 
 324      if bfinal=0 
 325        restart deflate_one_block 
 326    buf terminate bytes_count crc 
 327    bs unbind 
 328    status := success 
 329   
 330   
 331 
 
 332   
 333   
 334  function zlib_uncompress src dest -> status 
 335    arg_rw Stream src dest ; arg Status status 
 336    src raw_read addressof:(var uInt8 cmf) 1 
 337    var Int cm := cmf .and. 0Fh 
 338    var Int cinfo := (cmf .and. 0F0h)\2^4 
 339    src raw_read addressof:(var uInt8 flg) 1 
 340    var Int fdict := (cmf .and. 020h)\2^5 
 341    var Int flevel := (cmf .and. 0C0h)\2^6 
 342    if cm<>8 or cinfo<>7 or (cmf*256+flg)%31<>0 
 343      return failure 
 344    if (deflate_uncompress src dest 1 (var Intn bytes_count) (var uInt32 crc))=failure 
 345      return failure 
 346    src raw_read addressof:(var uInt32_hi alder32) uInt32:size 
 347    if alder32<>crc 
 348      console " WRONG CRC " (string (cast alder32 uInt) "radix 16") " " (string (cast crc uInt) "radix 16") eol 
 349    status := shunt alder32=crc success failure 
 350   
 351   
 352 
 
 353   
 354   
 355  type GzipHeader 
 356    packed 
 357    field uInt8 id1 id2 
 358    field uInt8 cm flg 
 359    field uInt32_li mtime 
 360    field uInt8 xfl os 
 361   
 362  function gzip_uncompress src dest -> status 
 363    arg_rw Stream src dest ; arg Status status 
 364    src raw_read addressof:(var GzipHeader h) GzipHeader:size 
 365    if h:id1<>1Fh or h:id2<>8Bh 
 366      return failure 
 367    if h:cm<>8 
 368      return failure 
 369    if (h:flg .and. 2^2)<>0 # FEXTRA 
 370      src raw_read addressof:(var uInt16_li xlen) 2 
 371      while xlen>=0 and not src:atend 
 372        src read_available (var Address adr) (var Int size) xlen 
 373        xlen -= size 
 374    if (h:flg .and. 2^3)<>0 # FNAME 
 375      while { src raw_read addressof:(var uInt8 ch) 1 ; ch<>0 and not src:atend } 
 376        void 
 377    if (h:flg .and. 2^4)<>0 # COMMENT 
 378      while { src raw_read addressof:(var uInt8 ch) 1 ; ch<>0 and not src:atend } 
 379        void 
 380    if (h:flg .and. 2^1)<>0 # FHCRC 
 381      src raw_read addressof:(var uInt16 crc16) 2 
 382    (var DateTime dt) seconds := (datetime 1970 1 1 0 0 0 0):seconds+h:mtime 
 383    if (deflate_uncompress src dest 0 (var Intn bytes_count) (var uInt32 crc))=failure 
 384      return failure 
 385    src raw_read addressof:(var uInt32 crc32) uInt32:size 
 386    src raw_read addressof:(var uInt32 isize) uInt32:size 
 387    status := shunt isize=bytes_count%2n^32 success failure 
 388   
 389   
 390  export zlib_uncompress gzip_uncompress