X-Git-Url: http://git.annexia.org/?a=blobdiff_plain;ds=sidebyside;f=generator%2Fgenerator_perl.ml;h=f42bc8798dcd3b36e067765454a5bc6e34ba3aeb;hb=f4dadd0fcfe41b9cc6fcd6097c4c3cf509d69879;hp=3ff060b8586df7e755c5c6ae88cedf52918098d9;hpb=04d8209077d2227eb1d42695ba71147f78987050;p=libguestfs.git diff --git a/generator/generator_perl.ml b/generator/generator_perl.ml index 3ff060b..f42bc87 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,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,27 +222,72 @@ 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); "; 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 +305,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 +329,190 @@ 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); + | Pointer (t, n) -> pr " %s %s;\n" t n + ) 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"; + | 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"; - pr " r = guestfs_%s " name; - generate_c_call_args ~handle:"g" style; - pr ";\n"; - do_cleanups (); + ); + + (* 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 _ | Pointer _ -> () + | 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 +520,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 +567,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 +609,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 (); @@ -519,6 +646,9 @@ with libvirt. All errors turn into calls to C (see L). +The error string from libguestfs is directly available from +C<$@>. Use the C method if you want to get the errno. + =head1 METHODS =over 4 @@ -539,6 +669,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. @@ -569,28 +703,93 @@ 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: + + &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 -Set the progress notification callback for this handle -to the Perl closure C. +For some event types (notably progress events), this is +an array of integers. -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. +=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 the callback which was previously registered using +C. + +=item $errnum = $h->last_errno (); + +This returns the last error number (errno) that happened on the +handle C<$h>. -This removes any progress callback function associated with -the handle. +If successful, an errno integer not equal to zero is returned. + +If no error number is available, this returns 0. +See L for more details of why +this can happen. + +You can use the standard Perl module L 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. @@ -688,8 +887,8 @@ L. =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 @@ -712,9 +911,16 @@ and generate_perl_prototype name style = 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 ");"