>From 9b9f78f56fb29ba2e4e344301ac32a856689ac24 Mon Sep 17 00:00:00 2001 From: Richard W.M. Jones Date: Mon, 14 Mar 2011 19:42:47 +0000 Subject: [PATCH 4/4] 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. --- generator/.depend | 6 +- generator/generator_perl.ml | 192 +++++++++++++++++++++++++++++++++--------- perl/t/400-events.t | 70 ++++++++++++++++ 3 files changed, 225 insertions(+), 43 deletions(-) create mode 100644 perl/t/400-events.t diff --git a/generator/.depend b/generator/.depend index 77daa8c..01c7be9 100644 --- a/generator/.depend +++ b/generator/.depend @@ -78,10 +78,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 diff --git a/generator/generator_perl.ml b/generator/generator_perl.ml index 72f978d..e315338 100644 --- a/generator/generator_perl.ml +++ b/generator/generator_perl.ml @@ -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 the program must not call any method (including C) on the handle (but the implicit call to C that happens when the final reference is cleaned up is OK). -=item $h->set_progress_callback (\\&cb); +"; + + List.iter ( + fun (name, bitmask) -> + pr "=item $Sys::Guestfs::EVENT_%s\n" (String.uppercase name); + pr "\n"; + pr "See L.\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; + + pr "\ +=item $event_handle = $h->set_event_callback (\\&cb, $event_bitmask); + +Register C 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. + +The callback function receives 4 parameters: -Set the progress notification callback for this handle -to the Perl closure C. + &cb ($event, $event_handle, $buf, $array) -C will be called whenever a long-running operation -generates a progress notification message. The 4 parameters -to the function are: C, C, C -and C. +=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 before using +L 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. =cut -" max_proc_nr; +"; (* Actions. We only need to print documentation for these as * they are pulled in from the XS code automatically. diff --git a/perl/t/400-events.t b/perl/t/400-events.t new file mode 100644 index 0000000..def37d4 --- /dev/null +++ b/perl/t/400-events.t @@ -0,0 +1,70 @@ +# 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; chomp $buf; + my $array = shift; + + # 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); -- 1.7.4