perl: Fix generated XS code for value_dword binding.
[hivex.git] / generator / generator.ml
index 830597b..5bd46ee 100755 (executable)
@@ -71,6 +71,7 @@ and argt =                              (* Note, cannot be NULL/0 unless it
   | AOpenFlags                          (* HIVEX_OPEN_* flags list. *)
   | AUnusedFlags                        (* Flags arg that is always 0 *)
   | ASetValues                          (* See hivex_node_set_values. *)
+  | ASetValue                           (* See hivex_node_set_value. *)
 
 (* Hive types, from:
  * https://secure.wikimedia.org/wikipedia/en/wiki/Windows_Registry#Keys_and_values
@@ -304,8 +305,16 @@ subnodes become invalid.  You cannot delete the root node.";
     "set (key, value) pairs at a node",
     "\
 This call can be used to set all the (key, value) pairs
-stored in C<node>.  Note that this library does not offer
-a way to modify just a single key at a node.
+stored in C<node>.
+
+C<node> is the node to modify.";
+
+  "node_set_value", (RErr, [AHive; ANode "node"; ASetValue; AUnusedFlags]),
+    "set a single (key, value) pair at a given node",
+    "\
+This call can be used to replace a single (key, value) pair
+stored in C<node>. If the key does not already exist, then a
+new key is added. Key matching is case insensitive.
 
 C<node> is the node to modify.";
 ]
@@ -459,6 +468,7 @@ let name_of_argt = function
   | ANode n | AValue n | AString n | AStringNullable n -> n
   | AOpenFlags | AUnusedFlags -> "flags"
   | ASetValues -> "values"
+  | ASetValue -> "val"
 
 (* Check function names etc. for consistency. *)
 let check_functions () =
@@ -806,6 +816,7 @@ and generate_c_prototype ?(extern = false) name style =
       | AString n | AStringNullable n -> pr "const char *%s" n
       | AOpenFlags | AUnusedFlags -> pr "int flags"
       | ASetValues -> pr "size_t nr_values, const hive_set_value *values"
+      | ASetValue -> pr "const hive_set_value *val"
   ) (snd style);
   (match fst style with
    | RLenType | RLenTypeVal -> pr ", hive_type *t, size_t *len"
@@ -937,6 +948,11 @@ Any existing values stored at the node are discarded, and their
 C<hive_value_h> handles become invalid.  Thus you can remove all
 values stored at C<node> by passing C<nr_values = 0>.\n\n";
 
+      if List.mem ASetValue (snd style) then
+       pr "C<value> is a single (key, value) pair.
+
+Existing C<hive_value_h> handles become invalid.\n\n";
+
       (match fst style with
        | RErr ->
            pr "\
@@ -990,7 +1006,7 @@ On error this returns NULL and sets errno.\n\n"
        | RLenType ->
            pr "\
 Returns 0 on success.
-On error this returns NULL and sets errno.\n\n"
+On error this returns -1 and sets errno.\n\n"
        | RLenTypeVal ->
            pr "\
 The value is returned as an array of bytes (of length C<len>).
@@ -1321,6 +1337,32 @@ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 Lesser General Public License for more details.
 "
 
+(* Generate the linker script which controls the visibility of
+ * symbols in the public ABI and ensures no other symbols get
+ * exported accidentally.
+ *)
+and generate_linker_script () =
+  generate_header HashStyle GPLv2plus;
+
+  let globals = [
+    "hivex_visit";
+    "hivex_visit_node"
+  ] in
+
+  let functions =
+    List.map (fun (name, _, _, _) -> "hivex_" ^ name)
+      functions in
+  let globals = List.sort compare (globals @ functions) in
+
+  pr "{\n";
+  pr "    global:\n";
+  List.iter (pr "        %s;\n") globals;
+  pr "\n";
+
+  pr "    local:\n";
+  pr "        *;\n";
+  pr "};\n"
+
 and generate_ocaml_interface () =
   generate_header OCamlStyle LGPLv2plus;
 
@@ -1452,6 +1494,7 @@ and generate_ocaml_prototype ?(is_external = false) name style =
     | AOpenFlags -> pr "open_flag list -> "
     | AUnusedFlags -> ()
     | ASetValues -> pr "set_value array -> "
+    | ASetValue -> pr "set_value -> "
   ) (snd style);
   (match fst style with
    | RErr -> pr "unit" (* all errors are turned into exceptions *)
@@ -1493,13 +1536,36 @@ and generate_ocaml_c () =
 #include <caml/memory.h>
 #include <caml/mlvalues.h>
 #include <caml/signals.h>
+
+#ifdef HAVE_CAML_UNIXSUPPORT_H
 #include <caml/unixsupport.h>
+#else
+extern value unix_error_of_code (int errcode);
+#endif
+
+#ifndef HAVE_CAML_RAISE_WITH_ARGS
+static void
+caml_raise_with_args (value tag, int nargs, value args[])
+{
+  CAMLparam1 (tag);
+  CAMLxparamN (args, nargs);
+  value bucket;
+  int i;
+
+  bucket = caml_alloc_small (1 + nargs, 0);
+  Field(bucket, 0) = tag;
+  for (i = 0; i < nargs; i++) Field(bucket, 1 + i) = args[i];
+  caml_raise(bucket);
+  CAMLnoreturn;
+}
+#endif
 
 #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 *HiveSetValue_val (value);
 static hive_set_value *HiveSetValues_val (value);
 static hive_type HiveType_val (value);
 static value Val_hive_type (hive_type);
@@ -1573,6 +1639,8 @@ static void raise_closed (const char *) Noreturn;
         | ASetValues ->
             pr "  int nrvalues = Wosize_val (valuesv);\n";
             pr "  hive_set_value *values = HiveSetValues_val (valuesv);\n"
+       | ASetValue ->
+           pr "  hive_set_value *val = HiveSetValue_val (valv);\n"
       ) (snd style);
       pr "\n";
 
@@ -1640,6 +1708,9 @@ static void raise_closed (const char *) Noreturn;
         | ASetValues ->
             pr "  free (values);\n";
             pr "\n";
+       | ASetValue ->
+           pr "  free (val);\n";
+           pr "\n";
       ) (snd style);
 
       (* Check for errors. *)
