2 * Copyright (C) 2009-2010 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
32 (* Generate Perl xs code, a sort of crazy variation of C with macros. *)
33 let rec generate_perl_xs () =
34 generate_header CStyle LGPLv2plus;
44 #define PRId64 \"lld\"
48 my_newSVll(long long val) {
54 len = snprintf(buf, 100, \"%%\" PRId64, val);
55 return newSVpv(buf, len);
60 #define PRIu64 \"llu\"
64 my_newSVull(unsigned long long val) {
70 len = snprintf(buf, 100, \"%%\" PRIu64, val);
71 return newSVpv(buf, len);
75 /* http://www.perlmonks.org/?node_id=680842 */
77 XS_unpack_charPtrPtr (SV *arg) {
82 if (!arg || !SvOK (arg) || !SvROK (arg) || SvTYPE (SvRV (arg)) != SVt_PVAV)
83 croak (\"array reference expected\");
85 av = (AV *)SvRV (arg);
86 ret = malloc ((av_len (av) + 1 + 1) * sizeof (char *));
88 croak (\"malloc failed\");
90 for (i = 0; i <= av_len (av); i++) {
91 SV **elem = av_fetch (av, i, 0);
94 croak (\"missing element in list\");
96 ret[i] = SvPV_nolen (*elem);
104 #define PROGRESS_KEY \"_perl_progress_cb\"
107 _clear_progress_callback (guestfs_h *g)
109 guestfs_set_progress_callback (g, NULL, NULL);
110 SV *cb = guestfs_get_private (g, PROGRESS_KEY);
112 guestfs_set_private (g, PROGRESS_KEY, NULL);
117 /* http://www.perlmonks.org/?node=338857 */
119 _progress_callback (guestfs_h *g, void *cb,
120 int proc_nr, int serial, uint64_t position, uint64_t total)
126 XPUSHs (sv_2mortal (newSViv (proc_nr)));
127 XPUSHs (sv_2mortal (newSViv (serial)));
128 XPUSHs (sv_2mortal (my_newSVull (position)));
129 XPUSHs (sv_2mortal (my_newSVull (total)));
131 call_sv ((SV *) cb, G_VOID | G_DISCARD | G_EVAL);
137 _close_handle (guestfs_h *g)
140 _clear_progress_callback (g);
144 MODULE = Sys::Guestfs PACKAGE = Sys::Guestfs
151 RETVAL = guestfs_create ();
153 croak (\"could not create guestfs handle\");
154 guestfs_set_error_handler (RETVAL, NULL, NULL);
162 /* For the 'g' argument above we do the conversion explicitly and
163 * don't rely on the typemap, because if the handle has been
164 * explicitly closed we don't want the typemap conversion to
167 HV *hv = (HV *) SvRV (sv);
168 SV **svp = hv_fetch (hv, \"_g\", 2, 0);
170 guestfs_h *g = (guestfs_h *) SvIV (*svp);
179 /* Avoid double-free in DESTROY method. */
180 HV *hv = (HV *) SvRV (ST(0));
181 (void) hv_delete (hv, \"_g\", 2, G_DISCARD);
184 set_progress_callback (g, cb)
188 _clear_progress_callback (g);
190 guestfs_set_private (g, PROGRESS_KEY, cb);
191 guestfs_set_progress_callback (g, _progress_callback, cb);
194 clear_progress_callback (g)
197 _clear_progress_callback (g);
202 fun (name, (ret, args, optargs as style), _, _, _, _, _) ->
204 | RErr -> pr "void\n"
205 | RInt _ -> pr "SV *\n"
206 | RInt64 _ -> pr "SV *\n"
207 | RBool _ -> pr "SV *\n"
208 | RConstString _ -> pr "SV *\n"
209 | RConstOptString _ -> pr "SV *\n"
210 | RString _ -> pr "SV *\n"
211 | RBufferOut _ -> pr "SV *\n"
213 | RStruct _ | RStructList _
215 pr "void\n" (* all lists returned implictly on the stack *)
217 (* Call and arguments. *)
220 fun arg -> pr ", %s" (name_of_argt arg)
222 if optargs <> [] then
225 pr " guestfs_h *g;\n";
229 | Pathname n | Device n | Dev_or_Path n | String n
230 | FileIn n | FileOut n | Key n ->
234 pr " size_t %s_size = SvCUR (ST(%d));\n" n (i+1)
236 (* http://www.perlmonks.org/?node_id=554277
237 * Note that the implicit handle argument means we have
238 * to add 1 to the ST(x) operator.
240 pr " char *%s = SvOK(ST(%d)) ? SvPV_nolen(ST(%d)) : NULL;\n" n (i+1) (i+1)
241 | StringList n | DeviceList n -> pr " char **%s;\n" n
242 | Bool n -> pr " int %s;\n" n
243 | Int n -> pr " int %s;\n" n
244 | Int64 n -> pr " int64_t %s;\n" n
245 | Pointer (t, n) -> pr " %s %s;\n" t n
248 (* PREINIT section (local variable declarations). *)
259 pr " const char *r;\n";
260 | RConstOptString _ ->
261 pr " const char *r;\n";
264 | RStringList _ | RHashtable _ ->
266 pr " size_t i, n;\n";
267 | RStruct (_, typ) ->
268 pr " struct guestfs_%s *r;\n" typ;
269 | RStructList (_, typ) ->
270 pr " struct guestfs_%s_list *r;\n" typ;
275 pr " size_t size;\n";
278 if optargs <> [] then (
279 pr " struct guestfs_%s_argv optargs_s = { .bitmask = 0 };\n" name;
280 pr " struct guestfs_%s_argv *optargs = &optargs_s;\n" name;
281 pr " size_t items_i;\n";
284 (* CODE or PPCODE section. PPCODE is used where we are
285 * returning void, or where we push the return value on the stack
286 * ourselves. Using CODE means we will manipulate RETVAL.
298 | RConstOptString n ->
302 | RStringList n | RHashtable n ->
311 (* For optional arguments, convert these from the XSUB "items"
314 if optargs <> [] then (
315 let uc_name = String.uppercase name in
316 let skip = List.length args + 1 in
317 pr " if (((items - %d) & 1) != 0)\n" skip;
318 pr " croak (\"expecting an even number of extra parameters\");\n";
319 pr " for (items_i = %d; items_i < items; items_i += 2) {\n" skip;
320 pr " uint64_t this_mask;\n";
321 pr " const char *this_arg;\n";
323 pr " this_arg = SvPV_nolen (ST (items_i));\n";
327 let n = name_of_argt argt in
328 let uc_n = String.uppercase n in
329 pr "if (strcmp (this_arg, \"%s\") == 0) {\n" n;
330 pr " optargs_s.%s = " n;
334 | Int64 _ -> pr "SvIV (ST (items_i+1))"
335 | String _ -> pr "SvPV_nolen (ST (items_i+1))"
339 pr " this_mask = GUESTFS_%s_%s_BITMASK;\n" uc_name uc_n;
343 pr "croak (\"unknown optional argument '%%s'\", this_arg);\n";
344 pr " if (optargs_s.bitmask & this_mask)\n";
345 pr " croak (\"optional argument '%%s' given twice\",\n";
347 pr " optargs_s.bitmask |= this_mask;\n";
352 (* The call to the C function. *)
354 pr " r = guestfs_%s " name
356 pr " r = guestfs_%s_argv " name;
357 generate_c_call_args ~handle:"g" style;
360 (* Cleanup any arguments. *)
363 | Pathname _ | Device _ | Dev_or_Path _ | String _ | OptString _
364 | Bool _ | Int _ | Int64 _
365 | FileIn _ | FileOut _
366 | BufferIn _ | Key _ | Pointer _ -> ()
367 | StringList n | DeviceList n -> pr " free (%s);\n" n
370 (* Check return value for errors and return it if necessary. *)
373 pr " if (r == -1)\n";
374 pr " croak (\"%%s\", guestfs_last_error (g));\n";
377 pr " if (r == -1)\n";
378 pr " croak (\"%%s\", guestfs_last_error (g));\n";
379 pr " RETVAL = newSViv (r);\n";
383 pr " if (r == -1)\n";
384 pr " croak (\"%%s\", guestfs_last_error (g));\n";
385 pr " RETVAL = my_newSVll (r);\n";
389 pr " if (r == NULL)\n";
390 pr " croak (\"%%s\", guestfs_last_error (g));\n";
391 pr " RETVAL = newSVpv (r, 0);\n";
394 | RConstOptString n ->
395 pr " if (r == NULL)\n";
396 pr " RETVAL = &PL_sv_undef;\n";
398 pr " RETVAL = newSVpv (r, 0);\n";
402 pr " if (r == NULL)\n";
403 pr " croak (\"%%s\", guestfs_last_error (g));\n";
404 pr " RETVAL = newSVpv (r, 0);\n";
408 | RStringList n | RHashtable n ->
409 pr " if (r == NULL)\n";
410 pr " croak (\"%%s\", guestfs_last_error (g));\n";
411 pr " for (n = 0; r[n] != NULL; ++n) /**/;\n";
412 pr " EXTEND (SP, n);\n";
413 pr " for (i = 0; i < n; ++i) {\n";
414 pr " PUSHs (sv_2mortal (newSVpv (r[i], 0)));\n";
415 pr " free (r[i]);\n";
418 | RStruct (n, typ) ->
419 let cols = cols_of_struct typ in
420 generate_perl_struct_code typ cols name style n
421 | RStructList (n, typ) ->
422 let cols = cols_of_struct typ in
423 generate_perl_struct_list_code typ cols name style n
425 pr " if (r == NULL)\n";
426 pr " croak (\"%%s\", guestfs_last_error (g));\n";
427 pr " RETVAL = newSVpvn (r, size);\n";
436 and generate_perl_struct_list_code typ cols name style n =
437 pr " if (r == NULL)\n";
438 pr " croak (\"%%s\", guestfs_last_error (g));\n";
439 pr " EXTEND (SP, r->len);\n";
440 pr " for (i = 0; i < r->len; ++i) {\n";
441 pr " hv = newHV ();\n";
445 pr " (void) hv_store (hv, \"%s\", %d, newSVpv (r->val[i].%s, 0), 0);\n"
446 name (String.length name) name
448 pr " (void) hv_store (hv, \"%s\", %d, newSVpv (r->val[i].%s, 32), 0);\n"
449 name (String.length name) name
451 pr " (void) hv_store (hv, \"%s\", %d, newSVpvn (r->val[i].%s, r->val[i].%s_len), 0);\n"
452 name (String.length name) name name
453 | name, (FBytes|FUInt64) ->
454 pr " (void) hv_store (hv, \"%s\", %d, my_newSVull (r->val[i].%s), 0);\n"
455 name (String.length name) name
457 pr " (void) hv_store (hv, \"%s\", %d, my_newSVll (r->val[i].%s), 0);\n"
458 name (String.length name) name
459 | name, (FInt32|FUInt32) ->
460 pr " (void) hv_store (hv, \"%s\", %d, newSVnv (r->val[i].%s), 0);\n"
461 name (String.length name) name
463 pr " (void) hv_store (hv, \"%s\", %d, newSVpv (&r->val[i].%s, 1), 0);\n"
464 name (String.length name) name
465 | name, FOptPercent ->
466 pr " (void) hv_store (hv, \"%s\", %d, newSVnv (r->val[i].%s), 0);\n"
467 name (String.length name) name
469 pr " PUSHs (sv_2mortal (newRV ((SV *) hv)));\n";
471 pr " guestfs_free_%s_list (r);\n" typ
473 and generate_perl_struct_code typ cols name style n =
474 pr " if (r == NULL)\n";
475 pr " croak (\"%%s\", guestfs_last_error (g));\n";
476 pr " EXTEND (SP, 2 * %d);\n" (List.length cols);
478 fun ((name, _) as col) ->
479 pr " PUSHs (sv_2mortal (newSVpv (\"%s\", 0)));\n" name;
483 pr " PUSHs (sv_2mortal (newSVpv (r->%s, 0)));\n"
486 pr " PUSHs (sv_2mortal (newSVpvn (r->%s, r->%s_len)));\n"
489 pr " PUSHs (sv_2mortal (newSVpv (r->%s, 32)));\n"
491 | name, (FBytes|FUInt64) ->
492 pr " PUSHs (sv_2mortal (my_newSVull (r->%s)));\n"
495 pr " PUSHs (sv_2mortal (my_newSVll (r->%s)));\n"
497 | name, (FInt32|FUInt32) ->
498 pr " PUSHs (sv_2mortal (newSVnv (r->%s)));\n"
501 pr " PUSHs (sv_2mortal (newSVpv (&r->%s, 1)));\n"
503 | name, FOptPercent ->
504 pr " PUSHs (sv_2mortal (newSVnv (r->%s)));\n"
509 (* Generate Sys/Guestfs.pm. *)
510 and generate_perl_pm () =
511 generate_header HashStyle LGPLv2plus;
518 Sys::Guestfs - Perl bindings for libguestfs
524 my $h = Sys::Guestfs->new ();
525 $h->add_drive_opts ('guest.img', format => 'raw');
527 $h->mount_options ('', '/dev/sda1', '/');
528 $h->touch ('/hello');
533 The C<Sys::Guestfs> module provides a Perl XS binding to the
534 libguestfs API for examining and modifying virtual machine
537 Amongst the things this is good for: making batch configuration
538 changes to guests, getting disk used/free statistics (see also:
539 virt-df), migrating between virtualization systems (see also:
540 virt-p2v), performing partial backups, performing partial guest
541 clones, cloning guests and changing registry/UUID/hostname info, and
544 Libguestfs uses Linux kernel and qemu code, and can access any type of
545 guest filesystem that Linux and qemu can, including but not limited
546 to: ext2/3/4, btrfs, FAT and NTFS, LVM, many different disk partition
547 schemes, qcow, qcow2, vmdk.
549 Libguestfs provides ways to enumerate guest storage (eg. partitions,
550 LVs, what filesystem is in each LV, etc.). It can also run commands
551 in the context of the guest. Also you can access filesystems over
554 See also L<Sys::Guestfs::Lib(3)> for a set of useful library
555 functions for using libguestfs from Perl, including integration
560 All errors turn into calls to C<croak> (see L<Carp(3)>).
568 package Sys::Guestfs;
573 # This version number changes whenever a new function
574 # is added to the libguestfs API. It is not directly
575 # related to the libguestfs version number.
576 use vars qw($VERSION);
580 XSLoader::load ('Sys::Guestfs');
582 =item $h = Sys::Guestfs->new ();
584 Create a new guestfs handle.
590 my $class = ref ($proto) || $proto;
592 my $g = Sys::Guestfs::_create ();
593 my $self = { _g => $g };
600 Explicitly close the guestfs handle.
602 B<Note:> You should not usually call this function. The handle will
603 be closed implicitly when its reference count goes to zero (eg.
604 when it goes out of scope or the program ends). This call is
605 only required in some exceptional cases, such as where the program
606 may contain cached references to the handle 'somewhere' and you
607 really have to have the close happen right away. After calling
608 C<close> the program must not call any method (including C<close>)
609 on the handle (but the implicit call to C<DESTROY> that happens
610 when the final reference is cleaned up is OK).
612 =item $h->set_progress_callback (\\&cb);
614 Set the progress notification callback for this handle
615 to the Perl closure C<cb>.
617 C<cb> will be called whenever a long-running operation
618 generates a progress notification message. The 4 parameters
619 to the function are: C<proc_nr>, C<serial>, C<position>
622 You should carefully read the documentation for
623 L<guestfs(3)/guestfs_set_progress_callback> before using
626 =item $h->clear_progress_callback ();
628 This removes any progress callback function associated with
635 (* Actions. We only need to print documentation for these as
636 * they are pulled in from the XS code automatically.
639 fun (name, style, _, flags, _, _, longdesc) ->
640 if not (List.mem NotInDocs flags) then (
641 let longdesc = replace_str longdesc "C<guestfs_" "C<$h-E<gt>" in
643 generate_perl_prototype name style;
645 pr "%s\n\n" longdesc;
646 if List.mem ProtocolLimitWarning flags then
647 pr "%s\n\n" protocol_limit_warning;
648 if List.mem DangerWillRobinson flags then
649 pr "%s\n\n" danger_will_robinson;
650 match deprecation_notice flags with
652 | Some txt -> pr "%s\n\n" txt
654 ) all_functions_sorted;
658 (* Introspection hash. *)
659 pr "use vars qw(%%guestfs_introspection);\n";
660 pr "%%guestfs_introspection = (\n";
662 fun (name, (ret, args, optargs), _, _, _, shortdesc, _) ->
663 pr " \"%s\" => {\n" name;
666 | RErr -> pr "'void'"
667 | RInt _ -> pr "'int'"
668 | RBool _ -> pr "'bool'"
669 | RInt64 _ -> pr "'int64'"
670 | RConstString _ -> pr "'const string'"
671 | RConstOptString _ -> pr "'const nullable string'"
672 | RString _ -> pr "'string'"
673 | RStringList _ -> pr "'string list'"
674 | RHashtable _ -> pr "'hash'"
675 | RStruct (_, typ) -> pr "'struct %s'" typ
676 | RStructList (_, typ) -> pr "'struct %s list'" typ
677 | RBufferOut _ -> pr "'buffer'"
680 let pr_type i = function
681 | Pathname n -> pr "[ '%s', 'string(path)', %d ]" n i
682 | Device n -> pr "[ '%s', 'string(device)', %d ]" n i
683 | Dev_or_Path n -> pr "[ '%s', 'string(dev_or_path)', %d ]" n i
684 | String n -> pr "[ '%s', 'string', %d ]" n i
685 | FileIn n -> pr "[ '%s', 'string(filename)', %d ]" n i
686 | FileOut n -> pr "[ '%s', 'string(filename)', %d ]" n i
687 | Key n -> pr "[ '%s', 'string(key)', %d ]" n i
688 | BufferIn n -> pr "[ '%s', 'buffer', %d ]" n i
689 | OptString n -> pr "[ '%s', 'nullable string', %d ]" n i
690 | StringList n -> pr "[ '%s', 'string list', %d ]" n i
691 | DeviceList n -> pr "[ '%s', 'string(device) list', %d ]" n i
692 | Bool n -> pr "[ '%s', 'bool', %d ]" n i
693 | Int n -> pr "[ '%s', 'int', %d ]" n i
694 | Int64 n -> pr "[ '%s', 'int64', %d ]" n i
695 | Pointer (t, n) -> pr "[ '%s', 'pointer(%s)', %d ]" n t i
704 if optargs <> [] then (
705 pr " optargs => {\n";
707 pr " %s => " (name_of_argt arg);
713 pr " name => \"%s\",\n" name;
714 pr " description => %S,\n" shortdesc;
716 ) all_functions_sorted;
727 From time to time we add new libguestfs APIs. Also some libguestfs
728 APIs won't be available in all builds of libguestfs (the Fedora
729 build is full-featured, but other builds may disable features).
730 How do you test whether the APIs that your Perl program needs are
731 available in the version of C<Sys::Guestfs> that you are using?
733 To test if a particular function is available in the C<Sys::Guestfs>
734 class, use the ordinary Perl UNIVERSAL method C<can(METHOD)>
735 (see L<perlobj(1)>). For example:
738 if (defined (Sys::Guestfs->can (\"set_verbose\"))) {
739 print \"\\$h->set_verbose is available\\n\";
742 Perl does not offer a way to list the arguments of a method, and
743 from time to time we may add extra arguments to calls that take
744 optional arguments. For this reason, we provide a global hash
745 variable C<%%guestfs_introspection> which contains the arguments
746 and their types for each libguestfs method. The keys of this
747 hash are the method names, and the values are an hashref
748 containing useful introspection information about the method
749 (further fields may be added to this in future).
752 $Sys::Guestfs::guestfs_introspection{mkfs_opts}
754 ret => 'void', # return type
755 args => [ # required arguments
756 [ 'fstype', 'string', 0 ],
757 [ 'device', 'string(device)', 1 ],
759 optargs => { # optional arguments
760 blocksize => [ 'blocksize', 'int', 0 ],
761 features => [ 'features', 'string', 1 ],
762 inode => [ 'inode', 'int', 2 ],
763 sectorsize => [ 'sectorsize', 'int', 3 ],
765 name => \"mkfs_opts\",
766 description => \"make a filesystem\",
769 To test if particular features are supported by the current
770 build, use the L</available> method like the example below. Note
771 that the appliance must be launched first.
773 $h->available ( [\"augeas\"] );
775 Since the L</available> method croaks if the feature is not supported,
776 you might also want to wrap this in an eval and return a boolean.
777 In fact this has already been done for you: use
778 L<Sys::Guestfs::Lib(3)/feature_available>.
780 For further discussion on this topic, refer to
781 L<guestfs(3)/AVAILABILITY>.
783 =head1 STORING DATA IN THE HANDLE
785 The handle returned from L</new> is a hash reference. The hash
786 normally contains a single element:
789 _g => [private data used by libguestfs]
792 Callers can add other elements to this hash to store data for their own
793 purposes. The data lasts for the lifetime of the handle.
795 Any fields whose names begin with an underscore are reserved
796 for private use by libguestfs. We may add more in future.
798 It is recommended that callers prefix the name of their field(s)
799 with some unique string, to avoid conflicts with other users.
803 Copyright (C) %s Red Hat Inc.
807 Please see the file COPYING.LIB for the full license.
813 L<http://libguestfs.org>,
814 L<Sys::Guestfs::Lib(3)>.
819 and generate_perl_prototype name (ret, args, optargs) =
828 | RBufferOut n -> pr "$%s = " n
830 | RHashtable n -> pr "%%%s = " n
832 | RStructList (n,_) -> pr "@%s = " n
835 let comma = ref false in
838 if !comma then pr ", ";
841 | Pathname n | Device n | Dev_or_Path n | String n
842 | OptString n | Bool n | Int n | Int64 n | FileIn n | FileOut n
843 | BufferIn n | Key n | Pointer (_, n) ->
845 | StringList n | DeviceList n ->
850 if !comma then pr " [, " else pr "[";
852 let n = name_of_argt arg in