X-Git-Url: http://git.annexia.org/?p=hivex.git;a=blobdiff_plain;f=generator%2Fgenerator.ml;h=71c3b4fc206499b05c5c1f32b749bc3789b73830;hp=fe12c0b8f808b4af5765ad3076ed17e8a92508df;hb=095c395082d1aad1e8558aa25514ad911e6d193c;hpb=0414ad324c67f8a4e780906dfdf0b40b91235fa4 diff --git a/generator/generator.ml b/generator/generator.ml index fe12c0b..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. =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_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, 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", @@ -733,8 +733,11 @@ struct hive_set_value { char *value; }; typedef struct hive_set_value hive_set_value; + "; + pr "/* Functions. */\n"; + (* Function declarations. *) List.iter ( fun (shortname, style, _, _) -> @@ -783,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 *" @@ -931,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. @@ -939,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. @@ -1298,6 +1315,554 @@ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. " +and generate_ocaml_interface () = + generate_header OCamlStyle LGPLv2plus; + + 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 "\ +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; + + pr "\ +#include + +#include +#include +#include +#include +#include + +#include +#include +#include +#include +#include +#include +#include +#include +#include + +#include + +#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 + +and generate_perl_xs () = + generate_header CStyle LGPLv2plus + +and generate_python_py () = + generate_header HashStyle LGPLv2plus + +and generate_python_c () = + generate_header CStyle LGPLv2plus + let output_to filename k = let filename_new = filename ^ ".new" in chan := open_out filename_new; @@ -1350,8 +1915,18 @@ Run it from the top source directory using the command check_functions (); - output_to "hivex/hivex.h" generate_c_header; - output_to "hivex/hivex.pod" generate_c_pod; + output_to "lib/hivex.h" generate_c_header; + output_to "lib/hivex.pod" generate_c_pod; + + output_to "ocaml/hivex.mli" generate_ocaml_interface; + output_to "ocaml/hivex.ml" generate_ocaml_implementation; + output_to "ocaml/hivex_c.c" generate_ocaml_c; + + output_to "perl/lib/Win/Hivex.pm" generate_perl_pm; + output_to "perl/Hivex.xs" generate_perl_xs; + + output_to "python/hivex.py" generate_python_py; + output_to "python/hivex-py.c" generate_python_c; (* Always generate this file last, and unconditionally. It's used * by the Makefile to know when we must re-run the generator.