path: root/generator/generator_perl.ml

(* libguestfs
 * Copyright (C) 2009-2010 Red Hat Inc.
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 *)

(* Please read generator/README first. *)

open Printf

open Generator_types
open Generator_utils
open Generator_pr
open Generator_docstrings
open Generator_optgroups
open Generator_actions
open Generator_structs
open Generator_c

(* Generate Perl xs code, a sort of crazy variation of C with macros. *)
let rec generate_perl_xs () =
  generate_header CStyle LGPLv2plus;

  pr "\
#include \"EXTERN.h\"
#include \"perl.h\"
#include \"XSUB.h\"

#include <guestfs.h>

#ifndef PRId64
#define PRId64 \"lld\"
#endif

static SV *
my_newSVll(long long val) {
#ifdef USE_64_BIT_ALL
  return newSViv(val);
#else
  char buf[100];
  int len;
  len = snprintf(buf, 100, \"%%\" PRId64, val);
  return newSVpv(buf, len);
#endif
}

#ifndef PRIu64
#define PRIu64 \"llu\"
#endif

static SV *
my_newSVull(unsigned long long val) {
#ifdef USE_64_BIT_ALL
  return newSVuv(val);
#else
  char buf[100];
  int len;
  len = snprintf(buf, 100, \"%%\" PRIu64, val);
  return newSVpv(buf, len);
#endif
}

/* http://www.perlmonks.org/?node_id=680842 */
static char **
XS_unpack_charPtrPtr (SV *arg) {
  char **ret;
  AV *av;
  I32 i;

  if (!arg || !SvOK (arg) || !SvROK (arg) || SvTYPE (SvRV (arg)) != SVt_PVAV)
    croak (\"array reference expected\");

  av = (AV *)SvRV (arg);
  ret = malloc ((av_len (av) + 1 + 1) * sizeof (char *));
  if (!ret)
    croak (\"malloc failed\");

  for (i = 0; i <= av_len (av); i++) {
    SV **elem = av_fetch (av, i, 0);

    if (!elem || !*elem)
      croak (\"missing element in list\");

    ret[i] = SvPV_nolen (*elem);
  }

  ret[i] = NULL;

  return ret;
}

#define PROGRESS_KEY \"_perl_progress_cb\"

static void
_clear_progress_callback (guestfs_h *g)
{
  guestfs_set_progress_callback (g, NULL, NULL);
  SV *cb = guestfs_get_private (g, PROGRESS_KEY);
  if (cb) {
    guestfs_set_private (g, PROGRESS_KEY, NULL);
    SvREFCNT_dec (cb);
  }
}

/* http://www.perlmonks.org/?node=338857 */
static void
_progress_callback (guestfs_h *g, void *cb,
                    int proc_nr, int serial, uint64_t position, uint64_t total)
{
  dSP;
  ENTER;
  SAVETMPS;
  PUSHMARK (SP);
  XPUSHs (sv_2mortal (newSViv (proc_nr)));
  XPUSHs (sv_2mortal (newSViv (serial)));
  XPUSHs (sv_2mortal (my_newSVull (position)));
  XPUSHs (sv_2mortal (my_newSVull (total)));
  PUTBACK;
  call_sv ((SV *) cb, G_VOID | G_DISCARD | G_EVAL);
  FREETMPS;
  LEAVE;
}

static void
_close_handle (guestfs_h *g)
{
  assert (g != NULL);
  _clear_progress_callback (g);
  guestfs_close (g);
}

MODULE = Sys::Guestfs  PACKAGE = Sys::Guestfs

PROTOTYPES: ENABLE

guestfs_h *
_create ()
   CODE:
      RETVAL = guestfs_create ();
      if (!RETVAL)
        croak (\"could not create guestfs handle\");
      guestfs_set_error_handler (RETVAL, NULL, NULL);
 OUTPUT:
      RETVAL

void
DESTROY (sv)
      SV *sv;
 PPCODE:
      /* For the 'g' argument above we do the conversion explicitly and
       * don't rely on the typemap, because if the handle has been
       * explicitly closed we don't want the typemap conversion to
       * display an error.
       */
      HV *hv = (HV *) SvRV (sv);
      SV **svp = hv_fetch (hv, \"_g\", 2, 0);
      if (svp != NULL) {
        guestfs_h *g = (guestfs_h *) SvIV (*svp);
        _close_handle (g);
      }

void
close (g)
      guestfs_h *g;
 PPCODE:
      _close_handle (g);
      /* Avoid double-free in DESTROY method. */
      HV *hv = (HV *) SvRV (ST(0));
      (void) hv_delete (hv, \"_g\", 2, G_DISCARD);

void
set_progress_callback (g, cb)
      guestfs_h *g;
      SV *cb;
 PPCODE:
      _clear_progress_callback (g);
      SvREFCNT_inc (cb);
      guestfs_set_private (g, PROGRESS_KEY, cb);
      guestfs_set_progress_callback (g, _progress_callback, cb);

void
clear_progress_callback (g)
      guestfs_h *g;
 PPCODE:
      _clear_progress_callback (g);

";

  List.iter (
    fun (name, style, _, _, _, _, _) ->
      (match fst style with
       | RErr -> pr "void\n"
       | RInt _ -> pr "SV *\n"
       | RInt64 _ -> pr "SV *\n"
       | RBool _ -> pr "SV *\n"
       | RConstString _ -> pr "SV *\n"
       | RConstOptString _ -> pr "SV *\n"
       | RString _ -> pr "SV *\n"
       | RBufferOut _ -> pr "SV *\n"
       | RStringList _
       | RStruct _ | RStructList _
       | RHashtable _ ->
           pr "void\n" (* all lists returned implictly on the stack *)
      );
      (* Call and arguments. *)
      pr "%s (g" name;
      List.iter (
        fun arg -> pr ", %s" (name_of_argt arg)
      ) (snd style);
      pr ")\n";
      pr "      guestfs_h *g;\n";
      iteri (
        fun i ->
          function
          | Pathname n | Device n | Dev_or_Path n | String n
          | FileIn n | FileOut n | Key n ->
              pr "      char *%s;\n" n
          | BufferIn n ->
              pr "      char *%s;\n" n;
              pr "      size_t %s_size = SvCUR (ST(%d));\n" n (i+1)
          | OptString n ->
              (* http://www.perlmonks.org/?node_id=554277
               * Note that the implicit handle argument means we have
               * to add 1 to the ST(x) operator.
               *)
              pr "      char *%s = SvOK(ST(%d)) ? SvPV_nolen(ST(%d)) : NULL;\n" n (i+1) (i+1)
          | StringList n | DeviceList n -> pr "      char **%s;\n" n
          | Bool n -> pr "      int %s;\n" n
          | Int n -> pr "      int %s;\n" n
          | Int64 n -> pr "      int64_t %s;\n" n
      ) (snd style);

      (* PREINIT section (local variable declarations). *)
      pr "PREINIT:\n";
      (match fst style with
       | RErr ->
           pr "      int r;\n";
       | RInt _
       | RBool _ ->
           pr "      int r;\n";
       | RInt64 _ ->
           pr "      int64_t r;\n";
       | RConstString _ ->
           pr "      const char *r;\n";
       | RConstOptString _ ->
           pr "      const char *r;\n";
       | RString _ ->
           pr "      char *r;\n";
       | RStringList _ | RHashtable _ ->
           pr "      char **r;\n";
           pr "      size_t i, n;\n";
       | RStruct (_, typ) ->
           pr "      struct guestfs_%s *r;\n" typ;
       | RStructList (_, typ) ->
           pr "      struct guestfs_%s_list *r;\n" typ;
           pr "      size_t i;\n";
           pr "      HV *hv;\n";
       | RBufferOut _ ->
           pr "      char *r;\n";
           pr "      size_t size;\n";
      );

      (* CODE or PPCODE section.  PPCODE is used where we are
       * returning void, or where we push the return value on the stack
       * ourselves.  Using CODE means we will manipulate RETVAL.
       *)
      (match fst style with
       | RErr ->
           pr " PPCODE:\n";
       | RInt n
       | RBool n ->
           pr "   CODE:\n";
       | RInt64 n ->
           pr "   CODE:\n";
       | RConstString n ->
           pr "   CODE:\n";
       | RConstOptString n ->
           pr "   CODE:\n";
       | RString n ->
           pr "   CODE:\n";
       | RStringList n | RHashtable n ->
           pr " PPCODE:\n";
       | RBufferOut n ->
           pr "   CODE:\n";
       | RStruct _
       | RStructList _ ->
           pr " PPCODE:\n";
      );

      (* The call to the C function. *)
      pr "      r = guestfs_%s " name;
      generate_c_call_args ~handle:"g" style;
      pr ";\n";

      (* Cleanup any arguments. *)
      List.iter (
        function
        | Pathname _ | Device _ | Dev_or_Path _ | String _ | OptString _
        | Bool _ | Int _ | Int64 _
        | FileIn _ | FileOut _
        | BufferIn _ | Key _ -> ()
        | StringList n | DeviceList n -> pr "      free (%s);\n" n
      ) (snd style);

      (* Check return value for errors and return it if necessary. *)
      (match fst style with
       | RErr ->
           pr "      if (r == -1)\n";
           pr "        croak (\"%%s\", guestfs_last_error (g));\n";
       | RInt n
       | RBool n ->
           pr "      if (r == -1)\n";
           pr "        croak (\"%%s\", guestfs_last_error (g));\n";
           pr "      RETVAL = newSViv (r);\n";
           pr " OUTPUT:\n";
           pr "      RETVAL\n"
       | RInt64 n ->
           pr "      if (r == -1)\n";
           pr "        croak (\"%%s\", guestfs_last_error (g));\n";
           pr "      RETVAL = my_newSVll (r);\n";
           pr " OUTPUT:\n";
           pr "      RETVAL\n"
       | RConstString n ->
           pr "      if (r == NULL)\n";
           pr "        croak (\"%%s\", guestfs_last_error (g));\n";
           pr "      RETVAL = newSVpv (r, 0);\n";
           pr " OUTPUT:\n";
           pr "      RETVAL\n"
       | RConstOptString n ->
           pr "      if (r == NULL)\n";
           pr "        RETVAL = &PL_sv_undef;\n";
           pr "      else\n";
           pr "        RETVAL = newSVpv (r, 0);\n";
           pr " OUTPUT:\n";
           pr "      RETVAL\n"
       | RString n ->
           pr "      if (r == NULL)\n";
           pr "        croak (\"%%s\", guestfs_last_error (g));\n";
           pr "      RETVAL = newSVpv (r, 0);\n";
           pr "      free (r);\n";
           pr " OUTPUT:\n";
           pr "      RETVAL\n"
       | RStringList n | RHashtable n ->
           pr "      if (r == NULL)\n";
           pr "        croak (\"%%s\", guestfs_last_error (g));\n";
           pr "      for (n = 0; r[n] != NULL; ++n) /**/;\n";
           pr "      EXTEND (SP, n);\n";
           pr "      for (i = 0; i < n; ++i) {\n";
           pr "        PUSHs (sv_2mortal (newSVpv (r[i], 0)));\n";
           pr "        free (r[i]);\n";
           pr "      }\n";
           pr "      free (r);\n";
       | RStruct (n, typ) ->
           let cols = cols_of_struct typ in
           generate_perl_struct_code typ cols name style n
       | RStructList (n, typ) ->
           let cols = cols_of_struct typ in
           generate_perl_struct_list_code typ cols name style n
       | RBufferOut n ->
           pr "      if (r == NULL)\n";
           pr "        croak (\"%%s\", guestfs_last_error (g));\n";
           pr "      RETVAL = newSVpvn (r, size);\n";
           pr "      free (r);\n";
           pr " OUTPUT:\n";
           pr "      RETVAL\n"
      );

      pr "\n"
  ) all_functions

and generate_perl_struct_list_code typ cols name style n =
  pr "      if (r == NULL)\n";
  pr "        croak (\"%%s\", guestfs_last_error (g));\n";
  pr "      EXTEND (SP, r->len);\n";
  pr "      for (i = 0; i < r->len; ++i) {\n";
  pr "        hv = newHV ();\n";
  List.iter (
    function
    | name, FString ->
        pr "        (void) hv_store (hv, \"%s\", %d, newSVpv (r->val[i].%s, 0), 0);\n"
          name (String.length name) name
    | name, FUUID ->
        pr "        (void) hv_store (hv, \"%s\", %d, newSVpv (r->val[i].%s, 32), 0);\n"
          name (String.length name) name
    | name, FBuffer ->
        pr "        (void) hv_store (hv, \"%s\", %d, newSVpvn (r->val[i].%s, r->val[i].%s_len), 0);\n"
          name (String.length name) name name
    | name, (FBytes|FUInt64) ->
        pr "        (void) hv_store (hv, \"%s\", %d, my_newSVull (r->val[i].%s), 0);\n"
          name (String.length name) name
    | name, FInt64 ->
        pr "        (void) hv_store (hv, \"%s\", %d, my_newSVll (r->val[i].%s), 0);\n"
          name (String.length name) name
    | name, (FInt32|FUInt32) ->
        pr "        (void) hv_store (hv, \"%s\", %d, newSVnv (r->val[i].%s), 0);\n"
          name (String.length name) name
    | name, FChar ->
        pr "        (void) hv_store (hv, \"%s\", %d, newSVpv (&r->val[i].%s, 1), 0);\n"
          name (String.length name) name
    | name, FOptPercent ->
        pr "        (void) hv_store (hv, \"%s\", %d, newSVnv (r->val[i].%s), 0);\n"
          name (String.length name) name
  ) cols;
  pr "        PUSHs (sv_2mortal (newRV ((SV *) hv)));\n";
  pr "      }\n";
  pr "      guestfs_free_%s_list (r);\n" typ

and generate_perl_struct_code typ cols name style n =
  pr "      if (r == NULL)\n";
  pr "        croak (\"%%s\", guestfs_last_error (g));\n";
  pr "      EXTEND (SP, 2 * %d);\n" (List.length cols);
  List.iter (
    fun ((name, _) as col) ->
      pr "      PUSHs (sv_2mortal (newSVpv (\"%s\", 0)));\n" name;

      match col with
      | name, FString ->
          pr "      PUSHs (sv_2mortal (newSVpv (r->%s, 0)));\n"
            name
      | name, FBuffer ->
          pr "      PUSHs (sv_2mortal (newSVpvn (r->%s, r->%s_len)));\n"
            name name
      | name, FUUID ->
          pr "      PUSHs (sv_2mortal (newSVpv (r->%s, 32)));\n"
            name
      | name, (FBytes|FUInt64) ->
          pr "      PUSHs (sv_2mortal (my_newSVull (r->%s)));\n"
            name
      | name, FInt64 ->
          pr "      PUSHs (sv_2mortal (my_newSVll (r->%s)));\n"
            name
      | name, (FInt32|FUInt32) ->
          pr "      PUSHs (sv_2mortal (newSVnv (r->%s)));\n"
            name
      | name, FChar ->
          pr "      PUSHs (sv_2mortal (newSVpv (&r->%s, 1)));\n"
            name
      | name, FOptPercent ->
          pr "      PUSHs (sv_2mortal (newSVnv (r->%s)));\n"
            name
  ) cols;
  pr "      free (r);\n"

(* Generate Sys/Guestfs.pm. *)
and generate_perl_pm () =
  generate_header HashStyle LGPLv2plus;

  pr "\
=pod

=head1 NAME

Sys::Guestfs - Perl bindings for libguestfs

=head1 SYNOPSIS

 use Sys::Guestfs;

 my $h = Sys::Guestfs->new ();
 $h->add_drive ('guest.img');
 $h->launch ();
 $h->mount ('/dev/sda1', '/');
 $h->touch ('/hello');
 $h->sync ();

=head1 DESCRIPTION

The C<Sys::Guestfs> module provides a Perl XS binding to the
libguestfs API for examining and modifying virtual machine
disk images.

Amongst the things this is good for: making batch configuration
changes to guests, getting disk used/free statistics (see also:
virt-df), migrating between virtualization systems (see also:
virt-p2v), performing partial backups, performing partial guest
clones, cloning guests and changing registry/UUID/hostname info, and
much else besides.

Libguestfs uses Linux kernel and qemu code, and can access any type of
guest filesystem that Linux and qemu can, including but not limited
to: ext2/3/4, btrfs, FAT and NTFS, LVM, many different disk partition
schemes, qcow, qcow2, vmdk.

Libguestfs provides ways to enumerate guest storage (eg. partitions,
LVs, what filesystem is in each LV, etc.).  It can also run commands
in the context of the guest.  Also you can access filesystems over
FUSE.

See also L<Sys::Guestfs::Lib(3)> for a set of useful library
functions for using libguestfs from Perl, including integration
with libvirt.

=head1 ERRORS

All errors turn into calls to C<croak> (see L<Carp(3)>).

=head1 METHODS

=over 4

=cut

package Sys::Guestfs;

use strict;
use warnings;

# This version number changes whenever a new function
# is added to the libguestfs API.  It is not directly
# related to the libguestfs version number.
use vars qw($VERSION);
$VERSION = '0.%d';

require XSLoader;
XSLoader::load ('Sys::Guestfs');

=item $h = Sys::Guestfs->new ();

Create a new guestfs handle.

=cut

sub new {
  my $proto = shift;
  my $class = ref ($proto) || $proto;

  my $g = Sys::Guestfs::_create ();
  my $self = { _g => $g };
  bless $self, $class;
  return $self;
}

=item $h->close ();

Explicitly close the guestfs handle.

B<Note:> You should not usually call this function.  The handle will
be closed implicitly when its reference count goes to zero (eg.
when it goes out of scope or the program ends).  This call is
only required in some exceptional cases, such as where the program
may contain cached references to the handle 'somewhere' and you
really have to have the close happen right away.  After calling
C<close> the program must not call any method (including C<close>)
on the handle (but the implicit call to C<DESTROY> that happens
when the final reference is cleaned up is OK).

=item $h->set_progress_callback (\\&cb);

Set the progress notification callback for this handle
to the Perl closure C<cb>.

C<cb> will be called whenever a long-running operation
generates a progress notification message.  The 4 parameters
to the function are: C<proc_nr>, C<serial>, C<position>
and C<total>.

You should carefully read the documentation for
L<guestfs(3)/guestfs_set_progress_callback> before using
this function.

=item $h->clear_progress_callback ();

This removes any progress callback function associated with
the handle.

=cut

" max_proc_nr;

  (* Actions.  We only need to print documentation for these as
   * they are pulled in from the XS code automatically.
   *)
  List.iter (
    fun (name, style, _, flags, _, _, longdesc) ->
      if not (List.mem NotInDocs flags) then (
        let longdesc = replace_str longdesc "C<guestfs_" "C<$h-E<gt>" in
        pr "=item ";
        generate_perl_prototype name style;
        pr "\n\n";
        pr "%s\n\n" longdesc;
        if List.mem ProtocolLimitWarning flags then
          pr "%s\n\n" protocol_limit_warning;
        if List.mem DangerWillRobinson flags then
          pr "%s\n\n" danger_will_robinson;
        match deprecation_notice flags with
        | None -> ()
        | Some txt -> pr "%s\n\n" txt
      )
  ) all_functions_sorted;

  (* End of file. *)
  pr "\
=cut

1;

=back

=head1 AVAILABILITY

From time to time we add new libguestfs APIs.  Also some libguestfs
APIs won't be available in all builds of libguestfs (the Fedora
build is full-featured, but other builds may disable features).
How do you test whether the APIs that your Perl program needs are
available in the version of C<Sys::Guestfs> that you are using?

To test if a particular function is available in the C<Sys::Guestfs>
class, use the ordinary Perl UNIVERSAL method C<can(METHOD)>
(see L<perlobj(1)>).  For example:

 use Sys::Guestfs;
 if (defined (Sys::Guestfs->can (\"set_verbose\"))) {
   print \"\\$h->set_verbose is available\\n\";
 }

To test if particular features are supported by the current
build, use the L</available> method like the example below.  Note
that the appliance must be launched first.

 $h->available ( [\"augeas\"] );

Since the L</available> method croaks if the feature is not supported,
you might also want to wrap this in an eval and return a boolean.
In fact this has already been done for you: use
L<Sys::Guestfs::Lib(3)/feature_available>.

For further discussion on this topic, refer to
L<guestfs(3)/AVAILABILITY>.

=head1 STORING DATA IN THE HANDLE

The handle returned from L</new> is a hash reference.  The hash
normally contains a single element:

 {
   _g => [private data used by libguestfs]
 }

Callers can add other elements to this hash to store data for their own
purposes.  The data lasts for the lifetime of the handle.

Any fields whose names begin with an underscore are reserved
for private use by libguestfs.  We may add more in future.

It is recommended that callers prefix the name of their field(s)
with some unique string, to avoid conflicts with other users.

=head1 COPYRIGHT

Copyright (C) %s Red Hat Inc.

=head1 LICENSE

Please see the file COPYING.LIB for the full license.

=head1 SEE ALSO

L<guestfs(3)>,
L<guestfish(1)>,
L<http://libguestfs.org>,
L<Sys::Guestfs::Lib(3)>.

=cut
" copyright_years

and generate_perl_prototype name style =
  (match fst style with
   | RErr -> ()
   | RBool n
   | RInt n
   | RInt64 n
   | RConstString n
   | RConstOptString n
   | RString n
   | RBufferOut n -> pr "$%s = " n
   | RStruct (n,_)
   | RHashtable n -> pr "%%%s = " n
   | RStringList n
   | RStructList (n,_) -> pr "@%s = " n
  );
  pr "$h->%s (" name;
  let comma = ref false in
  List.iter (
    fun arg ->
      if !comma then pr ", ";
      comma := true;
      match arg with
      | Pathname n | Device n | Dev_or_Path n | String n
      | OptString n | Bool n | Int n | Int64 n | FileIn n | FileOut n
      | BufferIn n | Key n ->
          pr "$%s" n
      | StringList n | DeviceList n ->
          pr "\\@%s" n
  ) (snd style);
  pr ");"