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, style, _, _, _, _, _) ->
203 (match fst style with
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)
223 pr " guestfs_h *g;\n";
227 | Pathname n | Device n | Dev_or_Path n | String n
228 | FileIn n | FileOut n | Key n ->
232 pr " size_t %s_size = SvCUR (ST(%d));\n" n (i+1)
234 (* http://www.perlmonks.org/?node_id=554277
235 * Note that the implicit handle argument means we have
236 * to add 1 to the ST(x) operator.
238 pr " char *%s = SvOK(ST(%d)) ? SvPV_nolen(ST(%d)) : NULL;\n" n (i+1) (i+1)
239 | StringList n | DeviceList n -> pr " char **%s;\n" n
240 | Bool n -> pr " int %s;\n" n
241 | Int n -> pr " int %s;\n" n
242 | Int64 n -> pr " int64_t %s;\n" n
248 | Pathname _ | Device _ | Dev_or_Path _ | String _ | OptString _
249 | Bool _ | Int _ | Int64 _
250 | FileIn _ | FileOut _
251 | BufferIn _ | Key _ -> ()
252 | StringList n | DeviceList n -> pr " free (%s);\n" n
257 (match fst style with
262 pr " r = guestfs_%s " name;
263 generate_c_call_args ~handle:"g" style;
266 pr " if (r == -1)\n";
267 pr " croak (\"%%s\", guestfs_last_error (g));\n";
273 pr " %s = guestfs_%s " n name;
274 generate_c_call_args ~handle:"g" style;
277 pr " if (%s == -1)\n" n;
278 pr " croak (\"%%s\", guestfs_last_error (g));\n";
279 pr " RETVAL = newSViv (%s);\n" n;
284 pr " int64_t %s;\n" n;
286 pr " %s = guestfs_%s " n name;
287 generate_c_call_args ~handle:"g" style;
290 pr " if (%s == -1)\n" n;
291 pr " croak (\"%%s\", guestfs_last_error (g));\n";
292 pr " RETVAL = my_newSVll (%s);\n" n;
297 pr " const char *%s;\n" n;
299 pr " %s = guestfs_%s " n name;
300 generate_c_call_args ~handle:"g" style;
303 pr " if (%s == NULL)\n" n;
304 pr " croak (\"%%s\", guestfs_last_error (g));\n";
305 pr " RETVAL = newSVpv (%s, 0);\n" n;
308 | RConstOptString n ->
310 pr " const char *%s;\n" n;
312 pr " %s = guestfs_%s " n name;
313 generate_c_call_args ~handle:"g" style;
316 pr " if (%s == NULL)\n" n;
317 pr " RETVAL = &PL_sv_undef;\n";
319 pr " RETVAL = newSVpv (%s, 0);\n" n;
326 pr " %s = guestfs_%s " n name;
327 generate_c_call_args ~handle:"g" style;
330 pr " if (%s == NULL)\n" n;
331 pr " croak (\"%%s\", guestfs_last_error (g));\n";
332 pr " RETVAL = newSVpv (%s, 0);\n" n;
333 pr " free (%s);\n" n;
336 | RStringList n | RHashtable n ->
338 pr " char **%s;\n" n;
339 pr " size_t i, n;\n";
341 pr " %s = guestfs_%s " n name;
342 generate_c_call_args ~handle:"g" style;
345 pr " if (%s == NULL)\n" n;
346 pr " croak (\"%%s\", guestfs_last_error (g));\n";
347 pr " for (n = 0; %s[n] != NULL; ++n) /**/;\n" n;
348 pr " EXTEND (SP, n);\n";
349 pr " for (i = 0; i < n; ++i) {\n";
350 pr " PUSHs (sv_2mortal (newSVpv (%s[i], 0)));\n" n;
351 pr " free (%s[i]);\n" n;
353 pr " free (%s);\n" n;
354 | RStruct (n, typ) ->
355 let cols = cols_of_struct typ in
356 generate_perl_struct_code typ cols name style n do_cleanups
357 | RStructList (n, typ) ->
358 let cols = cols_of_struct typ in
359 generate_perl_struct_list_code typ cols name style n do_cleanups
363 pr " size_t size;\n";
365 pr " %s = guestfs_%s " n name;
366 generate_c_call_args ~handle:"g" style;
369 pr " if (%s == NULL)\n" n;
370 pr " croak (\"%%s\", guestfs_last_error (g));\n";
371 pr " RETVAL = newSVpvn (%s, size);\n" n;
372 pr " free (%s);\n" n;
380 and generate_perl_struct_list_code typ cols name style n do_cleanups =
382 pr " struct guestfs_%s_list *%s;\n" typ n;
386 pr " %s = guestfs_%s " n name;
387 generate_c_call_args ~handle:"g" style;
390 pr " if (%s == NULL)\n" n;
391 pr " croak (\"%%s\", guestfs_last_error (g));\n";
392 pr " EXTEND (SP, %s->len);\n" n;
393 pr " for (i = 0; i < %s->len; ++i) {\n" n;
394 pr " hv = newHV ();\n";
398 pr " (void) hv_store (hv, \"%s\", %d, newSVpv (%s->val[i].%s, 0), 0);\n"
399 name (String.length name) n name
401 pr " (void) hv_store (hv, \"%s\", %d, newSVpv (%s->val[i].%s, 32), 0);\n"
402 name (String.length name) n name
404 pr " (void) hv_store (hv, \"%s\", %d, newSVpvn (%s->val[i].%s, %s->val[i].%s_len), 0);\n"
405 name (String.length name) n name n name
406 | name, (FBytes|FUInt64) ->
407 pr " (void) hv_store (hv, \"%s\", %d, my_newSVull (%s->val[i].%s), 0);\n"
408 name (String.length name) n name
410 pr " (void) hv_store (hv, \"%s\", %d, my_newSVll (%s->val[i].%s), 0);\n"
411 name (String.length name) n name
412 | name, (FInt32|FUInt32) ->
413 pr " (void) hv_store (hv, \"%s\", %d, newSVnv (%s->val[i].%s), 0);\n"
414 name (String.length name) n name
416 pr " (void) hv_store (hv, \"%s\", %d, newSVpv (&%s->val[i].%s, 1), 0);\n"
417 name (String.length name) n name
418 | name, FOptPercent ->
419 pr " (void) hv_store (hv, \"%s\", %d, newSVnv (%s->val[i].%s), 0);\n"
420 name (String.length name) n name
422 pr " PUSHs (sv_2mortal (newRV ((SV *) hv)));\n";
424 pr " guestfs_free_%s_list (%s);\n" typ n
426 and generate_perl_struct_code typ cols name style n do_cleanups =
428 pr " struct guestfs_%s *%s;\n" typ n;
430 pr " %s = guestfs_%s " n name;
431 generate_c_call_args ~handle:"g" style;
434 pr " if (%s == NULL)\n" n;
435 pr " croak (\"%%s\", guestfs_last_error (g));\n";
436 pr " EXTEND (SP, 2 * %d);\n" (List.length cols);
438 fun ((name, _) as col) ->
439 pr " PUSHs (sv_2mortal (newSVpv (\"%s\", 0)));\n" name;
443 pr " PUSHs (sv_2mortal (newSVpv (%s->%s, 0)));\n"
446 pr " PUSHs (sv_2mortal (newSVpvn (%s->%s, %s->%s_len)));\n"
449 pr " PUSHs (sv_2mortal (newSVpv (%s->%s, 32)));\n"
451 | name, (FBytes|FUInt64) ->
452 pr " PUSHs (sv_2mortal (my_newSVull (%s->%s)));\n"
455 pr " PUSHs (sv_2mortal (my_newSVll (%s->%s)));\n"
457 | name, (FInt32|FUInt32) ->
458 pr " PUSHs (sv_2mortal (newSVnv (%s->%s)));\n"
461 pr " PUSHs (sv_2mortal (newSVpv (&%s->%s, 1)));\n"
463 | name, FOptPercent ->
464 pr " PUSHs (sv_2mortal (newSVnv (%s->%s)));\n"
469 (* Generate Sys/Guestfs.pm. *)
470 and generate_perl_pm () =
471 generate_header HashStyle LGPLv2plus;
478 Sys::Guestfs - Perl bindings for libguestfs
484 my $h = Sys::Guestfs->new ();
485 $h->add_drive ('guest.img');
487 $h->mount ('/dev/sda1', '/');
488 $h->touch ('/hello');
493 The C<Sys::Guestfs> module provides a Perl XS binding to the
494 libguestfs API for examining and modifying virtual machine
497 Amongst the things this is good for: making batch configuration
498 changes to guests, getting disk used/free statistics (see also:
499 virt-df), migrating between virtualization systems (see also:
500 virt-p2v), performing partial backups, performing partial guest
501 clones, cloning guests and changing registry/UUID/hostname info, and
504 Libguestfs uses Linux kernel and qemu code, and can access any type of
505 guest filesystem that Linux and qemu can, including but not limited
506 to: ext2/3/4, btrfs, FAT and NTFS, LVM, many different disk partition
507 schemes, qcow, qcow2, vmdk.
509 Libguestfs provides ways to enumerate guest storage (eg. partitions,
510 LVs, what filesystem is in each LV, etc.). It can also run commands
511 in the context of the guest. Also you can access filesystems over
514 See also L<Sys::Guestfs::Lib(3)> for a set of useful library
515 functions for using libguestfs from Perl, including integration
520 All errors turn into calls to C<croak> (see L<Carp(3)>).
528 package Sys::Guestfs;
533 # This version number changes whenever a new function
534 # is added to the libguestfs API. It is not directly
535 # related to the libguestfs version number.
536 use vars qw($VERSION);
540 XSLoader::load ('Sys::Guestfs');
542 =item $h = Sys::Guestfs->new ();
544 Create a new guestfs handle.
550 my $class = ref ($proto) || $proto;
552 my $g = Sys::Guestfs::_create ();
553 my $self = { _g => $g };
560 Explicitly close the guestfs handle.
562 B<Note:> You should not usually call this function. The handle will
563 be closed implicitly when its reference count goes to zero (eg.
564 when it goes out of scope or the program ends). This call is
565 only required in some exceptional cases, such as where the program
566 may contain cached references to the handle 'somewhere' and you
567 really have to have the close happen right away. After calling
568 C<close> the program must not call any method (including C<close>)
569 on the handle (but the implicit call to C<DESTROY> that happens
570 when the final reference is cleaned up is OK).
572 =item $h->set_progress_callback (\\&cb);
574 Set the progress notification callback for this handle
575 to the Perl closure C<cb>.
577 C<cb> will be called whenever a long-running operation
578 generates a progress notification message. The 4 parameters
579 to the function are: C<proc_nr>, C<serial>, C<position>
582 You should carefully read the documentation for
583 L<guestfs(3)/guestfs_set_progress_callback> before using
586 =item $h->clear_progress_callback ();
588 This removes any progress callback function associated with
595 (* Actions. We only need to print documentation for these as
596 * they are pulled in from the XS code automatically.
599 fun (name, style, _, flags, _, _, longdesc) ->
600 if not (List.mem NotInDocs flags) then (
601 let longdesc = replace_str longdesc "C<guestfs_" "C<$h-E<gt>" in
603 generate_perl_prototype name style;
605 pr "%s\n\n" longdesc;
606 if List.mem ProtocolLimitWarning flags then
607 pr "%s\n\n" protocol_limit_warning;
608 if List.mem DangerWillRobinson flags then
609 pr "%s\n\n" danger_will_robinson;
610 match deprecation_notice flags with
612 | Some txt -> pr "%s\n\n" txt
614 ) all_functions_sorted;
626 From time to time we add new libguestfs APIs. Also some libguestfs
627 APIs won't be available in all builds of libguestfs (the Fedora
628 build is full-featured, but other builds may disable features).
629 How do you test whether the APIs that your Perl program needs are
630 available in the version of C<Sys::Guestfs> that you are using?
632 To test if a particular function is available in the C<Sys::Guestfs>
633 class, use the ordinary Perl UNIVERSAL method C<can(METHOD)>
634 (see L<perlobj(1)>). For example:
637 if (defined (Sys::Guestfs->can (\"set_verbose\"))) {
638 print \"\\$h->set_verbose is available\\n\";
641 To test if particular features are supported by the current
642 build, use the L</available> method like the example below. Note
643 that the appliance must be launched first.
645 $h->available ( [\"augeas\"] );
647 Since the L</available> method croaks if the feature is not supported,
648 you might also want to wrap this in an eval and return a boolean.
649 In fact this has already been done for you: use
650 L<Sys::Guestfs::Lib(3)/feature_available>.
652 For further discussion on this topic, refer to
653 L<guestfs(3)/AVAILABILITY>.
655 =head1 STORING DATA IN THE HANDLE
657 The handle returned from L</new> is a hash reference. The hash
658 normally contains a single element:
661 _g => [private data used by libguestfs]
664 Callers can add other elements to this hash to store data for their own
665 purposes. The data lasts for the lifetime of the handle.
667 Any fields whose names begin with an underscore are reserved
668 for private use by libguestfs. We may add more in future.
670 It is recommended that callers prefix the name of their field(s)
671 with some unique string, to avoid conflicts with other users.
675 Copyright (C) %s Red Hat Inc.
679 Please see the file COPYING.LIB for the full license.
685 L<http://libguestfs.org>,
686 L<Sys::Guestfs::Lib(3)>.
691 and generate_perl_prototype name style =
692 (match fst style with
700 | RBufferOut n -> pr "$%s = " n
702 | RHashtable n -> pr "%%%s = " n
704 | RStructList (n,_) -> pr "@%s = " n
707 let comma = ref false in
710 if !comma then pr ", ";
713 | Pathname n | Device n | Dev_or_Path n | String n
714 | OptString n | Bool n | Int n | Int64 n | FileIn n | FileOut n
715 | BufferIn n | Key n ->
717 | StringList n | DeviceList n ->