New event API - Perl bindings (RHBZ#664558).

The methods $h->set_progress_callback and $h->clear_progress_callback
have been removed, and replaced with a complete mechanism for setting
and deleting general-purpose events.

This also updates virt-resize to use the new API.

generator/.depend

@@ -76,10 +76,12 @@ generator_ocaml.cmx: generator_utils.cmx generator_types.cmx \
     generator_actions.cmx
 generator_perl.cmo: generator_utils.cmi generator_types.cmo \
     generator_structs.cmi generator_pr.cmi generator_optgroups.cmo \
-    generator_docstrings.cmo generator_c.cmo generator_actions.cmi
+    generator_events.cmo generator_docstrings.cmo generator_c.cmo \
+    generator_actions.cmi
 generator_perl.cmx: generator_utils.cmx generator_types.cmx \
     generator_structs.cmx generator_pr.cmx generator_optgroups.cmx \
-    generator_docstrings.cmx generator_c.cmx generator_actions.cmx
+    generator_events.cmx generator_docstrings.cmx generator_c.cmx \
+    generator_actions.cmx
 generator_python.cmo: generator_utils.cmi generator_types.cmo \
     generator_structs.cmi generator_pr.cmi generator_optgroups.cmo \
     generator_docstrings.cmo generator_c.cmo generator_actions.cmi

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,85 @@ 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]);
 }
 
 MODULE = Sys::Guestfs  PACKAGE = Sys::Guestfs
@@ -180,21 +222,45 @@ 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
-clear_progress_callback (g)
+delete_event_callback (g, event_handle)
       guestfs_h *g;
- PPCODE:
-      _clear_progress_callback (g);
+      int event_handle;
+PREINIT:
+      char key[64];
+   CODE:
+      snprintf (key, sizeof key, \"_perl_event_%%d\", event_handle);
+      guestfs_set_private (g, key, NULL);
+
+      guestfs_delete_event_callback (g, event_handle);
 
 ";
 
@@ -579,6 +645,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 +679,68 @@ 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 any progress callback function associated with
-the handle.
+This removes the callback which was previously registered using
+C<set_event_callback>.
 
 =cut
 
-" max_proc_nr;
+";
 
   (* Actions.  We only need to print documentation for these as
    * they are pulled in from the XS code automatically.

perl/t/400-events.t

@@ -0,0 +1,72 @@
+# libguestfs Perl bindings -*- perl -*-
+# Copyright (C) 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
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+use strict;
+use warnings;
+use Test::More tests => 7;
+
+use Sys::Guestfs;
+
+my $h = Sys::Guestfs->new ();
+ok ($h);
+
+sub log_callback {
+    my $ev = shift;
+    my $eh = shift;
+    my $buf = shift;
+    my $array = shift;
+
+    chomp $buf if $ev == $Sys::Guestfs::EVENT_APPLIANCE;
+
+    # We don't get to see this output because it is eaten up by the
+    # test harness, but generate it anyway.
+    printf("perl event logged: event=0x%x eh=%d buf='%s' array=[%s]\n",
+           $ev, $eh, $buf, join (", ", @$array));
+}
+
+my $close_invoked = 0;
+
+sub close_callback {
+    $close_invoked++;
+    log_callback (@_);
+}
+
+# Register an event callback for all log messages.
+my $events = $Sys::Guestfs::EVENT_APPLIANCE | $Sys::Guestfs::EVENT_LIBRARY |
+    $Sys::Guestfs::EVENT_TRACE;
+my $eh;
+$eh = $h->set_event_callback (\&log_callback, $events);
+ok ($eh >= 0);
+
+# Check that the close event is invoked.
+$h->set_event_callback (\&close_callback, $Sys::Guestfs::EVENT_CLOSE);
+ok ($eh >= 0);
+
+# Now make sure we see some messages.
+$h->set_trace (1);
+$h->set_verbose (1);
+ok (1);
+
+# Do some stuff.
+$h->add_drive_ro ("/dev/null");
+$h->set_autosync (1);
+ok (1);
+
+# Close the handle.  The close callback should be invoked.
+ok ($close_invoked == 0);
+undef $h;
+ok ($close_invoked == 1);

tools/virt-resize

@@ -1,6 +1,6 @@
 #!/usr/bin/perl -w
 # virt-resize
-# Copyright (C) 2010 Red Hat Inc.
+# Copyright (C) 2010-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
@@ -598,7 +598,8 @@ sub launch_guestfs
     @args = ($outfile);
     push @args, format => $output_format if defined $output_format;
     $g->add_drive_opts (@args);
-    $g->set_progress_callback (\&progress_callback) unless $quiet;
+    $g->set_event_callback (\&progress_callback, $Sys::Guestfs::EVENT_PROGRESS)
+        unless $quiet;
     $g->launch ();
 }
 
@@ -1401,10 +1402,15 @@ sub canonicalize
 # I intend to use an external library for this at some point (XXX).
 sub progress_callback
 {
-    my $proc_nr = shift;
-    my $serial = shift;
-    my $position = shift;
-    my $total = shift;
+    my $event = shift;
+    my $event_handle = shift;
+    my $buf = shift;
+    my $array = shift;
+
+    my $proc_nr = $array->[0];
+    my $serial = $array->[1];
+    my $position = $array->[2];
+    my $total = $array->[3];
 
     my $ratio = $position / $total;
     if ($ratio < 0) { $ratio = 0 }