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);
271 errnum = guestfs_last_errno (g);
272 RETVAL = newSViv (errnum);
279 fun (name, (ret, args, optargs as style), _, _, _, _, _) ->
281 | RErr -> pr "void\n"
282 | RInt _ -> pr "SV *\n"
283 | RInt64 _ -> pr "SV *\n"
284 | RBool _ -> pr "SV *\n"
285 | RConstString _ -> pr "SV *\n"
286 | RConstOptString _ -> pr "SV *\n"
287 | RString _ -> pr "SV *\n"
288 | RBufferOut _ -> pr "SV *\n"
290 | RStruct _ | RStructList _
292 pr "void\n" (* all lists returned implictly on the stack *)
294 (* Call and arguments. *)
297 fun arg -> pr ", %s" (name_of_argt arg)
299 if optargs <> [] then
302 pr " guestfs_h *g;\n";
306 | Pathname n | Device n | Dev_or_Path n | String n
307 | FileIn n | FileOut n | Key n ->
311 pr " size_t %s_size = SvCUR (ST(%d));\n" n (i+1)
313 (* http://www.perlmonks.org/?node_id=554277
314 * Note that the implicit handle argument means we have
315 * to add 1 to the ST(x) operator.
317 pr " char *%s = SvOK(ST(%d)) ? SvPV_nolen(ST(%d)) : NULL;\n" n (i+1) (i+1)
318 | StringList n | DeviceList n -> pr " char **%s;\n" n
319 | Bool n -> pr " int %s;\n" n
320 | Int n -> pr " int %s;\n" n
321 | Int64 n -> pr " int64_t %s;\n" n
322 | Pointer (t, n) -> pr " %s %s;\n" t n
325 (* PREINIT section (local variable declarations). *)
336 pr " const char *r;\n";
337 | RConstOptString _ ->
338 pr " const char *r;\n";
341 | RStringList _ | RHashtable _ ->
343 pr " size_t i, n;\n";
344 | RStruct (_, typ) ->
345 pr " struct guestfs_%s *r;\n" typ;
346 | RStructList (_, typ) ->
347 pr " struct guestfs_%s_list *r;\n" typ;
352 pr " size_t size;\n";
355 if optargs <> [] then (
356 pr " struct guestfs_%s_argv optargs_s = { .bitmask = 0 };\n" name;
357 pr " struct guestfs_%s_argv *optargs = &optargs_s;\n" name;
358 pr " size_t items_i;\n";
361 (* CODE or PPCODE section. PPCODE is used where we are
362 * returning void, or where we push the return value on the stack
363 * ourselves. Using CODE means we will manipulate RETVAL.
375 | RConstOptString n ->
379 | RStringList n | RHashtable n ->
388 (* For optional arguments, convert these from the XSUB "items"
391 if optargs <> [] then (
392 let uc_name = String.uppercase name in
393 let skip = List.length args + 1 in
394 pr " if (((items - %d) & 1) != 0)\n" skip;
395 pr " croak (\"expecting an even number of extra parameters\");\n";
396 pr " for (items_i = %d; items_i < items; items_i += 2) {\n" skip;
397 pr " uint64_t this_mask;\n";
398 pr " const char *this_arg;\n";
400 pr " this_arg = SvPV_nolen (ST (items_i));\n";
404 let n = name_of_argt argt in
405 let uc_n = String.uppercase n in
406 pr "if (strcmp (this_arg, \"%s\") == 0) {\n" n;
407 pr " optargs_s.%s = " n;
411 | Int64 _ -> pr "SvIV (ST (items_i+1))"
412 | String _ -> pr "SvPV_nolen (ST (items_i+1))"
416 pr " this_mask = GUESTFS_%s_%s_BITMASK;\n" uc_name uc_n;
420 pr "croak (\"unknown optional argument '%%s'\", this_arg);\n";
421 pr " if (optargs_s.bitmask & this_mask)\n";
422 pr " croak (\"optional argument '%%s' given twice\",\n";
424 pr " optargs_s.bitmask |= this_mask;\n";
429 (* The call to the C function. *)
431 pr " r = guestfs_%s " name
433 pr " r = guestfs_%s_argv " name;
434 generate_c_call_args ~handle:"g" style;
437 (* Cleanup any arguments. *)
440 | Pathname _ | Device _ | Dev_or_Path _ | String _ | OptString _
441 | Bool _ | Int _ | Int64 _
442 | FileIn _ | FileOut _
443 | BufferIn _ | Key _ | Pointer _ -> ()
444 | StringList n | DeviceList n -> pr " free (%s);\n" n
447 (* Check return value for errors and return it if necessary. *)
450 pr " if (r == -1)\n";
451 pr " croak (\"%%s\", guestfs_last_error (g));\n";
454 pr " if (r == -1)\n";
455 pr " croak (\"%%s\", guestfs_last_error (g));\n";
456 pr " RETVAL = newSViv (r);\n";
460 pr " if (r == -1)\n";
461 pr " croak (\"%%s\", guestfs_last_error (g));\n";
462 pr " RETVAL = my_newSVll (r);\n";
466 pr " if (r == NULL)\n";
467 pr " croak (\"%%s\", guestfs_last_error (g));\n";
468 pr " RETVAL = newSVpv (r, 0);\n";
471 | RConstOptString n ->
472 pr " if (r == NULL)\n";
473 pr " RETVAL = &PL_sv_undef;\n";
475 pr " RETVAL = newSVpv (r, 0);\n";
479 pr " if (r == NULL)\n";
480 pr " croak (\"%%s\", guestfs_last_error (g));\n";
481 pr " RETVAL = newSVpv (r, 0);\n";
485 | RStringList n | RHashtable n ->
486 pr " if (r == NULL)\n";
487 pr " croak (\"%%s\", guestfs_last_error (g));\n";
488 pr " for (n = 0; r[n] != NULL; ++n) /**/;\n";
489 pr " EXTEND (SP, n);\n";
490 pr " for (i = 0; i < n; ++i) {\n";
491 pr " PUSHs (sv_2mortal (newSVpv (r[i], 0)));\n";
492 pr " free (r[i]);\n";
495 | RStruct (n, typ) ->
496 let cols = cols_of_struct typ in
497 generate_perl_struct_code typ cols name style n
498 | RStructList (n, typ) ->
499 let cols = cols_of_struct typ in
500 generate_perl_struct_list_code typ cols name style n
502 pr " if (r == NULL)\n";
503 pr " croak (\"%%s\", guestfs_last_error (g));\n";
504 pr " RETVAL = newSVpvn (r, size);\n";
513 and generate_perl_struct_list_code typ cols name style n =
514 pr " if (r == NULL)\n";
515 pr " croak (\"%%s\", guestfs_last_error (g));\n";
516 pr " EXTEND (SP, r->len);\n";
517 pr " for (i = 0; i < r->len; ++i) {\n";
518 pr " hv = newHV ();\n";
522 pr " (void) hv_store (hv, \"%s\", %d, newSVpv (r->val[i].%s, 0), 0);\n"
523 name (String.length name) name
525 pr " (void) hv_store (hv, \"%s\", %d, newSVpv (r->val[i].%s, 32), 0);\n"
526 name (String.length name) name
528 pr " (void) hv_store (hv, \"%s\", %d, newSVpvn (r->val[i].%s, r->val[i].%s_len), 0);\n"
529 name (String.length name) name name
530 | name, (FBytes|FUInt64) ->
531 pr " (void) hv_store (hv, \"%s\", %d, my_newSVull (r->val[i].%s), 0);\n"
532 name (String.length name) name
534 pr " (void) hv_store (hv, \"%s\", %d, my_newSVll (r->val[i].%s), 0);\n"
535 name (String.length name) name
536 | name, (FInt32|FUInt32) ->
537 pr " (void) hv_store (hv, \"%s\", %d, newSVnv (r->val[i].%s), 0);\n"
538 name (String.length name) name
540 pr " (void) hv_store (hv, \"%s\", %d, newSVpv (&r->val[i].%s, 1), 0);\n"
541 name (String.length name) name
542 | name, FOptPercent ->
543 pr " (void) hv_store (hv, \"%s\", %d, newSVnv (r->val[i].%s), 0);\n"
544 name (String.length name) name
546 pr " PUSHs (sv_2mortal (newRV ((SV *) hv)));\n";
548 pr " guestfs_free_%s_list (r);\n" typ
550 and generate_perl_struct_code typ cols name style n =
551 pr " if (r == NULL)\n";
552 pr " croak (\"%%s\", guestfs_last_error (g));\n";
553 pr " EXTEND (SP, 2 * %d);\n" (List.length cols);
555 fun ((name, _) as col) ->
556 pr " PUSHs (sv_2mortal (newSVpv (\"%s\", 0)));\n" name;
560 pr " PUSHs (sv_2mortal (newSVpv (r->%s, 0)));\n"
563 pr " PUSHs (sv_2mortal (newSVpvn (r->%s, r->%s_len)));\n"
566 pr " PUSHs (sv_2mortal (newSVpv (r->%s, 32)));\n"
568 | name, (FBytes|FUInt64) ->
569 pr " PUSHs (sv_2mortal (my_newSVull (r->%s)));\n"
572 pr " PUSHs (sv_2mortal (my_newSVll (r->%s)));\n"
574 | name, (FInt32|FUInt32) ->
575 pr " PUSHs (sv_2mortal (newSVnv (r->%s)));\n"
578 pr " PUSHs (sv_2mortal (newSVpv (&r->%s, 1)));\n"
580 | name, FOptPercent ->
581 pr " PUSHs (sv_2mortal (newSVnv (r->%s)));\n"
586 (* Generate Sys/Guestfs.pm. *)
587 and generate_perl_pm () =
588 generate_header HashStyle LGPLv2plus;
595 Sys::Guestfs - Perl bindings for libguestfs
601 my $h = Sys::Guestfs->new ();
602 $h->add_drive_opts ('guest.img', format => 'raw');
604 $h->mount_options ('', '/dev/sda1', '/');
605 $h->touch ('/hello');
610 The C<Sys::Guestfs> module provides a Perl XS binding to the
611 libguestfs API for examining and modifying virtual machine
614 Amongst the things this is good for: making batch configuration
615 changes to guests, getting disk used/free statistics (see also:
616 virt-df), migrating between virtualization systems (see also:
617 virt-p2v), performing partial backups, performing partial guest
618 clones, cloning guests and changing registry/UUID/hostname info, and
621 Libguestfs uses Linux kernel and qemu code, and can access any type of
622 guest filesystem that Linux and qemu can, including but not limited
623 to: ext2/3/4, btrfs, FAT and NTFS, LVM, many different disk partition
624 schemes, qcow, qcow2, vmdk.
626 Libguestfs provides ways to enumerate guest storage (eg. partitions,
627 LVs, what filesystem is in each LV, etc.). It can also run commands
628 in the context of the guest. Also you can access filesystems over
631 See also L<Sys::Guestfs::Lib(3)> for a set of useful library
632 functions for using libguestfs from Perl, including integration
637 All errors turn into calls to C<croak> (see L<Carp(3)>).
639 The error string from libguestfs is directly available from
640 C<$@>. Use the C<last_errno> method if you want to get the errno.
648 package Sys::Guestfs;
653 # This version number changes whenever a new function
654 # is added to the libguestfs API. It is not directly
655 # related to the libguestfs version number.
656 use vars qw($VERSION);
660 XSLoader::load ('Sys::Guestfs');
666 =item $h = Sys::Guestfs->new ();
668 Create a new guestfs handle.
674 my $class = ref ($proto) || $proto;
676 my $g = Sys::Guestfs::_create ();
677 my $self = { _g => $g };
684 Explicitly close the guestfs handle.
686 B<Note:> You should not usually call this function. The handle will
687 be closed implicitly when its reference count goes to zero (eg.
688 when it goes out of scope or the program ends). This call is
689 only required in some exceptional cases, such as where the program
690 may contain cached references to the handle 'somewhere' and you
691 really have to have the close happen right away. After calling
692 C<close> the program must not call any method (including C<close>)
693 on the handle (but the implicit call to C<DESTROY> that happens
694 when the final reference is cleaned up is OK).
699 fun (name, bitmask) ->
700 pr "=item $Sys::Guestfs::EVENT_%s\n" (String.uppercase name);
702 pr "See L<guestfs(3)/GUESTFS_EVENT_%s>.\n"
703 (String.uppercase name);
707 pr "our $EVENT_%s = 0x%x;\n" (String.uppercase name) bitmask;
712 =item $event_handle = $h->set_event_callback (\\&cb, $event_bitmask);
714 Register C<cb> as a callback function for all of the events
715 in C<$event_bitmask> (one or more C<$Sys::Guestfs::EVENT_*> flags
716 logically or'd together).
718 This function returns an event handle which
719 can be used to delete the callback using C<delete_event_callback>.
721 The callback function receives 4 parameters:
723 &cb ($event, $event_handle, $buf, $array)
729 The event which happened (equal to one of C<$Sys::Guestfs::EVENT_*>).
737 For some event types, this is a message buffer (ie. a string).
741 For some event types (notably progress events), this is
742 an array of integers.
746 You should carefully read the documentation for
747 L<guestfs(3)/guestfs_set_event_callback> before using
750 =item $h->delete_event_callback ($event_handle);
752 This removes the callback which was previously registered using
753 C<set_event_callback>.
755 =item $errnum = $h->last_errno ();
757 This returns the last error number (errno) that happened on the
760 If successful, an errno integer not equal to zero is returned.
762 If no error number is available, this returns 0.
763 See L<guestfs(3)/guestfs_last_errno> for more details of why
766 You can use the standard Perl module L<Errno(3)> to compare
767 the numeric error returned from this call with symbolic
770 $h->mkdir (\"/foo\");
771 if ($h->last_errno() == Errno::EEXIST()) {
772 # mkdir failed because the directory exists already.
779 (* Actions. We only need to print documentation for these as
780 * they are pulled in from the XS code automatically.
783 fun (name, style, _, flags, _, _, longdesc) ->
784 if not (List.mem NotInDocs flags) then (
785 let longdesc = replace_str longdesc "C<guestfs_" "C<$h-E<gt>" in
787 generate_perl_prototype name style;
789 pr "%s\n\n" longdesc;
790 if List.mem ProtocolLimitWarning flags then
791 pr "%s\n\n" protocol_limit_warning;
792 if List.mem DangerWillRobinson flags then
793 pr "%s\n\n" danger_will_robinson;
794 match deprecation_notice flags with
796 | Some txt -> pr "%s\n\n" txt
798 ) all_functions_sorted;
810 From time to time we add new libguestfs APIs. Also some libguestfs
811 APIs won't be available in all builds of libguestfs (the Fedora
812 build is full-featured, but other builds may disable features).
813 How do you test whether the APIs that your Perl program needs are
814 available in the version of C<Sys::Guestfs> that you are using?
816 To test if a particular function is available in the C<Sys::Guestfs>
817 class, use the ordinary Perl UNIVERSAL method C<can(METHOD)>
818 (see L<perlobj(1)>). For example:
821 if (defined (Sys::Guestfs->can (\"set_verbose\"))) {
822 print \"\\$h->set_verbose is available\\n\";
825 To test if particular features are supported by the current
826 build, use the L</available> method like the example below. Note
827 that the appliance must be launched first.
829 $h->available ( [\"augeas\"] );
831 Since the L</available> method croaks if the feature is not supported,
832 you might also want to wrap this in an eval and return a boolean.
833 In fact this has already been done for you: use
834 L<Sys::Guestfs::Lib(3)/feature_available>.
836 For further discussion on this topic, refer to
837 L<guestfs(3)/AVAILABILITY>.
839 =head1 STORING DATA IN THE HANDLE
841 The handle returned from L</new> is a hash reference. The hash
842 normally contains a single element:
845 _g => [private data used by libguestfs]
848 Callers can add other elements to this hash to store data for their own
849 purposes. The data lasts for the lifetime of the handle.
851 Any fields whose names begin with an underscore are reserved
852 for private use by libguestfs. We may add more in future.
854 It is recommended that callers prefix the name of their field(s)
855 with some unique string, to avoid conflicts with other users.
859 Copyright (C) %s Red Hat Inc.
863 Please see the file COPYING.LIB for the full license.
869 L<http://libguestfs.org>,
870 L<Sys::Guestfs::Lib(3)>.
875 and generate_perl_prototype name (ret, args, optargs) =
884 | RBufferOut n -> pr "$%s = " n
886 | RHashtable n -> pr "%%%s = " n
888 | RStructList (n,_) -> pr "@%s = " n
891 let comma = ref false in
894 if !comma then pr ", ";
897 | Pathname n | Device n | Dev_or_Path n | String n
898 | OptString n | Bool n | Int n | Int64 n | FileIn n | FileOut n
899 | BufferIn n | Key n | Pointer (_, n) ->
901 | StringList n | DeviceList n ->
906 if !comma then pr " [, " else pr "[";
908 let n = name_of_argt arg in