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
247 (* PREINIT section (local variable declarations). *)
258 pr " const char *r;\n";
259 | RConstOptString _ ->
260 pr " const char *r;\n";
263 | RStringList _ | RHashtable _ ->
265 pr " size_t i, n;\n";
266 | RStruct (_, typ) ->
267 pr " struct guestfs_%s *r;\n" typ;
268 | RStructList (_, typ) ->
269 pr " struct guestfs_%s_list *r;\n" typ;
274 pr " size_t size;\n";
277 if optargs <> [] then (
278 pr " struct guestfs_%s_argv optargs_s = { .bitmask = 0 };\n" name;
279 pr " struct guestfs_%s_argv *optargs = &optargs_s;\n" name;
280 pr " size_t items_i;\n";
283 (* CODE or PPCODE section. PPCODE is used where we are
284 * returning void, or where we push the return value on the stack
285 * ourselves. Using CODE means we will manipulate RETVAL.
297 | RConstOptString n ->
301 | RStringList n | RHashtable n ->
310 (* For optional arguments, convert these from the XSUB "items"
313 if optargs <> [] then (
314 let uc_name = String.uppercase name in
315 let skip = List.length args + 1 in
316 pr " if (((items - %d) & 1) != 0)\n" skip;
317 pr " croak (\"expecting an even number of extra parameters\");\n";
318 pr " for (items_i = %d; items_i < items; items_i += 2) {\n" skip;
319 pr " uint64_t this_mask;\n";
320 pr " const char *this_arg;\n";
322 pr " this_arg = SvPV_nolen (ST (items_i));\n";
326 let n = name_of_argt argt in
327 let uc_n = String.uppercase n in
328 pr "if (strcmp (this_arg, \"%s\") == 0) {\n" n;
329 pr " optargs_s.%s = " n;
333 | Int64 _ -> pr "SvIV (ST (items_i+1))"
334 | String _ -> pr "SvPV_nolen (ST (items_i+1))"
338 pr " this_mask = GUESTFS_%s_%s_BITMASK;\n" uc_name uc_n;
342 pr "croak (\"unknown optional argument '%%s'\", this_arg);\n";
343 pr " if (optargs_s.bitmask & this_mask)\n";
344 pr " croak (\"optional argument '%%s' given twice\",\n";
346 pr " optargs_s.bitmask |= this_mask;\n";
351 (* The call to the C function. *)
353 pr " r = guestfs_%s " name
355 pr " r = guestfs_%s_argv " name;
356 generate_c_call_args ~handle:"g" style;
359 (* Cleanup any arguments. *)
362 | Pathname _ | Device _ | Dev_or_Path _ | String _ | OptString _
363 | Bool _ | Int _ | Int64 _
364 | FileIn _ | FileOut _
365 | BufferIn _ | Key _ -> ()
366 | StringList n | DeviceList n -> pr " free (%s);\n" n
369 (* Check return value for errors and return it if necessary. *)
372 pr " if (r == -1)\n";
373 pr " croak (\"%%s\", guestfs_last_error (g));\n";
376 pr " if (r == -1)\n";
377 pr " croak (\"%%s\", guestfs_last_error (g));\n";
378 pr " RETVAL = newSViv (r);\n";
382 pr " if (r == -1)\n";
383 pr " croak (\"%%s\", guestfs_last_error (g));\n";
384 pr " RETVAL = my_newSVll (r);\n";
388 pr " if (r == NULL)\n";
389 pr " croak (\"%%s\", guestfs_last_error (g));\n";
390 pr " RETVAL = newSVpv (r, 0);\n";
393 | RConstOptString n ->
394 pr " if (r == NULL)\n";
395 pr " RETVAL = &PL_sv_undef;\n";
397 pr " RETVAL = newSVpv (r, 0);\n";
401 pr " if (r == NULL)\n";
402 pr " croak (\"%%s\", guestfs_last_error (g));\n";
403 pr " RETVAL = newSVpv (r, 0);\n";
407 | RStringList n | RHashtable n ->
408 pr " if (r == NULL)\n";
409 pr " croak (\"%%s\", guestfs_last_error (g));\n";
410 pr " for (n = 0; r[n] != NULL; ++n) /**/;\n";
411 pr " EXTEND (SP, n);\n";
412 pr " for (i = 0; i < n; ++i) {\n";
413 pr " PUSHs (sv_2mortal (newSVpv (r[i], 0)));\n";
414 pr " free (r[i]);\n";
417 | RStruct (n, typ) ->
418 let cols = cols_of_struct typ in
419 generate_perl_struct_code typ cols name style n
420 | RStructList (n, typ) ->
421 let cols = cols_of_struct typ in
422 generate_perl_struct_list_code typ cols name style n
424 pr " if (r == NULL)\n";
425 pr " croak (\"%%s\", guestfs_last_error (g));\n";
426 pr " RETVAL = newSVpvn (r, size);\n";
435 and generate_perl_struct_list_code typ cols name style n =
436 pr " if (r == NULL)\n";
437 pr " croak (\"%%s\", guestfs_last_error (g));\n";
438 pr " EXTEND (SP, r->len);\n";
439 pr " for (i = 0; i < r->len; ++i) {\n";
440 pr " hv = newHV ();\n";
444 pr " (void) hv_store (hv, \"%s\", %d, newSVpv (r->val[i].%s, 0), 0);\n"
445 name (String.length name) name
447 pr " (void) hv_store (hv, \"%s\", %d, newSVpv (r->val[i].%s, 32), 0);\n"
448 name (String.length name) name
450 pr " (void) hv_store (hv, \"%s\", %d, newSVpvn (r->val[i].%s, r->val[i].%s_len), 0);\n"
451 name (String.length name) name name
452 | name, (FBytes|FUInt64) ->
453 pr " (void) hv_store (hv, \"%s\", %d, my_newSVull (r->val[i].%s), 0);\n"
454 name (String.length name) name
456 pr " (void) hv_store (hv, \"%s\", %d, my_newSVll (r->val[i].%s), 0);\n"
457 name (String.length name) name
458 | name, (FInt32|FUInt32) ->
459 pr " (void) hv_store (hv, \"%s\", %d, newSVnv (r->val[i].%s), 0);\n"
460 name (String.length name) name
462 pr " (void) hv_store (hv, \"%s\", %d, newSVpv (&r->val[i].%s, 1), 0);\n"
463 name (String.length name) name
464 | name, FOptPercent ->
465 pr " (void) hv_store (hv, \"%s\", %d, newSVnv (r->val[i].%s), 0);\n"
466 name (String.length name) name
468 pr " PUSHs (sv_2mortal (newRV ((SV *) hv)));\n";
470 pr " guestfs_free_%s_list (r);\n" typ
472 and generate_perl_struct_code typ cols name style n =
473 pr " if (r == NULL)\n";
474 pr " croak (\"%%s\", guestfs_last_error (g));\n";
475 pr " EXTEND (SP, 2 * %d);\n" (List.length cols);
477 fun ((name, _) as col) ->
478 pr " PUSHs (sv_2mortal (newSVpv (\"%s\", 0)));\n" name;
482 pr " PUSHs (sv_2mortal (newSVpv (r->%s, 0)));\n"
485 pr " PUSHs (sv_2mortal (newSVpvn (r->%s, r->%s_len)));\n"
488 pr " PUSHs (sv_2mortal (newSVpv (r->%s, 32)));\n"
490 | name, (FBytes|FUInt64) ->
491 pr " PUSHs (sv_2mortal (my_newSVull (r->%s)));\n"
494 pr " PUSHs (sv_2mortal (my_newSVll (r->%s)));\n"
496 | name, (FInt32|FUInt32) ->
497 pr " PUSHs (sv_2mortal (newSVnv (r->%s)));\n"
500 pr " PUSHs (sv_2mortal (newSVpv (&r->%s, 1)));\n"
502 | name, FOptPercent ->
503 pr " PUSHs (sv_2mortal (newSVnv (r->%s)));\n"
508 (* Generate Sys/Guestfs.pm. *)
509 and generate_perl_pm () =
510 generate_header HashStyle LGPLv2plus;
517 Sys::Guestfs - Perl bindings for libguestfs
523 my $h = Sys::Guestfs->new ();
524 $h->add_drive_opts ('guest.img', format => 'raw');
526 $h->mount_options ('', '/dev/sda1', '/');
527 $h->touch ('/hello');
532 The C<Sys::Guestfs> module provides a Perl XS binding to the
533 libguestfs API for examining and modifying virtual machine
536 Amongst the things this is good for: making batch configuration
537 changes to guests, getting disk used/free statistics (see also:
538 virt-df), migrating between virtualization systems (see also:
539 virt-p2v), performing partial backups, performing partial guest
540 clones, cloning guests and changing registry/UUID/hostname info, and
543 Libguestfs uses Linux kernel and qemu code, and can access any type of
544 guest filesystem that Linux and qemu can, including but not limited
545 to: ext2/3/4, btrfs, FAT and NTFS, LVM, many different disk partition
546 schemes, qcow, qcow2, vmdk.
548 Libguestfs provides ways to enumerate guest storage (eg. partitions,
549 LVs, what filesystem is in each LV, etc.). It can also run commands
550 in the context of the guest. Also you can access filesystems over
553 See also L<Sys::Guestfs::Lib(3)> for a set of useful library
554 functions for using libguestfs from Perl, including integration
559 All errors turn into calls to C<croak> (see L<Carp(3)>).
567 package Sys::Guestfs;
572 # This version number changes whenever a new function
573 # is added to the libguestfs API. It is not directly
574 # related to the libguestfs version number.
575 use vars qw($VERSION);
579 XSLoader::load ('Sys::Guestfs');
581 =item $h = Sys::Guestfs->new ();
583 Create a new guestfs handle.
589 my $class = ref ($proto) || $proto;
591 my $g = Sys::Guestfs::_create ();
592 my $self = { _g => $g };
599 Explicitly close the guestfs handle.
601 B<Note:> You should not usually call this function. The handle will
602 be closed implicitly when its reference count goes to zero (eg.
603 when it goes out of scope or the program ends). This call is
604 only required in some exceptional cases, such as where the program
605 may contain cached references to the handle 'somewhere' and you
606 really have to have the close happen right away. After calling
607 C<close> the program must not call any method (including C<close>)
608 on the handle (but the implicit call to C<DESTROY> that happens
609 when the final reference is cleaned up is OK).
611 =item $h->set_progress_callback (\\&cb);
613 Set the progress notification callback for this handle
614 to the Perl closure C<cb>.
616 C<cb> will be called whenever a long-running operation
617 generates a progress notification message. The 4 parameters
618 to the function are: C<proc_nr>, C<serial>, C<position>
621 You should carefully read the documentation for
622 L<guestfs(3)/guestfs_set_progress_callback> before using
625 =item $h->clear_progress_callback ();
627 This removes any progress callback function associated with
634 (* Actions. We only need to print documentation for these as
635 * they are pulled in from the XS code automatically.
638 fun (name, style, _, flags, _, _, longdesc) ->
639 if not (List.mem NotInDocs flags) then (
640 let longdesc = replace_str longdesc "C<guestfs_" "C<$h-E<gt>" in
642 generate_perl_prototype name style;
644 pr "%s\n\n" longdesc;
645 if List.mem ProtocolLimitWarning flags then
646 pr "%s\n\n" protocol_limit_warning;
647 if List.mem DangerWillRobinson flags then
648 pr "%s\n\n" danger_will_robinson;
649 match deprecation_notice flags with
651 | Some txt -> pr "%s\n\n" txt
653 ) all_functions_sorted;
665 From time to time we add new libguestfs APIs. Also some libguestfs
666 APIs won't be available in all builds of libguestfs (the Fedora
667 build is full-featured, but other builds may disable features).
668 How do you test whether the APIs that your Perl program needs are
669 available in the version of C<Sys::Guestfs> that you are using?
671 To test if a particular function is available in the C<Sys::Guestfs>
672 class, use the ordinary Perl UNIVERSAL method C<can(METHOD)>
673 (see L<perlobj(1)>). For example:
676 if (defined (Sys::Guestfs->can (\"set_verbose\"))) {
677 print \"\\$h->set_verbose is available\\n\";
680 To test if particular features are supported by the current
681 build, use the L</available> method like the example below. Note
682 that the appliance must be launched first.
684 $h->available ( [\"augeas\"] );
686 Since the L</available> method croaks if the feature is not supported,
687 you might also want to wrap this in an eval and return a boolean.
688 In fact this has already been done for you: use
689 L<Sys::Guestfs::Lib(3)/feature_available>.
691 For further discussion on this topic, refer to
692 L<guestfs(3)/AVAILABILITY>.
694 =head1 STORING DATA IN THE HANDLE
696 The handle returned from L</new> is a hash reference. The hash
697 normally contains a single element:
700 _g => [private data used by libguestfs]
703 Callers can add other elements to this hash to store data for their own
704 purposes. The data lasts for the lifetime of the handle.
706 Any fields whose names begin with an underscore are reserved
707 for private use by libguestfs. We may add more in future.
709 It is recommended that callers prefix the name of their field(s)
710 with some unique string, to avoid conflicts with other users.
714 Copyright (C) %s Red Hat Inc.
718 Please see the file COPYING.LIB for the full license.
724 L<http://libguestfs.org>,
725 L<Sys::Guestfs::Lib(3)>.
730 and generate_perl_prototype name (ret, args, optargs) =
739 | RBufferOut n -> pr "$%s = " n
741 | RHashtable n -> pr "%%%s = " n
743 | RStructList (n,_) -> pr "@%s = " n
746 let comma = ref false in
749 if !comma then pr ", ";
752 | Pathname n | Device n | Dev_or_Path n | String n
753 | OptString n | Bool n | Int n | Int64 n | FileIn n | FileOut n
754 | BufferIn n | Key n ->
756 | StringList n | DeviceList n ->
761 if !comma then pr " [, " else pr "[";
763 let n = name_of_argt arg in