2 * Copyright (C) 2009-2011 Red Hat Inc.
4 * This program is free software; you can redistribute it and/or modify
5 * it under the terms of the GNU General Public License as published by
6 * the Free Software Foundation; either version 2 of the License, or
7 * (at your option) any later version.
9 * This program is distributed in the hope that it will be useful,
10 * but WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12 * GNU General Public License for more details.
14 * You should have received a copy of the GNU General Public License
15 * along with this program; if not, write to the Free Software
16 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
19 (* Please read generator/README first. *)
26 open Generator_docstrings
27 open Generator_optgroups
28 open Generator_actions
29 open Generator_structs
33 (* Generate Perl xs code, a sort of crazy variation of C with macros. *)
34 let rec generate_perl_xs () =
35 generate_header CStyle LGPLv2plus;
45 #define PRId64 \"lld\"
49 my_newSVll(long long val) {
55 len = snprintf(buf, 100, \"%%\" PRId64, val);
56 return newSVpv(buf, len);
61 #define PRIu64 \"llu\"
65 my_newSVull(unsigned long long val) {
71 len = snprintf(buf, 100, \"%%\" PRIu64, val);
72 return newSVpv(buf, len);
76 /* http://www.perlmonks.org/?node_id=680842 */
78 XS_unpack_charPtrPtr (SV *arg) {
83 if (!arg || !SvOK (arg) || !SvROK (arg) || SvTYPE (SvRV (arg)) != SVt_PVAV)
84 croak (\"array reference expected\");
86 av = (AV *)SvRV (arg);
87 ret = malloc ((av_len (av) + 1 + 1) * sizeof (char *));
89 croak (\"malloc failed\");
91 for (i = 0; i <= av_len (av); i++) {
92 SV **elem = av_fetch (av, i, 0);
95 croak (\"missing element in list\");
97 ret[i] = SvPV_nolen (*elem);
105 /* http://www.perlmonks.org/?node=338857 */
107 _event_callback_wrapper (guestfs_h *g,
112 const char *buf, size_t buf_len,
113 const uint64_t *array, size_t array_len)
119 XPUSHs (sv_2mortal (my_newSVull (event)));
120 XPUSHs (sv_2mortal (newSViv (event_handle)));
121 XPUSHs (sv_2mortal (newSVpvn (buf ? buf : \"\", buf_len)));
124 for (i = 0; i < array_len; ++i)
125 av_push (av, my_newSVull (array[i]));
126 XPUSHs (sv_2mortal (newRV ((SV *) av)));
128 call_sv ((SV *) cb, G_VOID | G_DISCARD | G_EVAL);
134 get_all_event_callbacks (guestfs_h *g, size_t *len_rtn)
141 /* Count the length of the array that will be needed. */
143 cb = guestfs_first_private (g, &key);
145 if (strncmp (key, \"_perl_event_\", strlen (\"_perl_event_\")) == 0)
147 cb = guestfs_next_private (g, &key);
150 /* Copy them into the return array. */
151 r = guestfs_safe_malloc (g, sizeof (SV *) * (*len_rtn));
154 cb = guestfs_first_private (g, &key);
156 if (strncmp (key, \"_perl_event_\", strlen (\"_perl_event_\")) == 0) {
160 cb = guestfs_next_private (g, &key);
167 _close_handle (guestfs_h *g)
174 /* As in the OCaml bindings, there is a hard to solve case where the
175 * caller can delete a callback from within the callback, resulting
176 * in a double-free here. XXX
178 cbs = get_all_event_callbacks (g, &len);
182 for (i = 0; i < len; ++i)
183 SvREFCNT_dec (cbs[i]);
186 MODULE = Sys::Guestfs PACKAGE = Sys::Guestfs
193 RETVAL = guestfs_create ();
195 croak (\"could not create guestfs handle\");
196 guestfs_set_error_handler (RETVAL, NULL, NULL);
204 /* For the 'g' argument above we do the conversion explicitly and
205 * don't rely on the typemap, because if the handle has been
206 * explicitly closed we don't want the typemap conversion to
209 HV *hv = (HV *) SvRV (sv);
210 SV **svp = hv_fetch (hv, \"_g\", 2, 0);
212 guestfs_h *g = (guestfs_h *) SvIV (*svp);
221 /* Avoid double-free in DESTROY method. */
222 HV *hv = (HV *) SvRV (ST(0));
223 (void) hv_delete (hv, \"_g\", 2, G_DISCARD);
226 set_event_callback (g, cb, event_bitmask)
234 eh = guestfs_set_event_callback (g, _event_callback_wrapper,
235 event_bitmask, 0, cb);
237 croak (\"%%s\", guestfs_last_error (g));
239 /* Increase the refcount for this callback, since we are storing
240 * it in the opaque C libguestfs handle. We need to remember that
241 * we did this, so we can decrease the refcount for all undeleted
242 * callbacks left around at close time (see _close_handle).
246 snprintf (key, sizeof key, \"_perl_event_%%d\", eh);
247 guestfs_set_private (g, key, cb);
249 RETVAL = newSViv (eh);
254 delete_event_callback (g, event_handle)
260 snprintf (key, sizeof key, \"_perl_event_%%d\", event_handle);
261 guestfs_set_private (g, key, NULL);
263 guestfs_delete_event_callback (g, event_handle);
268 fun (name, (ret, args, optargs as style), _, _, _, _, _) ->
270 | RErr -> pr "void\n"
271 | RInt _ -> pr "SV *\n"
272 | RInt64 _ -> pr "SV *\n"
273 | RBool _ -> pr "SV *\n"
274 | RConstString _ -> pr "SV *\n"
275 | RConstOptString _ -> pr "SV *\n"
276 | RString _ -> pr "SV *\n"
277 | RBufferOut _ -> pr "SV *\n"
279 | RStruct _ | RStructList _
281 pr "void\n" (* all lists returned implictly on the stack *)
283 (* Call and arguments. *)
286 fun arg -> pr ", %s" (name_of_argt arg)
288 if optargs <> [] then
291 pr " guestfs_h *g;\n";
295 | Pathname n | Device n | Dev_or_Path n | String n
296 | FileIn n | FileOut n | Key n ->
300 pr " size_t %s_size = SvCUR (ST(%d));\n" n (i+1)
302 (* http://www.perlmonks.org/?node_id=554277
303 * Note that the implicit handle argument means we have
304 * to add 1 to the ST(x) operator.
306 pr " char *%s = SvOK(ST(%d)) ? SvPV_nolen(ST(%d)) : NULL;\n" n (i+1) (i+1)
307 | StringList n | DeviceList n -> pr " char **%s;\n" n
308 | Bool n -> pr " int %s;\n" n
309 | Int n -> pr " int %s;\n" n
310 | Int64 n -> pr " int64_t %s;\n" n
311 | Pointer (t, n) -> pr " %s %s;\n" t n
314 (* PREINIT section (local variable declarations). *)
325 pr " const char *r;\n";
326 | RConstOptString _ ->
327 pr " const char *r;\n";
330 | RStringList _ | RHashtable _ ->
332 pr " size_t i, n;\n";
333 | RStruct (_, typ) ->
334 pr " struct guestfs_%s *r;\n" typ;
335 | RStructList (_, typ) ->
336 pr " struct guestfs_%s_list *r;\n" typ;
341 pr " size_t size;\n";
344 if optargs <> [] then (
345 pr " struct guestfs_%s_argv optargs_s = { .bitmask = 0 };\n" name;
346 pr " struct guestfs_%s_argv *optargs = &optargs_s;\n" name;
347 pr " size_t items_i;\n";
350 (* CODE or PPCODE section. PPCODE is used where we are
351 * returning void, or where we push the return value on the stack
352 * ourselves. Using CODE means we will manipulate RETVAL.
364 | RConstOptString n ->
368 | RStringList n | RHashtable n ->
377 (* For optional arguments, convert these from the XSUB "items"
380 if optargs <> [] then (
381 let uc_name = String.uppercase name in
382 let skip = List.length args + 1 in
383 pr " if (((items - %d) & 1) != 0)\n" skip;
384 pr " croak (\"expecting an even number of extra parameters\");\n";
385 pr " for (items_i = %d; items_i < items; items_i += 2) {\n" skip;
386 pr " uint64_t this_mask;\n";
387 pr " const char *this_arg;\n";
389 pr " this_arg = SvPV_nolen (ST (items_i));\n";
393 let n = name_of_argt argt in
394 let uc_n = String.uppercase n in
395 pr "if (strcmp (this_arg, \"%s\") == 0) {\n" n;
396 pr " optargs_s.%s = " n;
400 | Int64 _ -> pr "SvIV (ST (items_i+1))"
401 | String _ -> pr "SvPV_nolen (ST (items_i+1))"
405 pr " this_mask = GUESTFS_%s_%s_BITMASK;\n" uc_name uc_n;
409 pr "croak (\"unknown optional argument '%%s'\", this_arg);\n";
410 pr " if (optargs_s.bitmask & this_mask)\n";
411 pr " croak (\"optional argument '%%s' given twice\",\n";
413 pr " optargs_s.bitmask |= this_mask;\n";
418 (* The call to the C function. *)
420 pr " r = guestfs_%s " name
422 pr " r = guestfs_%s_argv " name;
423 generate_c_call_args ~handle:"g" style;
426 (* Cleanup any arguments. *)
429 | Pathname _ | Device _ | Dev_or_Path _ | String _ | OptString _
430 | Bool _ | Int _ | Int64 _
431 | FileIn _ | FileOut _
432 | BufferIn _ | Key _ | Pointer _ -> ()
433 | StringList n | DeviceList n -> pr " free (%s);\n" n
436 (* Check return value for errors and return it if necessary. *)
439 pr " if (r == -1)\n";
440 pr " croak (\"%%s\", guestfs_last_error (g));\n";
443 pr " if (r == -1)\n";
444 pr " croak (\"%%s\", guestfs_last_error (g));\n";
445 pr " RETVAL = newSViv (r);\n";
449 pr " if (r == -1)\n";
450 pr " croak (\"%%s\", guestfs_last_error (g));\n";
451 pr " RETVAL = my_newSVll (r);\n";
455 pr " if (r == NULL)\n";
456 pr " croak (\"%%s\", guestfs_last_error (g));\n";
457 pr " RETVAL = newSVpv (r, 0);\n";
460 | RConstOptString n ->
461 pr " if (r == NULL)\n";
462 pr " RETVAL = &PL_sv_undef;\n";
464 pr " RETVAL = newSVpv (r, 0);\n";
468 pr " if (r == NULL)\n";
469 pr " croak (\"%%s\", guestfs_last_error (g));\n";
470 pr " RETVAL = newSVpv (r, 0);\n";
474 | RStringList n | RHashtable n ->
475 pr " if (r == NULL)\n";
476 pr " croak (\"%%s\", guestfs_last_error (g));\n";
477 pr " for (n = 0; r[n] != NULL; ++n) /**/;\n";
478 pr " EXTEND (SP, n);\n";
479 pr " for (i = 0; i < n; ++i) {\n";
480 pr " PUSHs (sv_2mortal (newSVpv (r[i], 0)));\n";
481 pr " free (r[i]);\n";
484 | RStruct (n, typ) ->
485 let cols = cols_of_struct typ in
486 generate_perl_struct_code typ cols name style n
487 | RStructList (n, typ) ->
488 let cols = cols_of_struct typ in
489 generate_perl_struct_list_code typ cols name style n
491 pr " if (r == NULL)\n";
492 pr " croak (\"%%s\", guestfs_last_error (g));\n";
493 pr " RETVAL = newSVpvn (r, size);\n";
502 and generate_perl_struct_list_code typ cols name style n =
503 pr " if (r == NULL)\n";
504 pr " croak (\"%%s\", guestfs_last_error (g));\n";
505 pr " EXTEND (SP, r->len);\n";
506 pr " for (i = 0; i < r->len; ++i) {\n";
507 pr " hv = newHV ();\n";
511 pr " (void) hv_store (hv, \"%s\", %d, newSVpv (r->val[i].%s, 0), 0);\n"
512 name (String.length name) name
514 pr " (void) hv_store (hv, \"%s\", %d, newSVpv (r->val[i].%s, 32), 0);\n"
515 name (String.length name) name
517 pr " (void) hv_store (hv, \"%s\", %d, newSVpvn (r->val[i].%s, r->val[i].%s_len), 0);\n"
518 name (String.length name) name name
519 | name, (FBytes|FUInt64) ->
520 pr " (void) hv_store (hv, \"%s\", %d, my_newSVull (r->val[i].%s), 0);\n"
521 name (String.length name) name
523 pr " (void) hv_store (hv, \"%s\", %d, my_newSVll (r->val[i].%s), 0);\n"
524 name (String.length name) name
525 | name, (FInt32|FUInt32) ->
526 pr " (void) hv_store (hv, \"%s\", %d, newSVnv (r->val[i].%s), 0);\n"
527 name (String.length name) name
529 pr " (void) hv_store (hv, \"%s\", %d, newSVpv (&r->val[i].%s, 1), 0);\n"
530 name (String.length name) name
531 | name, FOptPercent ->
532 pr " (void) hv_store (hv, \"%s\", %d, newSVnv (r->val[i].%s), 0);\n"
533 name (String.length name) name
535 pr " PUSHs (sv_2mortal (newRV ((SV *) hv)));\n";
537 pr " guestfs_free_%s_list (r);\n" typ
539 and generate_perl_struct_code typ cols name style n =
540 pr " if (r == NULL)\n";
541 pr " croak (\"%%s\", guestfs_last_error (g));\n";
542 pr " EXTEND (SP, 2 * %d);\n" (List.length cols);
544 fun ((name, _) as col) ->
545 pr " PUSHs (sv_2mortal (newSVpv (\"%s\", 0)));\n" name;
549 pr " PUSHs (sv_2mortal (newSVpv (r->%s, 0)));\n"
552 pr " PUSHs (sv_2mortal (newSVpvn (r->%s, r->%s_len)));\n"
555 pr " PUSHs (sv_2mortal (newSVpv (r->%s, 32)));\n"
557 | name, (FBytes|FUInt64) ->
558 pr " PUSHs (sv_2mortal (my_newSVull (r->%s)));\n"
561 pr " PUSHs (sv_2mortal (my_newSVll (r->%s)));\n"
563 | name, (FInt32|FUInt32) ->
564 pr " PUSHs (sv_2mortal (newSVnv (r->%s)));\n"
567 pr " PUSHs (sv_2mortal (newSVpv (&r->%s, 1)));\n"
569 | name, FOptPercent ->
570 pr " PUSHs (sv_2mortal (newSVnv (r->%s)));\n"
575 (* Generate Sys/Guestfs.pm. *)
576 and generate_perl_pm () =
577 generate_header HashStyle LGPLv2plus;
584 Sys::Guestfs - Perl bindings for libguestfs
590 my $h = Sys::Guestfs->new ();
591 $h->add_drive_opts ('guest.img', format => 'raw');
593 $h->mount_options ('', '/dev/sda1', '/');
594 $h->touch ('/hello');
599 The C<Sys::Guestfs> module provides a Perl XS binding to the
600 libguestfs API for examining and modifying virtual machine
603 Amongst the things this is good for: making batch configuration
604 changes to guests, getting disk used/free statistics (see also:
605 virt-df), migrating between virtualization systems (see also:
606 virt-p2v), performing partial backups, performing partial guest
607 clones, cloning guests and changing registry/UUID/hostname info, and
610 Libguestfs uses Linux kernel and qemu code, and can access any type of
611 guest filesystem that Linux and qemu can, including but not limited
612 to: ext2/3/4, btrfs, FAT and NTFS, LVM, many different disk partition
613 schemes, qcow, qcow2, vmdk.
615 Libguestfs provides ways to enumerate guest storage (eg. partitions,
616 LVs, what filesystem is in each LV, etc.). It can also run commands
617 in the context of the guest. Also you can access filesystems over
620 See also L<Sys::Guestfs::Lib(3)> for a set of useful library
621 functions for using libguestfs from Perl, including integration
626 All errors turn into calls to C<croak> (see L<Carp(3)>).
634 package Sys::Guestfs;
639 # This version number changes whenever a new function
640 # is added to the libguestfs API. It is not directly
641 # related to the libguestfs version number.
642 use vars qw($VERSION);
646 XSLoader::load ('Sys::Guestfs');
652 =item $h = Sys::Guestfs->new ();
654 Create a new guestfs handle.
660 my $class = ref ($proto) || $proto;
662 my $g = Sys::Guestfs::_create ();
663 my $self = { _g => $g };
670 Explicitly close the guestfs handle.
672 B<Note:> You should not usually call this function. The handle will
673 be closed implicitly when its reference count goes to zero (eg.
674 when it goes out of scope or the program ends). This call is
675 only required in some exceptional cases, such as where the program
676 may contain cached references to the handle 'somewhere' and you
677 really have to have the close happen right away. After calling
678 C<close> the program must not call any method (including C<close>)
679 on the handle (but the implicit call to C<DESTROY> that happens
680 when the final reference is cleaned up is OK).
685 fun (name, bitmask) ->
686 pr "=item $Sys::Guestfs::EVENT_%s\n" (String.uppercase name);
688 pr "See L<guestfs(3)/GUESTFS_EVENT_%s>.\n"
689 (String.uppercase name);
693 pr "our $EVENT_%s = 0x%x;\n" (String.uppercase name) bitmask;
698 =item $event_handle = $h->set_event_callback (\\&cb, $event_bitmask);
700 Register C<cb> as a callback function for all of the events
701 in C<$event_bitmask> (one or more C<$Sys::Guestfs::EVENT_*> flags
702 logically or'd together).
704 This function returns an event handle which
705 can be used to delete the callback using C<delete_event_callback>.
707 The callback function receives 4 parameters:
709 &cb ($event, $event_handle, $buf, $array)
715 The event which happened (equal to one of C<$Sys::Guestfs::EVENT_*>).
723 For some event types, this is a message buffer (ie. a string).
727 For some event types (notably progress events), this is
728 an array of integers.
732 You should carefully read the documentation for
733 L<guestfs(3)/guestfs_set_event_callback> before using
736 =item $h->delete_event_callback ($event_handle);
738 This removes the callback which was previously registered using
739 C<set_event_callback>.
745 (* Actions. We only need to print documentation for these as
746 * they are pulled in from the XS code automatically.
749 fun (name, style, _, flags, _, _, longdesc) ->
750 if not (List.mem NotInDocs flags) then (
751 let longdesc = replace_str longdesc "C<guestfs_" "C<$h-E<gt>" in
753 generate_perl_prototype name style;
755 pr "%s\n\n" longdesc;
756 if List.mem ProtocolLimitWarning flags then
757 pr "%s\n\n" protocol_limit_warning;
758 if List.mem DangerWillRobinson flags then
759 pr "%s\n\n" danger_will_robinson;
760 match deprecation_notice flags with
762 | Some txt -> pr "%s\n\n" txt
764 ) all_functions_sorted;
776 From time to time we add new libguestfs APIs. Also some libguestfs
777 APIs won't be available in all builds of libguestfs (the Fedora
778 build is full-featured, but other builds may disable features).
779 How do you test whether the APIs that your Perl program needs are
780 available in the version of C<Sys::Guestfs> that you are using?
782 To test if a particular function is available in the C<Sys::Guestfs>
783 class, use the ordinary Perl UNIVERSAL method C<can(METHOD)>
784 (see L<perlobj(1)>). For example:
787 if (defined (Sys::Guestfs->can (\"set_verbose\"))) {
788 print \"\\$h->set_verbose is available\\n\";
791 To test if particular features are supported by the current
792 build, use the L</available> method like the example below. Note
793 that the appliance must be launched first.
795 $h->available ( [\"augeas\"] );
797 Since the L</available> method croaks if the feature is not supported,
798 you might also want to wrap this in an eval and return a boolean.
799 In fact this has already been done for you: use
800 L<Sys::Guestfs::Lib(3)/feature_available>.
802 For further discussion on this topic, refer to
803 L<guestfs(3)/AVAILABILITY>.
805 =head1 STORING DATA IN THE HANDLE
807 The handle returned from L</new> is a hash reference. The hash
808 normally contains a single element:
811 _g => [private data used by libguestfs]
814 Callers can add other elements to this hash to store data for their own
815 purposes. The data lasts for the lifetime of the handle.
817 Any fields whose names begin with an underscore are reserved
818 for private use by libguestfs. We may add more in future.
820 It is recommended that callers prefix the name of their field(s)
821 with some unique string, to avoid conflicts with other users.
825 Copyright (C) %s Red Hat Inc.
829 Please see the file COPYING.LIB for the full license.
835 L<http://libguestfs.org>,
836 L<Sys::Guestfs::Lib(3)>.
841 and generate_perl_prototype name (ret, args, optargs) =
850 | RBufferOut n -> pr "$%s = " n
852 | RHashtable n -> pr "%%%s = " n
854 | RStructList (n,_) -> pr "@%s = " n
857 let comma = ref false in
860 if !comma then pr ", ";
863 | Pathname n | Device n | Dev_or_Path n | String n
864 | OptString n | Bool n | Int n | Int64 n | FileIn n | FileOut n
865 | BufferIn n | Key n | Pointer (_, n) ->
867 | StringList n | DeviceList n ->
872 if !comma then pr " [, " else pr "[";
874 let n = name_of_argt arg in