X-Git-Url: http://git.annexia.org/?p=libguestfs.git;a=blobdiff_plain;f=generator%2Fgenerator_perl.ml;h=10a2387e5e099d3f1bc727eb59bfec59d32073dd;hp=72f978df607043eb6560be07d0b90aa15329d0fe;hb=00c9755ee3bea98968acea47bac858db94f7fbe2;hpb=4ada0a7815075c9cbe9d8b00da791c105ae739a9

diff --git a/generator/generator_perl.ml b/generator/generator_perl.ml
index 72f978d..10a2387 100644
--- a/generator/generator_perl.ml
+++ b/generator/generator_perl.ml
@@ -1,5 +1,5 @@
 (* libguestfs
- * Copyright (C) 2009-2010 Red Hat Inc.
+ * Copyright (C) 2009-2011 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
@@ -28,6 +28,7 @@ open Generator_optgroups
 open Generator_actions
 open Generator_structs
 open Generator_c
+open Generator_events
 
 (* Generate Perl xs code, a sort of crazy variation of C with macros. *)
 let rec generate_perl_xs () =
@@ -101,44 +102,86 @@ XS_unpack_charPtrPtr (SV *arg) {
   return ret;
 }
 
-#define PROGRESS_KEY \"_perl_progress_cb\"
-
-static void
-_clear_progress_callback (guestfs_h *g)
-{
-  guestfs_set_progress_callback (g, NULL, NULL);
-  SV *cb = guestfs_get_private (g, PROGRESS_KEY);
-  if (cb) {
-    guestfs_set_private (g, PROGRESS_KEY, NULL);
-    SvREFCNT_dec (cb);
-  }
-}
-
 /* http://www.perlmonks.org/?node=338857 */
 static void
-_progress_callback (guestfs_h *g, void *cb,
-                    int proc_nr, int serial, uint64_t position, uint64_t total)
+_event_callback_wrapper (guestfs_h *g,
+                         void *cb,
+                         uint64_t event,
+                         int event_handle,
+                         int flags,
+                         const char *buf, size_t buf_len,
+                         const uint64_t *array, size_t array_len)
 {
   dSP;
   ENTER;
   SAVETMPS;
   PUSHMARK (SP);
-  XPUSHs (sv_2mortal (newSViv (proc_nr)));
-  XPUSHs (sv_2mortal (newSViv (serial)));
-  XPUSHs (sv_2mortal (my_newSVull (position)));
-  XPUSHs (sv_2mortal (my_newSVull (total)));
+  XPUSHs (sv_2mortal (my_newSVull (event)));
+  XPUSHs (sv_2mortal (newSViv (event_handle)));
+  XPUSHs (sv_2mortal (newSVpvn (buf ? buf : \"\", buf_len)));
+  AV *av = newAV ();
+  size_t i;
+  for (i = 0; i < array_len; ++i)
+    av_push (av, my_newSVull (array[i]));
+  XPUSHs (sv_2mortal (newRV ((SV *) av)));
   PUTBACK;
   call_sv ((SV *) cb, G_VOID | G_DISCARD | G_EVAL);
   FREETMPS;
   LEAVE;
 }
 
+static SV **
+get_all_event_callbacks (guestfs_h *g, size_t *len_rtn)
+{
+  SV **r;
+  size_t i;
+  const char *key;
+  SV *cb;
+
+  /* Count the length of the array that will be needed. */
+  *len_rtn = 0;
+  cb = guestfs_first_private (g, &key);
+  while (cb != NULL) {
+    if (strncmp (key, \"_perl_event_\", strlen (\"_perl_event_\")) == 0)
+      (*len_rtn)++;
+    cb = guestfs_next_private (g, &key);
+  }
+
+  /* Copy them into the return array. */
+  r = guestfs_safe_malloc (g, sizeof (SV *) * (*len_rtn));
+
+  i = 0;
+  cb = guestfs_first_private (g, &key);
+  while (cb != NULL) {
+    if (strncmp (key, \"_perl_event_\", strlen (\"_perl_event_\")) == 0) {
+      r[i] = cb;
+      i++;
+    }
+    cb = guestfs_next_private (g, &key);
+  }
+
+  return r;
+}
+
 static void
 _close_handle (guestfs_h *g)
 {
+  size_t i, len;
+  SV **cbs;
+
   assert (g != NULL);
-  _clear_progress_callback (g);
+
+  /* As in the OCaml bindings, there is a hard to solve case where the
+   * caller can delete a callback from within the callback, resulting
+   * in a double-free here.  XXX
+   */
+  cbs = get_all_event_callbacks (g, &len);
+
   guestfs_close (g);
+
+  for (i = 0; i < len; ++i)
+    SvREFCNT_dec (cbs[i]);
+  free (cbs);
 }
 
 MODULE = Sys::Guestfs  PACKAGE = Sys::Guestfs
@@ -180,21 +223,66 @@ close (g)
       HV *hv = (HV *) SvRV (ST(0));
       (void) hv_delete (hv, \"_g\", 2, G_DISCARD);
 
-void
-set_progress_callback (g, cb)
+SV *
+set_event_callback (g, cb, event_bitmask)
       guestfs_h *g;
       SV *cb;
- PPCODE:
-      _clear_progress_callback (g);
+      int event_bitmask;
+PREINIT:
+      int eh;
+      char key[64];
+   CODE:
+      eh = guestfs_set_event_callback (g, _event_callback_wrapper,
+                                       event_bitmask, 0, cb);
+      if (eh == -1)
+        croak (\"%%s\", guestfs_last_error (g));
+
+      /* Increase the refcount for this callback, since we are storing
+       * it in the opaque C libguestfs handle.  We need to remember that
+       * we did this, so we can decrease the refcount for all undeleted
+       * callbacks left around at close time (see _close_handle).
+       */
       SvREFCNT_inc (cb);
-      guestfs_set_private (g, PROGRESS_KEY, cb);
-      guestfs_set_progress_callback (g, _progress_callback, cb);
+
+      snprintf (key, sizeof key, \"_perl_event_%%d\", eh);
+      guestfs_set_private (g, key, cb);
+
+      RETVAL = newSViv (eh);
+ OUTPUT:
+      RETVAL
+
+void
+delete_event_callback (g, event_handle)
+      guestfs_h *g;
+      int event_handle;
+PREINIT:
+      char key[64];
+      SV *cb;
+   CODE:
+      snprintf (key, sizeof key, \"_perl_event_%%d\", event_handle);
+      cb = guestfs_get_private (g, key);
+      if (cb) {
+        SvREFCNT_dec (cb);
+        guestfs_set_private (g, key, NULL);
+        guestfs_delete_event_callback (g, event_handle);
+      }
+
+SV *
+last_errno (g)
+      guestfs_h *g;
+PREINIT:
+      int errnum;
+   CODE:
+      errnum = guestfs_last_errno (g);
+      RETVAL = newSViv (errnum);
+ OUTPUT:
+      RETVAL
 
 void
-clear_progress_callback (g)
+user_cancel (g)
       guestfs_h *g;
  PPCODE:
-      _clear_progress_callback (g);
+      guestfs_user_cancel (g);
 
 ";
 
@@ -559,6 +647,9 @@ with libvirt.
 
 All errors turn into calls to C<croak> (see L<Carp(3)>).
 
+The error string from libguestfs is directly available from
+C<$@>.  Use the C<last_errno> method if you want to get the errno.
+
 =head1 METHODS
 
 =over 4
@@ -579,6 +670,10 @@ $VERSION = '0.%d';
 require XSLoader;
 XSLoader::load ('Sys::Guestfs');
 
+" max_proc_nr;
+
+  (* Methods. *)
+  pr "\
 =item $h = Sys::Guestfs->new ();
 
 Create a new guestfs handle.
@@ -609,28 +704,93 @@ C<close> the program must not call any method (including C<close>)
 on the handle (but the implicit call to C<DESTROY> that happens
 when the final reference is cleaned up is OK).
 
-=item $h->set_progress_callback (\\&cb);
+";
 
-Set the progress notification callback for this handle
-to the Perl closure C<cb>.
+  List.iter (
+    fun (name, bitmask) ->
+      pr "=item $Sys::Guestfs::EVENT_%s\n" (String.uppercase name);
+      pr "\n";
+      pr "See L<guestfs(3)/GUESTFS_EVENT_%s>.\n"
+        (String.uppercase name);
+      pr "\n";
+      pr "=cut\n";
+      pr "\n";
+      pr "our $EVENT_%s = 0x%x;\n" (String.uppercase name) bitmask;
+      pr "\n"
+  ) events;
 
-C<cb> will be called whenever a long-running operation
-generates a progress notification message.  The 4 parameters
-to the function are: C<proc_nr>, C<serial>, C<position>
-and C<total>.
+  pr "\
+=item $event_handle = $h->set_event_callback (\\&cb, $event_bitmask);
+
+Register C<cb> as a callback function for all of the events
+in C<$event_bitmask> (one or more C<$Sys::Guestfs::EVENT_*> flags
+logically or'd together).
+
+This function returns an event handle which
+can be used to delete the callback using C<delete_event_callback>.
+
+The callback function receives 4 parameters:
+
+ &cb ($event, $event_handle, $buf, $array)
+
+=over 4
+
+=item $event
+
+The event which happened (equal to one of C<$Sys::Guestfs::EVENT_*>).
+
+=item $event_handle
+
+The event handle.
+
+=item $buf
+
+For some event types, this is a message buffer (ie. a string).
+
+=item $array
+
+For some event types (notably progress events), this is
+an array of integers.
+
+=back
 
 You should carefully read the documentation for
-L<guestfs(3)/guestfs_set_progress_callback> before using
+L<guestfs(3)/guestfs_set_event_callback> before using
 this function.
 
-=item $h->clear_progress_callback ();
+=item $h->delete_event_callback ($event_handle);
+
+This removes the callback which was previously registered using
+C<set_event_callback>.
 
-This removes any progress callback function associated with
-the handle.
+=item $errnum = $h->last_errno ();
+
+This returns the last error number (errno) that happened on the
+handle C<$h>.
+
+If successful, an errno integer not equal to zero is returned.
+
+If no error number is available, this returns 0.
+See L<guestfs(3)/guestfs_last_errno> for more details of why
+this can happen.
+
+You can use the standard Perl module L<Errno(3)> to compare
+the numeric error returned from this call with symbolic
+errnos:
+
+ $h->mkdir (\"/foo\");
+ if ($h->last_errno() == Errno::EEXIST()) {
+   # mkdir failed because the directory exists already.
+ }
+
+=item $h->user_cancel ();
+
+Cancel current transfer.  This is safe to call from Perl signal
+handlers and threads.
 
 =cut
 
-" max_proc_nr;
+";
 
   (* Actions.  We only need to print documentation for these as
    * they are pulled in from the XS code automatically.
@@ -645,18 +805,77 @@ the handle.
         pr "%s\n\n" longdesc;
         if List.mem ProtocolLimitWarning flags then
           pr "%s\n\n" protocol_limit_warning;
-        if List.mem DangerWillRobinson flags then
-          pr "%s\n\n" danger_will_robinson;
         match deprecation_notice flags with
         | None -> ()
         | Some txt -> pr "%s\n\n" txt
       )
   ) all_functions_sorted;
 
+  pr "=cut\n\n";
+
+  (* Introspection hash. *)
+  pr "use vars qw(%%guestfs_introspection);\n";
+  pr "%%guestfs_introspection = (\n";
+  List.iter (
+    fun (name, (ret, args, optargs), _, _, _, shortdesc, _) ->
+      pr "  \"%s\" => {\n" name;
+      pr "    ret => ";
+      (match ret with
+       | RErr -> pr "'void'"
+       | RInt _ -> pr "'int'"
+       | RBool _ -> pr "'bool'"
+       | RInt64 _ -> pr "'int64'"
+       | RConstString _ -> pr "'const string'"
+       | RConstOptString _ -> pr "'const nullable string'"
+       | RString _ -> pr "'string'"
+       | RStringList _ -> pr "'string list'"
+       | RHashtable _ -> pr "'hash'"
+       | RStruct (_, typ) -> pr "'struct %s'" typ
+       | RStructList (_, typ) -> pr "'struct %s list'" typ
+       | RBufferOut _ -> pr "'buffer'"
+      );
+      pr ",\n";
+      let pr_type i = function
+        | Pathname n -> pr "[ '%s', 'string(path)', %d ]" n i
+        | Device n -> pr "[ '%s', 'string(device)', %d ]" n i
+        | Dev_or_Path n -> pr "[ '%s', 'string(dev_or_path)', %d ]" n i
+        | String n -> pr "[ '%s', 'string', %d ]" n i
+        | FileIn n -> pr "[ '%s', 'string(filename)', %d ]" n i
+        | FileOut n -> pr "[ '%s', 'string(filename)', %d ]" n i
+        | Key n -> pr "[ '%s', 'string(key)', %d ]" n i
+        | BufferIn n -> pr "[ '%s', 'buffer', %d ]" n i
+        | OptString n -> pr "[ '%s', 'nullable string', %d ]" n i
+        | StringList n -> pr "[ '%s', 'string list', %d ]" n i
+        | DeviceList n -> pr "[ '%s', 'string(device) list', %d ]" n i
+        | Bool n -> pr "[ '%s', 'bool', %d ]" n i
+        | Int n -> pr "[ '%s', 'int', %d ]" n i
+        | Int64 n -> pr "[ '%s', 'int64', %d ]" n i
+        | Pointer (t, n) -> pr "[ '%s', 'pointer(%s)', %d ]" n t i
+      in
+      pr "    args => [\n";
+      iteri (fun i arg ->
+        pr "      ";
+        pr_type i arg;
+        pr ",\n"
+      ) args;
+      pr "    ],\n";
+      if optargs <> [] then (
+        pr "    optargs => {\n";
+        iteri (fun i arg ->
+          pr "      %s => " (name_of_argt arg);
+          pr_type i arg;
+          pr ",\n"
+        ) optargs;
+        pr "    },\n";
+      );
+      pr "    name => \"%s\",\n" name;
+      pr "    description => %S,\n" shortdesc;
+      pr "  },\n";
+  ) all_functions_sorted;
+  pr ");\n\n";
+
   (* End of file. *)
   pr "\
-=cut
-
 1;
 
 =back
@@ -678,6 +897,33 @@ class, use the ordinary Perl UNIVERSAL method C<can(METHOD)>
    print \"\\$h->set_verbose is available\\n\";
  }
 
+Perl does not offer a way to list the arguments of a method, and
+from time to time we may add extra arguments to calls that take
+optional arguments.  For this reason, we provide a global hash
+variable C<%%guestfs_introspection> which contains the arguments
+and their types for each libguestfs method.  The keys of this
+hash are the method names, and the values are an hashref
+containing useful introspection information about the method
+(further fields may be added to this in future).
+
+ use Sys::Guestfs;
+ $Sys::Guestfs::guestfs_introspection{mkfs_opts}
+ => {
+    ret => 'void',                    # return type
+    args => [                         # required arguments
+      [ 'fstype', 'string', 0 ],
+      [ 'device', 'string(device)', 1 ],
+    ],
+    optargs => {                      # optional arguments
+      blocksize => [ 'blocksize', 'int', 0 ],
+      features => [ 'features', 'string', 1 ],
+      inode => [ 'inode', 'int', 2 ],
+      sectorsize => [ 'sectorsize', 'int', 3 ],
+    },
+    name => \"mkfs_opts\",
+    description => \"make a filesystem\",
+  }
+
 To test if particular features are supported by the current
 build, use the L</available> method like the example below.  Note
 that the appliance must be launched first.