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)
261 snprintf (key, sizeof key, \"_perl_event_%%d\", event_handle);
262 cb = guestfs_get_private (g, key);
265 guestfs_set_private (g, key, NULL);
266 guestfs_delete_event_callback (g, event_handle);
275 errnum = guestfs_last_errno (g);
276 RETVAL = newSViv (errnum);
283 fun (name, (ret, args, optargs as style), _, _, _, _, _) ->
285 | RErr -> pr "void\n"
286 | RInt _ -> pr "SV *\n"
287 | RInt64 _ -> pr "SV *\n"
288 | RBool _ -> pr "SV *\n"
289 | RConstString _ -> pr "SV *\n"
290 | RConstOptString _ -> pr "SV *\n"
291 | RString _ -> pr "SV *\n"
292 | RBufferOut _ -> pr "SV *\n"
294 | RStruct _ | RStructList _
296 pr "void\n" (* all lists returned implictly on the stack *)
298 (* Call and arguments. *)
301 fun arg -> pr ", %s" (name_of_argt arg)
303 if optargs <> [] then
306 pr " guestfs_h *g;\n";
310 | Pathname n | Device n | Dev_or_Path n | String n
311 | FileIn n | FileOut n | Key n ->
315 pr " size_t %s_size = SvCUR (ST(%d));\n" n (i+1)
317 (* http://www.perlmonks.org/?node_id=554277
318 * Note that the implicit handle argument means we have
319 * to add 1 to the ST(x) operator.
321 pr " char *%s = SvOK(ST(%d)) ? SvPV_nolen(ST(%d)) : NULL;\n" n (i+1) (i+1)
322 | StringList n | DeviceList n -> pr " char **%s;\n" n
323 | Bool n -> pr " int %s;\n" n
324 | Int n -> pr " int %s;\n" n
325 | Int64 n -> pr " int64_t %s;\n" n
326 | Pointer (t, n) -> pr " %s %s;\n" t n
329 (* PREINIT section (local variable declarations). *)
340 pr " const char *r;\n";
341 | RConstOptString _ ->
342 pr " const char *r;\n";
345 | RStringList _ | RHashtable _ ->
347 pr " size_t i, n;\n";
348 | RStruct (_, typ) ->
349 pr " struct guestfs_%s *r;\n" typ;
350 | RStructList (_, typ) ->
351 pr " struct guestfs_%s_list *r;\n" typ;
356 pr " size_t size;\n";
359 if optargs <> [] then (
360 pr " struct guestfs_%s_argv optargs_s = { .bitmask = 0 };\n" name;
361 pr " struct guestfs_%s_argv *optargs = &optargs_s;\n" name;
362 pr " size_t items_i;\n";
365 (* CODE or PPCODE section. PPCODE is used where we are
366 * returning void, or where we push the return value on the stack
367 * ourselves. Using CODE means we will manipulate RETVAL.
379 | RConstOptString n ->
383 | RStringList n | RHashtable n ->
392 (* For optional arguments, convert these from the XSUB "items"
395 if optargs <> [] then (
396 let uc_name = String.uppercase name in
397 let skip = List.length args + 1 in
398 pr " if (((items - %d) & 1) != 0)\n" skip;
399 pr " croak (\"expecting an even number of extra parameters\");\n";
400 pr " for (items_i = %d; items_i < items; items_i += 2) {\n" skip;
401 pr " uint64_t this_mask;\n";
402 pr " const char *this_arg;\n";
404 pr " this_arg = SvPV_nolen (ST (items_i));\n";
408 let n = name_of_argt argt in
409 let uc_n = String.uppercase n in
410 pr "if (strcmp (this_arg, \"%s\") == 0) {\n" n;
411 pr " optargs_s.%s = " n;
415 | Int64 _ -> pr "SvIV (ST (items_i+1))"
416 | String _ -> pr "SvPV_nolen (ST (items_i+1))"
420 pr " this_mask = GUESTFS_%s_%s_BITMASK;\n" uc_name uc_n;
424 pr "croak (\"unknown optional argument '%%s'\", this_arg);\n";
425 pr " if (optargs_s.bitmask & this_mask)\n";
426 pr " croak (\"optional argument '%%s' given twice\",\n";
428 pr " optargs_s.bitmask |= this_mask;\n";
433 (* The call to the C function. *)
435 pr " r = guestfs_%s " name
437 pr " r = guestfs_%s_argv " name;
438 generate_c_call_args ~handle:"g" style;
441 (* Cleanup any arguments. *)
444 | Pathname _ | Device _ | Dev_or_Path _ | String _ | OptString _
445 | Bool _ | Int _ | Int64 _
446 | FileIn _ | FileOut _
447 | BufferIn _ | Key _ | Pointer _ -> ()
448 | StringList n | DeviceList n -> pr " free (%s);\n" n
451 (* Check return value for errors and return it if necessary. *)
454 pr " if (r == -1)\n";
455 pr " croak (\"%%s\", guestfs_last_error (g));\n";
458 pr " if (r == -1)\n";
459 pr " croak (\"%%s\", guestfs_last_error (g));\n";
460 pr " RETVAL = newSViv (r);\n";
464 pr " if (r == -1)\n";
465 pr " croak (\"%%s\", guestfs_last_error (g));\n";
466 pr " RETVAL = my_newSVll (r);\n";
470 pr " if (r == NULL)\n";
471 pr " croak (\"%%s\", guestfs_last_error (g));\n";
472 pr " RETVAL = newSVpv (r, 0);\n";
475 | RConstOptString n ->
476 pr " if (r == NULL)\n";
477 pr " RETVAL = &PL_sv_undef;\n";
479 pr " RETVAL = newSVpv (r, 0);\n";
483 pr " if (r == NULL)\n";
484 pr " croak (\"%%s\", guestfs_last_error (g));\n";
485 pr " RETVAL = newSVpv (r, 0);\n";
489 | RStringList n | RHashtable n ->
490 pr " if (r == NULL)\n";
491 pr " croak (\"%%s\", guestfs_last_error (g));\n";
492 pr " for (n = 0; r[n] != NULL; ++n) /**/;\n";
493 pr " EXTEND (SP, n);\n";
494 pr " for (i = 0; i < n; ++i) {\n";
495 pr " PUSHs (sv_2mortal (newSVpv (r[i], 0)));\n";
496 pr " free (r[i]);\n";
499 | RStruct (n, typ) ->
500 let cols = cols_of_struct typ in
501 generate_perl_struct_code typ cols name style n
502 | RStructList (n, typ) ->
503 let cols = cols_of_struct typ in
504 generate_perl_struct_list_code typ cols name style n
506 pr " if (r == NULL)\n";
507 pr " croak (\"%%s\", guestfs_last_error (g));\n";
508 pr " RETVAL = newSVpvn (r, size);\n";
517 and generate_perl_struct_list_code typ cols name style n =
518 pr " if (r == NULL)\n";
519 pr " croak (\"%%s\", guestfs_last_error (g));\n";
520 pr " EXTEND (SP, r->len);\n";
521 pr " for (i = 0; i < r->len; ++i) {\n";
522 pr " hv = newHV ();\n";
526 pr " (void) hv_store (hv, \"%s\", %d, newSVpv (r->val[i].%s, 0), 0);\n"
527 name (String.length name) name
529 pr " (void) hv_store (hv, \"%s\", %d, newSVpv (r->val[i].%s, 32), 0);\n"
530 name (String.length name) name
532 pr " (void) hv_store (hv, \"%s\", %d, newSVpvn (r->val[i].%s, r->val[i].%s_len), 0);\n"
533 name (String.length name) name name
534 | name, (FBytes|FUInt64) ->
535 pr " (void) hv_store (hv, \"%s\", %d, my_newSVull (r->val[i].%s), 0);\n"
536 name (String.length name) name
538 pr " (void) hv_store (hv, \"%s\", %d, my_newSVll (r->val[i].%s), 0);\n"
539 name (String.length name) name
540 | name, (FInt32|FUInt32) ->
541 pr " (void) hv_store (hv, \"%s\", %d, newSVnv (r->val[i].%s), 0);\n"
542 name (String.length name) name
544 pr " (void) hv_store (hv, \"%s\", %d, newSVpv (&r->val[i].%s, 1), 0);\n"
545 name (String.length name) name
546 | name, FOptPercent ->
547 pr " (void) hv_store (hv, \"%s\", %d, newSVnv (r->val[i].%s), 0);\n"
548 name (String.length name) name
550 pr " PUSHs (sv_2mortal (newRV ((SV *) hv)));\n";
552 pr " guestfs_free_%s_list (r);\n" typ
554 and generate_perl_struct_code typ cols name style n =
555 pr " if (r == NULL)\n";
556 pr " croak (\"%%s\", guestfs_last_error (g));\n";
557 pr " EXTEND (SP, 2 * %d);\n" (List.length cols);
559 fun ((name, _) as col) ->
560 pr " PUSHs (sv_2mortal (newSVpv (\"%s\", 0)));\n" name;
564 pr " PUSHs (sv_2mortal (newSVpv (r->%s, 0)));\n"
567 pr " PUSHs (sv_2mortal (newSVpvn (r->%s, r->%s_len)));\n"
570 pr " PUSHs (sv_2mortal (newSVpv (r->%s, 32)));\n"
572 | name, (FBytes|FUInt64) ->
573 pr " PUSHs (sv_2mortal (my_newSVull (r->%s)));\n"
576 pr " PUSHs (sv_2mortal (my_newSVll (r->%s)));\n"
578 | name, (FInt32|FUInt32) ->
579 pr " PUSHs (sv_2mortal (newSVnv (r->%s)));\n"
582 pr " PUSHs (sv_2mortal (newSVpv (&r->%s, 1)));\n"
584 | name, FOptPercent ->
585 pr " PUSHs (sv_2mortal (newSVnv (r->%s)));\n"
590 (* Generate Sys/Guestfs.pm. *)
591 and generate_perl_pm () =
592 generate_header HashStyle LGPLv2plus;
599 Sys::Guestfs - Perl bindings for libguestfs
605 my $h = Sys::Guestfs->new ();
606 $h->add_drive_opts ('guest.img', format => 'raw');
608 $h->mount_options ('', '/dev/sda1', '/');
609 $h->touch ('/hello');
614 The C<Sys::Guestfs> module provides a Perl XS binding to the
615 libguestfs API for examining and modifying virtual machine
618 Amongst the things this is good for: making batch configuration
619 changes to guests, getting disk used/free statistics (see also:
620 virt-df), migrating between virtualization systems (see also:
621 virt-p2v), performing partial backups, performing partial guest
622 clones, cloning guests and changing registry/UUID/hostname info, and
625 Libguestfs uses Linux kernel and qemu code, and can access any type of
626 guest filesystem that Linux and qemu can, including but not limited
627 to: ext2/3/4, btrfs, FAT and NTFS, LVM, many different disk partition
628 schemes, qcow, qcow2, vmdk.
630 Libguestfs provides ways to enumerate guest storage (eg. partitions,
631 LVs, what filesystem is in each LV, etc.). It can also run commands
632 in the context of the guest. Also you can access filesystems over
635 See also L<Sys::Guestfs::Lib(3)> for a set of useful library
636 functions for using libguestfs from Perl, including integration
641 All errors turn into calls to C<croak> (see L<Carp(3)>).
643 The error string from libguestfs is directly available from
644 C<$@>. Use the C<last_errno> method if you want to get the errno.
652 package Sys::Guestfs;
657 # This version number changes whenever a new function
658 # is added to the libguestfs API. It is not directly
659 # related to the libguestfs version number.
660 use vars qw($VERSION);
664 XSLoader::load ('Sys::Guestfs');
670 =item $h = Sys::Guestfs->new ();
672 Create a new guestfs handle.
678 my $class = ref ($proto) || $proto;
680 my $g = Sys::Guestfs::_create ();
681 my $self = { _g => $g };
688 Explicitly close the guestfs handle.
690 B<Note:> You should not usually call this function. The handle will
691 be closed implicitly when its reference count goes to zero (eg.
692 when it goes out of scope or the program ends). This call is
693 only required in some exceptional cases, such as where the program
694 may contain cached references to the handle 'somewhere' and you
695 really have to have the close happen right away. After calling
696 C<close> the program must not call any method (including C<close>)
697 on the handle (but the implicit call to C<DESTROY> that happens
698 when the final reference is cleaned up is OK).
703 fun (name, bitmask) ->
704 pr "=item $Sys::Guestfs::EVENT_%s\n" (String.uppercase name);
706 pr "See L<guestfs(3)/GUESTFS_EVENT_%s>.\n"
707 (String.uppercase name);
711 pr "our $EVENT_%s = 0x%x;\n" (String.uppercase name) bitmask;
716 =item $event_handle = $h->set_event_callback (\\&cb, $event_bitmask);
718 Register C<cb> as a callback function for all of the events
719 in C<$event_bitmask> (one or more C<$Sys::Guestfs::EVENT_*> flags
720 logically or'd together).
722 This function returns an event handle which
723 can be used to delete the callback using C<delete_event_callback>.
725 The callback function receives 4 parameters:
727 &cb ($event, $event_handle, $buf, $array)
733 The event which happened (equal to one of C<$Sys::Guestfs::EVENT_*>).
741 For some event types, this is a message buffer (ie. a string).
745 For some event types (notably progress events), this is
746 an array of integers.
750 You should carefully read the documentation for
751 L<guestfs(3)/guestfs_set_event_callback> before using
754 =item $h->delete_event_callback ($event_handle);
756 This removes the callback which was previously registered using
757 C<set_event_callback>.
759 =item $errnum = $h->last_errno ();
761 This returns the last error number (errno) that happened on the
764 If successful, an errno integer not equal to zero is returned.
766 If no error number is available, this returns 0.
767 See L<guestfs(3)/guestfs_last_errno> for more details of why
770 You can use the standard Perl module L<Errno(3)> to compare
771 the numeric error returned from this call with symbolic
774 $h->mkdir (\"/foo\");
775 if ($h->last_errno() == Errno::EEXIST()) {
776 # mkdir failed because the directory exists already.
783 (* Actions. We only need to print documentation for these as
784 * they are pulled in from the XS code automatically.
787 fun (name, style, _, flags, _, _, longdesc) ->
788 if not (List.mem NotInDocs flags) then (
789 let longdesc = replace_str longdesc "C<guestfs_" "C<$h-E<gt>" in
791 generate_perl_prototype name style;
793 pr "%s\n\n" longdesc;
794 if List.mem ProtocolLimitWarning flags then
795 pr "%s\n\n" protocol_limit_warning;
796 if List.mem DangerWillRobinson flags then
797 pr "%s\n\n" danger_will_robinson;
798 match deprecation_notice flags with
800 | Some txt -> pr "%s\n\n" txt
802 ) all_functions_sorted;
814 From time to time we add new libguestfs APIs. Also some libguestfs
815 APIs won't be available in all builds of libguestfs (the Fedora
816 build is full-featured, but other builds may disable features).
817 How do you test whether the APIs that your Perl program needs are
818 available in the version of C<Sys::Guestfs> that you are using?
820 To test if a particular function is available in the C<Sys::Guestfs>
821 class, use the ordinary Perl UNIVERSAL method C<can(METHOD)>
822 (see L<perlobj(1)>). For example:
825 if (defined (Sys::Guestfs->can (\"set_verbose\"))) {
826 print \"\\$h->set_verbose is available\\n\";
829 To test if particular features are supported by the current
830 build, use the L</available> method like the example below. Note
831 that the appliance must be launched first.
833 $h->available ( [\"augeas\"] );
835 Since the L</available> method croaks if the feature is not supported,
836 you might also want to wrap this in an eval and return a boolean.
837 In fact this has already been done for you: use
838 L<Sys::Guestfs::Lib(3)/feature_available>.
840 For further discussion on this topic, refer to
841 L<guestfs(3)/AVAILABILITY>.
843 =head1 STORING DATA IN THE HANDLE
845 The handle returned from L</new> is a hash reference. The hash
846 normally contains a single element:
849 _g => [private data used by libguestfs]
852 Callers can add other elements to this hash to store data for their own
853 purposes. The data lasts for the lifetime of the handle.
855 Any fields whose names begin with an underscore are reserved
856 for private use by libguestfs. We may add more in future.
858 It is recommended that callers prefix the name of their field(s)
859 with some unique string, to avoid conflicts with other users.
863 Copyright (C) %s Red Hat Inc.
867 Please see the file COPYING.LIB for the full license.
873 L<http://libguestfs.org>,
874 L<Sys::Guestfs::Lib(3)>.
879 and generate_perl_prototype name (ret, args, optargs) =
888 | RBufferOut n -> pr "$%s = " n
890 | RHashtable n -> pr "%%%s = " n
892 | RStructList (n,_) -> pr "@%s = " n
895 let comma = ref false in
898 if !comma then pr ", ";
901 | Pathname n | Device n | Dev_or_Path n | String n
902 | OptString n | Bool n | Int n | Int64 n | FileIn n | FileOut n
903 | BufferIn n | Key n | Pointer (_, n) ->
905 | StringList n | DeviceList n ->
910 if !comma then pr " [, " else pr "[";
912 let n = name_of_argt arg in