basis/compression/zlib/zlib.factor

   1 ! Copyright (C) 2009 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien alien.c-types alien.data alien.syntax
   4 byte-arrays byte-vectors classes.struct combinators
   5 compression.zlib.ffi continuations destructors fry kernel libc
   6 math math.functions math.ranges sequences system ;
   7 QUALIFIED: compression.zlib.ffi
   8 IN: compression.zlib
   9
  10 ERROR: zlib-failed n string ;
  11
  12 : zlib-error-message ( n -- * )
  13     dup compression.zlib.ffi:Z_ERRNO = [
  14         drop errno "native libc error"
  15     ] [
  16         dup
  17         neg ! zlib error codes are negative
  18         {
  19             "no error" "libc_error"
  20             "stream error" "data error"
  21             "memory error" "buffer error" "zlib version error"
  22         } ?nth
  23     ] if throw-zlib-failed ;
  24
  25 : zlib-error ( n -- )
  26     dup {
  27         { compression.zlib.ffi:Z_OK [ drop ] }
  28         { compression.zlib.ffi:Z_STREAM_END [ drop ] }
  29         [ dup zlib-error-message throw-zlib-failed ]
  30     } case ;
  31
  32 : compressed-size ( byte-array -- n )
  33     length 1001/1000 * ceiling 12 + ;
  34
  35 : compress ( byte-array -- byte-array' )
  36     [
  37         compressed-size
  38         [ <byte-vector> dup underlying>> ] keep ulong <ref>
  39     ] keep [
  40         dup length compression.zlib.ffi:compress zlib-error
  41     ] 2keep drop ulong deref >>length B{ } like ;
  42
  43 : (uncompress) ( length byte-array -- byte-array )
  44     [
  45         [ drop [ malloc &free ] [ ulong <ref> ] bi ]
  46         [ nip dup length ] 2bi
  47         [ compression.zlib.ffi:uncompress zlib-error ] 4keep
  48         2drop ulong deref memory>byte-array
  49     ] with-destructors ;
  50
  51 : uncompress ( byte-array -- byte-array' )
  52     [ length 5 [0,b) [ 2^ * ] with map ] keep
  53     '[ _ (uncompress) ] attempt-all ;
  54
  55
  56 : zlib-inflate-init ( -- z_stream_s )
  57     z_stream <struct> ZLIB_VERSION over byte-length [
  58         inflateInit_ zlib-error
  59     ] 3keep 2drop  ;
  60
  61 ! window can be 0, 15, 32, 47 (others?)
  62 : zlib-inflate-init2 ( window -- z_stream_s )
  63     [ z_stream <struct> ] dip ZLIB_VERSION pick byte-length [
  64         inflateInit2_ zlib-error
  65     ] 4keep 3drop  ;
  66
  67 : zlib-inflate-end ( z_stream -- )
  68     inflateEnd zlib-error ;
  69
  70 : zlib-inflate-reset ( z_stream -- )
  71     inflateReset zlib-error ;
  72
  73 : zlib-inflate ( z_stream flush -- )
  74     inflate zlib-error ;
  75
  76 : zlib-inflate-get-header ( z_stream -- gz_header )
  77     gz_header <struct> [
  78         inflateGetHeader zlib-error
  79     ] keep ;