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;
666 From time to time we add new libguestfs APIs. Also some libguestfs
667 APIs won't be available in all builds of libguestfs (the Fedora
668 build is full-featured, but other builds may disable features).
669 How do you test whether the APIs that your Perl program needs are
670 available in the version of C<Sys::Guestfs> that you are using?
672 To test if a particular function is available in the C<Sys::Guestfs>
673 class, use the ordinary Perl UNIVERSAL method C<can(METHOD)>
674 (see L<perlobj(1)>). For example:
677 if (defined (Sys::Guestfs->can (\"set_verbose\"))) {
678 print \"\\$h->set_verbose is available\\n\";
681 To test if particular features are supported by the current
682 build, use the L</available> method like the example below. Note
683 that the appliance must be launched first.
685 $h->available ( [\"augeas\"] );
687 Since the L</available> method croaks if the feature is not supported,
688 you might also want to wrap this in an eval and return a boolean.
689 In fact this has already been done for you: use
690 L<Sys::Guestfs::Lib(3)/feature_available>.
692 For further discussion on this topic, refer to
693 L<guestfs(3)/AVAILABILITY>.
695 =head1 STORING DATA IN THE HANDLE
697 The handle returned from L</new> is a hash reference. The hash
698 normally contains a single element:
701 _g => [private data used by libguestfs]
704 Callers can add other elements to this hash to store data for their own
705 purposes. The data lasts for the lifetime of the handle.
707 Any fields whose names begin with an underscore are reserved
708 for private use by libguestfs. We may add more in future.
710 It is recommended that callers prefix the name of their field(s)
711 with some unique string, to avoid conflicts with other users.
715 Copyright (C) %s Red Hat Inc.
719 Please see the file COPYING.LIB for the full license.
725 L<http://libguestfs.org>,
726 L<Sys::Guestfs::Lib(3)>.
731 and generate_perl_prototype name (ret, args, optargs) =
740 | RBufferOut n -> pr "$%s = " n
742 | RHashtable n -> pr "%%%s = " n
744 | RStructList (n,_) -> pr "@%s = " n
747 let comma = ref false in
750 if !comma then pr ", ";
753 | Pathname n | Device n | Dev_or_Path n | String n
754 | OptString n | Bool n | Int n | Int64 n | FileIn n | FileOut n
755 | BufferIn n | Key n | Pointer (_, n) ->
757 | StringList n | DeviceList n ->
762 if !comma then pr " [, " else pr "[";
764 let n = name_of_argt arg in