generator: Add OCaml bindings.

Also we tighten up the definition of hivex_close (it disposes of handles)
and hivex_node_get_child (unusual "not found" non-error condition).

This also adds tests of the OCaml bindings.

9 files changed, 882 insertions, 10 deletions

diff --git a/.gitignore b/.gitignore
index 5ecefaa..997bbcf 100644
--- a/.gitignore
+++ b/.gitignore
@@ -60,6 +60,12 @@ ocaml/hivex_c.c
 ocaml/META
 ocaml/*.so
 ocaml/t/hivex_005_load
+ocaml/t/hivex_010_open
+ocaml/t/hivex_020_root
+ocaml/t/hivex_100_errors
+ocaml/t/hivex_110_gc_handle
+ocaml/t/hivex_200_write
+ocaml/t/hivex_300_fold
 perl/blib
 perl/Hivex.bs
 perl/Hivex.c
diff --git a/generator/generator.ml b/generator/generator.ml
index 87afde3..71c3b4f 100755
--- a/generator/generator.ml
+++ b/generator/generator.ml
@@ -45,8 +45,10 @@ open Printf
 type style = ret * args
 and ret =
   | RErr                                (* 0 = ok, -1 = error *)
+  | RErrDispose                         (* Disposes handle, see hivex_close. *)
   | RHive                               (* Returns a hive_h or NULL. *)
   | RNode                               (* Returns hive_node_h or 0. *)
+  | RNodeNotFound                       (* See hivex_node_get_child. *)
   | RNodeList                           (* Returns hive_node_h* or NULL. *)
   | RValue                              (* Returns hive_value_h or 0. *)
   | RValueList                          (* Returns hive_value_h* or NULL. *)
@@ -103,6 +105,7 @@ let hive_types = [
   11, "qword", "QWORD",
     "QWORD (64 bit integer), unspecified endianness but usually little endian"
 ]
+let max_hive_type = 11
 
 (* Open flags (bitmask passed to AOpenFlags) *)
 let open_flags = [
@@ -143,7 +146,7 @@ See L<hivex(3)/WRITING TO HIVE FILES>.
 
 =back";
 
-  "close", (RErr, [AHive]),
+  "close", (RErrDispose, [AHive]),
     "close a hive handle",
     "\
 Close a hive handle and free all associated resources.
@@ -175,15 +178,12 @@ outside the scope of this library.";
 Return an array of nodes which are the subkeys
 (children) of C<node>.";
 
-  "node_get_child", (RNode, [AHive; ANode "node"; AString "name"]),
+  "node_get_child", (RNodeNotFound, [AHive; ANode "node"; AString "name"]),
     "return named child of node",
     "\
 Return the child of node with the name C<name>, if it exists.
 
-The name is matched case insensitively.
-
-If the child node does not exist, this returns 0 without
-setting errno.";
+The name is matched case insensitively.";
 
   "node_parent", (RNode, [AHive; ANode "node"]),
     "return the parent of node",
@@ -786,8 +786,10 @@ and generate_c_prototype ?(extern = false) name style =
   if extern then pr "extern ";
   (match fst style with
    | RErr -> pr "int "
+   | RErrDispose -> pr "int "
    | RHive -> pr "hive_h *"
    | RNode -> pr "hive_node_h "
+   | RNodeNotFound -> pr "hive_node_h "
    | RNodeList -> pr "hive_node_h *"
    | RValue -> pr "hive_value_h "
    | RValueList -> pr "hive_value_h *"
@@ -934,6 +936,13 @@ here.  Often it's not documented at all.
            pr "\
 Returns 0 on success.
 On error this returns -1 and sets errno.\n\n"
+       | RErrDispose ->
+           pr "\
+Returns 0 on success.
+On error this returns -1 and sets errno.
+
+This function frees the hive handle (even if it returns an error).
+The hive handle must not be used again after calling this function.\n\n"
        | RHive ->
            pr "\
 Returns a new hive handle.
@@ -942,6 +951,11 @@ On error this returns NULL and sets errno.\n\n"
            pr "\
 Returns a node handle.
 On error this returns 0 and sets errno.\n\n"
+       | RNodeNotFound ->
+           pr "\
+Returns a node handle.
+If the node was not found, this returns 0 without setting errno.
+On error this returns 0 and sets errno.\n\n"
        | RNodeList ->
            pr "\
 Returns a 0-terminated array of nodes.
@@ -1303,14 +1317,539 @@ Lesser General Public License for more details.
 
 and generate_ocaml_interface () =
   generate_header OCamlStyle LGPLv2plus;
-  pr "val open_file : unit\n"
+
+  pr "\
+type t
+(** A [hive_h] hive file handle. *)
+
+type node
+type value
+(** Nodes and values. *)
+
+exception Error of string * Unix.error * string
+(** Error raised by a function.
+
+    The first parameter is the name of the function which raised the error.
+    The second parameter is the errno (see the [Unix] module).  The third
+    parameter is a human-readable string corresponding to the errno.
+
+    See hivex(3) for a partial list of interesting errno values that
+    can be generated by the library. *)
+exception Handle_closed of string
+(** This exception is raised if you call a function on a closed handle. *)
+
+type hive_type =
+";
+  iteri (
+    fun i ->
+      fun (t, _, new_style, description) ->
+        assert (i = t);
+        pr "  | REG_%s (** %s *)\n" new_style description
+  ) hive_types;
+
+  pr "\
+  | REG_UNKNOWN of int32 (** unknown type *)
+(** Hive type field. *)
+
+type open_flag =
+";
+  iteri (
+    fun i ->
+      fun (v, flag, description) ->
+        assert (1 lsl i = v);
+        pr "  | OPEN_%s (** %s *)\n" flag description
+  ) open_flags;
+
+  pr "\
+(** Open flags for {!open_file} call. *)
+
+type set_value = {
+  key : string;
+  t : hive_type;
+  value : string;
+}
+(** (key, value) pair passed (as an array) to {!node_set_values}. *)
+";
+
+  List.iter (
+    fun (name, style, shortdesc, _) ->
+      pr "\n";
+      generate_ocaml_prototype name style;
+      pr "(** %s *)\n" shortdesc
+  ) functions
 
 and generate_ocaml_implementation () =
   generate_header OCamlStyle LGPLv2plus;
-  pr "let open_file = ()\n"
+
+  pr "\
+type t
+type node = int
+type value = int
+
+exception Error of string * Unix.error * string
+exception Handle_closed of string
+
+(* Give the exceptions names, so they can be raised from the C code. *)
+let () =
+  Callback.register_exception \"ocaml_hivex_error\"
+    (Error (\"\", Unix.EUNKNOWNERR 0, \"\"));
+  Callback.register_exception \"ocaml_hivex_closed\" (Handle_closed \"\")
+
+type hive_type =
+";
+  iteri (
+    fun i ->
+      fun (t, _, new_style, _) ->
+        assert (i = t);
+        pr "  | REG_%s\n" new_style
+  ) hive_types;
+
+  pr "\
+  | REG_UNKNOWN of int32
+
+type open_flag =
+";
+  iteri (
+    fun i ->
+      fun (v, flag, description) ->
+        assert (1 lsl i = v);
+        pr "  | OPEN_%s (** %s *)\n" flag description
+  ) open_flags;
+
+  pr "\
+
+type set_value = {
+  key : string;
+  t : hive_type;
+  value : string;
+}
+
+";
+
+  List.iter (
+    fun (name, style, _, _) ->
+      generate_ocaml_prototype ~is_external:true name style
+  ) functions
+
+and generate_ocaml_prototype ?(is_external = false) name style =
+  let ocaml_name = if name = "open" then "open_file" else name in
+
+  if is_external then pr "external " else pr "val ";
+  pr "%s : " ocaml_name;
+  List.iter (
+    function
+    | AHive -> pr "t -> "
+    | ANode _ -> pr "node -> "
+    | AValue _ -> pr "value -> "
+    | AString _ -> pr "string -> "
+    | AStringNullable _ -> pr "string option -> "
+    | AOpenFlags -> pr "open_flag list -> "
+    | AUnusedFlags -> ()
+    | ASetValues -> pr "set_value array -> "
+  ) (snd style);
+  (match fst style with
+   | RErr -> pr "unit" (* all errors are turned into exceptions *)
+   | RErrDispose -> pr "unit"
+   | RHive -> pr "t"
+   | RNode -> pr "node"
+   | RNodeNotFound -> pr "node"
+   | RNodeList -> pr "node array"
+   | RValue -> pr "value"
+   | RValueList -> pr "value array"
+   | RString -> pr "string"
+   | RStringList -> pr "string array"
+   | RLenType -> pr "hive_type * int"
+   | RLenTypeVal -> pr "hive_type * string"
+   | RInt32 -> pr "int32"
+   | RInt64 -> pr "int64"
+  );
+  if is_external then
+    pr " = \"ocaml_hivex_%s\"" name;
+  pr "\n"
 
 and generate_ocaml_c () =
-  generate_header CStyle LGPLv2plus
+  generate_header CStyle LGPLv2plus;
+
+  pr "\
+#include <config.h>
+
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <stdint.h>
+#include <errno.h>
+
+#include <caml/config.h>
+#include <caml/alloc.h>
+#include <caml/callback.h>
+#include <caml/custom.h>
+#include <caml/fail.h>
+#include <caml/memory.h>
+#include <caml/mlvalues.h>
+#include <caml/signals.h>
+#include <caml/unixsupport.h>
+
+#include <hivex.h>
+
+#define Hiveh_val(v) (*((hive_h **)Data_custom_val(v)))
+static value Val_hiveh (hive_h *);
+static int HiveOpenFlags_val (value);
+static hive_set_value *HiveSetValues_val (value);
+static hive_type HiveType_val (value);
+static value Val_hive_type (hive_type);
+static value copy_int_array (size_t *);
+static value copy_type_len (size_t, hive_type);
+static value copy_type_value (const char *, size_t, hive_type);
+static void raise_error (const char *) Noreturn;
+static void raise_closed (const char *) Noreturn;
+
+";
+
+  (* The wrappers. *)
+  List.iter (
+    fun (name, style, _, _) ->
+      pr "/* Automatically generated wrapper for function\n";
+      pr " * "; generate_ocaml_prototype name style;
+      pr " */\n";
+      pr "\n";
+
+      let c_params =
+        List.map (function
+                  | ASetValues -> ["nrvalues"; "values"]
+                  | AUnusedFlags -> ["0"]
+                  | arg -> [name_of_argt arg]) (snd style) in
+      let c_params =
+        match fst style with
+        | RLenType | RLenTypeVal -> c_params @ [["&t"; "&len"]]
+        | _ -> c_params in
+      let c_params = List.concat c_params in
+
+      let params =
+        filter_map (function
+                    | AUnusedFlags -> None
+                    | arg -> Some (name_of_argt arg ^ "v")) (snd style) in
+
+      pr "/* Emit prototype to appease gcc's -Wmissing-prototypes. */\n";
+      pr "CAMLprim value ocaml_hivex_%s (value %s" name (List.hd params);
+      List.iter (pr ", value %s") (List.tl params); pr ");\n";
+      pr "\n";
+
+      pr "CAMLprim value\n";
+      pr "ocaml_hivex_%s (value %s" name (List.hd params);
+      List.iter (pr ", value %s") (List.tl params);
+      pr ")\n";
+      pr "{\n";
+
+      pr "  CAMLparam%d (%s);\n"
+        (List.length params) (String.concat ", " params);
+      pr "  CAMLlocal1 (rv);\n";
+      pr "\n";
+
+      List.iter (
+        function
+        | AHive ->
+            pr "  hive_h *h = Hiveh_val (hv);\n";
+            pr "  if (h == NULL)\n";
+            pr "    raise_closed (\"%s\");\n" name
+        | ANode n ->
+            pr "  hive_node_h %s = Int_val (%sv);\n" n n
+        | AValue n ->
+            pr "  hive_value_h %s = Int_val (%sv);\n" n n
+        | AString n ->
+            pr "  const char *%s = String_val (%sv);\n" n n
+        | AStringNullable n ->
+            pr "  const char *%s =\n" n;
+            pr "    %sv != Val_int (0) ? String_val (Field (%sv, 0)) : NULL;\n"
+              n n
+        | AOpenFlags ->
+            pr "  int flags = HiveOpenFlags_val (flagsv);\n"
+        | AUnusedFlags -> ()
+        | ASetValues ->
+            pr "  int nrvalues = Wosize_val (valuesv);\n";
+            pr "  hive_set_value *values = HiveSetValues_val (valuesv);\n"
+      ) (snd style);
+      pr "\n";
+
+      let error_code =
+        match fst style with
+        | RErr -> pr "  int r;\n"; "-1"
+        | RErrDispose -> pr "  int r;\n"; "-1"
+        | RHive -> pr "  hive_h *r;\n"; "NULL"
+        | RNode -> pr "  hive_node_h r;\n"; "0"
+        | RNodeNotFound ->
+            pr "  errno = 0;\n";
+            pr "  hive_node_h r;\n";
+            "0 && errno != 0"
+        | RNodeList -> pr "  hive_node_h *r;\n"; "NULL"
+        | RValue -> pr "  hive_value_h r;\n"; "0"
+        | RValueList -> pr "  hive_value_h *r;\n"; "NULL"
+        | RString -> pr "  char *r;\n"; "NULL"
+        | RStringList -> pr "  char **r;\n"; "NULL"
+        | RLenType ->
+            pr "  int r;\n";
+            pr "  size_t len;\n";
+            pr "  hive_type t;\n";
+            "-1"
+        | RLenTypeVal ->
+            pr "  char *r;\n";
+            pr "  size_t len;\n";
+            pr "  hive_type t;\n";
+            "NULL"
+        | RInt32 ->
+            pr "  errno = 0;\n";
+            pr "  int32_t r;\n";
+            "-1 && errno != 0"
+        | RInt64 ->
+            pr "  errno = 0;\n";
+            pr "  int64_t r;\n";
+            "-1 && errno != 0" in
+
+      (* The libguestfs OCaml bindings call enter_blocking_section
+       * here.  However I don't think that is safe, because we are
+       * holding pointers to caml strings during the call, and these
+       * could be moved or freed by other threads.  In any case, there
+       * is very little reason to enter_blocking_section for any hivex
+       * call, so don't do it.  XXX
+       *)
+      (*pr "  caml_enter_blocking_section ();\n";*)
+      pr "  r = hivex_%s (%s" name (List.hd c_params);
+      List.iter (pr ", %s") (List.tl c_params);
+      pr ");\n";
+      (*pr "  caml_leave_blocking_section ();\n";*)
+      pr "\n";
+
+      (* Dispose of the hive handle (even if hivex_close returns error). *)
+      (match fst style with
+       | RErrDispose ->
+           pr "  /* So we don't double-free in the finalizer. */\n";
+           pr "  Hiveh_val (hv) = NULL;\n";
+           pr "\n";
+       | _ -> ()
+      );
+
+      List.iter (
+        function
+        | AHive | ANode _ | AValue _ | AString _ | AStringNullable _
+        | AOpenFlags | AUnusedFlags -> ()
+        | ASetValues ->
+            pr "  free (values);\n";
+            pr "\n";
+      ) (snd style);
+
+      (* Check for errors. *)
+      pr "  if (r == %s)\n" error_code;
+      pr "    raise_error (\"%s\");\n" name;
+      pr "\n";
+
+      (match fst style with
+       | RErr -> pr "  rv = Val_unit;\n"
+       | RErrDispose -> pr "  rv = Val_unit;\n"
+       | RHive -> pr "  rv = Val_hiveh (r);\n"
+       | RNode -> pr "  rv = Val_int (r);\n"
+       | RNodeNotFound ->
+           pr "  if (r == 0)\n";
+           pr "    caml_raise_not_found ();\n";
+           pr "\n";
+           pr "  rv = Val_int (r);\n"
+       | RNodeList ->
+           pr "  rv = copy_int_array (r);\n";
+           pr "  free (r);\n"
+       | RValue -> pr "  rv = Val_int (r);\n"
+       | RValueList ->
+           pr "  rv = copy_int_array (r);\n";
+           pr "  free (r);\n"
+       | RString ->
+           pr "  rv = caml_copy_string (r);\n";
+           pr "  free (r);\n"
+       | RStringList ->
+           pr "  rv = caml_copy_string_array ((const char **) r);\n";
+           pr "  for (int i = 0; r[i] != NULL; ++i) free (r[i]);\n";
+           pr "  free (r);\n"
+       | RLenType -> pr "  rv = copy_type_len (len, t);\n"
+       | RLenTypeVal ->
+           pr "  rv = copy_type_value (r, len, t);\n";
+           pr "  free (r);\n"
+       | RInt32 -> pr "  rv = caml_copy_int32 (r);\n"
+       | RInt64 -> pr "  rv = caml_copy_int32 (r);\n"
+      );
+
+      pr "  CAMLreturn (rv);\n";
+      pr "}\n";
+      pr "\n";
+
+  ) functions;
+
+  pr "\
+static int
+HiveOpenFlags_val (value v)
+{
+  int flags = 0;
+  value v2;
+
+  while (v != Val_int (0)) {
+    v2 = Field (v, 0);
+    flags |= 1 << Int_val (v2);
+    v = Field (v, 1);
+  }
+
+  return flags;
+}
+
+static hive_set_value *
+HiveSetValues_val (value v)
+{
+  size_t nr_values = Wosize_val (v);
+  hive_set_value *values = malloc (nr_values * sizeof (hive_set_value));
+  size_t i;
+  value v2;
+
+  for (i = 0; i < nr_values; ++i) {
+    v2 = Field (v, i);
+    values[i].key = String_val (Field (v2, 0));
+    values[i].t = HiveType_val (Field (v2, 1));
+    values[i].len = caml_string_length (Field (v2, 2));
+    values[i].value = String_val (Field (v2, 2));
+  }
+
+  return values;
+}
+
+static hive_type
+HiveType_val (value v)
+{
+  if (Is_long (v))
+    return Int_val (v); /* REG_NONE etc. */
+  else
+    return Int32_val (Field (v, 0)); /* REG_UNKNOWN of int32 */
+}
+
+static value
+Val_hive_type (hive_type t)
+{
+  CAMLparam0 ();
+  CAMLlocal2 (rv, v);
+
+  if (t <= %d)
+    CAMLreturn (Val_int (t));
+  else {
+    rv = caml_alloc (1, 0); /* REG_UNKNOWN of int32 */
+    v = caml_copy_int32 (t);
+    caml_modify (&Field (rv, 0), v);
+    CAMLreturn (rv);
+  }
+}
+
+static value
+copy_int_array (size_t *xs)
+{
+  CAMLparam0 ();
+  CAMLlocal2 (v, rv);
+  size_t nr, i;
+
+  for (nr = 0; xs[nr] != 0; ++nr)
+    ;
+  if (nr == 0)
+    CAMLreturn (Atom (0));
+  else {
+    rv = caml_alloc (nr, 0);
+    for (i = 0; i < nr; ++i) {
+      v = Val_int (xs[i]);
+      Store_field (rv, i, v); /* Safe because v is not a block. */
+    }
+    CAMLreturn (rv);
+  }
+}
+
+static value
+copy_type_len (size_t len, hive_type t)
+{
+  CAMLparam0 ();
+  CAMLlocal2 (v, rv);
+
+  rv = caml_alloc (2, 0);
+  v = Val_hive_type (t);
+  Store_field (rv, 0, v);
+  v = Val_int (len);
+  Store_field (rv, 1, len);
+  CAMLreturn (rv);
+}
+
+static value
+copy_type_value (const char *r, size_t len, hive_type t)
+{
+  CAMLparam0 ();
+  CAMLlocal2 (v, rv);
+
+  rv = caml_alloc (2, 0);
+  v = Val_hive_type (t);
+  Store_field (rv, 0, v);
+  v = caml_alloc_string (len);
+  memcpy (String_val (v), r, len);
+  caml_modify (&Field (rv, 1), len);
+  CAMLreturn (rv);
+}
+
+/* Raise exceptions. */
+static void
+raise_error (const char *function)
+{
+  /* Save errno early in case it gets trashed. */
+  int err = errno;
+
+  CAMLparam0 ();
+  CAMLlocal3 (v1, v2, v3);
+
+  v1 = caml_copy_string (function);
+  v2 = unix_error_of_code (err);
+  v3 = caml_copy_string (strerror (err));
+  value vvv[] = { v1, v2, v3 };
+  caml_raise_with_args (*caml_named_value (\"ocaml_hivex_error\"), 3, vvv);
+
+  CAMLnoreturn;
+}
+
+static void
+raise_closed (const char *function)
+{
+  CAMLparam0 ();
+  CAMLlocal1 (v);
+
+  v = caml_copy_string (function);
+  caml_raise_with_arg (*caml_named_value (\"ocaml_hivex_closed\"), v);
+
+  CAMLnoreturn;
+}
+
+/* Allocate handles and deal with finalization. */
+static void
+hivex_finalize (value hv)
+{
+  hive_h *h = Hiveh_val (hv);
+  if (h) hivex_close (h);
+}
+
+static struct custom_operations hivex_custom_operations = {
+  (char *) \"hivex_custom_operations\",
+  hivex_finalize,
+  custom_compare_default,
+  custom_hash_default,
+  custom_serialize_default,
+  custom_deserialize_default
+};
+
+static value
+Val_hiveh (hive_h *h)
+{
+  CAMLparam0 ();
+  CAMLlocal1 (rv);
+
+  rv = caml_alloc_custom (&hivex_custom_operations,
+                          sizeof (hive_h *), 0, 1);
+  Hiveh_val (rv) = h;
+
+  CAMLreturn (rv);
+}
+" max_hive_type
 
 and generate_perl_pm () =
   generate_header HashStyle LGPLv2plus
diff --git a/ocaml/Makefile.am b/ocaml/Makefile.am
index f7d26ce..b3f5e14 100644
--- a/ocaml/Makefile.am
+++ b/ocaml/Makefile.am
@@ -49,13 +49,44 @@ TESTS_ENVIRONMENT = \
 	LD_LIBRARY_PATH=$(top_builddir)/lib/.libs \
 	$(VG)
 
-TESTS = t/hivex_005_load
+TESTS = \
+	t/hivex_005_load \
+	t/hivex_010_open \
+	t/hivex_020_root \
+	t/hivex_100_errors \
+	t/hivex_110_gc_handle \
+	t/hivex_200_write \
+	t/hivex_300_fold
 noinst_DATA += $(TESTS)
 
 t/hivex_005_load: t/hivex_005_load.cmx mlhivex.cmxa
 	mkdir -p t
 	$(OCAMLFIND) ocamlopt -cclib -L$(top_builddir)/lib/.libs -I . -package unix -linkpkg mlhivex.cmxa $< -o $@
 
+t/hivex_010_open: t/hivex_010_open.cmx mlhivex.cmxa
+	mkdir -p t
+	$(OCAMLFIND) ocamlopt -cclib -L$(top_builddir)/lib/.libs -I . -package unix -linkpkg mlhivex.cmxa $< -o $@
+
+t/hivex_020_root: t/hivex_020_root.cmx mlhivex.cmxa
+	mkdir -p t
+	$(OCAMLFIND) ocamlopt -cclib -L$(top_builddir)/lib/.libs -I . -package unix -linkpkg mlhivex.cmxa $< -o $@
+
+t/hivex_100_errors: t/hivex_100_errors.cmx mlhivex.cmxa
+	mkdir -p t
+	$(OCAMLFIND) ocamlopt -cclib -L$(top_builddir)/lib/.libs -I . -package unix -linkpkg mlhivex.cmxa $< -o $@
+
+t/hivex_110_gc_handle: t/hivex_110_gc_handle.cmx mlhivex.cmxa
+	mkdir -p t
+	$(OCAMLFIND) ocamlopt -cclib -L$(top_builddir)/lib/.libs -I . -package unix -linkpkg mlhivex.cmxa $< -o $@
+
+t/hivex_200_write: t/hivex_200_write.cmx mlhivex.cmxa
+	mkdir -p t
+	$(OCAMLFIND) ocamlopt -cclib -L$(top_builddir)/lib/.libs -I . -package unix -linkpkg mlhivex.cmxa $< -o $@
+
+t/hivex_300_fold: t/hivex_300_fold.cmx mlhivex.cmxa
+	mkdir -p t
+	$(OCAMLFIND) ocamlopt -cclib -L$(top_builddir)/lib/.libs -I . -package unix -linkpkg mlhivex.cmxa $< -o $@
+
 # Need to rebuild the tests from source if the main library has
 # changed at all, otherwise we get inconsistent assumptions.
 t/%.cmx: t/%.ml mlhivex.cmxa
diff --git a/ocaml/t/hivex_010_open.ml b/ocaml/t/hivex_010_open.ml
new file mode 100644
index 0000000..5a74a7b
--- /dev/null
+++ b/ocaml/t/hivex_010_open.ml
@@ -0,0 +1,33 @@
+(* hivex OCaml bindings
+ * Copyright (C) 2009-2010 Red Hat Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * 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
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+ *)
+
+(* Test that we can open, read in and close a hive file. *)
+
+open Unix
+open Printf
+let (//) = Filename.concat
+let srcdir = try Sys.getenv "srcdir" with Not_found -> "."
+
+let () =
+  let h = Hivex.open_file (srcdir // "../images/minimal") [] in
+  Hivex.close h;
+
+  (* Gc.compact is a good way to ensure we don't have
+   * heap corruption or double-freeing.
+   *)
+  Gc.compact ()
diff --git a/ocaml/t/hivex_020_root.ml b/ocaml/t/hivex_020_root.ml
new file mode 100644
index 0000000..d11c991
--- /dev/null
+++ b/ocaml/t/hivex_020_root.ml
@@ -0,0 +1,34 @@
+(* hivex OCaml bindings
+ * Copyright (C) 2009-2010 Red Hat Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * 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
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+ *)
+
+(* Test that the root of the minimal hive exists. *)
+
+open Unix
+open Printf
+let (//) = Filename.concat
+let srcdir = try Sys.getenv "srcdir" with Not_found -> "."
+
+let () =
+  let h = Hivex.open_file (srcdir // "../images/minimal") [] in
+  ignore (Hivex.root h);
+  Hivex.close h;
+
+  (* Gc.compact is a good way to ensure we don't have
+   * heap corruption or double-freeing.
+   *)
+  Gc.compact ()
diff --git a/ocaml/t/hivex_100_errors.ml b/ocaml/t/hivex_100_errors.ml
new file mode 100644
index 0000000..0577632
--- /dev/null
+++ b/ocaml/t/hivex_100_errors.ml
@@ -0,0 +1,69 @@
+(* hivex OCaml bindings
+ * Copyright (C) 2009-2010 Red Hat Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * 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
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+ *)
+
+(* Test different types of error handling used by the API. *)
+
+open Unix
+open Printf
+let (//) = Filename.concat
+let srcdir = try Sys.getenv "srcdir" with Not_found -> "."
+
+let () =
+  printf "01 non-existent file\n%!";
+  (try
+     ignore (Hivex.open_file "no_such_file" []);
+     failwith "no exception thrown when opening a non-existent file"
+   with
+   | Hivex.Error ("open", ENOENT, _) -> () (* ok *)
+   (* let any other exception escape and stop the test *)
+  );
+
+  printf "02 closed handle\n%!";
+  let h = Hivex.open_file (srcdir // "../images/minimal") [] in
+  Hivex.close h;
+  (try
+     ignore (Hivex.root h)
+   with
+   | Hivex.Handle_closed "root" -> () (* ok *)
+   (* let any other exception escape and stop the test *)
+  );
+
+  printf "03 write to read-only file\n%!";
+  let h = Hivex.open_file (srcdir // "../images/minimal") [] in
+  (try
+     ignore (Hivex.node_add_child h (Hivex.root h) "Foo")
+   with
+   | Hivex.Error ("node_add_child", EROFS, _) -> () (* ok *)
+   (* let any other exception escape and stop the test *)
+  );
+  Hivex.close h;
+
+  printf "04 node_get_child node not found\n%!";
+  let h = Hivex.open_file (srcdir // "../images/minimal") [] in
+  (try
+     ignore (Hivex.node_get_child h (Hivex.root h) "NoSuchNode")
+   with
+   | Not_found -> () (* ok *)
+   (* let any other exception escape and stop the test *)
+  );
+  Hivex.close h;
+
+  (* Gc.compact is a good way to ensure we don't have
+   * heap corruption or double-freeing.
+   *)
+  Gc.compact ()
diff --git a/ocaml/t/hivex_110_gc_handle.ml b/ocaml/t/hivex_110_gc_handle.ml
new file mode 100644
index 0000000..0820a89
--- /dev/null
+++ b/ocaml/t/hivex_110_gc_handle.ml
@@ -0,0 +1,32 @@
+(* hivex OCaml bindings
+ * Copyright (C) 2009-2010 Red Hat Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * 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
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+ *)
+
+(* Test that the handle is GC'd (closed) when unreachable.
+ *
+ * XXX Actually we cannot really test that, but at least make
+ * sure there is no error.
+ *)
+
+open Unix
+open Printf
+let (//) = Filename.concat
+let srcdir = try Sys.getenv "srcdir" with Not_found -> "."
+
+let () =
+  ignore (Hivex.open_file (srcdir // "../images/minimal") []);
+  Gc.compact ()
diff --git a/ocaml/t/hivex_200_write.ml b/ocaml/t/hivex_200_write.ml
new file mode 100644
index 0000000..f70deee
--- /dev/null
+++ b/ocaml/t/hivex_200_write.ml
@@ -0,0 +1,75 @@
+(* hivex OCaml bindings
+ * Copyright (C) 2009-2010 Red Hat Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * 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
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+ *)
+
+(* Test some significant write operations.  Take the minimal hive
+ * and algorithmically construct a large, deep hive.
+ *)
+
+open Unix
+open Printf
+let (//) = Filename.concat
+let srcdir = try Sys.getenv "srcdir" with Not_found -> "."
+
+let () =
+  let h = Hivex.open_file (srcdir // "../images/minimal") [Hivex.OPEN_WRITE] in
+
+  let degrees = [| 3; 1; 4; 1; 5; 9; 2 |] (* ~1000 nodes *) in
+  let numbers = [| "Zero"; "One"; "Two"; "Three"; "Four";
+                   "Five"; "Six"; "Seven"; "Eight"; "Nine" |] in
+  let animals = [| "Horse"; "Ant"; "Mouse"; "Rabbit"; "Cat";
+                   "Giraffe"; "Kangaroo"; "Tiger"; "Zebra"; "Elephant" |] in
+
+  let rec iter depth posn parent =
+    if depth < Array.length degrees then (
+      let degree = degrees.(depth) in
+      for i = 0 to degree-1 do
+        let node_name = numbers.(depth) ^ " " ^ animals.(i) in
+        let node = Hivex.node_add_child h parent node_name in
+        iter (depth+1) i node
+      done;
+      let values = Array.init (10-posn) (
+        fun i ->
+          { Hivex.key = animals.(i);
+            t = Hivex.REG_SZ;
+            value = utf16le_of_ascii numbers.(i) }
+      ) in
+      Hivex.node_set_values h parent values
+    )
+
+  (* Make a nul-terminated UTF16-LE string from an ASCII string. *)
+  and utf16le_of_ascii str =
+    let len = String.length str in
+    let len' = len * 2 + 2 in
+    let str' = String.create len' in
+    for i = 0 to len-1 do
+      str'.[i*2] <- str.[i];
+      str'.[i*2+1] <- '\000'
+    done;
+    str'.[len'-2] <- '\000';
+    str'.[len'-1] <- '\000';
+    str'
+  in
+  iter 0 0 (Hivex.root h);
+
+  (* Discard the changes. *)
+  Hivex.close h;
+
+  (* Gc.compact is a good way to ensure we don't have
+   * heap corruption or double-freeing.
+   *)
+  Gc.compact ()
diff --git a/ocaml/t/hivex_300_fold.ml b/ocaml/t/hivex_300_fold.ml
new file mode 100644
index 0000000..0c7bc4f
--- /dev/null
+++ b/ocaml/t/hivex_300_fold.ml
@@ -0,0 +1,53 @@
+(* hivex OCaml bindings
+ * Copyright (C) 2009-2010 Red Hat Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * 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
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+ *)
+
+(* Fold over the large hive. *)
+
+open Unix
+open Printf
+let (//) = Filename.concat
+let srcdir = try Sys.getenv "srcdir" with Not_found -> "."
+
+(* This is a generic function to fold over hives.
+ *   fn : 'a -> node -> 'a is called for each node
+ *   fv : 'a -> node -> value array -> 'a is called for the values at each node
+ *)
+let hive_fold h fn fv a root =
+  let rec fold a node =
+    let a = fn a node in
+    let a = fv a node (Hivex.node_values h node) in
+    Array.fold_left fold a (Hivex.node_children h node)
+  in
+  fold a root
+
+let () =
+  let h = Hivex.open_file (srcdir // "../images/large") [] in
+
+  (* Count the number of nodes and values in the hive. *)
+  let count_node (nodes, values) _ = (nodes+1, values) in
+  let count_values (nodes, values) _ vs = (nodes, values + Array.length vs) in
+  let root = Hivex.root h in
+  let (nodes, values) = hive_fold h count_node count_values (0, 0) root in
+  printf "large test hive contains %d nodes and %d values\n%!" nodes values;
+
+  Hivex.close h;
+
+  (* Gc.compact is a good way to ensure we don't have
+   * heap corruption or double-freeing.
+   *)
+  Gc.compact ()