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. *)
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 = [
=back";
- "close", (RErr, [AHive]),
+ "close", (RErrDispose, [AHive]),
"close a hive handle",
"\
Close a hive handle and free all associated resources.
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",
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 *"
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.
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.
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
git.annexia.org / hivex.git / commitdiff