buf: compression and decompression functions.

* buf.c (buf_compress, buf_decompress): New static functions.
(buf_init): buf-compress and buf-decompress intrinsics registered.

* txr.1: Documented.

* stdlib/doc-syms.tl: Updated.

3 files changed, 119 insertions, 0 deletions

diff --git a/buf.c b/buf.c
index 04e1a971..be728189 100644
--- a/buf.c
+++ b/buf.c
@@ -35,6 +35,9 @@
 #include <signal.h>
 #include <stdio.h>
 #include "config.h"
+#if HAVE_ZLIB
+#include <zlib.h>
+#endif
 #include "lib.h"
 #include "gc.h"
 #include "itypes.h"
@@ -1223,6 +1226,69 @@ static val uint_buf(val buf)
   return normalize(ubn);
 }
 
+#if HAVE_ZLIB
+
+static val buf_compress(val buf, val level_opt)
+{
+  val self = lit("buf-compress");
+  val level = default_arg(level_opt, num_fast(6));
+  int lev = c_int(level, self);
+  struct buf *b = buf_handle(buf, self);
+  ucnum size = c_unum(b->len, self);
+  uLong bound = compressBound(size), zsize = bound;
+  mem_t *zdata = chk_malloc(bound);
+
+  if (convert(uLong, size) != size) {
+    free(zdata);
+    uw_throwf(error_s, lit("~a: array size overflow"), self, nao);
+  }
+
+  if (compress2(zdata, &zsize, b->data, size, lev) != Z_OK) {
+    free(zdata);
+    uw_throwf(error_s, lit("~a: compression failed"), self, nao);
+  }
+
+  zdata = chk_realloc(zdata, zsize);
+  return make_owned_buf(unum(zsize), zdata);
+}
+
+static val buf_decompress(val buf)
+{
+  val self = lit("buf-decompress");
+  struct buf *b = buf_handle(buf, self);
+  ucnum zsize = c_unum(b->len, self);
+  uLong zsz10 = 10 * zsize;
+  uLong size = if3(zsz10 > zsize, zsz10, convert(uLong, -1));
+  mem_t *data = chk_malloc(size);
+
+  for (;;) {
+    switch (uncompress(data, &size, b->data, zsize)) {
+    case Z_OK:
+      data = chk_realloc(data, size);
+      return make_owned_buf(unum(size), data);
+    case Z_BUF_ERROR:
+      if (size == convert(uLong, -1))
+        break;
+      if (size * 2 > size)
+        size = size * 2;
+      else if (size == convert(uLong, -1))
+        break;
+      else
+        size  = convert(uLong, -1);
+      data = chk_realloc(data, size);
+      continue;
+    default:
+      break;
+    }
+    break;
+  }
+
+  free(data);
+  uw_throwf(error_s, lit("~a: decompression failed"), self, nao);
+}
+
+#endif
+
 void buf_init(void)
 {
   reg_fun(intern(lit("make-buf"), user_package), func_n3o(make_buf, 1));
@@ -1311,5 +1377,10 @@ void buf_init(void)
   reg_fun(intern(lit("int-buf"), user_package), func_n1(int_buf));
   reg_fun(intern(lit("uint-buf"), user_package), func_n1(uint_buf));
 
+#if HAVE_ZLIB
+  reg_fun(intern(lit("buf-compress"), user_package), func_n2o(buf_compress, 1));
+  reg_fun(intern(lit("buf-decompress"), user_package), func_n1(buf_decompress));
+#endif
+
   fill_stream_ops(&buf_strm_ops);
 }
diff --git a/stdlib/doc-syms.tl b/stdlib/doc-syms.tl
index ea778779..b9956422 100644
--- a/stdlib/doc-syms.tl
+++ b/stdlib/doc-syms.tl
@@ -175,7 +175,9 @@
       ("buf" "D-005E")
       ("buf-alloc-size" "N-013A3727")
       ("buf-carray" "N-0022F54E")
+      ("buf-compress" "N-02DB9DFB")
       ("buf-d" "D-0014")
+      ("buf-decompress" "N-02DB9DFB")
       ("buf-get-char" "N-03E9074A")
       ("buf-get-cptr" "N-00E90766")
       ("buf-get-double" "N-006C6EB9")
diff --git a/txr.1 b/txr.1
index b230458c..6279ece1 100644
--- a/txr.1
+++ b/txr.1
@@ -28392,6 +28392,52 @@ is of integer type and, in the case of
 .codn buf-uint ,
 nonnegative.
 
+.coNP Functions @ buf-compress and @ buf-decompress
+.synb
+.mets (buf-compress < buf <> [ level ])
+.mets (buf-decompress << buf )
+.syne
+.desc
+The
+.code buf-compress
+and
+.code buf-decompress
+functions perform compression using the Deflate algorithm, via Zlib.
+These functions are only available if \*(TX is built with Zlib support.
+More specifically,
+.code buf-compress
+uses Zlib's
+.code compress2
+function; therefore it can be expected to interoperate with other software
+which uses the same function.
+
+The
+.code buf-compress
+function compresses the entire contents of
+.meta buf
+and returns new buffer with the compressed contents. The optional
+.meta level
+argument specifies the compression level as an integer, which defaults to 6.
+Valid values range from 0 to 9: no compression, to maximum.
+
+The
+.code buf-decompress
+function reverses the
+.code buf-compress
+operation: it takes a compressed
+.meta buf
+and returns a buffer containing the original uncompressed data.
+
+The
+.code buf-compress
+function throws an error exception if the
+.meta level
+value is unacceptable to Zlib. The
+.code buf-decompress
+function throws an error exception if
+.meta buf
+doesn't contain a compressed image.
+
 .SS* Structures
 
 \*(TX supports user-defined types in the form of structures. Structures