@@ -1702,6 +1773,19 @@ HiveOpenFlags_val (value v)
 }
 
 static hive_set_value *
+HiveSetValue_val (value v)
+{
+  hive_set_value *val = malloc (sizeof (hive_set_value));
+
+  val->key = String_val (Field (v, 0));
+  val->t = HiveType_val (Field (v, 1));
+  val->len = caml_string_length (Field (v, 2));
+  val->value = String_val (Field (v, 2));
+
+  return val;
+}
+
+static hive_set_value *
 HiveSetValues_val (value v)
 {
   size_t nr_values = Wosize_val (v);
@@ -1901,7 +1985,7 @@ XSLoader::load ('Win::Hivex');
 
 =item open
 
- $h = Win::Hivex::open ($filename,";
+ $h = Win::Hivex->open ($filename,";
 
   List.iter (
     fun (_, flag, _) ->
@@ -2065,6 +2149,7 @@ and generate_perl_prototype name style =
       | AOpenFlags -> pr "[flags]"
       | AUnusedFlags -> assert false
       | ASetValues -> pr "\\@values"
+      | ASetValue -> pr "$val"
   ) args;
 
   pr ")"
@@ -2195,6 +2280,39 @@ unpack_pl_set_values (SV *sv)
   return ret;
 }
 
+static hive_set_value *
+unpack_set_value (SV *sv)
+{
+  hive_set_value *ret;
+
+  if (!sv || !SvROK (sv) || SvTYPE (SvRV (sv)) != SVt_PVHV)
+    croak (\"not a hash ref\");
+
+  ret = malloc (sizeof (hive_set_value));
+  if (ret == NULL)
+    croak (\"malloc failed\");
+
+  HV *hv = (HV *)SvRV(sv);
+
+  SV **svp;
+  svp = hv_fetch (hv, \"key\", 3, 0);
+  if (!svp || !*svp)
+    croak (\"missing 'key' in hash\");
+  ret->key = SvPV_nolen (*svp);
+
+  svp = hv_fetch (hv, \"t\", 1, 0);
+  if (!svp || !*svp)
+    croak (\"missing 't' in hash\");
+  ret->t = SvIV (*svp);
+
+  svp = hv_fetch (hv, \"value\", 5, 0);
+  if (!svp || !*svp)
+    croak (\"missing 'value' in hash\");
+  ret->value = SvPV (*svp, ret->len);
+
+  return ret;
+}
+
 MODULE = Win::Hivex  PACKAGE = Win::Hivex
 
 PROTOTYPES: ENABLE
@@ -2271,6 +2389,8 @@ DESTROY (h)
            | AUnusedFlags -> ()
            | ASetValues ->
                pr "      pl_set_values values = unpack_pl_set_values (ST(%d));\n" i
+           | ASetValue ->
+               pr "      hive_set_value *val = unpack_set_value (ST(%d));\n" i
        ) (snd style);
 
        let free_args () =
@@ -2278,6 +2398,8 @@ DESTROY (h)
            function
            | ASetValues ->
                pr "      free (values.values);\n"
+           | ASetValue ->
+               pr "      free (val);\n"
            | AHive | ANode _ | AValue _ | AString _ | AStringNullable _
            | AOpenFlags | AUnusedFlags -> ()
          ) (snd style)
@@ -2299,7 +2421,6 @@ DESTROY (h)
         | RErrDispose -> assert false
         | RHive -> assert false
 
-        | RInt32
         | RNode
         | RValue ->
              pr "PREINIT:\n";
@@ -2393,7 +2514,7 @@ DESTROY (h)
             pr "      size_t len;\n";
             pr "      hive_type type;\n";
             pr " PPCODE:\n";
-             pr "      r = hivex_%s (%s, &len, &type);\n"
+             pr "      r = hivex_%s (%s, &type, &len);\n"
               name (String.concat ", " c_params);
             free_args ();
              pr "      if (r == -1)\n";
@@ -2409,7 +2530,7 @@ DESTROY (h)
             pr "      size_t len;\n";
             pr "      hive_type type;\n";
             pr " PPCODE:\n";
-             pr "      r = hivex_%s (%s, &len, &type);\n"
+             pr "      r = hivex_%s (%s, &type, &len);\n"
               name (String.concat ", " c_params);
             free_args ();
              pr "      if (r == NULL)\n";
@@ -2417,9 +2538,24 @@ DESTROY (h)
               name;
             pr "      EXTEND (SP, 2);\n";
             pr "      PUSHs (sv_2mortal (newSViv (type)));\n";
-            pr "      PUSHs (sv_2mortal (newSVpv (r, len)));\n";
+            pr "      PUSHs (sv_2mortal (newSVpvn (r, len)));\n";
             pr "      free (r);\n";
 
+        | RInt32 ->
+             pr "PREINIT:\n";
+             pr "      int32_t r;\n";
+             pr "   CODE:\n";
+            pr "      errno = 0;\n";
+             pr "      r = hivex_%s (%s);\n"
+              name (String.concat ", " c_params);
+            free_args ();
+             pr "      if (r == -1 && errno != 0)\n";
+             pr "        croak (\"%%s: %%s\", \"%s\", strerror (errno));\n"
+              name;
+             pr "      RETVAL = newSViv (r);\n";
+             pr " OUTPUT:\n";
+             pr "      RETVAL\n"
+
         | RInt64 ->
              pr "PREINIT:\n";
              pr "      int64_t r;\n";
@@ -2500,6 +2636,8 @@ Run it from the top source directory using the command
   output_to "lib/hivex.h" generate_c_header;
   output_to "lib/hivex.pod" generate_c_pod;
 
+  output_to "lib/hivex.syms" generate_linker_script;
+
   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;
@@ -2507,8 +2645,11 @@ Run it from the top source directory using the command
   output_to "perl/lib/Win/Hivex.pm" generate_perl_pm;
   output_to "perl/Hivex.xs" generate_perl_xs;
 
+(*
+  We ran out of time before we could write the Python bindings.
   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.