X-Git-Url: http://git.annexia.org/?a=blobdiff_plain;f=generator%2Fgenerator_perl.ml;h=e2ec254bcf0b4a8eedf9216a0a2581246aff3d2e;hb=adb5db58d850ce6d15380177a63c68276f863c98;hp=020f1b2e8c79f6f59e31d77745e600161647227c;hpb=ea6209198026080a9d9e588283e83aa9c4e2f177;p=libguestfs.git diff --git a/generator/generator_perl.ml b/generator/generator_perl.ml index 020f1b2..e2ec254 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,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 -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]; + 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 "; 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 +299,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,11 +323,12 @@ 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; (* PREINIT section (local variable declarations). *) pr "PREINIT:\n"; - (match fst style with + (match ret with | RErr -> pr " int r;\n"; | RInt _ @@ -272,11 +356,17 @@ clear_progress_callback (g) 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 @@ -299,8 +389,52 @@ clear_progress_callback (g) 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"; @@ -310,12 +444,12 @@ clear_progress_callback (g) | 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"; @@ -469,9 +603,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 (); @@ -506,6 +640,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 @@ -526,6 +663,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. @@ -556,28 +697,88 @@ 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_*>). -Set the progress notification callback for this handle -to the Perl closure C. +=item $event_handle -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. +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 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. + } =cut -" max_proc_nr; +"; (* Actions. We only need to print documentation for these as * they are pulled in from the XS code automatically. @@ -675,8 +876,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 @@ -699,9 +900,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 ");"