(* 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
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 () =
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
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);
";
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"
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 (
| Bool n -> pr " int %s;\n" n
| Int n -> pr " int %s;\n" n
| Int64 n -> pr " int64_t %s;\n" n
- ) (snd style);
+ | Pointer (t, n) -> pr " %s %s;\n" t n
+ ) args;
(* PREINIT section (local variable declarations). *)
pr "PREINIT:\n";
- (match fst style with
+ (match ret with
| RErr ->
pr " int r;\n";
| RInt _
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 fst style with
+ (match ret with
| RErr ->
pr " PPCODE:\n";
| RInt n
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. *)
- pr " r = guestfs_%s " name;
+ if optargs = [] then
+ pr " r = guestfs_%s " name
+ else
+ pr " r = guestfs_%s_argv " name;
generate_c_call_args ~handle:"g" style;
pr ";\n";
| Pathname _ | Device _ | Dev_or_Path _ | String _ | OptString _
| Bool _ | Int _ | Int64 _
| FileIn _ | FileOut _
- | BufferIn _ | Key _ -> ()
+ | BufferIn _ | Key _ | Pointer _ -> ()
| StringList n | DeviceList n -> pr " free (%s);\n" n
- ) (snd style);
+ ) args;
(* Check return value for errors and return it if necessary. *)
- (match fst style with
+ (match ret with
| RErr ->
pr " if (r == -1)\n";
pr " croak (\"%%s\", guestfs_last_error (g));\n";
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 ();
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
require XSLoader;
XSLoader::load ('Sys::Guestfs');
+" max_proc_nr;
+
+ (* Methods. *)
+ pr "\
=item $h = Sys::Guestfs->new ();
Create a new guestfs handle.
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);
+";
+
+ 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;
+
+ 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
-Set the progress notification callback for this handle
-to the Perl closure C<cb>.
+The event handle.
-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>.
+=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>.
+
+=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.
-This removes any progress callback function associated with
-the handle.
+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.
=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
match arg with
| Pathname n | Device n | Dev_or_Path n | String n
| OptString n | Bool n | Int n | Int64 n | FileIn n | FileOut n
- | BufferIn n | Key n ->
+ | BufferIn n | Key n | Pointer (_, n) ->
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 ");"
git.annexia.org / libguestfs.git / blobdiff