X-Git-Url: http://git.annexia.org/?p=libguestfs.git;a=blobdiff_plain;f=generator%2Fgenerator_perl.ml;h=96b8dd18b9b763ad1be2e7ff2da3ef0cc9e8762a;hp=3ff060b8586df7e755c5c6ae88cedf52918098d9;hb=bf3b9e2e236b4dd2216200993ba39545ad5160bb;hpb=04d8209077d2227eb1d42695ba71147f78987050

diff --git a/generator/generator_perl.ml b/generator/generator_perl.ml
index 3ff060b..96b8dd1 100644
--- a/generator/generator_perl.ml
+++ b/generator/generator_perl.ml
@@ -199,8 +199,8 @@ clear_progress_callback (g)
 ";
 
   List.iter (
-    fun (name, style, _, _, _, _, _) ->
-      (match fst style with
+    fun (name, (ret, args, optargs as style), _, _, _, _, _) ->
+      (match ret with
        | RErr -> pr "void\n"
        | RInt _ -> pr "SV *\n"
        | RInt64 _ -> pr "SV *\n"
@@ -218,7 +218,9 @@ clear_progress_callback (g)
       pr "%s (g" name;
       List.iter (
         fun arg -> pr ", %s" (name_of_argt arg)
-      ) (snd style);
+      ) args;
+      if optargs <> [] then
+        pr ", ...";
       pr ")\n";
       pr "      guestfs_h *g;\n";
       iteri (
@@ -240,136 +242,189 @@ clear_progress_callback (g)
           | Bool n -> pr "      int %s;\n" n
           | Int n -> pr "      int %s;\n" n
           | Int64 n -> pr "      int64_t %s;\n" n
-      ) (snd style);
+      ) args;
 
-      let do_cleanups () =
-        List.iter (
-          function
-          | Pathname _ | Device _ | Dev_or_Path _ | String _ | OptString _
-          | Bool _ | Int _ | Int64 _
-          | FileIn _ | FileOut _
-          | BufferIn _ | Key _ -> ()
-          | StringList n | DeviceList n -> pr "      free (%s);\n" n
-        ) (snd style)
-      in
-
-      (* Code. *)
-      (match fst style with
+      (* PREINIT section (local variable declarations). *)
+      pr "PREINIT:\n";
+      (match ret with
        | RErr ->
-           pr "PREINIT:\n";
            pr "      int r;\n";
+       | RInt _
+       | RBool _ ->
+           pr "      int r;\n";
+       | RInt64 _ ->
+           pr "      int64_t r;\n";
+       | RConstString _ ->
+           pr "      const char *r;\n";
+       | RConstOptString _ ->
+           pr "      const char *r;\n";
+       | RString _ ->
+           pr "      char *r;\n";
+       | RStringList _ | RHashtable _ ->
+           pr "      char **r;\n";
+           pr "      size_t i, n;\n";
+       | RStruct (_, typ) ->
+           pr "      struct guestfs_%s *r;\n" typ;
+       | RStructList (_, typ) ->
+           pr "      struct guestfs_%s_list *r;\n" typ;
+           pr "      size_t i;\n";
+           pr "      HV *hv;\n";
+       | RBufferOut _ ->
+           pr "      char *r;\n";
+           pr "      size_t size;\n";
+      );
+
+      if optargs <> [] then (
+        pr "      struct guestfs_%s_argv optargs_s = { .bitmask = 0 };\n" name;
+        pr "      struct guestfs_%s_argv *optargs = &optargs_s;\n" name;
+        pr "      size_t items_i;\n";
+      );
+
+      (* CODE or PPCODE section.  PPCODE is used where we are
+       * returning void, or where we push the return value on the stack
+       * ourselves.  Using CODE means we will manipulate RETVAL.
+       *)
+      (match ret with
+       | RErr ->
            pr " PPCODE:\n";
-           pr "      r = guestfs_%s " name;
-           generate_c_call_args ~handle:"g" style;
-           pr ";\n";
-           do_cleanups ();
+       | RInt n
+       | RBool n ->
+           pr "   CODE:\n";
+       | RInt64 n ->
+           pr "   CODE:\n";
+       | RConstString n ->
+           pr "   CODE:\n";
+       | RConstOptString n ->
+           pr "   CODE:\n";
+       | RString n ->
+           pr "   CODE:\n";
+       | RStringList n | RHashtable n ->
+           pr " PPCODE:\n";
+       | RBufferOut n ->
+           pr "   CODE:\n";
+       | RStruct _
+       | RStructList _ ->
+           pr " PPCODE:\n";
+      );
+
+      (* For optional arguments, convert these from the XSUB "items"
+       * variable by hand.
+       *)
+      if optargs <> [] then (
+        let uc_name = String.uppercase name in
+        let skip = List.length args + 1 in
+        pr "      if (((items - %d) & 1) != 0)\n" skip;
+        pr "        croak (\"expecting an even number of extra parameters\");\n";
+        pr "      for (items_i = %d; items_i < items; items_i += 2) {\n" skip;
+        pr "        uint64_t this_mask;\n";
+        pr "        const char *this_arg;\n";
+        pr "\n";
+        pr "        this_arg = SvPV_nolen (ST (items_i));\n";
+        pr "        ";
+        List.iter (
+          fun argt ->
+            let n = name_of_argt argt in
+            let uc_n = String.uppercase n in
+            pr "if (strcmp (this_arg, \"%s\") == 0) {\n" n;
+            pr "          optargs_s.%s = " n;
+            (match argt with
+             | Bool _
+             | Int _
+             | Int64 _ -> pr "SvIV (ST (items_i+1))"
+             | String _ -> pr "SvPV_nolen (ST (items_i+1))"
+             | _ -> assert false
+            );
+            pr ";\n";
+            pr "          this_mask = GUESTFS_%s_%s_BITMASK;\n" uc_name uc_n;
+            pr "        }\n";
+            pr "        else ";
+        ) optargs;
+        pr "croak (\"unknown optional argument '%%s'\", this_arg);\n";
+        pr "        if (optargs_s.bitmask & this_mask)\n";
+        pr "          croak (\"optional argument '%%s' given twice\",\n";
+        pr "                 this_arg);\n";
+        pr "        optargs_s.bitmask |= this_mask;\n";
+        pr "      }\n";
+        pr "\n";
+      );
+
+      (* The call to the C function. *)
+      if optargs = [] then
+        pr "      r = guestfs_%s " name
+      else
+        pr "      r = guestfs_%s_argv " name;
+      generate_c_call_args ~handle:"g" style;
+      pr ";\n";
+
+      (* Cleanup any arguments. *)
+      List.iter (
+        function
+        | Pathname _ | Device _ | Dev_or_Path _ | String _ | OptString _
+        | Bool _ | Int _ | Int64 _
+        | FileIn _ | FileOut _
+        | BufferIn _ | Key _ -> ()
+        | StringList n | DeviceList n -> pr "      free (%s);\n" n
+      ) args;
+
+      (* Check return value for errors and return it if necessary. *)
+      (match ret with
+       | RErr ->
            pr "      if (r == -1)\n";
            pr "        croak (\"%%s\", guestfs_last_error (g));\n";
        | RInt n
        | RBool n ->
-           pr "PREINIT:\n";
-           pr "      int %s;\n" n;
-           pr "   CODE:\n";
-           pr "      %s = guestfs_%s " n name;
-           generate_c_call_args ~handle:"g" style;
-           pr ";\n";
-           do_cleanups ();
-           pr "      if (%s == -1)\n" n;
+           pr "      if (r == -1)\n";
            pr "        croak (\"%%s\", guestfs_last_error (g));\n";
-           pr "      RETVAL = newSViv (%s);\n" n;
+           pr "      RETVAL = newSViv (r);\n";
            pr " OUTPUT:\n";
            pr "      RETVAL\n"
        | RInt64 n ->
-           pr "PREINIT:\n";
-           pr "      int64_t %s;\n" n;
-           pr "   CODE:\n";
-           pr "      %s = guestfs_%s " n name;
-           generate_c_call_args ~handle:"g" style;
-           pr ";\n";
-           do_cleanups ();
-           pr "      if (%s == -1)\n" n;
+           pr "      if (r == -1)\n";
            pr "        croak (\"%%s\", guestfs_last_error (g));\n";
-           pr "      RETVAL = my_newSVll (%s);\n" n;
+           pr "      RETVAL = my_newSVll (r);\n";
            pr " OUTPUT:\n";
            pr "      RETVAL\n"
        | RConstString n ->
-           pr "PREINIT:\n";
-           pr "      const char *%s;\n" n;
-           pr "   CODE:\n";
-           pr "      %s = guestfs_%s " n name;
-           generate_c_call_args ~handle:"g" style;
-           pr ";\n";
-           do_cleanups ();
-           pr "      if (%s == NULL)\n" n;
+           pr "      if (r == NULL)\n";
            pr "        croak (\"%%s\", guestfs_last_error (g));\n";
-           pr "      RETVAL = newSVpv (%s, 0);\n" n;
+           pr "      RETVAL = newSVpv (r, 0);\n";
            pr " OUTPUT:\n";
            pr "      RETVAL\n"
        | RConstOptString n ->
-           pr "PREINIT:\n";
-           pr "      const char *%s;\n" n;
-           pr "   CODE:\n";
-           pr "      %s = guestfs_%s " n name;
-           generate_c_call_args ~handle:"g" style;
-           pr ";\n";
-           do_cleanups ();
-           pr "      if (%s == NULL)\n" n;
+           pr "      if (r == NULL)\n";
            pr "        RETVAL = &PL_sv_undef;\n";
            pr "      else\n";
-           pr "        RETVAL = newSVpv (%s, 0);\n" n;
+           pr "        RETVAL = newSVpv (r, 0);\n";
            pr " OUTPUT:\n";
            pr "      RETVAL\n"
        | RString n ->
-           pr "PREINIT:\n";
-           pr "      char *%s;\n" n;
-           pr "   CODE:\n";
-           pr "      %s = guestfs_%s " n name;
-           generate_c_call_args ~handle:"g" style;
-           pr ";\n";
-           do_cleanups ();
-           pr "      if (%s == NULL)\n" n;
+           pr "      if (r == NULL)\n";
            pr "        croak (\"%%s\", guestfs_last_error (g));\n";
-           pr "      RETVAL = newSVpv (%s, 0);\n" n;
-           pr "      free (%s);\n" n;
+           pr "      RETVAL = newSVpv (r, 0);\n";
+           pr "      free (r);\n";
            pr " OUTPUT:\n";
            pr "      RETVAL\n"
        | RStringList n | RHashtable n ->
-           pr "PREINIT:\n";
-           pr "      char **%s;\n" n;
-           pr "      size_t i, n;\n";
-           pr " PPCODE:\n";
-           pr "      %s = guestfs_%s " n name;
-           generate_c_call_args ~handle:"g" style;
-           pr ";\n";
-           do_cleanups ();
-           pr "      if (%s == NULL)\n" n;
+           pr "      if (r == NULL)\n";
            pr "        croak (\"%%s\", guestfs_last_error (g));\n";
-           pr "      for (n = 0; %s[n] != NULL; ++n) /**/;\n" n;
+           pr "      for (n = 0; r[n] != NULL; ++n) /**/;\n";
            pr "      EXTEND (SP, n);\n";
            pr "      for (i = 0; i < n; ++i) {\n";
-           pr "        PUSHs (sv_2mortal (newSVpv (%s[i], 0)));\n" n;
-           pr "        free (%s[i]);\n" n;
+           pr "        PUSHs (sv_2mortal (newSVpv (r[i], 0)));\n";
+           pr "        free (r[i]);\n";
            pr "      }\n";
-           pr "      free (%s);\n" n;
+           pr "      free (r);\n";
        | RStruct (n, typ) ->
            let cols = cols_of_struct typ in
-           generate_perl_struct_code typ cols name style n do_cleanups
+           generate_perl_struct_code typ cols name style n
        | RStructList (n, typ) ->
            let cols = cols_of_struct typ in
-           generate_perl_struct_list_code typ cols name style n do_cleanups
+           generate_perl_struct_list_code typ cols name style n
        | RBufferOut n ->
-           pr "PREINIT:\n";
-           pr "      char *%s;\n" n;
-           pr "      size_t size;\n";
-           pr "   CODE:\n";
-           pr "      %s = guestfs_%s " n name;
-           generate_c_call_args ~handle:"g" style;
-           pr ";\n";
-           do_cleanups ();
-           pr "      if (%s == NULL)\n" n;
+           pr "      if (r == NULL)\n";
            pr "        croak (\"%%s\", guestfs_last_error (g));\n";
-           pr "      RETVAL = newSVpvn (%s, size);\n" n;
-           pr "      free (%s);\n" n;
+           pr "      RETVAL = newSVpvn (r, size);\n";
+           pr "      free (r);\n";
            pr " OUTPUT:\n";
            pr "      RETVAL\n"
       );
@@ -377,61 +432,45 @@ clear_progress_callback (g)
       pr "\n"
   ) all_functions
 
-and generate_perl_struct_list_code typ cols name style n do_cleanups =
-  pr "PREINIT:\n";
-  pr "      struct guestfs_%s_list *%s;\n" typ n;
-  pr "      size_t i;\n";
-  pr "      HV *hv;\n";
-  pr " PPCODE:\n";
-  pr "      %s = guestfs_%s " n name;
-  generate_c_call_args ~handle:"g" style;
-  pr ";\n";
-  do_cleanups ();
-  pr "      if (%s == NULL)\n" n;
+and generate_perl_struct_list_code typ cols name style n =
+  pr "      if (r == NULL)\n";
   pr "        croak (\"%%s\", guestfs_last_error (g));\n";
-  pr "      EXTEND (SP, %s->len);\n" n;
-  pr "      for (i = 0; i < %s->len; ++i) {\n" n;
+  pr "      EXTEND (SP, r->len);\n";
+  pr "      for (i = 0; i < r->len; ++i) {\n";
   pr "        hv = newHV ();\n";
   List.iter (
     function
     | name, FString ->
-        pr "        (void) hv_store (hv, \"%s\", %d, newSVpv (%s->val[i].%s, 0), 0);\n"
-          name (String.length name) n name
+        pr "        (void) hv_store (hv, \"%s\", %d, newSVpv (r->val[i].%s, 0), 0);\n"
+          name (String.length name) name
     | name, FUUID ->
-        pr "        (void) hv_store (hv, \"%s\", %d, newSVpv (%s->val[i].%s, 32), 0);\n"
-          name (String.length name) n name
+        pr "        (void) hv_store (hv, \"%s\", %d, newSVpv (r->val[i].%s, 32), 0);\n"
+          name (String.length name) name
     | name, FBuffer ->
-        pr "        (void) hv_store (hv, \"%s\", %d, newSVpvn (%s->val[i].%s, %s->val[i].%s_len), 0);\n"
-          name (String.length name) n name n name
+        pr "        (void) hv_store (hv, \"%s\", %d, newSVpvn (r->val[i].%s, r->val[i].%s_len), 0);\n"
+          name (String.length name) name name
     | name, (FBytes|FUInt64) ->
-        pr "        (void) hv_store (hv, \"%s\", %d, my_newSVull (%s->val[i].%s), 0);\n"
-          name (String.length name) n name
+        pr "        (void) hv_store (hv, \"%s\", %d, my_newSVull (r->val[i].%s), 0);\n"
+          name (String.length name) name
     | name, FInt64 ->
-        pr "        (void) hv_store (hv, \"%s\", %d, my_newSVll (%s->val[i].%s), 0);\n"
-          name (String.length name) n name
+        pr "        (void) hv_store (hv, \"%s\", %d, my_newSVll (r->val[i].%s), 0);\n"
+          name (String.length name) name
     | name, (FInt32|FUInt32) ->
-        pr "        (void) hv_store (hv, \"%s\", %d, newSVnv (%s->val[i].%s), 0);\n"
-          name (String.length name) n name
+        pr "        (void) hv_store (hv, \"%s\", %d, newSVnv (r->val[i].%s), 0);\n"
+          name (String.length name) name
     | name, FChar ->
-        pr "        (void) hv_store (hv, \"%s\", %d, newSVpv (&%s->val[i].%s, 1), 0);\n"
-          name (String.length name) n name
+        pr "        (void) hv_store (hv, \"%s\", %d, newSVpv (&r->val[i].%s, 1), 0);\n"
+          name (String.length name) name
     | name, FOptPercent ->
-        pr "        (void) hv_store (hv, \"%s\", %d, newSVnv (%s->val[i].%s), 0);\n"
-          name (String.length name) n name
+        pr "        (void) hv_store (hv, \"%s\", %d, newSVnv (r->val[i].%s), 0);\n"
+          name (String.length name) name
   ) cols;
   pr "        PUSHs (sv_2mortal (newRV ((SV *) hv)));\n";
   pr "      }\n";
-  pr "      guestfs_free_%s_list (%s);\n" typ n
-
-and generate_perl_struct_code typ cols name style n do_cleanups =
-  pr "PREINIT:\n";
-  pr "      struct guestfs_%s *%s;\n" typ n;
-  pr " PPCODE:\n";
-  pr "      %s = guestfs_%s " n name;
-  generate_c_call_args ~handle:"g" style;
-  pr ";\n";
-  do_cleanups ();
-  pr "      if (%s == NULL)\n" n;
+  pr "      guestfs_free_%s_list (r);\n" typ
+
+and generate_perl_struct_code typ cols name style n =
+  pr "      if (r == NULL)\n";
   pr "        croak (\"%%s\", guestfs_last_error (g));\n";
   pr "      EXTEND (SP, 2 * %d);\n" (List.length cols);
   List.iter (
@@ -440,31 +479,31 @@ and generate_perl_struct_code typ cols name style n do_cleanups =
 
       match col with
       | name, FString ->
-          pr "      PUSHs (sv_2mortal (newSVpv (%s->%s, 0)));\n"
-            n name
+          pr "      PUSHs (sv_2mortal (newSVpv (r->%s, 0)));\n"
+            name
       | name, FBuffer ->
-          pr "      PUSHs (sv_2mortal (newSVpvn (%s->%s, %s->%s_len)));\n"
-            n name n name
+          pr "      PUSHs (sv_2mortal (newSVpvn (r->%s, r->%s_len)));\n"
+            name name
       | name, FUUID ->
-          pr "      PUSHs (sv_2mortal (newSVpv (%s->%s, 32)));\n"
-            n name
+          pr "      PUSHs (sv_2mortal (newSVpv (r->%s, 32)));\n"
+            name
       | name, (FBytes|FUInt64) ->
-          pr "      PUSHs (sv_2mortal (my_newSVull (%s->%s)));\n"
-            n name
+          pr "      PUSHs (sv_2mortal (my_newSVull (r->%s)));\n"
+            name
       | name, FInt64 ->
-          pr "      PUSHs (sv_2mortal (my_newSVll (%s->%s)));\n"
-            n name
+          pr "      PUSHs (sv_2mortal (my_newSVll (r->%s)));\n"
+            name
       | name, (FInt32|FUInt32) ->
-          pr "      PUSHs (sv_2mortal (newSVnv (%s->%s)));\n"
-            n name
+          pr "      PUSHs (sv_2mortal (newSVnv (r->%s)));\n"
+            name
       | name, FChar ->
-          pr "      PUSHs (sv_2mortal (newSVpv (&%s->%s, 1)));\n"
-            n name
+          pr "      PUSHs (sv_2mortal (newSVpv (&r->%s, 1)));\n"
+            name
       | name, FOptPercent ->
-          pr "      PUSHs (sv_2mortal (newSVnv (%s->%s)));\n"
-            n name
+          pr "      PUSHs (sv_2mortal (newSVnv (r->%s)));\n"
+            name
   ) cols;
-  pr "      free (%s);\n" n
+  pr "      free (r);\n"
 
 (* Generate Sys/Guestfs.pm. *)
 and generate_perl_pm () =
@@ -482,9 +521,9 @@ Sys::Guestfs - Perl bindings for libguestfs
  use Sys::Guestfs;
 
  my $h = Sys::Guestfs->new ();
- $h->add_drive ('guest.img');
+ $h->add_drive_opts ('guest.img', format => 'raw');
  $h->launch ();
- $h->mount ('/dev/sda1', '/');
+ $h->mount_options ('', '/dev/sda1', '/');
  $h->touch ('/hello');
  $h->sync ();
 
@@ -688,8 +727,8 @@ L<Sys::Guestfs::Lib(3)>.
 =cut
 " copyright_years
 
-and generate_perl_prototype name style =
-  (match fst style with
+and generate_perl_prototype name (ret, args, optargs) =
+  (match ret with
    | RErr -> ()
    | RBool n
    | RInt n
@@ -716,5 +755,12 @@ and generate_perl_prototype name style =
           pr "$%s" n
       | StringList n | DeviceList n ->
           pr "\\@%s" n
-  ) (snd style);
+  ) args;
+  List.iter (
+    fun arg ->
+      if !comma then pr " [, " else pr "[";
+      comma := true;
+      let n = name_of_argt arg in
+      pr "%s => $%s]" n n
+  ) optargs;
   pr ");"